ftp-client 0.4.0.1 → 0.5.0.0

raw patch · 3 files changed

+220/−116 lines, 3 filesdep −ftp-clientPVP ok

version bump matches the API change (PVP)

Dependencies removed: ftp-client

API changes (from Hackage documentation)

Files

• LICENSE +20/−26
• ftp-client.cabal +2/−3
• src/Network/FTP/Client.hs +198/−87

@@ -1,30 +1,24 @@-Copyright Author name here (c) 2016--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:+This is free and unencumbered software released into the public domain. -    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.+Anyone is free to copy, modify, publish, use, compile, sell, or+distribute this software, either in source code form or as a compiled+binary, for any purpose, commercial or non-commercial, and by any+means. -    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.+In jurisdictions that recognize copyright laws, the author or authors+of this software dedicate any and all copyright interest in the+software to the public domain. We make this dedication for the benefit+of the public at large and to the detriment of our heirs and+successors. We intend this dedication to be an overt act of+relinquishment in perpetuity of all present and future rights to this+software under copyright law. -    * Neither the name of Author name here nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+For more information, please refer to <http://unlicense.org/>

@@ -1,5 +1,5 @@ name: ftp-client-version: 0.4.0.1+version: 0.5.0.0 cabal-version: >=1.10 build-type: Simple license: PublicDomain@@ -38,8 +38,7 @@     type: exitcode-stdio-1.0     main-is: Spec.hs     build-depends:-        base >=4.9.1.0 && <4.10,-        ftp-client >=0.4.0.1 && <0.5+        base >=4.9.1.0 && <4.10     default-language: Haskell2010     hs-source-dirs: test     ghc-options: -threaded -rtsopts -with-rtsopts=-N

