Validate FTPS certificates, stop losing data on failure, plug leaks

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

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)

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:

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

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
+<https://github.com/flipstone/ftp-client/pull/1>, 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

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
+```

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

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