Corrections on parser

src/Walrus/Backend/Metadata.hs

@@ -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)