diff --git a/ftphs.cabal b/ftphs.cabal --- a/ftphs.cabal +++ b/ftphs.cabal @@ -1,10 +1,10 @@ Name: ftphs -Version: 1.0.9.1 +Version: 1.0.9.2 License: LGPL Maintainer: John Goerzen Author: John Goerzen Stability: Stable -Copyright: Copyright (c) 2004-2013 John Goerzen +Copyright: Copyright (c) 2004-2017 John Goerzen license-file: COPYRIGHT extra-source-files: COPYING, Makefile, @@ -12,16 +12,20 @@ Homepage: http://software.complete.org/ftphs Category: Network Synopsis: FTP Client and Server Library -Description: ftphs provides a Haskell library to implement a FTP client +Description: ftphs provides a Haskell library to implement a FTP client and a FTP server. . ftphs has a number of features: . - * Easy to use operation - * Full support of text and binary transfers - * Optional lazy interaction - * Server can serve up a real or a virtual filesystem tree - * Standards compliant + * Easy to use operation. + . + * Full support of text and binary transfers. + . + * Optional lazy interaction. + . + * Server can serve up a real or a virtual filesystem tree. + . + * Standards compliant. Build-Type: Simple Cabal-Version: >=1.2.3 @@ -40,13 +44,13 @@ UndecidableInstances, CPP, ScopedTypeVariables Build-Depends: network, parsec, base >= 3 && < 5, mtl, regex-compat, - hslogger, MissingH>=1.0.0 + hslogger, MissingH>=1.0.0, bytestring GHC-Options: -O2 Executable runtests if flag(buildtests) Buildable: True - Build-Depends: testpack, HUnit + Build-Depends: HUnit else Buildable: False Main-Is: runtests.hs diff --git a/src/Network/FTP/Client.hs b/src/Network/FTP/Client.hs --- a/src/Network/FTP/Client.hs +++ b/src/Network/FTP/Client.hs @@ -21,7 +21,7 @@ Copyright : Copyright (C) 2004-2005 John Goerzen License : GNU LGPL, version 2.1 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : experimental Portability: systems with networking @@ -33,7 +33,7 @@ Welcome to the FTP module for Haskell. Here is a quick usage example to get you started. This is a log of a real -session with ghci: +session with ghci: (This would be similar in a @do@ block. You could also save it to a file and run that with Hugs.) @@ -102,7 +102,7 @@ > -----BEGIN PGP SIGNATURE----- > Version: GnuPG v1.0.0 (GNU/Linux) > Comment: See http://www.kernel.org/signature.html for info -> +> > iD8DBQA54rf0yGugalF9Dw4RAqelAJ9lafFni4f/QyJ2IqDXzW2nz/ZIogCfRPtg > uYpWffOhkyByfhUt8Lcelec= > =KnLA @@ -200,41 +200,43 @@ module Network.FTP.Client(-- * Establishing\/Removing connections easyConnectFTP, connectFTP, - loginAnon, login, quit, + loginAnon, login, quit, -- * Configuration setPassive, isPassive, enableFTPDebugging, -- * Directory listing - nlst, dir, + nlst, dir, -- * File downloads getlines, getbinary, - downloadbinary, + downloadbinary, downloadlargebinary, -- * File uploads putlines, putbinary, uploadbinary, -- * File manipulation rename, delete, size, -- * Directory manipulation - cwd, mkdir, rmdir, pwd, + cwd, mkdir, rmdir, pwd, -- * Low-level advanced commands FTPConnection, transfercmd, ntransfercmd, retrlines, storlines, sendcmd ) where -import Network.FTP.Client.Parser -import Network.BSD -import Network.Socket -import System.IO.Binary +import Control.Exception +import Data.ByteString (hGet, hPut) +import Data.String.Utils import qualified Network -import System.IO -import System.IO.Unsafe -import System.Log.Logger -import Network.Utils -import Data.String.Utils -data FTPConnection = FTPConnection {readh :: IO String, - writeh :: Handle, +import Network.BSD +import Network.FTP.Client.Parser +import Network.Socket +import Network.Utils +import System.IO +import System.IO.Binary +import System.IO.Unsafe +import System.Log.Logger +data FTPConnection = FTPConnection {readh :: IO String, + writeh :: Handle, socket_internal :: Socket, - isPassive :: Bool} + isPassive :: Bool} getresp h = do c <- (readh h) @@ -261,7 +263,7 @@ The effect is global and persists until changed. -} enableFTPDebugging :: IO () -enableFTPDebugging = +enableFTPDebugging = do updateGlobalLogger "Network.FTP.Client.Parser" (setLevel DEBUG) updateGlobalLogger "Network.FTP.Client" (setLevel DEBUG) @@ -279,7 +281,7 @@ s <- connectTCP h p newh <- socketToHandle s ReadWriteMode hSetBuffering newh LineBuffering - let h = FTPConnection {readh = readchars newh, + let h = FTPConnection {readh = readchars newh, socket_internal = s, writeh = newh, isPassive = True} resp <- getresp h @@ -314,7 +316,7 @@ {- | Sets whether passive mode is used (returns new connection object reflecting this) -} -setPassive :: FTPConnection -> Bool -> FTPConnection +setPassive :: FTPConnection -> Bool -> FTPConnection setPassive f b = f{isPassive = b} {- | Finds the addres sof the remote. -} @@ -337,7 +339,7 @@ result <- sendcmd h ("PORT " ++ ps) return (mastersock, result) -{- | Establishes a connection to the remote. +{- | Establishes a connection to the remote. FIXME: need support for rest -} @@ -347,10 +349,16 @@ then do addr <- makepasv h s <- connectTCPAddr addr - r <- sendcmd h cmd - forceioresp 100 r - return s - else do + catch + (do + r <- sendcmd h cmd + forceioresp 100 r + return s) + ((\exc -> do + sClose s + throw exc + ) :: IOError -> IO Socket) + else do masterresult <- makeport h r <- sendcmd h cmd forceioresp 100 r @@ -389,7 +397,7 @@ hClose newh getresp h -{- | Retrieves lines of data from the remote. The string gives +{- | Retrieves lines of data from the remote. The string gives the command to issue. -} retrlines :: FTPConnection -> String -> IO ([String], FTPResult) retrlines h cmd = @@ -432,11 +440,11 @@ {- | Puts data in the specified file in text mode. The first string is the filename. -} putlines :: FTPConnection -> String -> [String] -> IO FTPResult -putlines h fn input = storlines h ("STOR " ++ fn) input +putlines h fn input = storlines h ("STOR " ++ fn) input {- | Puts data in the specified file in binary. The first string is the filename. -} putbinary :: FTPConnection -> String -> String -> IO FTPResult -putbinary h fn input = storbinary h ("STOR " ++ fn) input +putbinary h fn input = storbinary h ("STOR " ++ fn) input {- | Uploads a file from disk in binary mode. Note: filename is used for both local and remote. -} uploadbinary :: FTPConnection -> String -> IO FTPResult @@ -449,13 +457,37 @@ writeBinaryFile fn r0 return r1 -{- | Retrieves a list of files in the given directory. +{- | Similar to downloadbinary, but downloads the file in blocks of 4096 bytes +so that memory usage is limited when downloading large files. +Uses Data.ByteString's hGet to read data from the socket and hPut to write data +to the file, since it is more space and time efficient than String. -} +downloadlargebinary :: FTPConnection -> FilePath -> IO FTPResult +downloadlargebinary h fn = do + ftp_data_h <- transfercmd h $ "RETR " ++ fn + out_file_fh <- openFile fn WriteMode + getAndWrite ftp_data_h out_file_fh + getresp h + where + getAndWrite ftp_data_h out_file_fh = do + eof_p <- hIsEOF ftp_data_h + case eof_p of + True -> do + hClose ftp_data_h + hFlush out_file_fh + hClose out_file_fh + return () + False -> do + buf <- hGet ftp_data_h 4096 + hPut out_file_fh buf + getAndWrite ftp_data_h out_file_fh +{- | Retrieves a list of files in the given directory. + FIXME: should this take a list of dirs? -} nlst :: FTPConnection -> Maybe String -- ^ The directory to list. If Nothing, list the current directory. -> IO [String] -nlst h Nothing = retrlines h "NLST" >>= return . fst +nlst h Nothing = retrlines h "NLST" >>= return . fst nlst h (Just dirname) = retrlines h ("NLST " ++ dirname) >>= return . fst {- | Retrieve the system-specific long form of a directory list. @@ -464,7 +496,7 @@ dir :: FTPConnection -> Maybe String -- ^ The directory to list. If Nothing, list the current directory. -> IO [String] -dir h Nothing = retrlines h "LIST" >>= return . fst +dir h Nothing = retrlines h "LIST" >>= return . fst dir h (Just dirname) = retrlines h ("LIST " ++ dirname) >>= return . fst {- | Rename or move a file. -} @@ -483,8 +515,8 @@ {- | Change the working directory. -} cwd :: FTPConnection -> String -> IO FTPResult -cwd h ".." = sendcmd h "CDUP" -cwd h "" = cwd h "." +cwd h ".." = sendcmd h "CDUP" +cwd h "" = cwd h "." cwd h newdir = sendcmd h ("CWD " ++ newdir) {- | Get the size of a file. diff --git a/src/Network/FTP/Client/Parser.hs b/src/Network/FTP/Client/Parser.hs --- a/src/Network/FTP/Client/Parser.hs +++ b/src/Network/FTP/Client/Parser.hs @@ -21,7 +21,7 @@ Copyright : Copyright (C) 2004 John Goerzen License : GNU LGPL, version 2.1 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: systems with networking @@ -137,7 +137,7 @@ multiReplyComponent :: Parser [String] multiReplyComponent = (try (do - notMatching (do + notMatching (do codeString sp ) "found unexpected code" @@ -190,9 +190,9 @@ let logPlugin :: String -> String -> IO String logPlugin [] [] = return [] logPlugin [] accum = do - logit accum + logit accum return [] - logPlugin (x:xs) accum = + logPlugin (x:xs) accum = case x of '\n' -> do logit (strip (accum)) next <- unsafeInterleaveIO $ logPlugin xs [] @@ -217,9 +217,9 @@ let wport = (fromIntegral (port))::Word16 in do hn <- inet_ntoa hostaddr - return ((replace "." "," hn) ++ "," ++ + return ((replace "." "," hn) ++ "," ++ (genericJoin "," . getBytes $ wport)) -toPortString _ = +toPortString _ = error "toPortString only works on AF_INET addresses" -- | Converts a port string to a socket address. This is the inverse calculation of 'toPortString'. @@ -245,15 +245,14 @@ Nothing -> fail ("Could not find remote endpoint in " ++ (show f)) Just (_, x, _, _) -> fromPortString x - + parseDirName :: FTPResult -> Maybe String parseDirName (257, name:_) = let procq [] = [] procq ('"':_) = [] procq ('"' : '"' : xs) = '"' : procq xs procq (x:xs) = x : procq xs - in + in if head name /= '"' then Nothing else Just (procq (tail name)) - diff --git a/src/Network/FTP/Server.hs b/src/Network/FTP/Server.hs --- a/src/Network/FTP/Server.hs +++ b/src/Network/FTP/Server.hs @@ -21,7 +21,7 @@ Copyright : Copyright (C) 2004 John Goerzen License : GNU LGPL, version 2.1 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : experimental Portability: systems with networking @@ -43,7 +43,7 @@ "System.IO.HVFS" and "System.IO.HVIO" modules. In addition, basic networking and multitasking configuration is handled -via "Network.SocketServer" and logging via +via "Network.SocketServer" and logging via "System.Log.Logger". This module is believed to be secure, but it not believed to be robust enough @@ -103,7 +103,7 @@ data DataType = ASCII | Binary deriving (Eq, Show) -data AuthState = NoAuth +data AuthState = NoAuth | User String | Authenticated String deriving (Eq, Show) @@ -135,10 +135,10 @@ writethis [item] = ftpPutStrLn h (codes ++ " " ++ item) writethis (item:xs) = do ftpPutStrLn h (codes ++ "-" ++ item) writethis xs - in + in writethis (map (rstrip) (lines text)) -{- | Main FTP handler; pass the result of applying this to one argument to +{- | Main FTP handler; pass the result of applying this to one argument to 'Network.SocketServer.handleHandler' -} anonFtpHandler :: forall a. HVFSOpenable a => a -> Handle -> SockAddr -> SockAddr -> IO () @@ -175,7 +175,7 @@ forceLogin :: CommandHandler -> CommandHandler forceLogin func h@(FTPServer _ _ state) args = do state <- readIORef (auth state) - case state of + case state of Authenticated _ -> func h args x -> do sendReply h 530 "Command not possible in non-authenticated state." return True @@ -214,13 +214,13 @@ ("Closing due to error: " ++ (show (e::SomeException))) hClose fh return False - in do continue <- (flip catch) errorhandler + in do continue <- (flip catch) errorhandler (do x <- parseCommand fh case x of Left err -> do sendReply h 500 $ " Couldn't parse command: " ++ (show err) return True - Right (cmd, args) -> + Right (cmd, args) -> case lookupC cmd commands of Nothing -> do sendReply h 502 $ "Unrecognized command " ++ cmd @@ -244,7 +244,7 @@ help_user = ("Provide a username", - unlines $ + unlines $ ["USER username will provide the username for authentication." ,"It should be followed by a PASS command to finish the authentication." ]) @@ -268,7 +268,7 @@ cmd_pass h@(FTPServer _ _ state) passedargs = do curstate <- readIORef (auth state) case curstate of - User "anonymous" -> + User "anonymous" -> do sendReply h 230 "Anonymous login successful." writeIORef (auth state) (Authenticated "anonymous") infoM logname "Anonymous authentication successful" @@ -291,7 +291,7 @@ sendReply h 250 $ "New directory now " ++ newdir return True -help_cdup = +help_cdup = ("Change to parent directory", "Same as CWD ..") cmd_cdup h _ = cmd_cwd h ".." @@ -322,16 +322,16 @@ help_port = ("Initiate a port-mode connection", "") cmd_port :: CommandHandler cmd_port h@(FTPServer _ _ state) args = - let doIt clientsa = + let doIt clientsa = do writeIORef (datachan state) (PortMode clientsa) str <- showSockAddr clientsa sendReply h 200 $ "OK, later I will connect to " ++ str return True in do closeconn h -- Close any existing connection - trapIOError h (fromPortString args) $ (\clientsa -> + trapIOError h (fromPortString args) $ (\clientsa -> case clientsa of - SockAddrInet _ ha -> + SockAddrInet _ ha -> case (local state) of SockAddrInet _ ha2 -> if ha /= ha2 then do sendReply h 501 "Will only connect to same client as command channel." @@ -361,10 +361,10 @@ cmd_pasv :: CommandHandler cmd_pasv h@(FTPServer _ _ state) args = do closeconn h -- Close any existing connection - addr <- case (local state) of + addr <- case (local state) of (SockAddrInet _ ha) -> return ha _ -> fail "Require IPv4 sockets" - let ssopts = InetServerOptions + let ssopts = InetServerOptions { listenQueueSize = 1, portNumber = aNY_PORT, interface = addr, @@ -379,9 +379,9 @@ sendReply h 227 $ "Entering passive mode (" ++ portstring ++ ")" writeIORef (datachan state) (PassiveMode ss) return True - - - + + + help_noop = ("Do nothing", "") cmd_noop :: CommandHandler cmd_noop h _ = @@ -390,7 +390,7 @@ help_rnfr = ("Specify FROM name for a file rename", "") cmd_rnfr :: CommandHandler -cmd_rnfr h@(FTPServer _ _ state) args = +cmd_rnfr h@(FTPServer _ _ state) args = if length args < 1 then do sendReply h 501 "Filename required" return True @@ -423,7 +423,7 @@ if length args < 1 then do sendReply h 501 "Filename required" return True - else trapIOError h (vOpen fs args WriteMode) + else trapIOError h (vOpen fs args WriteMode) (\fhencap -> trapIOError h (do sendReply h 150 "File OK; about to open data channel" runDataChan h (runit fhencap) @@ -462,7 +462,7 @@ genericTransmit :: FTPServer -> a -> (a -> FTPServer -> Socket -> IO ()) -> IO Bool genericTransmit h dat func = - trapIOError h + trapIOError h (do sendReply h 150 "I'm going to open the data channel now." runDataChan h (func dat) ) (\_ -> @@ -485,7 +485,7 @@ if length args < 1 then do sendReply h 501 "Filename required" return True - else trapIOError h (vOpen fs args ReadMode) + else trapIOError h (vOpen fs args ReadMode) (\fhencap -> genericTransmitHandle h fhencap) help_rnto = ("Specify TO name for a file name", "") @@ -498,11 +498,11 @@ case fr of Nothing -> do sendReply h 503 "RNFR required before RNTO" return True - Just fromname -> + Just fromname -> do writeIORef (rename state) Nothing trapIOError h (vRenameFile fs fromname args) - $ \_ -> do sendReply h 250 - ("File " ++ fromname ++ + $ \_ -> do sendReply h 250 + ("File " ++ fromname ++ " renamed to " ++ args) return True @@ -608,8 +608,8 @@ ,"Auth Status : " ++ (show auth) ,"End of status."] return True - + help_help = ("Display help on available commands", "When called without arguments, shows a summary of available system\n" @@ -640,13 +640,13 @@ return True else let newargs = map toUpper args in case lookupC newargs commands of - Nothing -> do + Nothing -> do sendReply h 214 $ "No help for \"" ++ newargs ++ "\" is available.\nPlese send HELP" ++ " without arguments for a list of\n" ++ "valid commands." return True Just (Command _ (_, (summary, detail))) -> - do sendReply h 214 $ newargs ++ ": " ++ summary ++ + do sendReply h 214 $ newargs ++ ": " ++ summary ++ "\n\n" ++ detail return True diff --git a/src/Network/FTP/Server/Parser.hs b/src/Network/FTP/Server/Parser.hs --- a/src/Network/FTP/Server/Parser.hs +++ b/src/Network/FTP/Server/Parser.hs @@ -21,7 +21,7 @@ Copyright : Copyright (C) 2004 John Goerzen License : GNU LGPL, version 2.1 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: systems with networking @@ -65,10 +65,10 @@ args :: Parser String args = try (do char ' ' r <- many anyChar - eof + eof return r) <|> return "" - + command :: Parser (String, String) command = do diff --git a/testsrc/Network/FTP/Parsertest.hs b/testsrc/Network/FTP/Parsertest.hs --- a/testsrc/Network/FTP/Parsertest.hs +++ b/testsrc/Network/FTP/Parsertest.hs @@ -19,7 +19,6 @@ module Network.FTP.Parsertest(tests) where import Test.HUnit import Network.FTP.Client.Parser -import Test.HUnit.Tools import Network.Socket test_parseReply =