diff --git a/Network/FTP/Conduit.hs b/Network/FTP/Conduit.hs --- a/Network/FTP/Conduit.hs +++ b/Network/FTP/Conduit.hs @@ -1,16 +1,17 @@ +{-# LANGUAGE DeriveDataTypeable #-} -- | This module contains code to use files on a remote FTP server as -- Sources and Sinks. -- -- Using these functions looks like this: -- > let uri = fromJust $ parseURI "ftp://ftp.kernel.org/pub/README_ABOUT_BZ2_FILES" --- > runErrorT $ runResourceT $ createSource uri $$ consume +-- > runResourceT $ createSource uri $$ consume -- -- The functions here operate on the ErrorT monad transformer, because -- the server can send unexpected replies, which are thrown as errors. module Network.FTP.Conduit ( createSink , createSource - , FTPError(..) + , FTPException(..) ) where import Data.Conduit @@ -19,35 +20,36 @@ import Network.Socket hiding (send, sendTo, recv, recvFrom, Closed) import Network.Socket.ByteString import Network.URI -import Network.Utils -import Control.Monad.Error +import Network.Utils (connectTCP) +import Control.Monad.Trans (lift) +import Control.Monad (when) import Data.Word import System.ByteOrder import Data.Bits import Prelude hiding (getLine) import Control.Monad.Trans.Resource +import Data.Typeable (Typeable) +import Control.Exception (Exception, throw) -data FTPError = UnexpectedCode Int BS.ByteString - | GeneralError String - | IncorrectScheme String - | SocketClosed - deriving (Show) -instance Error FTPError where - noMsg = GeneralError "" - strMsg = GeneralError +data FTPException = UnexpectedCode Int BS.ByteString + | IncorrectScheme String + | SocketClosed + deriving (Show, Typeable) +instance Exception FTPException + hton_16 :: Word16 -> Word16 hton_16 x = case byteOrder of BigEndian -> x LittleEndian -> x `shiftL` 8 + x `shiftR` 8 _ -> undefined -getByte :: Socket -> ResourceT (ErrorT FTPError IO) Word8 +getByte :: Socket -> ResourceT IO Word8 getByte s = do - b <- lift $ lift $ recv s 1 - if BS.null b then lift (throwError SocketClosed) else return $ BS.head b + b <- lift $ recv s 1 + if BS.null b then throw SocketClosed else return $ BS.head b -getLine :: Socket -> ResourceT (ErrorT FTPError IO) BS.ByteString +getLine :: Socket -> ResourceT IO BS.ByteString getLine s = do b <- getByte s helper b @@ -60,23 +62,23 @@ extractCode :: BS.ByteString -> Int extractCode = read . toString . (BS.takeWhile (/= 32)) -readExpected :: Socket -> Int -> ResourceT (ErrorT FTPError IO) BS.ByteString +readExpected :: Socket -> Int -> ResourceT IO BS.ByteString readExpected s i = do line <- getLine s --lift $ lift $ putStrLn $ "Read: " ++ (toString line) if extractCode line /= i - then lift $ throwError $ UnexpectedCode i line + then throw $ UnexpectedCode i line else return line -writeLine :: Socket -> BS.ByteString -> ResourceT (ErrorT FTPError IO) () -writeLine s bs = lift $ lift $ do +writeLine :: Socket -> BS.ByteString -> ResourceT IO () +writeLine s bs = lift $ do --lift $ lift $ putStrLn $ "Writing: " ++ (toString bs) - sendAll s $ bs `BS.append` (fromString "\r\n") -- hardcode the newline for platform independence + sendAll s $ bs `BS.append` (fromString "\r\n") -createSource :: URI -> Source (ErrorT FTPError IO) BS.ByteString +createSource :: URI -> Source IO BS.ByteString createSource uri = Source { sourcePull = pull - , sourceClose = close - } + , sourceClose = close + } where pull = do (c, rc, d, rd, path') <- common uri @@ -84,7 +86,7 @@ _ <- readExpected c 150 pull' c rc d rd pull' c rc d rd= do - bytes <- lift $ lift $ recv d 1024 + bytes <- lift $ recv d 1024 if BS.null bytes then do close' c rc d rd @@ -101,17 +103,17 @@ _ <- readExpected c 221 release rc -createSink :: URI -> Sink BS.ByteString (ErrorT FTPError IO) () +createSink :: URI -> Sink BS.ByteString IO () createSink uri = SinkData { sinkPush = push - , sinkClose = close - } + , sinkClose = close + } where push input = do (c, rc, d, rd, path') <- common uri writeLine c $ fromString $ "STOR " ++ path' _ <- readExpected c 150 push' c rc d rd input push' c rc d rd input = do - lift $ lift $ sendAll d input + lift $ sendAll d input return $ Processing (push' c rc d rd) (close' c rc d rd) close = return () close' c rc _ rd = do @@ -121,13 +123,13 @@ _ <- readExpected c 221 release rc -common :: URI -> ResourceT (ErrorT FTPError IO) (Socket, ReleaseKey, Socket, ReleaseKey, String) +common :: URI -> ResourceT IO (Socket, ReleaseKey, Socket, ReleaseKey, String) common (URI { uriScheme = scheme' , uriAuthority = authority' , uriPath = path' }) = do - if scheme' /= "ftp:" then lift (throwError (IncorrectScheme scheme')) else return () - c <- lift $ lift $ connectTCP host (PortNum (hton_16 port)) + when (scheme' /= "ftp:") $ throw (IncorrectScheme scheme') + c <- lift $ connectTCP host (PortNum (hton_16 port)) rc <- register $ sClose c _ <- readExpected c 220 writeLine c $ fromString $ "USER " ++ user @@ -139,18 +141,31 @@ writeLine c $ fromString "PASV" pasv_response <- readExpected c 227 let (pasvhost, pasvport) = parsePasvString pasv_response - d <- lift $ lift $ connectTCP (toString pasvhost) (PortNum (hton_16 pasvport)) + d <- lift $ connectTCP (toString pasvhost) (PortNum (hton_16 pasvport)) rd <- register $ sClose d return (c, rc, d, rd, path') where (host, port, user, pass) = case authority' of Nothing -> undefined Just (URIAuth userInfo regName port') -> ( regName - , if null port' then 21 else read (tail port') - , if null userInfo then "anonymous" else takeWhile (\ l -> l /= ':' && l /= '@') userInfo - , if null userInfo || not (':' `elem` userInfo) then "" else init $ tail $ (dropWhile (/= ':')) userInfo + , if null port' + then 21 + else read (tail port') + , if null userInfo + then "anonymous" + else takeWhile (\ l -> l /= ':' && l /= '@') userInfo + , if null userInfo || not (':' `elem` userInfo) + then "" else + init $ tail $ (dropWhile (/= ':')) userInfo ) parsePasvString ps = (pasvhost, pasvport) - where pasvhost = BS.init $ foldl (\ a ip -> a `BS.append` (fromString $ show ip) `BS.append` (fromString ".")) BS.empty [ip1, ip2, ip3, ip4] + where pasvhost = BS.init $ foldl + (\ a ip -> a + `BS.append` (fromString $ show ip) + `BS.append` (fromString ".")) + BS.empty [ip1, ip2, ip3, ip4] pasvport = (fromIntegral port1) `shiftL` 8 + (fromIntegral port2) - (ip1, ip2, ip3, ip4, port1, port2) = read $ toString $ (`BS.append` (fromString ")")) $ (BS.takeWhile (/= 41)) $ (BS.dropWhile (/= 40)) ps :: (Int, Int, Int, Int, Int, Int) + (ip1, ip2, ip3, ip4, port1, port2) = read $ + toString $ (`BS.append` (fromString ")")) $ + (BS.takeWhile (/= 41)) $ (BS.dropWhile (/= 40)) + ps :: (Int, Int, Int, Int, Int, Int) diff --git a/ftp-conduit.cabal b/ftp-conduit.cabal --- a/ftp-conduit.cabal +++ b/ftp-conduit.cabal @@ -1,5 +1,5 @@ name: ftp-conduit -version: 0.0.3 +version: 0.0.4 license: BSD3 license-file: LICENSE author: Myles C. Maxfield @@ -15,7 +15,7 @@ library build-depends: base >= 4 && < 5 - , conduit >= 0.2 + , conduit >= 0.1.1 , network >= 2.0 , bytestring >= 0.9 , MissingH >= 0.18.6