Quote and encode IMAP mailbox names

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

src/Network/HaskellNet/IMAP.hs

@@ -30,6 +30,7 @@
 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)
@@ -259,7 +260,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 $
@@ -275,10 +276,8 @@
 
 _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 = _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 @@
 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 @@
            -> 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 @@
 
 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"

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 =

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