ftp-client 0.5.1.6 → 0.6.0.0

raw patch · 7 files changed

+1703/−909 lines, 7 filesdep +directorydep +henforcerdep −transformersdep ~basedep ~containerssetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, henforcer

Dependencies removed: transformers

Dependency ranges changed: base, containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +130/−0
• README.md +15/−0
• Setup.hs +1/−0
• ftp-client.cabal +94/−38
• henforcer.toml +10/−0
• src/Network/FTP/Client.hs +1172/−810
• test/test.hs +281/−61

@@ -0,0 +1,130 @@+# 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 on both control connections.+  `connectionGetLine` was called with `maxBound`, so a server that never sent a+  newline could exhaust memory before authentication. The clear-channel handle+  used unbounded `hGetLine`, which left `withFTP` replies -- and the plaintext+  greeting and `AUTH TLS` reply that `createTLSConnection` reads before+  authenticating -- without any limit at all. Both now apply+  `maxReplyLineLength`, which is exported, and raise+  `Network.Connection.LineTooLong` past it.++* 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.++  That drain is now conditional on a completion reply actually being pending.+  A transfer the server rejects outright -- `PBSZ`, `PROT`, `PASV` or the+  transfer command itself -- fails with its error reply already consumed, and+  nothing further is coming, so draining blocked until the server gave up on+  the connection. `PendingCompletion`, `newPendingCompletion` and+  `drainPendingCompletion` are exported, and `createSendDataCommand` and+  `createTLSSendDataCommand` take a `PendingCompletion`.++* `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`, `toNetworkAscii` and+  `maxReplyLineLength` are now exported.++## 0.5.3.1++* Enable the `henforcer` plugin and `fourmolu` under the `ci` flag. Imports are+  now qualified per the house style and the source is fourmolu formatted;+  neither changes the API.++## 0.5.3.0++* Export `acct`, `pbsz`, `prot`, `ccc` and `auth`. These command wrappers were+  defined but never exported, unlike every other command wrapper in the module.++* Drop the `transformers` dependency. The only module it supplied,+  `Control.Monad.IO.Class`, has been in `base` since 4.9.++* Stop deriving `Typeable` for `FTPException`. It has been a no-op since GHC+  7.10 and GHC 9.12 warns about it.++## 0.5.2.0++* Expose `createSIOHandle`, `createTLSConnection` and `connectTLS` so callers can+  manage the handle lifecycle themselves rather than going through `withFTP` and+  `withFTPS`. Thanks to @pucsdian.++* Fix multiline response parsing. A response was terminated at the first+  continuation line whose first three bytes matched the response code, so a reply+  such as `220-First` / `220-Second` / `220 Third` was truncated to two lines. Per+  [RFC 959](https://datatracker.ietf.org/doc/html/rfc959#page-36) only the code+  followed by a space ends a multiline reply; the code followed by a hyphen+  continues it. A final line consisting of the bare code is also accepted, for+  servers that omit the trailing space. Thanks to @pucsdian.++## 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+  GHC 7.10, but no compiler that old can build it because `crypton-connection`+  does not exist there. The bound is now `>= 4.16`, the oldest GHC that is+  actually tested, and `tested-with` records the full set.++## Earlier releases++Prior to 0.5.1.7 this package had no changelog. See the git history at+<https://github.com/flipstone/ftp-client> for changes in earlier versions.

@@ -13,9 +13,24 @@ ```  ## 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 ```

@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain

@@ -1,43 +1,99 @@-name:                ftp-client-version:             0.5.1.6-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-license:             PublicDomain-maintainer:          Flipstone Technology Partners-license-file:        LICENSE-author:              Megan Robinson-category:            Web-build-type:          Simple-extra-source-files:  README.md-cabal-version:       >=1.10+cabal-version: 1.12 -library-  hs-source-dirs:      src-  exposed-modules:     Network.FTP.Client-  default-language:    Haskell2010-  default-extensions:  OverloadedStrings-  build-depends:       base >= 4.8 && < 5-                     , bytestring >= 0.10.8.2 && < 0.13-                     , network >= 2.6.3.6 && < 3.3-                     , attoparsec >= 0.10 && < 0.15-                     , crypton-connection >= 0.3 && < 0.5-                     , transformers >= 0.5.6.2 && < 0.7-                     , exceptions >= 0.10.3 && < 0.11-                     , containers >= 0.5.11.0 && < 0.8-                     , data-default-class >= 0.1.2.0 && < 0.2+-- This file has been generated from package.yaml by hpack version 0.39.1.+--+-- see: https://github.com/sol/hpack -test-suite ftp-client-test-  type:                exitcode-stdio-1.0-  hs-source-dirs:      test-  main-is:             test.hs-  build-depends:       base >=4.11.1.0 && < 5-                     , bytestring >=0.10.8.2 && <0.13-                     , hspec >= 2.7-                     , ftp-client -any-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N-  default-language:    Haskell2010+name:           ftp-client+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+homepage:       https://github.com/flipstone/ftp-client+author:         Megan Robinson+maintainer:     Flipstone Technology Partners+license:        PublicDomain+license-file:   LICENSE+build-type:     Simple+tested-with:+    GHC == 9.2.8+  , GHC == 9.4.8+  , GHC == 9.6.7+  , GHC == 9.8.4+  , GHC == 9.10.3+  , GHC == 9.12.4+extra-source-files:+    README.md+    CHANGELOG.md+    henforcer.toml  source-repository head-  type:     git+  type: git   location: https://github.com/flipstone/ftp-client++flag ci+  description: More strict ghc options used for development and ci, not intended for end-use.+  manual: True+  default: False++library+  exposed-modules:+      Network.FTP.Client+  other-modules:+      Paths_ftp_client+  hs-source-dirs:+      src+  default-extensions:+      OverloadedStrings+  build-depends:+      attoparsec >=0.10 && <0.15+    , base >=4.16 && <5+    , bytestring >=0.10.8.2 && <0.13+    , containers >=0.5.11.0 && <0.8+    , crypton-connection >=0.3 && <0.5+    , data-default-class >=0.1.2.0 && <0.3+    , exceptions >=0.10.3 && <0.11+    , network >=2.6.3.6 && <3.3+  default-language: Haskell2010+  if flag(ci)+    ghc-options: -O2 -Wall -Werror -Wcompat -Widentities -Winvalid-haddock -Wmissing-local-signatures -Wmissing-export-lists -Wpartial-fields -Wmissed-specialisations -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wunused-packages+    if impl (ghc < 9.4)+      ghc-options: -Wno-unticked-promoted-constructors+    if impl (ghc >= 9.4)+      ghc-options: -Wimplicit-lift -Woperator-whitespace -Wredundant-bang-patterns -Wredundant-strictness-flags+    if impl (ghc >= 9.8)+      ghc-options: -Wincomplete-export-warnings -Wmissing-poly-kind-signatures -Wterm-variable-capture+    if impl (ghc >= 9.10)+      ghc-options: -Wdefaulted-exception-context+    if impl (ghc >= 9.6)+      ghc-options: -fplugin Henforcer+      build-depends:+          henforcer++test-suite ftp-client-test+  type: exitcode-stdio-1.0+  main-is: test.hs+  other-modules:+      Paths_ftp_client+  hs-source-dirs:+      test+  build-depends:+      base >=4.16 && <5+    , bytestring >=0.10.8.2 && <0.13+    , crypton-connection >=0.3 && <0.5+    , directory ==1.3.*+    , ftp-client+    , hspec >=2.7+  default-language: Haskell2010+  if flag(ci)+    ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Werror -Wcompat -Widentities -Winvalid-haddock -Wmissing-local-signatures -Wmissing-export-lists -Wpartial-fields -Wmissed-specialisations -Wno-implicit-prelude -Wno-safe -Wno-unsafe+    if impl (ghc < 9.4)+      ghc-options: -Wno-unticked-promoted-constructors+    if impl (ghc >= 9.4)+      ghc-options: -Wimplicit-lift -Woperator-whitespace -Wredundant-bang-patterns -Wredundant-strictness-flags+    if impl (ghc >= 9.8)+      ghc-options: -Wincomplete-export-warnings -Wmissing-poly-kind-signatures -Wterm-variable-capture+    if impl (ghc >= 9.10)+      ghc-options: -Wdefaulted-exception-context+  else+    ghc-options: -threaded -rtsopts -with-rtsopts=-N

@@ -0,0 +1,10 @@+[forAnyModule]+allowedOpenUnaliasedImports = 1+moduleHeaderCopyrightMustExistNonEmpty = true+moduleHeaderDescriptionMustExistNonEmpty = false+moduleHeaderLicenseMustExistNonEmpty = true+moduleHeaderMaintainerMustExistNonEmpty = false+[[forPatternModules]]+pattern = "Paths_*"+[forPatternModules.rulesToIgnore]+all = true

