Browse Source

Added MaybeMetadata for incomplete data

Marcos Dumay de Medeiros 8 years ago
parent
commit
0ffd2846b1
2 changed files with 92 additions and 73 deletions
  1. 9 10
      src/Walrus/Backend.hs
  2. 83 63
      src/Walrus/Backend/Metadata.hs

+ 9 - 10
src/Walrus/Backend.hs

@@ -59,16 +59,15 @@ parseBackend = do
       return p
 
 runBackend :: Backend -> (Metadata, LBS.ByteString) -> IO (Either String (Metadata, LBS.ByteString))
-runBackend b (m, qdt) = case renderMetadata m of
-  Nothing -> return $ Left "Metadata error"
-  Just rm -> do
-    edt' <- intBk b $ LBS.concat [
-      fromText rm,
-      "\r\n",
-      qdt]
-    case LA.parse repParse edt' of
-      LA.Fail _ _ e -> return $ Left e
-      LA.Done edt m' -> return $ Right (m', edt)
+runBackend b (m, qdt) = do
+  let rm = renderMetadata m
+  edt' <- intBk b $ LBS.concat [
+    fromText rm,
+    "\r\n",
+    qdt]
+  case LA.parse repParse edt' of
+    LA.Fail _ _ e -> return $ Left e
+    LA.Done edt m' -> return $ Right (m', edt)
   where
     intBk :: Backend -> LBS.ByteString -> IO LBS.ByteString
     intBk (TCPBackend h p) = runTcp h p

+ 83 - 63
src/Walrus/Backend/Metadata.hs

@@ -20,7 +20,6 @@ import Control.Applicative
 import Control.Lens
 
 import Text.Read (readMaybe)
-import Data.Maybe (isJust)
 
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
@@ -31,78 +30,98 @@ import qualified Data.List as List
 data BackendAction = DATA deriving (Show, Read, Eq, Ord, Bounded, Enum)
 data ClientIdentity = ClientIdentity {_clientIp :: IP, _clientPort :: Int} deriving (Show, Read, Ord, Eq)
 
