Skip to content

Add support for a nonstandard multiline response. #21

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
mr wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Add support for a nonstandard multiline response. #21

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
25 changes: 19 additions & 6 deletions ftp-client/src/Network/FTP/Client.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -82,7 +82,7 @@ import Control.Arrow
import Data.Typeable

debugging :: Bool
debugging = False
debugging = True

debugPrint :: (Show a, MonadIO m) => a -> m ()
debugPrint s = when debugging (liftIO $ print s)
Expand Down Expand Up @@ -267,11 +267,24 @@ loopMultiLine
-> 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
let newLineSpace = C.dropWhile (== ' ') nextLine
-- some ftp implementations start all multiline responses with "<code>-"
-- this is not standard but we account for that possibility
(nextCode, newLineContinue) = C.splitAt 3 nextLine
hasDash = C.head newLineContinue == '-'
codePresent = nextCode == code
-- strip the code and dash off if they exist
-- otherwise just strip leading spaces
newLine = if C.length nextLine > 3 && hasDash
then C.drop 1 newLineContinue
else newLineSpace
newLines = lines <> [newLine]
-- we continue if we find the code with a dash afterward
-- the code by itself (no dash) means we should stop
continue = (codePresent && hasDash) || not codePresent
if continue
then loopMultiLine h code newLines
else return newLines

ensureSuccess :: MonadIO m => FTPResponse -> m FTPResponse
ensureSuccess resp =
Expand Down