Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Fixed issues in transfering file in binary mode #7

Open
wants to merge 3 commits into
base: master
Choose a base branch
from
Open

Fixed issues in transfering file in binary mode #7

Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
0176777
Fixed binary mode for RETR
abaw Jun 20, 2014
14f438c
Removed rtransmitString
abaw Jun 20, 2014
987d5d5
Fixed binary issue in cmd_stor
abaw Jun 20, 2014
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
55 changes: 32 additions & 23 deletions src/Network/FTP/Server.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -417,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
Expand All @@ -436,29 +437,36 @@ 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 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 =
Expand All @@ -476,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", "")
Expand Down