Fix a crash on short response lines and a hang on mid-reply hangup

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

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

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

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 =

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