From 0e242d953895dfae80057084cea066ed2ae5115f Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Fri, 5 Jun 2026 16:07:20 +0200 Subject: [PATCH] Quote and encode IMAP mailbox names --- HaskellNet.cabal | 2 + src/Network/HaskellNet/IMAP.hs | 32 +++--- src/Network/HaskellNet/IMAP/Parsers.hs | 17 ++-- src/Network/HaskellNet/IMAP/UTF7.hs | 105 +++++++++++++++++++ test/IMAPParsersTest.hs | 135 +++++++++++++++++++++++++ 5 files changed, 273 insertions(+), 18 deletions(-) create mode 100644 src/Network/HaskellNet/IMAP/UTF7.hs diff --git a/HaskellNet.cabal b/HaskellNet.cabal index 657309e..1df52fc 100644 --- a/HaskellNet.cabal +++ b/HaskellNet.cabal @@ -61,6 +61,7 @@ Library Other-modules: Network.Compat + Network.HaskellNet.IMAP.UTF7 Text.Packrat.Pos Text.Packrat.Parse Reexported-modules: @@ -95,5 +96,6 @@ Test-suite imap-parsers default-language: Haskell2010 Build-Depends: base >= 4.3 && < 4.22, + bytestring >=0.10.2 && < 0.13, HaskellNet, HUnit >= 1.6 && < 1.7 diff --git a/src/Network/HaskellNet/IMAP.hs b/src/Network/HaskellNet/IMAP.hs index 69af0bd..e00af52 100644 --- a/src/Network/HaskellNet/IMAP.hs +++ b/src/Network/HaskellNet/IMAP.hs @@ -30,6 +30,7 @@ import Network.HaskellNet.BSStream import Network.HaskellNet.IMAP.Connection import Network.HaskellNet.IMAP.Parsers import Network.HaskellNet.IMAP.Types +import Network.HaskellNet.IMAP.UTF7 import Network.Socket (PortNumber) import Data.ByteString (ByteString) @@ -275,10 +276,8 @@ authenticate conn at username password = _select :: String -> IMAPConnection -> String -> IO () _select cmd conn mboxName = - do mbox' <- sendCommand conn (cmd ++ quoted mboxName) pSelect + do mbox' <- sendCommand conn (cmd ++ quoteMailboxName mboxName) pSelect setMailboxInfo conn $ mbox' { _mailbox = mboxName } - where - quoted s = "\"" ++ s ++ "\"" select :: IMAPConnection -> MailboxName -> IO () select = _select "SELECT " @@ -287,20 +286,20 @@ examine :: IMAPConnection -> MailboxName -> IO () examine = _select "EXAMINE " create :: IMAPConnection -> MailboxName -> IO () -create conn mboxname = sendCommand conn ("CREATE " ++ mboxname) pNone +create conn mboxname = sendCommand conn ("CREATE " ++ quoteMailboxName mboxname) pNone delete :: IMAPConnection -> MailboxName -> IO () -delete conn mboxname = sendCommand conn ("DELETE " ++ mboxname) pNone +delete conn mboxname = sendCommand conn ("DELETE " ++ quoteMailboxName mboxname) pNone rename :: IMAPConnection -> MailboxName -> MailboxName -> IO () rename conn mboxorg mboxnew = - sendCommand conn ("RENAME " ++ mboxorg ++ " " ++ mboxnew) pNone + sendCommand conn ("RENAME " ++ quoteMailboxName mboxorg ++ " " ++ quoteMailboxName mboxnew) pNone subscribe :: IMAPConnection -> MailboxName -> IO () -subscribe conn mboxname = sendCommand conn ("SUBSCRIBE " ++ mboxname) pNone +subscribe conn mboxname = sendCommand conn ("SUBSCRIBE " ++ quoteMailboxName mboxname) pNone unsubscribe :: IMAPConnection -> MailboxName -> IO () -unsubscribe conn mboxname = sendCommand conn ("UNSUBSCRIBE " ++ mboxname) pNone +unsubscribe conn mboxname = sendCommand conn ("UNSUBSCRIBE " ++ quoteMailboxName mboxname) pNone list :: IMAPConnection -> IO [([Attribute], MailboxName)] list conn = (map (\(a, _, m) -> (a, m))) <$> listFull conn "\"\"" "*" @@ -319,7 +318,7 @@ 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 " ++ mbox ++ " (" ++ (unwords $ map show stats) ++ ")" + let cmd = "STATUS " ++ quoteMailboxName mbox ++ " (" ++ (unwords $ map show stats) ++ ")" in sendCommand conn cmd pStatus append :: IMAPConnection -> MailboxName -> ByteString -> IO () @@ -329,7 +328,7 @@ appendFull :: IMAPConnection -> MailboxName -> ByteString -> Maybe [Flag] -> Maybe CalendarTime -> IO () appendFull conn mbox mailData flags' time = do (buf, num) <- sendCommand' conn - (concat ["APPEND ", mbox + (concat ["APPEND ", quoteMailboxName mbox , fstr, tstr, " {" ++ show len ++ "}"]) when (BS.null buf || (BS.head buf /= '+')) $ fail "illegal server response" @@ -466,17 +465,26 @@ 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 ++ " " ++ mbox) pNone + sendCommand conn ("UID COPY " ++ uidStr ++ " " ++ quoteMailboxName mbox) pNone copy :: IMAPConnection -> UID -> MailboxName -> IO () copy conn uid mbox = copyFull conn (show uid) mbox move :: IMAPConnection -> UID -> MailboxName -> IO () -move conn uid mboxname = sendCommand conn ("UID MOVE " ++ show uid ++ " " ++ mboxname) pNone +move conn uid mboxname = sendCommand conn ("UID MOVE " ++ show uid ++ " " ++ quoteMailboxName mboxname) pNone ---------------------------------------------------------------------- -- auxialiary functions +quoteMailboxName :: MailboxName -> String +quoteMailboxName = quoteIMAPString . encodeMailboxName + +quoteIMAPString :: String -> String +quoteIMAPString s = "\"" ++ concatMap escapeChar s ++ "\"" + where escapeChar '"' = "\\\"" + escapeChar '\\' = "\\\\" + escapeChar c = [c] + showMonth :: Month -> String showMonth January = "Jan" showMonth February = "Feb" diff --git a/src/Network/HaskellNet/IMAP/Parsers.hs b/src/Network/HaskellNet/IMAP/Parsers.hs index f0b521f..04e750e 100644 --- a/src/Network/HaskellNet/IMAP/Parsers.hs +++ b/src/Network/HaskellNet/IMAP/Parsers.hs @@ -23,6 +23,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Network.HaskellNet.IMAP.Types +import Network.HaskellNet.IMAP.UTF7 eval :: (RespDerivs -> Result RespDerivs r) -> String -> ByteString -> r eval pMain tag s = case pMain (parse tag (Pos tag 1 1) s) of @@ -249,12 +250,16 @@ pListLine list = return attrs parseSep = space >> char '"' >> anyChar `manyTill` char '"' parseMailbox = do space - q <- optional $ char '"' - case q of - Just _ -> do mbox <- anyChar `manyTill` char '"' - anyChar `manyTill` crlfP - return mbox - Nothing -> anyChar `manyTill` crlfP + mbox <- pListMailboxName + 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 = diff --git a/src/Network/HaskellNet/IMAP/UTF7.hs b/src/Network/HaskellNet/IMAP/UTF7.hs new file mode 100644 index 0000000..6a8f3a6 --- /dev/null +++ b/src/Network/HaskellNet/IMAP/UTF7.hs @@ -0,0 +1,105 @@ +module Network.HaskellNet.IMAP.UTF7 + ( encodeMailboxName + , decodeMailboxName + ) +where + +import Data.Bits +import qualified Data.ByteString as B +import Data.Char (ord) +import Data.Word (Word8) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TextEncoding +import qualified Data.Text.Encoding.Error as TextEncodingError + +encodeMailboxName :: String -> String +encodeMailboxName [] = [] +encodeMailboxName ('&':cs) = "&-" ++ encodeMailboxName cs +encodeMailboxName cs@(c:rest') + | isDirect c = c : encodeMailboxName rest' + | otherwise = + let (encoded, rest) = span isShifted cs + in '&' : encodeBase64 (B.unpack (TextEncoding.encodeUtf16BE (Text.pack encoded))) + ++ "-" ++ encodeMailboxName rest + where + isShifted ch = ch /= '&' && not (isDirect ch) + +decodeMailboxName :: String -> String +decodeMailboxName [] = [] +decodeMailboxName ('&':'-':cs) = '&' : decodeMailboxName cs +decodeMailboxName ('&':cs) = + let (encoded, rest) = break (== '-') cs + rest' = dropDash rest + shifted = '&' : encoded ++ dash rest + in case rest of + '-' : _ -> + case decodeBase64 encoded of + Just decoded + | even (length decoded) -> + Text.unpack (TextEncoding.decodeUtf16BEWith + TextEncodingError.lenientDecode + (B.pack decoded)) + ++ decodeMailboxName rest' + _ -> shifted ++ decodeMailboxName rest' + _ -> shifted ++ decodeMailboxName rest' + where + dropDash ('-':rest) = rest + dropDash rest = rest + dash ('-':_) = "-" + dash _ = "" +decodeMailboxName (c:cs) = c : decodeMailboxName cs + +isDirect :: Char -> Bool +isDirect c = ord c >= 0x20 && ord c <= 0x7e && c /= '&' + +alphabet :: String +alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+," + +encodeBase64 :: [Word8] -> String +encodeBase64 [] = [] +encodeBase64 [a] = + [ alphabetAt (fromIntegral a `shiftR` 2) + , alphabetAt ((fromIntegral a .&. 0x03) `shiftL` 4) + ] +encodeBase64 [a, b] = + [ alphabetAt (fromIntegral a `shiftR` 2) + , alphabetAt (((fromIntegral a .&. 0x03) `shiftL` 4) .|. (fromIntegral b `shiftR` 4)) + , alphabetAt ((fromIntegral b .&. 0x0f) `shiftL` 2) + ] +encodeBase64 (a:b:c:rest) = + [ alphabetAt (fromIntegral a `shiftR` 2) + , alphabetAt (((fromIntegral a .&. 0x03) `shiftL` 4) .|. (fromIntegral b `shiftR` 4)) + , alphabetAt (((fromIntegral b .&. 0x0f) `shiftL` 2) .|. (fromIntegral c `shiftR` 6)) + , alphabetAt (fromIntegral c .&. 0x3f) + ] ++ encodeBase64 rest + +alphabetAt :: Int -> Char +alphabetAt n = alphabet !! n + +decodeBase64 :: String -> Maybe [Word8] +decodeBase64 [] = Just [] +decodeBase64 chars = + let (chunk, rest) = splitAt 4 chars + in do decodedChunk <- traverse base64Value chunk >>= decodeChunk + decodedRest <- decodeBase64 rest + return (decodedChunk ++ decodedRest) + +decodeChunk :: [Int] -> Maybe [Word8] +decodeChunk [a, b] = + Just [fromIntegral $ (a `shiftL` 2) .|. (b `shiftR` 4)] +decodeChunk [a, b, c] = + Just [ fromIntegral $ (a `shiftL` 2) .|. (b `shiftR` 4) + , fromIntegral $ ((b .&. 0x0f) `shiftL` 4) .|. (c `shiftR` 2) + ] +decodeChunk [a, b, c, d] = + Just [ fromIntegral $ (a `shiftL` 2) .|. (b `shiftR` 4) + , fromIntegral $ ((b .&. 0x0f) `shiftL` 4) .|. (c `shiftR` 2) + , fromIntegral $ ((c .&. 0x03) `shiftL` 6) .|. d + ] +decodeChunk _ = Nothing + +base64Value :: Char -> Maybe Int +base64Value c = + case lookup c (zip alphabet [0..]) of + Just n -> Just n + Nothing -> Nothing diff --git a/test/IMAPParsersTest.hs b/test/IMAPParsersTest.hs index eb6890e..95d4407 100644 --- a/test/IMAPParsersTest.hs +++ b/test/IMAPParsersTest.hs @@ -1,12 +1,76 @@ module Main (main) where +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BS +import Data.IORef +import Network.HaskellNet.BSStream +import qualified Network.HaskellNet.IMAP as IMAP +import Network.HaskellNet.IMAP.Connection import Network.HaskellNet.IMAP.Parsers import Network.HaskellNet.IMAP.Types +import System.Exit import System.Exit import Test.HUnit +data ReadStep = ReadLine ByteString | ReadBytes ByteString + +scriptedStream :: [ReadStep] -> IO (BSStream, IO ByteString) +scriptedStream steps = do + input <- newIORef steps + output <- newIORef [] + return (BSStream + { bsGetLine = popLine input + , bsGet = popBytes input + , bsPut = \bytes -> modifyIORef' output (bytes:) + , bsFlush = return () + , bsClose = return () + , bsIsOpen = return True + , bsWaitForInput = \_ -> return False + }, B.concat . reverse <$> readIORef output) + where + popLine input = do + steps' <- readIORef input + case steps' of + ReadLine line : rest -> writeIORef input rest >> return line + ReadBytes _ : _ -> assertFailure "expected test stream line, got bytes" + [] -> assertFailure "test stream exhausted while reading a line" + + popBytes input n = do + steps' <- readIORef input + case steps' of + ReadBytes bytes : rest -> + let (chunk, remainder) = BS.splitAt n bytes + next = if BS.null remainder then rest else ReadBytes remainder : rest + in writeIORef input next >> return chunk + ReadLine _ : _ -> assertFailure "expected test stream bytes, got a line" + [] -> assertFailure "test stream exhausted while reading bytes" + +scriptedConnection :: [ReadStep] -> IO (IMAPConnection, IO ByteString) +scriptedConnection steps = do + (testStream, written) <- scriptedStream steps + conn <- newConnection testStream + return (conn, written) + +line :: String -> ReadStep +line = ReadLine . BS.pack + +okLine :: String -> ReadStep +okLine = line . ("000000 OK " ++) + +commandBytes :: String -> ByteString +commandBytes cmd = BS.pack (cmd ++ "\r\n") + +assertCommand :: String -> ByteString -> [ReadStep] -> (IMAPConnection -> IO a) -> Test +assertCommand name expected steps action = + name ~: TestCase $ do + (conn, written) <- scriptedConnection steps + _ <- action conn + actual <- written + expected @=? actual + baseTest = [(OK Nothing "LOGIN Completed", MboxUpdate Nothing Nothing, ()) ~=? eval' pNone "A001" @@ -88,6 +152,13 @@ listTest = ~=? eval' pLsub "A002" "* LSUB () \".\" #news.comp.mail.mime\r\n\ \* LSUB () \".\" #news.comp.mail.misc\r\n\ \A002 OK LSUB completed\r\n" + , ( OK Nothing "LIST completed" + , MboxUpdate Nothing Nothing + , [([], "/", "Entwürfe") + ,([], "/", "A&B")]) + ~=? eval' pList "A003" "* LIST () \"/\" Entw&APw-rfe\r\n\ + \* LIST () \"/\" A&-B\r\n\ + \A003 OK LIST completed\r\n" ] statusTest = @@ -184,6 +255,69 @@ fetchTest = \a005 OK +FLAGS completed\r\n" ] +imapCommandTest = + [ assertCommand "create quotes mailbox" + (commandBytes "000000 CREATE \"foo bar\"") + [okLine "CREATE completed"] + (\conn -> IMAP.create conn "foo bar") + , assertCommand "delete quotes mailbox" + (commandBytes "000000 DELETE \"foo bar\"") + [okLine "DELETE completed"] + (\conn -> IMAP.delete conn "foo bar") + , assertCommand "rename quotes mailboxes" + (commandBytes "000000 RENAME \"old name\" \"new name\"") + [okLine "RENAME completed"] + (\conn -> IMAP.rename conn "old name" "new name") + , assertCommand "subscribe quotes mailbox" + (commandBytes "000000 SUBSCRIBE \"foo bar\"") + [okLine "SUBSCRIBE completed"] + (\conn -> IMAP.subscribe conn "foo bar") + , assertCommand "unsubscribe quotes mailbox" + (commandBytes "000000 UNSUBSCRIBE \"foo bar\"") + [okLine "UNSUBSCRIBE completed"] + (\conn -> IMAP.unsubscribe conn "foo bar") + , assertCommand "select escapes mailbox" + (commandBytes "000000 SELECT \"foo\\\"bar\"") + [okLine "[READ-WRITE] SELECT completed"] + (\conn -> IMAP.select conn "foo\"bar") + , assertCommand "select encodes utf7 mailbox" + (commandBytes "000000 SELECT \"Entw&APw-rfe\"") + [okLine "[READ-WRITE] SELECT completed"] + (\conn -> IMAP.select conn "Entwürfe") + , assertCommand "select encodes ampersand" + (commandBytes "000000 SELECT \"A&-B\"") + [okLine "[READ-WRITE] SELECT completed"] + (\conn -> IMAP.select conn "A&B") + , "status quotes mailbox" ~: TestCase $ do + (conn, written) <- scriptedConnection + [ line "* STATUS \"foo bar\" (MESSAGES 1)" + , okLine "STATUS completed" + ] + statusResult <- IMAP.status conn "foo bar" [MESSAGES] + [(MESSAGES, 1)] @=? statusResult + actual <- written + commandBytes "000000 STATUS \"foo bar\" (MESSAGES)" @=? actual + , "append quotes mailbox" ~: TestCase $ do + let mailData = BS.pack "Body" + (conn, written) <- scriptedConnection + [ line "+ Ready for literal" + , okLine "APPEND completed" + ] + IMAP.append conn "foo bar" mailData + actual <- written + B.concat [ commandBytes "000000 APPEND \"foo bar\" {6}" + , BS.pack "Body\r\n\r\n" + ] @=? actual + , assertCommand "copy quotes mailbox" + (commandBytes "000000 UID COPY 42 \"foo bar\"") + [okLine "COPY completed"] + (\conn -> IMAP.copy conn 42 "foo bar") + , assertCommand "move quotes mailbox" + (commandBytes "000000 UID MOVE 42 \"foo bar\"") + [okLine "MOVE completed"] + (\conn -> IMAP.move conn 42 "foo bar") + ] + testData = [ "base" ~: baseTest , "capability" ~: capabilityTest @@ -194,6 +328,7 @@ testData = [ "base" ~: baseTest , "expunge" ~: expungeTest , "search" ~: searchTest , "fetch" ~: fetchTest + , "imap commands" ~: imapCommandTest ]