haskell-ftp (empty) → 0.1.0.0
raw patch · 11 files changed
+888/−0 lines, 11 filesdep +basedep +basic-preludedep +bytestringsetup-changed
Dependencies added: base, basic-prelude, bytestring, case-insensitive, conduit, directory, lifted-base, monad-control, network, network-conduit, process-conduit, system-filepath, text, transformers, transformers-base, unix
Files
- Ftp.hs +13/−0
- LICENSE +30/−0
- Network/FTP/Backend.hs +39/−0
- Network/FTP/Backend/FileSystem.hs +98/−0
- Network/FTP/Commands.hs +287/−0
- Network/FTP/Monad.hs +161/−0
- Network/FTP/Server.hs +29/−0
- Network/FTP/Socket.hs +110/−0
- Network/FTP/Utils.hs +20/−0
- Setup.hs +2/−0
- haskell-ftp.cabal +99/−0
+ Ftp.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE ViewPatterns #-}+import System.Environment (getArgs)+import Filesystem.Path.CurrentOS (decodeString)+import Data.Conduit.Network (runTCPServer, serverSettings, HostPreference(HostAny), serverNeedLocalAddr)+import Network.FTP.Server (ftpServer)+import Network.FTP.Backend.FileSystem (runFSBackend, FSConf(FSConf))++main :: IO ()+main = do+ [read -> port, d] <- getArgs+ let serverConf = (serverSettings port HostAny){serverNeedLocalAddr=True}+ runFSBackend (FSConf (decodeString d)) $+ runTCPServer serverConf ftpServer
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, yihuang++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of yihuang nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++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.
+ Network/FTP/Backend.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}+module Network.FTP.Backend+ ( FTPBackend(..)+ ) where++{-|+ - Interface for backend.+ -}++import qualified Prelude as P+import BasicPrelude++import Control.Monad.Trans.Control+import Data.Conduit++class ( Functor m+ , Monad m+ , MonadIO m+ , MonadBaseControl IO m+ , Show (UserId m)+ ) => FTPBackend m where++ type UserId m++ ftplog :: ByteString -> m () -- ^ logging.++ authenticate :: ByteString+ -> ByteString+ -> m (Maybe (UserId m)) -- ^ login.++ list :: FilePath -> Source m ByteString -- ^ list directory content.+ nlst :: FilePath -> Source m ByteString -- ^ list names inside directory.+ mkd :: FilePath -> m () -- ^ create directory.+ dele :: FilePath -> m () -- ^ remove file.+ rmd :: FilePath -> m () -- ^ remove directory.+ rename :: FilePath -> FilePath -> m () -- ^ rename file.++ download :: FilePath -> Source m ByteString -- ^ fetch file.+ upload :: FilePath -> Sink ByteString m () -- ^ store file.
+ Network/FTP/Backend/FileSystem.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE GeneralizedNewtypeDeriving+ , OverloadedStrings+ , TypeFamilies+ , MultiParamTypeClasses+ , CPP+ #-}+module Network.FTP.Backend.FileSystem+ ( FSConf(..)+ , FSBackend(..)+ , runFSBackend+ ) where++{-|+ - Simple file system backend.+ -}++import qualified Prelude+import BasicPrelude+import System.Directory+import Filesystem.Path.CurrentOS++import Control.Monad.Trans.Reader+import Control.Monad.Trans.Control+import Control.Monad.Base++import qualified Data.ByteString.Char8 as S+import Data.Conduit+import qualified Data.Conduit.List as C+import qualified Data.Conduit.Binary as C+import qualified Data.Conduit.Process as C++import Network.FTP.Utils (dropHeadingPathSeparator)+import Network.FTP.Backend (FTPBackend(..))++data FSConf = FSConf+ { fsBase :: FilePath+ }++newtype FSBackend a = FSBackend { unFSBackend :: ReaderT FSConf (ResourceT IO) a }+ deriving ( Functor, Applicative, Monad, MonadIO+ , MonadUnsafeIO, MonadThrow, MonadResource+ )++instance MonadBase IO FSBackend where+ liftBase = FSBackend . liftBase++instance MonadBaseControl IO FSBackend where+ newtype StM FSBackend a = FSBackendStM { unFSBackendStM :: StM (ReaderT FSConf (ResourceT IO)) a }+ liftBaseWith f = FSBackend . liftBaseWith $ \runInBase -> f $ liftM FSBackendStM . runInBase . unFSBackend+ restoreM = FSBackend . restoreM . unFSBackendStM++runFSBackend :: FSConf -> FSBackend a -> IO a+runFSBackend st m = runResourceT $ runReaderT (unFSBackend m) st++makeAbsolute :: FilePath -> FSBackend FilePath+makeAbsolute path = do+ b <- FSBackend (asks fsBase)+ return $ b </> dropHeadingPathSeparator path++instance FTPBackend FSBackend where+ type UserId FSBackend = ByteString++ ftplog = liftIO . S.putStrLn++ authenticate user pass =+ if user==pass+ then return (Just user)+ else return Nothing++ list dir = do+ dir' <- lift (makeAbsolute dir)+ C.sourceCmd $ "ls -l " ++ encodeString dir'++ nlst dir = do+ dir' <- lift (makeAbsolute dir)+ paths <- liftIO $ getDirectoryContents (encodeString dir')+ C.sourceList $ map (S.pack . (++"\n")) paths++ mkd dir =+ makeAbsolute dir >>= liftIO . createDirectory . encodeString++ dele name =+ makeAbsolute name >>= liftIO . removeFile . encodeString++ rename fname tname = do+ fname' <- makeAbsolute fname+ tname' <- makeAbsolute tname+ liftIO $ renameFile (encodeString fname') (encodeString tname')++ rmd dir = do+ dir' <- makeAbsolute dir+ liftIO $ removeDirectory (encodeString dir')++ download name =+ lift (makeAbsolute name) >>= C.sourceFile . encodeString++ upload name =+ lift (makeAbsolute name) >>= C.sinkFile . encodeString
+ Network/FTP/Commands.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, DeriveDataTypeable, ScopedTypeVariables #-}+module Network.FTP.Commands where++{-| Implement all ftp commands in FTP Monad.+ -}++import qualified Prelude as P+import BasicPrelude++import Control.Monad.Trans.State (get, gets, put, modify)+import Control.Exception (throw)+import qualified Control.Exception.Lifted as Lifted++import qualified Data.ByteString.Char8 as S+import qualified Data.CaseInsensitive as CI+import Data.Typeable (Typeable)+import Data.Maybe (isJust)+import Data.Conduit ( ($$) )+import Data.Conduit.Network (Application, sinkSocket, sourceSocket, appSource, appSink)+import Data.Conduit.Network.Internal (AppData(..))++import Network.FTP.Monad+import qualified Network.FTP.Socket as NS+import Network.FTP.Backend (FTPBackend(..))+import Network.FTP.Utils (encode, decode)++type Command m = ByteString -> FTP m ()++data ApplicationQuit = ApplicationQuit+ deriving (Show, Typeable)++instance Exception ApplicationQuit++{-+ - check auth state before run command.+ -}+login_required :: FTPBackend m => Command m -> Command m+login_required cmd arg = do+ b <- isJust <$> FTP (gets ftpUser)+ if b+ then cmd arg+ else reply "530" "Command not possible in non-authenticated state."++cmd_user :: FTPBackend m => Command m+cmd_user name = do+ b <- isJust <$> FTP (gets ftpUser)+ if b+ then reply "530" "Command not possible in authenticated state."+ else do+ reply "331" "User name accepted; send password."+ pass <- wait (expect "PASS")+ muser <- lift (authenticate name pass)+ FTP $ modify $ \st -> st { ftpUser = muser }+ if isJust muser+ then reply "230" "login successful."+ else reply "530" "incorrect password."++cmd_cwd, cmd_cdup, cmd_pwd :: FTPBackend m => Command m++cmd_cwd dir = do+ cwd (decode dir)+ dir' <- pwd+ reply "250" $ "New directory now " ++ encode dir'++cmd_cdup _ = cmd_cwd ".."+cmd_pwd _ = do+ d <- pwd+ reply "257" $ "\"" ++ encode d ++ "\" is the current working directory."++cmd_type :: FTPBackend m => Command m+cmd_type tp = do+ let modType newtp = do+ st <- FTP get+ reply "200" $ S.pack $+ "Type changed from " ++ P.show (ftpDataType st) +++ " to " ++ P.show newtp+ FTP $ put st{ ftpDataType = newtp }+ case tp of+ "I" -> modType Binary+ "L 8" -> modType Binary+ "A" -> modType ASCII+ "AN" -> modType ASCII+ "AT" -> modType ASCII+ _ -> reply "504" $ "Type \"" ++ tp ++ "\" not supported."++cmd_pasv :: FTPBackend m => Command m+cmd_pasv _ = do+ local <- FTP (gets ftpLocal)+ sock <- liftIO $ NS.startPasvServer local+ FTP $ modify $ \st -> st { ftpChannel = PasvChannel sock }+ portstr <- liftIO $ NS.getSocketName sock >>= NS.toPortString+ reply "227" $ S.pack $ "Entering passive mode (" ++ portstr ++ ")"++cmd_port :: FTPBackend m => Command m+cmd_port port = do+ local <- FTP (gets ftpLocal)+ addr <- liftIO $ NS.fromPortString (S.unpack port)+ case validate local addr of+ Right _ -> doit addr+ Left err -> reply "501" err+ where+ validate (NS.SockAddrInet _ h1) (NS.SockAddrInet _ h2) =+ if h1==h2+ then Right ()+ else Left "Will only connect to same client as command channel."+ validate (NS.SockAddrInet _ _) _ = Left "Require IPv4 in specified address"+ validate _ _ = Left "Require IPv4 on client"++ doit addr = do+ FTP $ modify $ \st -> st { ftpChannel = PortChannel addr }+ reply "200" $ S.pack $ "OK, later I will connect to " ++ P.show addr++runTransfer :: FTPBackend m => Application m -> FTP m ()+runTransfer app = do+ reply "150" "I'm going to open the data channel now."+ chan <- FTP (gets ftpChannel)+ FTP $ modify $ \st -> st{ ftpChannel = NoChannel }+ case chan of+ NoChannel -> fail "Can't connect when no data channel exists"++ PasvChannel sock ->+ Lifted.finally+ (do (csock, addr) <- liftIO $ NS.accept sock+ lift $ Lifted.finally+ (app AppData+ { appSource = sourceSocket csock+ , appSink = sinkSocket csock+ , appSockAddr = addr+ , appLocalAddr = Nothing+ })+ (liftIO (NS.sClose csock))+ )+ (liftIO (NS.sClose sock))++ PortChannel addr -> do+ sock <- liftIO $ do+ proto <- NS.getProtocolNumber "tcp"+ sock <- NS.socket NS.AF_INET NS.Stream proto+ NS.connect sock addr+ return sock+ lift $ Lifted.finally+ (app AppData+ { appSource = sourceSocket sock+ , appSink = sinkSocket sock+ , appSockAddr = addr+ , appLocalAddr = Nothing+ })+ (liftIO (NS.sClose sock))++ reply "226" "Closing data connection; transfer complete."++cmd_list :: FTPBackend m => Command m+cmd_list dir = do+ dir' <- ftpAbsolute (decode dir)+ runTransfer $ \ad -> list dir' $$ (appSink ad)++cmd_nlst :: FTPBackend m => Command m+cmd_nlst dir = do+ dir' <- ftpAbsolute (decode dir)+ runTransfer $ \ad -> nlst dir' $$ (appSink ad)++cmd_noop :: FTPBackend m => Command m+cmd_noop _ = reply "200" "OK"++cmd_dele :: FTPBackend m => Command m+cmd_dele "" = reply "501" "Filename required"+cmd_dele name = do+ ftpAbsolute (decode name) >>= lift . dele+ reply "250" $ "File " ++ name ++ " deleted."++cmd_retr :: FTPBackend m => Command m+cmd_retr "" = reply "501" "Filename required"+cmd_retr name = do+ name' <- ftpAbsolute (decode name)+ runTransfer $ \ad -> download name' $$ (appSink ad)++cmd_stor :: FTPBackend m => Command m+cmd_stor "" = reply "501" "Filename required"+cmd_stor name = do+ name' <- ftpAbsolute (decode name)+ runTransfer $ \ad -> (appSource ad) $$ upload name'++cmd_syst :: FTPBackend m => Command m+cmd_syst _ = reply "215" "UNIX Type: L8"++cmd_mkd :: FTPBackend m => Command m+cmd_mkd "" = reply "501" "Directory name required"+cmd_mkd dir = do+ dir' <- ftpAbsolute (decode dir)+ lift $ mkd dir'+ reply "257" $ "\"" ++ encode dir' ++ "\" created."++cmd_rnfr, cmd_rnto :: FTPBackend m => Command m+cmd_rnfr "" = reply "501" "Filename required"+cmd_rnfr name = do+ FTP $ modify $ \st -> st { ftpRename = Just (decode name) }+ reply "350" $ "Noted rename from "++name++"; please send RNTO."++cmd_rnto "" = reply "501" "Filename required"+cmd_rnto name = do+ mfromname <- FTP (gets ftpRename)+ case mfromname of+ Nothing ->+ reply "503" "RNFR required before RNTO"+ Just fromname -> do+ FTP $ modify $ \st -> st { ftpRename = Nothing }+ fname <- ftpAbsolute fromname+ tname <- ftpAbsolute (decode name)+ lift (rename fname tname)+ reply "250" $ "File "++encode fromname++" renamed to "++name++cmd_rmd :: FTPBackend m => Command m+cmd_rmd "" = reply "501" "Filename required"+cmd_rmd dir = do+ ftpAbsolute (decode dir) >>= lift . rmd+ reply "250" $ "Directory " ++ dir ++ " removed."++cmd_stat :: FTPBackend m => Command m+cmd_stat _ = do+ st <- FTP get+ reply "211" $ S.pack $ P.unlines+ [" *** Sever statistics and information"+ ," *** Please type HELP for more details"+ ,""+ ,"Server Software : haskell-ftp, https://github.com/yihuang/haskell-ftp"+ ,"Connected From : ", P.show (ftpRemote st)+ ,"Connected To : ", P.show (ftpLocal st)+ ,"Data Transfer Type : ", P.show (ftpDataType st)+ ,"Auth Status : ", P.show (ftpUser st)+ ,"End of status."+ ]++cmd_mode, cmd_stru :: FTPBackend m => Command m+cmd_mode m =+ case m of+ "S" -> reply "200" "Mode is Stream."+ _ -> reply "504" $ "Mode \"" ++ m ++ "\" not supported."++cmd_stru s =+ case s of+ "F" -> reply "200" "Structure is File."+ _ -> reply "504" $ "Structure \"" ++ s ++ "\" not supported."++commands :: FTPBackend m => [(CI.CI ByteString, Command m)]+commands =+ [("USER", cmd_user)+ ,("PASS", const $ reply "530" "Out of sequence PASS command")+ ,("QUIT", const $ reply "221" "OK, Goodbye." >> throw ApplicationQuit)+ --,(Command "HELP" (help, help_help))+ ,("CWD", login_required cmd_cwd)+ ,("PWD", login_required cmd_pwd)+ ,("CDUP", login_required cmd_cdup)+ ,("PASV", login_required cmd_pasv)+ ,("PORT", login_required cmd_port)+ ,("LIST", login_required cmd_list)+ ,("TYPE", login_required cmd_type)+ ,("MKD", login_required cmd_mkd)+ ,("NOOP", login_required cmd_noop)+ ,("RNFR", login_required cmd_rnfr)+ ,("RNTO", login_required cmd_rnto)+ ,("DELE", login_required cmd_dele)+ ,("RMD", login_required cmd_rmd)+ ,("RETR", login_required cmd_retr)+ ,("STOR", login_required cmd_stor)+ ,("STAT", login_required cmd_stat)+ ,("SYST", login_required cmd_syst)+ ,("NLST", login_required cmd_nlst)+ ,("MODE", login_required cmd_mode)+ ,("STRU", login_required cmd_stru)+ ]++commandLoop :: FTPBackend m => FTP m ()+commandLoop = do+ (cmd, arg) <- wait getCommand+ lift (ftplog $ CI.original cmd++" "++arg)+ case lookup cmd commands of+ Just cmd' -> do+ continue <- (cmd' arg >> return True)+ `Lifted.catch` (\(_::ApplicationQuit) -> return False)+ `Lifted.catch` (\(ex::SomeException) -> do+ reply "502" (S.pack $ P.show ex)+ return True+ )+ when continue commandLoop+ Nothing -> do+ reply "502" $ "Unrecognized command " ++ CI.original cmd+ commandLoop
+ Network/FTP/Monad.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings, MultiParamTypeClasses, FlexibleContexts, TypeFamilies #-}+module Network.FTP.Monad where++import qualified Prelude as P+import BasicPrelude+import Filesystem.Path.CurrentOS (parent)++import qualified Data.ByteString.Char8 as S+import qualified Data.CaseInsensitive as CI+import Data.Conduit++import Control.Monad.Trans.State (StateT, runStateT, gets, modify)+import Control.Monad.Base (MonadBase(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Control (MonadBaseControl(..))++import Network.Socket (Socket, SockAddr)+import Network.FTP.Backend (UserId)++data DataChannel = NoChannel+ | PasvChannel Socket+ | PortChannel SockAddr+ deriving (Show)++data DataType = ASCII | Binary+ deriving (Show)++data FTPState m = FTPState+ { ftpSource :: ResumableSource m ByteString -- ^ source for reading request+ , ftpSink :: Sink ByteString m () -- ^ sink for sending respose+ , ftpRemote :: SockAddr -- ^ client address+ , ftpLocal :: SockAddr -- ^ local address+ , ftpChannel :: DataChannel -- ^ ftp data channel+ , ftpDataType :: DataType -- ^ ftp data type+ , ftpRename :: Maybe FilePath -- ^ store from name during renaming.+ , ftpDir :: FilePath -- ^ the ftp virtual directory.+ , ftpUser :: Maybe (UserId m) -- ^ current authenticated user.+ }++defaultFTPState :: ResumableSource m ByteString+ -> Sink ByteString m ()+ -> SockAddr+ -> SockAddr+ -> FTPState m+defaultFTPState src snk remote local =+ FTPState src+ snk+ remote+ local+ NoChannel+ ASCII+ Nothing+ "/"+ Nothing++{-|+ - FTP is a monad transformer that only handles only ftp protocol, and leaves authentication and filesystem details to underlying monad.+ -}+newtype FTP m a = FTP { unFTP :: StateT (FTPState m) m a }+ deriving (Functor, Applicative, Monad, MonadIO)++instance MonadTrans FTP where+ lift m = FTP (lift m)++instance MonadBase IO m => MonadBase IO (FTP m) where+ liftBase = FTP . liftBase++instance MonadBaseControl IO m => MonadBaseControl IO (FTP m) where+ newtype StM (FTP m) a = FTPStM { unFTPStM :: StM (StateT (FTPState m) m) a }+ liftBaseWith f = FTP . liftBaseWith $ \runInBase -> f $ liftM FTPStM . runInBase . unFTP+ restoreM = FTP . restoreM . unFTPStM++runFTP :: FTPState m -> FTP m a -> m (a, FTPState m)+runFTP s m = runStateT (unFTP m) s++{-|+ - Consume request source, store the modified ResumableSource into state monad.+ -}+consumeSource :: Monad m+ => (ResumableSource m ByteString -> FTP m (ResumableSource m ByteString, a))+ -> FTP m a+consumeSource f = do+ src <- FTP (gets ftpSource)+ (src', r) <- f src+ FTP $ modify $ \st -> st{ ftpSource = src' }+ return r++{-|+ - Run a `Sink` to parse request.+ - e.g. `wait getCommand :: FTP m (ByteString, ByteString)`+ -}+wait :: Monad m => Sink ByteString m b -> FTP m b+wait snk = consumeSource $ \src -> lift (src $$++ snk)++{-|+ - Get a line, fail when connection closed. The stream is assumed to be individual lines produced by upstream conduit.+ -}+headOrFail :: Monad m => GSink a m a+headOrFail = await >>= maybe (fail "connection closed") return++{-|+ - Parse a request command.+ -}+getCommand :: Monad m => GSink ByteString m (CI.CI ByteString, ByteString)+getCommand = do+ s' <- headOrFail+ let (cmd', arg) = S.span (\c -> c/=' ' && c/='\r') s'+ arg' = if S.length arg < 2+ then S.empty+ else S.tail (S.init arg) -- strip heading ' ' and trailing '\r'+ return (CI.mk cmd', arg')++{-|+ - Parse a command, if it's not the expected one, then fail.+ -}+expect :: (Monad m) => CI.CI ByteString -> GSink ByteString m ByteString+expect s = do+ (cmd, arg) <- getCommand+ if s==cmd+ then return arg+ else fail $ concat ["expect ", P.show s, " but got ", P.show cmd, " ."]++{-|+ - Send raw message to client+ -}+send :: Monad m => ByteString -> FTP m ()+send s = do+ snk <- FTP $ gets ftpSink+ lift (yield s $$ snk)++{-|+ - Send reply code and message to client, support multiline message.+ -}+reply :: Monad m => ByteString -> ByteString -> FTP m ()+reply code msg =+ send . S.concat $ build code (S.lines msg) ++ ["\r\n"]+ where+ build c [] = [c, " "]+ build c [s] = [c, " ", s]+ build c (s:ss) = [c, "-", s] ++ build c ss++{-|+ - Change working directory+ -}+cwd :: Monad m => FilePath -> FTP m ()+cwd ".." = FTP (modify $ \st -> st{ftpDir = parent (ftpDir st)})+cwd d = FTP (modify $ \st -> st{ftpDir = ftpDir st </> d})++{-|+ - Print working directory+ -}+pwd :: Monad m => FTP m FilePath+pwd = FTP (gets ftpDir)++{-|+ - Make absolute path.+ -}+ftpAbsolute :: Monad m => FilePath -> FTP m FilePath+ftpAbsolute path = do+ dir <- FTP (gets ftpDir)+ return (dir </> path)
+ Network/FTP/Server.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+module Network.FTP.Server+ ( ftpServer+ ) where++{-| Run ftp server to backend monad.+ -}++import qualified Prelude as P+import BasicPrelude++import Data.Conduit ( ($=), ($$+) )+import qualified Data.Conduit.Binary as C+import Data.Conduit.Network (Application, appSource, appSink, appSockAddr, appLocalAddr)++import Network.FTP.Monad (runFTP, reply, defaultFTPState)+import Network.FTP.Backend (FTPBackend)+import Network.FTP.Commands (commandLoop)++{-| Main ftp server application, should be runned by `runTCPServer`.+ -}+ftpServer :: FTPBackend m => Application m+ftpServer ad = do+ let local = fromMaybe (error "Need to runTCPServer with serverNeedLocalAddr=True.") (appLocalAddr ad)+ (src', _) <- appSource ad $= C.lines $$+ return ()+ void $ runFTP (defaultFTPState src' (appSink ad) (appSockAddr ad) local) $ do+ reply "220" "Welcome to Haskell Ftp Server."+ commandLoop
+ Network/FTP/Socket.hs view
@@ -0,0 +1,110 @@+module Network.FTP.Socket+ ( startPasvServer+ , toPortString+ , fromPortString+ , module Network.Socket+ , module Network.BSD+ ) where++{-|+ - Network Utils.+ -}++import Data.List (intercalate)+import Data.Word+import Data.Bits+import Control.Exception (bracketOnError)+import Network.Socket+import Network.BSD (getProtocolNumber)++startPasvServer :: SockAddr -> IO Socket+startPasvServer (SockAddrInet _ host) = do+ proto <- getProtocolNumber "tcp"+ bracketOnError+ (socket AF_INET Stream proto)+ sClose+ (\sock -> do+ setSocketOption sock ReuseAddr 0+ bindSocket sock (SockAddrInet aNY_PORT host)+ listen sock 1+ return sock+ )+startPasvServer _ = fail "Require IPv4 sockets"++{- | Converts a socket address to a string suitable for a PORT command.++Example:++> toPortString (SockAddrInet (PortNum 0x1234) (0xaabbccdd)) ->+> "170,187,204,221,18,52"+-}+toPortString :: SockAddr -> IO String+toPortString (SockAddrInet port hostaddr) =+ let wport = fromIntegral port::Word16+ in do+ hn <- inet_ntoa hostaddr+ return (replace '.' ',' hn ++ "," ++ + (intercalate "," . map show . getBytes $ wport))+toPortString _ = + error "toPortString only works on AF_INET addresses"++-- | Converts a port string to a socket address. This is the inverse calculation of 'toPortString'.+fromPortString :: String -> IO SockAddr+fromPortString instr =+ let inbytes = split ',' instr+ (hostpart, portpart) = splitAt 4 inbytes+ hostname = intercalate "." hostpart+ portbytes = map read portpart+ in+ do+ addr <- inet_addr hostname+ return $ SockAddrInet (fromInteger $ fromBytes portbytes) addr++-- copied from cgi+--+-- * Utilities+--++-- | Replaces all instances of a value in a list by another value.+replace :: Eq a =>+ a -- ^ Value to look for+ -> a -- ^ Value to replace it with+ -> [a] -- ^ Input list+ -> [a] -- ^ Output list+replace x y = map (\z -> if z == x then y else z)++-- copied from MissingH+{- | Returns a list representing the bytes that comprise a data type.++Example:++> getBytes (0x12345678::Int) -> [0x12, 0x34, 0x56, 0x78]+-}+getBytes :: (Integral a, Bounded a, Bits a) => a -> [a]+getBytes input = + let getByte _ 0 = []+ getByte x remaining = (x .&. 0xff) : getByte (shiftR x 8) (remaining - 1)+ in+ if (bitSize input `mod` 8) /= 0+ then error "Input data bit size must be a multiple of 8"+ else reverse $ getByte input (bitSize input `div` 8)++{- | The opposite of 'getBytes', this function builds a number based on+its component bytes.++Results are undefined if any components of the input list are > 0xff!++-}++fromBytes :: (Bits a) => [a] -> a+fromBytes =+ foldl (\accum x -> shiftL accum 8 .|. x) 0++-- | split a list by sperator+split :: Eq a => a -> [a] -> [[a]]+split _ [] = []+split sep xs = s : split sep rest'+ where (s, rest) = break (==sep) xs+ rest' = case rest of+ (_:r) -> r+ _ -> []
+ Network/FTP/Utils.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.FTP.Utils where++import qualified Prelude+import BasicPrelude+import qualified Filesystem.Path as Path+import qualified Filesystem.Path.CurrentOS as Path+import qualified Data.Text.Encoding as T++-- | drop root+dropHeadingPathSeparator :: FilePath -> FilePath+dropHeadingPathSeparator p = fromMaybe p $ Path.stripPrefix "/" p++-- | encode file path.+encode :: FilePath -> ByteString+encode = T.encodeUtf8 . either id id . Path.toText++-- | decode file path.+decode :: ByteString -> FilePath+decode = Path.fromText . T.decodeUtf8
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haskell-ftp.cabal view
@@ -0,0 +1,99 @@+-- Initial haskell-ftp.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++-- The name of the package.+name: haskell-ftp++-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.1.0.0++-- A short (one-line) description of the package.+synopsis: A Haskell ftp server with configurable backend.++-- A longer description of the package.+description: https://github.com/yihuang/haskell-ftp++-- The license under which the package is released.+license: BSD3++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: yihuang++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer: yi.codeplayer@gmail.com++-- A copyright notice.+-- copyright: ++category: Network++build-type: Simple++-- Constraint on the version of Cabal needed to build this package.+cabal-version: >=1.8++source-repository head+ type: git+ location: git://github.com/yihuang/haskell-ftp++library+ ghc-options: -Wall -O2+ -- Modules exported by the library.+ exposed-modules: Network.FTP.Server+ , Network.FTP.Monad+ , Network.FTP.Commands+ , Network.FTP.Socket+ , Network.FTP.Utils+ , Network.FTP.Backend+ , Network.FTP.Backend.FileSystem+ + -- Modules included in this library but not exported.+ -- other-modules: + + -- Other library packages from which modules are imported.+ build-depends: base ==4.*+ , basic-prelude ==0.3.*+ , lifted-base ==0.1.*+ , monad-control ==0.3.*+ , transformers >=0.3+ , transformers-base >=0.4+ , case-insensitive >=0.3+ , text >= 0.11+ , bytestring >=0.9+ , unix ==2.5.*+ , directory ==1.1.*+ , system-filepath ==0.4.*+ , network ==2.3.*+ , conduit ==0.5.*+ , network-conduit >=0.6.1+ , process-conduit ==0.5.*++executable simple-ftp-server+ ghc-options: -Wall -O2+ main-is: Ftp.hs+ build-depends: base ==4.*+ , basic-prelude ==0.3.*+ , lifted-base ==0.1.*+ , monad-control ==0.3.*+ , transformers >=0.3+ , transformers-base >=0.4+ , case-insensitive >=0.3+ , text >= 0.11+ , bytestring >=0.9+ , unix ==2.5.*+ , directory ==1.1.*+ , system-filepath ==0.4.*+ , network ==2.3.*+ , conduit ==0.5.*+ , network-conduit >=0.6.1+ , process-conduit ==0.5.*+