diff --git a/CHANGELOG b/CHANGELOG index 07570a0..bfe6d14 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,15 @@ +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 + - IMAP SEARCH string arguments are now quoted, LARGER/SMALLER no longer wrap + their size in braces, and SEARCH automatically adds CHARSET UTF-8 (and + sends the command UTF-8 encoded) when a query contains non-ASCII text + 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..ccecd8e 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(..) ) @@ -36,6 +37,8 @@ import Network.Socket (PortNumber) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TextEncoding import Control.Monad @@ -83,13 +86,13 @@ instance Show SearchQuery where showQuery ALLs = "ALL" showQuery (FLAG f) = showFlag f showQuery (UNFLAG f) = "UN" ++ showFlag f - showQuery (BCCs addr) = "BCC " ++ addr + showQuery (BCCs addr) = "BCC " ++ quoteIMAPString addr showQuery (BEFOREs t) = "BEFORE " ++ dateToStringIMAP t - showQuery (BODYs s) = "BODY " ++ s - showQuery (CCs addr) = "CC " ++ addr - showQuery (FROMs addr) = "FROM " ++ addr - showQuery (HEADERs f v) = "HEADER " ++ f ++ " " ++ v - showQuery (LARGERs siz) = "LARGER {" ++ show siz ++ "}" + showQuery (BODYs s) = "BODY " ++ quoteIMAPString s + showQuery (CCs addr) = "CC " ++ quoteIMAPString addr + showQuery (FROMs addr) = "FROM " ++ quoteIMAPString addr + showQuery (HEADERs f v) = "HEADER " ++ f ++ " " ++ quoteIMAPString v + showQuery (LARGERs siz) = "LARGER " ++ show siz showQuery NEWs = "NEW" showQuery (NOTs qry) = "NOT " ++ show qry showQuery OLDs = "OLD" @@ -99,11 +102,11 @@ instance Show SearchQuery where showQuery (SENTONs t) = "SENTON " ++ dateToStringIMAP t showQuery (SENTSINCEs t) = "SENTSINCE " ++ dateToStringIMAP t showQuery (SINCEs t) = "SINCE " ++ dateToStringIMAP t - showQuery (SMALLERs siz) = "SMALLER {" ++ show siz ++ "}" - showQuery (SUBJECTs s) = "SUBJECT " ++ s - showQuery (TEXTs s) = "TEXT " ++ s - showQuery (TOs addr) = "TO " ++ addr - showQuery (XGMRAW s) = "X-GM-RAW " ++ s + showQuery (SMALLERs siz) = "SMALLER " ++ show siz + showQuery (SUBJECTs s) = "SUBJECT " ++ quoteIMAPString s + showQuery (TEXTs s) = "TEXT " ++ quoteIMAPString s + showQuery (TOs addr) = "TO " ++ quoteIMAPString addr + showQuery (XGMRAW s) = "X-GM-RAW " ++ quoteIMAPString s showQuery (UIDs uids) = concat $ intersperse "," $ map show uids showFlag Seen = "SEEN" @@ -149,10 +152,14 @@ sendCommand' c cmdstr = do sendCommandNoResponse :: IMAPConnection -> String -> IO Int sendCommandNoResponse c cmdstr = do - (_, num) <- withNextCommandNum c $ \num -> bsPutCrLf (stream c) $ - BS.pack $ show6 num ++ " " ++ cmdstr + (_, num) <- withNextCommandNum c $ \num -> do + let bytes = encodeUtf8 $ show6 num ++ " " ++ cmdstr + BS.length bytes `seq` bsPutCrLf (stream c) bytes return num +encodeUtf8 :: String -> ByteString +encodeUtf8 = TextEncoding.encodeUtf8 . Text.pack + show6 :: (Ord a, Num a, Show a) => a -> String show6 n | n > 100000 = show n | n > 10000 = '0' : show n @@ -164,12 +171,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 +347,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 +365,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 @@ -363,7 +388,30 @@ expunge :: IMAPConnection -> IO [Integer] expunge conn = sendCommand conn "EXPUNGE" pExpunge search :: IMAPConnection -> [SearchQuery] -> IO [UID] -search conn queries = searchCharset conn "" queries +search conn queries = + let charset = if any searchQueryNeedsUtf8 queries + then "CHARSET UTF-8" + else "" + in searchCharset conn charset queries + +-- | Whether a search query carries non-ASCII text and therefore needs an +-- explicit @CHARSET UTF-8@ on the SEARCH command (RFC 3501 §6.4.4). +searchQueryNeedsUtf8 :: SearchQuery -> Bool +searchQueryNeedsUtf8 (BCCs s) = containsNonAscii s +searchQueryNeedsUtf8 (BODYs s) = containsNonAscii s +searchQueryNeedsUtf8 (CCs s) = containsNonAscii s +searchQueryNeedsUtf8 (FROMs s) = containsNonAscii s +searchQueryNeedsUtf8 (HEADERs f v) = containsNonAscii f || containsNonAscii v +searchQueryNeedsUtf8 (NOTs q) = searchQueryNeedsUtf8 q +searchQueryNeedsUtf8 (ORs q1 q2) = searchQueryNeedsUtf8 q1 || searchQueryNeedsUtf8 q2 +searchQueryNeedsUtf8 (SUBJECTs s) = containsNonAscii s +searchQueryNeedsUtf8 (TEXTs s) = containsNonAscii s +searchQueryNeedsUtf8 (TOs s) = containsNonAscii s +searchQueryNeedsUtf8 (XGMRAW s) = containsNonAscii s +searchQueryNeedsUtf8 _ = False + +containsNonAscii :: String -> Bool +containsNonAscii = any ((> 0x7f) . ord) searchCharset :: IMAPConnection -> Charset -> [SearchQuery] -> IO [UID] @@ -771,12 +819,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..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,132 +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 "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 ')') + 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 ',' <|> 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) @@ -200,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 @@ -223,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 @@ -231,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 @@ -299,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 -> @@ -318,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 } } @@ -335,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 @@ -370,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/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..4514283 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,111 @@ 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 + ] + +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" + ] + +imapSearchApiTest = + [ "search quotes string arguments" ~: TestCase $ do + (conn, written) <- scriptedConnection + [ line "* SEARCH 1 2", okLine "SEARCH completed" ] + _ <- IMAP.search conn [IMAP.SUBJECTs "hello world"] + actual <- written + commandBytes "000000 UID SEARCH SUBJECT \"hello world\"" @=? actual + , "search emits LARGER/SMALLER without braces" ~: TestCase $ do + (conn, written) <- scriptedConnection + [ line "* SEARCH", okLine "SEARCH completed" ] + _ <- IMAP.search conn [IMAP.LARGERs 100, IMAP.SMALLERs 200] + actual <- written + commandBytes "000000 UID SEARCH LARGER 100 SMALLER 200" @=? actual + , "search omits charset for ascii queries" ~: TestCase $ do + (conn, written) <- scriptedConnection + [ line "* SEARCH", okLine "SEARCH completed" ] + _ <- IMAP.search conn [IMAP.SUBJECTs "hello"] + actual <- written + commandBytes "000000 UID SEARCH SUBJECT \"hello\"" @=? actual + , "search adds CHARSET UTF-8 for non-ascii queries" ~: TestCase $ do + (conn, written) <- scriptedConnection + [ line "* SEARCH", okLine "SEARCH completed" ] + _ <- IMAP.search conn [IMAP.SUBJECTs "\252ber"] + actual <- written + assertBool "expected CHARSET UTF-8 in command" + (BS.pack "UID SEARCH CHARSET UTF-8 SUBJECT" `B.isInfixOf` actual) + ] + testData = [ "base" ~: baseTest , "capability" ~: capabilityTest , "noop" ~: noopTest @@ -452,6 +566,9 @@ testData = [ "base" ~: baseTest , "imap commands" ~: imapCommandTest , "flags" ~: flagTest , "imap fetch api" ~: imapFetchTest + , "imap uidplus api" ~: imapUIDPlusTest + , "case insensitivity" ~: caseInsensitiveTest + , "imap search api" ~: imapSearchApiTest ]