|
@@ -11,6 +11,7 @@ import SMTP.Account
|
|
|
import qualified SMTP.Mime as Mime
|
|
|
import SMTP.Response
|
|
|
import Data.Textual.Class
|
|
|
+import Text.StringConvert
|
|
|
|
|
|
import Data.Time.ISO8601
|
|
|
import Data.IP
|
|
@@ -62,7 +63,7 @@ instance Default MaybeMetadata where
|
|
|
|
|
|
-- | Creates an empty metadata with just the client identity
|
|
|
metadataForClient :: IP -> Int -> MaybeMetadata
|
|
|
-metadataForClient c p = def & mclientId .~ (Just (ClientIdentity c p))
|
|
|
+metadataForClient c p = def & mclientId .~ Just (ClientIdentity c p)
|
|
|
-- | Blanks the data as necessary for the RSET SMTP command
|
|
|
resetMetadata :: MaybeMetadata -> MaybeMetadata
|
|
|
resetMetadata d = def & mclientId .~ d^.mclientId & mclientName .~ d^.mclientName
|
|
@@ -104,8 +105,8 @@ renderMetadata m = BS.concat serialize
|
|
|
usrStr = case usr of
|
|
|
Nothing -> []
|
|
|
Just u -> ["Auth-User: ", u, "\r\n"]
|
|
|
- toStr = List.concat $ map (\x -> ["To: ", renderMetadataAddress $ x, "\r\n"]) rto
|
|
|
- failStr = List.concat $ map (\(a, r) -> ["Failed: ", renderMetadataAddress a, "; ", renderLineResponse r, "\r\n"]) rfail
|
|
|
+ toStr = List.concatMap (\x -> ["To: ", renderMetadataAddress x, "\r\n"]) rto
|
|
|
+ failStr = List.concatMap (\(a, r) -> ["Failed: ", renderMetadataAddress a, "; ", renderLineResponse r, "\r\n"]) rfail
|
|
|
unrec = m^.unrecognized
|
|
|
h = [
|
|
|
"Action: ", show act, "\r\n",
|
|
@@ -113,7 +114,7 @@ renderMetadata m = BS.concat serialize
|
|
|
"Client-Port: ", show $ cid^.clientPort, "\r\n",
|
|
|
"Client-Name: ", fromTextual cnm, "\r\n",
|
|
|
"Return-Path: ", fromTextual . normalAccountName $ rfm, "\r\n",
|
|
|
- "Recv-Date: ", formatISO8601 $ rcv, "\r\n",
|
|
|
+ "Recv-Date: ", formatISO8601 rcv, "\r\n",
|
|
|
"Body-Encoding: ", show enc, "\r\n",
|
|
|
"SMTP-UTF8: ", if utf then "Yes" else "No", "\r\n",
|
|
|
"Data-Size: ", show sz, "\r\n"
|
|
@@ -131,58 +132,57 @@ parseMetadata = do
|
|
|
return $ ClientIdentity h p
|
|
|
m = set mclientId i m'
|
|
|
case strictMetadata m of
|
|
|
- Just s -> return s
|
|
|
+ Just sm -> return sm
|
|
|
Nothing -> fail "missing required fields"
|
|
|
where
|
|
|
parseField :: Parser ((MaybeMetadata, Maybe IP, Maybe Int) -> (MaybeMetadata, Maybe IP, Maybe Int))
|
|
|
- parseField = do
|
|
|
- A.choice [
|
|
|
- do
|
|
|
- act <- hdr "Action" parseEnumCI
|
|
|
- return $ \(m, ip, p) -> (set maction (Just act) m, ip, p),
|
|
|
- do
|
|
|
- ip <- hdr "Client-Ip" parseRead
|
|
|
- return $ \(m, _, p) -> (m, Just ip, p),
|
|
|
- do
|
|
|
- p <- hdr "Client-Port" parseRead
|
|
|
- return $ \(m, ip, _) -> (m, ip, Just p),
|
|
|
- do
|
|
|
- nm <- hdr "Client-Name" (A.takeTill A.isSpace)
|
|
|
- return $ \(m, ip, p) -> (set mclientName (Just nm) m, ip, p),
|
|
|
- do
|
|
|
- frm <- hdr "Return-Path" parseAccount
|
|
|
- return $ \(m, ip, p) -> (set mmailFrom (Just frm) m, ip, p),
|
|
|
- do
|
|
|
- rtp <- hdr "To" parseAddress
|
|
|
- return $ \(m, ip, p) -> let
|
|
|
- crtp = m^.mrcptTo
|
|
|
- in (set mrcptTo (rtp:crtp) m, ip, p),
|
|
|
- do
|
|
|
- rfl <- hdr "Failed" parseAddressingReason
|
|
|
- return $ \(m, ip, p) -> let
|
|
|
- fld = m^.mrcptFailed
|
|
|
- in (set mrcptFailed (rfl:fld) m, ip, p),
|
|
|
- do
|
|
|
- recv <- hdr "Recv-Date" parseISO8601Val
|
|
|
- return $ \(m, ip, p) -> (set mrecvDate (Just recv) m, ip, p),
|
|
|
- do
|
|
|
- enc <- hdr "Body-Encoding" Mime.parseBodyEncoding
|
|
|
- return $ \(m, ip, p) -> (set mbodyEnc enc m, ip, p),
|
|
|
- do
|
|
|
- utf <- hdr "SMTP-UTF8" parseMetadataBool
|
|
|
- return $ \(m, ip, p) -> (set msmtpUtf8 utf m, ip, p),
|
|
|
- do
|
|
|
- usr <- hdr "Auth-User" A.takeByteString
|
|
|
- return $ \(m, ip, p) -> (set mauth (Just usr) m, ip, p),
|
|
|
- do
|
|
|
- sz <- hdr "Data-Size" A.decimal
|
|
|
- return $ \(m, ip, p) -> (set mdataSize (Just sz) m, ip, p),
|
|
|
- do
|
|
|
- u <- entireHdr
|
|
|
- return $ \(m, ip, p) -> let
|
|
|
- uu = m^.munrecognized
|
|
|
- in (set munrecognized (u:uu) m, ip, p)
|
|
|
- ]
|
|
|
+ parseField = A.choice [
|
|
|
+ do
|
|
|
+ act <- hdr "Action" parseEnumCI
|
|
|
+ return $ \(m, ip, p) -> (set maction (Just act) m, ip, p),
|
|
|
+ do
|
|
|
+ ip <- hdr "Client-Ip" parseRead
|
|
|
+ return $ \(m, _, p) -> (m, Just ip, p),
|
|
|
+ do
|
|
|
+ p <- hdr "Client-Port" parseRead
|
|
|
+ return $ \(m, ip, _) -> (m, ip, Just p),
|
|
|
+ do
|
|
|
+ nm <- hdr "Client-Name" (A.takeTill A.isSpace)
|
|
|
+ return $ \(m, ip, p) -> (set mclientName (Just nm) m, ip, p),
|
|
|
+ do
|
|
|
+ frm <- hdr "Return-Path" parseAccount
|
|
|
+ return $ \(m, ip, p) -> (set mmailFrom (Just frm) m, ip, p),
|
|
|
+ do
|
|
|
+ rtp <- hdr "To" parseAddress
|
|
|
+ return $ \(m, ip, p) -> let
|
|
|
+ crtp = m^.mrcptTo
|
|
|
+ in (set mrcptTo (rtp:crtp) m, ip, p),
|
|
|
+ do
|
|
|
+ rfl <- hdr "Failed" parseAddressingReason
|
|
|
+ return $ \(m, ip, p) -> let
|
|
|
+ fld = m^.mrcptFailed
|
|
|
+ in (set mrcptFailed (rfl:fld) m, ip, p),
|
|
|
+ do
|
|
|
+ recv <- hdr "Recv-Date" parseISO8601Val
|
|
|
+ return $ \(m, ip, p) -> (set mrecvDate (Just recv) m, ip, p),
|
|
|
+ do
|
|
|
+ enc <- hdr "Body-Encoding" Mime.parseBodyEncoding
|
|
|
+ return $ \(m, ip, p) -> (set mbodyEnc enc m, ip, p),
|
|
|
+ do
|
|
|
+ utf <- hdr "SMTP-UTF8" parseMetadataBool
|
|
|
+ return $ \(m, ip, p) -> (set msmtpUtf8 utf m, ip, p),
|
|
|
+ do
|
|
|
+ usr <- hdr "Auth-User" A.takeByteString
|
|
|
+ return $ \(m, ip, p) -> (set mauth (Just usr) m, ip, p),
|
|
|
+ do
|
|
|
+ sz <- hdr "Data-Size" A.decimal
|
|
|
+ return $ \(m, ip, p) -> (set mdataSize (Just sz) m, ip, p),
|
|
|
+ do
|
|
|
+ u <- entireHdr
|
|
|
+ return $ \(m, ip, p) -> let
|
|
|
+ uu = m^.munrecognized
|
|
|
+ in (set munrecognized (u:uu) m, ip, p)
|
|
|
+ ]
|
|
|
entireHdr :: Parser ByteString
|
|
|
entireHdr = do
|
|
|
a <- A.satisfy (not . A.isEndOfLine . asW8)
|
|
@@ -211,7 +211,7 @@ parseMetadata = do
|
|
|
skipHorizontalSpace
|
|
|
t <- bsval
|
|
|
r <- case A.parseOnly f t of
|
|
|
- Left _ -> failParser
|
|
|
+ Left _ -> fail $ "failed parsing value of " ++ s pt
|
|
|
Right v -> return v
|
|
|
skipHorizontalSpace
|
|
|
return r
|
|
@@ -224,19 +224,18 @@ parseMetadata = do
|
|
|
parseRead = do
|
|
|
v <- A.takeTill A.isSpace
|
|
|
case readMaybe . fromTextual $ v of
|
|
|
- Nothing -> failParser
|
|
|
+ Nothing -> fail "failed parsing value"
|
|
|
Just i -> return i
|
|
|
parseISO8601Val = do
|
|
|
v <- A.takeTill A.isSpace
|
|
|
case parseISO8601 . fromTextual $ v of
|
|
|
- Nothing -> failParser
|
|
|
+ Nothing -> fail "failed parsing ISO8601 date"
|
|
|
Just t -> return t
|
|
|
parseMetadataBool :: Parser Bool
|
|
|
- parseMetadataBool = do
|
|
|
- A.choice [
|
|
|
- A.stringCI "YES" *> return True,
|
|
|
- A.stringCI "NO" *> return False
|
|
|
- ]
|
|
|
+ parseMetadataBool = A.choice [
|
|
|
+ A.stringCI "YES" *> return True,
|
|
|
+ A.stringCI "NO" *> return False
|
|
|
+ ]
|
|
|
parseAddressingReason :: Parser (Address, Response)
|
|
|
parseAddressingReason = do
|
|
|
a <- parseMetadataAddress
|