@@ -26,28 +26,34 @@     list,     stor,     mlsd,+    mlst,     -- * Types     FTPCommand(..),     FTPResponse(..),     ResponseStatus(..),-    MlsdResponse(..),+    MlsxResponse(..),     RTypeCode(..),     PortActivity(..),     ProtType(..),     Security(..),     Handle(..),+    -- * Exceptions+    FTPException(..),     -- * Handle Implementations     sIOHandleImpl,     tlsHandleImpl,     -- * Lower Level Functions     sendCommand,-    sendCommands,+    sendCommandS,+    sendAll,+    sendAllS,     getLineResp,-    getMultiLineResp,+    getResponse,+    getResponseS,     sendCommandLine,     createSendDataCommand,     createTLSSendDataCommand,-    parseMlsdLine+    parseMlsxLine ) where  import qualified Data.ByteString.Char8 as C@@ -72,11 +78,12 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Control.Arrow+import Data.Typeable  import Debug.Trace  debugging :: Bool-debugging = False+debugging = True  debugPrint :: (Show a, MonadIO m) => a -> m () debugPrint s = debugPrint' s debugging@@ -84,6 +91,9 @@         debugPrint' _ False = return ()         debugPrint' s True = 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'.@@ -95,15 +105,21 @@     , security :: Security     } +data FTPMessage = SingleLine ByteString | MultiLine [ByteString]++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 :: ByteString -- ^ Text of the response+    frMessage :: FTPMessage -- ^ Text of the response }  instance Show FTPResponse where-    show fr = (show $ frCode fr) <> " " <> (C.unpack $ frMessage fr)+    show fr = (show $ frCode fr) <> " " <> (show $ frMessage fr)  -- | First digit of an FTP response data ResponseStatus@@ -112,8 +128,18 @@     | Continue -- ^ 3     | FailureRetry -- ^ 4     | Failure -- ^ 5-    deriving (Show)+    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@@ -121,7 +147,8 @@         Just ('2', _) -> Success         Just ('3', _) -> Continue         Just ('4', _) -> FailureRetry-        _             -> Failure+        Just ('5', _) -> Failure+        _ -> throw $ BadProtocolResponseException cbs  data RTypeCode = TA | TI @@ -153,6 +180,7 @@     | Pbsz Int     | Prot ProtType     | Mlsd String+    | Mlst String     | Cwd String     | Cdup     | Ccc@@ -170,7 +198,7 @@     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)+    in intercalate "," (hn <> portParts)  serializeCommand :: FTPCommand -> String serializeCommand (User user)  = "USER " <> user@@ -194,6 +222,7 @@ 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"@@ -212,32 +241,50 @@  -- | Get a full response from the server -- Used in 'sendCommand'-getMultiLineResp :: MonadIO m => Handle -> m FTPResponse-getMultiLineResp h = do+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 loopMultiLine h code line-        else return line-    return $ FTPResponse-        (responseStatus code)-        (read $ C.unpack code)-        (C.drop 4 message)+        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 line = do+    -> [ByteString]+    -> m [ByteString]+loopMultiLine h code lines = do     nextLine <- liftIO $ getLineResp h-    let multiLine = line <> "\n" <> nextLine+    let newLines = lines <> [C.dropWhile (== ' ') nextLine]         nextCode = C.take 3 nextLine     if nextCode == code-        then return multiLine-        else loopMultiLine h nextCode multiLine+        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") @@ -248,19 +295,33 @@     let command = serializeCommand fc     debugPrint $ "Sending: " <> command     sendCommandLine h $ C.pack command-    resp <- getMultiLineResp h-    debugPrint $ "Recieved: " <> (show resp)+    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-sendCommands :: MonadIO m => Handle -> [FTPCommand] -> m [FTPResponse]-sendCommands = 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+    :: MonadIO m+    => Maybe String+    -> Int+    -> S.AddrInfo+    -> m (S.Socket, S.AddrInfo) createSocket host portNum hints = do     addr:_ <- liftIO $ S.getAddrInfo (Just hints) host (Just $ show portNum)     debugPrint $ "Addr: " <> show addr@@ -284,6 +345,7 @@         (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@@ -299,6 +361,7 @@         (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"@@ -345,7 +408,7 @@     -> (Handle -> FTPResponse -> m a)     -> m a withFTP host portNum f = withSIOHandle host portNum $ \h -> do-    resp <- getMultiLineResp h+    resp <- getResponse h     f h resp  -- Data connection@@ -385,16 +448,30 @@ 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]+    -> FTPCommand     -> m (SIO.Handle)-createSendDataCommand h pa cmds = withDataSocket pa h $ \socket -> do-    sendCommands h cmds+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 @@ -403,16 +480,18 @@     :: (MonadIO m, MonadMask m)     => Handle     -> PortActivity-    -> [FTPCommand]+    -> RTypeCode+    -> FTPCommand     -> (Handle -> m a)     -> m a-withDataCommand ch pa cmds f = do+withDataCommand ch pa code cmd f = do+    sendCommandS ch $ RType code     x <- M.bracket-        (createSendDataCommand ch pa cmds)+        (createSendDataCommand ch pa cmd)         (liftIO . SIO.hClose)         (f . sIOHandleImpl)-    resp <- getMultiLineResp ch-    debugPrint $ "Recieved: " <> (show resp)+    resp <- getResponse ch+    debugResponse resp     return x  -- | Recieve data and interpret it linewise@@ -459,7 +538,7 @@ createTLSConnection host portNum = do     h <- createSIOHandle host portNum     let insecureH = sIOHandleImpl h-    resp <- getMultiLineResp insecureH+    resp <- getResponse insecureH     sendCommand insecureH Auth     conn <- connectTLS h host portNum     return (resp, conn)@@ -509,12 +588,13 @@     :: (MonadIO m, MonadMask m)     => Handle     -> PortActivity-    -> [FTPCommand]+    -> FTPCommand     -> m Connection-createTLSSendDataCommand ch pa cmds = do-    sendCommands ch [Pbsz 0, Prot P]+createTLSSendDataCommand ch pa cmd = do+    sendAllS ch [Pbsz 0, Prot P]     withDataSocket pa ch $ \socket -> do-        sendCommands ch cmds+        resp <- sendCommand ch cmd+        ensureSucessfulData ch resp         acceptedSock <- acceptData pa socket         (S.SockAddrInet sPort sHost) <- liftIO $ S.getSocketName acceptedSock         let (h1, h2, h3, h4) = S.hostAddressToTuple sHost@@ -526,18 +606,35 @@     :: (MonadIO m, MonadMask m)     => Handle     -> PortActivity-    -> [FTPCommand]+    -> RTypeCode+    -> FTPCommand     -> (Handle -> m a)     -> m a-withTLSDataCommand ch pa cmds f = do+withTLSDataCommand ch pa code cmd f = do+    sendCommandS ch $ RType code     x <- M.bracket-        (createTLSSendDataCommand ch pa cmds)+        (createTLSSendDataCommand ch pa cmd)         (liftIO . connectionClose)         (f . tlsHandleImpl)-    resp <- getMultiLineResp ch+    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 '('@@ -556,72 +653,86 @@ -- Control commands  login :: MonadIO m => Handle -> String -> String -> m FTPResponse-login h user pass = last <$> sendCommands h [User user, Pass pass]+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 <- sendCommand h Pasv-    let (Right (host, portNum)) = parseOnly parse227 (frMessage resp)-    return (host, portNum)+    resp <- sendCommandS h Pasv+    ensureCode resp 227+    parseResponse resp parse227  port :: MonadIO m => Handle -> S.HostAddress -> S.PortNumber -> m FTPResponse-port h ha pn = sendCommand h (Port ha pn)+port h ha pn = sendCommandS h (Port ha pn)  acct :: MonadIO m => Handle -> String -> m FTPResponse-acct h pass = sendCommand h (Acct pass)+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 -> sendCommand h (Rnto to)+        Continue -> sendCommandS h (Rnto to)         _ -> return res  dele :: MonadIO m => Handle -> String -> m FTPResponse-dele h file = sendCommand h (Dele file)+dele h file = sendCommandS h (Dele file)  cwd :: MonadIO m => Handle -> String -> m FTPResponse cwd h dir =-    sendCommand h $ if dir == ".."+    sendCommandS h $ if dir == ".."         then Cdup         else Cwd dir  size :: MonadIO m => Handle -> String -> m Int size h file = do-    resp <- sendCommand h (Size file)-    return $ read $ C.unpack $ frMessage resp+    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 <- sendCommand h (Mkd dir)-    let (Right dir) = parseOnly parse257 (frMessage resp)-    return dir+    resp <- sendCommandS h (Mkd dir)+    ensureCode resp 257+    parseResponse resp parse257  rmd :: MonadIO m => Handle -> String -> m FTPResponse-rmd h dir = sendCommand h (Rmd dir)+rmd h dir = sendCommandS h (Rmd dir)  pwd :: MonadIO m => Handle -> m String pwd h = do-    resp <- sendCommand h Pwd-    let (Right dir) = parseOnly parse257 (frMessage resp)-    return dir+    resp <- sendCommandS h Pwd+    ensureCode resp 257+    parseResponse resp parse257  quit :: MonadIO m => Handle -> m FTPResponse-quit h = sendCommand h Quit+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 = sendCommand h . Pbsz+pbsz h = sendCommandS h . Pbsz  prot :: MonadIO m => Handle -> ProtType -> m FTPResponse-prot h = sendCommand h . Prot+prot h = sendCommandS h . Prot  ccc :: MonadIO m => Handle -> m FTPResponse-ccc h = sendCommand h Ccc+ccc h = sendCommandS h Ccc  auth :: MonadIO m => Handle -> m FTPResponse-auth h = sendCommand h Auth+auth h = sendCommandS h Auth  -- Data commands @@ -633,7 +744,8 @@     :: (MonadIO m, MonadMask m)     => Handle     -> PortActivity-    -> [FTPCommand]+    -> RTypeCode+    -> FTPCommand     -> (Handle -> m a)     -> m a withDataCommandSecurity h =@@ -642,13 +754,13 @@         TLS -> withTLSDataCommand h  nlst :: (MonadIO m, MonadMask m) => Handle -> [String] -> m ByteString-nlst h args = withDataCommandSecurity h Passive [RType TA, Nlst args] getAllLineResp+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 [RType TI, Retr path] recvAll+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 [RType TA, List args] getAllLineResp+list h args = withDataCommandSecurity h Passive TA (List args) getAllLineResp  stor     :: (MonadIO m, MonadMask m)@@ -658,10 +770,9 @@     -> RTypeCode     -> m () stor h loc dat rtype =-    withDataCommandSecurity h Passive [RType rtype, Stor loc]-        $ sendType rtype dat+    withDataCommandSecurity h Passive rtype (Stor loc) $ sendType rtype dat -data MlsdResponse = MlsdResponse {+data MlsxResponse = MlsxResponse {     mrFilename :: String,     mrFacts :: Map String String } deriving (Show)@@ -671,26 +782,26 @@     let (x0, x1) = C.break (== on) s     in (x0, C.drop 1 x1) -parseMlsdLine :: ByteString -> MlsdResponse-parseMlsdLine line =+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 MlsdResponse (C.unpack filename) facts+    in MlsxResponse (C.unpack filename) facts -getMlsdResponse :: (MonadIO m, MonadCatch m) => Handle -> m [MlsdResponse]-getMlsdResponse h = getMlsdResponse' h []+getMlsxResponse :: (MonadIO m, MonadCatch m) => Handle -> m [MlsxResponse]+getMlsxResponse h = getMlsxResponse' h []     where-        getMlsdResponse' h ret = ( do+        getMlsxResponse' h ret = ( do             line <- liftIO $ getLineResp h-            getMlsdResponse' h $+            getMlsxResponse' h $                 if C.null line                     then ret-                    else (parseMlsdLine line):ret+                    else (parseMlsxLine line):ret             ) `M.catchIOError` (\_ -> return ret) -mlsd :: (MonadIO m, MonadMask m) => Handle -> String -> m [MlsdResponse]-mlsd h path = withDataCommandSecurity h Passive [RType TA, Mlsd path] getMlsdResponse+mlsd :: (MonadIO m, MonadMask m) => Handle -> String -> m [MlsxResponse]+mlsd h path = withDataCommandSecurity h Passive TA (Mlsd path) getMlsxResponse