-data Metadata = Metadata {_clientId :: Maybe ClientIdentity, _clientName :: Maybe ByteString,
-                          _mailFrom :: Maybe Account, _rcptTo :: [Address], _rcptFailed :: [(Address, Response)],
-                          _auth :: Maybe ByteString, _recvDate :: Maybe UTCTime, _bodyEnc :: Mime.BodyEncoding,
-                          _smtpUtf8 :: Bool, _action :: Maybe BackendAction, _unrecognized :: [ByteString]
+data MaybeMetadata = MaybeMetadata {_mclientId :: Maybe ClientIdentity, _mclientName :: Maybe ByteString,
+                                    _mmailFrom :: Maybe Account, _mrcptTo :: [Address], _mrcptFailed :: [(Address, Response)],
+                                    _mauth :: Maybe ByteString, _mrecvDate :: Maybe UTCTime, _mbodyEnc :: Mime.BodyEncoding,
+                                    _msmtpUtf8 :: Bool, _maction :: Maybe BackendAction, _munrecognized :: [ByteString]
+                                   } deriving (Show, Ord, Eq)
+
+data Metadata = Metadata {_clientId :: ClientIdentity, _clientName :: ByteString,
+                          _mailFrom :: Account, _rcptTo :: [Address], _rcptFailed :: [(Address, Response)],
+                          _auth :: Maybe ByteString, _recvDate :: UTCTime, _bodyEnc :: Mime.BodyEncoding,
+                          _smtpUtf8 :: Bool, _action :: BackendAction, _unrecognized :: [ByteString]
                          } deriving (Show, Ord, Eq)
 
 makeLenses ''ClientIdentity
+makeLenses ''MaybeMetadata
 makeLenses ''Metadata
 
-instance Default Metadata where
-  def = Metadata Nothing Nothing Nothing [] [] Nothing Nothing Mime.B7BitEncoding False Nothing []
+instance Default MaybeMetadata where
+  def = MaybeMetadata Nothing Nothing Nothing [] [] Nothing Nothing Mime.B7BitEncoding False Nothing []
+
+metadataForClient :: IP -> Int -> MaybeMetadata
+metadataForClient c p = def & mclientId .~ (Just (ClientIdentity c p))
+resetMetadata :: MaybeMetadata -> MaybeMetadata
+resetMetadata d = def & mclientId .~ d^.mclientId & mclientName .~ d^.mclientName
 
-metadataForClient :: IP -> Int -> Metadata
-metadataForClient c p = def & clientId .~ (Just (ClientIdentity c p))
-resetMetadata :: Metadata -> Metadata
-resetMetadata d = def & clientId .~ d^.clientId & clientName .~ d^.clientName
+strictMetadata :: MaybeMetadata -> Maybe Metadata
+strictMetadata m = do
+  act <- m^.maction
+  cid <- m^.mclientId
+  cnm <- m^.mclientName
+  rfm <- m^.mmailFrom
+  let rto = m^.mrcptTo
+      rfail = m^.mrcptFailed
+      usr = m^.mauth
+  rcv <- m^.mrecvDate
+  let enc = m^.mbodyEnc
+      utf = m^.msmtpUtf8
+      unrq = m^.munrecognized
+  return $ Metadata cid cnm rfm rto rfail usr rcv enc utf act unrq
 
-renderMetadata :: Metadata -> Maybe ByteString
-renderMetadata m = BS.concat . map fromText <$> serialize
+renderMetadata :: Metadata -> ByteString
+renderMetadata m = BS.concat serialize
   where
-    serialize :: Maybe [ByteString]
-    serialize = do
-      act <- m^.action
-      cid <- m^.clientId
-      cnm <- m^.clientName
-      rfm <- m^.mailFrom
-      let rto = m^.rcptTo
-          rfail = m^.rcptFailed
-          usr = m^.auth
-      rcv <- m^.recvDate
-      let enc = m^.bodyEnc
-          utf = m^.smtpUtf8
-          usrStr = case usr of
-            Nothing -> []
-            Just u -> ["Auth-User: ", u, "\r\n"]
-      let toStr = List.concat $ map (\x -> ["To: ", renderMetadataAddress $ x, "\r\n"]) rto
-          failStr = List.concat $ map (\(a, r) -> ["Failed: ", renderMetadataAddress a, "; ", renderResponse r, "\r\n"]) rfail
-      let unrec = m^.unrecognized
-      let h = [
-            "Action: ", show act, "\r\n",
-            "Client-Ip: ", show $ cid^.clientIp, "\r\n",
-            "Client-Port: ", show $ cid^.clientPort, "\r\n",
-            "Client-Name: ", fromText cnm, "\r\n",
-            "Return-Path: ", fromText . normalAccountName $ rfm, "\r\n",
-            "Recv-Date: ", formatISO8601 $ rcv, "\r\n",
-            "Body-Encoding: ", show $ enc, "\r\n",
-            "SMTP-UTF8: ", if utf then "Yes" else "No", "\r\n"
-            ] :: [String]
-      return $ map fromText h ++ toStr ++ failStr ++ usrStr ++ unrec
-
-isMetadataComplete :: Metadata -> Bool
-isMetadataComplete = isJust . renderMetadata
+    serialize :: [ByteString]
+    serialize = let
+      act = m^.action
+      cid = m^.clientId
+      cnm = m^.clientName
+      rfm = m^.mailFrom
+      rto = m^.rcptTo
+      rfail = m^.rcptFailed
+      usr = m^.auth
+      rcv = m^.recvDate
+      enc = m^.bodyEnc
+      utf = m^.smtpUtf8
+      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, "; ", renderResponse r, "\r\n"]) rfail
+      unrec = m^.unrecognized
+      h = [
+        "Action: ", show act, "\r\n",
+        "Client-Ip: ", show $ cid^.clientIp, "\r\n",
+        "Client-Port: ", show $ cid^.clientPort, "\r\n",
+        "Client-Name: ", fromText cnm, "\r\n",
+        "Return-Path: ", fromText . normalAccountName $ rfm, "\r\n",
+        "Recv-Date: ", formatISO8601 $ rcv, "\r\n",
+        "Body-Encoding: ", show $ enc, "\r\n",
+        "SMTP-UTF8: ", if utf then "Yes" else "No", "\r\n"
+        ] :: [String]
+      in map fromText h ++ toStr ++ failStr ++ usrStr ++ unrec
 
 parseMetadata :: A.Parser Metadata
 parseMetadata = do
   (m', h', p') <- parserFold parseField (def, Nothing, Nothing)
+  A.endOfLine
   let i = do
         h <- h'
         p <- p'
         return $ ClientIdentity h p
-      m = set clientId i m'
-  if isMetadataComplete m
-    then return m
-    else failParser
+      m = set mclientId i m'
+  case strictMetadata m of
+    Just s -> return s
+    Nothing -> failParser
   where
-    parseField :: Parser ((Metadata, Maybe IP, Maybe Int) -> (Metadata, Maybe IP, Maybe Int))
+    parseField :: Parser ((MaybeMetadata, Maybe IP, Maybe Int) -> (MaybeMetadata, Maybe IP, Maybe Int))
     parseField = do
       skipHorizontalSpace
       A.choice [
         do
           act <- hdr "Action" parseEnumCI
-          return $ \(m, ip, p) -> (set action (Just act) m, ip, p),
+          return $ \(m, ip, p) -> (set maction (Just act) m, ip, p),
         do
           ip <- hdr "Client-Ip" parseRead
           return $ \(m, _, p) -> (m, ip, p),
@@ -111,40 +130,41 @@ parseMetadata = do
           return $ \(m, ip, _) -> (m, ip, p),
         do
           nm <- hdr "Client-Name" bsval
-          return $ \(m, ip, p) -> (set clientName (Just nm) m, ip, p),
+          return $ \(m, ip, p) -> (set mclientName (Just nm) m, ip, p),
         do
           frm <- hdr "Return-Path" parseAccountVal
-          return $ \(m, ip, p) -> (set mailFrom (Just frm) m, ip, p),
+          return $ \(m, ip, p) -> (set mmailFrom (Just frm) m, ip, p),
         do
           rtp <- hdr "To" parseAddressingVal
           return $ \(m, ip, p) -> let
-            crtp = m^.rcptTo
-            in (set rcptTo (rtp:crtp) m, ip, p),
+            crtp = m^.mrcptTo
+            in (set mrcptTo (rtp:crtp) m, ip, p),
         do
           rfl <- hdr "Failed" (parseAddressingReason)
           return $ \(m, ip, p) -> let
-            fld = m^.rcptFailed
-            in (set rcptFailed (rfl:fld) m, ip, p),
+            fld = m^.mrcptFailed
+            in (set mrcptFailed (rfl:fld) m, ip, p),
         do
           recv <- hdr "Recv-Date" parseISO8601Val
-          return $ \(m, ip, p) -> (set recvDate (Just recv) m, ip, p),
+          return $ \(m, ip, p) -> (set mrecvDate (Just recv) m, ip, p),
         do
           enc <- hdr "Body-Encoding" parseEncodingVal
-          return $ \(m, ip, p) -> (set bodyEnc enc m, ip, p),
+          return $ \(m, ip, p) -> (set mbodyEnc enc m, ip, p),
         do
           utf <- hdr "SMTP-UTF8" parseBoolVal
-          return $ \(m, ip, p) -> (set smtpUtf8 utf m, ip, p),
+          return $ \(m, ip, p) -> (set msmtpUtf8 utf m, ip, p),
         do
           usr <- hdr "Auth-User" bsval
-          return $ \(m, ip, p) -> (set auth (Just usr) m, ip, p),
+          return $ \(m, ip, p) -> (set mauth (Just usr) m, ip, p),
         do
           u <- entireHdr
           return $ \(m, ip, p) -> let
-            uu = m^.unrecognized
-            in (set unrecognized (u:uu) m, ip, p)
+            uu = m^.munrecognized
+            in (set munrecognized (u:uu) m, ip, p)
         ]
     entireHdr :: Parser ByteString
     entireHdr = do
+      A.satisfy (not . A.isEndOfLine . asW8)
       t <- A.takeTill (A.isEndOfLine . asW8)
       A.endOfLine
       l <- takeLines