diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/ftp-client.cabal b/ftp-client.cabal --- a/ftp-client.cabal +++ b/ftp-client.cabal @@ -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 diff --git a/src/Network/FTP/Client.hs b/src/Network/FTP/Client.hs --- a/src/Network/FTP/Client.hs +++ b/src/Network/FTP/Client.hs @@ -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