Initial version unblunded.

.gitignore

@@ -0,0 +1,7 @@
+dist/
+.cabal-sandbox/
+cabal.sandbox.config
+*~
+**/*~
+
+

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2016, Marcos Dumay de Medeiros
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Marcos Dumay de Medeiros nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README

@@ -0,0 +1,3 @@
+Common tools for Sealgram projects
+
+

fcmtp-data.cabal

@@ -0,0 +1,59 @@
+name: fcmtp-data
+version: 0.1.0.0
+cabal-version: >=1.10
+build-type: Simple
+license: BSD3
+license-file: LICENSE
+maintainer: marcos@marcosdumay.com
+homepage: http://sealgram/git/haskell/fmctp-data
+synopsis: fCMTP (and SMTP) protocol related data structures
+author: Marcos Dumay de Medeiros
+data-dir: ""
+extra-source-files: README
+ 
+library
+    build-depends:
+        base >=4.7,
+        bytestring >=0.10,
+        attoparsec >=0.10,
+        stringsearch >= 0.3,
+        base64-bytestring >= 1.0,
+        word8 >= 0.1,
+        data-default-class -any,
+        utf8-string -any,
+        uniform-io >=1.1,
+        tools-for-attoparsec,
+        string-convert,
+        memory,
+        cond,
+        cryptonite >= 0.9
+    exposed-modules:
+        Data.SMTP.Response
+        Data.SMTP.Account
+        Data.SMTP.Constants
+        Data.SMTP.Extensions
+        Data.SMTP.Mime
+        Data.SMTP.Resource
+        Data.SMTP.ResponseCode
+        Data.SMTP.Parser.ExtensionParser
+        Data.SMTP.Parser.Host
+        Data.SMTP.Seal
+        Data.SMTP.URI
+        Data.SMTP.Address
+        Data.SMTP.Crypto.CP
+    exposed: True
+    buildable: True
+    hs-source-dirs: src
+    default-language: Haskell2010
+    other-extensions:
+        OverloadedStrings
+        DeriveDataTypeable
+    other-modules:
+        Data.SMTP.Parser.Account Data.SMTP.Types.Account
+        Data.SMTP.Types.Mime Data.SMTP.Parser.Mime
+        Data.SMTP.Types.Resource Data.SMTP.Parser.Resource
+        Data.SMTP.Types.Seal
+        Data.SMTP.Types.Address Data.SMTP.Parser.Address
+        Data.SMTP.Types.URI Data.SMTP.Parser.URI,
+        Data.SMTP.Crypto.Types.CP, Data.SMTP.Crypto.Algos.CP
+    ghc-options: -Wall -fno-warn-unused-do-bind -fwarn-incomplete-patterns -threaded

src/Data/SMTP/Account.hs

@@ -0,0 +1,5 @@
+module Data.SMTP.Account (Account(..), PersonalName(..), AccountName(..), HostName(..), AccountTag(..), parseAccount, normalize) where
+
+import Data.SMTP.Types.Account
+import Data.SMTP.Parser.Account
+

src/Data/SMTP/Address.hs

@@ -0,0 +1,4 @@
+module Data.SMTP.Address (module Data.SMTP.Types.Address, module Data.SMTP.Parser.Address) where
+
+import Data.SMTP.Types.Address
+import Data.SMTP.Parser.Address

src/Data/SMTP/CL.hs

@@ -0,0 +1,14 @@
+module Data.SMTP.CL (module Data.SMTP.Types.CL, module Data.SMTP.Reader.CL) where
+
+import Data.SMTP.Types.CL 
+
+import qualified Data.SMTP.Types.Resource as R
+
+verifyResource :: ClVerifier -> SomeIO -> IO Bool
+verifyResource v resc = case R.seal resc of
+  Nothing -> return False
+  Just s -> verifyWithSeal v s resc
+    
+-- verifyWithSeal :: ClVerifier -> S.Seal -> SomeIO -> IO Bool
+-- verifyWithSeal v seal resc = do
+  

src/Data/SMTP/Constants.hs

@@ -0,0 +1,8 @@
+module Data.SMTP.Constants where
+
+relayPortNumber :: Integer
+relayPortNumber = 25
+initiationPortNumber :: Integer
+initiationPortNumber = 587
+maximumLineSize :: Integer
+maximumLineSize = 1000

src/Data/SMTP/Crypto/Algos/CP.hs

@@ -0,0 +1,53 @@
+{- |
+Crypto algorithms used on capabilities
+-}
+module Data.SMTP.Crypto.Algos.CP (
+  Algo,
+  initCp,
+  update,
+  update',
+  checkSeal,
+  toSeal
+  ) where
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.SMTP.Seal as Seal
+import qualified Crypto.Hash as Hash
+import qualified Crypto.Hash.Algorithms as Hashs
+import qualified Crypto.PubKey.Ed25519 as Ed25519
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString as BS
+import Crypto.Error
+import Data.SMTP.Crypto.Types.CP
+
+data Algo = Sha512Ed25519 deriving (Eq, Ord, Bounded, Enum)
+
+instance Show Algo where
+  show Sha512Ed25519 = "SHA512-ED25519"
+
+data State = Sha512Ed25519s (Hash.Context Hashs.SHA512)
+             
+initCp :: Algo -> State
+initCp Sha512Ed25519 = Sha512Ed25519s Hash.hashInit
+update ::  State -> ByteString -> State
+update (Sha512Ed25519s s) dt = Sha512Ed25519s $ Hash.hashUpdate s dt
+update' :: State -> LBS.ByteString -> State
+update' (Sha512Ed25519s s) dt = Sha512Ed25519s $ Hash.hashUpdates s $ LBS.toChunks dt
+checkSeal :: State -> Seal.Seal -> CP -> Bool
+checkSeal (Sha512Ed25519s s) (Seal.Seal _ seal _) (Sha512Ed25519Cp _ pk _) = let
+  dg = Hash.hashFinalize s
+  sig' = Ed25519.signature seal
+  in case sig' of
+    CryptoFailed _ -> False
+    CryptoPassed sig -> Ed25519.verify pk dg sig
+toSeal :: State -> CP -> Maybe Seal.Seal
+toSeal (Sha512Ed25519s s) (Sha512Ed25519Cp cpid pk (Just sk)) = let
+  dg = Hash.hashFinalize s
+  sig = ba2bs $ Ed25519.sign sk pk dg
+  in Just $ Seal.Seal cpid sig Nothing
+toSeal (Sha512Ed25519s _) _ = Nothing
+
+
+ba2bs :: BA.ByteArrayAccess a => a -> ByteString
+ba2bs = BS.pack . BA.unpack

src/Data/SMTP/Crypto/CP.hs

@@ -0,0 +1,10 @@
+{- |
+fCMTP capabilities.
+-}
+module Data.SMTP.Crypto.CP (
+  module Data.SMTP.Crypto.Types.CP,
+  module Data.SMTP.Crypto.Algos.CP
+  )where
+
+import Data.SMTP.Crypto.Types.CP
+import Data.SMTP.Crypto.Algos.CP

src/Data/SMTP/Crypto/Types/CP.hs

@@ -0,0 +1,10 @@
+{- |
+fCMTP capabilities.
+-}
+module Data.SMTP.Crypto.Types.CP where
+
+import Data.ByteString (ByteString)
+import qualified Crypto.PubKey.Ed25519 as Ed25519
+
+data CP = Sha512Ed25519Cp ByteString Ed25519.PublicKey (Maybe Ed25519.SecretKey)
+

src/Data/SMTP/EncodedBody.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.SMTP.EncodedBody where
+
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.ByteString.Base64.Lazy as B64
+import qualified Data.ByteString.Lazy.Search as Search
+import GHC.Word (Word8)
+import Data.Default.Class
+import Data.Maybe (fromMaybe)
+
+import Data.SMTP.Email (EmailData)
+import Data.SMTP.Mime
+
+reencodeBody :: BodyEncoding -> EmailData -> EmailData
+reencodeBody toEncoding = id
+
+b7bitMessage :: EmailData -> EmailData
+b7bitMessage = B64.encode
+
+qpDecode :: EmailData -> EmailData
+qpDecode dt = unextend $ Search.replace "=\r\n" BS.empty dt
+  where
+      unextend d
+        | BS.null d = d
+        | BS.head d == 61 = let
+          (a, rem') = BS.splitAt 2 d
+          in BS.cons (unascii . reverse . BS.unpack $ a) (unextend rem')
+        | otherwise = d
+      unascii :: [Word8] -> Word8
+      unascii [] = 0
+      unascii (a:aa) = fromIntegral loc + 16 * unascii aa -- the list is reversed
+        where
+          loc = fromMaybe (
+            fromMaybe (
+               fromMaybe 0 $ BS.elemIndex a "abcdef" + 10
+               ) BS.elemIndex a "ABCDEF" + 10
+            ) BS.elemIndex a "0123456789"
+
+qpEncode :: EmailData -> EmailData
+qpEncode = quoteP
+    where
+      quoteP :: ByteString -> ByteString
+      quoteP d = BS.intercalate "=\r\n" lineCount
+        where 
+          lineCount = splitN 70 cat
+          cat = BS.concatMap extendCharP d
+      extendCharP :: Word8 -> ByteString
+      extendCharP w
+        | w > 32 && w < 127 && w /= 61= BS.singleton w
+        | otherwise = BS.cons 61 $ asciicode w
+      asciicode :: Word8 -> ByteString
+      asciicode 0 = ""
+      asciicode w = BS.cons h t
+        where
+          m = mod w 16
+          h = if m < 10 then 48 + m else 65 + m
+          t = asciicode $ div w 16
+      splitN _ d | BS.null d = []
+      splitN n d = h : splitN n t
+        where
+          (h, t) = BS.splitAt n d

src/Data/SMTP/Extensions.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.SMTP.Extensions where
+
+import Data.List
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+
+import Text.StringConvert
+
+data Extension = OnlyExt ExtName | IntExt ExtName Int | StringExt ExtName ByteString
+               | AuthExt ExtName [SaslMethod] deriving (Eq, Ord, Read, Show)
+data ExtName = E8BITMIME | AUTH | CHUNKING | HELP | SIZE | SMTPUTF8 |
+               STARTTLS | PIPELINING | ATRN | DSN | ETRN | UTF8SMTP |
+               UNRECOGNIZED | ENHANCEDSTATUSCODES | EXPN | BINARYMIME |
+               CHECKPOINT | DELIVERBY | NOSOLICITING | MTRK | SUBMITTER |
+               BURL | FUTURERELEASE | CONPERM | CONNEG | MTPRIORITY | RRVS deriving (Eq, Ord, Read, Show)
+
+ehloValue :: Extension -> ByteString
+ehloValue (OnlyExt e) = printExtName e
+ehloValue (IntExt e v) = BS.intercalate " " [printExtName e, s $ show v]
+ehloValue (StringExt e v) = BS.intercalate " " [printExtName e, v]
+ehloValue (AuthExt e v) = BS.intercalate " " (printExtName e : map saslValue v)
+
+printExtName :: ExtName -> ByteString
+printExtName E8BITMIME = "8BITMIME"
+printExtName NOSOLICITING = "NO-SOLICITING"
+printExtName MTPRIORITY = "MT-PRIORITY"
+printExtName e = s . show $ e
+
+hasExtension :: [Extension] -> ExtName -> Bool
+hasExtension [] _ = False
+hasExtension (e:ee) name = (name' == name) || hasExtension ee name
+  where
+    name' = getExtName e
+
+getExtension :: [Extension] -> ExtName -> Maybe Extension
+getExtension [] _ = Nothing
+getExtension (e:ee) name = if name' == name then Just e else getExtension ee name
+  where
+    name' = getExtName e
+
+getExtName :: Extension -> ExtName
+getExtName (OnlyExt a) = a 
+getExtName (IntExt a _) = a 
+getExtName (StringExt a _) = a
+getExtName (AuthExt a _) = a
+
+
+data SaslMethod = PLAIN | DIGEST_MD5 | GSSAPI | UNRECOGNIZED_SASL deriving (Eq, Ord, Read, Show)
+
+saslValue :: SaslMethod -> ByteString
+saslValue DIGEST_MD5 = "DIGEST-MD5"
+saslValue v = s . show $ v
+
+readAllSasl :: String -> [SaslMethod]
+readAllSasl [] = []
+readAllSasl (' ':ss) = readAllSasl ss
+readAllSasl ss
+  | "DIGEST-MD5" `isPrefixOf` ss = DIGEST_MD5 : readAllSasl (drop 10 ss)
+  | "PLAIN" `isPrefixOf` ss  = PLAIN : readAllSasl (drop 5 ss)
+  | "GSSAPI" `isPrefixOf` ss = GSSAPI : readAllSasl (drop 6 ss)
+readAllSasl (_:ss) = readAllSasl ss

src/Data/SMTP/Mime.hs

@@ -0,0 +1,146 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.SMTP.Mime (
+  module Data.SMTP.Types.Mime,
+  module Data.SMTP.Parser.Mime,
+  getMimeData,
+  reencodeMessage,
+  requiredEncoding,
+  splitEach
+  ) where
+
+import Data.SMTP.Types.Mime
+import Data.SMTP.Parser.Mime
+
+import Data.SMTP.Types.Resource
+import Data.SMTP.Parser.Resource
+
+import Text.StringConvert
+
+import qualified Data.Attoparsec.ByteString.Char8.Extras as P
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import qualified Data.Char as C
+import Data.ByteString (ByteString)
+import Data.Word8 (Word8)
+import qualified Data.Word8 as W
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Base64.Lazy as B64
+import qualified Data.ByteString.Lazy.Search as LSearch
+--import qualified Data.ByteString.Search as SSearch
+
+import Data.Default.Class
+
+getMimeData :: [Header] -> (ContentTypeHeader, TransferEncoding)
+getMimeData hh = (ct, te)
+  where
+    ct = case getHeader hh contentTypeHeaderName of
+      Nothing -> def
+      Just (Header (_, cth)) -> case A.parseOnly parseContentType (s cth) of
+        Left _ -> def
+        Right (ctv, ctp) -> ContentTypeHeader ctv ctp
+    te = case getHeader hh transferEncodingHeaderName of
+      Nothing -> def
+      Just (Header (_, teh)) -> case A.parseOnly parseTransferEncoding (C8.pack teh) of
+        Left _ -> def
+        Right t -> t
+
+{- |
+Required encoding for the given data.
+
+Will evaluate the entire data, thus using a lot of memory.
+
+7/8 bit mime is available for data where all lines are shorter then 1000 bytes.
+
+7 bit mime is available ofr that where no byte is larger than 128 or equal 0.
+
+othersiwe data requires binarymime.
+-}
+requiredEncoding :: ResourceData -> BodyEncoding
+requiredEncoding dt = case requiredFeatures 0 $ LBS.unpack dt of
+  (False, False) -> B7BitEncoding
+  (False, True) -> B8BitEncoding
+  (True, _) -> BBinaryEncoding
+  where
+    requiredFeatures :: Int -> [Word8] -> (Bool, Bool)
+    requiredFeatures _ [] = (False, False)
+    requiredFeatures len (c:cc) = let
+      nlen = if c == (fromIntegral . C.ord $ '\n') then 0 else len+1
+      (ll, ee) = requiredFeatures nlen cc
+      in (len >= 1000 || ll, c == 0 || c >= 128 || ee)
+
+
+reencodeMessage :: BodyEncoding -> ResourceData -> ResourceData
+reencodeMessage toEncoding dt = LBS.concat [
+  if newEncoding == fromEncoding then LBS.fromStrict $ BS.concat dthh else replaceEncodingHeader newEncoding dthh,
+  "\r\n",
+  reencodeBody'
+  ]
+  where
+    (dthh, hh, dtb) = takeHeaders dt
+    (ct, fromEncoding) = getMimeData hh
+    fromEncoding' = transferToBody fromEncoding
+    (message, multiPart, separator) = case ct of
+      (ContentTypeHeader (MultiPartMime _) (ContentTypeParameters (Just sep) _ _)) -> (False, True, C8.pack sep)
+      (ContentTypeHeader (MessageMime _) _ ) -> (True, False, "")
+      _ -> (False, False, "")
+    newEncoding :: TransferEncoding
+    newEncoding = case (fromEncoding', toEncoding, multiPart) of
+      (_, BBinaryEncoding, _) -> fromEncoding
+      (BBinaryEncoding, B8BitEncoding, True) -> IdentityEncoding B7BitEncoding
+      (_, B8BitEncoding, _) -> fromEncoding
+      (_, B7BitEncoding, True) -> IdentityEncoding B7BitEncoding
+      (BBinaryEncoding, B7BitEncoding, False) -> Base64EncodedBody
+      (B8BitEncoding, B7BitEncoding, False) -> Base64EncodedBody
+      _ -> fromEncoding
+    newEncoding' = transferToBody newEncoding
+    reencodeBody' :: ResourceData
+    reencodeBody'
+      | newEncoding == fromEncoding = dtb
+      | message = reencodeBody newEncoding dtb
+      | multiPart = concatParts separator . map (reencodeMessage newEncoding') . splitParts separator $ dtb
+      | otherwise = reencodeBody newEncoding dtb
+
+reencodeBody :: TransferEncoding -> ResourceData -> ResourceData
+reencodeBody (IdentityEncoding _) dt = dt
+reencodeBody Base64EncodedBody dt = LBS.intercalate "\r\n" $ splitEach 76 $ B64.encode dt
+reencodeBody QPEncodedBody dt = dt
+
+splitEach :: Int -> LBS.ByteString -> [LBS.ByteString]
+splitEach n t
+  | LBS.null t = []
+  | otherwise = let (p, pp) = LBS.splitAt (fromIntegral n) t
+                in p : splitEach n pp
+
+splitParts :: ByteString -> LBS.ByteString -> [LBS.ByteString]
+splitParts sep dt = map manageChunk chunks
+  where
+    sep' = BS.concat ["\r\n--", sep]
+    chunks = LSearch.split sep' dt
+    manageChunk = LBS.dropWhile (== P.asW8 '-') . LBS.dropWhile A.isHorizontalSpace . LBS.dropWhile A.isEndOfLine
+
+concatParts :: ByteString -> [LBS.ByteString] -> LBS.ByteString
+concatParts sep = joinChunks (LBS.fromStrict sep)
+  where
+    joinChunks _ [] = ""
+    joinChunks _ [c] = c
+    joinChunks sep' [c1, c2] = LBS.concat [c1, "\r\n--", sep', "--\r\n", c2]
+    joinChunks sep' (c:cc2) = LBS.concat [c, "\r\n--", sep', "\r\n", joinChunks sep' cc2]
+
+replaceEncodingHeader :: TransferEncoding -> [ByteString] -> LBS.ByteString
+replaceEncodingHeader enc = LBS.concat . map LBS.fromStrict . echoAndReplace
+  where
+    h = transferEncodingHeaderName
+    echoAndReplace [] = []
+    echoAndReplace (l:ll) = if isPrefixCI h l
+                            then BS.concat [C8.pack h, ": ", C8.pack . show $ enc, "\r\n"] :
+                                 dropWhile (\x -> BS.null x || (W.isSpace . BS.head $ x)) ll
+                            else l : echoAndReplace ll
+                                 
+
+isPrefixCI :: String -> ByteString -> Bool
+isPrefixCI [] _ = True
+isPrefixCI (c:cc) bs = case BS.uncons bs of
+  Nothing -> False
+  Just (h, t) -> (C.toUpper . C.chr . fromIntegral $ h) == C.toUpper c && isPrefixCI cc t

src/Data/SMTP/Parser/Account.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- Parser of email account
+
+module Data.SMTP.Parser.Account where
+
+import Data.SMTP.Types.Account
+import Data.Attoparsec.ByteString.Char8.Extras
+import Data.SMTP.Parser.Host
+
+import Control.Applicative ((<|>))
+import Data.Attoparsec.ByteString.Char8
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Search as Search
+import Data.ByteString (ByteString)
+import qualified Codec.Binary.UTF8.String as UTF8
+import qualified Data.Char as C
+import qualified Data.Word8 as W
+
+parseAccount :: Parser Account
+parseAccount = quotedAccount <|> escapedAccount <|> plainAccount
+
+quotedAccount :: Parser Account
+quotedAccount = do
+  char '\"'
+  a <- parseAccount
+  char '\"'
+  return a
+
+plainAccount :: Parser Account
+plainAccount = do
+  (fa, AccountName a, h, ts) <- plainAddress
+  if BS.null a
+    then fail "empty account name"
+    else return $ Account fa (PersonalName "") (AccountName a) h ts
+    
+escapedAccount :: Parser Account
+escapedAccount = do
+  n' <- takeTill (`elem` ("\"'<\r\n" :: String))
+  let n = fst . BS.spanEnd W.isSpace $ n'
+  char '<'
+  (fa, a, h, ts) <- plainAddress
+  char '>'
+  return $ Account (BS.concat [n', "<", fa, ">"]) (PersonalName n) a h ts
+ 
+plainAddress :: Parser (ByteString, AccountName, HostName, [AccountTag])
+plainAddress = do
+  (fa, a, ts) <- scanAccountName
+  (h, hasAt) <-
+    (do
+        char '@'
+        h <- scanHostName
+        return (h, True)
+    ) <|> return ("", False)
+  return (if hasAt then BS.concat [fa, "@", h] else fa, a, HostName h, ts)
+
+scanAccountName :: Parser (ByteString, AccountName, [AccountTag])
+scanAccountName = do
+  f <- quotedString '\\' " ][,:\\;<>\"\r\n@" "\r\n"
+  let ff = Search.split "+" f
+  case ff of
+    [] -> return (f, normalizeA f, [])
+    [_] -> return (f, normalizeA f, [])
+    (a:aa) -> return (f, normalizeA a, map AccountTag aa)
+    
+normalizeA :: ByteString -> AccountName
+normalizeA a = AccountName na
+  where
+    a' = LBS.unpack $ Search.replace ("([^)]*)"::ByteString) (""::ByteString) a
+    a'' = UTF8.encode . map C.toLower . UTF8.decode $ a'
+    na = BS.pack a''

src/Data/SMTP/Parser/Address.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.SMTP.Parser.Address (
+  parseAddress,
+  parseMetadataAddress,
+  renderMetadataAddress
+  ) where
+
+import Data.Attoparsec.ByteString.Char8
+import qualified Data.SMTP.URI as URI
+import Data.SMTP.Account
+import Data.SMTP.Types.Address
+import qualified Data.SMTP.Seal as Seal
+import Data.Attoparsec.ByteString.Char8.Extras
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base64 as B64
+import Control.Applicative ((<|>))
+
+parseAddress :: Parser Address
+parseAddress = ((\x -> Address (Just x) (URI.account x) Nothing) <$> URI.parseURI) <|>
+               ((\x -> Address Nothing x Nothing) <$> parseAccount)
+
+renderMetadataAddress :: Address -> ByteString
+renderMetadataAddress add@(Address _ _ s) =
+  BS.intercalate "; " $ asToURI add : case s of
+    Nothing -> []
+    Just (Seal.Seal cp code nonce) -> [
+      BS.append "CP=" $ B64.encode cp
+      ] ++ nc nonce ++ [
+      BS.append "SEAL=" $ B64.encode code
+      ]
+  where
+    nc nonce = case nonce of
+      Nothing -> []
+      Just n -> [BS.append "Nonce=" $ B64.encode n]
+
+parseMetadataAddress :: Parser Address
+parseMetadataAddress = do
+  a <- parseAddress
+  (cp, nonce, code) <- parserFold addrParams (Nothing, Nothing, Nothing)
+  let r = do
+        cp' <- cp
+        code' <- code
+        return a{seal=Just $ Seal.Seal cp' code' nonce}
+  case r of
+    Nothing -> return a
+    Just r' -> return r'
+  where
+    addrParams = choice [
+      do
+        c <- cmdSep "CP" decodeBase64
+        return $ \(_, n, s) -> (Just c, n, s),
+      do
+        n <- cmdSep "Nonce" decodeBase64
+        return $ \(c, _, s) -> (c, Just n, s),
+      do
+        s <- cmdSep "Seal" decodeBase64
+        return $ \(c, n, _) -> (c, n, Just s)
+      ]
+    cmdSep c p = do
+      skipWhile isCHorizontalSpace
+      stringCI c
+      skipWhile isCHorizontalSpace
+      char ':'
+      skipWhile isCHorizontalSpace
+      p
+

src/Data/SMTP/Parser/Email.hs

@@ -0,0 +1,87 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- Parser of email text
+
+module Data.SMTP.Parser.Email (parseHeaders, takeHeaders) where
+
+import Data.SMTP.Types.Email
+import Text.StringConvert
+
+import Control.Applicative ((<|>))
+import Control.Monad
+import Data.Attoparsec.ByteString.Char8
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import qualified Data.Attoparsec.ByteString.Lazy as Alz
+import qualified Data.ByteString as BS
+import Data.ByteString (ByteString)
+import qualified Data.Word8 as W
+import qualified Data.Char as C
+
+{- |
+Splits the data into headers and body,
+also, parses the headers, returning both
+the bare headers data and the parsed result.
+
+Returns: (headers data, headers, body)
+
+Notice that this function chomps the lone CRLF
+that separates the body from the headers.
+-}
+takeHeaders :: EmailData -> ([ByteString], [Header], EmailData)
+takeHeaders dt = case Alz.parse parseHeadersAndReturn dt of
+  Alz.Fail{} -> ([], [], dt)
+  Alz.Done dtb (dth, hh) -> (dth, hh, dtb)
+
+parseHeaders :: Parser [Header]
+parseHeaders = snd <$> parseHeadersAndReturn
+
+parseHeadersAndReturn :: Parser ([ByteString], [Header])
+parseHeadersAndReturn = (
+  do
+    blankLine
+    return ([], [])
+  ) <|> (
+  do
+    (dth, h) <- headerAndReturn
+    (dthh, hh) <- parseHeadersAndReturn
+    return (dth:dthh, h:hh)
+  )
+
+-- header :: Parser Header
+-- header = do
+--   key <- A.takeTill (== ':')
+--   char ':'
+--   if BS.null key then failParser else return ()
+--   skipSpace
+--   value <- scan Value headerValueScanner
+--   let key' = s . BS.reverse . (BS.dropWhile W.isSpace) . BS.reverse . (BS.dropWhile W.isSpace) $ key
+--   let value' = s . BS.reverse . (BS.dropWhile A.isEndOfLine) . BS.reverse $ value
+--   return $ Header (key', value')
+
+headerAndReturn :: Parser (ByteString, Header)
+headerAndReturn = do
+  key <- A.takeTill (== ':')
+  char ':'
+  when (BS.null key) $ fail "email header must have a name"
+  sp <- A.takeWhile isSpace
+  value <- scan Value headerValueScanner
+  let key' = s . BS.reverse . BS.dropWhile W.isSpace . BS.reverse . BS.dropWhile W.isSpace $ key
+  let value' = s . BS.reverse . BS.dropWhile A.isEndOfLine . BS.reverse $ value
+  return (BS.concat [key, sp, value], Header (key', value'))
+
+data HeaderScanStatus = Value | CR | LF
+
+headerValueScanner :: HeaderScanStatus -> Char -> Maybe HeaderScanStatus
+headerValueScanner Value c 
+  | c == '\r' = Just CR
+  | c == '\n' = Just LF
+  | otherwise = Just Value
+headerValueScanner CR c
+  | c == '\r' = Just CR
+  | c == '\n' = Just LF
+  | otherwise = Nothing
+headerValueScanner LF c
+  | isHorizontalSpace . fromIntegral .C.ord $ c = Just Value
+  | otherwise = Nothing
+
+blankLine :: Parser ByteString
+blankLine = string "\n" <|> string "\r\n"

src/Data/SMTP/Parser/ExtensionParser.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- Parser of mail commands
+
+module Data.SMTP.Parser.ExtensionParser where
+
+import Data.SMTP.Extensions
+
+import Control.Applicative ((<|>))
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Attoparsec.ByteString (Parser)
+import qualified Data.Char as C
+
+noParameterExtensions :: [ExtName]
+noParameterExtensions = [E8BITMIME, CHUNKING, HELP, SMTPUTF8, STARTTLS, PIPELINING,
+                         ATRN, DSN, ETRN, UTF8SMTP, ENHANCEDSTATUSCODES, EXPN, BINARYMIME,
+                         CHECKPOINT, DELIVERBY, NOSOLICITING, MTRK, SUBMITTER, BURL,
+                         FUTURERELEASE, CONPERM, CONNEG, MTPRIORITY, RRVS, SIZE]
+
+parseExtension :: Parser Extension
+parseExtension = parseAuth <|> parseSize <|> onlyName noParameterExtensions
+
+onlyName :: [ExtName] -> Parser Extension
+onlyName = foldr
+           (\ e ->
+             (<|>) ((A.stringCI . printExtName $ e) *> (return . OnlyExt $ e)))
+           (fail "Unknown extension")
+
+parseAuth :: Parser Extension
+parseAuth = do
+  A.stringCI "AUTH "
+  skipHor
+  mets <- parseAuthMethods
+  return $ AuthExt AUTH mets
+  
+parseAuthMethods :: Parser [SaslMethod]
+parseAuthMethods = parsePlainAuth
+
+parsePlainAuth :: Parser [SaslMethod]
+parsePlainAuth = do
+  A.stringCI "PLAIN"
+  skipHor
+  return [PLAIN]
+  
+parseSize :: Parser Extension
+parseSize = do
+  A.stringCI "SIZE "
+  skipHor
+  size <- A.decimal
+  return $ IntExt SIZE size
+
+skipHor :: Parser ()
+skipHor = A.skipWhile $ A.isHorizontalSpace . fromIntegral . C.ord

src/Data/SMTP/Parser/Host.hs

@@ -0,0 +1,23 @@
+module Data.SMTP.Parser.Host (scanHostName, parseHostName) where
+
+import Data.SMTP.Types.Account
+
+import Data.Attoparsec.ByteString.Char8
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.ByteString (ByteString)
+import qualified Data.Char as C
+
+parseHostName :: Parser HostName
+parseHostName = do
+  h <- scanHostName
+  return . HostName $ h
+
+scanHostName :: Parser ByteString
+scanHostName = A.takeWhile isHostChar
+
+isHostChar :: Char -> Bool
+isHostChar c
+  | c `elem` ("._-" :: String) = True
+  | C.isSpace c = False
+  | C.isAlphaNum c = True
+  | otherwise = False

src/Data/SMTP/Parser/Mime.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.SMTP.Parser.Mime where
+
+import Data.Attoparsec.ByteString.Char8.Extras
+import Data.SMTP.Types.Mime
+import Text.StringConvert
+
+import Data.Default.Class
+
+import Control.Applicative ((<|>))
+import Data.Attoparsec.ByteString.Char8
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import qualified Data.Char as C
+
+parseContentType :: Parser (ContentType, ContentTypeParameters)
+parseContentType = do
+  mime <- (
+    stringCI "multipart/" *>
+    parseMultipart
+    ) <|> (
+    stringCI "message/" *>
+    parseMessage
+    ) <|> (
+    ContentMime . s <$> takeTill endType
+    )
+  A.takeWhile endType
+  pars <- parseContentTypeParameters
+  return (mime, pars)
+  where
+    endType c = C.isSpace c || c == ';'
+    parseMultipart :: Parser ContentType
+    parseMultipart = (
+      stringCI "vnd.dFCMTP.Digest" *>
+      (return . MultiPartMime $ FcmtpDigest)
+      ) <|> (do
+                tp <- takeTill endType
+                return . MultiPartMime . OtherMultiPartType $ "multipart/" ++ s tp
+            )
+    parseMessage :: Parser ContentType
+    parseMessage = (
+      do
+        stringCI "vnd.dFCMTP.Resource"
+        return . MessageMime $ FcmtpResource
+      ) <|> (
+      do
+        tp <-  takeTill endType
+        return . MessageMime . OtherMessageType $ "message/" ++ s tp
+      )
+parseContentTypeParameters :: Parser ContentTypeParameters
+parseContentTypeParameters = parserFold parseContentTypeParameter def
+parseContentTypeParameter :: Parser (ContentTypeParameters -> ContentTypeParameters)
+parseContentTypeParameter = do
+  A.takeWhile isSpace
+  k' <- takeTill (\c -> C.isSpace c || c == '=')
+  skipWhile isSpace
+  let k = map C.toLower . s $ k'
+  A.char '='
+  A.skipWhile isSpace
+  v' <- takeTill (\c -> C.isSpace c || c == ';')
+  skipWhile isSpace
+  let v = s v'
+  case lookup k [
+    ("boundary", \pp -> pp{boundary=Just v}),
+    ("charset", \pp -> pp{charset=Just v})
+    ] of
+    Just f -> return f
+    Nothing -> return (\pp -> pp{other = (k,v): other pp})
+
+
+parseTransferEncoding :: Parser TransferEncoding
+parseTransferEncoding = parseShowCI allEncodings
+  where
+    allEncodings = map IdentityEncoding [B7BitEncoding,
+                                         B8BitEncoding,
+                                         BBinaryEncoding] ++
+                   [
+                     QPEncodedBody,
+                     Base64EncodedBody
+                   ]
+
+parseBodyEncoding :: Parser BodyEncoding
+parseBodyEncoding = parseEnumCI

src/Data/SMTP/Parser/Resource.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- Parser of email text
+
+module Data.SMTP.Parser.Resource (takeHeaders, parseHeaders) where
+
+import Data.SMTP.Types.Resource
+import Text.StringConvert
+
+import Control.Applicative ((<|>))
+import Control.Monad
+import Data.Attoparsec.ByteString.Char8
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import qualified Data.Attoparsec.ByteString.Lazy as Alz
+import qualified Data.ByteString as BS
+import Data.ByteString (ByteString)
+import qualified Data.Word8 as W
+import qualified Data.Char as C
+
+{- |
+Splits the data into headers and body,
+also, parses the headers, returning both
+the bare headers data and the parsed result.
+
+Returns: (headers data, headers, body)
+
+Notice that this function chomps the lone CRLF
+that separates the body from the headers.
+-}
+takeHeaders :: ResourceData -> ([ByteString], [Header], ResourceData)
+takeHeaders dt = case Alz.parse parseHeadersAndReturn dt of
+  Alz.Fail{} -> ([], [], dt)
+  Alz.Done dtb (dth, hh) -> (dth, hh, dtb)
+
+
+parseHeaders :: Parser [Header]
+parseHeaders = snd <$> parseHeadersAndReturn
+
+parseHeadersAndReturn :: Parser ([ByteString], [Header])
+parseHeadersAndReturn = (
+  do
+    blankLine
+    return ([], [])
+  ) <|> (
+  do
+    (dth, h) <- headerAndReturn
+    (dthh, hh) <- parseHeadersAndReturn
+    return (dth:dthh, h:hh)
+  )
+
+-- header :: Parser Header
+-- header = do
+--   key <- A.takeTill (== ':')
+--   char ':'
+--   if BS.null key then failParser else return ()
+--   skipSpace
+--   value <- scan Value headerValueScanner
+--   let key' = s . BS.reverse . (BS.dropWhile W.isSpace) . BS.reverse . (BS.dropWhile W.isSpace) $ key
+--   let value' = s . BS.reverse . (BS.dropWhile A.isEndOfLine) . BS.reverse $ value
+--   return $ Header (key', value')
+
+headerAndReturn :: Parser (ByteString, Header)
+headerAndReturn = do
+  key <- A.takeTill (== ':')
+  char ':'
+  when (BS.null key) $ fail "email header must have a name"
+  sp <- A.takeWhile isSpace
+  value <- scan Value headerValueScanner
+  let key' = s . BS.reverse . BS.dropWhile W.isSpace . BS.reverse . BS.dropWhile W.isSpace $ key
+  let value' = s . BS.reverse . BS.dropWhile A.isEndOfLine . BS.reverse $ value
+  return (BS.concat [key, sp, value], Header (key', value'))
+
+data HeaderScanStatus = Value | CR | LF
+
+headerValueScanner :: HeaderScanStatus -> Char -> Maybe HeaderScanStatus
+headerValueScanner Value c 
+  | c == '\r' = Just CR
+  | c == '\n' = Just LF
+  | otherwise = Just Value
+headerValueScanner CR c
+  | c == '\r' = Just CR
+  | c == '\n' = Just LF
+  | otherwise = Nothing
+headerValueScanner LF c
+  | isHorizontalSpace . fromIntegral .C.ord $ c = Just Value
+  | otherwise = Nothing
+
+blankLine :: Parser ByteString
+blankLine = string "\n" <|> string "\r\n"

src/Data/SMTP/Parser/Seal.hs

@@ -0,0 +1,28 @@
+module Data.SMTP.Parser.Seal (
+  --parseRcptSeal, parseRcptSealParam, SealAttribute,
+  headersToSeal) where
+
+import Data.SMTP.Types.Seal
+import Data.SMTP.Types.Resource
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Char8 as C8
+import Data.ByteString (ByteString)
+
+headersToSeal :: [Header] -> Maybe Seal
+headersToSeal hh = let
+  mycp = decode2maybe =<< getH hh cpHeaderName
+  mynonce = decode2maybe =<< getH hh nonceHeaderName
+  mycode = decode2maybe =<< getH hh sealHeaderName
+  in do
+    cp' <- mycp
+    code' <- mycode
+    Just $ Seal cp' code' mynonce
+  where
+    getH :: [Header] -> String -> Maybe ByteString
+    getH hh' h = C8.pack <$> getHeaderValue hh' h
+    either2maybef :: (a -> Either b c) -> a -> Maybe c
+    either2maybef f v = either2maybe $ f v
+    either2maybe :: Either a b -> Maybe b
+    either2maybe (Left _) = Nothing
+    either2maybe (Right v) = Just v
+    decode2maybe = either2maybef B64.decode

src/Data/SMTP/Parser/URI.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.SMTP.Parser.URI (parseURI) where
+
+import Data.Attoparsec.ByteString.Char8
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.SMTP.Types.URI
+import Data.SMTP.Account
+import Control.Applicative ((<|>))
+import qualified Data.Char as C
+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)
+
+parsePath :: Parser Path
+parsePath = (Path . s) <$> A.takeWhile isPathChar
+  where
+    isPathChar :: Char -> Bool
+    isPathChar c = C.isAlphaNum c || elem c ("_-=[]{}().:%/" :: String)
+
+parseRevision :: Parser Revision
+parseRevision = (Revision . s) <$> A.takeWhile isRevisionChar
+  where
+    isRevisionChar :: Char -> Bool
+    isRevisionChar c = C.isAlphaNum c || elem c ("+-/_=." :: String)

src/Data/SMTP/Resource.hs

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

src/Data/SMTP/Response.hs

@@ -0,0 +1,113 @@
+
+{-# LANGUAGE OverloadedStrings #-}
+module Data.SMTP.Response (
+  ResponseStatus(..),
+  Response(..),
+  parseResponse,
+  parseLineResponse,
+  renderResponse,
+  renderLineResponse,
+  )where
+
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Attoparsec.ByteString.Char8.Extras
+import Data.Default.Class
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+
+import Text.StringConvert
+
+data ResponseStatus = Preliminary | Completion | Intermediate | TransientError | PermanentError
+                    deriving (Read, Show, Ord, Eq)
+data Response = Response {status :: ResponseStatus, respLines :: [ByteString],
+                          code :: Int, extended :: Maybe (Int, Int, Int), message :: ByteString}
+              deriving (Read, Show, Ord, Eq)
+
+instance Default Response where
+  def = Response PermanentError [] 500 Nothing ""
+
+parseLineResponse :: A.Parser Response
+parseLineResponse = do
+  (cd, xcd, m, _) <- parseLine
+  return $ Response (statusFromCode cd) [] cd xcd m
+  
+
+parseResponse :: A.Parser Response
+parseResponse = do
+  (cd, xcd, m, moreLines) <- parseLine
+  A.endOfLine
+  lns <- parseLines moreLines
+  return $ Response (statusFromCode cd) lns cd xcd m
+
+parseLines :: Bool -> A.Parser [ByteString]
+parseLines False = return []
+parseLines True = do
+  (_, _, m, moreLines) <- parseLine
+  A.endOfLine
+  lns <- parseLines moreLines
+  return $ m : lns
+
+parseLine :: A.Parser (Int, Maybe (Int, Int, Int), ByteString, Bool)
+parseLine = A.choice [
+  do
+    cd  <- A.decimal
+    A.string "-"
+    xcd <- parsexcode "-"
+    m <- A.takeTill (A.isEndOfLine. asW8)
+    return (cd, xcd, m, True),
+  do
+    cd <- A.decimal
+    A.string " "
+    xcd <- parsexcode " "
+    m <- A.takeTill (A.isEndOfLine . asW8)
+    return (cd, xcd, m, False)
+  ]
+
+parsexcode :: ByteString -> A.Parser (Maybe (Int, Int, Int))
+parsexcode sep = A.choice [
+  do
+    c1 <- A.decimal
+    A.string "."
+    c2 <- A.decimal
+    A.string "."
+    c3 <- A.decimal
+    A.string sep
+    return $ Just (c1, c2, c3),
+  return Nothing
+  ]
+
+statusFromCode :: Int -> ResponseStatus
+statusFromCode c
+  | c < 100 = PermanentError
+  | c < 200 = Preliminary
+  | c < 300 = Completion
+  | c < 400 = Intermediate
+  | c < 500 = TransientError
+  | otherwise = PermanentError
+
+renderResponse :: Response -> ByteString
+renderResponse (Response _ lns cd ext msg) = let
+  tst = showBS cd
+  sep = if null lns then " " else "-"
+  enh = case ext of
+    Nothing -> ""
+    Just (s1, s2, s3) -> BS.intercalate "." $ map showBS [s1, s2, s3]
+  in BS.concat $ [tst, sep, enh, if BS.null enh then "" else sep, msg, "\r\n"] ++ renderLines tst enh lns
+  where
+    renderLines _ _ [] = []
+    renderLines tst enh (l:ll) = let
+      sep = if null ll then " " else "-"
+      in [tst, sep, enh, if BS.null enh then "" else sep, l, "\r\n"] ++ renderLines tst enh ll
+
+renderLineResponse :: Response -> ByteString
+renderLineResponse (Response _ _ cd ext msg) = let
+  tst = showBS cd
+  sep = " "
+  enh = case ext of
+    Nothing -> ""
+    Just (s1, s2, s3) -> BS.intercalate "." $ map showBS [s1, s2, s3]
+  in BS.concat [tst, sep, enh, if BS.null enh then "" else sep, msg]
+
+showBS :: Show a => a -> ByteString
+showBS = s . show

src/Data/SMTP/ResponseCode.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.SMTP.ResponseCode where
+
+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)
+
+errorMessage :: ResponseCode -> ByteString
+errorMessage = renderResponse . toResponse
+
+continueOnError :: ResponseCode -> Bool
+continueOnError Timeout = False
+continueOnError _ = True
+
+toResponse :: ResponseCode -> Response
+toResponse Unrecognized = Response PermanentError [] 500 (Just (5, 5, 1)) "Unrecognized command"
+toResponse InvalidHost = Response PermanentError [] 501 (Just (5, 5, 2)) "Invalid hostname"
+toResponse (InvalidArguments a) = Response PermanentError [] 502 (Just (5, 5, 4)) $ BS.concat ["Invalid argument: ", a, "."]
+toResponse InvalidSetOfArguments = Response PermanentError [] 502 (Just (5, 5, 4)) "Invalid argument sequence."
+toResponse (InvalidEmail a) = Response PermanentError [] 501 (Just (5, 1, 3)) $ BS.concat ["Invalid email address: ", a, "."]
+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 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."
+toResponse RequiresTls = Response PermanentError [] 538 (Just (5, 7, 11)) "StartTLS before this authentication."
+toResponse BadAuthCredentials = Response PermanentError [] 535 (Just (5, 7, 8)) "Bad credentials."
+toResponse AuthRequired = Response PermanentError [] 530 (Just (5, 7, 0)) "You must be authenticated."
+toResponse Congestion = Response TransientError [] 451 (Just (4, 4, 5)) "Mail system congestion."
+toResponse BadConnection = Response TransientError [] 421 (Just (4, 4, 2)) "Connection problems."
+toResponse NoConversion = Response PermanentError [] 554 (Just (5, 6, 1)) "Conversion is not supported."
+toResponse TempUndefined = Response TransientError [] 451 (Just (4, 2, 0)) "Undefined mailsystem error."
+toResponse InvalidCP = Response PermanentError [] 500 (Just (5, 7, 7)) "Capability corrupted or invalid."

src/Data/SMTP/Seal.hs

@@ -0,0 +1,4 @@
+module Data.SMTP.Seal (module Data.SMTP.Types.Seal, module Data.SMTP.Parser.Seal) where
+
+import Data.SMTP.Types.Seal
+import Data.SMTP.Parser.Seal

src/Data/SMTP/Types/Account.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.SMTP.Types.Account (Account(..), PersonalName(..), AccountName(..), HostName(..), AccountTag(..), normalize) where
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import Data.Default.Class
+
+newtype PersonalName = PersonalName ByteString deriving (Show, Read, Eq, Ord)
+newtype HostName = HostName ByteString deriving (Show, Read, Eq, Ord)
+newtype AccountTag = AccountTag ByteString deriving (Show, Read, Eq, Ord)
+newtype AccountName = AccountName ByteString deriving (Show, Read, Eq, Ord)
+data Account = Account {fullAccount :: ByteString, personalName :: PersonalName,
+                        name :: AccountName, domain :: HostName,
+                        tags :: [AccountTag]} deriving (Show, Read)
+
+instance Eq Account where
+  a == b = name a == name b && domain a == domain b
+instance Ord Account where
+  compare a b = case compare (name a) (name b) of
+    LT -> LT
+    GT -> GT
+    EQ -> compare (domain a) (domain b)
+instance Default Account where
+  def = Account "<>" (PersonalName "") (AccountName "") (HostName "") []
+
+normalize :: Account -> ByteString
+normalize a = let
+  AccountName an = name a
+  HostName hn = domain a
+  in if BS.null hn then an else BS.concat [an, "@", hn]

src/Data/SMTP/Types/Address.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.SMTP.Types.Address where
+
+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
+
+data Address = Address {uri :: Maybe URI.URI, account :: Ac.Account, seal :: 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
+
+hostFrom :: Address -> Ac.HostName
+hostFrom = Ac.domain . account
+
+fromAccount :: Ac.Account -> Address
+fromAccount a = Address Nothing a Nothing

src/Data/SMTP/Types/Mime.hs

@@ -0,0 +1,55 @@
+module Data.SMTP.Types.Mime where
+
+import Data.Default.Class
+
+mimeVersionHeaderName :: String
+mimeVersionHeaderName = "Mime-Version"
+
+data ContentTypeHeader = ContentTypeHeader ContentType ContentTypeParameters deriving (Read, Show, Eq, Ord)
+
+data ContentType = MultiPartMime MultiPartType | MessageMime MessageType |
+                   ContentMime String deriving (Read, Show, Eq, Ord)
+data MultiPartType = FcmtpDigest | OtherMultiPartType String deriving (Read, Show, Eq, Ord)
+data MessageType = FcmtpResource | OtherMessageType String deriving (Read, Show, Eq, Ord)
+
+data ContentTypeParameters = ContentTypeParameters {
+  boundary :: Maybe String, charset :: Maybe String, other :: [(String, String)]
+  } deriving (Read, Show, Eq, Ord)
+
+instance Default ContentType where
+  def = ContentMime "text/plain"
+
+instance Default ContentTypeParameters where
+  def = ContentTypeParameters Nothing Nothing []
+
+instance Default ContentTypeHeader where
+  def = ContentTypeHeader def def{charset=Just "us-ascii"}
+
+contentTypeHeaderName :: String
+contentTypeHeaderName = "Content-Type"
+
+data BodyEncoding = B7BitEncoding | B8BitEncoding | BBinaryEncoding deriving (Eq, Ord, Bounded, Enum)
+
+data TransferEncoding = IdentityEncoding BodyEncoding | QPEncodedBody | Base64EncodedBody deriving (Eq, Ord)
+
+instance Default TransferEncoding where
+  def = IdentityEncoding B7BitEncoding
+
+instance Show BodyEncoding where
+  show B7BitEncoding = "7BIT"
+  show B8BitEncoding = "8BITMIME"
+  show BBinaryEncoding = "BINARYMIME"
+instance Show TransferEncoding where
+  show (IdentityEncoding b) = case b of
+    B7BitEncoding -> "7bit"
+    B8BitEncoding -> "8bit"
+    BBinaryEncoding -> "binary"
+  show QPEncodedBody = "quoted-printable"
+  show Base64EncodedBody = "base64"
+
+transferEncodingHeaderName :: String
+transferEncodingHeaderName = "Content-Transfer-Encoding"
+
+transferToBody :: TransferEncoding -> BodyEncoding
+transferToBody (IdentityEncoding e) = e
+transferToBody _ = B7BitEncoding

src/Data/SMTP/Types/Resource.hs

@@ -0,0 +1,32 @@
+module Data.SMTP.Types.Resource where
+
+import Data.SMTP.Types.Seal
+--import Data.SMTP.Types.URI
+--import Data.SMTP.Account (Account)
+import qualified Data.SMTP.Types.Mime as Mime
+
+--import qualified System.IO.Uniform as UIO
+import qualified Data.ByteString.Lazy as LBS
+
+import Data.Char
+
+data Header = Header (String, String) deriving (Read, Show, Eq, Ord)
+
+data Resource = Resource {
+  mimeType :: Mime.ContentType,
+  publicHeaders :: [Header],
+  seal :: Maybe Seal,
+  bodyData :: ResourceData}
+
+type ResourceData = LBS.ByteString
+
+getHeader :: [Header] -> String -> Maybe Header
+getHeader [] _ = Nothing
+getHeader (h@(Header (hk, _)) : hh) k
+  | map toLower hk == map toLower k = Just h
+  | otherwise = getHeader hh k
+
+getHeaderValue :: [Header] -> String -> Maybe String
+getHeaderValue hh h = case getHeader hh h of
+  Just (Header (_, v)) -> Just v
+  Nothing -> Nothing

src/Data/SMTP/Types/Seal.hs

@@ -0,0 +1,17 @@
+module Data.SMTP.Types.Seal where
+
+import Data.ByteString (ByteString)
+
+data Seal = Seal {
+  cp :: ByteString,
+  seal :: ByteString,
+  nonce :: Maybe ByteString} deriving (Eq, Ord, Read, Show)
+
+data SealAlgo = ED25519 deriving (Eq, Ord, Read, Show, Bounded, Enum)
+
+cpHeaderName :: String
+cpHeaderName = "FCMTP-SEAL-CP"
+nonceHeaderName :: String
+nonceHeaderName = "FCMTP-SEAL-NONCE"
+sealHeaderName :: String
+sealHeaderName = "FCMTP-SEAL"

src/Data/SMTP/Types/URI.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.SMTP.Types.URI where
+
+import Data.SMTP.Account
+import qualified Data.ByteString as BS
+
+import Text.StringConvert
+
+newtype Path = Path FilePath 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']
+
+instance Show URI where
+  show = toString . fullURI

src/Data/SMTP/URI.hs

@@ -0,0 +1,4 @@
+module Data.SMTP.URI (module Data.SMTP.Types.URI, module Data.SMTP.Parser.URI) where
+
+import Data.SMTP.Types.URI
+import Data.SMTP.Parser.URI