Added revision type; better structure for URIs and Addresses

src/Data/SMTP/Parser/Address.hs

@@ -16,14 +16,15 @@ import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Base64 as B64
 import Control.Applicative ((<|>))
+import qualified Text.StringConvert as SC
 
 parseAddress :: Parser Address
-parseAddress = ((\x -> Address (Just x) (URI.account x) Nothing) <$> URI.parseURI) <|>
-               ((\x -> Address Nothing x Nothing) <$> parseAccount)
+parseAddress = ((\x -> URIAdd x Nothing) <$> URI.parseURI) <|>
+               ((\x -> AccountAdd x Nothing) <$> parseAccount)
 
 renderMetadataAddress :: Address -> ByteString
-renderMetadataAddress add@(Address _ _ s) =
-  BS.intercalate "; " $ asToURI add : case s of
+renderMetadataAddress add =
+  BS.intercalate "; " $ (SC.s . asToURI $ add) : case seal add of
     Nothing -> []
     Just (Seal.Seal cp code nonce) -> [
       BS.append "CP=" $ B64.encode cp
@@ -42,7 +43,7 @@ parseMetadataAddress = do
   let r = do
         cp' <- cp
         code' <- code
-        return a{seal=Just $ Seal.Seal cp' code' nonce}
+        return . setSeal a . Just $ Seal.Seal cp' code' nonce
   case r of
     Nothing -> return a
     Just r' -> return r'

src/Data/SMTP/Parser/Resource.hs

@@ -37,9 +37,7 @@ parseHeaders = snd <$> parseHeadersAndReturn
 
 parseHeadersAndReturn :: Parser ([ByteString], [Header])
 parseHeadersAndReturn = (
-  do
-    blankLine
-    return ([], [])
+  blankLine >> return ([], [])
   ) <|> (
   do
     (dth, h) <- headerAndReturn

src/Data/SMTP/Parser/URI.hs

@@ -4,31 +4,95 @@ module Data.SMTP.Parser.URI (parseURI) where
 
 import Data.Attoparsec.ByteString.Char8
 import qualified Data.Attoparsec.ByteString.Char8 as A
+import qualified Data.Attoparsec.ByteString as AA
+import Data.Word8 (Word8)
+import qualified Data.ByteString as BS
 import Data.SMTP.Types.URI
 import Data.SMTP.Account
-import Control.Applicative ((<|>))
 import qualified Data.Char as C
+import Control.Applicative ((<|>))
 import Text.StringConvert
 
 parseURI :: Parser URI
 parseURI = do
   stringCI "fCMTP://"
   a <- parseAccount
-  p <- parsePath
-  (do
-      stringCI "#"
-      rev <- parseRevision
-      return $ URI a p (Just rev)
-    ) <|> return (URI a p Nothing)
+  u <- A.choice [
+    do
+      string "/"
+      p <- parsePath
+      return $ URI a p Nothing,
+    return $ URI a (Path []) Nothing
+    ]
+  r <- parseRevision
+  return u{revision=r}
 
 parsePath :: Parser Path
-parsePath = (Path . s) <$> A.takeWhile isPathChar
+parsePath = Path <$>
+  A.many' parseSegment
+
+parseSegment :: Parser String
+parseSegment = do
+  pp <- A.many' $ A.choice [
+    escapeURI <$> A.takeWhile isPathChar,
+    do
+      A.string "%"
+      c0 <- AA.anyWord8
+      c1 <- AA.anyWord8
+      let n' = do
+            n0 <- fromHex c0
+            n1 <- fromHex c1
+            return $ 16*n0 + n1
+      case n' of
+        Nothing -> fail "Invalid URI character escaping"
+        Just n -> return . BS.pack $ if isUnquoted n
+                            then [n]
+                            else [asWord8 '%', c0, c1]
+    ]
+  string "/" <|> return "" -- Segments end on a slash, colon, or end of input
+  return . s . BS.concat $ pp
   where
     isPathChar :: Char -> Bool
-    isPathChar c = C.isAlphaNum c || elem c ("_-=[]{}().:%/" :: String)
+    isPathChar c = (C.isAscii c && C.isAlphaNum c) || elem c ("_-=[]{}()." :: String)
+    escapeURI = BS.pack . normalizePath . BS.unpack
+    normalizePath :: [Word8] -> [Word8]
+    normalizePath [] = []
+    normalizePath (p:pp)
+      | isReserved p = p : normalizePath pp
+      | isUnquoted p = p : normalizePath pp
+      | otherwise = let
+        c0 = asWord8 '%'
+        c1 = div p 16
+        c2 = mod p 16
+        in c0:c1:c2: normalizePath pp
+    fromHex p
+      | p >= asWord8 '0' && p <= asWord8 '9' = Just $ p - asWord8 '0'
+      | p >= asWord8 'a' && p <= asWord8 'z' = Just $ 10 + p - asWord8 'a'
+      | p >= asWord8 'A' && p <= asWord8 'Z' = Just $ 10 + p - asWord8 'A'
+      | otherwise = Nothing
+    isReserved :: Word8 -> Bool
+    isReserved x = elem x $ fmap asWord8
+                   [':', '/', '?', '#', '[', ']', '@', '!', '$', '&',
+                    '\'', '(', ')', '*', '+', ',', ';', '=']
+    isUnquoted :: Word8 -> Bool
+    isUnquoted x =
+      inRange x '=' '9' ||
+      inRange x 'A' 'Z' ||
+      (x == asWord8 '_') ||
+      inRange x 'a' 'z'
+    inRange x b e = x >= asWord8 b && x <= asWord8 e
+    asWord8 :: Char -> Word8
+    asWord8 = fromIntegral . C.ord
+    
 
-parseRevision :: Parser Revision
-parseRevision = (Revision . s) <$> A.takeWhile isRevisionChar
+parseRevision :: Parser (Maybe Revision)
+parseRevision =
+  A.choice [
+    do
+      string ":"
+      Just . Revision . s <$> A.takeWhile isRevisionChar,
+    return Nothing
+    ]
   where
     isRevisionChar :: Char -> Bool
-    isRevisionChar c = C.isAlphaNum c || elem c ("+-/_=." :: String)
+    isRevisionChar c = C.isAlphaNum c || elem c ("+-_=." :: String)

src/Data/SMTP/Resource.hs

@@ -1,5 +1,9 @@
 -- | Resources are the messages exchanged at the FCMTP infrastructure.
 
-module Data.SMTP.Resource (module Data.SMTP.Types.Resource) where
+module Data.SMTP.Resource (
+  module Data.SMTP.Types.Resource,
+  takeHeaders
+  ) where
 
 import Data.SMTP.Types.Resource
+import Data.SMTP.Parser.Resource

src/Data/SMTP/ResponseCode.hs

@@ -6,13 +6,30 @@ import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import Data.SMTP.Response
 
-data ResponseCode = Unrecognized | InvalidHost | InvalidArguments {argumentError :: ByteString} |
-                    InvalidSetOfArguments |
-                    InvalidEmail {invalidEmailAddress :: ByteString} | Timeout | NotImplemented |
-                    BadSequence | MailboxUnavailable {unavailableMailbox :: ByteString} | TLSNotAvailable |
-                    TLSNoSecurity | AuthTypeNotSupported | RequiresTls | BadAuthCredentials |
-                    AuthRequired | Congestion | BadConnection | NoConversion | TempUndefined |
-                    InvalidCP deriving (Eq, Ord, Read, Show)
+import Text.StringConvert
+
+data ResponseCode =
+  Unrecognized -- ^ Generic unrecognized command error
+  | InvalidHost -- ^ Invalid host at HELO or EHLO argument
+  | InvalidArguments ByteString -- ^ Generic invalid argument error
+  | InvalidSetOfArguments -- ^ Invalid argument sequence error
+  | InvalidEmail ByteString -- ^ @InvalidEmail m@ means @m@ is not in the correct format for an email address
+  | Timeout -- ^ Timeout at server or client
+  | NotImplemented -- ^ Command not implemented
+  | BadSequence -- ^ Bad sequences of commands
+  | MailboxUnavailable String -- ^ @MailbxUnavailable m@ means m has the correct format, but does not exist
+  | TLSNotAvailable -- ^ Server can not do TLS
+  | TLSNoSecurity -- ^ The agreed TLS parameters are not good enough
+  | AuthTypeNotSupported -- ^ Server does not support the given authentication method
+  | RequiresTls -- ^ This feature is only avilable in TLS connections
+  | BadAuthCredentials -- ^ Bad authentication credentials
+  | AuthRequired -- ^ This feature is only available for authenticated users
+  | Congestion -- ^ Mailsystem congestion error
+  | BadConnection -- ^ There were connection problems
+  | NoConversion -- ^ This conversion of email encoding is not supported
+  | TempUndefined -- ^ Generic undefined temporary error
+  | InvalidCP -- ^ Capability has an invalid format
+    deriving (Eq, Ord, Read, Show)
 
 errorMessage :: ResponseCode -> ByteString
 errorMessage = renderResponse . toResponse
@@ -30,7 +47,7 @@ toResponse (InvalidEmail a) = Response PermanentError [] 501 (Just (5, 1, 3)) $
 toResponse Timeout = Response TransientError [] 421 (Just (4, 2, 1)) "Connection timeout, closing transmission channel."
 toResponse NotImplemented = Response PermanentError [] 502 (Just (5, 5, 1)) "Command not implemented"
 toResponse BadSequence = Response PermanentError [] 503 (Just (5, 5, 1)) "Bad sequence of commands"
-toResponse (MailboxUnavailable a) = Response PermanentError [] 551 (Just (5, 5, 1)) $ BS.concat ["Nope, don't know ", a, "."]
+toResponse (MailboxUnavailable a) = Response PermanentError [] 551 (Just (5, 5, 1)) $ BS.concat ["Nope, don't know ", s a, "."]
 toResponse TLSNotAvailable = Response TransientError [] 454 (Just (4, 7, 0)) "TLS not available due to temporary reason."
 toResponse TLSNoSecurity = Response PermanentError [] 554 (Just (5, 7, 0)) "Get a non-broken TLS lib."
 toResponse AuthTypeNotSupported = Response PermanentError [] 504 (Just (5, 5, 4)) "Autentication mechanism is not supported."

src/Data/SMTP/Revision.hs

@@ -0,0 +1,6 @@
+module Data.SMTP.Revision (
+  module Data.SMTP.Types.Revision
+  ) where
+
+import Data.SMTP.Types.Revision
+

src/Data/SMTP/Types/Address.hs

@@ -6,18 +6,30 @@ import qualified Data.SMTP.Account as Ac
 import qualified Data.SMTP.URI as URI
 import qualified Data.SMTP.Seal as Seal
 
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as BS
+import Text.StringConvert
 
-data Address = Address {uri :: Maybe URI.URI, account :: Ac.Account, seal :: Maybe Seal.Seal}
-               deriving (Read, Show, Eq, Ord)
+data Address = AccountAdd Ac.Account (Maybe Seal.Seal)
+             | URIAdd URI.URI (Maybe Seal.Seal)
+             deriving (Read, Show, Eq, Ord)
 
-asToURI :: Address -> ByteString
-asToURI a@Address{uri = Nothing} = BS.concat ["<", Ac.normalize . account $ a, ">"]
-asToURI Address{uri = (Just u)} = URI.fullURI u
+asToURI :: Address -> String
+asToURI (AccountAdd a _) = concat ["<", s . Ac.normalize $ a, ">"]
+asToURI (URIAdd u _) = URI.fullURI u
 
 hostFrom :: Address -> Ac.HostName
 hostFrom = Ac.domain . account
 
 fromAccount :: Ac.Account -> Address
-fromAccount a = Address Nothing a Nothing
+fromAccount a = AccountAdd a Nothing
+
+account :: Address -> Ac.Account
+account (AccountAdd a _) = a
+account (URIAdd u _) = URI.account u
+
+seal :: Address -> Maybe Seal.Seal
+seal (AccountAdd _ se) = se
+seal (URIAdd _ se) = se
+
+setSeal :: Address -> Maybe Seal.Seal -> Address
+setSeal (AccountAdd a _) se = AccountAdd a se
+setSeal (URIAdd u _) se = URIAdd u se

src/Data/SMTP/Types/Resource.hs

@@ -1,7 +1,7 @@
 module Data.SMTP.Types.Resource where
 
 import Data.SMTP.Types.Seal
---import Data.SMTP.Types.URI
+import Data.SMTP.Types.URI
 --import Data.SMTP.Account (Account)
 import qualified Data.SMTP.Types.Mime as Mime
 
@@ -12,10 +12,16 @@ import Data.Char
 
 data Header = Header (String, String) deriving (Read, Show, Eq, Ord)
 
+data RevisionInfo = RevisionInfo {
+  current :: Revision,
+  bases :: [Revision]
+  } deriving (Eq, Ord, Read, Show)
+
 data Resource = Resource {
   mimeType :: Mime.ContentType,
   publicHeaders :: [Header],
   seal :: Maybe Seal,
+  revision :: Maybe RevisionInfo,
   bodyData :: ResourceData}
 
 type ResourceData = LBS.ByteString
@@ -30,3 +36,21 @@ getHeaderValue :: [Header] -> String -> Maybe String
 getHeaderValue hh h = case getHeader hh h of
   Just (Header (_, v)) -> Just v
   Nothing -> Nothing
+
+getMultiple :: [Header] -> String -> [Header]
+getMultiple hh h = filter (\(Header (k, _)) -> k == h) hh
+
+getMultipleValue :: [Header] -> String -> [String]
+getMultipleValue hh = map (\(Header (_, v)) -> v) . getMultiple hh
+
+revisionHeader :: String
+revisionHeader = "FCMTP-Revision"
+
+baseHeader :: String
+baseHeader = "FCMTP-Revision-Base"
+
+headersRevision :: [Header] -> Maybe RevisionInfo
+headersRevision hh = do
+  curr <- Revision <$> getHeaderValue hh revisionHeader
+  let bb = map Revision $ getMultipleValue hh baseHeader
+  return $ RevisionInfo curr bb

src/Data/SMTP/Types/Revision.hs

@@ -0,0 +1,5 @@
+module Data.SMTP.Types.Revisioning where
+
+import Data.SMTP.Resource
+
+

src/Data/SMTP/Types/URI.hs

@@ -3,21 +3,25 @@
 module Data.SMTP.Types.URI where
 
 import Data.SMTP.Account
-import qualified Data.ByteString as BS
+import Data.List
 
 import Text.StringConvert
 
-newtype Path = Path FilePath deriving (Eq, Ord, Read, Show)
+newtype Path = Path [String] deriving (Eq, Ord, Read, Show)
 newtype Revision = Revision String deriving (Eq, Ord, Read, Show)
 
 data URI = URI {account :: Account, path :: Path, revision :: Maybe Revision} 
          deriving (Eq, Ord, Read)
 
-fullURI :: URI -> BS.ByteString
-fullURI (URI a (Path p) r) = let bg = BS.concat ["FCMTP://", fullAccount a, s p]
-                      in case r of
-                        Nothing -> bg
-                        Just (Revision r') -> BS.concat[bg, "#", s r']
+fullPath :: URI -> String
+fullPath URI{path=Path p} = "/" ++ intercalate "/" p
+
+fullURI :: URI -> String
+fullURI u@(URI{account=a, revision=r}) =
+  concat $ ["FCMTP://", s . fullAccount $ a, fullPath u] ++
+  case r of
+    Nothing -> []
+    Just (Revision r') -> [":", r']
 
 instance Show URI where
   show = toString . fullURI

src/Data/SMTP/URI.hs

@@ -1,3 +1,20 @@
+{- |
+fCMTP URIs.
+
+Those are also URLs, and have the following format:
+
+> fcmtp://account.name@host.name/path/to/resource:revision
+
+Very similar to HTTP, with an added optional revision.
+
+Path to resource is also optional, but a revision can only
+come in URIs with a path.
+
+URIs that don't specify a path resolve to the account's
+default path (what is implementation dependent),
+and the ones that don't specify a revision resolve to the
+aggregate of all the head revisions of the path.
+-}
 module Data.SMTP.URI (module Data.SMTP.Types.URI, module Data.SMTP.Parser.URI) where
 
 import Data.SMTP.Types.URI