From 4396646e4220df726fe024d008428644bc766a3b Mon Sep 17 00:00:00 2001 From: Paul Burns Date: Wed, 19 Aug 2026 09:32:25 -0400 Subject: [PATCH 1/3] Fix partial response line parsing and multiline hang getResponse called C.head on the remainder after the three digit code, so any response line shorter than four bytes died with "Prelude.head: empty list" instead of an FTPException. A bare "200", or the empty line a closed socket yields, both hit this. Validate the three digit code up front and match on the remainder with C.uncons, which also makes the later read of the code total. loopMultiLine never terminated when the peer hung up mid response, since no line ever matched the closing code. It now stops at end of input. End of input and a blank line are deliberately kept distinct. recvLine signals end of input by throwing, while an empty ByteString is legitimate reply text -- RFC 959 lets the intermediate lines of a multiline reply carry arbitrary text. Collapsing the two would truncate any reply containing a blank line and leave its real terminator unread, so every later command would pick up the previous reply. --- ftp-client/src/Network/FTP/Client.hs | 42 ++++++++++++++---- ftp-client/test/test.hs | 65 +++++++++++++++++++++++++--- 2 files changed, 93 insertions(+), 14 deletions(-) diff --git a/ftp-client/src/Network/FTP/Client.hs b/ftp-client/src/Network/FTP/Client.hs index 33e33dd..d780aae 100644 --- a/ftp-client/src/Network/FTP/Client.hs +++ b/ftp-client/src/Network/FTP/Client.hs @@ -81,6 +81,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Control.Arrow import Data.Typeable +import System.IO.Error (isEOFError) debugging :: Bool debugging = False @@ -237,15 +238,30 @@ stripCLRF = C.takeWhile $ (&&) <$> (/= '\r') <*> (/= '\n') 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 :: 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 + -- 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. + when (C.length code < 3 || not (C.all isDigit code)) + $ liftIO $ throwIO $ BadProtocolResponseException line + message <- case C.uncons rest of + Just ('-', _) -> MultiLine <$> loopMultiLine h code [line] + _ -> return $ SingleLine line let codeDroppedMessage = case message of SingleLine message -> SingleLine $ C.drop 4 message MultiLine [] -> MultiLine [] @@ -267,12 +283,20 @@ loopMultiLine -> [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 + mNextLine <- liftIO $ getLineRespMaybe h + case mNextLine of + -- The server hung up before sending the terminating line. Return what + -- was collected rather than looping forever. Note 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 -> return lines + Just nextLine -> do + 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 = diff --git a/ftp-client/test/test.hs b/ftp-client/test/test.hs index 0cd43b2..fa8b996 100644 --- a/ftp-client/test/test.hs +++ b/ftp-client/test/test.hs @@ -5,6 +5,7 @@ import Network.FTP.Client hiding (Success) import qualified Network.FTP.Client as F import Control.Monad.IO.Class import Control.Concurrent.MVar +import System.IO.Error (eofErrorType, mkIOError) data TestHandleMVars = TestHandleMVars { thmSend :: MVar [ByteString] @@ -37,15 +38,21 @@ testHandle recvResps recvLineResps sec = do , 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)) + 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 + main :: IO () main = hspec $ do describe "Network.FTP.Client.sendCommand" $ do @@ -67,8 +74,56 @@ main = hspec $ do ] 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 "stops when the server hangs up during a multiline response" $ do + let expected = FTPResponse + F.Success 220 + (MultiLine [C.pack "First Line"]) + (TestHandle _ h) <- testHandle [] + [ C.pack "220-First Line\r\n" + ] Clear + getResponse h `shouldReturn` expected 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 + +isBadProtocolResponse :: FTPException -> Bool +isBadProtocolResponse e = + case e of + BadProtocolResponseException _ -> True + _ -> False From 6ede0ec859a9f963534b5dc6be88e7602c261712 Mon Sep 17 00:00:00 2001 From: Paul Burns Date: Tue, 18 Aug 2026 19:51:47 -0400 Subject: [PATCH 2/3] Version 0.5.1.8, changelog entry Both changes on this branch are bug fixes with no API change, so PVP asks for a patch bump. --- ftp-client/CHANGELOG.md | 12 ++++++++++++ ftp-client/ftp-client.cabal | 2 +- ftp-client/package.yaml | 2 +- 3 files changed, 14 insertions(+), 2 deletions(-) diff --git a/ftp-client/CHANGELOG.md b/ftp-client/CHANGELOG.md index d55224d..7c3b1ad 100644 --- a/ftp-client/CHANGELOG.md +++ b/ftp-client/CHANGELOG.md @@ -1,5 +1,17 @@ # Changelog for ftp-client +## 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. It now stops on an exhausted stream and returns the + lines received, matching the existing behaviour of `recvAll`. + ## 0.5.1.7 * Correct the `base` bound. The package claimed `>= 4.8`, i.e. support back to diff --git a/ftp-client/ftp-client.cabal b/ftp-client/ftp-client.cabal index 84cd0b3..a7e5ad8 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.1.7 +version: 0.5.1.8 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 369da2e..323c3f0 100644 --- a/ftp-client/package.yaml +++ b/ftp-client/package.yaml @@ -1,5 +1,5 @@ name: ftp-client -version: 0.5.1.7 +version: 0.5.1.8 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 From 9d5bab72a841a01c0b38976373036283ef2882d6 Mon Sep 17 00:00:00 2001 From: Paul Burns Date: Mon, 24 Aug 2026 20:37:46 -0400 Subject: [PATCH 3/3] Reject a multiline reply the server never finished Terminating instead of looping forever was only half of the fix. Returning the lines collected so far handed back a fragment as though it were a whole reply, so a greeting cut off after "220-" produced a well formed FTPResponse with code 220 and status Success, and withFTP carried on against a control connection that was already gone. End of input mid reply now raises BadProtocolResponseException carrying what did arrive. The distinction that motivated the original fix is unchanged: end of input is not a blank line. RFC 959 lets the intermediate lines of a multiline reply hold arbitrary text, blank lines included, so a blank line still has to be kept and the loop still has to continue past it. The existing test asserted the old behaviour -- it expected exactly the Success 220 that this commit rejects -- so it becomes a shouldThrow rather than a new case beside it. Reported by Copilot on flipstone/ftp-client#4. Co-Authored-By: Claude Opus 5 (1M context) --- ftp-client/CHANGELOG.md | 7 +++++-- ftp-client/src/Network/FTP/Client.hs | 18 ++++++++++++------ ftp-client/test/test.hs | 10 +++++----- 3 files changed, 22 insertions(+), 13 deletions(-) diff --git a/ftp-client/CHANGELOG.md b/ftp-client/CHANGELOG.md index 7c3b1ad..48cf595 100644 --- a/ftp-client/CHANGELOG.md +++ b/ftp-client/CHANGELOG.md @@ -9,8 +9,11 @@ * 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. It now stops on an exhausted stream and returns the - lines received, matching the existing behaviour of `recvAll`. + 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 diff --git a/ftp-client/src/Network/FTP/Client.hs b/ftp-client/src/Network/FTP/Client.hs index d780aae..2b01e29 100644 --- a/ftp-client/src/Network/FTP/Client.hs +++ b/ftp-client/src/Network/FTP/Client.hs @@ -285,12 +285,18 @@ loopMultiLine loopMultiLine h code lines = do mNextLine <- liftIO $ getLineRespMaybe h case mNextLine of - -- The server hung up before sending the terminating line. Return what - -- was collected rather than looping forever. Note 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 -> return lines + -- 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 -> liftIO $ throwIO $ BadProtocolResponseException + $ C.intercalate "\n" lines Just nextLine -> do let newLines = lines <> [C.dropWhile (== ' ') nextLine] nextCode = C.take 3 nextLine diff --git a/ftp-client/test/test.hs b/ftp-client/test/test.hs index fa8b996..f5b3e28 100644 --- a/ftp-client/test/test.hs +++ b/ftp-client/test/test.hs @@ -108,14 +108,14 @@ main = hspec $ do , C.pack "220 Third Line\r\n" ] Clear getResponse h `shouldReturn` expected - it "stops when the server hangs up during a multiline response" $ do - let expected = FTPResponse - F.Success 220 - (MultiLine [C.pack "First Line"]) + 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 `shouldReturn` expected + getResponse h `shouldThrow` isBadProtocolResponse describe "Network.FTP.Client.recvAll" $ it "doesn't hang on empty response" $ do let expected = C.pack ""