ftp-conduit 0.0.4 → 0.0.5

raw patch · 2 files changed

+94/−110 lines, 2 filesdep +transformersdep −mtldep ~conduitPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: transformers

Dependencies removed: mtl

Dependency ranges changed: conduit

API changes (from Hackage documentation)

Files

• Network/FTP/Conduit.hs +84/−100
• ftp-conduit.cabal +10/−10

@@ -1,13 +1,13 @@ {-# LANGUAGE DeriveDataTypeable #-}+ -- | This module contains code to use files on a remote FTP server as--- Sources and Sinks.+--   Sources and Sinks. ----- Using these functions looks like this:+--   Using these functions looks like this:+-- -- > let uri = fromJust $ parseURI "ftp://ftp.kernel.org/pub/README_ABOUT_BZ2_FILES" -- > 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@@ -20,21 +20,21 @@ import Network.Socket hiding (send, sendTo, recv, recvFrom, Closed) import Network.Socket.ByteString import Network.URI-import Network.Utils (connectTCP)-import Control.Monad.Trans (lift)-import Control.Monad (when)+import Network.Utils+import Control.Exception 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)+import Prelude hiding (getLine, catch)+import Data.Typeable+import Control.Monad.IO.Class +-- | Thrown if a FTP-level protocol exception happens data FTPException = UnexpectedCode Int BS.ByteString+                  | GeneralError String                   | IncorrectScheme String                   | SocketClosed-  deriving (Show, Typeable)+  deriving (Typeable, Show)  instance Exception FTPException @@ -44,12 +44,12 @@   LittleEndian -> x `shiftL` 8 + x `shiftR` 8   _ -> undefined -getByte :: Socket -> ResourceT IO Word8+getByte :: Socket -> IO Word8 getByte s = do-  b <- lift $ recv s 1+  b <- recv s 1   if BS.null b then throw SocketClosed else return $ BS.head b -getLine :: Socket -> ResourceT IO BS.ByteString+getLine :: Socket -> IO BS.ByteString getLine s = do   b <- getByte s   helper b@@ -62,110 +62,94 @@ extractCode :: BS.ByteString -> Int extractCode = read . toString . (BS.takeWhile (/= 32)) -readExpected :: Socket -> Int -> ResourceT IO BS.ByteString+readExpected :: Socket -> Int -> IO BS.ByteString readExpected s i = do   line <- getLine s-  --lift $ lift $ putStrLn $ "Read: " ++ (toString line)+  --putStrLn $ "Read: " ++ (toString line)   if extractCode line /= i     then throw $ UnexpectedCode i line     else return line -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")+writeLine :: Socket -> BS.ByteString -> IO ()+writeLine s bs = do+  --putStrLn $ "Writing: " ++ (toString bs)+  sendAll s $ bs `BS.append` (fromString "\r\n") -- hardcode the newline for platform independence -createSource :: URI -> Source IO BS.ByteString-createSource uri = Source { sourcePull = pull-                          , sourceClose = close-                          }+close :: (Socket, Socket) -> IO ()+close (c, d) = do+  --putStrLn "Closing data connection"+  sClose d+  catch (do+    _ <- readExpected c 226+    writeLine c $ fromString "QUIT"+    _ <- readExpected c 221+    --putStrLn "Closing control connection"+    sClose c+    ) (\ e -> sClose c >> throw (e :: IOException)) -  where pull = do-          (c, rc, d, rd, path') <- common uri-          writeLine c $ fromString $ "RETR " ++ path'-          _ <- readExpected c 150-          pull' c rc d rd-        pull' c rc d rd= do-          bytes <- lift $ recv d 1024+-- | Create a conduit source out of a 'URI'. Uses the @RETR@ command.+createSource :: MonadResource m => URI -> Source m BS.ByteString+createSource uri = sourceIO setup close pull+  where setup = do+          (c, d, path') <- common uri+          catch (do+            writeLine c $ fromString $ "RETR " ++ path'+            _ <- readExpected c 150+            return (c, d)+            ) (\ e -> sClose d >> sClose c >> throw (e :: IOException))+        pull (_, d) = liftIO $ do+          bytes <- recv d 4096           if BS.null bytes             then do-              close' c rc d rd-              return Closed-            else do-              return $ Open (Source { sourcePull = pull' c rc d rd-                                    , sourceClose = close' c rc d rd-                                    }) bytes-        close = return ()-        close' c rc _ rd = do-          release rd-          _ <- readExpected c 226-          writeLine c $ fromString "QUIT"-          _ <- readExpected c 221-          release rc+              return IOClosed+            else return $ IOOpen bytes -createSink :: URI -> Sink BS.ByteString IO ()-createSink uri = SinkData { sinkPush = push-                          , 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 $ sendAll d input-          return $ Processing (push' c rc d rd) (close' c rc d rd)-        close = return ()-        close' c rc _ rd = do-          release rd-          _ <- readExpected c 226-          writeLine c $ fromString "QUIT"-          _ <- readExpected c 221-          release rc+-- | Create a conduit sink out of a 'URI'. Uses the @STOR@ command.+createSink :: MonadResource m => URI -> Sink BS.ByteString m ()+createSink uri = sinkIO setup close push (liftIO . close)+  where setup = do+          (c, d, path') <- common uri+          catch (do+            writeLine c $ fromString $ "STOR " ++ path'+            _ <- readExpected c 150+            return (c, d)+            ) (\ e -> sClose d >> sClose c >> throw (e :: IOException))+        push (_, d) input = liftIO $ do+          sendAll d input+          return IOProcessing -common :: URI -> ResourceT IO (Socket, ReleaseKey, Socket, ReleaseKey, String)+common :: URI -> IO (Socket, Socket, String) common (URI { uriScheme = scheme'        , uriAuthority = authority'        , uriPath = path'        }) = do-  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-  _ <- readExpected c 331-  writeLine c $ fromString $ "PASS " ++ pass-  _ <- readExpected c 230-  writeLine c $ fromString "TYPE I"-  _ <- readExpected c 200-  writeLine c $ fromString "PASV"-  pasv_response <- readExpected c 227-  let (pasvhost, pasvport) = parsePasvString pasv_response-  d <- lift $ connectTCP (toString pasvhost) (PortNum (hton_16 pasvport))-  rd <- register $ sClose d-  return (c, rc, d, rd, path')+  if scheme' /= "ftp:" then throw $ IncorrectScheme scheme' else return ()+  --putStrLn "Opening control connection"+  c <- connectTCP host (PortNum (hton_16 port))+  catch (do+    _ <- readExpected c 220+    writeLine c $ fromString $ "USER " ++ user+    _ <- readExpected c 331+    writeLine c $ fromString $ "PASS " ++ pass+    _ <- readExpected c 230+    writeLine c $ fromString "TYPE I"+    _ <- readExpected c 200+    writeLine c $ fromString "PASV"+    pasv_response <- readExpected c 227+    let (pasvhost, pasvport) = parsePasvString pasv_response+    --putStrLn "Opening data connection"+    d <- connectTCP (toString pasvhost) (PortNum (hton_16 pasvport))+    return (c, d, path')+    ) (\ e -> sClose c >> throw (e :: IOException))   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)

@@ -1,5 +1,5 @@ name:            ftp-conduit-version:         0.0.4+version:         0.0.5 license:         BSD3 license-file:    LICENSE author:          Myles C. Maxfield <myles.maxfield@gmail.com>@@ -7,21 +7,21 @@ synopsis:        FTP client package with conduit interface based off http-conduit description:     This package allows files on remote FTP servers to be available through the Conduit interface.-category:        Web, Conduit+category:        Network, Conduit stability:       Experimental cabal-version:   >= 1.8 build-type:      Simple homepage:        https://github.com/litherum/ftp-conduit  library-    build-depends: base                  >= 4       && < 5-                 , conduit               >= 0.1.1-                 , network               >= 2.0-                 , bytestring            >= 0.9-                 , MissingH              >= 0.18.6-                 , mtl                   >= 1.0-                 , byteorder             >= 1.0.0-                 , utf8-string           >= 0.3+    build-depends: base         >= 4     && < 5+                 , conduit      >= 0.4.0 && < 0.5.0+                 , network      >= 2.0+                 , bytestring   >= 0.9+                 , MissingH     >= 0.18.6+                 , byteorder    >= 1.0.0+                 , transformers >= 0.2.0.0+                 , utf8-string  >= 0.3     exposed-modules: Network.FTP.Conduit     ghc-options:     -Wall