-- | Parsers for IMAP server responses module Network.HaskellNet.IMAP.Parsers ( eval , eval' , pNone , pCapability , pSelect , pList , pLsub , pStatus , pExpunge , pSearch , pFetch ) where import Text.Packrat.Parse hiding (space, spaces) import Text.Packrat.Pos import Data.Maybe import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Network.HaskellNet.IMAP.Types eval :: (RespDerivs -> Result RespDerivs r) -> String -> ByteString -> r eval pMain tag s = case pMain (parse tag (Pos tag 1 1) s) of Parsed v _ _ -> v NoParse e -> error (show e) parse :: String -> Pos -> ByteString -> RespDerivs parse tagstr pos s = d where d = RespDerivs flag tag chr pos flag = pParenFlags d tag = Parsed tagstr d (nullError d) chr = if BS.null s then NoParse (eofError d) else let (c, s') = (BS.head s, BS.tail s) in Parsed c (parse tagstr (nextPos pos c) s') (nullError d) eval' :: (RespDerivs -> Result RespDerivs r) -> String -> String -> r eval' pMain tag s = case pMain (parse' tag (Pos tag 1 1) s) of Parsed v _ _ -> v NoParse e -> error (show e) parse' :: String -> Pos -> String -> RespDerivs parse' tagstr pos s = d where d = RespDerivs flag tag chr pos flag = pParenFlags d tag = Parsed tagstr d (nullError d) chr = case s of (c:s') -> Parsed c (parse' tagstr (nextPos pos c) s') (nullError d) _ -> NoParse (eofError d) mkMboxUpdate :: [Either (String, Integer) b] -> (MboxUpdate, [b]) mkMboxUpdate untagged = (MboxUpdate exists' recent', others) where exists' = lookup "EXISTS" $ catLefts untagged recent' = lookup "RECENT" $ catLefts untagged others = catRights untagged pNone :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, ()) Parser pNone = do untagged <- many pOtherLine resp <- Parser pDone let (mboxUp, _) = mkMboxUpdate untagged return (resp, mboxUp, ()) pCapability :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [String]) Parser pCapability = do untagged <- many (pCapabilityLine <|> pOtherLine) resp <- Parser pDone let (mboxUp, caps) = mkMboxUpdate untagged return (resp, mboxUp, concat caps) pList :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [([Attribute], String, MailboxName)]) Parser pList = do untagged <- many (pListLine "LIST" <|> pOtherLine) resp <- Parser pDone let (mboxUp, listRes) = mkMboxUpdate untagged return (resp, mboxUp, listRes) pLsub :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [([Attribute], String, MailboxName)]) Parser pLsub = do untagged <- many (pListLine "LSUB" <|> pOtherLine) resp <- Parser pDone let (mboxUp, listRes) = mkMboxUpdate untagged return (resp, mboxUp, listRes) pStatus :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [(MailboxStatus, Integer)]) Parser pStatus = do untagged <- many (pStatusLine <|> pOtherLine) resp <- Parser pDone let (mboxUp, statRes) = mkMboxUpdate untagged return (resp, mboxUp, concat statRes) pExpunge :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [Integer]) Parser pExpunge = do untagged <- many ((do string "* " n <- pExpungeLine return $ Right ("EXPUNGE", n)) <|> pOtherLine) resp <- Parser pDone let (mboxUp, expunges) = mkMboxUpdate untagged return (resp, mboxUp, lookups "EXPUNGE" expunges) pSearch :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [UID]) Parser pSearch = do untagged <- many (pSearchLine <|> pOtherLine) resp <- Parser pDone let (mboxUp, searchRes) = mkMboxUpdate untagged return (resp, mboxUp, concat searchRes) pSelect :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, MailboxInfo) Parser pSelect = do untagged <- many (pSelectLine <|> (do string "* " anyChar `manyTill` crlfP return id)) resp <- Parser pDone let box = case resp of OK writable _ -> emptyBox { _isWritable = isJust writable && fromJust writable == READ_WRITE } _ -> emptyBox return (resp, MboxUpdate Nothing Nothing, foldl (flip ($)) box untagged) where emptyBox = MboxInfo "" 0 0 [] [] False False 0 0 pFetch :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [(Integer, [(String, String)])]) Parser pFetch = do untagged <- many (pFetchLine <|> pOtherLine) resp <- Parser pDone let (mboxUp, fetchRes) = mkMboxUpdate untagged return (resp, mboxUp, fetchRes) pDone :: RespDerivs -> Result RespDerivs ServerResponse Parser pDone = do tag <- Parser advTag string tag >> space respCode <- parseCode space stat <- optional (do s <- parseStatusCode space >> return s) body <- anyChar `manyTill` crlfP return $ respCode stat body where parseCode = choice $ [ string "OK" >> return OK , string "NO" >> return NO , string "BAD" >> return BAD , string "PREAUTH" >> return PREAUTH ] parseStatusCode = between (char '[') (char ']') $ choice [ string "ALERT" >> return ALERT , do { string "BADCHARSET" ; ws <- optional parenWords ; return $ BADCHARSET $ fromMaybe [] ws } , do { string "CAPABILITY" ; space ; ws <- (many1 $ noneOf " ]") `sepBy1` space ; return $ CAPABILITY_sc ws } , string "PARSE" >> return PARSE , do { string "PERMANENTFLAGS" >> space >> char '(' ; fs <- pFlag `sepBy1` spaces1 ; char ')' ; return $ PERMANENTFLAGS fs } , string "READ-ONLY" >> return READ_ONLY , string "READ-WRITE" >> return READ_WRITE , string "TRYCREATE" >> return TRYCREATE , do { string "UNSEEN" >> space ; num <- many1 digit ; return $ UNSEEN_sc $ read num } , do { string "UIDNEXT" >> space ; num <- many1 digit ; return $ UIDNEXT_sc $ read num } , do { string "UIDVALIDITY" >> space ; num <- many1 digit ; return $ UIDVALIDITY_sc $ read num } ] parenWords = between (space >> char '(') (char ')') (many1 (noneOf " )") `sepBy1` space) pFlag :: Parser RespDerivs Flag pFlag = do char '\\' choice [ string "Seen" >> return Seen , string "Answered" >> return Answered , string "Flagged" >> return Flagged , string "Deleted" >> return Deleted , string "Draft" >> return Draft , string "Recent" >> return Recent , char '*' >> return (Keyword "*") , many1 atomChar >>= return . Keyword ] <|> (many1 atomChar >>= return . Keyword) pParenFlags :: RespDerivs -> Result RespDerivs [Flag] Parser pParenFlags = do char '(' fs <- pFlag `sepBy` space char ')' return fs atomChar :: Derivs d => Parser d Char atomChar = noneOf " (){%*\"\\]" pNumberedLine :: String -> Parser RespDerivs Integer pNumberedLine str = do num <- many1 digit space string str crlfP return $ read num pExistsLine, pRecentLine, pExpungeLine :: Parser RespDerivs Integer pExistsLine = pNumberedLine "EXISTS" pRecentLine = pNumberedLine "RECENT" pExpungeLine = pNumberedLine "EXPUNGE" pOtherLine :: Parser RespDerivs (Either (String, Integer) b) pOtherLine = do string "* " choice [ pExistsLine >>= \n -> return (Left ("EXISTS", n)) , pRecentLine >>= \n -> return (Left ("RECENT", n)) , blankLine >> return (Left ("", 0))] where blankLine = anyChar `manyTill` crlfP pCapabilityLine :: Parser RespDerivs (Either a [String]) pCapabilityLine = do string "* CAPABILITY " ws <- many1 (noneOf " \r") `sepBy` space crlfP return $ Right ws pListLine :: String -> Parser RespDerivs (Either a ([Attribute], String, MailboxName)) pListLine list = do string "* " >> string list >> space attrs <- parseAttrs sep <- parseSep mbox <- parseMailbox return $ Right (attrs, sep, mbox) where parseAttr = do char '\\' choice [ string "Noinferior" >> return Noinferiors , string "Noselect" >> return Noselect , string "Marked" >> return Marked , string "Unmarked" >> return Unmarked , many atomChar >>= return . OtherAttr ] parseAttrs = do char '(' attrs <- parseAttr `sepBy` space char ')' return attrs parseSep = space >> char '"' >> anyChar `manyTill` char '"' parseMailbox = space >> anyChar `manyTill` crlfP pStatusLine :: Parser RespDerivs (Either a [(MailboxStatus, Integer)]) pStatusLine = do string "* STATUS " _ <- anyChar `manyTill` space stats <- between (char '(') (char ')') (parseStat `sepBy1` space) crlfP return $ Right stats where parseStat = do cons <- choice [ string "MESSAGES" >>= return . read , string "RECENT" >>= return . read , string "UIDNEXT" >>= return . read , string "UIDVALIDITY" >>= return . read ] space num <- many1 digit >>= return . read return (cons, num) pSearchLine :: Parser RespDerivs (Either a [UID]) pSearchLine = do string "* SEARCH " nums <- (many1 digit) `sepBy` space crlfP return $ Right $ map read nums pSelectLine :: Parser RespDerivs (MailboxInfo -> MailboxInfo) pSelectLine = do string "* " choice [ pExistsLine >>= \n -> return (\mbox -> mbox { _exists = n }) , pRecentLine >>= \n -> return (\mbox -> mbox { _recent = n }) , pFlags >>= \fs -> return (\mbox -> mbox { _flags = fs }) , string "OK " >> okResps ] where pFlags = do string "FLAGS " char '(' fs <- pFlag `sepBy` space char ')' >> crlfP return fs okResps = do char '[' v <- choice [ do { string "UNSEEN " ; many1 digit ; return id } , do { string "PERMANENTFLAGS (" ; fs <- pFlag `sepBy` space ; char ')' ; return $ \mbox -> mbox { _isFlagWritable = Keyword "*" `elem` fs , _permanentFlags = filter (/= Keyword "*") fs } } , do { string "UIDNEXT " ; n <- many1 digit ; return $ \mbox -> mbox { _uidNext = read n } } , do { string "UIDVALIDITY " ; n <- many1 digit ; return $ \mbox -> mbox { _uidValidity = read n } } ] char ']' anyChar `manyTill` crlfP return v pFetchLine :: Parser RespDerivs (Either a (Integer, [(String, String)])) pFetchLine = do string "* " num <- many1 digit string " FETCH" >> spaces char '(' pairs <- pPair `sepBy` space char ')' crlfP return $ Right $ (read num, pairs) where pPair = do key <- anyChar `manyTill` space value <- (do char '(' v <- pParen `sepBy` space char ')' return ("("++unwords v++")")) <|> (do char '{' num <- many1 digit >>= return . read char '}' >> crlfP sequence $ replicate num anyChar) <|> (do char '"' v <- noneOf "\"" `manyTill` char '"' return ("\""++v++"\"")) <|> many1 atomChar return (key, value) pParen = (do char '"' v <- noneOf "\"" `manyTill` char '"' return ("\""++v++"\"")) <|> (do char '(' v <- pParen `sepBy` space char ')' return ("("++unwords v++")")) <|> (do char '\\' v <- many1 atomChar return ('\\':v)) <|> many1 atomChar ---------------------------------------------------------------------- -- auxiliary parsers space :: Parser RespDerivs Char space = char ' ' spaces, spaces1 :: Parser RespDerivs String spaces = many space spaces1 = many1 space crlf :: String crlf = "\r\n" crlfP :: Derivs d => Parser d String crlfP = string crlf lookups :: Eq a => a -> [(a, b)] -> [b] lookups _ [] = [] lookups k ((k', v):tl) | k == k' = v : lookups k tl | otherwise = lookups k tl ---- Either handling catRights :: [Either a b] -> [b] catRights [] = [] catRights (Right r:tl) = r : catRights tl catRights (_:tl) = catRights tl catLefts :: [Either a b] -> [a] catLefts [] = [] catLefts (Left r:tl) = r : catLefts tl catLefts (_:tl) = catLefts tl