diff --git a/ftp-client/CHANGELOG.md b/ftp-client/CHANGELOG.md index d55224d..48cf595 100644 --- a/ftp-client/CHANGELOG.md +++ b/ftp-client/CHANGELOG.md @@ -1,5 +1,20 @@ # 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. 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 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 diff --git a/ftp-client/src/Network/FTP/Client.hs b/ftp-client/src/Network/FTP/Client.hs index 33e33dd..2b01e29 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,26 @@ 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. 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 + 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..f5b3e28 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 "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" $ 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