diff --git a/ftp-client.cabal b/ftp-client.cabal --- a/ftp-client.cabal +++ b/ftp-client.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: ftp-client -version: 0.5.1.2 +version: 0.5.1.3 license: PublicDomain license-file: LICENSE maintainer: mrobinson7627@gmail.com @@ -30,15 +30,19 @@ network >=2.6.3.6 && <2.9, attoparsec >=0.10 && <0.14, connection >=0.2 && <0.4, - transformers >=0.5.5.0 && <0.6, - exceptions >=0.10.0 && <0.11, + transformers >=0.5.6.2 && <0.6, + exceptions >=0.10.3 && <0.11, containers >=0.5.11.0 && <0.7 test-suite ftp-client-test type: exitcode-stdio-1.0 - main-is: Spec.hs + main-is: test.hs hs-source-dirs: test default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.11.1.0 && <5 + base >=4.11.1.0 && <5, + bytestring >=0.10.8.2 && <0.11, + tasty >=1.2.3 && <1.3, + tasty-hspec >=1.1.5.1 && <1.2, + ftp-client -any 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 @@ -30,6 +30,7 @@ -- * Types FTPCommand(..), FTPResponse(..), + FTPMessage(..), ResponseStatus(..), MlsxResponse(..), RTypeCode(..), @@ -45,6 +46,7 @@ -- * Lower Level Functions sendCommand, sendCommandS, + recvAll, sendAll, sendAllS, getLineResp, @@ -80,15 +82,13 @@ import Data.Typeable debugging :: Bool -debugging = True +debugging = False debugPrint :: (Show a, MonadIO m) => a -> m () -debugPrint s = if debugging - then return () - else liftIO $ print s +debugPrint s = when debugging (liftIO $ print s) debugResponse :: (Show a, MonadIO m) => a -> m () -debugResponse s = debugPrint $ "Recieved: " <> (show s) +debugResponse s = debugPrint $ "Recieved: " <> show s data Security = Clear | TLS @@ -102,6 +102,7 @@ } data FTPMessage = SingleLine ByteString | MultiLine [ByteString] + deriving Eq instance Show FTPMessage where show (SingleLine message) = C.unpack message @@ -112,10 +113,10 @@ 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) + show fr = show (frCode fr) <> " " <> show (frMessage fr) -- | First digit of an FTP response data ResponseStatus @@ -203,11 +204,11 @@ serializeCommand (RType rt) = "TYPE " <> serialzeRTypeCode rt serializeCommand (Retr file) = "RETR " <> file serializeCommand (Nlst []) = "NLST" -serializeCommand (Nlst args) = "NLST " <> intercalate " " args +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 " <> intercalate " " args +serializeCommand (List args) = "LIST " <> unwords args serializeCommand (Rnfr from) = "RNFR " <> from serializeCommand (Rnto to) = "RNTO " <> to serializeCommand (Dele file) = "DELE " <> file @@ -248,7 +249,7 @@ SingleLine message -> SingleLine $ C.drop 4 message MultiLine [] -> MultiLine [] MultiLine (message:messages) -> - MultiLine ((C.drop 4 message):messages) + MultiLine $ C.drop 4 message : messages let response = FTPResponse (responseStatus code) (read $ C.unpack code) @@ -343,7 +344,7 @@ (createSocket (Just host) portNum hints) (liftIO . S.close . fst) (\(sock, addr) -> do - debugPrint $ "Connecting" + debugPrint "Connecting" liftIO $ S.connect sock (S.addrAddress addr) debugPrint "Connected" f sock @@ -468,7 +469,7 @@ => Handle -> PortActivity -> FTPCommand - -> m (SIO.Handle) + -> m SIO.Handle createSendDataCommand h pa cmd = withDataSocket pa h $ \socket -> do resp <- sendCommand h cmd ensureSucessfulData h resp @@ -509,8 +510,10 @@ where recvAll' bs = ( do chunk <- liftIO $ recv h defaultChunkSize - recvAll' $ bs <> chunk) - `M.catchIOError` (\_ -> return bs) + if C.null chunk + then return bs + else recvAll' $ bs <> chunk + ) `M.catchIOError` (\_ -> return bs) -- TLS connection @@ -578,7 +581,7 @@ -> Int -> (Handle -> FTPResponse -> m a) -> m a -withFTPS host portNum = withTLSHandle host portNum +withFTPS = withTLSHandle -- TLS data connection @@ -600,7 +603,7 @@ (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] + hostName = intercalate "." $ show . fromEnum <$> [h1, h2, h3, h4] h <- liftIO $ S.socketToHandle acceptedSock SIO.ReadWriteMode liftIO $ connectTLS h hostName (fromEnum sPort) @@ -619,7 +622,7 @@ (liftIO . connectionClose) (f . tlsHandleImpl) resp <- getResponse ch - debugPrint $ "Recieved: " <> (show resp) + debugPrint $ "Recieved: " <> show resp return x parseResponse :: MonadIO m => FTPResponse -> Parser a -> m a @@ -692,7 +695,7 @@ resp <- sendCommandS h (Size file) ensureCode resp 213 return $ case frMessage resp of - SingleLine message -> read $ C.unpack $ message + SingleLine message -> read . C.unpack $ message MultiLine _ -> 0 mkd :: MonadIO m => Handle -> String -> m String @@ -739,7 +742,7 @@ -- Data commands sendType :: MonadIO m => RTypeCode -> ByteString -> Handle -> m () -sendType TA dat h = void $ mapM (sendCommandLine h) $ C.split '\n' dat +sendType TA dat h = mapM_ (sendCommandLine h) $ C.split '\n' dat sendType TI dat h = liftIO $ send h dat withDataCommandSecurity @@ -802,7 +805,7 @@ getMlsxResponse' h $ if C.null line then ret - else (parseMlsxLine line):ret + else parseMlsxLine line : ret ) `M.catchIOError` (\_ -> return ret) mlsd :: (MonadIO m, MonadMask m) => Handle -> String -> m [MlsxResponse] diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented" diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,75 @@ +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as C +import Test.Tasty +import Test.Tasty.Hspec +import Network.FTP.Client hiding (Success) +import qualified Network.FTP.Client as F +import Control.Monad.IO.Class +import Control.Concurrent.MVar + +data TestHandleMVars = TestHandleMVars + { thmSend :: MVar [ByteString] + , thmSendLine :: MVar [ByteString] + , thmRecv :: MVar [Int] + } + +data TestHandle = TestHandle TestHandleMVars Handle + +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 + +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