Preserve raw bytes in IMAP APPEND

HaskellNet.cabal

@@ -95,5 +95,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

@@ -259,7 +259,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,7 +333,7 @@
                         , fstr, tstr, " {" ++ show len ++ "}"])
        when (BS.null buf || (BS.head buf /= '+')) $
               fail "illegal server response"
-       mapM_ (bsPutCrLf $ stream conn) mailLines
+       bsPut (stream conn) mailData
        bsPutCrLf (stream conn) BS.empty
        buf2 <- getResponse $ stream conn
        let (resp, mboxUp, ()) = eval pNone (show6 num) buf2
@@ -342,8 +342,7 @@
          NO _ msg      -> fail ("NO: "++msg)
          BAD _ msg     -> fail ("BAD: "++msg)
          PREAUTH _ msg -> fail ("PREAUTH: "++msg)
-    where mailLines = BS.lines mailData
-          len       = sum $ map ((2+) . BS.length) mailLines
+    where len       = BS.length mailData
           tstr      = maybe "" ((" "++) . datetimeToStringIMAP) time
           fstr      = maybe "" ((" ("++) . (++")") . unwords . map show) flags'
 

test/IMAPParsersTest.hs

@@ -1,12 +1,69 @@
 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 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 _ : _ -> failRead "expected test stream line, got bytes"
+            [] -> failRead "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 _ : _ -> failRead "expected test stream bytes, got a line"
+            [] -> failRead "test stream exhausted while reading bytes"
+
+    failRead message = assertFailure message >> return BS.empty
+
+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")
+
 baseTest =
     [(OK Nothing "LOGIN Completed", MboxUpdate Nothing Nothing, ())
      ~=? eval' pNone "A001"
@@ -184,6 +241,22 @@ fetchTest =
                               \a005 OK +FLAGS completed\r\n"
     ]
 
+imapAppendTest =
+    [ "append preserves raw crlf message bytes" ~: TestCase $ do
+          let mailData = BS.pack "Subject: x\r\n\r\nBody\r\n"
+              expectedCommand = "000000 APPEND INBOX {" ++ show (BS.length mailData) ++ "}"
+          (conn, written) <- scriptedConnection
+              [ line "+ Ready for literal"
+              , okLine "APPEND completed"
+              ]
+          IMAP.append conn "INBOX" mailData
+          actual <- written
+          B.concat [ commandBytes expectedCommand
+                   , mailData
+                   , BS.pack "\r\n"
+                   ] @=? actual
+    ]
+
 
 testData = [ "base" ~: baseTest
            , "capability" ~: capabilityTest
@@ -194,6 +267,7 @@ testData = [ "base" ~: baseTest
            , "expunge" ~: expungeTest
            , "search" ~: searchTest
            , "fetch" ~: fetchTest
+           , "imap append api" ~: imapAppendTest
            ]