ftp-conduit 0.0.1 → 0.0.2

raw patch · 2 files changed

+113/−134 lines, 2 filesdep +utf8-stringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: utf8-string

API changes (from Hackage documentation)

Files

• Network/FTP/Conduit.hs +111/−133
• ftp-conduit.cabal +2/−1

@@ -1,69 +1,36 @@ -- | This module contains code to use files on a remote FTP server as -- Sources and Sinks. ----- This module makes use of the FTP 'STOR' and 'RETR' commands. According--- to the FTP spec, these--- commands are set up so that a server response is sent at the beginning--- and end of the data transfers. The current Conduit library doesn't--- allow the code that creates the Source / Sink of the data transfer to--- run checks _after_ the data has been transferred. Because of this fact, this module exposes--- two interfaces.------ One interface is an interface that simply creates a Source / Sink and--- does not check the server return code after the data transfer (because--- it can't, as stated above). These two functions (putFTPFile and--- getFTPFile) return a Sink and a Source, respectively.------ Using these functions looks like:------ > runErrorT $--- >   runResourceT $--- >     (getFTPFile $ fromJust $ parseURI--- >       "ftp://ftp.kernel.org/pub/README_ABOUT_BZ2_FILES") >>=--- >         (\ (_, s, _, _) -> s $$ consume)------ The other interface is one that does check the error code after the--- data transfer. In order to do this, however, these functions must--- actually be the ones that apply the '$$' (connect) function, so they--- can perform the checks afterword. These are the connectDownloadToSink--- and connectSourceToUpload functions. You pass them a Sink and a Source,--- respectively, and they will call the '$$' (connect) function, check that--- the data transfer was successful, and then safely tear down the FTP--- connection. ------ Using these functions looks like:------ > runErrorT $ runResourceT $ connectDownloadToSink--- >   (fromJust $ parseURI--- >     "ftp://ftp.kernel.org/pub/README_ABOUT_BZ2_FILES") consume+-- Using these functions looks like this:+-- > let uri = fromJust $ parseURI "ftp://ftp.kernel.org/pub/README_ABOUT_BZ2_FILES"+-- > runErrorT $ 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-  ( FTPError(..)-  , putFTPFile-  , getFTPFile-  , connectDownloadToSink-  , connectSourceToUpload+  ( createSink+  , createSource+  , FTPError(..)   ) where -import Control.Monad.Trans.Resource-import Data.Word import Data.Conduit-import Data.Conduit.Binary (sourceHandle, sinkHandle)-import Data.Bits-import Network.URI (URI(..), URIAuth(..))-import Data.ByteString (ByteString)-import Network.Socket hiding (connect)+import qualified Data.ByteString as BS+import Data.ByteString.UTF8 hiding (foldl)+import Network.Socket hiding (send, sendTo, recv, recvFrom, Closed)+import Network.Socket.ByteString+import Network.URI import Network.Utils import Control.Monad.Error-import System.IO+import Data.Word import System.ByteOrder+import Data.Bits+import Prelude hiding (getLine)+import Control.Monad.Trans.Resource --- | 'UnexpectedCode' has the form (Expected code, full response string)-data FTPError = UnexpectedCode Int String+data FTPError = UnexpectedCode Int BS.ByteString                 | GeneralError String                 | IncorrectScheme String+                | SocketClosed   deriving (Show) instance Error FTPError where   noMsg  = GeneralError ""@@ -75,74 +42,107 @@   LittleEndian -> x `shiftL` 8 + x `shiftR` 8   _ -> undefined -extractCode :: String -> Int-extractCode = read . (takeWhile (/= ' '))+getByte :: Socket -> ResourceT (ErrorT FTPError IO) Word8+getByte s = do+  b <- lift $ lift $ recv s 1+  if BS.null b then lift (throwError SocketClosed) else return $ BS.head b -readExpected :: Handle -> Int -> ResourceT (ErrorT FTPError IO) String-readExpected h i = do-  line <- liftIO $ hGetLine h-  --liftIO $ putStrLn $ "Read: " ++ line+getLine :: Socket -> ResourceT (ErrorT FTPError IO) BS.ByteString+getLine s = do+  b <- getByte s+  helper b+  where helper b = do+          b' <- getByte s+          if BS.pack [b, b'] == fromString "\r\n"+            then return BS.empty+            else helper b' >>= return . (BS.cons b)++extractCode :: BS.ByteString -> Int+extractCode = read . toString . (BS.takeWhile (/= 32))++readExpected :: Socket -> Int -> ResourceT (ErrorT FTPError 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     else return line -writeLine :: Handle -> String -> ResourceT (ErrorT FTPError IO) ()-writeLine h s = liftIO $ do-  --liftIO $ putStrLn $ "Writing: " ++ s-  hPutStr h $ s ++ "\r\n" -- hardcode the newline for platform independence-  hFlush h -- Buffering doesn't work right for some reason. Explicitly flush here.+writeLine :: Socket -> BS.ByteString -> ResourceT (ErrorT FTPError IO) ()+writeLine s bs = lift $ lift $ do+  --lift $ lift $ putStrLn $ "Writing: " ++ (toString bs)+  sendAll s $ bs `BS.append` (fromString "\r\n") -- hardcode the newline for platform independence --- | Give this a source and it uploads it to the given URI. This function calls '$$'.-connectSourceToUpload :: URI -> Source (ErrorT FTPError IO) ByteString -> ResourceT (ErrorT FTPError IO) ()-connectSourceToUpload uri source = do-  (handle, sink, release_control, release_data) <- putFTPFile uri-  out <- source $$ sink-  cleanUp release_control release_data handle-  return out+createSource :: URI -> Source (ErrorT FTPError IO) BS.ByteString+createSource uri = Source { sourcePull = pull+                           , sourceClose = close+                           } --- | Give this a Sink and it downloads the given URI to it. This function calls '$$'.-connectDownloadToSink :: URI -> Sink ByteString (ErrorT FTPError IO) b -> ResourceT (ErrorT FTPError IO) b-connectDownloadToSink uri sink = do-  (handle, source, release_control, release_data) <- getFTPFile uri-  out <- source $$ sink-  cleanUp release_control release_data handle-  return out+  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 $ lift $ recv d 1024+          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 -cleanUp :: ReleaseKey -> ReleaseKey -> Handle -> ResourceT (ErrorT FTPError IO) ()-cleanUp release_control release_data handle= do-  release release_data-  _ <- readExpected handle 226-  writeLine handle "QUIT"-  _ <- readExpected handle 221-  release release_control-  return ()+createSink :: URI -> Sink BS.ByteString (ErrorT FTPError 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 $ 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 -setupHandleForFTP :: URI -> IOMode -> ResourceT (ErrorT FTPError IO) (Handle, Handle, String, ReleaseKey, ReleaseKey)-setupHandleForFTP URI { uriScheme = scheme-                      , uriAuthority = authority-                      , uriPath = path-                      } iomode = do -  if scheme /= "ftp:" then lift (throwError (IncorrectScheme scheme)) else return ()-  s <- liftIO $ connectTCP host (PortNum (hton_16 port))-  h <- liftIO $ socketToHandle s ReadWriteMode-  liftIO $ hSetBuffering h LineBuffering-  release_control <- register $ liftIO $ hClose h-  _ <- readExpected h 220-  writeLine h $ "USER " ++ user-  _ <- readExpected h 331-  writeLine h $ "PASS " ++ pass-  _ <- readExpected h 230-  writeLine h "TYPE I"-  _ <- readExpected h 200-  writeLine h "PASV"-  pasv_response <- readExpected h 227+common :: URI -> ResourceT (ErrorT FTPError 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))+  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-  ds <- liftIO $ connectTCP pasvhost (PortNum (hton_16 pasvport))-  dh <- liftIO $ socketToHandle ds iomode-  liftIO $ hSetBuffering h $ BlockBuffering Nothing-  release_data <- register $ liftIO $ hClose dh-  return (h, dh, path, release_control, release_data)-  where (host, port, user, pass) = case authority of+  d <- lift $ 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@@ -150,29 +150,7 @@             , if null userInfo then "anonymous" else takeWhile (\ l -> l /= ':' && l /= '@') userInfo             , if null userInfo || not (':' `elem` userInfo) then "" else init $ tail $ (dropWhile (/= ':')) userInfo             )-        parsePasvString s = (pasvhost, pasvport)-          where pasvhost = (show ip1) ++ "." ++ (show ip2) ++ "." ++ (show ip3) ++ "." ++ (show ip4)+        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]                 pasvport = (fromIntegral port1) `shiftL` 8 + (fromIntegral port2)-                (ip1, ip2, ip3, ip4, port1, port2) = read $ (++ ")") $ (takeWhile (/= ')')) $ (dropWhile (/= '(')) s :: (Int, Int, Int, Int, Int, Int)---- | Returns (Handle of the control connection, the Sink itself--- a destructor for the control connection, and a destructor for the data connection).------ The caller should use the handle to check for return codes, and release the ReleaseKeys when appropriate.-putFTPFile :: URI -> ResourceT (ErrorT FTPError IO) (Handle, (Sink ByteString (ErrorT FTPError IO) ()), ReleaseKey, ReleaseKey)-putFTPFile uri = do-  (h, dh, path, release_control, release_data) <- setupHandleForFTP uri WriteMode-  writeLine h $ "STOR " ++ path-  _ <- readExpected h 150-  return $ (h, sinkHandle dh, release_control, release_data)---- | Returns (Handle of the control connection, the Source itself,--- a destructor for the control connection, and a destructor for the data connection).------ The caller should use the handle to check for return codes, and release the ReleaseKeys when appropriate.-getFTPFile :: URI -> ResourceT (ErrorT FTPError IO) (Handle, (Source (ErrorT FTPError IO) ByteString), ReleaseKey, ReleaseKey)-getFTPFile uri = do-  (h, dh, path, release_control, release_data) <- setupHandleForFTP uri ReadMode-  writeLine h $ "RETR " ++ path-  _ <- readExpected h 150-  return $ (h, sourceHandle dh, release_control, release_data)+                (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.1+version:         0.0.2 license:         BSD3 license-file:    LICENSE author:          Myles C. Maxfield <myles.maxfield@gmail.com>@@ -21,6 +21,7 @@                  , MissingH              >= 0.18.6                  , mtl                   >= 1.0                  , byteorder             >= 1.0.0+                 , utf8-string           >= 0.3     exposed-modules: Network.FTP.Conduit     ghc-options:     -Wall