|
@@ -25,8 +25,11 @@ import Data.Attoparsec.ByteString.Char8 (Parser)
|
|
|
import qualified Data.Attoparsec.ByteString.Char8 as A
|
|
|
import Data.Attoparsec.ByteString.Char8.Extras
|
|
|
import qualified Data.ByteString as BS
|
|
|
+import qualified Data.ByteString.Char8 as C8
|
|
|
import qualified Data.List as List
|
|
|
|
|
|
+import Debug.Trace
|
|
|
+
|
|
|
data BackendAction = DATA deriving (Show, Read, Eq, Ord, Bounded, Enum)
|
|
|
data ClientIdentity = ClientIdentity {_clientIp :: IP, _clientPort :: Int} deriving (Show, Read, Ord, Eq)
|
|
|
|
|
@@ -117,58 +120,70 @@ parseMetadata = do
|
|
|
where
|
|
|
parseField :: Parser ((MaybeMetadata, Maybe IP, Maybe Int) -> (MaybeMetadata, Maybe IP, Maybe Int))
|
|
|
parseField = do
|
|
|
- skipHorizontalSpace
|
|
|
A.choice [
|
|
|
do
|
|
|
act <- hdr "Action" parseEnumCI
|
|
|
+ trace "Action" $ return ()
|
|
|
return $ \(m, ip, p) -> (set maction (Just act) m, ip, p),
|
|
|
do
|
|
|
ip <- hdr "Client-Ip" parseRead
|
|
|
- return $ \(m, _, p) -> (m, ip, p),
|
|
|
+ trace "Client-Ip" $ return ()
|
|
|
+ return $ \(m, _, p) -> (m, Just ip, p),
|
|
|
do
|
|
|
p <- hdr "Client-Port" parseRead
|
|
|
- return $ \(m, ip, _) -> (m, ip, p),
|
|
|
+ trace "Client-Port" $ return ()
|
|
|
+ return $ \(m, ip, _) -> (m, ip, Just p),
|
|
|
do
|
|
|
- nm <- hdr "Client-Name" bsval
|
|
|
+ nm <- hdr "Client-Name" (A.takeTill A.isSpace)
|
|
|
+ trace "Client-Name" $ return ()
|
|
|
return $ \(m, ip, p) -> (set mclientName (Just nm) m, ip, p),
|
|
|
do
|
|
|
- frm <- hdr "Return-Path" parseAccountVal
|
|
|
+ frm <- hdr "Return-Path" parseAccount
|
|
|
+ trace "Return-Path" $ return ()
|
|
|
return $ \(m, ip, p) -> (set mmailFrom (Just frm) m, ip, p),
|
|
|
do
|
|
|
- rtp <- hdr "To" parseAddressingVal
|
|
|
+ rtp <- hdr "To" parseAddress
|
|
|
+ trace "To" $ return ()
|
|
|
return $ \(m, ip, p) -> let
|
|
|
crtp = m^.mrcptTo
|
|
|
in (set mrcptTo (rtp:crtp) m, ip, p),
|
|
|
do
|
|
|
- rfl <- hdr "Failed" (parseAddressingReason)
|
|
|
+ rfl <- hdr "Failed" parseAddressingReason
|
|
|
+ trace "Failed" $ return ()
|
|
|
return $ \(m, ip, p) -> let
|
|
|
fld = m^.mrcptFailed
|
|
|
in (set mrcptFailed (rfl:fld) m, ip, p),
|
|
|
do
|
|
|
recv <- hdr "Recv-Date" parseISO8601Val
|
|
|
+ trace "Recv-Date" $ return ()
|
|
|
return $ \(m, ip, p) -> (set mrecvDate (Just recv) m, ip, p),
|
|
|
do
|
|
|
- enc <- hdr "Body-Encoding" parseEncodingVal
|
|
|
+ enc <- hdr "Body-Encoding" Mime.parseBodyEncoding
|
|
|
+ trace "Body-Encoding" $ return ()
|
|
|
return $ \(m, ip, p) -> (set mbodyEnc enc m, ip, p),
|
|
|
do
|
|
|
- utf <- hdr "SMTP-UTF8" parseBoolVal
|
|
|
+ utf <- hdr "SMTP-UTF8" parseMetadataBool
|
|
|
+ trace "SMTP-UTF8" $ return ()
|
|
|
return $ \(m, ip, p) -> (set msmtpUtf8 utf m, ip, p),
|
|
|
do
|
|
|
usr <- hdr "Auth-User" bsval
|
|
|
+ trace "Auth-User" $ return ()
|
|
|
return $ \(m, ip, p) -> (set mauth (Just usr) m, ip, p),
|
|
|
do
|
|
|
u <- entireHdr
|
|
|
+ trace "Unknown" $ return ()
|
|
|
+ trace (show u) $ return ()
|
|
|
return $ \(m, ip, p) -> let
|
|
|
uu = m^.munrecognized
|
|
|
in (set munrecognized (u:uu) m, ip, p)
|
|
|
]
|
|
|
entireHdr :: Parser ByteString
|
|
|
entireHdr = do
|
|
|
- A.satisfy (not . A.isEndOfLine . asW8)
|
|
|
+ a <- A.satisfy (not . A.isEndOfLine . asW8)
|
|
|
t <- A.takeTill (A.isEndOfLine . asW8)
|
|
|
A.endOfLine
|
|
|
l <- takeLines
|
|
|
- return $ BS.concat [t, "\r\n", l]
|
|
|
+ return $ BS.concat [C8.cons a t, "\r\n", l]
|
|
|
takeLines :: Parser ByteString
|
|
|
takeLines = do
|
|
|
c' <- A.peekChar
|
|
@@ -183,45 +198,34 @@ parseMetadata = do
|
|
|
else return ""
|
|
|
hdr :: ByteString -> Parser a -> Parser a
|
|
|
hdr pt f = do
|
|
|
+ trace ("testing " ++ show pt) $ return ()
|
|
|
skipHorizontalSpace
|
|
|
A.stringCI pt
|
|
|
+ trace ("it's it") $ return ()
|
|
|
skipHorizontalSpace
|
|
|
A.char ':'
|
|
|
skipHorizontalSpace
|
|
|
- r <- f
|
|
|
+ t <- bsval
|
|
|
+ trace ("Will now parse value: " ++ show t) $ return ()
|
|
|
+ r <- case A.parseOnly f t of
|
|
|
+ Left _ -> failParser
|
|
|
+ Right v -> return v
|
|
|
+ trace "Got value" $ return ()
|
|
|
skipHorizontalSpace
|
|
|
- A.endOfLine
|
|
|
return r
|
|
|
bsval :: Parser ByteString
|
|
|
bsval = do
|
|
|
- v <- A.takeTill (A.isEndOfLine . asW8)
|
|
|
- A.endOfLine
|
|
|
- c' <- A.peekChar
|
|
|
- case c' of
|
|
|
- Nothing -> return v
|
|
|
- Just c -> if isCHorizontalSpace c
|
|
|
- then do
|
|
|
- v' <- bsval
|
|
|
- return $ BS.concat [v, " ", v']
|
|
|
- else return v
|
|
|
+ ll <- entireHdr
|
|
|
+ let (b, _) = BS.spanEnd (\x -> x == asW8 '\r' || x == asW8 '\n') ll
|
|
|
+ return b
|
|
|
parseRead :: Read a => Parser a
|
|
|
parseRead = do
|
|
|
- v <- bsval
|
|
|
+ v <- A.takeTill A.isSpace
|
|
|
case readMaybe . fromTextual $ v of
|
|
|
Nothing -> failParser
|
|
|
Just i -> return i
|
|
|
- parseVal :: Parser a -> Parser a
|
|
|
- parseVal p = do
|
|
|
- v <- bsval
|
|
|
- case A.parseOnly p v of
|
|
|
- Left _ -> failParser
|
|
|
- Right v' -> return v'
|
|
|
- parseAccountVal = parseVal parseAccount
|
|
|
- parseAddressingVal = parseVal parseMetadataAddress
|
|
|
- parseEncodingVal = parseVal Mime.parseBodyEncoding
|
|
|
- parseBoolVal = parseVal parseMetadataBool
|
|
|
parseISO8601Val = do
|
|
|
- v <- bsval
|
|
|
+ v <- A.takeTill A.isSpace
|
|
|
case parseISO8601 . fromTextual $ v of
|
|
|
Nothing -> failParser
|
|
|
Just t -> return t
|
|
@@ -237,5 +241,5 @@ parseMetadata = do
|
|
|
skipHorizontalSpace
|
|
|
A.char ';'
|
|
|
skipHorizontalSpace
|
|
|
- r <- parseResponse
|
|
|
+ r <- parseLineResponse
|
|
|
return (a, r)
|