Add IMAP UIDPLUS support (RFC 4315)

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

src/Network/HaskellNet/IMAP.hs

@@ -8,10 +8,10 @@
       -- ** 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 @@
     , fetchPeek, fetchRPeek
       -- * other types
     , Flag(..), Attribute(..), MailboxStatus(..)
+    , AppendUID(..), CopyUID(..), UIDSet
     , SearchQuery(..), FlagsQuery(..)
     , A.AuthType(..)
     )
@@ -164,12 +165,19 @@
 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)
@@ -266,7 +274,7 @@
     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
                else ""
        bsPutCrLf (stream conn) $ BS.pack $
@@ -333,6 +341,14 @@
 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 @@
        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 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
 

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 '\\'

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)
 

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
            ]