diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,130 @@ +# Changelog for ftp-client + +## 0.6.0.0 + +**Breaking change.** `withFTPS` now verifies the server's certificate chain and +host name. Validation was previously disabled, and a caller had no way to enable +it. Reported by @ysangkok in +, which proposed the same fix and +was approved but closed unmerged; this completes that change. + +If you connect to a server whose certificate cannot be validated, that +connection will now fail. Use the new `withFTPSSettings` with +`settingDisableCertificateValidation` set to keep the previous behaviour +deliberately. + +* `withFTPSSettings` takes `Connection.TLSSettings`, for callers who need to + choose their own. + +* Data connections now authenticate against the host the control connection was + opened to. They previously used the *local* end of the data socket, which no + server certificate can match. This is why enabling validation on the control + connection alone was not sufficient: PR #1 changed only that, and on its own + would have left every FTPS data transfer unable to validate. + +* `Security` now carries a `TLSContext` (settings, host, port) so a data + connection can reproduce the control connection's protection. `connectTLS`, + `createTLSConnection`, `withTLSHandle` and `tlsHandleImpl` take the settings + or context they need. + +* Reply lines are now length limited on both control connections. + `connectionGetLine` was called with `maxBound`, so a server that never sent a + newline could exhaust memory before authentication. The clear-channel handle + used unbounded `hGetLine`, which left `withFTP` replies -- and the plaintext + greeting and `AUTH TLS` reply that `createTLSConnection` reads before + authenticating -- without any limit at all. Both now apply + `maxReplyLineLength`, which is exported, and raise + `Network.Connection.LineTooLong` past it. + +* IO failures during a transfer are no longer reported as a completed one. + `recvAll`, `getAllLineResp` and `getMlsxResponse` turned any `IOError` into a + clean end of data, so a reset or timed-out connection produced a truncated + result that a caller could not distinguish from a whole one. End of input is + now distinguished from failure, and only end of input terminates a read. + +* Fixed three descriptor leaks: `createTLSConnection` on a refused greeting, + rejected `AUTH TLS` or failed handshake; the data handshake, where + `socketToHandle` had already invalidated the socket the release closed; and + the active-mode listening socket, which was never closed on success. + +* A data transfer that does not complete normally now still consumes the + server's completion reply. Left unread it became the answer to the next + command, and every reply after that belonged to the previous command. + + That drain is now conditional on a completion reply actually being pending. + A transfer the server rejects outright -- `PBSZ`, `PROT`, `PASV` or the + transfer command itself -- fails with its error reply already consumed, and + nothing further is coming, so draining blocked until the server gave up on + the connection. `PendingCompletion`, `newPendingCompletion` and + `drainPendingCompletion` are exported, and `createSendDataCommand` and + `createTLSSendDataCommand` take a `PendingCompletion`. + +* `TYPE A` transfers now send CRLF as RFC 959 requires. `sendType TA` doubled a + CR that was already there and appended a record the input did not have, and + `sendLine` sent a bare LF. + +* `ccc` and `auth` are removed. CCC cannot work here -- there is no way to + downgrade our side of the connection, so the control connection would + desynchronise -- and `auth` on its own tells the server to expect a handshake + that never happens. Both remain reachable as `FTPCommand` constructors. + +* `getLineRespMaybe`, `getAllLineResp`, `toNetworkAscii` and + `maxReplyLineLength` are now exported. + +## 0.5.3.1 + +* Enable the `henforcer` plugin and `fourmolu` under the `ci` flag. Imports are + now qualified per the house style and the source is fourmolu formatted; + neither changes the API. + +## 0.5.3.0 + +* Export `acct`, `pbsz`, `prot`, `ccc` and `auth`. These command wrappers were + defined but never exported, unlike every other command wrapper in the module. + +* Drop the `transformers` dependency. The only module it supplied, + `Control.Monad.IO.Class`, has been in `base` since 4.9. + +* Stop deriving `Typeable` for `FTPException`. It has been a no-op since GHC + 7.10 and GHC 9.12 warns about it. + +## 0.5.2.0 + +* Expose `createSIOHandle`, `createTLSConnection` and `connectTLS` so callers can + manage the handle lifecycle themselves rather than going through `withFTP` and + `withFTPS`. Thanks to @pucsdian. + +* Fix multiline response parsing. A response was terminated at the first + continuation line whose first three bytes matched the response code, so a reply + such as `220-First` / `220-Second` / `220 Third` was truncated to two lines. Per + [RFC 959](https://datatracker.ietf.org/doc/html/rfc959#page-36) only the code + followed by a space ends a multiline reply; the code followed by a hyphen + continues it. A final line consisting of the bare code is also accepted, for + servers that omit the trailing space. Thanks to @pucsdian. + +## 0.5.1.8 + +* Fix a crash on short response lines. `getResponse` called `head` on the bytes + following the response code, so a line shorter than four bytes failed with + `Prelude.head: empty list` instead of an `FTPException`. Response lines that do + not begin with a three digit code now raise `BadProtocolResponseException`. + +* Fix a hang when the server closes the connection partway through a multiline + response. The read loop had no terminating condition other than the closing + code, so it never returned. An exhausted stream now raises + `BadProtocolResponseException`. The loop terminates, and a reply the server + never finished is reported as bad rather than handed back as though it were + complete -- which would have let a truncated `220-` greeting read as a + successful 220 and let `withFTP` proceed against a dead control connection. + +## 0.5.1.7 + +* Correct the `base` bound. The package claimed `>= 4.8`, i.e. support back to + GHC 7.10, but no compiler that old can build it because `crypton-connection` + does not exist there. The bound is now `>= 4.16`, the oldest GHC that is + actually tested, and `tested-with` records the full set. + +## Earlier releases + +Prior to 0.5.1.7 this package had no changelog. See the git history at + for changes in earlier versions. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -13,9 +13,24 @@ ``` ## Secured with TLS + +`withFTPS` verifies the server's certificate chain and host name, so a server +that cannot be validated is refused. + ```haskell withFTPS "ftps.server.com" 21 $ \h welcome -> do print welcome login h "username" "password" print =<< nlst h [] +``` + +To talk to a server whose certificate cannot be validated, pass your own +settings. Disabling validation leaves the connection encrypted but not +authenticated, so anyone on the network path can read the credentials and alter +transferred data: + +```haskell +let insecure = def { settingDisableCertificateValidation = True } +withFTPSSettings insecure "ftps.server.com" 21 $ \h welcome -> + print welcome ``` diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/ftp-client.cabal b/ftp-client.cabal --- a/ftp-client.cabal +++ b/ftp-client.cabal @@ -1,43 +1,99 @@ -name: ftp-client -version: 0.5.1.6 -synopsis: Transfer files with FTP and FTPS -description: ftp-client is a library for communicating with an FTP server. It works over both a clear channel or TLS. -homepage: https://github.com/flipstone/ftp-client -license: PublicDomain -maintainer: Flipstone Technology Partners -license-file: LICENSE -author: Megan Robinson -category: Web -build-type: Simple -extra-source-files: README.md -cabal-version: >=1.10 +cabal-version: 1.12 -library - hs-source-dirs: src - exposed-modules: Network.FTP.Client - default-language: Haskell2010 - default-extensions: OverloadedStrings - build-depends: base >= 4.8 && < 5 - , bytestring >= 0.10.8.2 && < 0.13 - , network >= 2.6.3.6 && < 3.3 - , attoparsec >= 0.10 && < 0.15 - , crypton-connection >= 0.3 && < 0.5 - , transformers >= 0.5.6.2 && < 0.7 - , exceptions >= 0.10.3 && < 0.11 - , containers >= 0.5.11.0 && < 0.8 - , data-default-class >= 0.1.2.0 && < 0.2 +-- This file has been generated from package.yaml by hpack version 0.39.1. +-- +-- see: https://github.com/sol/hpack -test-suite ftp-client-test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: test.hs - build-depends: base >=4.11.1.0 && < 5 - , bytestring >=0.10.8.2 && <0.13 - , hspec >= 2.7 - , ftp-client -any - ghc-options: -threaded -rtsopts -with-rtsopts=-N - default-language: Haskell2010 +name: ftp-client +version: 0.6.0.0 +synopsis: Transfer files with FTP and FTPS +description: ftp-client is a library for communicating with an FTP server. It works over both a clear channel or TLS. +category: Web +homepage: https://github.com/flipstone/ftp-client +author: Megan Robinson +maintainer: Flipstone Technology Partners +license: PublicDomain +license-file: LICENSE +build-type: Simple +tested-with: + GHC == 9.2.8 + , GHC == 9.4.8 + , GHC == 9.6.7 + , GHC == 9.8.4 + , GHC == 9.10.3 + , GHC == 9.12.4 +extra-source-files: + README.md + CHANGELOG.md + henforcer.toml source-repository head - type: git + type: git location: https://github.com/flipstone/ftp-client + +flag ci + description: More strict ghc options used for development and ci, not intended for end-use. + manual: True + default: False + +library + exposed-modules: + Network.FTP.Client + other-modules: + Paths_ftp_client + hs-source-dirs: + src + default-extensions: + OverloadedStrings + build-depends: + attoparsec >=0.10 && <0.15 + , base >=4.16 && <5 + , bytestring >=0.10.8.2 && <0.13 + , containers >=0.5.11.0 && <0.8 + , crypton-connection >=0.3 && <0.5 + , data-default-class >=0.1.2.0 && <0.3 + , exceptions >=0.10.3 && <0.11 + , network >=2.6.3.6 && <3.3 + default-language: Haskell2010 + if flag(ci) + ghc-options: -O2 -Wall -Werror -Wcompat -Widentities -Winvalid-haddock -Wmissing-local-signatures -Wmissing-export-lists -Wpartial-fields -Wmissed-specialisations -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wunused-packages + if impl (ghc < 9.4) + ghc-options: -Wno-unticked-promoted-constructors + if impl (ghc >= 9.4) + ghc-options: -Wimplicit-lift -Woperator-whitespace -Wredundant-bang-patterns -Wredundant-strictness-flags + if impl (ghc >= 9.8) + ghc-options: -Wincomplete-export-warnings -Wmissing-poly-kind-signatures -Wterm-variable-capture + if impl (ghc >= 9.10) + ghc-options: -Wdefaulted-exception-context + if impl (ghc >= 9.6) + ghc-options: -fplugin Henforcer + build-depends: + henforcer + +test-suite ftp-client-test + type: exitcode-stdio-1.0 + main-is: test.hs + other-modules: + Paths_ftp_client + hs-source-dirs: + test + build-depends: + base >=4.16 && <5 + , bytestring >=0.10.8.2 && <0.13 + , crypton-connection >=0.3 && <0.5 + , directory ==1.3.* + , ftp-client + , hspec >=2.7 + default-language: Haskell2010 + if flag(ci) + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Werror -Wcompat -Widentities -Winvalid-haddock -Wmissing-local-signatures -Wmissing-export-lists -Wpartial-fields -Wmissed-specialisations -Wno-implicit-prelude -Wno-safe -Wno-unsafe + if impl (ghc < 9.4) + ghc-options: -Wno-unticked-promoted-constructors + if impl (ghc >= 9.4) + ghc-options: -Wimplicit-lift -Woperator-whitespace -Wredundant-bang-patterns -Wredundant-strictness-flags + if impl (ghc >= 9.8) + ghc-options: -Wincomplete-export-warnings -Wmissing-poly-kind-signatures -Wterm-variable-capture + if impl (ghc >= 9.10) + ghc-options: -Wdefaulted-exception-context + else + ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/henforcer.toml b/henforcer.toml new file mode 100644 --- /dev/null +++ b/henforcer.toml @@ -0,0 +1,10 @@ +[forAnyModule] +allowedOpenUnaliasedImports = 1 +moduleHeaderCopyrightMustExistNonEmpty = true +moduleHeaderDescriptionMustExistNonEmpty = false +moduleHeaderLicenseMustExistNonEmpty = true +moduleHeaderMaintainerMustExistNonEmpty = false +[[forPatternModules]] +pattern = "Paths_*" +[forPatternModules.rulesToIgnore] +all = true 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 @@ -1,811 +1,1173 @@ -{-| -Module : Network.FTP.Client -Description : Transfer files over FTP and FTPS -License : Public Domain -Stability : experimental -Portability : POSIX --} -module Network.FTP.Client ( - -- * Main Entrypoints - withFTP, - withFTPS, - -- * Control Commands - login, - pasv, - rename, - dele, - cwd, - size, - mkd, - rmd, - pwd, - quit, - -- * Data Commands - nlst, - retr, - list, - stor, - mlsd, - mlst, - -- * Types - FTPCommand(..), - FTPResponse(..), - FTPMessage(..), - ResponseStatus(..), - MlsxResponse(..), - RTypeCode(..), - PortActivity(..), - ProtType(..), - Security(..), - Handle(..), - -- * Exceptions - FTPException(..), - -- * Handle Implementations - sIOHandleImpl, - tlsHandleImpl, - -- * Lower Level Functions - sendCommand, - sendCommandS, - recvAll, - sendAll, - sendAllS, - getLineResp, - getResponse, - getResponseS, - sendCommandLine, - createSendDataCommand, - createTLSSendDataCommand, - parseMlsxLine -) where - -import Data.Default.Class (def) -import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString as B -import Data.ByteString (ByteString) -import Data.List -import Data.Attoparsec.ByteString.Char8 -import qualified Network.Socket as S -import qualified System.IO as SIO -import Data.Monoid ((<>)) -import Control.Exception -import Control.Monad.Catch (MonadCatch, MonadMask) -import qualified Control.Monad.Catch as M -import Control.Monad -import Control.Monad.IO.Class -import Data.Bits -import Network.Connection -import Data.ByteString.Lazy.Internal (defaultChunkSize) -import Data.Functor ((<$>)) -import Control.Applicative ((<*>)) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Control.Arrow -import Data.Typeable - -debugging :: Bool -debugging = False - -debugPrint :: (Show a, MonadIO m) => a -> m () -debugPrint s = when debugging (liftIO $ print s) - -debugResponse :: (Show a, MonadIO m) => a -> m () -debugResponse s = debugPrint $ "Recieved: " <> show s - -data Security = Clear | TLS - --- | Can send and recieve a 'Data.ByteString.ByteString'. -data Handle = Handle - { send :: ByteString -> IO () - , sendLine :: ByteString -> IO () - , recv :: Int -> IO ByteString - , recvLine :: IO ByteString - , security :: Security - } - -data FTPMessage = SingleLine ByteString | MultiLine [ByteString] - deriving Eq - -instance Show FTPMessage where - show (SingleLine message) = C.unpack message - show (MultiLine messages) = intercalate "\n" $ C.unpack <$> messages - --- | Response from an FTP command. ex "200 Welcome!" -data FTPResponse = FTPResponse { - frStatus :: ResponseStatus, -- ^ Interpretation of the first digit of an FTP response code - frCode :: Int, -- ^ The three digit response code - frMessage :: FTPMessage -- ^ Text of the response -} deriving Eq - -instance Show FTPResponse where - show fr = show (frCode fr) <> " " <> show (frMessage fr) - --- | First digit of an FTP response -data ResponseStatus - = Wait -- ^ 1 - | Success -- ^ 2 - | Continue -- ^ 3 - | FailureRetry -- ^ 4 - | Failure -- ^ 5 - deriving (Show, Eq) - -data FTPException - = FailureRetryException FTPResponse - | FailureException FTPResponse - | UnsuccessfulException FTPResponse - | BogusResponseFormatException FTPResponse - | BadProtocolResponseException ByteString - deriving (Show, Typeable) - -instance Exception FTPException - -responseStatus :: ByteString -> ResponseStatus -responseStatus cbs = - case C.uncons cbs of - Just ('1', _) -> Wait - Just ('2', _) -> Success - Just ('3', _) -> Continue - Just ('4', _) -> FailureRetry - Just ('5', _) -> Failure - _ -> throw $ BadProtocolResponseException cbs - -data RTypeCode = TA | TI - -serialzeRTypeCode :: RTypeCode -> String -serialzeRTypeCode TA = "A" -serialzeRTypeCode TI = "I" - -data PortActivity = Active | Passive - -data ProtType = P | C - --- | Commands according to the FTP specification -data FTPCommand - = User String - | Pass String - | Acct String - | RType RTypeCode - | Retr String - | Nlst [String] - | Port S.HostAddress S.PortNumber - | Stor String - | List [String] - | Rnfr String - | Rnto String - | Dele String - | Size String - | Mkd String - | Rmd String - | Pbsz Int - | Prot ProtType - | Mlsd String - | Mlst String - | Cwd String - | Cdup - | Ccc - | Auth - | Pwd - | Abor - | Pasv - | Quit - -instance Show FTPCommand where - show = serializeCommand - -formatPort :: S.HostAddress -> S.PortNumber -> String -formatPort ha pn = - let (w1, w2, w3, w4) = S.hostAddressToTuple ha - hn = show <$> [w1, w2, w3, w4] - portParts = show <$> [pn `quot` 256, pn `mod` 256] - in intercalate "," (hn <> portParts) - -serializeCommand :: FTPCommand -> String -serializeCommand (User user) = "USER " <> user -serializeCommand (Pass pass) = "PASS " <> pass -serializeCommand (Acct acct) = "ACCT " <> acct -serializeCommand (RType rt) = "TYPE " <> serialzeRTypeCode rt -serializeCommand (Retr file) = "RETR " <> file -serializeCommand (Nlst []) = "NLST" -serializeCommand (Nlst args) = "NLST " <> unwords args -serializeCommand (Port ha pn) = "PORT " <> formatPort ha pn -serializeCommand (Stor loc) = "STOR " <> loc -serializeCommand (List []) = "LIST" -serializeCommand (List args) = "LIST " <> unwords args -serializeCommand (Rnfr from) = "RNFR " <> from -serializeCommand (Rnto to) = "RNTO " <> to -serializeCommand (Dele file) = "DELE " <> file -serializeCommand (Size file) = "SIZE " <> file -serializeCommand (Mkd dir) = "MKD " <> dir -serializeCommand (Rmd dir) = "RMD " <> dir -serializeCommand (Pbsz buf) = "PBSZ " <> show buf -serializeCommand (Prot P) = "PROT P" -serializeCommand (Prot C) = "PROT C" -serializeCommand (Mlsd path) = "MLSD " <> path -serializeCommand (Mlst path) = "MLST " <> path -serializeCommand (Cwd dir) = "CWD " <> dir -serializeCommand Cdup = "CDUP" -serializeCommand Ccc = "CCC" -serializeCommand Auth = "AUTH TLS" -serializeCommand Pwd = "PWD" -serializeCommand Abor = "ABOR" -serializeCommand Pasv = "PASV" -serializeCommand Quit = "QUIT" - -stripCLRF :: ByteString -> ByteString -stripCLRF = C.takeWhile $ (&&) <$> (/= '\r') <*> (/= '\n') - --- | Get a line from the server -getLineResp :: Handle -> IO ByteString -getLineResp h = stripCLRF <$> recvLine h - --- | Get a full response from the server --- Used in 'sendCommand' -getResponse :: MonadIO m => Handle -> m FTPResponse -getResponse h = do - line <- liftIO $ getLineResp h - let (code, rest) = C.splitAt 3 line - message <- if C.head rest == '-' - then MultiLine <$> loopMultiLine h code [line] - else return $ SingleLine line - let codeDroppedMessage = case message of - SingleLine message -> SingleLine $ C.drop 4 message - MultiLine [] -> MultiLine [] - MultiLine (message:messages) -> - MultiLine $ C.drop 4 message : messages - let response = FTPResponse - (responseStatus code) - (read $ C.unpack code) - codeDroppedMessage - case frStatus response of - FailureRetry -> liftIO $ throwIO $ FailureRetryException response - Failure -> liftIO $ throwIO $ FailureException response - _ -> return response - -loopMultiLine - :: MonadIO m - => Handle - -> ByteString - -> [ByteString] - -> m [ByteString] -loopMultiLine h code lines = do - nextLine <- liftIO $ getLineResp h - let newLines = lines <> [C.dropWhile (== ' ') nextLine] - nextCode = C.take 3 nextLine - if nextCode == code - then return newLines - else loopMultiLine h code newLines - -ensureSuccess :: MonadIO m => FTPResponse -> m FTPResponse -ensureSuccess resp = - case frStatus resp of - Success -> return resp - _ -> liftIO $ throwIO $ UnsuccessfulException resp - -getResponseS :: MonadIO m => Handle -> m FTPResponse -getResponseS = ensureSuccess <=< getResponse - -sendCommandLine :: MonadIO m => Handle -> ByteString -> m () -sendCommandLine h = liftIO . send h . (<> "\r\n") - --- | Send a command to the server and get a response back. --- Some commands use a data 'Handle', and their data is not returned here. -sendCommand :: MonadIO m => Handle -> FTPCommand -> m FTPResponse -sendCommand h fc = do - let command = serializeCommand fc - debugPrint $ "Sending: " <> command - sendCommandLine h $ C.pack command - resp <- getResponse h - debugResponse resp - return resp - -sendCommandS :: MonadIO m => Handle -> FTPCommand -> m FTPResponse -sendCommandS h fc = sendCommand h fc >>= ensureSuccess - --- | Equvalent to --- --- > mapM . sendCommand -sendAll :: MonadIO m => Handle -> [FTPCommand] -> m [FTPResponse] -sendAll = mapM . sendCommand - --- | Equvalent to --- --- > mapM . sendCommandS -sendAllS :: MonadIO m => Handle -> [FTPCommand] -> m [FTPResponse] -sendAllS = mapM . sendCommandS - --- Control connection - -createSocket - :: MonadIO m - => Maybe String - -> Int - -> S.AddrInfo - -> m (S.Socket, S.AddrInfo) -createSocket host portNum hints = do - addr <- liftIO $ do - a:_ <- S.getAddrInfo (Just hints) host (Just $ show portNum) - return a - debugPrint $ "Addr: " <> show addr - sock <- liftIO $ S.socket - (S.addrFamily addr) - (S.addrSocketType addr) - (S.addrProtocol addr) - return (sock, addr) - -withSocketPassive - :: (MonadIO m, MonadMask m) - => String - -> Int - -> (S.Socket -> m a) - -> m a -withSocketPassive host portNum f = do - let hints = S.defaultHints { - S.addrSocketType = S.Stream - } - M.bracketOnError - (createSocket (Just host) portNum hints) - (liftIO . S.close . fst) - (\(sock, addr) -> do - debugPrint "Connecting" - liftIO $ S.connect sock (S.addrAddress addr) - debugPrint "Connected" - f sock - ) - -withSocketActive :: (MonadIO m, MonadMask m) => (S.Socket -> m a) -> m a -withSocketActive f = do - let hints = S.defaultHints { - S.addrSocketType = S.Stream, - S.addrFlags = [S.AI_PASSIVE] - } - M.bracketOnError - (createSocket Nothing 0 hints) - (liftIO . S.close . fst) - (\(sock, addr) -> do - debugPrint "Binding" - liftIO $ S.bind sock (S.addrAddress addr) - liftIO $ S.listen sock 1 - debugPrint "Listening" - f sock - ) - -createSIOHandle :: (MonadIO m, MonadMask m) => String -> Int -> m SIO.Handle -createSIOHandle host portNum = withSocketPassive host portNum - $ liftIO . flip S.socketToHandle SIO.ReadWriteMode - -sIOHandleImpl :: SIO.Handle -> Handle -sIOHandleImpl h = Handle - { send = C.hPut h - , sendLine = C.hPutStrLn h - , recv = C.hGetSome h - , recvLine = C.hGetLine h - , security = Clear - } - -withSIOHandle - :: (MonadIO m, MonadMask m) - => String - -> Int - -> (Handle -> m a) - -> m a -withSIOHandle host portNum f = M.bracket - (liftIO $ createSIOHandle host portNum) - (liftIO . SIO.hClose) - (f . sIOHandleImpl) - --- | Takes a host name and port. A handle for interacting with the server --- will be returned in a callback. --- --- @ --- withFTP "ftp.server.com" 21 $ \h welcome -> do --- print welcome --- login h "username" "password" --- print =<< nlst h [] --- @ -withFTP - :: (MonadIO m, MonadMask m) - => String - -> Int - -> (Handle -> FTPResponse -> m a) - -> m a -withFTP host portNum f = withSIOHandle host portNum $ \h -> do - resp <- getResponse h - f h resp - --- Data connection - -withDataSocketPasv - :: (MonadIO m, MonadMask m) - => Handle - -> (S.Socket -> m a) - -> m a -withDataSocketPasv h f = do - (host, portNum) <- pasv h - debugPrint $ "Host: " <> host - debugPrint $ "Port: " <> show portNum - withSocketPassive host portNum f - -withDataSocketActive - :: (MonadIO m, MonadMask m) - => Handle - -> (S.Socket -> m a) - -> m a -withDataSocketActive h f = withSocketActive $ \socket -> do - (sPort, sHost) <- liftIO $ do - (S.SockAddrInet p h) <- S.getSocketName socket - return (p,h) - port h sHost sPort - f socket - --- | Open a socket that can be used for data transfers -withDataSocket - :: (MonadIO m, MonadMask m) - => PortActivity - -> Handle - -> (S.Socket -> m a) - -> m a -withDataSocket Active = withDataSocketActive -withDataSocket Passive = withDataSocketPasv - -acceptData :: MonadIO m => PortActivity -> S.Socket -> m S.Socket -acceptData Passive = return -acceptData Active = return . fst <=< liftIO . S.accept - --- Response to data commands should be 150 but apparently --- some servers will respond with 200 before 150 so just ignore it -ensureSucessfulData :: MonadIO m => Handle -> FTPResponse -> m () -ensureSucessfulData h resp = do - resp' <- case frStatus resp of - Success -> do - newResp <- getResponse h - debugResponse newResp - return newResp - _ -> return resp - liftIO $ when (frStatus resp' /= Wait) - $ throwIO $ UnsuccessfulException resp - --- | Send setup commands to the server and --- create a data 'System.IO.Handle' -createSendDataCommand - :: (MonadIO m, MonadMask m) - => Handle - -> PortActivity - -> FTPCommand - -> m SIO.Handle -createSendDataCommand h pa cmd = withDataSocket pa h $ \socket -> do - resp <- sendCommand h cmd - ensureSucessfulData h resp - acceptedSock <- acceptData pa socket - liftIO $ S.socketToHandle acceptedSock SIO.ReadWriteMode - --- | Provides a data 'Handle' in a callback for a command -withDataCommand - :: (MonadIO m, MonadMask m) - => Handle - -> PortActivity - -> RTypeCode - -> FTPCommand - -> (Handle -> m a) - -> m a -withDataCommand ch pa code cmd f = do - sendCommandS ch $ RType code - x <- M.bracket - (createSendDataCommand ch pa cmd) - (liftIO . SIO.hClose) - (f . sIOHandleImpl) - resp <- getResponse ch - debugResponse resp - return x - --- | Recieve data and interpret it linewise -getAllLineResp :: (MonadIO m, MonadCatch m) => Handle -> m ByteString -getAllLineResp h = getAllLineResp' h [] - where - getAllLineResp' h ret = ( do - line <- liftIO $ getLineResp h - getAllLineResp' h (ret <> [line])) - `M.catchIOError` (\_ -> return $ C.intercalate "\n" ret) - --- | Recieve all data and return it as a 'Data.ByteString.ByteString' -recvAll :: (MonadIO m, MonadCatch m) => Handle -> m ByteString -recvAll h = recvAll' "" - where - recvAll' bs = ( do - chunk <- liftIO $ recv h defaultChunkSize - if C.null chunk - then return bs - else recvAll' $ bs <> chunk - ) `M.catchIOError` (\_ -> return bs) - --- TLS connection - -connectTLS :: MonadIO m => SIO.Handle -> String -> Int -> m Connection -connectTLS h host portNum = do - context <- liftIO initConnectionContext - let tlsSettings = def - { settingDisableCertificateValidation = True - } - connectionParams = ConnectionParams - { connectionHostname = host - , connectionPort = toEnum . fromEnum $ portNum - , connectionUseSecure = Just tlsSettings - , connectionUseSocks = Nothing - } - liftIO $ connectFromHandle context h connectionParams - -createTLSConnection - :: (MonadIO m, MonadMask m) - => String - -> Int - -> m (FTPResponse, Connection) -createTLSConnection host portNum = do - h <- createSIOHandle host portNum - let insecureH = sIOHandleImpl h - resp <- getResponse insecureH - sendCommand insecureH Auth - conn <- connectTLS h host portNum - return (resp, conn) - -tlsHandleImpl :: Connection -> Handle -tlsHandleImpl c = Handle - { send = connectionPut c - , sendLine = connectionPut c . (<> "\n") - , recv = connectionGet c - , recvLine = connectionGetLine maxBound c - , security = TLS - } - -withTLSHandle - :: (MonadMask m, MonadIO m) - => String - -> Int - -> (Handle -> FTPResponse -> m a) - -> m a -withTLSHandle host portNum f = M.bracket - (createTLSConnection host portNum) - (liftIO . connectionClose . snd) - (\(resp, conn) -> f (tlsHandleImpl conn) resp) - --- | Takes a host name and port. A handle for interacting with the server --- will be returned in a callback. The commands will be protected with TLS. --- --- @ --- withFTPS "ftps.server.com" 21 $ \h welcome -> do --- print welcome --- login h "username" "password" --- print =<< nlst h [] --- @ -withFTPS - :: (MonadMask m, MonadIO m) - => String - -> Int - -> (Handle -> FTPResponse -> m a) - -> m a -withFTPS = withTLSHandle - --- TLS data connection - --- | Send setup commands to the server and --- create a data TLS connection -createTLSSendDataCommand - :: (MonadIO m, MonadMask m) - => Handle - -> PortActivity - -> FTPCommand - -> m Connection -createTLSSendDataCommand ch pa cmd = do - sendAllS ch [Pbsz 0, Prot P] - withDataSocket pa ch $ \socket -> do - resp <- sendCommand ch cmd - ensureSucessfulData ch resp - acceptedSock <- acceptData pa socket - (sPort, sHost) <- liftIO $ do - (S.SockAddrInet p h) <- S.getSocketName acceptedSock - return (p, h) - let (h1, h2, h3, h4) = S.hostAddressToTuple sHost - hostName = intercalate "." $ show . fromEnum <$> [h1, h2, h3, h4] - h <- liftIO $ S.socketToHandle acceptedSock SIO.ReadWriteMode - liftIO $ connectTLS h hostName (fromEnum sPort) - -withTLSDataCommand - :: (MonadIO m, MonadMask m) - => Handle - -> PortActivity - -> RTypeCode - -> FTPCommand - -> (Handle -> m a) - -> m a -withTLSDataCommand ch pa code cmd f = do - sendCommandS ch $ RType code - x <- M.bracket - (createTLSSendDataCommand ch pa cmd) - (liftIO . connectionClose) - (f . tlsHandleImpl) - resp <- getResponse ch - debugPrint $ "Recieved: " <> show resp - return x - -parseResponse :: MonadIO m => FTPResponse -> Parser a -> m a -parseResponse resp p = - let parsableMessage = case frMessage resp of - SingleLine message -> message - MultiLine messages -> C.intercalate "\n" messages - in case parseOnly p parsableMessage of - Right x -> return x - Left _ -> liftIO $ throwIO - $ BadProtocolResponseException parsableMessage - -ensureCode :: MonadIO m => FTPResponse -> Int -> m () -ensureCode resp code = - liftIO $ when (frCode resp /= code) - $ liftIO $ throwIO $ UnsuccessfulException resp - -parse227 :: Parser (String, Int) -parse227 = do - skipWhile (/= '(') *> char '(' - [h1,h2,h3,h4,p1,p2] <- many1 digit `sepBy` char ',' - let host = intercalate "." [h1,h2,h3,h4] - highBits = read p1 - lowBits = read p2 - portNum = (highBits `shift` 8) + lowBits - return (host, portNum) - -parse257 :: Parser String -parse257 = do - char '"' - C.unpack <$> takeTill (== '"') - --- Control commands - -login :: MonadIO m => Handle -> String -> String -> m FTPResponse -login h user pass = do - resp <- last <$> sendAll h [User user, Pass pass] - ensureSuccess resp - -pasv :: MonadIO m => Handle -> m (String, Int) -pasv h = do - resp <- sendCommandS h Pasv - ensureCode resp 227 - parseResponse resp parse227 - -port :: MonadIO m => Handle -> S.HostAddress -> S.PortNumber -> m FTPResponse -port h ha pn = sendCommandS h (Port ha pn) - -acct :: MonadIO m => Handle -> String -> m FTPResponse -acct h pass = sendCommandS h (Acct pass) - -rename :: MonadIO m => Handle -> String -> String -> m FTPResponse -rename h from to = do - res <- sendCommand h (Rnfr from) - case frStatus res of - Continue -> sendCommandS h (Rnto to) - _ -> return res - -dele :: MonadIO m => Handle -> String -> m FTPResponse -dele h file = sendCommandS h (Dele file) - -cwd :: MonadIO m => Handle -> String -> m FTPResponse -cwd h dir = - sendCommandS h $ if dir == ".." - then Cdup - else Cwd dir - -size :: MonadIO m => Handle -> String -> m Int -size h file = do - resp <- sendCommandS h (Size file) - ensureCode resp 213 - return $ case frMessage resp of - SingleLine message -> read . C.unpack $ message - MultiLine _ -> 0 - -mkd :: MonadIO m => Handle -> String -> m String -mkd h dir = do - resp <- sendCommandS h (Mkd dir) - ensureCode resp 257 - parseResponse resp parse257 - -rmd :: MonadIO m => Handle -> String -> m FTPResponse -rmd h dir = sendCommandS h (Rmd dir) - -pwd :: MonadIO m => Handle -> m String -pwd h = do - resp <- sendCommandS h Pwd - ensureCode resp 257 - parseResponse resp parse257 - -quit :: MonadIO m => Handle -> m FTPResponse -quit h = sendCommandS h Quit - -mlst :: (MonadIO m, MonadMask m) => Handle -> String -> m MlsxResponse -mlst h path = do - resp <- sendCommandS h (Mlst path) - case frMessage resp of - SingleLine message -> return $ parseMlsxLine message - MultiLine messages -> if length messages >= 2 - then return $ parseMlsxLine $ messages !! 1 - else liftIO $ throwIO $ BogusResponseFormatException resp - --- TLS commands - -pbsz :: MonadIO m => Handle -> Int -> m FTPResponse -pbsz h = sendCommandS h . Pbsz - -prot :: MonadIO m => Handle -> ProtType -> m FTPResponse -prot h = sendCommandS h . Prot - -ccc :: MonadIO m => Handle -> m FTPResponse -ccc h = sendCommandS h Ccc - -auth :: MonadIO m => Handle -> m FTPResponse -auth h = sendCommandS h Auth - --- Data commands - -sendType :: MonadIO m => RTypeCode -> ByteString -> Handle -> m () -sendType TA dat h = mapM_ (sendCommandLine h) $ C.split '\n' dat -sendType TI dat h = liftIO $ send h dat - -withDataCommandSecurity - :: (MonadIO m, MonadMask m) - => Handle - -> PortActivity - -> RTypeCode - -> FTPCommand - -> (Handle -> m a) - -> m a -withDataCommandSecurity h = - case security h of - Clear -> withDataCommand h - TLS -> withTLSDataCommand h - -nlst :: (MonadIO m, MonadMask m) => Handle -> [String] -> m ByteString -nlst h args = withDataCommandSecurity h Passive TA (Nlst args) getAllLineResp - -retr :: (MonadIO m, MonadMask m) => Handle -> String -> m ByteString -retr h path = withDataCommandSecurity h Passive TI (Retr path) recvAll - -list :: (MonadIO m, MonadMask m) => Handle -> [String] -> m ByteString -list h args = withDataCommandSecurity h Passive TA (List args) getAllLineResp - -stor - :: (MonadIO m, MonadMask m) - => Handle - -> String - -> B.ByteString - -> RTypeCode - -> m () -stor h loc dat rtype = - withDataCommandSecurity h Passive rtype (Stor loc) $ sendType rtype dat - -data MlsxResponse = MlsxResponse { - mrFilename :: String, - mrFacts :: Map String String -} deriving (Show) - -splitApart :: Char -> ByteString -> (ByteString, ByteString) -splitApart on s = - let (x0, x1) = C.break (== on) s - in (x0, C.drop 1 x1) - -parseMlsxLine :: ByteString -> MlsxResponse -parseMlsxLine line = - let (factLine, filename) = splitApart ' ' line - bFacts = splitApart '=' <$> C.split ';' factLine - facts - = Map.fromList - $ filter (not . null . fst) - $ join (***) C.unpack <$> bFacts - in MlsxResponse (C.unpack filename) facts - -getMlsxResponse :: (MonadIO m, MonadCatch m) => Handle -> m [MlsxResponse] -getMlsxResponse h = getMlsxResponse' h [] - where - getMlsxResponse' h ret = ( do - line <- liftIO $ getLineResp h - getMlsxResponse' h $ - if C.null line - then ret - else parseMlsxLine line : ret - ) `M.catchIOError` (\_ -> return ret) - -mlsd :: (MonadIO m, MonadMask m) => Handle -> String -> m [MlsxResponse] +{- | +Module : Network.FTP.Client +Description : Transfer files over FTP and FTPS +Copyright : Megan Robinson 2018-2019, Flipstone Technology Partners 2024-2026 +License : Public Domain +Stability : experimental +Portability : POSIX +-} +module Network.FTP.Client + ( -- * Main Entrypoints + withFTP + , withFTPS + , withFTPSSettings + + -- * Control Commands + , login + , pasv + , rename + , dele + , cwd + , size + , acct + , mkd + , rmd + , pwd + , quit + + -- * Data Commands + , nlst + , retr + , list + , stor + , mlsd + , mlst + + -- * Types + , FTPCommand (..) + , FTPResponse (..) + , FTPMessage (..) + , ResponseStatus (..) + , MlsxResponse (..) + , RTypeCode (..) + , PortActivity (..) + , ProtType (..) + , Security (..) + , TLSContext (..) + , Handle (..) + + -- * TLS Commands + , pbsz + , prot + + -- * Exceptions + , FTPException (..) + + -- * System Handle Creation + , createSIOHandle + , createTLSConnection + , connectTLS + + -- * Handle Implementations + , sIOHandleImpl + , tlsHandleImpl + + -- * Lower Level Functions + , sendCommand + , sendCommandS + , recvAll + , sendAll + , sendAllS + , getLineResp + , getAllLineResp + , getLineRespMaybe + , maxReplyLineLength + , toNetworkAscii + , requireTLSContext + , getResponse + , getResponseS + , sendCommandLine + , createSendDataCommand + , createTLSSendDataCommand + , PendingCompletion + , newPendingCompletion + , drainPendingCompletion + , parseMlsxLine + ) where + +import Control.Arrow ((***)) +import qualified Control.Exception as Exception +import Control.Monad ((<=<)) +import qualified Control.Monad as Monad +import Control.Monad.Catch (MonadCatch, MonadMask) +import qualified Control.Monad.Catch as M +import qualified Control.Monad.IO.Class as MIO +import qualified Data.Attoparsec.ByteString.Char8 as AC +import qualified Data.Bits as Bits +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C +import Data.ByteString.Lazy.Internal (defaultChunkSize) +import Data.Default.Class (def) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.List (intercalate) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Network.Connection as Connection +import qualified Network.Socket as S +import qualified System.IO as SIO +import System.IO.Error (eofErrorType, isEOFError, mkIOError) + +debugging :: Bool +debugging = False + +debugPrint :: (Show a, MIO.MonadIO m) => a -> m () +debugPrint s = Monad.when debugging (MIO.liftIO $ print s) + +debugResponse :: (Show a, MIO.MonadIO m) => a -> m () +debugResponse s = debugPrint $ "Recieved: " <> show s + +{- | What a data connection needs in order to be protected the same way the +control connection is. The host is the one the control connection was opened +to, which is what the server's certificate is issued for -- deriving it from +the data socket instead names the local end and can never validate. +-} +data TLSContext = TLSContext + { tlsContextSettings :: Connection.TLSSettings + , tlsContextHost :: String + , tlsContextPort :: Int + } + +-- Only TLS settings are threaded through the connection helpers today. If the +-- rest of the hardening lands -- ignoring the address in a PASV reply, a +-- timeout on the active-mode accept, a bound on data-channel line length -- +-- those belong together with these as fields of one options record passed to +-- the with* functions, rather than as further positional parameters. That was +-- @qxjit's suggestion on https://github.com/flipstone/ftp-client/pull/1. + +data Security = Clear | TLS TLSContext + +-- | Can send and recieve a 'Data.ByteString.ByteString'. +data Handle = Handle + { send :: ByteString -> IO () + , sendLine :: ByteString -> IO () + , recv :: Int -> IO ByteString + , recvLine :: IO ByteString + , security :: Security + } + +data FTPMessage = SingleLine ByteString | MultiLine [ByteString] + deriving (Eq) + +instance Show FTPMessage where + show (SingleLine message) = C.unpack message + show (MultiLine messages) = intercalate "\n" $ C.unpack <$> messages + +-- | Response from an FTP command. ex "200 Welcome!" +data FTPResponse = FTPResponse + { frStatus :: ResponseStatus + -- ^ Interpretation of the first digit of an FTP response code + , frCode :: Int + -- ^ The three digit response code + , frMessage :: FTPMessage + -- ^ Text of the response + } + deriving (Eq) + +instance Show FTPResponse where + show fr = show (frCode fr) <> " " <> show (frMessage fr) + +-- | First digit of an FTP response +data ResponseStatus + = -- | 1 + Wait + | -- | 2 + Success + | -- | 3 + Continue + | -- | 4 + FailureRetry + | -- | 5 + Failure + deriving (Show, Eq) + +data FTPException + = FailureRetryException FTPResponse + | FailureException FTPResponse + | UnsuccessfulException FTPResponse + | BogusResponseFormatException FTPResponse + | BadProtocolResponseException ByteString + deriving (Show) + +instance Exception.Exception FTPException + +responseStatus :: ByteString -> ResponseStatus +responseStatus cbs = + case C.uncons cbs of + Just ('1', _) -> Wait + Just ('2', _) -> Success + Just ('3', _) -> Continue + Just ('4', _) -> FailureRetry + Just ('5', _) -> Failure + _ -> Exception.throw $ BadProtocolResponseException cbs + +data RTypeCode = TA | TI + +serialzeRTypeCode :: RTypeCode -> String +serialzeRTypeCode TA = "A" +serialzeRTypeCode TI = "I" + +data PortActivity = Active | Passive + +data ProtType = P | C + +-- | Commands according to the FTP specification +data FTPCommand + = User String + | Pass String + | Acct String + | RType RTypeCode + | Retr String + | Nlst [String] + | Port S.HostAddress S.PortNumber + | Stor String + | List [String] + | Rnfr String + | Rnto String + | Dele String + | Size String + | Mkd String + | Rmd String + | Pbsz Int + | Prot ProtType + | Mlsd String + | Mlst String + | Cwd String + | Cdup + | Ccc + | Auth + | Pwd + | Abor + | Pasv + | Quit + +instance Show FTPCommand where + show = serializeCommand + +formatPort :: S.HostAddress -> S.PortNumber -> String +formatPort ha pn = + let + (w1, w2, w3, w4) = S.hostAddressToTuple ha + hn = show <$> [w1, w2, w3, w4] + portParts = show <$> [pn `quot` 256, pn `mod` 256] + in + intercalate "," (hn <> portParts) + +serializeCommand :: FTPCommand -> String +serializeCommand (User user) = "USER " <> user +serializeCommand (Pass pass) = "PASS " <> pass +serializeCommand (Acct account) = "ACCT " <> account +serializeCommand (RType rt) = "TYPE " <> serialzeRTypeCode rt +serializeCommand (Retr file) = "RETR " <> file +serializeCommand (Nlst []) = "NLST" +serializeCommand (Nlst args) = "NLST " <> unwords args +serializeCommand (Port ha pn) = "PORT " <> formatPort ha pn +serializeCommand (Stor loc) = "STOR " <> loc +serializeCommand (List []) = "LIST" +serializeCommand (List args) = "LIST " <> unwords args +serializeCommand (Rnfr from) = "RNFR " <> from +serializeCommand (Rnto to) = "RNTO " <> to +serializeCommand (Dele file) = "DELE " <> file +serializeCommand (Size file) = "SIZE " <> file +serializeCommand (Mkd dir) = "MKD " <> dir +serializeCommand (Rmd dir) = "RMD " <> dir +serializeCommand (Pbsz buf) = "PBSZ " <> show buf +serializeCommand (Prot P) = "PROT P" +serializeCommand (Prot C) = "PROT C" +serializeCommand (Mlsd path) = "MLSD " <> path +serializeCommand (Mlst path) = "MLST " <> path +serializeCommand (Cwd dir) = "CWD " <> dir +serializeCommand Cdup = "CDUP" +serializeCommand Ccc = "CCC" +serializeCommand Auth = "AUTH TLS" +serializeCommand Pwd = "PWD" +serializeCommand Abor = "ABOR" +serializeCommand Pasv = "PASV" +serializeCommand Quit = "QUIT" + +{- | Cap on one reply line. RFC 959 replies are short; this exists so a server +that never sends a newline cannot make us buffer without limit. It applies to +both control connections: 'Connection.connectionGetLine' takes it directly, and +'hGetLineBounded' applies it to a clear handle. Exceeding it raises +'Connection.LineTooLong', which is not an 'IOError' and so is not swallowed by +the end-of-input handling elsewhere in this module. +-} +maxReplyLineLength :: Int +maxReplyLineLength = 65536 + +{- | 'C.hGetLine' with a bound, for handles that 'Network.Connection' is not +managing. Reads a byte at a time rather than in chunks because 'recv' shares +the handle: anything taken past the newline would be stolen from the data the +caller asks for next. The handle is buffered, so this is not a syscall per +byte, and reply lines are short. + +End of input is reported the way 'C.hGetLine' reports it, because +'getLineRespMaybe' relies on the distinction: throw when nothing has been read +yet, hand back the partial line when something has. +-} +hGetLineBounded :: Int -> SIO.Handle -> IO ByteString +hGetLineBounded limit h = + let + collect :: Int -> [ByteString] -> IO ByteString + collect remaining acc + | remaining <= 0 = Exception.throwIO Connection.LineTooLong + | otherwise = do + byte <- B.hGet h 1 + if B.null byte + then + if null acc + then + Exception.throwIO $ + mkIOError eofErrorType "hGetLineBounded" (Just h) Nothing + else return $ B.concat (reverse acc) + else + if byte == C.singleton '\n' + then return $ B.concat (reverse acc) + else collect (remaining - 1) (byte : acc) + in + collect limit [] + +stripCLRF :: ByteString -> ByteString +stripCLRF = C.takeWhile $ (&&) <$> (/= '\r') <*> (/= '\n') + +-- | Get a line from the server +getLineResp :: Handle -> IO ByteString +getLineResp h = stripCLRF <$> recvLine h + +{- | Get a line from the server, returning 'Nothing' once the stream is +exhausted. A blank line and end of input are different things: 'recvLine' +signals end of input by throwing, and an empty 'ByteString' is a legitimate +line of reply text. +-} +getLineRespMaybe :: Handle -> IO (Maybe ByteString) +getLineRespMaybe h = + (Just <$> getLineResp h) `M.catchIOError` \e -> + if isEOFError e + then return Nothing + else ioError e + +{- | Get a full response from the server +Used in 'sendCommand' +-} +getResponse :: MIO.MonadIO m => Handle -> m FTPResponse +getResponse h = do + line <- MIO.liftIO $ getLineResp h + let + (code, rest) = C.splitAt 3 line + -- A response must open with a three digit code. Checking that up front keeps + -- the 'C.uncons' below and the 'read' further down from being partial. + Monad.when (C.length code < 3 || not (C.all AC.isDigit code)) $ + MIO.liftIO $ + Exception.throwIO $ + BadProtocolResponseException line + message <- case C.uncons rest of + Just ('-', _) -> MultiLine <$> loopMultiLine h code [line] + _ -> return $ SingleLine line + let + codeDroppedMessage = case message of + SingleLine singleMessage -> SingleLine $ C.drop 4 singleMessage + MultiLine [] -> MultiLine [] + MultiLine (firstMessage : messages) -> + MultiLine $ C.drop 4 firstMessage : messages + let + response = + FTPResponse + (responseStatus code) + (read $ C.unpack code) + codeDroppedMessage + case frStatus response of + FailureRetry -> MIO.liftIO $ Exception.throwIO $ FailureRetryException response + Failure -> MIO.liftIO $ Exception.throwIO $ FailureException response + _ -> return response + +loopMultiLine :: + MIO.MonadIO m => + Handle -> + ByteString -> + [ByteString] -> + m [ByteString] +loopMultiLine h code priorLines = do + mNextLine <- MIO.liftIO $ getLineRespMaybe h + case mNextLine of + -- The server hung up before sending the terminating line. Stop rather + -- than looping forever, but treat the reply as bad rather than + -- returning it: what was collected is a fragment, and handing it back + -- would turn a truncated reply into a well formed one. A cut off "220-" + -- greeting would read as a successful 220 and let 'withFTP' carry on + -- against a control connection that is already gone. + -- + -- This is end of input, not a blank line. RFC 959 lets the intermediate + -- lines of a multiline reply hold arbitrary text, blank lines included, + -- so a blank line has to be kept and the loop has to continue past it. + Nothing -> + MIO.liftIO $ + Exception.throwIO $ + BadProtocolResponseException $ + C.intercalate "\n" priorLines + Just nextLine -> do + -- RFC 959 (https://datatracker.ietf.org/doc/html/rfc959#page-36) ends a + -- multiline reply with the code followed by a space, and continues it + -- with the code followed by a hyphen. The bare code is accepted too, + -- for servers that omit the trailing space on an empty final line. + let + newLines = priorLines <> [C.dropWhile (== ' ') nextLine] + isLastLine = + nextLine == code + || C.isPrefixOf (code <> " ") nextLine + if isLastLine + then return newLines + else loopMultiLine h code newLines + +ensureSuccess :: MIO.MonadIO m => FTPResponse -> m FTPResponse +ensureSuccess resp = + case frStatus resp of + Success -> return resp + _ -> MIO.liftIO $ Exception.throwIO $ UnsuccessfulException resp + +getResponseS :: MIO.MonadIO m => Handle -> m FTPResponse +getResponseS = ensureSuccess <=< getResponse + +sendCommandLine :: MIO.MonadIO m => Handle -> ByteString -> m () +sendCommandLine h = MIO.liftIO . send h . (<> "\r\n") + +{- | Send a command to the server and get a response back. +Some commands use a data 'Handle', and their data is not returned here. +-} +sendCommand :: MIO.MonadIO m => Handle -> FTPCommand -> m FTPResponse +sendCommand h fc = do + let + command = serializeCommand fc + debugPrint $ "Sending: " <> command + sendCommandLine h $ C.pack command + resp <- getResponse h + debugResponse resp + return resp + +sendCommandS :: MIO.MonadIO m => Handle -> FTPCommand -> m FTPResponse +sendCommandS h fc = sendCommand h fc >>= ensureSuccess + +{- | Equvalent to + +> mapM . sendCommand +-} +sendAll :: MIO.MonadIO m => Handle -> [FTPCommand] -> m [FTPResponse] +sendAll = mapM . sendCommand + +{- | Equvalent to + +> mapM . sendCommandS +-} +sendAllS :: MIO.MonadIO m => Handle -> [FTPCommand] -> m [FTPResponse] +sendAllS = mapM . sendCommandS + +-- Control connection + +createSocket :: + MIO.MonadIO m => + Maybe String -> + Int -> + S.AddrInfo -> + m (S.Socket, S.AddrInfo) +createSocket host portNum hints = do + addr <- MIO.liftIO $ do + a : _ <- S.getAddrInfo (Just hints) host (Just $ show portNum) + return a + debugPrint $ "Addr: " <> show addr + sock <- + MIO.liftIO $ + S.socket + (S.addrFamily addr) + (S.addrSocketType addr) + (S.addrProtocol addr) + return (sock, addr) + +withSocketPassive :: + (MIO.MonadIO m, MonadMask m) => + String -> + Int -> + (S.Socket -> m a) -> + m a +withSocketPassive host portNum f = do + let + hints = + S.defaultHints + { S.addrSocketType = S.Stream + } + -- bracketOnError, not bracket: on success this socket is handed to + -- socketToHandle, which takes ownership of the descriptor, so closing it here + -- as well would be wrong. Contrast withSocketActive above. + M.bracketOnError + (createSocket (Just host) portNum hints) + (MIO.liftIO . S.close . fst) + ( \(sock, addr) -> do + debugPrint ("Connecting" :: String) + MIO.liftIO $ S.connect sock (S.addrAddress addr) + debugPrint ("Connected" :: String) + f sock + ) + +withSocketActive :: (MIO.MonadIO m, MonadMask m) => (S.Socket -> m a) -> m a +withSocketActive f = do + let + hints = + S.defaultHints + { S.addrSocketType = S.Stream + , S.addrFlags = [S.AI_PASSIVE] + } + -- bracket, not bracketOnError: in active mode acceptData returns a *new* + -- socket and only that one is converted to a Handle, so ownership of this + -- listening socket is never transferred and it must be closed on the success + -- path too. The passive helper below is the opposite case and deliberately + -- differs. + M.bracket + (createSocket Nothing 0 hints) + (MIO.liftIO . S.close . fst) + ( \(sock, addr) -> do + debugPrint ("Binding" :: String) + MIO.liftIO $ S.bind sock (S.addrAddress addr) + MIO.liftIO $ S.listen sock 1 + debugPrint ("Listening" :: String) + f sock + ) + +createSIOHandle :: (MIO.MonadIO m, MonadMask m) => String -> Int -> m SIO.Handle +createSIOHandle host portNum = + withSocketPassive host portNum $ + MIO.liftIO . flip S.socketToHandle SIO.ReadWriteMode + +sIOHandleImpl :: SIO.Handle -> Handle +sIOHandleImpl h = + Handle + { send = C.hPut h + , -- RFC 959 TYPE A data uses CRLF, not a bare LF + sendLine = \s -> C.hPut h (s <> "\r\n") + , recv = C.hGetSome h + , recvLine = hGetLineBounded maxReplyLineLength h + , security = Clear + } + +withSIOHandle :: + (MIO.MonadIO m, MonadMask m) => + String -> + Int -> + (Handle -> m a) -> + m a +withSIOHandle host portNum f = + M.bracket + (MIO.liftIO $ createSIOHandle host portNum) + (MIO.liftIO . SIO.hClose) + (f . sIOHandleImpl) + +{- | Takes a host name and port. A handle for interacting with the server +will be returned in a callback. + +@ +withFTP "ftp.server.com" 21 $ \h welcome -> do + print welcome + login h "username" "password" + print =<< nlst h [] +@ +-} +withFTP :: + (MIO.MonadIO m, MonadMask m) => + String -> + Int -> + (Handle -> FTPResponse -> m a) -> + m a +withFTP host portNum f = withSIOHandle host portNum $ \h -> do + resp <- getResponse h + f h resp + +-- Data connection + +withDataSocketPasv :: + (MIO.MonadIO m, MonadMask m) => + Handle -> + (S.Socket -> m a) -> + m a +withDataSocketPasv h f = do + (host, portNum) <- pasv h + debugPrint $ "Host: " <> host + debugPrint $ "Port: " <> show portNum + withSocketPassive host portNum f + +withDataSocketActive :: + (MIO.MonadIO m, MonadMask m) => + Handle -> + (S.Socket -> m a) -> + m a +withDataSocketActive h f = withSocketActive $ \socket -> do + (sPort, sHost) <- MIO.liftIO $ do + (S.SockAddrInet p hostAddr) <- S.getSocketName socket + return (p, hostAddr) + _ <- port h sHost sPort + f socket + +-- | Open a socket that can be used for data transfers +withDataSocket :: + (MIO.MonadIO m, MonadMask m) => + PortActivity -> + Handle -> + (S.Socket -> m a) -> + m a +withDataSocket Active = withDataSocketActive +withDataSocket Passive = withDataSocketPasv + +acceptData :: MIO.MonadIO m => PortActivity -> S.Socket -> m S.Socket +acceptData Passive = return +acceptData Active = return . fst <=< MIO.liftIO . S.accept + +-- Response to data commands should be 150 but apparently +-- some servers will respond with 200 before 150 so just ignore it +ensureSucessfulData :: MIO.MonadIO m => Handle -> FTPResponse -> m () +ensureSucessfulData h resp = do + resp' <- case frStatus resp of + Success -> do + newResp <- getResponse h + debugResponse newResp + return newResp + _ -> return resp + MIO.liftIO $ + Monad.when (frStatus resp' /= Wait) $ + Exception.throwIO $ + UnsuccessfulException resp + +{- | Send setup commands to the server and +create a data 'System.IO.Handle' +-} +createSendDataCommand :: + (MIO.MonadIO m, MonadMask m) => + Handle -> + PortActivity -> + PendingCompletion -> + FTPCommand -> + m SIO.Handle +createSendDataCommand h pa pending cmd = withDataSocket pa h $ \socket -> do + resp <- sendCommand h cmd + ensureSucessfulData h resp + -- Past this point the server has accepted the transfer, so a completion + -- reply is owed to us however the rest of it goes. + markCompletionPending pending + acceptedSock <- acceptData pa socket + MIO.liftIO $ S.socketToHandle acceptedSock SIO.ReadWriteMode + +-- | Provides a data 'Handle' in a callback for a command +withDataCommand :: + (MIO.MonadIO m, MonadMask m) => + Handle -> + PortActivity -> + RTypeCode -> + FTPCommand -> + (Handle -> m a) -> + m a +withDataCommand ch pa code cmd f = do + _ <- sendCommandS ch $ RType code + pending <- newPendingCompletion + x <- + M.bracket + (createSendDataCommand ch pa pending cmd) + (MIO.liftIO . SIO.hClose) + (f . sIOHandleImpl) + `M.onException` drainPendingCompletion ch pending + resp <- getResponse ch + debugResponse resp + return x + +-- | Recieve data and interpret it linewise +getAllLineResp :: (MIO.MonadIO m, MonadCatch m) => Handle -> m ByteString +getAllLineResp h = + let + collect :: MIO.MonadIO n => [ByteString] -> n ByteString + collect ret = do + mLine <- MIO.liftIO $ getLineRespMaybe h + case mLine of + Nothing -> return $ C.intercalate (C.pack "\n") ret + Just line -> collect (ret <> [line]) + in + collect [] + +-- | Recieve all data and return it as a 'Data.ByteString.ByteString' +recvAll :: (MIO.MonadIO m, MonadCatch m) => Handle -> m ByteString +recvAll h = + let + collect :: (MIO.MonadIO n, MonadCatch n) => ByteString -> n ByteString + collect bs = + ( do + -- No handler here on purpose. recv returns "" at end of data, so + -- catching IOErrors would only turn a reset or timed-out connection + -- into a short read that looks like a complete one. + chunk <- MIO.liftIO $ recv h defaultChunkSize + if C.null chunk + then return bs + else collect $ bs <> chunk + ) + in + collect "" + +-- TLS connection + +{- | Wrap an existing handle in TLS. The settings are supplied by the caller; +'def' validates the server's certificate chain and host name. Passing settings +with 'Connection.settingDisableCertificateValidation' set gives an encrypted +but unauthenticated connection, which any on-path attacker can read and rewrite. +-} +connectTLS :: + MIO.MonadIO m => + Connection.TLSSettings -> + SIO.Handle -> + String -> + Int -> + m Connection.Connection +connectTLS settings h host portNum = do + context <- MIO.liftIO Connection.initConnectionContext + let + connectionParams = + Connection.ConnectionParams + { Connection.connectionHostname = host + , Connection.connectionPort = toEnum . fromEnum $ portNum + , Connection.connectionUseSecure = Just settings + , Connection.connectionUseSocks = Nothing + } + MIO.liftIO $ Connection.connectFromHandle context h connectionParams + +createTLSConnection :: + (MIO.MonadIO m, MonadMask m) => + Connection.TLSSettings -> + String -> + Int -> + m (FTPResponse, Connection.Connection) +createTLSConnection settings host portNum = + -- Without this the socket leaks whenever the greeting is a refusal, AUTH TLS + -- is rejected, or the handshake fails. This is the acquire action of + -- withTLSHandle's bracket, so its release would never run. + M.bracketOnError + (createSIOHandle host portNum) + (MIO.liftIO . SIO.hClose) + ( \h -> do + let + insecureH = sIOHandleImpl h + resp <- getResponse insecureH + _ <- sendCommandS insecureH Auth + conn <- connectTLS settings h host portNum + return (resp, conn) + ) + +tlsHandleImpl :: TLSContext -> Connection.Connection -> Handle +tlsHandleImpl tlsContext c = + Handle + { send = Connection.connectionPut c + , -- RFC 959 TYPE A data uses CRLF, not a bare LF + sendLine = Connection.connectionPut c . (<> "\r\n") + , recv = Connection.connectionGet c + , recvLine = Connection.connectionGetLine maxReplyLineLength c + , security = TLS tlsContext + } + +withTLSHandle :: + (MonadMask m, MIO.MonadIO m) => + Connection.TLSSettings -> + String -> + Int -> + (Handle -> FTPResponse -> m a) -> + m a +withTLSHandle settings host portNum f = + let + tlsContext = + TLSContext + { tlsContextSettings = settings + , tlsContextHost = host + , tlsContextPort = portNum + } + in + M.bracket + (createTLSConnection settings host portNum) + (MIO.liftIO . Connection.connectionClose . snd) + (\(resp, conn) -> f (tlsHandleImpl tlsContext conn) resp) + +{- | Takes a host name and port. A handle for interacting with the server +will be returned in a callback. The connection is protected with TLS and the +server's certificate chain and host name are verified, so a failure to validate +aborts the connection. + +@ +withFTPS "ftps.server.com" 21 $ \h welcome -> do + print welcome + login h "username" "password" + print =<< nlst h [] +@ + +Use 'withFTPSSettings' if you need to talk to a server whose certificate cannot +be validated. +-} +withFTPS :: + (MonadMask m, MIO.MonadIO m) => + String -> + Int -> + (Handle -> FTPResponse -> m a) -> + m a +withFTPS = withTLSHandle def + +{- | As 'withFTPS', but with caller supplied TLS settings. + +Setting 'Connection.settingDisableCertificateValidation' accepts any +certificate, including one an attacker generated. The connection is then +encrypted but not authenticated: anyone on the network path can read the +credentials sent by 'login' and alter transferred data. Only do this when you +have another way to establish that the peer is who it claims to be. + +@ +let insecure = 'def' { 'Connection.settingDisableCertificateValidation' = True } +withFTPSSettings insecure "ftps.server.com" 21 $ \h welcome -> do + print welcome +@ +-} +withFTPSSettings :: + (MonadMask m, MIO.MonadIO m) => + Connection.TLSSettings -> + String -> + Int -> + (Handle -> FTPResponse -> m a) -> + m a +withFTPSSettings = withTLSHandle + +-- TLS data connection + +{- | The TLS details of a control connection, for reproducing them on a data +connection. +-} +requireTLSContext :: MIO.MonadIO m => Handle -> m TLSContext +requireTLSContext h = + case security h of + TLS ctx -> return ctx + Clear -> + MIO.liftIO . Exception.throwIO . BadProtocolResponseException $ + C.pack "cannot open a TLS data connection over a clear control connection" + +{- | Read the reply that terminates a data transfer, discarding any failure. + +Used on the paths where the transfer did not complete normally. The reply still +has to be taken off the control connection: left there it becomes the answer to +whichever command is sent next, and every reply after that belongs to the +previous command for the rest of the session. Failures are swallowed so this +cannot mask the exception that brought us here. +-} +drainDataResponse :: (MIO.MonadIO m, MonadCatch m) => Handle -> m () +drainDataResponse ch = + Monad.void (getResponse ch) `M.catchAll` (\_ -> return ()) + +{- | Whether the server has accepted the preliminary reply to a transfer +command, and so whether a completion reply is on its way. + +A transfer that is rejected outright -- @PBSZ@, @PROT@, @PASV@ or the transfer +command itself -- fails with its error reply already consumed by +'ensureSucessfulData', and nothing further is coming. Draining then waits for a +reply the server will never send, which blocks until it gives up on the +connection. Draining is only correct once this says a reply is pending. +-} +newtype PendingCompletion = PendingCompletion (IORef Bool) + +newPendingCompletion :: MIO.MonadIO m => m PendingCompletion +newPendingCompletion = + MIO.liftIO $ PendingCompletion <$> newIORef False + +markCompletionPending :: MIO.MonadIO m => PendingCompletion -> m () +markCompletionPending (PendingCompletion ref) = + MIO.liftIO $ writeIORef ref True + +{- | 'drainDataResponse', but only when a completion reply is actually pending. + +This deliberately stays outside the bracket that owns the data connection. The +server sends the completion reply once that connection has closed, so draining +before the release action has run would block on a reply that is waiting on us. +-} +drainPendingCompletion :: + (MIO.MonadIO m, MonadCatch m) => + Handle -> + PendingCompletion -> + m () +drainPendingCompletion ch (PendingCompletion ref) = do + pending <- MIO.liftIO $ readIORef ref + Monad.when pending $ drainDataResponse ch + +{- | Send setup commands to the server and +create a data TLS connection +-} +createTLSSendDataCommand :: + (MIO.MonadIO m, MonadMask m) => + Handle -> + PortActivity -> + PendingCompletion -> + FTPCommand -> + m Connection.Connection +createTLSSendDataCommand ch pa pending cmd = do + tlsContext <- requireTLSContext ch + _ <- sendAllS ch [Pbsz 0, Prot P] + withDataSocket pa ch $ \socket -> do + resp <- sendCommand ch cmd + ensureSucessfulData ch resp + -- Past this point the server has accepted the transfer, so a completion + -- reply is owed to us however the rest of it goes -- a rejected + -- certificate in the handshake below included. + markCompletionPending pending + acceptedSock <- acceptData pa socket + -- socketToHandle invalidates the socket, so the enclosing bracketOnError's + -- close becomes a no-op from here on; protect the handle separately or a + -- failed handshake leaks the descriptor. + M.bracketOnError + (MIO.liftIO $ S.socketToHandle acceptedSock SIO.ReadWriteMode) + (MIO.liftIO . SIO.hClose) + ( \h -> + -- Authenticate against the host the control connection was opened to. + -- getSocketName here would name the local end of the data socket, + -- which no server certificate can ever match. + MIO.liftIO $ + connectTLS + (tlsContextSettings tlsContext) + h + (tlsContextHost tlsContext) + (tlsContextPort tlsContext) + ) + +withTLSDataCommand :: + (MIO.MonadIO m, MonadMask m) => + Handle -> + PortActivity -> + RTypeCode -> + FTPCommand -> + (Handle -> m a) -> + m a +withTLSDataCommand ch pa code cmd f = do + tlsContext <- requireTLSContext ch + _ <- sendCommandS ch $ RType code + pending <- newPendingCompletion + x <- + M.bracket + (createTLSSendDataCommand ch pa pending cmd) + (MIO.liftIO . Connection.connectionClose) + (f . tlsHandleImpl tlsContext) + `M.onException` drainPendingCompletion ch pending + resp <- getResponse ch + debugPrint $ "Recieved: " <> show resp + return x + +parseResponse :: MIO.MonadIO m => FTPResponse -> AC.Parser a -> m a +parseResponse resp p = + let + parsableMessage = case frMessage resp of + SingleLine message -> message + MultiLine messages -> C.intercalate "\n" messages + in + case AC.parseOnly p parsableMessage of + Right x -> return x + Left _ -> + MIO.liftIO $ + Exception.throwIO $ + BadProtocolResponseException parsableMessage + +ensureCode :: MIO.MonadIO m => FTPResponse -> Int -> m () +ensureCode resp code = + MIO.liftIO $ + Monad.when (frCode resp /= code) $ + MIO.liftIO $ + Exception.throwIO $ + UnsuccessfulException resp + +parse227 :: AC.Parser (String, Int) +parse227 = do + _ <- AC.skipWhile (/= '(') *> AC.char '(' + [h1, h2, h3, h4, p1, p2] <- AC.many1 AC.digit `AC.sepBy` AC.char ',' + let + host = intercalate "." [h1, h2, h3, h4] + highBits = read p1 + lowBits = read p2 + portNum = (highBits `Bits.shift` 8) + lowBits + return (host, portNum) + +parse257 :: AC.Parser String +parse257 = do + _ <- AC.char '"' + C.unpack <$> AC.takeTill (== '"') + +-- Control commands + +login :: MIO.MonadIO m => Handle -> String -> String -> m FTPResponse +login h user pass = do + resp <- last <$> sendAll h [User user, Pass pass] + ensureSuccess resp + +pasv :: MIO.MonadIO m => Handle -> m (String, Int) +pasv h = do + resp <- sendCommandS h Pasv + ensureCode resp 227 + parseResponse resp parse227 + +port :: MIO.MonadIO m => Handle -> S.HostAddress -> S.PortNumber -> m FTPResponse +port h ha pn = sendCommandS h (Port ha pn) + +acct :: MIO.MonadIO m => Handle -> String -> m FTPResponse +acct h pass = sendCommandS h (Acct pass) + +rename :: MIO.MonadIO m => Handle -> String -> String -> m FTPResponse +rename h from to = do + res <- sendCommand h (Rnfr from) + case frStatus res of + Continue -> sendCommandS h (Rnto to) + _ -> return res + +dele :: MIO.MonadIO m => Handle -> String -> m FTPResponse +dele h file = sendCommandS h (Dele file) + +cwd :: MIO.MonadIO m => Handle -> String -> m FTPResponse +cwd h dir = + sendCommandS h $ + if dir == ".." + then Cdup + else Cwd dir + +size :: MIO.MonadIO m => Handle -> String -> m Int +size h file = do + resp <- sendCommandS h (Size file) + ensureCode resp 213 + return $ case frMessage resp of + SingleLine message -> read . C.unpack $ message + MultiLine _ -> 0 + +mkd :: MIO.MonadIO m => Handle -> String -> m String +mkd h dir = do + resp <- sendCommandS h (Mkd dir) + ensureCode resp 257 + parseResponse resp parse257 + +rmd :: MIO.MonadIO m => Handle -> String -> m FTPResponse +rmd h dir = sendCommandS h (Rmd dir) + +pwd :: MIO.MonadIO m => Handle -> m String +pwd h = do + resp <- sendCommandS h Pwd + ensureCode resp 257 + parseResponse resp parse257 + +quit :: MIO.MonadIO m => Handle -> m FTPResponse +quit h = sendCommandS h Quit + +mlst :: (MIO.MonadIO m, MonadMask m) => Handle -> String -> m MlsxResponse +mlst h path = do + resp <- sendCommandS h (Mlst path) + case frMessage resp of + SingleLine message -> return $ parseMlsxLine message + MultiLine messages -> + if length messages >= 2 + then return $ parseMlsxLine $ messages !! 1 + else MIO.liftIO $ Exception.throwIO $ BogusResponseFormatException resp + +-- TLS commands + +pbsz :: MIO.MonadIO m => Handle -> Int -> m FTPResponse +pbsz h = sendCommandS h . Pbsz + +prot :: MIO.MonadIO m => Handle -> ProtType -> m FTPResponse +prot h = sendCommandS h . Prot + +-- CCC and AUTH deliberately have no wrappers. CCC tells the server to drop to +-- cleartext, but there is no way to downgrade our side of a +-- crypton-connection, so the control connection would desynchronise and +-- 'security' could not be corrected to match. AUTH on its own tells the server +-- to expect a handshake that never happens; 'createTLSConnection' is the only +-- sequence that issues it correctly. Both remain reachable as 'FTPCommand' +-- constructors for anyone who needs to drive them by hand. + +-- Data commands + +{- | Rewrite line endings for a TYPE A transfer. RFC 959 specifies NVT-ASCII, +whose terminator is CRLF. Input already using CRLF is left alone rather than +having its CR doubled, and input with no final terminator does not gain one. +-} +toNetworkAscii :: ByteString -> ByteString +toNetworkAscii = + let + dropTrailingCR piece = + if not (C.null piece) && C.last piece == '\r' + then C.init piece + else piece + in + C.intercalate (C.pack "\r\n") . fmap dropTrailingCR . C.split '\n' + +sendType :: MIO.MonadIO m => RTypeCode -> ByteString -> Handle -> m () +sendType TA dat h = MIO.liftIO . send h $ toNetworkAscii dat +sendType TI dat h = MIO.liftIO $ send h dat + +withDataCommandSecurity :: + (MIO.MonadIO m, MonadMask m) => + Handle -> + PortActivity -> + RTypeCode -> + FTPCommand -> + (Handle -> m a) -> + m a +withDataCommandSecurity h = + case security h of + Clear -> withDataCommand h + TLS _ -> withTLSDataCommand h + +nlst :: (MIO.MonadIO m, MonadMask m) => Handle -> [String] -> m ByteString +nlst h args = withDataCommandSecurity h Passive TA (Nlst args) getAllLineResp + +retr :: (MIO.MonadIO m, MonadMask m) => Handle -> String -> m ByteString +retr h path = withDataCommandSecurity h Passive TI (Retr path) recvAll + +list :: (MIO.MonadIO m, MonadMask m) => Handle -> [String] -> m ByteString +list h args = withDataCommandSecurity h Passive TA (List args) getAllLineResp + +stor :: + (MIO.MonadIO m, MonadMask m) => + Handle -> + String -> + B.ByteString -> + RTypeCode -> + m () +stor h loc dat rtype = + withDataCommandSecurity h Passive rtype (Stor loc) $ sendType rtype dat + +data MlsxResponse = MlsxResponse + { mrFilename :: String + , mrFacts :: Map String String + } + deriving (Show) + +splitApart :: Char -> ByteString -> (ByteString, ByteString) +splitApart on s = + let + (x0, x1) = C.break (== on) s + in + (x0, C.drop 1 x1) + +parseMlsxLine :: ByteString -> MlsxResponse +parseMlsxLine line = + let + (factLine, filename) = splitApart ' ' line + bFacts = splitApart '=' <$> C.split ';' factLine + facts = + Map.fromList $ + filter (not . null . fst) $ + Monad.join (***) C.unpack <$> bFacts + in + MlsxResponse (C.unpack filename) facts + +getMlsxResponse :: (MIO.MonadIO m, MonadCatch m) => Handle -> m [MlsxResponse] +getMlsxResponse h = + let + collect :: MIO.MonadIO n => [MlsxResponse] -> n [MlsxResponse] + collect ret = do + mLine <- MIO.liftIO $ getLineRespMaybe h + case mLine of + Nothing -> return ret + Just line -> + collect $ + if C.null line + then ret + else parseMlsxLine line : ret + in + collect [] + +mlsd :: (MIO.MonadIO m, MonadMask m) => Handle -> String -> m [MlsxResponse] mlsd h path = withDataCommandSecurity h Passive TA (Mlsd path) getMlsxResponse diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -1,74 +1,294 @@ +module Main (main) where + +import Control.Concurrent.MVar +import qualified Control.Exception as Exception import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C -import Test.Hspec +import qualified Network.Connection as Connection import Network.FTP.Client hiding (Success) import qualified Network.FTP.Client as F -import Control.Monad.IO.Class -import Control.Concurrent.MVar +import qualified System.Directory as Directory +import qualified System.IO as SIO +import System.IO.Error (eofErrorType, fullErrorType, isFullError, mkIOError) +import Test.Hspec data TestHandleMVars = TestHandleMVars - { thmSend :: MVar [ByteString] - , thmSendLine :: MVar [ByteString] - , thmRecv :: MVar [Int] - } + { thmSend :: MVar [ByteString] + , _thmSendLine :: MVar [ByteString] + , _thmRecv :: MVar [Int] + } data TestHandle = TestHandle TestHandleMVars Handle -testHandle - :: [ByteString] - -> [ByteString] - -> Security - -> IO TestHandle +testHandle :: + [ByteString] -> + [ByteString] -> + Security -> + IO TestHandle testHandle recvResps recvLineResps sec = do - sendMVar <- newMVar [] - sendLineMVar <- newMVar [] - recvMVar <- newMVar [] - recvCount <- newMVar 0 - recvLineCount <- newMVar 0 - let testHandleMVars = TestHandleMVars - sendMVar sendLineMVar recvMVar - handle = Handle - { send = \s -> - modifyMVar_ sendMVar - (\ss -> return $ ss <> [s]) - , sendLine = \s -> - modifyMVar_ sendLineMVar - (\ss -> return $ ss <> [s]) - , recv = \i -> do - modifyMVar_ recvMVar - (\is -> return $ is <> [i]) - (recvResps !!) <$> modifyMVar recvCount - (\i -> return (i + 1, i)) - , recvLine = - (recvLineResps !!) <$> modifyMVar recvLineCount - (\i -> return (i + 1, i)) - , security = sec - } - return $ TestHandle testHandleMVars handle + sendMVar <- newMVar [] + sendLineMVar <- newMVar [] + recvMVar <- newMVar [] + recvCount <- newMVar 0 + recvLineCount <- newMVar 0 + let + testHandleMVars = + TestHandleMVars + sendMVar + sendLineMVar + recvMVar + handle = + Handle + { send = \s -> + modifyMVar_ + sendMVar + (\ss -> return $ ss <> [s]) + , sendLine = \s -> + modifyMVar_ + sendLineMVar + (\ss -> return $ ss <> [s]) + , recv = \i -> do + modifyMVar_ + recvMVar + (\is -> return $ is <> [i]) + nextScripted "recv" recvResps recvCount + , recvLine = nextScripted "recvLine" recvLineResps recvLineCount + , security = sec + } + return $ TestHandle testHandleMVars handle +{- | Hand back the next scripted response, or signal end of input the way a +real handle does once the peer has hung up. +-} +nextScripted :: String -> [ByteString] -> MVar Int -> IO ByteString +nextScripted what scripted countMVar = do + i <- modifyMVar countMVar (\count -> return (count + 1, count)) + case drop i scripted of + (x : _) -> return x + [] -> ioError $ mkIOError eofErrorType what Nothing Nothing + +{- | A handle whose reads fail the way a reset connection does, rather than the +way end of input does. The two must not be conflated: end of input is a +complete transfer, a reset is a truncated one. +-} +failingHandle :: Security -> IO Handle +failingHandle sec = do + (TestHandle _ h) <- testHandle [] [] sec + return + h + { recv = \_ -> ioError brokenConnection + , recvLine = ioError brokenConnection + } + +brokenConnection :: IOError +brokenConnection = mkIOError fullErrorType "connection reset" Nothing Nothing + main :: IO () main = hspec $ do - describe "Network.FTP.Client.sendCommand" $ do - it "sends USER for User" $ do - let expected = FTPResponse - F.Success 200 - (SingleLine $ C.pack "Ok") - (TestHandle mvars h) <- testHandle [] [C.pack "200 Ok"] Clear - sendCommand h (User "megan") `shouldReturn` expected - takeMVar (thmSend mvars) `shouldReturn` [C.pack "USER megan\r\n"] - it "sends USER for User and receives a multiline response" $ do - let expected = FTPResponse - F.Success 200 - (MultiLine [C.pack "line1", C.pack "line2", C.pack "200 line3"]) - (TestHandle mvars h) <- testHandle [] - [ C.pack "200-line1\r\n" - , C.pack "line2\r\n" - , C.pack "200 line3\r\n" - ] Clear - sendCommand h (User "megan") `shouldReturn` expected - takeMVar (thmSend mvars) `shouldReturn` [C.pack "USER megan\r\n"] - describe "Network.FTP.Client.recvAll" $ - it "doesn't hang on empty response" $ do - let expected = C.pack "" - (TestHandle mvars h) <- testHandle [C.pack ""] [] Clear - recvAll h `shouldReturn` expected + describe "Network.FTP.Client.sendCommand" $ do + it "sends USER for User" $ do + let + expected = + FTPResponse + F.Success + 200 + (SingleLine $ C.pack "Ok") + (TestHandle mvars h) <- testHandle [] [C.pack "200 Ok"] Clear + sendCommand h (User "megan") `shouldReturn` expected + takeMVar (thmSend mvars) `shouldReturn` [C.pack "USER megan\r\n"] + it "sends USER for User and receives a multiline response" $ do + let + expected = + FTPResponse + F.Success + 200 + (MultiLine [C.pack "line1", C.pack "line2", C.pack "200 line3"]) + (TestHandle mvars h) <- + testHandle + [] + [ C.pack "200-line1\r\n" + , C.pack "line2\r\n" + , C.pack "200 line3\r\n" + ] + Clear + sendCommand h (User "megan") `shouldReturn` expected + takeMVar (thmSend mvars) `shouldReturn` [C.pack "USER megan\r\n"] + describe "Network.FTP.Client.getResponse" $ do + it "rejects an empty response line" $ do + (TestHandle _ h) <- testHandle [] [C.pack ""] Clear + getResponse h `shouldThrow` isBadProtocolResponse + it "rejects a response line with a non numeric code" $ do + (TestHandle _ h) <- testHandle [] [C.pack "abc def"] Clear + getResponse h `shouldThrow` isBadProtocolResponse + it "rejects a response line with a truncated code" $ do + (TestHandle _ h) <- testHandle [] [C.pack "20 Ok"] Clear + getResponse h `shouldThrow` isBadProtocolResponse + it "accepts a bare code with no message" $ do + let + expected = + FTPResponse + F.Success + 200 + (SingleLine $ C.pack "") + (TestHandle _ h) <- testHandle [] [C.pack "200"] Clear + getResponse h `shouldReturn` expected + it "keeps a blank line inside a multiline response" $ do + -- RFC 959 lets the intermediate lines carry arbitrary text, so a + -- blank line is reply content and must not end the response. Ending + -- early would leave the real terminator unread and every later + -- command would pick up the wrong reply. + let + expected = + FTPResponse + F.Success + 220 + ( MultiLine + [ C.pack "First Line" + , C.pack "" + , C.pack "220 Third Line" + ] + ) + (TestHandle _ h) <- + testHandle + [] + [ C.pack "220-First Line\r\n" + , C.pack "\r\n" + , C.pack "220 Third Line\r\n" + ] + Clear + getResponse h `shouldReturn` expected + it "keeps reading continuation lines that repeat the code" $ do + let + expected = + FTPResponse + F.Success + 220 + ( MultiLine + [ C.pack "First Line" + , C.pack "220-Second Line" + , C.pack "220 Third Line" + ] + ) + (TestHandle _ h) <- + testHandle + [] + [ C.pack "220-First Line\r\n" + , C.pack "220-Second Line\r\n" + , C.pack "220 Third Line\r\n" + ] + Clear + getResponse h `shouldReturn` expected + it "ends a multiline response on a bare code" $ do + let + expected = + FTPResponse + F.Success + 220 + (MultiLine [C.pack "First Line", C.pack "220"]) + (TestHandle _ h) <- + testHandle + [] + [ C.pack "220-First Line\r\n" + , C.pack "220\r\n" + ] + Clear + getResponse h `shouldReturn` expected + it "does not end a multiline response on a different code" $ do + let + expected = + FTPResponse + F.Success + 220 + ( MultiLine + [ C.pack "First Line" + , C.pack "331 Not the terminator" + , C.pack "220 Done" + ] + ) + (TestHandle _ h) <- + testHandle + [] + [ C.pack "220-First Line\r\n" + , C.pack "331 Not the terminator\r\n" + , C.pack "220 Done\r\n" + ] + Clear + getResponse h `shouldReturn` expected + it "rejects a multiline response the server never finished" $ do + -- Terminating rather than hanging is only half of it. Handing back + -- the fragment would report a successful 220 for a greeting that + -- was cut off, against a control connection that is already gone. + (TestHandle _ h) <- + testHandle + [] + [ C.pack "220-First Line\r\n" + ] + Clear + getResponse h `shouldThrow` isBadProtocolResponse + describe "Network.FTP.Client.recvAll" $ do + it "doesn't hang on empty response" $ do + let + expected = C.pack "" + (TestHandle _ h) <- testHandle [C.pack ""] [] Clear + recvAll h `shouldReturn` expected + it "reports a broken connection instead of a short read" $ do + -- A failure part way through a transfer used to be turned into a clean + -- end of data, so a truncated download could not be told apart from a + -- complete one. + h <- failingHandle Clear + recvAll h `shouldThrow` isFullError + describe "Network.FTP.Client.getAllLineResp" $ + it "reports a broken connection instead of a truncated listing" $ do + h <- failingHandle Clear + getAllLineResp h `shouldThrow` isFullError + describe "Network.FTP.Client.sIOHandleImpl" $ do + it "reads reply lines from a clear handle" $ + withBytesHandle (C.pack "220 Welcome\r\n331 Password\r\n") $ \h -> do + getLineResp h `shouldReturn` C.pack "220 Welcome" + getLineResp h `shouldReturn` C.pack "331 Password" + it "hands back a final line the server never terminated" $ + -- Matches hGetLine, which this replaces: bytes did arrive, so they are + -- the line, and end of input is reported on the read after it. + withBytesHandle (C.pack "220 Welcome") $ \h -> do + getLineResp h `shouldReturn` C.pack "220 Welcome" + getLineRespMaybe h `shouldReturn` Nothing + it "signals end of input once the stream is exhausted" $ + withBytesHandle (C.pack "220 Welcome\r\n") $ \h -> do + _ <- getLineResp h + getLineRespMaybe h `shouldReturn` Nothing + it "refuses a reply line that exceeds the cap" $ + -- A server that never sends a newline must not be able to make us + -- buffer without limit before we have even authenticated. + withBytesHandle (C.replicate (maxReplyLineLength + 1) 'x') $ \h -> + getLineResp h `shouldThrow` isLineTooLong + describe "Network.FTP.Client.toNetworkAscii" $ do + it "terminates LF input with CRLF" $ + toNetworkAscii (C.pack "a\nb\n") `shouldBe` C.pack "a\r\nb\r\n" + it "leaves CRLF input unchanged rather than doubling the CR" $ + toNetworkAscii (C.pack "a\r\nb\r\n") `shouldBe` C.pack "a\r\nb\r\n" + it "does not append a terminator the input did not have" $ + toNetworkAscii (C.pack "a\nb") `shouldBe` C.pack "a\r\nb" + +{- | A real 'SIO.Handle' over fixed bytes. 'sIOHandleImpl' needs one, so the +scripted 'Handle' above cannot reach it. +-} +withBytesHandle :: ByteString -> (Handle -> IO a) -> IO a +withBytesHandle bytes use = do + tmp <- Directory.getTemporaryDirectory + Exception.bracket + (SIO.openBinaryTempFile tmp "ftp-client-test") + (\(path, h) -> SIO.hClose h >> Directory.removeFile path) + ( \(path, h) -> do + C.hPut h bytes + SIO.hClose h + SIO.withBinaryFile path SIO.ReadMode (use . sIOHandleImpl) + ) + +isLineTooLong :: Connection.LineTooLong -> Bool +isLineTooLong _ = True + +isBadProtocolResponse :: FTPException -> Bool +isBadProtocolResponse e = + case e of + BadProtocolResponseException _ -> True + _ -> False