From e1d84dd86fc2e12ad4694597a7d809015f157663 Mon Sep 17 00:00:00 2001 From: Paul Burns Date: Wed, 19 Aug 2026 09:51:59 -0400 Subject: [PATCH] Validate FTPS certificates, stop losing data on failure, plug leaks Fixes the security, silent-corruption and resource findings from the audit. Breaking, so both packages go to 0.6.0.0. withFTPS did not verify the server's certificate. Validation was disabled in connectTLS with no way for a caller to enable it, so the connection was encrypted but not authenticated. It now validates by default, with withFTPSSettings for callers who need to supply their own TLSSettings. Reported by @ysangkok in flipstone/ftp-client#1, which proposed the same fix and was approved but closed unmerged. That PR changed only the control connection. On its own it would have left every FTPS data transfer unable to validate, because the data channel took its TLS host name from getSocketName -- the local end of the data socket, which no server certificate can match. Security now carries a TLSContext so a data connection can reproduce the control connection's protection against the host it was actually opened to. This completes that PR, and adds the caller-supplied settings variant @jbrechtel asked for on it. Reply lines are bounded. connectionGetLine was called with maxBound, so a server that never sent a newline could exhaust memory before authentication. IO failures are no longer reported as successful short reads. recvAll, getAllLineResp, getMlsxResponse and the conduit sources mapped any IOError to a clean end of data, so a reset or timed-out connection produced a truncated result indistinguishable from a whole one. End of input and failure are now distinct, and only end of input terminates a read. The same conflation made a blank line truncate a conduit listing while the caller still saw 226. A 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 for the rest of the session -- reachable from ordinary conduit code such as retr .| takeC 1. TYPE A transfers send CRLF as RFC 959 requires. sendType TA doubled a CR that was already present and appended a record the input did not have, and the conduit sink terminated per awaited chunk rather than per line, so uploading from sourceFile injected a terminator at every chunk boundary. Three descriptor leaks: createTLSConnection had no bracketOnError, so a refused greeting or rejected AUTH TLS leaked the socket; the data handshake ran after socketToHandle had invalidated the socket its release closed; and the active-mode listening socket was never closed on success, since bracketOnError is only right for the passive case where socketToHandle takes ownership. Both socket helpers now say which they are and why. ccc and auth are gone. CCC cannot work -- there is no way to downgrade our side, so the control connection would desynchronise and security could not be corrected -- and auth alone tells the server to expect a handshake that never comes. Both remain reachable as FTPCommand constructors. --- ftp-client-conduit/CHANGELOG.md | 24 ++ ftp-client-conduit/ftp-client-conduit.cabal | 5 +- ftp-client-conduit/package.yaml | 5 +- .../src/Network/FTP/Client/Conduit.hs | 84 +++--- ftp-client/CHANGELOG.md | 57 ++++ ftp-client/README.md | 15 + ftp-client/ftp-client.cabal | 2 +- ftp-client/package.yaml | 2 +- ftp-client/src/Network/FTP/Client.hs | 271 ++++++++++++++---- ftp-client/test/test.hs | 37 ++- 10 files changed, 394 insertions(+), 108 deletions(-) diff --git a/ftp-client-conduit/CHANGELOG.md b/ftp-client-conduit/CHANGELOG.md index 2ee7b8e..36d94ed 100644 --- a/ftp-client-conduit/CHANGELOG.md +++ b/ftp-client-conduit/CHANGELOG.md @@ -1,5 +1,29 @@ # Changelog for ftp-client-conduit +## 0.6.0.0 + +Requires `ftp-client` 0.6, whose `withFTPS` now validates certificates. See its +changelog for the security implications of that change. + +* IO failures during a transfer are no longer reported as a completed one. + `retr` and the listing sources turned any `IOError` into a clean end of + stream, so a reset connection wrote a truncated file and reported success. + +* A blank line no longer truncates a listing. `nlst`, `list` and `mlsd` stopped + at the first empty line and the caller still saw the normal completion reply, + so a short listing looked complete. This also brings the conduit `mlsd` into + agreement with `Network.FTP.Client.mlsd`, which skipped blank lines. + +* The server's completion reply is now consumed even when the downstream + consumer terminates early. With `takeC`, `headC` or any short circuit it was + skipped, and became the answer to the next command on the control connection. + +* `stor` in `TYPE A` mode now frames by line and sends CRLF. It appended a + terminator to every awaited chunk, so uploading from `sourceFile` injected one + at every chunk boundary, and it used a bare LF where RFC 959 requires CRLF. + +* Dropped the `exceptions` dependency, which is no longer used. + ## 0.5.0.8 * Enable the `henforcer` plugin and `fourmolu` under the `ci` flag. Imports are diff --git a/ftp-client-conduit/ftp-client-conduit.cabal b/ftp-client-conduit/ftp-client-conduit.cabal index cd15f83..4fa964d 100644 --- a/ftp-client-conduit/ftp-client-conduit.cabal +++ b/ftp-client-conduit/ftp-client-conduit.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: ftp-client-conduit -version: 0.5.0.8 +version: 0.6.0.0 synopsis: Transfer file with FTP and FTPS with Conduit description: ftp-client is a library for communicating with an FTP server. It works over both a clear channel or TLS. ftp-client-conduit uses conduit to stream files and data in constant space. category: Web @@ -49,8 +49,7 @@ library , bytestring >=0.10.8.2 && <0.13 , conduit >=1.1 && <1.4 , crypton-connection >=0.3 && <0.5 - , exceptions >=0.10.3 && <0.11 - , ftp-client ==0.5.* + , ftp-client ==0.6.* , resourcet >=1.2 && <1.4 default-language: Haskell2010 if flag(ci) diff --git a/ftp-client-conduit/package.yaml b/ftp-client-conduit/package.yaml index 20ecde2..6862668 100644 --- a/ftp-client-conduit/package.yaml +++ b/ftp-client-conduit/package.yaml @@ -1,5 +1,5 @@ name: ftp-client-conduit -version: 0.5.0.8 +version: 0.6.0.0 synopsis: Transfer file with FTP and FTPS with Conduit description: ftp-client is a library for communicating with an FTP server. It works over both a clear channel or TLS. ftp-client-conduit uses conduit to stream files and data in constant space. homepage: https://github.com/flipstone/ftp-client @@ -38,12 +38,11 @@ library: - OverloadedStrings dependencies: - base >= 4.16 && < 5 - - ftp-client == 0.5.* + - ftp-client == 0.6.* - conduit >= 1.1 && < 1.4 - bytestring >= 0.10.8.2 && < 0.13 - resourcet >= 1.2 && < 1.4 - crypton-connection >= 0.3 && < 0.5 - - exceptions >= 0.10.3 && < 0.11 when: - condition: flag(ci) ghc-options: diff --git a/ftp-client-conduit/src/Network/FTP/Client/Conduit.hs b/ftp-client-conduit/src/Network/FTP/Client/Conduit.hs index 0365522..e6089fa 100644 --- a/ftp-client-conduit/src/Network/FTP/Client/Conduit.hs +++ b/ftp-client-conduit/src/Network/FTP/Client/Conduit.hs @@ -23,6 +23,7 @@ module Network.FTP.Client.Conduit import Conduit ((.|)) import qualified Conduit +import qualified Control.Monad as Monad import qualified Control.Monad.IO.Class as MIO import Control.Monad.Trans.Resource (MonadResource) import Data.ByteString.Lazy.Internal (defaultChunkSize) @@ -35,15 +36,16 @@ import Network.FTP.Client , createTLSSendDataCommand , getResponse , parseMlsxLine + , requireTLSContext , sIOHandleImpl , sendCommandS , tlsHandleImpl ) import qualified System.IO as SIO -import qualified Control.Monad.Catch as M import Data.ByteString (ByteString) import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C import qualified Network.Connection as Connection import qualified Network.FTP.Client as FTP @@ -68,13 +70,16 @@ getAllLineRespC h = let loop :: Conduit.ConduitT i ByteString m () loop = do - line <- - MIO.liftIO $ - FTP.getLineResp h `M.catchIOError` const (return "") - if B.null line - then return () - else do - Conduit.yield line + -- End of input is signalled by getLineRespMaybe returning Nothing. A + -- blank line is reply content, not a terminator: treating it as one + -- silently dropped the rest of a listing and the caller still saw the + -- normal 226. Any other IO failure propagates rather than masquerading + -- as a complete transfer. + mLine <- MIO.liftIO $ FTP.getLineRespMaybe h + case mLine of + Nothing -> return () + Just line -> do + Monad.unless (B.null line) $ Conduit.yield line loop in loop @@ -86,16 +91,25 @@ sendAllLineC :: Conduit.ConduitT ByteString o m () sendAllLineC h = let - loop :: Conduit.ConduitT ByteString o m () - loop = do + loop :: ByteString -> Conduit.ConduitT ByteString o m () + loop carry = do mx <- Conduit.await case mx of - Nothing -> return () + Nothing -> + -- Trailing bytes with no final newline: send them as-is rather than + -- inventing a terminator the input did not have. + Monad.unless (B.null carry) . MIO.liftIO $ + FTP.send h (FTP.toNetworkAscii carry) Just x -> do - MIO.liftIO $ FTP.sendLine h x - loop + let + -- Hold back whatever follows the last newline; the rest of that + -- line may be in the next chunk. + (complete, rest) = C.breakEnd (== '\n') (carry <> x) + Monad.unless (B.null complete) . MIO.liftIO $ + FTP.send h (FTP.toNetworkAscii complete) + loop rest in - loop + loop "" sourceDataCommandSecurity :: MonadResource m => @@ -108,7 +122,7 @@ sourceDataCommandSecurity :: sourceDataCommandSecurity h = case FTP.security h of Clear -> sourceDataCommand h - TLS -> sourceTLSDataCommand h + TLS _ -> sourceTLSDataCommand h sourceDataCommand :: MonadResource m => @@ -120,14 +134,17 @@ sourceDataCommand :: Conduit.ConduitM i o m r sourceDataCommand ch pa code cmd f = do _ <- sendCommandS ch $ RType code - x <- - Conduit.bracketP - (createSendDataCommand ch pa cmd) - (MIO.liftIO . SIO.hClose) - (f . sIOHandleImpl) - resp <- getResponse ch - debugResponse resp - return x + -- Reading the completion reply is part of releasing the data connection, not + -- a later statement. Downstream terminating early -- takeC, headC, any short + -- circuit -- abandons this pipeline, and a reply left unread becomes the + -- answer to the next command for the rest of the session. + Conduit.bracketP + (createSendDataCommand ch pa cmd) + ( \dataHandle -> do + SIO.hClose dataHandle + getResponse ch >>= debugResponse + ) + (f . sIOHandleImpl) sourceTLSDataCommand :: MonadResource m => @@ -138,15 +155,15 @@ sourceTLSDataCommand :: (FTP.Handle -> Conduit.ConduitM i o m r) -> Conduit.ConduitM i o m r sourceTLSDataCommand ch pa code cmd f = do + tlsContext <- requireTLSContext ch _ <- sendCommandS ch $ RType code - x <- - Conduit.bracketP - (createTLSSendDataCommand ch pa cmd) - (MIO.liftIO . Connection.connectionClose) - (f . tlsHandleImpl) - resp <- getResponse ch - debugResponse resp - return x + Conduit.bracketP + (createTLSSendDataCommand ch pa cmd) + ( \conn -> do + Connection.connectionClose conn + getResponse ch >>= debugResponse + ) + (f . tlsHandleImpl tlsContext) sourceFTPHandle :: forall i m. @@ -157,10 +174,7 @@ sourceFTPHandle h = let loop :: Conduit.ConduitT i ByteString m () loop = do - bs <- - MIO.liftIO $ - FTP.recv h defaultChunkSize - `M.catchIOError` const (return "") + bs <- MIO.liftIO $ FTP.recv h defaultChunkSize if B.null bs then return () else do diff --git a/ftp-client/CHANGELOG.md b/ftp-client/CHANGELOG.md index 139d48f..87fedaa 100644 --- a/ftp-client/CHANGELOG.md +++ b/ftp-client/CHANGELOG.md @@ -1,5 +1,62 @@ # 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. `connectionGetLine` was called with + `maxBound`, so a server that never sent a newline could exhaust memory before + authentication. + +* 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. + +* `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` and `toNetworkAscii` are now exported. + ## 0.5.3.1 * Enable the `henforcer` plugin and `fourmolu` under the `ci` flag. Imports are diff --git a/ftp-client/README.md b/ftp-client/README.md index 800e3c4..0ac98f1 100644 --- a/ftp-client/README.md +++ b/ftp-client/README.md @@ -13,9 +13,24 @@ withFTP "ftp.server.com" 21 $ \h welcome -> do ``` ## 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/ftp-client/ftp-client.cabal b/ftp-client/ftp-client.cabal index 065169b..a46376b 100644 --- a/ftp-client/ftp-client.cabal +++ b/ftp-client/ftp-client.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: ftp-client -version: 0.5.3.1 +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 diff --git a/ftp-client/package.yaml b/ftp-client/package.yaml index cf18b69..e93ee01 100644 --- a/ftp-client/package.yaml +++ b/ftp-client/package.yaml @@ -1,5 +1,5 @@ name: ftp-client -version: 0.5.3.1 +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. homepage: https://github.com/flipstone/ftp-client diff --git a/ftp-client/src/Network/FTP/Client.hs b/ftp-client/src/Network/FTP/Client.hs index 4c8a2f9..08c2b5e 100644 --- a/ftp-client/src/Network/FTP/Client.hs +++ b/ftp-client/src/Network/FTP/Client.hs @@ -10,6 +10,7 @@ module Network.FTP.Client ( -- * Main Entrypoints withFTP , withFTPS + , withFTPSSettings -- * Control Commands , login @@ -42,13 +43,12 @@ module Network.FTP.Client , PortActivity (..) , ProtType (..) , Security (..) + , TLSContext (..) , Handle (..) -- * TLS Commands , pbsz , prot - , ccc - , auth -- * Exceptions , FTPException (..) @@ -69,6 +69,10 @@ module Network.FTP.Client , sendAll , sendAllS , getLineResp + , getAllLineResp + , getLineRespMaybe + , toNetworkAscii + , requireTLSContext , getResponse , getResponseS , sendCommandLine @@ -108,7 +112,25 @@ debugPrint s = Monad.when debugging (MIO.liftIO $ print s) debugResponse :: (Show a, MIO.MonadIO m) => a -> m () debugResponse s = debugPrint $ "Recieved: " <> show s -data Security = Clear | TLS +{- | 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 @@ -258,6 +280,14 @@ 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. 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 + stripCLRF :: ByteString -> ByteString stripCLRF = C.takeWhile $ (&&) <$> (/= '\r') <*> (/= '\n') @@ -415,6 +445,9 @@ withSocketPassive host portNum f = do 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) @@ -433,7 +466,12 @@ withSocketActive f = do { S.addrSocketType = S.Stream , S.addrFlags = [S.AI_PASSIVE] } - M.bracketOnError + -- 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 @@ -453,7 +491,8 @@ sIOHandleImpl :: SIO.Handle -> Handle sIOHandleImpl h = Handle { send = C.hPut h - , sendLine = C.hPutStrLn 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 = C.hGetLine h , security = Clear @@ -576,6 +615,7 @@ withDataCommand ch pa code cmd f = do (createSendDataCommand ch pa cmd) (MIO.liftIO . SIO.hClose) (f . sIOHandleImpl) + `M.onException` drainDataResponse ch resp <- getResponse ch debugResponse resp return x @@ -584,13 +624,12 @@ withDataCommand ch pa code cmd f = do getAllLineResp :: (MIO.MonadIO m, MonadCatch m) => Handle -> m ByteString getAllLineResp h = let - collect :: (MIO.MonadIO n, MonadCatch n) => [ByteString] -> n ByteString - collect ret = - ( do - line <- MIO.liftIO $ getLineResp h - collect (ret <> [line]) - ) - `M.catchIOError` (\_ -> return $ C.intercalate "\n" ret) + 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 [] @@ -601,72 +640,101 @@ recvAll h = 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 ) - `M.catchIOError` (\_ -> return bs) in collect "" -- TLS connection -connectTLS :: MIO.MonadIO m => SIO.Handle -> String -> Int -> m Connection.Connection -connectTLS h host portNum = do +{- | 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 - tlsSettings = case def of - simpleSettings@Connection.TLSSettingsSimple {} -> - simpleSettings {Connection.settingDisableCertificateValidation = True} - otherSettings -> otherSettings connectionParams = Connection.ConnectionParams { Connection.connectionHostname = host , Connection.connectionPort = toEnum . fromEnum $ portNum - , Connection.connectionUseSecure = Just tlsSettings + , 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 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.Connection -> Handle -tlsHandleImpl c = +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 - , sendLine = Connection.connectionPut c . (<> "\n") + , -- RFC 959 TYPE A data uses CRLF, not a bare LF + sendLine = Connection.connectionPut c . (<> "\r\n") , recv = Connection.connectionGet c - , recvLine = Connection.connectionGetLine maxBound c - , security = TLS + , 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 host portNum f = - M.bracket - (createTLSConnection host portNum) - (MIO.liftIO . Connection.connectionClose . snd) - (\(resp, conn) -> f (tlsHandleImpl conn) resp) +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 commands will be protected with TLS. +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 @@ -674,6 +742,9 @@ withFTPS "ftps.server.com" 21 $ \h welcome -> do 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) => @@ -681,10 +752,56 @@ withFTPS :: Int -> (Handle -> FTPResponse -> m a) -> m a -withFTPS = withTLSHandle +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 ()) + {- | Send setup commands to the server and create a data TLS connection -} @@ -695,19 +812,29 @@ createTLSSendDataCommand :: FTPCommand -> m Connection.Connection createTLSSendDataCommand ch pa cmd = do + tlsContext <- requireTLSContext ch _ <- sendAllS ch [Pbsz 0, Prot P] withDataSocket pa ch $ \socket -> do resp <- sendCommand ch cmd ensureSucessfulData ch resp acceptedSock <- acceptData pa socket - (sPort, sHost) <- MIO.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 <- MIO.liftIO $ S.socketToHandle acceptedSock SIO.ReadWriteMode - MIO.liftIO $ connectTLS h hostName (fromEnum sPort) + -- 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) => @@ -718,12 +845,14 @@ withTLSDataCommand :: (Handle -> m a) -> m a withTLSDataCommand ch pa code cmd f = do + tlsContext <- requireTLSContext ch _ <- sendCommandS ch $ RType code x <- M.bracket (createTLSSendDataCommand ch pa cmd) (MIO.liftIO . Connection.connectionClose) - (f . tlsHandleImpl) + (f . tlsHandleImpl tlsContext) + `M.onException` drainDataResponse ch resp <- getResponse ch debugPrint $ "Recieved: " <> show resp return x @@ -846,16 +975,32 @@ pbsz h = sendCommandS h . Pbsz prot :: MIO.MonadIO m => Handle -> ProtType -> m FTPResponse prot h = sendCommandS h . Prot -ccc :: MIO.MonadIO m => Handle -> m FTPResponse -ccc h = sendCommandS h Ccc - -auth :: MIO.MonadIO m => Handle -> m FTPResponse -auth h = sendCommandS h Auth +-- 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 = mapM_ (sendCommandLine h) $ C.split '\n' dat +sendType TA dat h = MIO.liftIO . send h $ toNetworkAscii dat sendType TI dat h = MIO.liftIO $ send h dat withDataCommandSecurity :: @@ -869,7 +1014,7 @@ withDataCommandSecurity :: withDataCommandSecurity h = case security h of Clear -> withDataCommand h - TLS -> withTLSDataCommand h + TLS _ -> withTLSDataCommand h nlst :: (MIO.MonadIO m, MonadMask m) => Handle -> [String] -> m ByteString nlst h args = withDataCommandSecurity h Passive TA (Nlst args) getAllLineResp @@ -918,16 +1063,16 @@ parseMlsxLine line = getMlsxResponse :: (MIO.MonadIO m, MonadCatch m) => Handle -> m [MlsxResponse] getMlsxResponse h = let - collect :: (MIO.MonadIO n, MonadCatch n) => [MlsxResponse] -> n [MlsxResponse] - collect ret = - ( do - line <- MIO.liftIO $ getLineResp h + 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 - ) - `M.catchIOError` (\_ -> return ret) in collect [] diff --git a/ftp-client/test/test.hs b/ftp-client/test/test.hs index 417c8b3..a27fb87 100644 --- a/ftp-client/test/test.hs +++ b/ftp-client/test/test.hs @@ -5,7 +5,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C import Network.FTP.Client hiding (Success) import qualified Network.FTP.Client as F -import System.IO.Error (eofErrorType, mkIOError) +import System.IO.Error (eofErrorType, fullErrorType, isFullError, mkIOError) import Test.Hspec data TestHandleMVars = TestHandleMVars @@ -63,6 +63,22 @@ nextScripted what scripted countMVar = do (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 @@ -208,12 +224,29 @@ main = hspec $ do ] Clear getResponse h `shouldReturn` expected - describe "Network.FTP.Client.recvAll" $ + 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.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" isBadProtocolResponse :: FTPException -> Bool isBadProtocolResponse e =