fcmtp-data/src/Data/SMTP/Extensions.hs

{-# 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