diff --git a/Ftp.hs b/Ftp.hs new file mode 100644 --- /dev/null +++ b/Ftp.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Network/FTP/Backend.hs b/Network/FTP/Backend.hs new file mode 100644 --- /dev/null +++ b/Network/FTP/Backend.hs @@ -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. diff --git a/Network/FTP/Backend/FileSystem.hs b/Network/FTP/Backend/FileSystem.hs new file mode 100644 --- /dev/null +++ b/Network/FTP/Backend/FileSystem.hs @@ -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 diff --git a/Network/FTP/Commands.hs b/Network/FTP/Commands.hs new file mode 100644 --- /dev/null +++ b/Network/FTP/Commands.hs @@ -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 diff --git a/Network/FTP/Monad.hs b/Network/FTP/Monad.hs new file mode 100644 --- /dev/null +++ b/Network/FTP/Monad.hs @@ -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) diff --git a/Network/FTP/Server.hs b/Network/FTP/Server.hs new file mode 100644 --- /dev/null +++ b/Network/FTP/Server.hs @@ -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 diff --git a/Network/FTP/Socket.hs b/Network/FTP/Socket.hs new file mode 100644 --- /dev/null +++ b/Network/FTP/Socket.hs @@ -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 + _ -> [] diff --git a/Network/FTP/Utils.hs b/Network/FTP/Utils.hs new file mode 100644 --- /dev/null +++ b/Network/FTP/Utils.hs @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haskell-ftp.cabal b/haskell-ftp.cabal new file mode 100644 --- /dev/null +++ b/haskell-ftp.cabal @@ -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.* +