@@ -1,811 +1,1173 @@-{-|-Module      : Network.FTP.Client-Description : Transfer files over FTP and FTPS-License     : Public Domain-Stability   : experimental-Portability : POSIX--}-module Network.FTP.Client (-    -- * Main Entrypoints-    withFTP,-    withFTPS,-    -- * Control Commands-    login,-    pasv,-    rename,-    dele,-    cwd,-    size,-    mkd,-    rmd,-    pwd,-    quit,-    -- * Data Commands-    nlst,-    retr,-    list,-    stor,-    mlsd,-    mlst,-    -- * Types-    FTPCommand(..),-    FTPResponse(..),-    FTPMessage(..),-    ResponseStatus(..),-    MlsxResponse(..),-    RTypeCode(..),-    PortActivity(..),-    ProtType(..),-    Security(..),-    Handle(..),-    -- * Exceptions-    FTPException(..),-    -- * Handle Implementations-    sIOHandleImpl,-    tlsHandleImpl,-    -- * Lower Level Functions-    sendCommand,-    sendCommandS,-    recvAll,-    sendAll,-    sendAllS,-    getLineResp,-    getResponse,-    getResponseS,-    sendCommandLine,-    createSendDataCommand,-    createTLSSendDataCommand,-    parseMlsxLine-) where--import Data.Default.Class (def)-import qualified Data.ByteString.Char8 as C-import qualified Data.ByteString as B-import Data.ByteString (ByteString)-import Data.List-import Data.Attoparsec.ByteString.Char8-import qualified Network.Socket as S-import qualified System.IO as SIO-import Data.Monoid ((<>))-import Control.Exception-import Control.Monad.Catch (MonadCatch, MonadMask)-import qualified Control.Monad.Catch as M-import Control.Monad-import Control.Monad.IO.Class-import Data.Bits-import Network.Connection-import Data.ByteString.Lazy.Internal (defaultChunkSize)-import Data.Functor ((<$>))-import Control.Applicative ((<*>))-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import Control.Arrow-import Data.Typeable--debugging :: Bool-debugging = False--debugPrint :: (Show a, MonadIO m) => a -> m ()-debugPrint s = when debugging (liftIO $ print s)--debugResponse :: (Show a, MonadIO m) => a -> m ()-debugResponse s = debugPrint $ "Recieved: " <> show s--data Security = Clear | TLS---- | Can send and recieve a 'Data.ByteString.ByteString'.-data Handle = Handle-    { send :: ByteString -> IO ()-    , sendLine :: ByteString -> IO ()-    , recv :: Int -> IO ByteString-    , recvLine :: IO ByteString-    , security :: Security-    }--data FTPMessage = SingleLine ByteString | MultiLine [ByteString]-    deriving Eq--instance Show FTPMessage where-    show (SingleLine message) = C.unpack message-    show (MultiLine messages) = intercalate "\n" $ C.unpack <$> messages---- | Response from an FTP command. ex "200 Welcome!"-data FTPResponse = FTPResponse {-    frStatus :: ResponseStatus, -- ^ Interpretation of the first digit of an FTP response code-    frCode :: Int, -- ^ The three digit response code-    frMessage :: FTPMessage -- ^ Text of the response-} deriving Eq--instance Show FTPResponse where-    show fr = show (frCode fr) <> " " <> show (frMessage fr)---- | First digit of an FTP response-data ResponseStatus-    = Wait -- ^ 1-    | Success -- ^ 2-    | Continue -- ^ 3-    | FailureRetry -- ^ 4-    | Failure -- ^ 5-    deriving (Show, Eq)--data FTPException-    = FailureRetryException FTPResponse-    | FailureException FTPResponse-    | UnsuccessfulException FTPResponse-    | BogusResponseFormatException FTPResponse-    | BadProtocolResponseException ByteString-    deriving (Show, Typeable)--instance Exception FTPException--responseStatus :: ByteString -> ResponseStatus-responseStatus cbs =-    case C.uncons cbs of-        Just ('1', _) -> Wait-        Just ('2', _) -> Success-        Just ('3', _) -> Continue-        Just ('4', _) -> FailureRetry-        Just ('5', _) -> Failure-        _ -> throw $ BadProtocolResponseException cbs--data RTypeCode = TA | TI--serialzeRTypeCode :: RTypeCode -> String-serialzeRTypeCode TA = "A"-serialzeRTypeCode TI = "I"--data PortActivity = Active | Passive--data ProtType = P | C---- | Commands according to the FTP specification-data FTPCommand-    = User String-    | Pass String-    | Acct String-    | RType RTypeCode-    | Retr String-    | Nlst [String]-    | Port S.HostAddress S.PortNumber-    | Stor String-    | List [String]-    | Rnfr String-    | Rnto String-    | Dele String-    | Size String-    | Mkd String-    | Rmd String-    | Pbsz Int-    | Prot ProtType-    | Mlsd String-    | Mlst String-    | Cwd String-    | Cdup-    | Ccc-    | Auth-    | Pwd-    | Abor-    | Pasv-    | Quit--instance Show FTPCommand where-    show = serializeCommand--formatPort :: S.HostAddress -> S.PortNumber -> String-formatPort ha pn =-    let (w1, w2, w3, w4) = S.hostAddressToTuple ha-        hn = show <$> [w1, w2, w3, w4]-        portParts = show <$> [pn `quot` 256, pn `mod` 256]-    in intercalate "," (hn <> portParts)--serializeCommand :: FTPCommand -> String-serializeCommand (User user)  = "USER " <> user-serializeCommand (Pass pass)  = "PASS " <> pass-serializeCommand (Acct acct)  = "ACCT " <> acct-serializeCommand (RType rt)   = "TYPE " <> serialzeRTypeCode rt-serializeCommand (Retr file)  = "RETR " <> file-serializeCommand (Nlst [])    = "NLST"-serializeCommand (Nlst args)  = "NLST " <> unwords args-serializeCommand (Port ha pn) = "PORT " <> formatPort ha pn-serializeCommand (Stor loc)   = "STOR " <> loc-serializeCommand (List [])    = "LIST"-serializeCommand (List args)  = "LIST " <> unwords args-serializeCommand (Rnfr from)  = "RNFR " <> from-serializeCommand (Rnto to)    = "RNTO " <> to-serializeCommand (Dele file)  = "DELE " <> file-serializeCommand (Size file)  = "SIZE " <> file-serializeCommand (Mkd dir)    = "MKD " <> dir-serializeCommand (Rmd dir)    = "RMD " <> dir-serializeCommand (Pbsz buf)   = "PBSZ " <> show buf-serializeCommand (Prot P)     = "PROT P"-serializeCommand (Prot C)     = "PROT C"-serializeCommand (Mlsd path)  = "MLSD " <> path-serializeCommand (Mlst path)  = "MLST " <> path-serializeCommand (Cwd dir)    = "CWD " <> dir-serializeCommand Cdup         = "CDUP"-serializeCommand Ccc          = "CCC"-serializeCommand Auth         = "AUTH TLS"-serializeCommand Pwd          = "PWD"-serializeCommand Abor         = "ABOR"-serializeCommand Pasv         = "PASV"-serializeCommand Quit         = "QUIT"--stripCLRF :: ByteString -> ByteString-stripCLRF = C.takeWhile $ (&&) <$> (/= '\r') <*> (/= '\n')---- | Get a line from the server-getLineResp :: Handle -> IO ByteString-getLineResp h = stripCLRF <$> recvLine h---- | 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-    let codeDroppedMessage = case message of-            SingleLine message -> SingleLine $ C.drop 4 message-            MultiLine [] -> MultiLine []-            MultiLine (message:messages) ->-                MultiLine $ C.drop 4 message : messages-    let response = FTPResponse-            (responseStatus code)-            (read $ C.unpack code)-            codeDroppedMessage-    case frStatus response of-        FailureRetry -> liftIO $ throwIO $ FailureRetryException response-        Failure -> liftIO $ throwIO $ FailureException response-        _ -> return response--loopMultiLine-    :: MonadIO m-    => Handle-    -> ByteString-    -> [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--ensureSuccess :: MonadIO m => FTPResponse -> m FTPResponse-ensureSuccess resp =-    case frStatus resp of-        Success -> return resp-        _ -> liftIO $ throwIO $ UnsuccessfulException resp--getResponseS :: MonadIO m => Handle -> m FTPResponse-getResponseS = ensureSuccess <=< getResponse--sendCommandLine :: MonadIO m => Handle -> ByteString -> m ()-sendCommandLine h = liftIO . send h . (<> "\r\n")---- | Send a command to the server and get a response back.--- Some commands use a data 'Handle', and their data is not returned here.-sendCommand :: MonadIO m => Handle -> FTPCommand -> m FTPResponse-sendCommand h fc = do-    let command = serializeCommand fc-    debugPrint $ "Sending: " <> command-    sendCommandLine h $ C.pack command-    resp <- getResponse h-    debugResponse resp-    return resp--sendCommandS :: MonadIO m => Handle -> FTPCommand -> m FTPResponse-sendCommandS h fc = sendCommand h fc >>= ensureSuccess---- | Equvalent to------ > mapM . sendCommand-sendAll :: MonadIO m => Handle -> [FTPCommand] -> m [FTPResponse]-sendAll = mapM . sendCommand---- | Equvalent to------ > mapM . sendCommandS-sendAllS :: MonadIO m => Handle -> [FTPCommand] -> m [FTPResponse]-sendAllS = mapM . sendCommandS---- Control connection--createSocket-    :: MonadIO m-    => Maybe String-    -> Int-    -> S.AddrInfo-    -> m (S.Socket, S.AddrInfo)-createSocket host portNum hints = do-    addr <- liftIO $ do-      a:_ <- S.getAddrInfo (Just hints) host (Just $ show portNum)-      return a-    debugPrint $ "Addr: " <> show addr-    sock <- liftIO $ S.socket-        (S.addrFamily addr)-        (S.addrSocketType addr)-        (S.addrProtocol addr)-    return (sock, addr)--withSocketPassive-    :: (MonadIO m, MonadMask m)-    => String-    -> Int-    -> (S.Socket -> m a)-    -> m a-withSocketPassive host portNum f = do-    let hints = S.defaultHints {-        S.addrSocketType = S.Stream-    }-    M.bracketOnError-        (createSocket (Just host) portNum hints)-        (liftIO . S.close . fst)-        (\(sock, addr) -> do-            debugPrint "Connecting"-            liftIO $ S.connect sock (S.addrAddress addr)-            debugPrint "Connected"-            f sock-        )--withSocketActive :: (MonadIO m, MonadMask m) => (S.Socket -> m a) -> m a-withSocketActive f = do-    let hints = S.defaultHints {-        S.addrSocketType = S.Stream,-        S.addrFlags = [S.AI_PASSIVE]-    }-    M.bracketOnError-        (createSocket Nothing 0 hints)-        (liftIO . S.close . fst)-        (\(sock, addr) -> do-            debugPrint "Binding"-            liftIO $ S.bind sock (S.addrAddress addr)-            liftIO $ S.listen sock 1-            debugPrint "Listening"-            f sock-        )--createSIOHandle :: (MonadIO m, MonadMask m) => String -> Int -> m SIO.Handle-createSIOHandle host portNum = withSocketPassive host portNum-    $ liftIO . flip S.socketToHandle SIO.ReadWriteMode--sIOHandleImpl :: SIO.Handle -> Handle-sIOHandleImpl h = Handle-    { send = C.hPut h-    , sendLine = C.hPutStrLn h-    , recv = C.hGetSome h-    , recvLine = C.hGetLine h-    , security = Clear-    }--withSIOHandle-    :: (MonadIO m, MonadMask m)-    => String-    -> Int-    -> (Handle -> m a)-    -> m a-withSIOHandle host portNum f = M.bracket-    (liftIO $ createSIOHandle host portNum)-    (liftIO . SIO.hClose)-    (f . sIOHandleImpl)---- | Takes a host name and port. A handle for interacting with the server--- will be returned in a callback.------ @--- withFTP "ftp.server.com" 21 $ \h welcome -> do---     print welcome---     login h "username" "password"---     print =<< nlst h []--- @-withFTP-    :: (MonadIO m, MonadMask m)-    => String-    -> Int-    -> (Handle -> FTPResponse -> m a)-    -> m a-withFTP host portNum f = withSIOHandle host portNum $ \h -> do-    resp <- getResponse h-    f h resp---- Data connection--withDataSocketPasv-    :: (MonadIO m, MonadMask m)-    => Handle-    -> (S.Socket -> m a)-    -> m a-withDataSocketPasv h f = do-    (host, portNum) <- pasv h-    debugPrint $ "Host: " <> host-    debugPrint $ "Port: " <> show portNum-    withSocketPassive host portNum f--withDataSocketActive-    :: (MonadIO m, MonadMask m)-    => Handle-    -> (S.Socket -> m a)-    -> m a-withDataSocketActive h f = withSocketActive $ \socket -> do-    (sPort, sHost) <- liftIO $ do-      (S.SockAddrInet p h) <- S.getSocketName socket-      return (p,h)-    port h sHost sPort-    f socket---- | Open a socket that can be used for data transfers-withDataSocket-    :: (MonadIO m, MonadMask m)-    => PortActivity-    -> Handle-    -> (S.Socket -> m a)-    -> m a-withDataSocket Active  = withDataSocketActive-withDataSocket Passive = withDataSocketPasv--acceptData :: MonadIO m => PortActivity -> S.Socket -> m S.Socket-acceptData Passive = return-acceptData Active = return . fst <=< liftIO . S.accept---- Response to data commands should be 150 but apparently--- some servers will respond with 200 before 150 so just ignore it-ensureSucessfulData :: MonadIO m => Handle -> FTPResponse -> m ()-ensureSucessfulData h resp = do-    resp' <- case frStatus resp of-        Success -> do-            newResp <- getResponse h-            debugResponse newResp-            return newResp-        _ -> return resp-    liftIO $ when (frStatus resp' /= Wait)-        $ throwIO $ UnsuccessfulException resp---- | Send setup commands to the server and--- create a data 'System.IO.Handle'-createSendDataCommand-    :: (MonadIO m, MonadMask m)-    => Handle-    -> PortActivity-    -> FTPCommand-    -> m SIO.Handle-createSendDataCommand h pa cmd = withDataSocket pa h $ \socket -> do-    resp <- sendCommand h cmd-    ensureSucessfulData h resp-    acceptedSock <- acceptData pa socket-    liftIO $ S.socketToHandle acceptedSock SIO.ReadWriteMode---- | Provides a data 'Handle' in a callback for a command-withDataCommand-    :: (MonadIO m, MonadMask m)-    => Handle-    -> PortActivity-    -> RTypeCode-    -> FTPCommand-    -> (Handle -> m a)-    -> m a-withDataCommand ch pa code cmd f = do-    sendCommandS ch $ RType code-    x <- M.bracket-        (createSendDataCommand ch pa cmd)-        (liftIO . SIO.hClose)-        (f . sIOHandleImpl)-    resp <- getResponse ch-    debugResponse resp-    return x---- | Recieve data and interpret it linewise-getAllLineResp :: (MonadIO m, MonadCatch m) => Handle -> m ByteString-getAllLineResp h = getAllLineResp' h []-    where-        getAllLineResp' h ret = ( do-            line <- liftIO $ getLineResp h-            getAllLineResp' h (ret <> [line]))-                `M.catchIOError` (\_ -> return $ C.intercalate "\n" ret)---- | Recieve all data and return it as a 'Data.ByteString.ByteString'-recvAll :: (MonadIO m, MonadCatch m) => Handle -> m ByteString-recvAll h = recvAll' ""-    where-        recvAll' bs = ( do-            chunk <- liftIO $ recv h defaultChunkSize-            if C.null chunk-               then return bs-               else recvAll' $ bs <> chunk-            ) `M.catchIOError` (\_ -> return bs)---- TLS connection--connectTLS :: MonadIO m => SIO.Handle -> String -> Int -> m Connection-connectTLS h host portNum = do-    context <- liftIO initConnectionContext-    let tlsSettings = def-            { settingDisableCertificateValidation = True-            }-        connectionParams = ConnectionParams-            { connectionHostname = host-            , connectionPort = toEnum . fromEnum $ portNum-            , connectionUseSecure = Just tlsSettings-            , connectionUseSocks = Nothing-            }-    liftIO $ connectFromHandle context h connectionParams--createTLSConnection-    :: (MonadIO m, MonadMask m)-    => String-    -> Int-    -> m (FTPResponse, Connection)-createTLSConnection host portNum = do-    h <- createSIOHandle host portNum-    let insecureH = sIOHandleImpl h-    resp <- getResponse insecureH-    sendCommand insecureH Auth-    conn <- connectTLS h host portNum-    return (resp, conn)--tlsHandleImpl :: Connection -> Handle-tlsHandleImpl c = Handle-    { send = connectionPut c-    , sendLine = connectionPut c . (<> "\n")-    , recv = connectionGet c-    , recvLine = connectionGetLine maxBound c-    , security = TLS-    }--withTLSHandle-    :: (MonadMask m, MonadIO m)-    => String-    -> Int-    -> (Handle -> FTPResponse -> m a)-    -> m a-withTLSHandle host portNum f = M.bracket-    (createTLSConnection host portNum)-    (liftIO . connectionClose . snd)-    (\(resp, conn) -> f (tlsHandleImpl conn) resp)---- | Takes a host name and port. A handle for interacting with the server--- will be returned in a callback. The commands will be protected with TLS.------ @--- withFTPS "ftps.server.com" 21 $ \h welcome -> do---     print welcome---     login h "username" "password"---     print =<< nlst h []--- @-withFTPS-    :: (MonadMask m, MonadIO m)-    => String-    -> Int-    -> (Handle -> FTPResponse -> m a)-    -> m a-withFTPS = withTLSHandle---- TLS data connection---- | Send setup commands to the server and--- create a data TLS connection-createTLSSendDataCommand-    :: (MonadIO m, MonadMask m)-    => Handle-    -> PortActivity-    -> FTPCommand-    -> m Connection-createTLSSendDataCommand ch pa cmd = do-    sendAllS ch [Pbsz 0, Prot P]-    withDataSocket pa ch $ \socket -> do-        resp <- sendCommand ch cmd-        ensureSucessfulData ch resp-        acceptedSock <- acceptData pa socket-        (sPort, sHost) <- liftIO $ do-          (S.SockAddrInet p h) <- S.getSocketName acceptedSock-          return (p, h)-        let (h1, h2, h3, h4) = S.hostAddressToTuple sHost-            hostName = intercalate "." $ show . fromEnum <$> [h1, h2, h3, h4]-        h <- liftIO $ S.socketToHandle acceptedSock SIO.ReadWriteMode-        liftIO $ connectTLS h hostName (fromEnum sPort)--withTLSDataCommand-    :: (MonadIO m, MonadMask m)-    => Handle-    -> PortActivity-    -> RTypeCode-    -> FTPCommand-    -> (Handle -> m a)-    -> m a-withTLSDataCommand ch pa code cmd f = do-    sendCommandS ch $ RType code-    x <- M.bracket-        (createTLSSendDataCommand ch pa cmd)-        (liftIO . connectionClose)-        (f . tlsHandleImpl)-    resp <- getResponse ch-    debugPrint $ "Recieved: " <> show resp-    return x--parseResponse :: MonadIO m => FTPResponse -> Parser a -> m a-parseResponse resp p =-    let parsableMessage = case frMessage resp of-            SingleLine message -> message-            MultiLine messages -> C.intercalate "\n" messages-    in case parseOnly p parsableMessage of-        Right x -> return x-        Left _ -> liftIO $ throwIO-            $ BadProtocolResponseException parsableMessage--ensureCode :: MonadIO m => FTPResponse -> Int -> m ()-ensureCode resp code =-    liftIO $ when (frCode resp /= code)-        $ liftIO $ throwIO $ UnsuccessfulException resp--parse227 :: Parser (String, Int)-parse227 = do-    skipWhile (/= '(') *> char '('-    [h1,h2,h3,h4,p1,p2] <- many1 digit `sepBy` char ','-    let host = intercalate "." [h1,h2,h3,h4]-        highBits = read p1-        lowBits = read p2-        portNum = (highBits `shift` 8) + lowBits-    return (host, portNum)--parse257 :: Parser String-parse257 = do-    char '"'-    C.unpack <$> takeTill (== '"')---- Control commands--login :: MonadIO m => Handle -> String -> String -> m FTPResponse-login h user pass = do-    resp <- last <$> sendAll h [User user, Pass pass]-    ensureSuccess resp--pasv :: MonadIO m => Handle -> m (String, Int)-pasv h = do-    resp <- sendCommandS h Pasv-    ensureCode resp 227-    parseResponse resp parse227--port :: MonadIO m => Handle -> S.HostAddress -> S.PortNumber -> m FTPResponse-port h ha pn = sendCommandS h (Port ha pn)--acct :: MonadIO m => Handle -> String -> m FTPResponse-acct h pass = sendCommandS h (Acct pass)--rename :: MonadIO m => Handle -> String -> String -> m FTPResponse-rename h from to = do-    res <- sendCommand h (Rnfr from)-    case frStatus res of-        Continue -> sendCommandS h (Rnto to)-        _ -> return res--dele :: MonadIO m => Handle -> String -> m FTPResponse-dele h file = sendCommandS h (Dele file)--cwd :: MonadIO m => Handle -> String -> m FTPResponse-cwd h dir =-    sendCommandS h $ if dir == ".."-        then Cdup-        else Cwd dir--size :: MonadIO m => Handle -> String -> m Int-size h file = do-    resp <- sendCommandS h (Size file)-    ensureCode resp 213-    return $ case frMessage resp of-        SingleLine message -> read . C.unpack $ message-        MultiLine _ -> 0--mkd :: MonadIO m => Handle -> String -> m String-mkd h dir = do-    resp <- sendCommandS h (Mkd dir)-    ensureCode resp 257-    parseResponse resp parse257--rmd :: MonadIO m => Handle -> String -> m FTPResponse-rmd h dir = sendCommandS h (Rmd dir)--pwd :: MonadIO m => Handle -> m String-pwd h = do-    resp <- sendCommandS h Pwd-    ensureCode resp 257-    parseResponse resp parse257--quit :: MonadIO m => Handle -> m FTPResponse-quit h = sendCommandS h Quit--mlst :: (MonadIO m, MonadMask m) => Handle -> String -> m MlsxResponse-mlst h path = do-    resp <- sendCommandS h (Mlst path)-    case frMessage resp of-        SingleLine message -> return $ parseMlsxLine message-        MultiLine messages -> if length messages >= 2-            then return $ parseMlsxLine $ messages !! 1-            else liftIO $ throwIO $ BogusResponseFormatException resp---- TLS commands--pbsz :: MonadIO m => Handle -> Int -> m FTPResponse-pbsz h = sendCommandS h . Pbsz--prot :: MonadIO m => Handle -> ProtType -> m FTPResponse-prot h = sendCommandS h . Prot--ccc :: MonadIO m => Handle -> m FTPResponse-ccc h = sendCommandS h Ccc--auth :: MonadIO m => Handle -> m FTPResponse-auth h = sendCommandS h Auth---- Data commands--sendType :: MonadIO m => RTypeCode -> ByteString -> Handle -> m ()-sendType TA dat h = mapM_ (sendCommandLine h) $ C.split '\n' dat-sendType TI dat h = liftIO $ send h dat--withDataCommandSecurity-    :: (MonadIO m, MonadMask m)-    => Handle-    -> PortActivity-    -> RTypeCode-    -> FTPCommand-    -> (Handle -> m a)-    -> m a-withDataCommandSecurity h =-    case security h of-        Clear -> withDataCommand h-        TLS -> withTLSDataCommand h--nlst :: (MonadIO m, MonadMask m) => Handle -> [String] -> m ByteString-nlst h args = withDataCommandSecurity h Passive TA (Nlst args) getAllLineResp--retr :: (MonadIO m, MonadMask m) => Handle -> String -> m ByteString-retr h path = withDataCommandSecurity h Passive TI (Retr path) recvAll--list :: (MonadIO m, MonadMask m) => Handle -> [String] -> m ByteString-list h args = withDataCommandSecurity h Passive TA (List args) getAllLineResp--stor-    :: (MonadIO m, MonadMask m)-    => Handle-    -> String-    -> B.ByteString-    -> RTypeCode-    -> m ()-stor h loc dat rtype =-    withDataCommandSecurity h Passive rtype (Stor loc) $ sendType rtype dat--data MlsxResponse = MlsxResponse {-    mrFilename :: String,-    mrFacts :: Map String String-} deriving (Show)--splitApart :: Char -> ByteString -> (ByteString, ByteString)-splitApart on s =-    let (x0, x1) = C.break (== on) s-    in (x0, C.drop 1 x1)--parseMlsxLine :: ByteString -> MlsxResponse-parseMlsxLine line =-    let (factLine, filename) = splitApart ' ' line-        bFacts = splitApart '=' <$> C.split ';' factLine-        facts-            = Map.fromList-            $ filter (not . null . fst)-            $ join (***) C.unpack <$> bFacts-    in MlsxResponse (C.unpack filename) facts--getMlsxResponse :: (MonadIO m, MonadCatch m) => Handle -> m [MlsxResponse]-getMlsxResponse h = getMlsxResponse' h []-    where-        getMlsxResponse' h ret = ( do-            line <- liftIO $ getLineResp h-            getMlsxResponse' h $-                if C.null line-                    then ret-                    else parseMlsxLine line : ret-            ) `M.catchIOError` (\_ -> return ret)--mlsd :: (MonadIO m, MonadMask m) => Handle -> String -> m [MlsxResponse]+{- |+Module      : Network.FTP.Client+Description : Transfer files over FTP and FTPS+Copyright   : Megan Robinson 2018-2019, Flipstone Technology Partners 2024-2026+License     : Public Domain+Stability   : experimental+Portability : POSIX+-}+module Network.FTP.Client+  ( -- * Main Entrypoints+    withFTP+  , withFTPS+  , withFTPSSettings++    -- * Control Commands+  , login+  , pasv+  , rename+  , dele+  , cwd+  , size+  , acct+  , mkd+  , rmd+  , pwd+  , quit++    -- * Data Commands+  , nlst+  , retr+  , list+  , stor+  , mlsd+  , mlst++    -- * Types+  , FTPCommand (..)+  , FTPResponse (..)+  , FTPMessage (..)+  , ResponseStatus (..)+  , MlsxResponse (..)+  , RTypeCode (..)+  , PortActivity (..)+  , ProtType (..)+  , Security (..)+  , TLSContext (..)+  , Handle (..)++    -- * TLS Commands+  , pbsz+  , prot++    -- * Exceptions+  , FTPException (..)++    -- * System Handle Creation+  , createSIOHandle+  , createTLSConnection+  , connectTLS++    -- * Handle Implementations+  , sIOHandleImpl+  , tlsHandleImpl++    -- * Lower Level Functions+  , sendCommand+  , sendCommandS+  , recvAll+  , sendAll+  , sendAllS+  , getLineResp+  , getAllLineResp+  , getLineRespMaybe+  , maxReplyLineLength+  , toNetworkAscii+  , requireTLSContext+  , getResponse+  , getResponseS+  , sendCommandLine+  , createSendDataCommand+  , createTLSSendDataCommand+  , PendingCompletion+  , newPendingCompletion+  , drainPendingCompletion+  , parseMlsxLine+  ) where++import Control.Arrow ((***))+import qualified Control.Exception as Exception+import Control.Monad ((<=<))+import qualified Control.Monad as Monad+import Control.Monad.Catch (MonadCatch, MonadMask)+import qualified Control.Monad.Catch as M+import qualified Control.Monad.IO.Class as MIO+import qualified Data.Attoparsec.ByteString.Char8 as AC+import qualified Data.Bits as Bits+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C+import Data.ByteString.Lazy.Internal (defaultChunkSize)+import Data.Default.Class (def)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.List (intercalate)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import qualified Network.Connection as Connection+import qualified Network.Socket as S+import qualified System.IO as SIO+import System.IO.Error (eofErrorType, isEOFError, mkIOError)++debugging :: Bool+debugging = False++debugPrint :: (Show a, MIO.MonadIO m) => a -> m ()+debugPrint s = Monad.when debugging (MIO.liftIO $ print s)++debugResponse :: (Show a, MIO.MonadIO m) => a -> m ()+debugResponse s = debugPrint $ "Recieved: " <> show s++{- | What a data connection needs in order to be protected the same way the+control connection is. The host is the one the control connection was opened+to, which is what the server's certificate is issued for -- deriving it from+the data socket instead names the local end and can never validate.+-}+data TLSContext = TLSContext+  { tlsContextSettings :: Connection.TLSSettings+  , tlsContextHost :: String+  , tlsContextPort :: Int+  }++-- Only TLS settings are threaded through the connection helpers today. If the+-- rest of the hardening lands -- ignoring the address in a PASV reply, a+-- timeout on the active-mode accept, a bound on data-channel line length --+-- those belong together with these as fields of one options record passed to+-- the with* functions, rather than as further positional parameters. That was+-- @qxjit's suggestion on https://github.com/flipstone/ftp-client/pull/1.++data Security = Clear | TLS TLSContext++-- | Can send and recieve a 'Data.ByteString.ByteString'.+data Handle = Handle+  { send :: ByteString -> IO ()+  , sendLine :: ByteString -> IO ()+  , recv :: Int -> IO ByteString+  , recvLine :: IO ByteString+  , security :: Security+  }++data FTPMessage = SingleLine ByteString | MultiLine [ByteString]+  deriving (Eq)++instance Show FTPMessage where+  show (SingleLine message) = C.unpack message+  show (MultiLine messages) = intercalate "\n" $ C.unpack <$> messages++-- | Response from an FTP command. ex "200 Welcome!"+data FTPResponse = FTPResponse+  { frStatus :: ResponseStatus+  -- ^ Interpretation of the first digit of an FTP response code+  , frCode :: Int+  -- ^ The three digit response code+  , frMessage :: FTPMessage+  -- ^ Text of the response+  }+  deriving (Eq)++instance Show FTPResponse where+  show fr = show (frCode fr) <> " " <> show (frMessage fr)++-- | First digit of an FTP response+data ResponseStatus+  = -- | 1+    Wait+  | -- | 2+    Success+  | -- | 3+    Continue+  | -- | 4+    FailureRetry+  | -- | 5+    Failure+  deriving (Show, Eq)++data FTPException+  = FailureRetryException FTPResponse+  | FailureException FTPResponse+  | UnsuccessfulException FTPResponse+  | BogusResponseFormatException FTPResponse+  | BadProtocolResponseException ByteString+  deriving (Show)++instance Exception.Exception FTPException++responseStatus :: ByteString -> ResponseStatus+responseStatus cbs =+  case C.uncons cbs of+    Just ('1', _) -> Wait+    Just ('2', _) -> Success+    Just ('3', _) -> Continue+    Just ('4', _) -> FailureRetry+    Just ('5', _) -> Failure+    _ -> Exception.throw $ BadProtocolResponseException cbs++data RTypeCode = TA | TI++serialzeRTypeCode :: RTypeCode -> String+serialzeRTypeCode TA = "A"+serialzeRTypeCode TI = "I"++data PortActivity = Active | Passive++data ProtType = P | C++-- | Commands according to the FTP specification+data FTPCommand+  = User String+  | Pass String+  | Acct String+  | RType RTypeCode+  | Retr String+  | Nlst [String]+  | Port S.HostAddress S.PortNumber+  | Stor String+  | List [String]+  | Rnfr String+  | Rnto String+  | Dele String+  | Size String+  | Mkd String+  | Rmd String+  | Pbsz Int+  | Prot ProtType+  | Mlsd String+  | Mlst String+  | Cwd String+  | Cdup+  | Ccc+  | Auth+  | Pwd+  | Abor+  | Pasv+  | Quit++instance Show FTPCommand where+  show = serializeCommand++formatPort :: S.HostAddress -> S.PortNumber -> String+formatPort ha pn =+  let+    (w1, w2, w3, w4) = S.hostAddressToTuple ha+    hn = show <$> [w1, w2, w3, w4]+    portParts = show <$> [pn `quot` 256, pn `mod` 256]+  in+    intercalate "," (hn <> portParts)++serializeCommand :: FTPCommand -> String+serializeCommand (User user) = "USER " <> user+serializeCommand (Pass pass) = "PASS " <> pass+serializeCommand (Acct account) = "ACCT " <> account+serializeCommand (RType rt) = "TYPE " <> serialzeRTypeCode rt+serializeCommand (Retr file) = "RETR " <> file+serializeCommand (Nlst []) = "NLST"+serializeCommand (Nlst args) = "NLST " <> unwords args+serializeCommand (Port ha pn) = "PORT " <> formatPort ha pn+serializeCommand (Stor loc) = "STOR " <> loc+serializeCommand (List []) = "LIST"+serializeCommand (List args) = "LIST " <> unwords args+serializeCommand (Rnfr from) = "RNFR " <> from+serializeCommand (Rnto to) = "RNTO " <> to+serializeCommand (Dele file) = "DELE " <> file+serializeCommand (Size file) = "SIZE " <> file+serializeCommand (Mkd dir) = "MKD " <> dir+serializeCommand (Rmd dir) = "RMD " <> dir+serializeCommand (Pbsz buf) = "PBSZ " <> show buf+serializeCommand (Prot P) = "PROT P"+serializeCommand (Prot C) = "PROT C"+serializeCommand (Mlsd path) = "MLSD " <> path+serializeCommand (Mlst path) = "MLST " <> path+serializeCommand (Cwd dir) = "CWD " <> dir+serializeCommand Cdup = "CDUP"+serializeCommand Ccc = "CCC"+serializeCommand Auth = "AUTH TLS"+serializeCommand Pwd = "PWD"+serializeCommand Abor = "ABOR"+serializeCommand Pasv = "PASV"+serializeCommand Quit = "QUIT"++{- | Cap on one reply line. RFC 959 replies are short; this exists so a server+that never sends a newline cannot make us buffer without limit. It applies to+both control connections: 'Connection.connectionGetLine' takes it directly, and+'hGetLineBounded' applies it to a clear handle. Exceeding it raises+'Connection.LineTooLong', which is not an 'IOError' and so is not swallowed by+the end-of-input handling elsewhere in this module.+-}+maxReplyLineLength :: Int+maxReplyLineLength = 65536++{- | 'C.hGetLine' with a bound, for handles that 'Network.Connection' is not+managing. Reads a byte at a time rather than in chunks because 'recv' shares+the handle: anything taken past the newline would be stolen from the data the+caller asks for next. The handle is buffered, so this is not a syscall per+byte, and reply lines are short.++End of input is reported the way 'C.hGetLine' reports it, because+'getLineRespMaybe' relies on the distinction: throw when nothing has been read+yet, hand back the partial line when something has.+-}+hGetLineBounded :: Int -> SIO.Handle -> IO ByteString+hGetLineBounded limit h =+  let+    collect :: Int -> [ByteString] -> IO ByteString+    collect remaining acc+      | remaining <= 0 = Exception.throwIO Connection.LineTooLong+      | otherwise = do+          byte <- B.hGet h 1+          if B.null byte+            then+              if null acc+                then+                  Exception.throwIO $+                    mkIOError eofErrorType "hGetLineBounded" (Just h) Nothing+                else return $ B.concat (reverse acc)+            else+              if byte == C.singleton '\n'+                then return $ B.concat (reverse acc)+                else collect (remaining - 1) (byte : acc)+  in+    collect limit []++stripCLRF :: ByteString -> ByteString+stripCLRF = C.takeWhile $ (&&) <$> (/= '\r') <*> (/= '\n')++-- | Get a line from the server+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 :: MIO.MonadIO m => Handle -> m FTPResponse+getResponse h = do+  line <- MIO.liftIO $ getLineResp h+  let+    (code, rest) = C.splitAt 3 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.+  Monad.when (C.length code < 3 || not (C.all AC.isDigit code)) $+    MIO.liftIO $+      Exception.throwIO $+        BadProtocolResponseException line+  message <- case C.uncons rest of+    Just ('-', _) -> MultiLine <$> loopMultiLine h code [line]+    _ -> return $ SingleLine line+  let+    codeDroppedMessage = case message of+      SingleLine singleMessage -> SingleLine $ C.drop 4 singleMessage+      MultiLine [] -> MultiLine []+      MultiLine (firstMessage : messages) ->+        MultiLine $ C.drop 4 firstMessage : messages+  let+    response =+      FTPResponse+        (responseStatus code)+        (read $ C.unpack code)+        codeDroppedMessage+  case frStatus response of+    FailureRetry -> MIO.liftIO $ Exception.throwIO $ FailureRetryException response+    Failure -> MIO.liftIO $ Exception.throwIO $ FailureException response+    _ -> return response++loopMultiLine ::+  MIO.MonadIO m =>+  Handle ->+  ByteString ->+  [ByteString] ->+  m [ByteString]+loopMultiLine h code priorLines = do+  mNextLine <- MIO.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 ->+      MIO.liftIO $+        Exception.throwIO $+          BadProtocolResponseException $+            C.intercalate "\n" priorLines+    Just nextLine -> do+      -- RFC 959 (https://datatracker.ietf.org/doc/html/rfc959#page-36) ends a+      -- multiline reply with the code followed by a space, and continues it+      -- with the code followed by a hyphen. The bare code is accepted too,+      -- for servers that omit the trailing space on an empty final line.+      let+        newLines = priorLines <> [C.dropWhile (== ' ') nextLine]+        isLastLine =+          nextLine == code+            || C.isPrefixOf (code <> " ") nextLine+      if isLastLine+        then return newLines+        else loopMultiLine h code newLines++ensureSuccess :: MIO.MonadIO m => FTPResponse -> m FTPResponse+ensureSuccess resp =+  case frStatus resp of+    Success -> return resp+    _ -> MIO.liftIO $ Exception.throwIO $ UnsuccessfulException resp++getResponseS :: MIO.MonadIO m => Handle -> m FTPResponse+getResponseS = ensureSuccess <=< getResponse++sendCommandLine :: MIO.MonadIO m => Handle -> ByteString -> m ()+sendCommandLine h = MIO.liftIO . send h . (<> "\r\n")++{- | Send a command to the server and get a response back.+Some commands use a data 'Handle', and their data is not returned here.+-}+sendCommand :: MIO.MonadIO m => Handle -> FTPCommand -> m FTPResponse+sendCommand h fc = do+  let+    command = serializeCommand fc+  debugPrint $ "Sending: " <> command+  sendCommandLine h $ C.pack command+  resp <- getResponse h+  debugResponse resp+  return resp++sendCommandS :: MIO.MonadIO m => Handle -> FTPCommand -> m FTPResponse+sendCommandS h fc = sendCommand h fc >>= ensureSuccess++{- | Equvalent to++> mapM . sendCommand+-}+sendAll :: MIO.MonadIO m => Handle -> [FTPCommand] -> m [FTPResponse]+sendAll = mapM . sendCommand++{- | Equvalent to++> mapM . sendCommandS+-}+sendAllS :: MIO.MonadIO m => Handle -> [FTPCommand] -> m [FTPResponse]+sendAllS = mapM . sendCommandS++-- Control connection++createSocket ::+  MIO.MonadIO m =>+  Maybe String ->+  Int ->+  S.AddrInfo ->+  m (S.Socket, S.AddrInfo)+createSocket host portNum hints = do+  addr <- MIO.liftIO $ do+    a : _ <- S.getAddrInfo (Just hints) host (Just $ show portNum)+    return a+  debugPrint $ "Addr: " <> show addr+  sock <-+    MIO.liftIO $+      S.socket+        (S.addrFamily addr)+        (S.addrSocketType addr)+        (S.addrProtocol addr)+  return (sock, addr)++withSocketPassive ::+  (MIO.MonadIO m, MonadMask m) =>+  String ->+  Int ->+  (S.Socket -> m a) ->+  m a+withSocketPassive host portNum f = do+  let+    hints =+      S.defaultHints+        { S.addrSocketType = S.Stream+        }+  -- bracketOnError, not bracket: on success this socket is handed to+  -- socketToHandle, which takes ownership of the descriptor, so closing it here+  -- as well would be wrong. Contrast withSocketActive above.+  M.bracketOnError+    (createSocket (Just host) portNum hints)+    (MIO.liftIO . S.close . fst)+    ( \(sock, addr) -> do+        debugPrint ("Connecting" :: String)+        MIO.liftIO $ S.connect sock (S.addrAddress addr)+        debugPrint ("Connected" :: String)+        f sock+    )++withSocketActive :: (MIO.MonadIO m, MonadMask m) => (S.Socket -> m a) -> m a+withSocketActive f = do+  let+    hints =+      S.defaultHints+        { S.addrSocketType = S.Stream+        , S.addrFlags = [S.AI_PASSIVE]+        }+  -- bracket, not bracketOnError: in active mode acceptData returns a *new*+  -- socket and only that one is converted to a Handle, so ownership of this+  -- listening socket is never transferred and it must be closed on the success+  -- path too. The passive helper below is the opposite case and deliberately+  -- differs.+  M.bracket+    (createSocket Nothing 0 hints)+    (MIO.liftIO . S.close . fst)+    ( \(sock, addr) -> do+        debugPrint ("Binding" :: String)+        MIO.liftIO $ S.bind sock (S.addrAddress addr)+        MIO.liftIO $ S.listen sock 1+        debugPrint ("Listening" :: String)+        f sock+    )++createSIOHandle :: (MIO.MonadIO m, MonadMask m) => String -> Int -> m SIO.Handle+createSIOHandle host portNum =+  withSocketPassive host portNum $+    MIO.liftIO . flip S.socketToHandle SIO.ReadWriteMode++sIOHandleImpl :: SIO.Handle -> Handle+sIOHandleImpl h =+  Handle+    { send = C.hPut h+    , -- RFC 959 TYPE A data uses CRLF, not a bare LF+      sendLine = \s -> C.hPut h (s <> "\r\n")+    , recv = C.hGetSome h+    , recvLine = hGetLineBounded maxReplyLineLength h+    , security = Clear+    }++withSIOHandle ::+  (MIO.MonadIO m, MonadMask m) =>+  String ->+  Int ->+  (Handle -> m a) ->+  m a+withSIOHandle host portNum f =+  M.bracket+    (MIO.liftIO $ createSIOHandle host portNum)+    (MIO.liftIO . SIO.hClose)+    (f . sIOHandleImpl)++{- | Takes a host name and port. A handle for interacting with the server+will be returned in a callback.++@+withFTP "ftp.server.com" 21 $ \h welcome -> do+    print welcome+    login h "username" "password"+    print =<< nlst h []+@+-}+withFTP ::+  (MIO.MonadIO m, MonadMask m) =>+  String ->+  Int ->+  (Handle -> FTPResponse -> m a) ->+  m a+withFTP host portNum f = withSIOHandle host portNum $ \h -> do+  resp <- getResponse h+  f h resp++-- Data connection++withDataSocketPasv ::+  (MIO.MonadIO m, MonadMask m) =>+  Handle ->+  (S.Socket -> m a) ->+  m a+withDataSocketPasv h f = do+  (host, portNum) <- pasv h+  debugPrint $ "Host: " <> host+  debugPrint $ "Port: " <> show portNum+  withSocketPassive host portNum f++withDataSocketActive ::+  (MIO.MonadIO m, MonadMask m) =>+  Handle ->+  (S.Socket -> m a) ->+  m a+withDataSocketActive h f = withSocketActive $ \socket -> do+  (sPort, sHost) <- MIO.liftIO $ do+    (S.SockAddrInet p hostAddr) <- S.getSocketName socket+    return (p, hostAddr)+  _ <- port h sHost sPort+  f socket++-- | Open a socket that can be used for data transfers+withDataSocket ::+  (MIO.MonadIO m, MonadMask m) =>+  PortActivity ->+  Handle ->+  (S.Socket -> m a) ->+  m a+withDataSocket Active = withDataSocketActive+withDataSocket Passive = withDataSocketPasv++acceptData :: MIO.MonadIO m => PortActivity -> S.Socket -> m S.Socket+acceptData Passive = return+acceptData Active = return . fst <=< MIO.liftIO . S.accept++-- Response to data commands should be 150 but apparently+-- some servers will respond with 200 before 150 so just ignore it+ensureSucessfulData :: MIO.MonadIO m => Handle -> FTPResponse -> m ()+ensureSucessfulData h resp = do+  resp' <- case frStatus resp of+    Success -> do+      newResp <- getResponse h+      debugResponse newResp+      return newResp+    _ -> return resp+  MIO.liftIO $+    Monad.when (frStatus resp' /= Wait) $+      Exception.throwIO $+        UnsuccessfulException resp++{- | Send setup commands to the server and+create a data 'System.IO.Handle'+-}+createSendDataCommand ::+  (MIO.MonadIO m, MonadMask m) =>+  Handle ->+  PortActivity ->+  PendingCompletion ->+  FTPCommand ->+  m SIO.Handle+createSendDataCommand h pa pending cmd = withDataSocket pa h $ \socket -> do+  resp <- sendCommand h cmd+  ensureSucessfulData h resp+  -- Past this point the server has accepted the transfer, so a completion+  -- reply is owed to us however the rest of it goes.+  markCompletionPending pending+  acceptedSock <- acceptData pa socket+  MIO.liftIO $ S.socketToHandle acceptedSock SIO.ReadWriteMode++-- | Provides a data 'Handle' in a callback for a command+withDataCommand ::+  (MIO.MonadIO m, MonadMask m) =>+  Handle ->+  PortActivity ->+  RTypeCode ->+  FTPCommand ->+  (Handle -> m a) ->+  m a+withDataCommand ch pa code cmd f = do+  _ <- sendCommandS ch $ RType code+  pending <- newPendingCompletion+  x <-+    M.bracket+      (createSendDataCommand ch pa pending cmd)+      (MIO.liftIO . SIO.hClose)+      (f . sIOHandleImpl)+      `M.onException` drainPendingCompletion ch pending+  resp <- getResponse ch+  debugResponse resp+  return x++-- | Recieve data and interpret it linewise+getAllLineResp :: (MIO.MonadIO m, MonadCatch m) => Handle -> m ByteString+getAllLineResp h =+  let+    collect :: MIO.MonadIO n => [ByteString] -> n ByteString+    collect ret = do+      mLine <- MIO.liftIO $ getLineRespMaybe h+      case mLine of+        Nothing -> return $ C.intercalate (C.pack "\n") ret+        Just line -> collect (ret <> [line])+  in+    collect []++-- | Recieve all data and return it as a 'Data.ByteString.ByteString'+recvAll :: (MIO.MonadIO m, MonadCatch m) => Handle -> m ByteString+recvAll h =+  let+    collect :: (MIO.MonadIO n, MonadCatch n) => ByteString -> n ByteString+    collect bs =+      ( do+          -- No handler here on purpose. recv returns "" at end of data, so+          -- catching IOErrors would only turn a reset or timed-out connection+          -- into a short read that looks like a complete one.+          chunk <- MIO.liftIO $ recv h defaultChunkSize+          if C.null chunk+            then return bs+            else collect $ bs <> chunk+      )+  in+    collect ""++-- TLS connection++{- | Wrap an existing handle in TLS. The settings are supplied by the caller;+'def' validates the server's certificate chain and host name. Passing settings+with 'Connection.settingDisableCertificateValidation' set gives an encrypted+but unauthenticated connection, which any on-path attacker can read and rewrite.+-}+connectTLS ::+  MIO.MonadIO m =>+  Connection.TLSSettings ->+  SIO.Handle ->+  String ->+  Int ->+  m Connection.Connection+connectTLS settings h host portNum = do+  context <- MIO.liftIO Connection.initConnectionContext+  let+    connectionParams =+      Connection.ConnectionParams+        { Connection.connectionHostname = host+        , Connection.connectionPort = toEnum . fromEnum $ portNum+        , Connection.connectionUseSecure = Just settings+        , Connection.connectionUseSocks = Nothing+        }+  MIO.liftIO $ Connection.connectFromHandle context h connectionParams++createTLSConnection ::+  (MIO.MonadIO m, MonadMask m) =>+  Connection.TLSSettings ->+  String ->+  Int ->+  m (FTPResponse, Connection.Connection)+createTLSConnection settings host portNum =+  -- Without this the socket leaks whenever the greeting is a refusal, AUTH TLS+  -- is rejected, or the handshake fails. This is the acquire action of+  -- withTLSHandle's bracket, so its release would never run.+  M.bracketOnError+    (createSIOHandle host portNum)+    (MIO.liftIO . SIO.hClose)+    ( \h -> do+        let+          insecureH = sIOHandleImpl h+        resp <- getResponse insecureH+        _ <- sendCommandS insecureH Auth+        conn <- connectTLS settings h host portNum+        return (resp, conn)+    )++tlsHandleImpl :: TLSContext -> Connection.Connection -> Handle+tlsHandleImpl tlsContext c =+  Handle+    { send = Connection.connectionPut c+    , -- RFC 959 TYPE A data uses CRLF, not a bare LF+      sendLine = Connection.connectionPut c . (<> "\r\n")+    , recv = Connection.connectionGet c+    , recvLine = Connection.connectionGetLine maxReplyLineLength c+    , security = TLS tlsContext+    }++withTLSHandle ::+  (MonadMask m, MIO.MonadIO m) =>+  Connection.TLSSettings ->+  String ->+  Int ->+  (Handle -> FTPResponse -> m a) ->+  m a+withTLSHandle settings host portNum f =+  let+    tlsContext =+      TLSContext+        { tlsContextSettings = settings+        , tlsContextHost = host+        , tlsContextPort = portNum+        }+  in+    M.bracket+      (createTLSConnection settings host portNum)+      (MIO.liftIO . Connection.connectionClose . snd)+      (\(resp, conn) -> f (tlsHandleImpl tlsContext conn) resp)++{- | Takes a host name and port. A handle for interacting with the server+will be returned in a callback. The connection is protected with TLS and the+server's certificate chain and host name are verified, so a failure to validate+aborts the connection.++@+withFTPS "ftps.server.com" 21 $ \h welcome -> do+    print welcome+    login h "username" "password"+    print =<< nlst h []+@++Use 'withFTPSSettings' if you need to talk to a server whose certificate cannot+be validated.+-}+withFTPS ::+  (MonadMask m, MIO.MonadIO m) =>+  String ->+  Int ->+  (Handle -> FTPResponse -> m a) ->+  m a+withFTPS = withTLSHandle def++{- | As 'withFTPS', but with caller supplied TLS settings.++Setting 'Connection.settingDisableCertificateValidation' accepts any+certificate, including one an attacker generated. The connection is then+encrypted but not authenticated: anyone on the network path can read the+credentials sent by 'login' and alter transferred data. Only do this when you+have another way to establish that the peer is who it claims to be.++@+let insecure = 'def' { 'Connection.settingDisableCertificateValidation' = True }+withFTPSSettings insecure "ftps.server.com" 21 $ \h welcome -> do+    print welcome+@+-}+withFTPSSettings ::+  (MonadMask m, MIO.MonadIO m) =>+  Connection.TLSSettings ->+  String ->+  Int ->+  (Handle -> FTPResponse -> m a) ->+  m a+withFTPSSettings = withTLSHandle++-- TLS data connection++{- | The TLS details of a control connection, for reproducing them on a data+connection.+-}+requireTLSContext :: MIO.MonadIO m => Handle -> m TLSContext+requireTLSContext h =+  case security h of+    TLS ctx -> return ctx+    Clear ->+      MIO.liftIO . Exception.throwIO . BadProtocolResponseException $+        C.pack "cannot open a TLS data connection over a clear control connection"++{- | Read the reply that terminates a data transfer, discarding any failure.++Used on the paths where the transfer did not complete normally. The reply still+has to be taken off the control connection: left there it becomes the answer to+whichever command is sent next, and every reply after that belongs to the+previous command for the rest of the session. Failures are swallowed so this+cannot mask the exception that brought us here.+-}+drainDataResponse :: (MIO.MonadIO m, MonadCatch m) => Handle -> m ()+drainDataResponse ch =+  Monad.void (getResponse ch) `M.catchAll` (\_ -> return ())++{- | Whether the server has accepted the preliminary reply to a transfer+command, and so whether a completion reply is on its way.++A transfer that is rejected outright -- @PBSZ@, @PROT@, @PASV@ or the transfer+command itself -- fails with its error reply already consumed by+'ensureSucessfulData', and nothing further is coming. Draining then waits for a+reply the server will never send, which blocks until it gives up on the+connection. Draining is only correct once this says a reply is pending.+-}+newtype PendingCompletion = PendingCompletion (IORef Bool)++newPendingCompletion :: MIO.MonadIO m => m PendingCompletion+newPendingCompletion =+  MIO.liftIO $ PendingCompletion <$> newIORef False++markCompletionPending :: MIO.MonadIO m => PendingCompletion -> m ()+markCompletionPending (PendingCompletion ref) =+  MIO.liftIO $ writeIORef ref True++{- | 'drainDataResponse', but only when a completion reply is actually pending.++This deliberately stays outside the bracket that owns the data connection. The+server sends the completion reply once that connection has closed, so draining+before the release action has run would block on a reply that is waiting on us.+-}+drainPendingCompletion ::+  (MIO.MonadIO m, MonadCatch m) =>+  Handle ->+  PendingCompletion ->+  m ()+drainPendingCompletion ch (PendingCompletion ref) = do+  pending <- MIO.liftIO $ readIORef ref+  Monad.when pending $ drainDataResponse ch++{- | Send setup commands to the server and+create a data TLS connection+-}+createTLSSendDataCommand ::+  (MIO.MonadIO m, MonadMask m) =>+  Handle ->+  PortActivity ->+  PendingCompletion ->+  FTPCommand ->+  m Connection.Connection+createTLSSendDataCommand ch pa pending cmd = do+  tlsContext <- requireTLSContext ch+  _ <- sendAllS ch [Pbsz 0, Prot P]+  withDataSocket pa ch $ \socket -> do+    resp <- sendCommand ch cmd+    ensureSucessfulData ch resp+    -- Past this point the server has accepted the transfer, so a completion+    -- reply is owed to us however the rest of it goes -- a rejected+    -- certificate in the handshake below included.+    markCompletionPending pending+    acceptedSock <- acceptData pa socket+    -- socketToHandle invalidates the socket, so the enclosing bracketOnError's+    -- close becomes a no-op from here on; protect the handle separately or a+    -- failed handshake leaks the descriptor.+    M.bracketOnError+      (MIO.liftIO $ S.socketToHandle acceptedSock SIO.ReadWriteMode)+      (MIO.liftIO . SIO.hClose)+      ( \h ->+          -- Authenticate against the host the control connection was opened to.+          -- getSocketName here would name the local end of the data socket,+          -- which no server certificate can ever match.+          MIO.liftIO $+            connectTLS+              (tlsContextSettings tlsContext)+              h+              (tlsContextHost tlsContext)+              (tlsContextPort tlsContext)+      )++withTLSDataCommand ::+  (MIO.MonadIO m, MonadMask m) =>+  Handle ->+  PortActivity ->+  RTypeCode ->+  FTPCommand ->+  (Handle -> m a) ->+  m a+withTLSDataCommand ch pa code cmd f = do+  tlsContext <- requireTLSContext ch+  _ <- sendCommandS ch $ RType code+  pending <- newPendingCompletion+  x <-+    M.bracket+      (createTLSSendDataCommand ch pa pending cmd)+      (MIO.liftIO . Connection.connectionClose)+      (f . tlsHandleImpl tlsContext)+      `M.onException` drainPendingCompletion ch pending+  resp <- getResponse ch+  debugPrint $ "Recieved: " <> show resp+  return x++parseResponse :: MIO.MonadIO m => FTPResponse -> AC.Parser a -> m a+parseResponse resp p =+  let+    parsableMessage = case frMessage resp of+      SingleLine message -> message+      MultiLine messages -> C.intercalate "\n" messages+  in+    case AC.parseOnly p parsableMessage of+      Right x -> return x+      Left _ ->+        MIO.liftIO $+          Exception.throwIO $+            BadProtocolResponseException parsableMessage++ensureCode :: MIO.MonadIO m => FTPResponse -> Int -> m ()+ensureCode resp code =+  MIO.liftIO $+    Monad.when (frCode resp /= code) $+      MIO.liftIO $+        Exception.throwIO $+          UnsuccessfulException resp++parse227 :: AC.Parser (String, Int)+parse227 = do+  _ <- AC.skipWhile (/= '(') *> AC.char '('+  [h1, h2, h3, h4, p1, p2] <- AC.many1 AC.digit `AC.sepBy` AC.char ','+  let+    host = intercalate "." [h1, h2, h3, h4]+    highBits = read p1+    lowBits = read p2+    portNum = (highBits `Bits.shift` 8) + lowBits+  return (host, portNum)++parse257 :: AC.Parser String+parse257 = do+  _ <- AC.char '"'+  C.unpack <$> AC.takeTill (== '"')++-- Control commands++login :: MIO.MonadIO m => Handle -> String -> String -> m FTPResponse+login h user pass = do+  resp <- last <$> sendAll h [User user, Pass pass]+  ensureSuccess resp++pasv :: MIO.MonadIO m => Handle -> m (String, Int)+pasv h = do+  resp <- sendCommandS h Pasv+  ensureCode resp 227+  parseResponse resp parse227++port :: MIO.MonadIO m => Handle -> S.HostAddress -> S.PortNumber -> m FTPResponse+port h ha pn = sendCommandS h (Port ha pn)++acct :: MIO.MonadIO m => Handle -> String -> m FTPResponse+acct h pass = sendCommandS h (Acct pass)++rename :: MIO.MonadIO m => Handle -> String -> String -> m FTPResponse+rename h from to = do+  res <- sendCommand h (Rnfr from)+  case frStatus res of+    Continue -> sendCommandS h (Rnto to)+    _ -> return res++dele :: MIO.MonadIO m => Handle -> String -> m FTPResponse+dele h file = sendCommandS h (Dele file)++cwd :: MIO.MonadIO m => Handle -> String -> m FTPResponse+cwd h dir =+  sendCommandS h $+    if dir == ".."+      then Cdup+      else Cwd dir++size :: MIO.MonadIO m => Handle -> String -> m Int+size h file = do+  resp <- sendCommandS h (Size file)+  ensureCode resp 213+  return $ case frMessage resp of+    SingleLine message -> read . C.unpack $ message+    MultiLine _ -> 0++mkd :: MIO.MonadIO m => Handle -> String -> m String+mkd h dir = do+  resp <- sendCommandS h (Mkd dir)+  ensureCode resp 257+  parseResponse resp parse257++rmd :: MIO.MonadIO m => Handle -> String -> m FTPResponse+rmd h dir = sendCommandS h (Rmd dir)++pwd :: MIO.MonadIO m => Handle -> m String+pwd h = do+  resp <- sendCommandS h Pwd+  ensureCode resp 257+  parseResponse resp parse257++quit :: MIO.MonadIO m => Handle -> m FTPResponse+quit h = sendCommandS h Quit++mlst :: (MIO.MonadIO m, MonadMask m) => Handle -> String -> m MlsxResponse+mlst h path = do+  resp <- sendCommandS h (Mlst path)+  case frMessage resp of+    SingleLine message -> return $ parseMlsxLine message+    MultiLine messages ->+      if length messages >= 2+        then return $ parseMlsxLine $ messages !! 1+        else MIO.liftIO $ Exception.throwIO $ BogusResponseFormatException resp++-- TLS commands++pbsz :: MIO.MonadIO m => Handle -> Int -> m FTPResponse+pbsz h = sendCommandS h . Pbsz++prot :: MIO.MonadIO m => Handle -> ProtType -> m FTPResponse+prot h = sendCommandS h . Prot++-- CCC and AUTH deliberately have no wrappers. CCC tells the server to drop to+-- cleartext, but there is no way to downgrade our side of a+-- crypton-connection, so the control connection would desynchronise and+-- 'security' could not be corrected to match. AUTH on its own tells the server+-- to expect a handshake that never happens; 'createTLSConnection' is the only+-- sequence that issues it correctly. Both remain reachable as 'FTPCommand'+-- constructors for anyone who needs to drive them by hand.++-- Data commands++{- | Rewrite line endings for a TYPE A transfer. RFC 959 specifies NVT-ASCII,+whose terminator is CRLF. Input already using CRLF is left alone rather than+having its CR doubled, and input with no final terminator does not gain one.+-}+toNetworkAscii :: ByteString -> ByteString+toNetworkAscii =+  let+    dropTrailingCR piece =+      if not (C.null piece) && C.last piece == '\r'+        then C.init piece+        else piece+  in+    C.intercalate (C.pack "\r\n") . fmap dropTrailingCR . C.split '\n'++sendType :: MIO.MonadIO m => RTypeCode -> ByteString -> Handle -> m ()+sendType TA dat h = MIO.liftIO . send h $ toNetworkAscii dat+sendType TI dat h = MIO.liftIO $ send h dat++withDataCommandSecurity ::+  (MIO.MonadIO m, MonadMask m) =>+  Handle ->+  PortActivity ->+  RTypeCode ->+  FTPCommand ->+  (Handle -> m a) ->+  m a+withDataCommandSecurity h =+  case security h of+    Clear -> withDataCommand h+    TLS _ -> withTLSDataCommand h++nlst :: (MIO.MonadIO m, MonadMask m) => Handle -> [String] -> m ByteString+nlst h args = withDataCommandSecurity h Passive TA (Nlst args) getAllLineResp++retr :: (MIO.MonadIO m, MonadMask m) => Handle -> String -> m ByteString+retr h path = withDataCommandSecurity h Passive TI (Retr path) recvAll++list :: (MIO.MonadIO m, MonadMask m) => Handle -> [String] -> m ByteString+list h args = withDataCommandSecurity h Passive TA (List args) getAllLineResp++stor ::+  (MIO.MonadIO m, MonadMask m) =>+  Handle ->+  String ->+  B.ByteString ->+  RTypeCode ->+  m ()+stor h loc dat rtype =+  withDataCommandSecurity h Passive rtype (Stor loc) $ sendType rtype dat++data MlsxResponse = MlsxResponse+  { mrFilename :: String+  , mrFacts :: Map String String+  }+  deriving (Show)++splitApart :: Char -> ByteString -> (ByteString, ByteString)+splitApart on s =+  let+    (x0, x1) = C.break (== on) s+  in+    (x0, C.drop 1 x1)++parseMlsxLine :: ByteString -> MlsxResponse+parseMlsxLine line =+  let+    (factLine, filename) = splitApart ' ' line+    bFacts = splitApart '=' <$> C.split ';' factLine+    facts =+      Map.fromList $+        filter (not . null . fst) $+          Monad.join (***) C.unpack <$> bFacts+  in+    MlsxResponse (C.unpack filename) facts++getMlsxResponse :: (MIO.MonadIO m, MonadCatch m) => Handle -> m [MlsxResponse]+getMlsxResponse h =+  let+    collect :: MIO.MonadIO n => [MlsxResponse] -> n [MlsxResponse]+    collect ret = do+      mLine <- MIO.liftIO $ getLineRespMaybe h+      case mLine of+        Nothing -> return ret+        Just line ->+          collect $+            if C.null line+              then ret+              else parseMlsxLine line : ret+  in+    collect []++mlsd :: (MIO.MonadIO m, MonadMask m) => Handle -> String -> m [MlsxResponse] mlsd h path = withDataCommandSecurity h Passive TA (Mlsd path) getMlsxResponse

@@ -1,74 +1,294 @@+module Main (main) where++import Control.Concurrent.MVar+import qualified Control.Exception as Exception import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C-import Test.Hspec+import qualified Network.Connection as Connection import Network.FTP.Client hiding (Success) import qualified Network.FTP.Client as F-import Control.Monad.IO.Class-import Control.Concurrent.MVar+import qualified System.Directory as Directory+import qualified System.IO as SIO+import System.IO.Error (eofErrorType, fullErrorType, isFullError, mkIOError)+import Test.Hspec  data TestHandleMVars = TestHandleMVars-    { thmSend :: MVar [ByteString]-    , thmSendLine :: MVar [ByteString]-    , thmRecv :: MVar [Int]-    }+  { thmSend :: MVar [ByteString]+  , _thmSendLine :: MVar [ByteString]+  , _thmRecv :: MVar [Int]+  }  data TestHandle = TestHandle TestHandleMVars Handle -testHandle-    :: [ByteString]-    -> [ByteString]-    -> Security-    -> IO TestHandle+testHandle ::+  [ByteString] ->+  [ByteString] ->+  Security ->+  IO TestHandle testHandle recvResps recvLineResps sec = do-    sendMVar <- newMVar []-    sendLineMVar <- newMVar []-    recvMVar <- newMVar []-    recvCount <- newMVar 0-    recvLineCount <- newMVar 0-    let testHandleMVars = TestHandleMVars-            sendMVar sendLineMVar recvMVar-        handle = Handle-            { send = \s ->-                modifyMVar_ sendMVar-                    (\ss -> return $ ss <> [s])-            , sendLine = \s ->-                modifyMVar_ sendLineMVar-                    (\ss -> return $ ss <> [s])-            , 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))-            , security = sec-            }-    return $ TestHandle testHandleMVars handle+  sendMVar <- newMVar []+  sendLineMVar <- newMVar []+  recvMVar <- newMVar []+  recvCount <- newMVar 0+  recvLineCount <- newMVar 0+  let+    testHandleMVars =+      TestHandleMVars+        sendMVar+        sendLineMVar+        recvMVar+    handle =+      Handle+        { send = \s ->+            modifyMVar_+              sendMVar+              (\ss -> return $ ss <> [s])+        , sendLine = \s ->+            modifyMVar_+              sendLineMVar+              (\ss -> return $ ss <> [s])+        , recv = \i -> do+            modifyMVar_+              recvMVar+              (\is -> return $ is <> [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++{- | A handle whose reads fail the way a reset connection does, rather than the+way end of input does. The two must not be conflated: end of input is a+complete transfer, a reset is a truncated one.+-}+failingHandle :: Security -> IO Handle+failingHandle sec = do+  (TestHandle _ h) <- testHandle [] [] sec+  return+    h+      { recv = \_ -> ioError brokenConnection+      , recvLine = ioError brokenConnection+      }++brokenConnection :: IOError+brokenConnection = mkIOError fullErrorType "connection reset" Nothing Nothing+ main :: IO () main = hspec $ do-    describe "Network.FTP.Client.sendCommand" $ do-        it "sends USER for User" $ do-            let expected = FTPResponse-                    F.Success 200-                    (SingleLine $ C.pack "Ok")-            (TestHandle mvars h) <- testHandle [] [C.pack "200 Ok"] Clear-            sendCommand h (User "megan") `shouldReturn` expected-            takeMVar (thmSend mvars) `shouldReturn` [C.pack "USER megan\r\n"]-        it "sends USER for User and receives a multiline response" $ do-            let expected = FTPResponse-                    F.Success 200-                    (MultiLine [C.pack "line1", C.pack "line2", C.pack "200 line3"])-            (TestHandle mvars h) <- testHandle []-                [ C.pack "200-line1\r\n"-                , C.pack "line2\r\n"-                , C.pack "200 line3\r\n"-                ] Clear-            sendCommand h (User "megan") `shouldReturn` expected-            takeMVar (thmSend mvars) `shouldReturn` [C.pack "USER megan\r\n"]-    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+  describe "Network.FTP.Client.sendCommand" $ do+    it "sends USER for User" $ do+      let+        expected =+          FTPResponse+            F.Success+            200+            (SingleLine $ C.pack "Ok")+      (TestHandle mvars h) <- testHandle [] [C.pack "200 Ok"] Clear+      sendCommand h (User "megan") `shouldReturn` expected+      takeMVar (thmSend mvars) `shouldReturn` [C.pack "USER megan\r\n"]+    it "sends USER for User and receives a multiline response" $ do+      let+        expected =+          FTPResponse+            F.Success+            200+            (MultiLine [C.pack "line1", C.pack "line2", C.pack "200 line3"])+      (TestHandle mvars h) <-+        testHandle+          []+          [ C.pack "200-line1\r\n"+          , C.pack "line2\r\n"+          , C.pack "200 line3\r\n"+          ]+          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 "keeps reading continuation lines that repeat the code" $ do+      let+        expected =+          FTPResponse+            F.Success+            220+            ( MultiLine+                [ C.pack "First Line"+                , C.pack "220-Second Line"+                , C.pack "220 Third Line"+                ]+            )+      (TestHandle _ h) <-+        testHandle+          []+          [ C.pack "220-First Line\r\n"+          , C.pack "220-Second Line\r\n"+          , C.pack "220 Third Line\r\n"+          ]+          Clear+      getResponse h `shouldReturn` expected+    it "ends a multiline response on a bare code" $ do+      let+        expected =+          FTPResponse+            F.Success+            220+            (MultiLine [C.pack "First Line", C.pack "220"])+      (TestHandle _ h) <-+        testHandle+          []+          [ C.pack "220-First Line\r\n"+          , C.pack "220\r\n"+          ]+          Clear+      getResponse h `shouldReturn` expected+    it "does not end a multiline response on a different code" $ do+      let+        expected =+          FTPResponse+            F.Success+            220+            ( MultiLine+                [ C.pack "First Line"+                , C.pack "331 Not the terminator"+                , C.pack "220 Done"+                ]+            )+      (TestHandle _ h) <-+        testHandle+          []+          [ C.pack "220-First Line\r\n"+          , C.pack "331 Not the terminator\r\n"+          , C.pack "220 Done\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" $ do+    it "doesn't hang on empty response" $ do+      let+        expected = C.pack ""+      (TestHandle _ h) <- testHandle [C.pack ""] [] Clear+      recvAll h `shouldReturn` expected+    it "reports a broken connection instead of a short read" $ do+      -- A failure part way through a transfer used to be turned into a clean+      -- end of data, so a truncated download could not be told apart from a+      -- complete one.+      h <- failingHandle Clear+      recvAll h `shouldThrow` isFullError+  describe "Network.FTP.Client.getAllLineResp" $+    it "reports a broken connection instead of a truncated listing" $ do+      h <- failingHandle Clear+      getAllLineResp h `shouldThrow` isFullError+  describe "Network.FTP.Client.sIOHandleImpl" $ do+    it "reads reply lines from a clear handle" $+      withBytesHandle (C.pack "220 Welcome\r\n331 Password\r\n") $ \h -> do+        getLineResp h `shouldReturn` C.pack "220 Welcome"+        getLineResp h `shouldReturn` C.pack "331 Password"+    it "hands back a final line the server never terminated" $+      -- Matches hGetLine, which this replaces: bytes did arrive, so they are+      -- the line, and end of input is reported on the read after it.+      withBytesHandle (C.pack "220 Welcome") $ \h -> do+        getLineResp h `shouldReturn` C.pack "220 Welcome"+        getLineRespMaybe h `shouldReturn` Nothing+    it "signals end of input once the stream is exhausted" $+      withBytesHandle (C.pack "220 Welcome\r\n") $ \h -> do+        _ <- getLineResp h+        getLineRespMaybe h `shouldReturn` Nothing+    it "refuses a reply line that exceeds the cap" $+      -- A server that never sends a newline must not be able to make us+      -- buffer without limit before we have even authenticated.+      withBytesHandle (C.replicate (maxReplyLineLength + 1) 'x') $ \h ->+        getLineResp h `shouldThrow` isLineTooLong+  describe "Network.FTP.Client.toNetworkAscii" $ do+    it "terminates LF input with CRLF" $+      toNetworkAscii (C.pack "a\nb\n") `shouldBe` C.pack "a\r\nb\r\n"+    it "leaves CRLF input unchanged rather than doubling the CR" $+      toNetworkAscii (C.pack "a\r\nb\r\n") `shouldBe` C.pack "a\r\nb\r\n"+    it "does not append a terminator the input did not have" $+      toNetworkAscii (C.pack "a\nb") `shouldBe` C.pack "a\r\nb"++{- | A real 'SIO.Handle' over fixed bytes. 'sIOHandleImpl' needs one, so the+scripted 'Handle' above cannot reach it.+-}+withBytesHandle :: ByteString -> (Handle -> IO a) -> IO a+withBytesHandle bytes use = do+  tmp <- Directory.getTemporaryDirectory+  Exception.bracket+    (SIO.openBinaryTempFile tmp "ftp-client-test")+    (\(path, h) -> SIO.hClose h >> Directory.removeFile path)+    ( \(path, h) -> do+        C.hPut h bytes+        SIO.hClose h+        SIO.withBinaryFile path SIO.ReadMode (use . sIOHandleImpl)+    )++isLineTooLong :: Connection.LineTooLong -> Bool+isLineTooLong _ = True++isBadProtocolResponse :: FTPException -> Bool+isBadProtocolResponse e =+  case e of+    BadProtocolResponseException _ -> True+    _ -> False