diff --git a/CHANGELOG b/CHANGELOG index 07570a0..3350b69 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,25 @@ +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 + - assorted IMAP robustness fixes: accept a PREAUTH (and case-insensitive) + connection greeting; loop over SASL '+' challenge continuations (e.g. + XOAUTH2); handle non-synchronising {n+} and binary ~{n} literals in + getResponse; normalize a NIL message body to empty; read STORE result + flags from the FLAGS key and quote X-GM-LABELS; unify escapeLogin with + quoteIMAPString + - reject command injection: user-supplied strings (login, mailbox names, + SEARCH/FETCH arguments, flag keywords, Gmail labels) containing CR, LF or + NUL are now refused instead of being sent, so they cannot smuggle extra + IMAP commands onto the connection + 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..5b8fe7b 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" @@ -135,9 +138,18 @@ connectIMAP hostname = connectIMAPPort hostname 143 connectStream :: BSStream -> IO IMAPConnection connectStream s = do msg <- bsGetLine s - unless (and $ BS.zipWith (==) msg (BS.pack "* OK")) $ + unless (isAcceptedGreeting msg) $ fail "cannot connect to the server" newConnection s + where + isAcceptedGreeting msg = + case BS.words msg of + (star:greetingStatus:_) -> + star == BS.pack "*" && isReadyStatus greetingStatus + _ -> False + isReadyStatus greetingStatus = + let upperStatus = BS.map toUpper greetingStatus + in upperStatus == BS.pack "OK" || upperStatus == BS.pack "PREAUTH" ---------------------------------------------------------------------- -- normal send commands @@ -149,10 +161,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 +180,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) @@ -194,11 +217,25 @@ getResponse s = unlinesCRLF <$> getLs then getLiteral l' (getLitLen l2) else return l' crlfStr = BS.pack "\r\n" - isLiteral l = not (BS.null l) && - BS.last l == '}' && - BS.last (fst (BS.spanEnd isDigit (BS.init l))) == '{' - getLitLen = read . BS.unpack . snd . BS.spanEnd isDigit . BS.init - isTagged l = BS.head l == '*' && BS.head (BS.tail l) == ' ' + literalLength :: ByteString -> Maybe Int + isLiteral = isJust . literalLength + getLitLen l = fromMaybe 0 (literalLength l) + literalLength l = + if BS.length l >= 3 && BS.last l == '}' + then parseLiteralTail $ reverse $ BS.unpack $ BS.init l + else Nothing + parseLiteralTail revBeforeClose = + case break (== '{') revBeforeClose of + (insideRev, _ : _) -> parseLiteralInside $ reverse insideRev + _ -> Nothing + parseLiteralInside inside = + let digits' = case reverse inside of + '+' : rest -> reverse rest + _ -> inside + in if not (null digits') && all isDigit digits' + then Just $ read digits' + else Nothing + isTagged l = BS.length l >= 2 && BS.take 2 l == BS.pack "* " mboxUpdate :: IMAPConnection -> MboxUpdate -> IO () mboxUpdate conn (MboxUpdate exists' recent') = do @@ -243,8 +280,11 @@ logout c = do bsPutCrLf (stream c) $ BS.pack "a0001 LOGOUT" bsClose (stream c) login :: IMAPConnection -> A.UserName -> A.Password -> IO () -login conn username password = sendCommand conn ("LOGIN " ++ (escapeLogin username) ++ " " ++ (escapeLogin password)) - pNone +login conn username password = + do validateCommandText "login username" username + validateCommandText "login password" password + sendCommand conn ("LOGIN " ++ (escapeLogin username) ++ " " ++ (escapeLogin password)) + pNone authenticate :: IMAPConnection -> A.AuthType -> A.UserName -> A.Password -> IO () @@ -265,13 +305,12 @@ authenticate conn A.LOGIN username password = authenticate conn at username password = do (c, num) <- sendCommand' conn $ "AUTHENTICATE " ++ show at let challenge = - if BS.take 2 c == BS.pack "+ " - then A.b64Decode $ BS.unpack $ head $ - dropWhile (isSpace . BS.last) $ BS.inits $ BS.drop 2 c + if BS.take 1 c == BS.pack "+" + then A.b64Decode $ BS.unpack $ strip $ BS.drop 1 c else "" bsPutCrLf (stream conn) $ BS.pack $ A.auth at challenge username password - buf <- getResponse $ stream conn + buf <- getAuthResponse conn let (resp, mboxUp, value) = eval pNone (show6 num) buf case resp of OK _ _ -> do mboxUpdate conn $ mboxUp @@ -280,9 +319,20 @@ authenticate conn at username password = BAD _ msg -> fail ("BAD: " ++ msg) PREAUTH _ msg -> fail ("preauth: " ++ msg) +-- | Some SASL mechanisms (e.g. XOAUTH2) emit one or more @+@ challenge +-- continuations before the final tagged response. Send an empty line in +-- response to each so the exchange completes instead of stalling. +getAuthResponse :: IMAPConnection -> IO ByteString +getAuthResponse conn = do + buf <- getResponse $ stream conn + if BS.take 1 (strip buf) == BS.pack "+" + then bsPutCrLf (stream conn) BS.empty >> getAuthResponse conn + else return buf + _select :: String -> IMAPConnection -> String -> IO () _select cmd conn mboxName = - do mbox' <- sendCommand conn (cmd ++ quoteMailboxName mboxName) pSelect + do validateCommandText "mailbox name" mboxName + mbox' <- sendCommand conn (cmd ++ quoteMailboxName mboxName) pSelect setMailboxInfo conn $ mbox' { _mailbox = mboxName } select :: IMAPConnection -> MailboxName -> IO () @@ -292,20 +342,30 @@ examine :: IMAPConnection -> MailboxName -> IO () examine = _select "EXAMINE " create :: IMAPConnection -> MailboxName -> IO () -create conn mboxname = sendCommand conn ("CREATE " ++ quoteMailboxName mboxname) pNone +create conn mboxname = + do validateCommandText "mailbox name" mboxname + sendCommand conn ("CREATE " ++ quoteMailboxName mboxname) pNone delete :: IMAPConnection -> MailboxName -> IO () -delete conn mboxname = sendCommand conn ("DELETE " ++ quoteMailboxName mboxname) pNone +delete conn mboxname = + do validateCommandText "mailbox name" mboxname + sendCommand conn ("DELETE " ++ quoteMailboxName mboxname) pNone rename :: IMAPConnection -> MailboxName -> MailboxName -> IO () rename conn mboxorg mboxnew = - sendCommand conn ("RENAME " ++ quoteMailboxName mboxorg ++ " " ++ quoteMailboxName mboxnew) pNone + do validateCommandText "mailbox name" mboxorg + validateCommandText "mailbox name" mboxnew + sendCommand conn ("RENAME " ++ quoteMailboxName mboxorg ++ " " ++ quoteMailboxName mboxnew) pNone subscribe :: IMAPConnection -> MailboxName -> IO () -subscribe conn mboxname = sendCommand conn ("SUBSCRIBE " ++ quoteMailboxName mboxname) pNone +subscribe conn mboxname = + do validateCommandText "mailbox name" mboxname + sendCommand conn ("SUBSCRIBE " ++ quoteMailboxName mboxname) pNone unsubscribe :: IMAPConnection -> MailboxName -> IO () -unsubscribe conn mboxname = sendCommand conn ("UNSUBSCRIBE " ++ quoteMailboxName mboxname) pNone +unsubscribe conn mboxname = + do validateCommandText "mailbox name" mboxname + sendCommand conn ("UNSUBSCRIBE " ++ quoteMailboxName mboxname) pNone list :: IMAPConnection -> IO [([Attribute], MailboxName)] list conn = (map (\(a, _, m) -> (a, m))) <$> listFull conn "\"\"" "*" @@ -324,8 +384,9 @@ lsubFull conn ref pat = sendCommand conn (unwords ["LSUB", ref, pat]) pLsub status :: IMAPConnection -> MailboxName -> [MailboxStatus] -> IO [(MailboxStatus, Integer)] status conn mbox stats = - let cmd = "STATUS " ++ quoteMailboxName mbox ++ " (" ++ (unwords $ map show stats) ++ ")" - in sendCommand conn cmd pStatus + do validateCommandText "mailbox name" mbox + let cmd = "STATUS " ++ quoteMailboxName mbox ++ " (" ++ (unwords $ map show stats) ++ ")" + sendCommand conn cmd pStatus append :: IMAPConnection -> MailboxName -> ByteString -> IO () append conn mbox mailData = appendFull conn mbox mailData Nothing Nothing @@ -333,7 +394,17 @@ 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 = - do (buf, num) <- sendCommand' conn + 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 validateCommandText "mailbox name" mbox + maybe (return ()) validateFlags flags' + (buf, num) <- sendCommand' conn (concat ["APPEND ", quoteMailboxName mbox , fstr, tstr, " {" ++ show len ++ "}"]) when (BS.null buf || (BS.head buf /= '+')) $ @@ -343,13 +414,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,27 +437,58 @@ 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] searchCharset conn charset queries = - sendCommand conn ("UID SEARCH " - ++ (if not . null $ charset - then charset ++ " " - else "") - ++ unwords (map show queries)) pSearch + do validateCommandText "search charset" charset + mapM_ validateSearchQuery queries + sendCommand conn ("UID SEARCH " + ++ (if not . null $ charset + then charset ++ " " + else "") + ++ unwords (map show queries)) pSearch + +-- | An untagged NIL means "no data" (RFC 3501); normalize it to an empty +-- body so callers don't see the literal atom. Real bodies arrive as IMAP +-- literals and are never the bare atom NIL. +nilToEmpty :: ByteString -> ByteString +nilToEmpty bs = if bs == BS.pack "NIL" then BS.empty else bs fetch :: IMAPConnection -> UID -> IO ByteString fetch conn uid = do lst <- fetchByByteString conn uid "BODY[]" - return $ fromMaybe BS.empty $ lookup' "BODY[]" lst + return $ nilToEmpty $ fromMaybe BS.empty $ lookup' "BODY[]" lst -- | Like 'fetch' but without marking the email as seen/read fetchPeek :: IMAPConnection -> UID -> IO ByteString fetchPeek conn uid = do lst <- fetchByByteString conn uid "BODY.PEEK[]" - return $ fromMaybe BS.empty $ lookup' "BODY[]" lst + return $ nilToEmpty $ fromMaybe BS.empty $ lookup' "BODY[]" lst fetchHeader :: IMAPConnection -> UID -> IO ByteString fetchHeader conn uid = @@ -398,14 +503,16 @@ fetchSize conn uid = fetchHeaderFields :: IMAPConnection -> UID -> [String] -> IO ByteString fetchHeaderFields conn uid hs = - do let fetchCmd = "BODY[HEADER.FIELDS ("++unwords hs++")]" + do mapM_ (validateCommandText "fetch header field") hs + let fetchCmd = "BODY[HEADER.FIELDS ("++unwords hs++")]" lst <- fetchByByteString conn uid fetchCmd return $ fromMaybe BS.empty $ lookup' fetchCmd lst fetchHeaderFieldsNot :: IMAPConnection -> UID -> [String] -> IO ByteString fetchHeaderFieldsNot conn uid hs = - do let fetchCmd = "BODY[HEADER.FIELDS.NOT ("++unwords hs++")]" + do mapM_ (validateCommandText "fetch header field") hs + let fetchCmd = "BODY[HEADER.FIELDS.NOT ("++unwords hs++")]" lst <- fetchByByteString conn uid fetchCmd return $ fromMaybe BS.empty $ lookup' fetchCmd lst @@ -420,14 +527,14 @@ fetchR :: IMAPConnection -> (UID, UID) -> IO [(UID, ByteString)] fetchR conn r = do lst <- fetchByByteStringR conn r "BODY[]" - return $ map (\(uid, vs) -> (uid, fromMaybe BS.empty $ + return $ map (\(uid, vs) -> (uid, nilToEmpty $ fromMaybe BS.empty $ lookup' "BODY[]" vs)) lst -- | Like 'fetchR' but without marking the email as seen/read fetchRPeek :: IMAPConnection -> (UID, UID) -> IO [(UID, ByteString)] fetchRPeek conn range = do ls <- fetchByByteStringR conn range "BODY.PEEK[]" - return $ map (\(uid, vs) -> (uid, fromMaybe BS.empty $ lookup' "BODY[]" vs)) ls + return $ map (\(uid, vs) -> (uid, nilToEmpty $ fromMaybe BS.empty $ lookup' "BODY[]" vs)) ls -- | Fetch arbitrary data items and return values as 'String's. -- @@ -445,7 +552,8 @@ fetchByString conn uid command = fetchByByteString :: IMAPConnection -> UID -> String -> IO [(String, ByteString)] fetchByByteString conn uid command = - do lst <- fetchCommandBS conn ("UID FETCH "++show uid++" "++command) id + do validateCommandText "fetch command" command + lst <- fetchCommandBS conn ("UID FETCH "++show uid++" "++command) id case lst of (_, pairs):_ -> return pairs [] -> return [] @@ -462,7 +570,8 @@ fetchByStringR conn (s, e) command = fetchByByteStringR :: IMAPConnection -> (UID, UID) -> String -> IO [(UID, [(String, ByteString)])] fetchByByteStringR conn (s, e) command = - fetchCommandBS conn ("UID FETCH "++show s++":"++show e++" "++command) proc + do validateCommandText "fetch command" command + fetchCommandBS conn ("UID FETCH "++show s++":"++show e++" "++command) proc where proc (n, ps) = (maybe (toEnum (fromIntegral n)) (read . BS.unpack) (lookup' "UID" ps), ps) @@ -752,33 +861,83 @@ fetchParseError message input = storeFull :: IMAPConnection -> String -> FlagsQuery -> Bool -> IO [(UID, [Flag])] storeFull conn uidstr query isSilent = - fetchCommand conn ("UID STORE " ++ uidstr ++ " " ++ flgs query) procStore - where fstrs fs = "(" ++ (concat $ intersperse " " $ map show fs) ++ ")" + do validateFlagsQuery query + fetchCommand conn ("UID STORE " ++ uidstr ++ " " ++ flgs query) procStore + where flagList fs = "(" ++ (concat $ intersperse " " $ map show fs) ++ ")" + labelList ls = "(" ++ (concat $ intersperse " " $ map quoteIMAPString ls) ++ ")" toFStr s fstrs' = s ++ (if isSilent then ".SILENT" else "") ++ " " ++ fstrs' - flgs (ReplaceGmailLabels ls) = toFStr "X-GM-LABELS" $ fstrs ls - flgs (PlusGmailLabels ls) = toFStr "+X-GM-LABELS" $ fstrs ls - flgs (MinusGmailLabels ls) = toFStr "-X-GM-LABELS" $ fstrs ls - flgs (ReplaceFlags fs) = toFStr "FLAGS" $ fstrs fs - flgs (PlusFlags fs) = toFStr "+FLAGS" $ fstrs fs - flgs (MinusFlags fs) = toFStr "-FLAGS" $ fstrs fs + flgs (ReplaceGmailLabels ls) = toFStr "X-GM-LABELS" $ labelList ls + flgs (PlusGmailLabels ls) = toFStr "+X-GM-LABELS" $ labelList ls + flgs (MinusGmailLabels ls) = toFStr "-X-GM-LABELS" $ labelList ls + flgs (ReplaceFlags fs) = toFStr "FLAGS" $ flagList fs + flgs (PlusFlags fs) = toFStr "+FLAGS" $ flagList fs + flgs (MinusFlags fs) = toFStr "-FLAGS" $ flagList fs procStore (n, ps) = (maybe (toEnum (fromIntegral n)) read (lookup' "UID" ps) - ,maybe [] (eval' dvFlags "") (lookup' "FLAG" ps)) + ,maybe [] (eval' dvFlags "") (lookup' "FLAGS" ps)) 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 validateCommandText "mailbox name" mbox + (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 +move conn uid mboxname = + do validateCommandText "mailbox name" mboxname + sendCommand conn ("UID MOVE " ++ show uid ++ " " ++ quoteMailboxName mboxname) pNone ---------------------------------------------------------------------- -- auxialiary functions @@ -792,6 +951,52 @@ quoteIMAPString s = "\"" ++ concatMap escapeChar s ++ "\"" escapeChar '\\' = "\\\\" escapeChar c = [c] +-- | Reject user-supplied text that would break out of the current command +-- line. A CR, LF or NUL in an argument lets a caller-controlled string inject +-- additional IMAP commands, so fail loudly instead of sending it. +validateCommandText :: String -> String -> IO () +validateCommandText label value = + when (any isCommandBreakingChar value) $ + fail (label ++ " contains CR, LF, or NUL") + +isCommandBreakingChar :: Char -> Bool +isCommandBreakingChar c = c == '\r' || c == '\n' || c == '\0' + +validateSearchQuery :: SearchQuery -> IO () +validateSearchQuery (BCCs s) = validateCommandText "search BCC" s +validateSearchQuery (BODYs s) = validateCommandText "search BODY" s +validateSearchQuery (CCs s) = validateCommandText "search CC" s +validateSearchQuery (FLAG f) = validateFlag f +validateSearchQuery (FROMs s) = validateCommandText "search FROM" s +validateSearchQuery (HEADERs f v) = validateCommandText "search HEADER field" f >> + validateCommandText "search HEADER value" v +validateSearchQuery (NOTs q) = validateSearchQuery q +validateSearchQuery (ORs q1 q2) = validateSearchQuery q1 >> validateSearchQuery q2 +validateSearchQuery (SUBJECTs s) = validateCommandText "search SUBJECT" s +validateSearchQuery (TEXTs s) = validateCommandText "search TEXT" s +validateSearchQuery (TOs s) = validateCommandText "search TO" s +validateSearchQuery (UNFLAG f) = validateFlag f +validateSearchQuery (XGMRAW s) = validateCommandText "search X-GM-RAW" s +validateSearchQuery _ = return () + +validateFlagsQuery :: FlagsQuery -> IO () +validateFlagsQuery (ReplaceFlags fs) = validateFlags fs +validateFlagsQuery (PlusFlags fs) = validateFlags fs +validateFlagsQuery (MinusFlags fs) = validateFlags fs +validateFlagsQuery (ReplaceGmailLabels labels) = validateGmailLabels labels +validateFlagsQuery (PlusGmailLabels labels) = validateGmailLabels labels +validateFlagsQuery (MinusGmailLabels labels) = validateGmailLabels labels + +validateFlags :: [Flag] -> IO () +validateFlags = mapM_ validateFlag + +validateFlag :: Flag -> IO () +validateFlag (Keyword keyword) = validateCommandText "flag keyword" keyword +validateFlag _ = return () + +validateGmailLabels :: [GmailLabel] -> IO () +validateGmailLabels = mapM_ (validateCommandText "Gmail label") + showMonth :: Month -> String showMonth January = "Jan" showMonth February = "Feb" @@ -876,12 +1081,4 @@ normalizeFetchKey = stripOrigin . stripPeek . map toUpper -- It must be reviewed. References: rfc3501#6.2.3, rfc2683#3.4.2. -- This function was tested against the password: `~1!2@3#4$5%6^7&8*9(0)-_=+[{]}\|;:'",<.>/? (with spaces in the laterals). escapeLogin :: String -> String -escapeLogin x = "\"" ++ replaceSpecialChars x ++ "\"" - where - replaceSpecialChars "" = "" - replaceSpecialChars (c:cs) = escapeChar c ++ replaceSpecialChars cs - escapeChar '"' = "\\\"" - escapeChar '\\' = "\\\\" - escapeChar '{' = "\\{" - escapeChar '}' = "\\}" - escapeChar s = [s] +escapeLogin = quoteIMAPString 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..272e40f 100644 --- a/test/IMAPParsersTest.hs +++ b/test/IMAPParsersTest.hs @@ -1,10 +1,13 @@ module Main (main) where +import Control.Exception (SomeException, displayException, try) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BS import Data.IORef +import Data.List (isInfixOf) import Network.HaskellNet.BSStream +import qualified Network.HaskellNet.Auth as Auth import qualified Network.HaskellNet.IMAP as IMAP import Network.HaskellNet.IMAP.Connection import Network.HaskellNet.IMAP.Parsers @@ -69,6 +72,15 @@ assertCommand name expected steps action = actual <- written expected @=? actual +assertThrowsContaining :: String -> String -> IO a -> Test +assertThrowsContaining name expected action = + name ~: TestCase $ do + result <- try (action >> return ()) :: IO (Either SomeException ()) + case result of + Left err -> assertBool ("expected exception containing " ++ show expected) + (expected `isInfixOf` displayException err) + Right _ -> assertFailure "expected exception" + baseTest = [(OK Nothing "LOGIN Completed", MboxUpdate Nothing Nothing, ()) @@ -84,6 +96,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 +461,160 @@ 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) + ] + +imapRobustnessTest = + [ "connect accepts PREAUTH greeting" ~: TestCase $ do + (testStream, _) <- scriptedStream [ line "* PREAUTH already logged in" ] + _ <- IMAP.connectStream testStream + return () + , "connect accepts lowercase ok greeting" ~: TestCase $ do + (testStream, _) <- scriptedStream [ line "* ok IMAP4rev1 ready" ] + _ <- IMAP.connectStream testStream + return () + , assertThrowsContaining "connect rejects empty greeting" "cannot connect" + (do (testStream, _) <- scriptedStream [ line "" ] + IMAP.connectStream testStream) + , assertThrowsContaining "multi-step auth consumes + continuations" "NO:" + (do (conn, _) <- scriptedConnection + [ line "+" + , line "+ eyJzdGF0dXMiOiI0MDAifQ==" + , line "000000 NO [AUTHENTICATIONFAILED] Invalid credentials" + ] + IMAP.authenticate conn Auth.XOAUTH2 "user@example.test" "Bearer bad") + , "login quotes credentials without escaping braces" ~: TestCase $ do + (conn, written) <- scriptedConnection [ okLine "LOGIN completed" ] + IMAP.login conn "user" "pa{ss}" + actual <- written + commandBytes "000000 LOGIN \"user\" \"pa{ss}\"" @=? actual + , "fetch normalizes a NIL body to empty" ~: TestCase $ do + (conn, _) <- scriptedConnection + [ line "* 1 FETCH (UID 42 BODY[] NIL)", okLine "FETCH completed" ] + body <- IMAP.fetch conn 42 + BS.empty @=? body + ] + +imapHardeningTest = + [ assertThrowsContaining "login rejects CRLF in username" "CR, LF, or NUL" + (do (conn, _) <- scriptedConnection [] + IMAP.login conn "user\r\nA NOOP" "pass") + , assertThrowsContaining "select rejects CRLF in mailbox name" "CR, LF, or NUL" + (do (conn, _) <- scriptedConnection [] + IMAP.select conn "INBOX\r\nA001 DELETE victim") + , assertThrowsContaining "search rejects LF in a string query" "CR, LF, or NUL" + (do (conn, _) <- scriptedConnection [] + IMAP.search conn [IMAP.SUBJECTs "hi\nthere"]) + , assertThrowsContaining "fetch rejects NUL in command" "CR, LF, or NUL" + (do (conn, _) <- scriptedConnection [] + IMAP.fetchByByteString conn 1 "BODY[\0]") + , assertThrowsContaining "store rejects CRLF in keyword flag" "CR, LF, or NUL" + (do (conn, _) <- scriptedConnection [] + IMAP.store conn 1 (IMAP.PlusFlags [Keyword "a\r\nb"])) + ] + testData = [ "base" ~: baseTest , "capability" ~: capabilityTest , "noop" ~: noopTest @@ -452,6 +627,11 @@ testData = [ "base" ~: baseTest , "imap commands" ~: imapCommandTest , "flags" ~: flagTest , "imap fetch api" ~: imapFetchTest + , "imap uidplus api" ~: imapUIDPlusTest + , "case insensitivity" ~: caseInsensitiveTest + , "imap search api" ~: imapSearchApiTest + , "imap robustness" ~: imapRobustnessTest + , "imap hardening" ~: imapHardeningTest ]