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 ]