From 01767775b0d34a3f6c9b6e73938b88737627b1d3 Mon Sep 17 00:00:00 2001
From: Ken Wu <abawwu@gmail.com>
Date: Fri, 20 Jun 2014 23:53:34 +0800
Subject: [PATCH 1/3] Fixed binary mode for RETR

The original implementation is based on vGetContents which does not work
if the binary file contain byte sequence that could not be decoded into
[Char]. The new implementation is based on vGetBuf which works for
binary data.
---
 src/Network/FTP/Server.hs | 34 +++++++++++++++++++++++++++++-----
 1 file changed, 29 insertions(+), 5 deletions(-)

diff --git a/src/Network/FTP/Server.hs b/src/Network/FTP/Server.hs
index d711627..9c245e0 100644
--- a/src/Network/FTP/Server.hs
+++ b/src/Network/FTP/Server.hs
@@ -100,6 +100,7 @@ import Data.IORef
 import Data.List
 import Control.Exception (try, catch, finally, SomeException)
 import System.IO
+import Foreign.Marshal.Alloc (allocaBytes)
 
 data DataType = ASCII | Binary
               deriving (Eq, Show)
@@ -453,12 +454,35 @@ rtransmitString thestr (FTPServer _ _ state) sock =
                                 (hClose writeh)
 
 rtransmitH :: HVFSOpenEncap -> FTPServer -> Socket -> IO ()
-rtransmitH fhencap h sock =
-    case fhencap of
+rtransmitH fhencap h@(FTPServer _ _ state) sock =
+    let go fh = do writeh <- socketToHandle sock WriteMode
+                   hSetBuffering writeh (BlockBuffering (Just 4096))
+                   mode <- readIORef (datatype state)
+                   case mode of
+                       ASCII -> rtransmitAscii fh writeh
+                       Binary -> rtransmitBinary fh writeh
+      in
+      case fhencap of
        HVFSOpenEncap fh ->
-        finally (do c <- vGetContents fh
-                    rtransmitString c h sock
-                ) (vClose fh)
+        finally (go fh) (vClose fh)
+
+rtransmitAscii :: (HVIO a, HVIO b) => a -> b -> IO ()
+rtransmitAscii src dst =
+    let fixlines :: [String] -> [String]
+        fixlines x = map (\y -> y ++ "\r") x
+        copyit h = vPutStr h . unlines . fixlines . lines
+      in
+      vGetContents src >>= \s -> copyit dst s `finally` vClose dst
+
+rtransmitBinary :: (HVIO a, HVIO b) => a -> b -> IO ()
+rtransmitBinary src dst =
+    let bufSize = 4096
+        go buf src dst = do n <- vGetBuf src buf bufSize
+                            case n of
+                                0 -> return ()
+                                n' -> vPutBuf dst buf n' >> go buf src dst
+      in
+      allocaBytes bufSize $ \buf -> go buf src dst `finally` vClose dst
 
 genericTransmit :: FTPServer -> a -> (a -> FTPServer -> Socket -> IO ()) -> IO Bool
 genericTransmit h dat func =

From 14f438c29635f405f3ffa9b4f2b453f1fd91bd91 Mon Sep 17 00:00:00 2001
From: Ken Wu <abawwu@gmail.com>
Date: Sat, 21 Jun 2014 01:26:56 +0800
Subject: [PATCH 2/3] Removed rtransmitString

I implemented genericTransmitString based on genericTransmitHandle,
hence could remove the usage of rtransmitString.
---
 src/Network/FTP/Server.hs | 19 ++-----------------
 1 file changed, 2 insertions(+), 17 deletions(-)

diff --git a/src/Network/FTP/Server.hs b/src/Network/FTP/Server.hs
index 9c245e0..3e154a6 100644
--- a/src/Network/FTP/Server.hs
+++ b/src/Network/FTP/Server.hs
@@ -437,22 +437,6 @@ cmd_stor h@(FTPServer _ fs state) args =
                                    )
                    )
 
-rtransmitString :: String -> FTPServer  -> Socket -> IO ()
-rtransmitString thestr (FTPServer _ _ state) sock =
-    let fixlines :: [String] -> [String]
-        fixlines x = map (\y -> y ++ "\r") x
-        copyit h =
-            hPutStr h $ unlines . fixlines . lines $ thestr
-        in
-        do writeh <- socketToHandle sock WriteMode
-           hSetBuffering writeh (BlockBuffering (Just 4096))
-           mode <- readIORef (datatype state)
-           case mode of
-              ASCII -> finally (copyit writeh)
-                               (hClose writeh)
-              Binary -> finally (hPutStr writeh thestr)
-                                (hClose writeh)
-
 rtransmitH :: HVFSOpenEncap -> FTPServer -> Socket -> IO ()
 rtransmitH fhencap h@(FTPServer _ _ state) sock =
     let go fh = do writeh <- socketToHandle sock WriteMode
@@ -500,7 +484,8 @@ genericTransmitHandle h dat =
 
 genericTransmitString :: FTPServer -> String -> IO Bool
 genericTransmitString h dat =
-    genericTransmit h dat rtransmitString
+    do buf <- newMemoryBuffer dat (\_->return ())
+       genericTransmit h (HVFSOpenEncap buf) rtransmitH
 
 
 help_retr = ("Retrieve a file", "")

From 987d5d5510b1c53c22a120ba2881963d88051dac Mon Sep 17 00:00:00 2001
From: Ken Wu <abawwu@gmail.com>
Date: Sat, 21 Jun 2014 01:42:48 +0800
Subject: [PATCH 3/3] Fixed binary issue in cmd_stor

cmd_stor has similar issue with cmd_retr.
---
 src/Network/FTP/Server.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Network/FTP/Server.hs b/src/Network/FTP/Server.hs
index 3e154a6..6634e4c 100644
--- a/src/Network/FTP/Server.hs
+++ b/src/Network/FTP/Server.hs
@@ -418,7 +418,7 @@ cmd_stor h@(FTPServer _ fs state) args =
                       ASCII -> finally (hLineInteract readh fh datamap)
                                        (hClose readh)
                       Binary -> finally (do vSetBuffering fh (BlockBuffering (Just 4096))
-                                            hCopy readh fh
+                                            rtransmitBinary readh fh
                                         ) (hClose readh)
         in
         if length args < 1