From 0086c027dae462a9194ad33e62a7d378300b3093 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Sat, 13 Jun 2026 11:34:50 +0200 Subject: [PATCH 1/2] Add IMAP UIDPLUS support (RFC 4315) Adds UIDPLUS extension support so callers can recover the UIDs the server assigns on APPEND/COPY and target expunges by UID: - appendFullUID: like appendFull, returns the APPENDUID response code - copyUID / copyUIDs / copyUIDR: UID COPY returning the COPYUID code - uidExpunge / uidExpungeR: UID EXPUNGE over a UID set or range New types AppendUID and CopyUID, the UIDSet alias, and the APPENDUID/COPYUID/UIDNOTSTICKY status codes with their parsers. sendCommandWithResponse exposes the tagged ServerResponse so the response codes can be read. The existing appendFull/copyFull keep their old signatures by discarding the UID result. Covered by new parser cases in baseTest and a dedicated imapUIDPlusTest group exercising the API against scripted server responses. --- CHANGELOG | 5 ++ src/Network/HaskellNet/IMAP.hs | 78 +++++++++++++++++++++++--- src/Network/HaskellNet/IMAP/Parsers.hs | 15 +++++ src/Network/HaskellNet/IMAP/Types.hs | 25 +++++++++ test/IMAPParsersTest.hs | 64 +++++++++++++++++++++ 5 files changed, 180 insertions(+), 7 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 07570a0..8cedab4 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,8 @@ +unreleased + - added IMAP UIDPLUS support (RFC 4315): appendFullUID, copyUID, copyUIDs, + copyUIDR, uidExpunge, uidExpungeR, plus the APPENDUID/COPYUID/UIDNOTSTICKY + response codes and AppendUID/CopyUID types + 0.7 (2025-06-08) - updated to the lastest GHC, tested with 8.10.7 — 9.12.2 (PR #103) Thanks to @thomasjm diff --git a/src/Network/HaskellNet/IMAP.hs b/src/Network/HaskellNet/IMAP.hs index 29c704c..63e8639 100644 --- a/src/Network/HaskellNet/IMAP.hs +++ b/src/Network/HaskellNet/IMAP.hs @@ -8,10 +8,10 @@ module Network.HaskellNet.IMAP -- ** autenticated state commands , select, examine, create, delete, rename , subscribe, unsubscribe - , list, lsub, status, append, appendFull + , list, lsub, status, append, appendFull, appendFullUID -- ** selected state commands , check, close, expunge - , search, store, copy, move + , search, store, copy, copyUID, copyUIDs, copyUIDR, uidExpunge, uidExpungeR, move , idle -- * fetch commands , fetch, fetchHeader, fetchSize, fetchHeaderFields, fetchHeaderFieldsNot @@ -20,6 +20,7 @@ module Network.HaskellNet.IMAP , fetchPeek, fetchRPeek -- * other types , Flag(..), Attribute(..), MailboxStatus(..) + , AppendUID(..), CopyUID(..), UIDSet , SearchQuery(..), FlagsQuery(..) , A.AuthType(..) ) @@ -164,12 +165,19 @@ show6 n | n > 100000 = show n sendCommand :: IMAPConnection -> String -> (RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, v)) -> IO v -sendCommand imapc cmdstr pFunc = +sendCommand imapc cmdstr pFunc = snd <$> sendCommandWithResponse imapc cmdstr pFunc + +-- | Like 'sendCommand', but also returns the tagged 'ServerResponse' so callers +-- can inspect response codes (e.g. the UIDPLUS @COPYUID@/@APPENDUID@ codes). +sendCommandWithResponse :: IMAPConnection -> String + -> (RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, v)) + -> IO (ServerResponse, v) +sendCommandWithResponse imapc cmdstr pFunc = do (buf, num) <- sendCommand' imapc cmdstr let (resp, mboxUp, value) = eval pFunc (show6 num) buf case resp of OK _ _ -> do mboxUpdate imapc mboxUp - return value + return (resp, value) NO _ msg -> fail ("NO: " ++ msg) BAD _ msg -> fail ("BAD: " ++ msg) PREAUTH _ msg -> fail ("preauth: " ++ msg) @@ -333,6 +341,14 @@ append conn mbox mailData = appendFull conn mbox mailData Nothing Nothing appendFull :: IMAPConnection -> MailboxName -> ByteString -> Maybe [Flag] -> Maybe CalendarTime -> IO () appendFull conn mbox mailData flags' time = + appendFullUID conn mbox mailData flags' time >> return () + +-- | Like 'appendFull', but returns the UIDPLUS @APPENDUID@ response code +-- (RFC 4315) when the server supports it, identifying the UID assigned to the +-- appended message. Returns 'Nothing' on servers that don't advertise UIDPLUS. +appendFullUID :: IMAPConnection -> MailboxName -> ByteString + -> Maybe [Flag] -> Maybe CalendarTime -> IO (Maybe AppendUID) +appendFullUID conn mbox mailData flags' time = do (buf, num) <- sendCommand' conn (concat ["APPEND ", quoteMailboxName mbox , fstr, tstr, " {" ++ show len ++ "}"]) @@ -343,13 +359,16 @@ appendFull conn mbox mailData flags' time = buf2 <- getResponse $ stream conn let (resp, mboxUp, ()) = eval pNone (show6 num) buf2 case resp of - OK _ _ -> mboxUpdate conn mboxUp + OK stat _ -> do mboxUpdate conn mboxUp + return $ appendUIDFromStatus stat NO _ msg -> fail ("NO: "++msg) BAD _ msg -> fail ("BAD: "++msg) PREAUTH _ msg -> fail ("PREAUTH: "++msg) where len = BS.length mailData tstr = maybe "" ((" "++) . datetimeToStringIMAP) time fstr = maybe "" ((" ("++) . (++")") . unwords . map show) flags' + appendUIDFromStatus (Just (APPENDUID_sc appendUID')) = Just appendUID' + appendUIDFromStatus _ = Nothing check :: IMAPConnection -> IO () check conn = sendCommand conn "CHECK" pNone @@ -771,12 +790,57 @@ store :: IMAPConnection -> UID -> FlagsQuery -> IO () store conn i q = storeFull conn (show i) q True >> return () copyFull :: IMAPConnection -> String -> String -> IO () -copyFull conn uidStr mbox = - sendCommand conn ("UID COPY " ++ uidStr ++ " " ++ quoteMailboxName mbox) pNone +copyFull conn uidStr mbox = copyUIDFull conn uidStr mbox >> return () + +-- | Like 'copyFull', but returns the UIDPLUS @COPYUID@ response code (RFC 4315) +-- when the server supports it, identifying the UIDs assigned to the copied +-- messages in the destination mailbox. Returns 'Nothing' on servers that don't +-- advertise UIDPLUS. +copyUIDFull :: IMAPConnection -> String -> String -> IO (Maybe CopyUID) +copyUIDFull conn uidStr mbox = + do (resp, ()) <- sendCommandWithResponse conn ("UID COPY " ++ uidStr ++ " " ++ quoteMailboxName mbox) pNone + return $ copyUIDFromResponse resp + where + copyUIDFromResponse (OK (Just (COPYUID_sc copyUID')) _) = Just copyUID' + copyUIDFromResponse _ = Nothing copy :: IMAPConnection -> UID -> MailboxName -> IO () copy conn uid mbox = copyFull conn (show uid) mbox +-- | Copy a single message to a mailbox, returning its UIDPLUS @COPYUID@ code. +copyUID :: IMAPConnection -> UID -> MailboxName -> IO (Maybe CopyUID) +copyUID conn uid mbox = copyUIDFull conn (show uid) mbox + +-- | Copy a set of messages to a mailbox, returning the UIDPLUS @COPYUID@ code. +copyUIDs :: IMAPConnection -> [UID] -> MailboxName -> IO (Maybe CopyUID) +copyUIDs _ [] _ = fail "copyUIDs: empty UID set" +copyUIDs conn uids mbox = copyUIDFull conn (showUIDList uids) mbox + +-- | Copy a contiguous UID range (inclusive) to a mailbox, returning the +-- UIDPLUS @COPYUID@ code. +copyUIDR :: IMAPConnection -> (UID, UID) -> MailboxName -> IO (Maybe CopyUID) +copyUIDR conn range mbox = copyUIDFull conn (showUIDRange range) mbox + +-- | @UID EXPUNGE@ (RFC 4315): permanently remove only the \\Deleted messages +-- within the given UID set, leaving other \\Deleted messages untouched. Returns +-- the message sequence numbers expunged. +uidExpunge :: IMAPConnection -> [UID] -> IO [Integer] +uidExpunge _ [] = fail "uidExpunge: empty UID set" +uidExpunge conn uids = uidExpungeBySet conn $ showUIDList uids + +-- | Like 'uidExpunge' but over a contiguous UID range (inclusive). +uidExpungeR :: IMAPConnection -> (UID, UID) -> IO [Integer] +uidExpungeR conn range = uidExpungeBySet conn $ showUIDRange range + +uidExpungeBySet :: IMAPConnection -> UIDSet -> IO [Integer] +uidExpungeBySet conn uidSet = sendCommand conn ("UID EXPUNGE " ++ uidSet) pExpunge + +showUIDList :: [UID] -> UIDSet +showUIDList = intercalate "," . map show + +showUIDRange :: (UID, UID) -> UIDSet +showUIDRange (start, end) = show start ++ ":" ++ show end + move :: IMAPConnection -> UID -> MailboxName -> IO () move conn uid mboxname = sendCommand conn ("UID MOVE " ++ show uid ++ " " ++ quoteMailboxName mboxname) pNone diff --git a/src/Network/HaskellNet/IMAP/Parsers.hs b/src/Network/HaskellNet/IMAP/Parsers.hs index c3de7ba..94803dd 100644 --- a/src/Network/HaskellNet/IMAP/Parsers.hs +++ b/src/Network/HaskellNet/IMAP/Parsers.hs @@ -168,6 +168,18 @@ Parser pDone = do tag <- Parser advTag , string "READ-ONLY" >> return READ_ONLY , string "READ-WRITE" >> return READ_WRITE , string "TRYCREATE" >> return TRYCREATE + , do { string "APPENDUID" >> space + ; uidValidity <- pUID + ; space + ; uid <- pUID + ; return $ APPENDUID_sc $ AppendUID uidValidity uid } + , do { string "COPYUID" >> space + ; uidValidity <- pUID + ; space + ; sourceSet <- pUIDSet + ; space + ; destinationSet <- pUIDSet + ; return $ COPYUID_sc $ CopyUID uidValidity sourceSet destinationSet } , do { string "UNSEEN" >> space ; num <- many1 digit ; return $ UNSEEN_sc $ read num } @@ -177,9 +189,12 @@ Parser pDone = do tag <- Parser advTag , do { string "UIDVALIDITY" >> space ; num <- many1 digit ; return $ UIDVALIDITY_sc $ read num } + , string "UIDNOTSTICKY" >> return UIDNOTSTICKY ] parenWords = between (space >> char '(') (char ')') (many1 (noneOf " )") `sepBy1` space) + pUID = many1 digit >>= return . read + pUIDSet = many1 (digit <|> char ':' <|> char ',') pFlag :: Parser RespDerivs Flag pFlag = do char '\\' diff --git a/src/Network/HaskellNet/IMAP/Types.hs b/src/Network/HaskellNet/IMAP/Types.hs index ed3c1cb..362a781 100644 --- a/src/Network/HaskellNet/IMAP/Types.hs +++ b/src/Network/HaskellNet/IMAP/Types.hs @@ -2,11 +2,14 @@ module Network.HaskellNet.IMAP.Types ( MailboxName , GmailLabel , UID + , UIDSet , Charset , MailboxInfo(..) , Flag(..) , Attribute(..) , MboxUpdate(..) + , AppendUID(..) + , CopyUID(..) , StatusCode(..) , ServerResponse(..) , MailboxStatus(..) @@ -28,6 +31,7 @@ import Text.Packrat.Pos type MailboxName = String type UID = Word64 +type UIDSet = String type Charset = String type GmailLabel = String @@ -75,6 +79,24 @@ data MboxUpdate = MboxUpdate { exists :: Maybe Integer , recent :: Maybe Integer } deriving (Show, Eq) +-- | The @APPENDUID@ response code (RFC 4315 UIDPLUS): the UIDVALIDITY of the +-- destination mailbox and the UID assigned to the appended message. +data AppendUID = AppendUID + { appendUIDValidity :: UID + , appendUID :: UID + } + deriving (Show, Eq) + +-- | The @COPYUID@ response code (RFC 4315 UIDPLUS): the UIDVALIDITY of the +-- destination mailbox and the source/destination UID sets of the copied +-- messages, in matching order. +data CopyUID = CopyUID + { copyUIDValidity :: UID + , copyUIDSourceSet :: UIDSet + , copyUIDDestinationSet :: UIDSet + } + deriving (Show, Eq) + data StatusCode = ALERT | BADCHARSET [Charset] | CAPABILITY_sc [String] @@ -83,8 +105,11 @@ data StatusCode = ALERT | READ_ONLY | READ_WRITE | TRYCREATE + | APPENDUID_sc AppendUID + | COPYUID_sc CopyUID | UIDNEXT_sc UID | UIDVALIDITY_sc UID + | UIDNOTSTICKY | UNSEEN_sc Integer deriving (Eq, Show) diff --git a/test/IMAPParsersTest.hs b/test/IMAPParsersTest.hs index b4e60c1..b5a0f38 100644 --- a/test/IMAPParsersTest.hs +++ b/test/IMAPParsersTest.hs @@ -84,6 +84,15 @@ baseTest = ~=? eval' pNone "a006" "* BYE Courier-IMAP server shutting down\r\n\ \a006 OK LOGOUT completed\r\n" + ,(OK (Just (APPENDUID_sc (AppendUID 38505 3955))) "APPEND completed", MboxUpdate Nothing Nothing, ()) + ~=? eval' pNone "a003" + "a003 OK [APPENDUID 38505 3955] APPEND completed\r\n" + ,(OK (Just (COPYUID_sc (CopyUID 38505 "304,319:320" "3956:3958"))) "COPY completed", MboxUpdate Nothing Nothing, ()) + ~=? eval' pNone "a004" + "a004 OK [COPYUID 38505 304,319:320 3956:3958] COPY completed\r\n" + ,(NO (Just UIDNOTSTICKY) "UIDs are not sticky", MboxUpdate Nothing Nothing, ()) + ~=? eval' pNone "a005" + "a005 NO [UIDNOTSTICKY] UIDs are not sticky\r\n" ] capabilityTest = @@ -440,6 +449,60 @@ imapFetchTest = IMAP.store conn 42 (IMAP.PlusFlags [Seen]) ] +imapUIDPlusTest = + [ "appendFullUID returns appenduid response code" ~: TestCase $ do + let mailData = BS.pack "Subject: x\r\n\r\nBody\r\n" + expectedCommand = "000000 APPEND \"foo bar\" {" ++ show (BS.length mailData) ++ "}" + (conn, written) <- scriptedConnection + [ line "+ Ready for literal" + , okLine "[APPENDUID 38505 3955] APPEND completed" + ] + result <- IMAP.appendFullUID conn "foo bar" mailData Nothing Nothing + Just (AppendUID 38505 3955) @=? result + actual <- written + B.concat [ commandBytes expectedCommand, mailData, BS.pack "\r\n" ] @=? actual + , "copyUID returns copyuid response code" ~: TestCase $ do + (conn, written) <- scriptedConnection + [ okLine "[COPYUID 38505 42 991] COPY completed" ] + result <- IMAP.copyUID conn 42 "Archive" + Just (CopyUID 38505 "42" "991") @=? result + actual <- written + commandBytes "000000 UID COPY 42 \"Archive\"" @=? actual + , "copyUIDR sends uid range" ~: TestCase $ do + (conn, written) <- scriptedConnection + [ okLine "[COPYUID 38505 42:44 991:993] COPY completed" ] + result <- IMAP.copyUIDR conn (42, 44) "Archive" + Just (CopyUID 38505 "42:44" "991:993") @=? result + actual <- written + commandBytes "000000 UID COPY 42:44 \"Archive\"" @=? actual + , "copyUIDs sends uid set" ~: TestCase $ do + (conn, written) <- scriptedConnection + [ okLine "[COPYUID 38505 42,44 991,993] COPY completed" ] + result <- IMAP.copyUIDs conn [42, 44] "Archive" + Just (CopyUID 38505 "42,44" "991,993") @=? result + actual <- written + commandBytes "000000 UID COPY 42,44 \"Archive\"" @=? actual + , "uidExpunge sends uid set" ~: TestCase $ do + (conn, written) <- scriptedConnection + [ line "* 3 EXPUNGE" + , line "* 3 EXPUNGE" + , okLine "UID EXPUNGE completed" + ] + result <- IMAP.uidExpunge conn [3000, 3001] + [3, 3] @=? result + actual <- written + commandBytes "000000 UID EXPUNGE 3000,3001" @=? actual + , "uidExpungeR sends uid range" ~: TestCase $ do + (conn, written) <- scriptedConnection + [ line "* 4 EXPUNGE" + , okLine "UID EXPUNGE completed" + ] + result <- IMAP.uidExpungeR conn (3000, 3002) + [4] @=? result + actual <- written + commandBytes "000000 UID EXPUNGE 3000:3002" @=? actual + ] + testData = [ "base" ~: baseTest , "capability" ~: capabilityTest , "noop" ~: noopTest @@ -452,6 +515,7 @@ testData = [ "base" ~: baseTest , "imap commands" ~: imapCommandTest , "flags" ~: flagTest , "imap fetch api" ~: imapFetchTest + , "imap uidplus api" ~: imapUIDPlusTest ] From 11750ce623c1b83a740a4f22f7b430c65473e99d Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Sat, 13 Jun 2026 11:54:19 +0200 Subject: [PATCH 2/2] Make IMAP response parsing case-insensitive (RFC 3501) RFC 3501 keywords, response codes, flag names and status attributes are case-insensitive, but the parser matched them with case-sensitive `string`, so any server replying with non-canonical casing (e.g. `ok`, `* search`, `[uidvalidity ...]`, `\seen`) caused a parse error. Adds `stringCI`/`charCI` and applies them throughout the response parser. Along the way the tagged/fatal response handling is factored into `pWithTaggedOrFatal`, `pDone` is split into `pRespCode`/`pRespText`/`pStatusCode`, and string parsing is unified (`pQuotedString`/`pLiteralString`/`pAString`/`pMailboxName`). This also: - surfaces an untagged `* BYE` as a fatal response instead of failing - accepts an empty `* SEARCH` reply (no matches) - accepts a `NIL` hierarchy separator in LIST/LSUB - stops `atomChar` from running past CR/LF Covered by a new caseInsensitiveTest group. --- CHANGELOG | 4 + src/Network/HaskellNet/IMAP/Parsers.hs | 369 +++++++++++++------------ test/IMAPParsersTest.hs | 24 ++ 3 files changed, 227 insertions(+), 170 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 8cedab4..c9ed141 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -2,6 +2,10 @@ unreleased - added IMAP UIDPLUS support (RFC 4315): appendFullUID, copyUID, copyUIDs, copyUIDR, uidExpunge, uidExpungeR, plus the APPENDUID/COPYUID/UIDNOTSTICKY response codes and AppendUID/CopyUID types + - IMAP response parser is now case-insensitive for protocol keywords, + status codes and flag names (per RFC 3501); also surfaces untagged BYE as + a fatal response, accepts an empty SEARCH reply and a NIL LIST hierarchy + separator, and no longer lets atoms run past CRLF 0.7 (2025-06-08) - updated to the lastest GHC, tested with 8.10.7 — 9.12.2 (PR #103) diff --git a/src/Network/HaskellNet/IMAP/Parsers.hs b/src/Network/HaskellNet/IMAP/Parsers.hs index 94803dd..61fa8c8 100644 --- a/src/Network/HaskellNet/IMAP/Parsers.hs +++ b/src/Network/HaskellNet/IMAP/Parsers.hs @@ -17,6 +17,10 @@ where import Text.Packrat.Parse hiding (space, spaces) import Text.Packrat.Pos +import Data.Char + ( toLower + , toUpper + ) import Data.Maybe import Data.ByteString (ByteString) @@ -63,147 +67,147 @@ mkMboxUpdate untagged = (MboxUpdate exists' recent', others) 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, ()) +Parser pNone = pWithTaggedOrFatal pOtherLine (const ()) 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) +Parser pCapability = pWithTaggedOrFatal (pCapabilityLine <|> pOtherLine) concat 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) +Parser pList = pWithTaggedOrFatal (pListLine "LIST" <|> pOtherLine) id 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) +Parser pLsub = pWithTaggedOrFatal (pListLine "LSUB" <|> pOtherLine) id 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) +Parser pStatus = pWithTaggedOrFatal (pStatusLine <|> pOtherLine) concat 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) + pWithTaggedOrFatal ((do string "* " + n <- pExpungeLine + return $ Right ("EXPUNGE", n)) + <|> pOtherLine) + (lookups "EXPUNGE") 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) +Parser pSearch = pWithTaggedOrFatal (pSearchLine <|> pOtherLine) concat 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) + tagged <|> fatal where emptyBox = MboxInfo "" 0 0 [] [] False False 0 0 + tagged = + 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) + fatal = + do resp <- pFatalLine + return (resp, MboxUpdate Nothing Nothing, emptyBox) 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) +Parser pFetch = pWithTaggedOrFatal (pFetchLine <|> pOtherLine) id + +pWithTaggedOrFatal :: Parser RespDerivs (Either (String, Integer) b) + -> ([b] -> v) + -> Parser RespDerivs (ServerResponse, MboxUpdate, v) +pWithTaggedOrFatal lineParser build = tagged <|> fatal + where + tagged = do untagged <- many lineParser + resp <- Parser pDone + let (mboxUp, values) = mkMboxUpdate untagged + return (resp, mboxUp, build values) + fatal = do resp <- pFatalLine + return (resp, MboxUpdate Nothing Nothing, build []) 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 "APPENDUID" >> space - ; uidValidity <- pUID - ; space - ; uid <- pUID - ; return $ APPENDUID_sc $ AppendUID uidValidity uid } - , do { string "COPYUID" >> space - ; uidValidity <- pUID - ; space - ; sourceSet <- pUIDSet - ; space - ; destinationSet <- pUIDSet - ; return $ COPYUID_sc $ CopyUID uidValidity sourceSet destinationSet } - , 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 } - , string "UIDNOTSTICKY" >> return UIDNOTSTICKY - ] - parenWords = between (space >> char '(') (char ')') + respCode <- pRespCode + pRespText respCode + +pFatalLine :: Parser RespDerivs ServerResponse +pFatalLine = do string "* " + stringCI "BYE" + pRespText (\stat body -> BAD stat ("BYE: " ++ body)) + +pRespCode :: Parser RespDerivs (Maybe StatusCode -> String -> ServerResponse) +pRespCode = choice [ stringCI "OK" >> return OK + , stringCI "NO" >> return NO + , stringCI "BAD" >> return BAD + , stringCI "PREAUTH" >> return PREAUTH + ] + +pRespText :: (Maybe StatusCode -> String -> ServerResponse) + -> Parser RespDerivs ServerResponse +pRespText respCode = do space + stat <- optional (do s <- pStatusCode + space >> return s) + body <- anyChar `manyTill` crlfP + return $ respCode stat body + +pStatusCode :: Parser RespDerivs StatusCode +pStatusCode = + between (char '[') (char ']') $ + choice [ stringCI "ALERT" >> return ALERT + , do { stringCI "BADCHARSET" + ; ws <- optional parenWords + ; return $ BADCHARSET $ fromMaybe [] ws } + , do { stringCI "CAPABILITY" + ; space + ; ws <- (many1 $ noneOf " ]") `sepBy1` space + ; return $ CAPABILITY_sc ws } + , stringCI "PARSE" >> return PARSE + , do { stringCI "PERMANENTFLAGS" >> space >> char '(' + ; fs <- pFlag `sepBy` spaces1 + ; char ')' + ; return $ PERMANENTFLAGS fs } + , stringCI "READ-ONLY" >> return READ_ONLY + , stringCI "READ-WRITE" >> return READ_WRITE + , stringCI "TRYCREATE" >> return TRYCREATE + , do { stringCI "APPENDUID" >> space + ; uidValidity <- pUID + ; space + ; uid <- pUID + ; return $ APPENDUID_sc $ AppendUID uidValidity uid } + , do { stringCI "COPYUID" >> space + ; uidValidity <- pUID + ; space + ; sourceSet <- pUIDSet + ; space + ; destinationSet <- pUIDSet + ; return $ COPYUID_sc $ CopyUID uidValidity sourceSet destinationSet } + , do { stringCI "UNSEEN" >> space + ; num <- many1 digit + ; return $ UNSEEN_sc $ read num } + , do { stringCI "UIDNEXT" >> space + ; num <- many1 digit + ; return $ UIDNEXT_sc $ read num } + , do { stringCI "UIDVALIDITY" >> space + ; num <- many1 digit + ; return $ UIDVALIDITY_sc $ read num } + , stringCI "UIDNOTSTICKY" >> return UIDNOTSTICKY + ] + where parenWords = between (space >> char '(') (char ')') (many1 (noneOf " )") `sepBy1` space) pUID = many1 digit >>= return . read - pUIDSet = many1 (digit <|> char ':' <|> char ',') + pUIDSet = many1 (digit <|> char ':' <|> char ',' <|> char '*') 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 + choice [ stringCI "Seen" >> return Seen + , stringCI "Answered" >> return Answered + , stringCI "Flagged" >> return Flagged + , stringCI "Deleted" >> return Deleted + , stringCI "Draft" >> return Draft + , stringCI "Recent" >> return Recent , char '*' >> return (Keyword "*") , many1 atomChar >>= return . Keyword . ('\\':) ] <|> (many1 atomChar >>= return . Keyword) @@ -215,12 +219,30 @@ Parser pParenFlags = do char '(' return fs atomChar :: Derivs d => Parser d Char -atomChar = noneOf " (){%*\"\\]" +atomChar = noneOf " (){%*\"\\]\r\n" + +pQuotedString :: Parser RespDerivs String +pQuotedString = between (char '"') (char '"') (many quotedChar) + where quotedChar = (char '\\' >> anyChar) <|> noneOf "\"\\\r\n" + +pLiteralString :: Parser RespDerivs String +pLiteralString = do optional (char '~') + char '{' + num <- many1 digit >>= return . read + optional (char '+') + char '}' >> crlfP + sequence $ replicate num anyChar + +pAString :: Parser RespDerivs String +pAString = pQuotedString <|> pLiteralString <|> many1 atomChar + +pMailboxName :: Parser RespDerivs MailboxName +pMailboxName = decodeMailboxName <$> pAString pNumberedLine :: String -> Parser RespDerivs Integer pNumberedLine str = do num <- many1 digit space - string str + stringCI str crlfP return $ read num @@ -238,7 +260,9 @@ pOtherLine = do string "* " pCapabilityLine :: Parser RespDerivs (Either a [String]) -pCapabilityLine = do string "* CAPABILITY " +pCapabilityLine = do string "* " + stringCI "CAPABILITY" + space ws <- many1 (noneOf " \r") `sepBy` space crlfP return $ Right ws @@ -246,65 +270,54 @@ pCapabilityLine = do string "* CAPABILITY " pListLine :: String -> Parser RespDerivs (Either a ([Attribute], String, MailboxName)) pListLine list = - do string "* " >> string list >> space + do string "* " >> stringCI list >> space attrs <- parseAttrs sep <- parseSep mbox <- parseMailbox return $ Right (attrs, sep, mbox) where parseAttr = do char '\\' - choice [ string "Noinferiors" >> return Noinferiors - , string "Noselect" >> return Noselect - , string "Marked" >> return Marked - , string "Unmarked" >> return Unmarked + choice [ stringCI "Noinferiors" >> return Noinferiors + , stringCI "Noselect" >> return Noselect + , stringCI "Marked" >> return Marked + , stringCI "Unmarked" >> return Unmarked , many atomChar >>= return . OtherAttr ] parseAttrs = do char '(' attrs <- parseAttr `sepBy` space char ')' return attrs - parseSep = space >> char '"' >> anyChar `manyTill` char '"' + parseSep = space >> ((string "NIL" >> return "") <|> pQuotedString) parseMailbox = do space - mbox <- pListMailboxName + mbox <- pMailboxName crlfP return mbox -pListMailboxName :: Parser RespDerivs MailboxName -pListMailboxName = decodeMailboxName <$> (pQuotedMailboxString <|> many1 (noneOf " \r\n")) - -pQuotedMailboxString :: Parser RespDerivs String -pQuotedMailboxString = between (char '"') (char '"') (many quotedChar) - where quotedChar = (char '\\' >> noneOf "\r\n") <|> noneOf "\"\\\r\n" - pStatusLine :: Parser RespDerivs (Either a [(MailboxStatus, Integer)]) pStatusLine = - do string "* STATUS " + do string "* " + stringCI "STATUS" + space _ <- pMailboxName 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 - , string "UNSEEN" >>= return . read + do cons <- choice [ stringCI "MESSAGES" >>= return . read + , stringCI "RECENT" >>= return . read + , stringCI "UIDNEXT" >>= return . read + , stringCI "UIDVALIDITY" >>= return . read + , stringCI "UNSEEN" >>= return . read ] space num <- many1 digit >>= return . read return (cons, num) -pMailboxName :: Parser RespDerivs MailboxName -pMailboxName = pQuotedString <|> many1 (noneOf " \r\n") - -pQuotedString :: Parser RespDerivs String -pQuotedString = between (char '"') (char '"') (many quotedChar) - where quotedChar = (char '\\' >> noneOf "\r\n") <|> noneOf "\"\\\r\n" - pSearchLine :: Parser RespDerivs (Either a [UID]) -pSearchLine = do string "* SEARCH " - nums <- (many1 digit) `sepBy` space +pSearchLine = do string "* " + stringCI "SEARCH" + nums <- option [] (space >> ((many1 digit) `sepBy` space)) crlfP return $ Right $ map read nums @@ -314,18 +327,19 @@ pSelectLine = 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 " + , stringCI "OK" >> space >> okResps ] + where pFlags = do stringCI "FLAGS" + space char '(' fs <- pFlag `sepBy` space char ')' >> crlfP return fs okResps = do char '[' - v <- choice [ do { string "UNSEEN " + v <- choice [ do { stringCI "UNSEEN" >> space ; many1 digit ; return id } - , do { string "PERMANENTFLAGS (" + , do { stringCI "PERMANENTFLAGS" >> space >> char '(' ; fs <- pFlag `sepBy` space ; char ')' ; return $ \mbox -> @@ -333,11 +347,11 @@ pSelectLine = Keyword "*" `elem` fs , _permanentFlags = filter (/= Keyword "*") fs } } - , do { string "UIDNEXT " + , do { stringCI "UIDNEXT" >> space ; n <- many1 digit ; return $ \mbox -> mbox { _uidNext = read n } } - , do { string "UIDVALIDITY " + , do { stringCI "UIDVALIDITY" >> space ; n <- many1 digit ; return $ \mbox -> mbox { _uidValidity = read n } } @@ -350,32 +364,36 @@ pFetchLine :: Parser RespDerivs (Either a (Integer, [(String, String)])) pFetchLine = do string "* " num <- many1 digit - string " FETCH" >> spaces + space >> stringCI "FETCH" >> spaces char '(' pairs <- pPair `manyTill` char ')' crlfP return $ Right $ (read num, pairs) - where pPair = do key <- (do k <- anyChar `manyTill` char '[' - ps <- anyChar `manyTill` char ']' - space - return (k++"["++ps++"]")) - <|> 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 + where pPair = do key <- pFetchKey + value <- pFetchValue spaces return (key, value) - pParen = (do char '"' - v <- noneOf "\"" `manyTill` char '"' + pFetchKey = do name <- many1 (noneOf " [)\r\n") + section <- option "" pSection + space + return (map toUpper name ++ section) + pSection = do char '[' + ps <- anyChar `manyTill` char ']' + origin <- option "" pOrigin + return ("[" ++ ps ++ "]" ++ origin) + pOrigin = do char '<' + n <- many1 digit + char '>' + return ("<" ++ n ++ ">") + pFetchValue = (do char '(' + v <- pParen `sepBy` space + char ')' + return ("("++unwords v++")")) + <|> pLiteralString + <|> (do v <- pQuotedString + return ("\""++v++"\"")) + <|> pAtomValue + pParen = (do v <- pQuotedString return ("\""++v++"\"")) <|> (do char '(' v <- pParen `sepBy` space @@ -385,12 +403,23 @@ pFetchLine = v <- many1 atomChar return ('\\':v)) <|> many1 atomChar + pAtomValue = do v <- many1 atomChar + return $ if map toUpper v == "NIL" then "" else v ---------------------------------------------------------------------- -- auxiliary parsers space :: Parser RespDerivs Char space = char ' ' +charCI :: Derivs d => Char -> Parser d Char +charCI c = charIf ((toLower c ==) . toLower) show c + +stringCI :: Derivs d => String -> Parser d String +stringCI str = go str show str + where + go [] = return str + go (c:cs) = charCI c >> go cs + spaces, spaces1 :: Parser RespDerivs String spaces = many space spaces1 = many1 space diff --git a/test/IMAPParsersTest.hs b/test/IMAPParsersTest.hs index b5a0f38..cacbf2a 100644 --- a/test/IMAPParsersTest.hs +++ b/test/IMAPParsersTest.hs @@ -503,6 +503,29 @@ imapUIDPlusTest = commandBytes "000000 UID EXPUNGE 3000:3002" @=? actual ] +caseInsensitiveTest = + [ "lowercase tagged status code is accepted" ~: + (OK Nothing "done", MboxUpdate Nothing Nothing, ()) + ~=? eval' pNone "a001" "a001 ok done\r\n" + , "lowercase bracketed response status code is accepted" ~: + (OK (Just READ_WRITE) "done", MboxUpdate Nothing Nothing, ()) + ~=? eval' pNone "a001" "a001 OK [read-write] done\r\n" + , "untagged BYE is surfaced as a fatal response" ~: + (BAD Nothing "BYE: server shutting down", MboxUpdate Nothing Nothing, ()) + ~=? eval' pNone "a001" "* BYE server shutting down\r\n" + , "lowercase flag names parse" ~: + [Seen, Deleted] ~=? eval' dvFlags "" "(\\seen \\deleted)" + , "empty SEARCH response yields no uids" ~: + (OK Nothing "done", MboxUpdate Nothing Nothing, []) + ~=? eval' pSearch "a001" "* SEARCH\r\na001 OK done\r\n" + , "lowercase SEARCH keyword with uids parses" ~: + (OK Nothing "done", MboxUpdate Nothing Nothing, [1, 2, 3]) + ~=? eval' pSearch "a001" "* search 1 2 3\r\na001 OK done\r\n" + , "NIL hierarchy separator in LIST parses" ~: + (OK Nothing "done", MboxUpdate Nothing Nothing, [([], "", "INBOX")]) + ~=? eval' pList "a001" "* LIST () NIL INBOX\r\na001 OK done\r\n" + ] + testData = [ "base" ~: baseTest , "capability" ~: capabilityTest , "noop" ~: noopTest @@ -516,6 +539,7 @@ testData = [ "base" ~: baseTest , "flags" ~: flagTest , "imap fetch api" ~: imapFetchTest , "imap uidplus api" ~: imapUIDPlusTest + , "case insensitivity" ~: caseInsensitiveTest ]