module Network.FTP.Server(
anonFtpHandler
)
where
import Network.FTP.Server.Parser
import Network.FTP.Client.Parser
import Network.BSD
import Network.Socket
import System.IO.Utils
import System.Log.Logger
import Network.Utils
import Network.SocketServer
import Data.String.Utils
import System.IO.HVIO
import System.IO.HVFS
import System.IO.HVFS.InstanceHelpers
import System.IO.HVFS.Utils
import Text.Printf
import Data.Char
import Data.IORef
import Data.List
import Control.Exception (try, catch, finally, SomeException)
import System.IO
data DataType = ASCII | Binary
deriving (Eq, Show)
data AuthState = NoAuth
| User String
| Authenticated String
deriving (Eq, Show)
data DataChan = NoChannel
| PassiveMode SocketServer
| PortMode SockAddr
data FTPState = FTPState
{ auth :: IORef AuthState,
datatype :: IORef DataType,
rename :: IORef (Maybe String),
datachan :: IORef DataChan,
local :: SockAddr,
remote :: SockAddr}
data FTPServer = forall a. HVFSOpenable a => FTPServer Handle a FTPState
s_crlf = "\r\n"
logname = "Network.FTP.Server"
ftpPutStrLn :: FTPServer -> String -> IO ()
ftpPutStrLn (FTPServer h _ _) text =
do hPutStr h (text ++ s_crlf)
hFlush h
sendReply :: FTPServer -> Int -> String -> IO ()
sendReply h codei text =
let codes = printf "%03d" codei
writethis [] = ftpPutStrLn h (codes ++ " ")
writethis [item] = ftpPutStrLn h (codes ++ " " ++ item)
writethis (item:xs) = do ftpPutStrLn h (codes ++ "-" ++ item)
writethis xs
in
writethis (map (rstrip) (lines text))
anonFtpHandler :: forall a. HVFSOpenable a => a -> Handle -> SockAddr -> SockAddr -> IO ()
anonFtpHandler f h saremote salocal =
let serv r = FTPServer h f r
in
traplogging logname NOTICE "" $
do authr <- newIORef (NoAuth)
typer <- newIORef ASCII
renamer <- newIORef (Nothing::Maybe String)
chanr <- newIORef (NoChannel)
let s = serv (FTPState {auth = authr, datatype = typer,
rename = renamer, datachan = chanr,
local = salocal, remote = saremote})
sendReply s 220 "Welcome to Network.FTP.Server."
commandLoop s
type CommandHandler = FTPServer -> String -> IO Bool
data Command = Command String (CommandHandler, (String, String))
instance Eq Command where
(Command x _) == (Command y _) = x == y
instance Ord Command where
compare (Command x _) (Command y _) = compare x y
trapIOError :: FTPServer -> IO a -> (a -> IO Bool) -> IO Bool
trapIOError h testAction remainingAction =
do result <- try testAction
case result of
Left (err::SomeException) -> do sendReply h 550 (show err)
return True
Right result -> remainingAction result
forceLogin :: CommandHandler -> CommandHandler
forceLogin func h@(FTPServer _ _ state) args =
do state <- readIORef (auth state)
case state of
Authenticated _ -> func h args
x -> do sendReply h 530 "Command not possible in non-authenticated state."
return True
commands :: [Command]
commands =
[(Command "HELP" (cmd_help, help_help))
,(Command "QUIT" (cmd_quit, help_quit))
,(Command "USER" (cmd_user, help_user))
,(Command "PASS" (cmd_pass, help_pass))
,(Command "CWD" (forceLogin cmd_cwd, help_cwd))
,(Command "CDUP" (forceLogin cmd_cdup, help_cdup))
,(Command "TYPE" (forceLogin cmd_type, help_type))
,(Command "NOOP" (forceLogin cmd_noop, help_noop))
,(Command "RNFR" (forceLogin cmd_rnfr, help_rnfr))
,(Command "RNTO" (forceLogin cmd_rnto, help_rnto))
,(Command "DELE" (forceLogin cmd_dele, help_dele))
,(Command "RMD" (forceLogin cmd_rmd, help_rmd))
,(Command "MKD" (forceLogin cmd_mkd, help_mkd))
,(Command "PWD" (forceLogin cmd_pwd, help_pwd))
,(Command "MODE" (forceLogin cmd_mode, help_mode))
,(Command "STRU" (forceLogin cmd_stru, help_stru))
,(Command "PASV" (forceLogin cmd_pasv, help_pasv))
,(Command "PORT" (forceLogin cmd_port, help_port))
,(Command "RETR" (forceLogin cmd_retr, help_retr))
,(Command "STOR" (forceLogin cmd_stor, help_stor))
,(Command "STAT" (forceLogin cmd_stat, help_stat))
,(Command "SYST" (forceLogin cmd_syst, help_syst))
,(Command "NLST" (forceLogin cmd_nlst, help_nlst))
,(Command "LIST" (forceLogin cmd_list, help_list))
]
commandLoop :: FTPServer -> IO ()
commandLoop h@(FTPServer fh _ _) =
let errorhandler e = do noticeM logname
("Closing due to error: " ++ (show (e::SomeException)))
hClose fh
return False
in do continue <- (flip catch) errorhandler
(do x <- parseCommand fh
case x of
Left err -> do sendReply h 500 $
" Couldn't parse command: " ++ (show err)
return True
Right (cmd, args) ->
case lookupC cmd commands of
Nothing -> do sendReply h 502 $
"Unrecognized command " ++ cmd
return True
Just (Command _ hdlr) -> (fst hdlr) h args
)
if continue
then commandLoop h
else return ()
lookupC cmd cl = find (\(Command x _) -> x == cmd) cl
help_quit =
("Terminate the session",
"")
cmd_quit :: CommandHandler
cmd_quit h args =
do sendReply h 221 "OK, Goodbye."
return False
help_user =
("Provide a username",
unlines $
["USER username will provide the username for authentication."
,"It should be followed by a PASS command to finish the authentication."
])
cmd_user :: CommandHandler
cmd_user h@(FTPServer _ _ state) passedargs =
let args = strip passedargs
in
case args of
"anonymous" -> do sendReply h 331 "User name accepted; send password."
writeIORef (auth state) (User args)
return True
_ -> do sendReply h 530 "Unrecognized user name; please try \"anonymous\""
writeIORef (auth state) NoAuth
return True
help_pass =
("Provide a password",
"PASS password will provide the password for authentication.")
cmd_pass :: CommandHandler
cmd_pass h@(FTPServer _ _ state) passedargs =
do curstate <- readIORef (auth state)
case curstate of
User "anonymous" ->
do sendReply h 230 "Anonymous login successful."
writeIORef (auth state) (Authenticated "anonymous")
infoM logname "Anonymous authentication successful"
return True
_ -> do sendReply h 530 "Out of sequence PASS command"
return True
help_cwd =
("Change working directory",
unlines $
["Syntax: CWD cwd"
,""
,"Changes the working directory to the specified item"])
cmd_cwd :: CommandHandler
cmd_cwd h@(FTPServer _ fs _) args =
do trapIOError h (vSetCurrentDirectory fs args)
$ \_ -> do
newdir <- vGetCurrentDirectory fs
sendReply h 250 $ "New directory now " ++ newdir
return True
help_cdup =
("Change to parent directory", "Same as CWD ..")
cmd_cdup h _ = cmd_cwd h ".."
help_type =
("Change the type of data transfer", "Valid args are A, AN, and I")
cmd_type :: CommandHandler
cmd_type h@(FTPServer _ _ state) args =
let changetype newt =
do oldtype <- readIORef (datatype state)
writeIORef (datatype state) newt
sendReply h 200 $ "Type changed from " ++ show oldtype ++
" to " ++ show newt
return True
in case args of
"I" -> changetype Binary
"L 8" -> changetype Binary
"A" -> changetype ASCII
"AN" -> changetype ASCII
"AT" -> changetype ASCII
_ -> do sendReply h 504 $ "Type \"" ++ args ++ "\" not supported."
return True
closeconn :: FTPServer -> IO ()
closeconn h@(FTPServer _ _ state) =
do dc <- readIORef (datachan state)
writeIORef (datachan state) NoChannel
help_port = ("Initiate a port-mode connection", "")
cmd_port :: CommandHandler
cmd_port h@(FTPServer _ _ state) args =
let doIt clientsa =
do writeIORef (datachan state) (PortMode clientsa)
str <- showSockAddr clientsa
sendReply h 200 $ "OK, later I will connect to " ++ str
return True
in
do closeconn h
trapIOError h (fromPortString args) $ (\clientsa ->
case clientsa of
SockAddrInet _ ha ->
case (local state) of
SockAddrInet _ ha2 -> if ha /= ha2
then do sendReply h 501 "Will only connect to same client as command channel."
return True
else doIt clientsa
_ -> do sendReply h 501 "Require IPv4 on client"
return True
_ -> do sendReply h 501 "Require IPv4 in specified address"
return True
)
runDataChan :: FTPServer -> (FTPServer -> Socket -> IO ()) -> IO ()
runDataChan h@(FTPServer _ _ state) func =
do chan <- readIORef (datachan state)
case chan of
NoChannel -> fail "Can't connect when no data channel exists"
PassiveMode ss -> do finally (handleOne ss (\sock _ _ -> func h sock))
(do closeSocketServer ss
closeconn h
)
PortMode sa -> do proto <- getProtocolNumber "tcp"
s <- socket AF_INET Stream proto
connect s sa
finally (func h s) $ closeconn h
help_pasv = ("Initiate a passive-mode connection", "")
cmd_pasv :: CommandHandler
cmd_pasv h@(FTPServer _ _ state) args =
do closeconn h
addr <- case (local state) of
(SockAddrInet _ ha) -> return ha
_ -> fail "Require IPv4 sockets"
let ssopts = InetServerOptions
{ listenQueueSize = 1,
portNumber = aNY_PORT,
interface = addr,
reuse = False,
family = AF_INET,
sockType = Stream,
protoStr = "tcp"
}
ss <- setupSocketServer ssopts
sa <- getSocketName (sockSS ss)
portstring <- toPortString sa
sendReply h 227 $ "Entering passive mode (" ++ portstring ++ ")"
writeIORef (datachan state) (PassiveMode ss)
return True
help_noop = ("Do nothing", "")
cmd_noop :: CommandHandler
cmd_noop h _ =
do sendReply h 200 "OK"
return True
help_rnfr = ("Specify FROM name for a file rename", "")
cmd_rnfr :: CommandHandler
cmd_rnfr h@(FTPServer _ _ state) args =
if length args < 1
then do sendReply h 501 "Filename required"
return True
else do writeIORef (rename state) (Just args)
sendReply h 350 "Noted rename from name; please send RNTO."
return True
help_stor = ("Upload a file", "")
cmd_stor :: CommandHandler
cmd_stor h@(FTPServer _ fs state) args =
let datamap :: [String] -> [String]
datamap instr =
let linemap :: String -> String
linemap x = if endswith "\r" x
then take ((length x) 1) x
else x
in map linemap instr
runit fhencap _ sock =
case fhencap of
HVFSOpenEncap fh ->
do readh <- socketToHandle sock ReadMode
mode <- readIORef (datatype state)
case mode of
ASCII -> finally (hLineInteract readh fh datamap)
(hClose readh)
Binary -> finally (do vSetBuffering fh (BlockBuffering (Just 4096))
hCopy readh fh
) (hClose readh)
in
if length args < 1
then do sendReply h 501 "Filename required"
return True
else trapIOError h (vOpen fs args WriteMode)
(\fhencap ->
trapIOError h (do sendReply h 150 "File OK; about to open data channel"
runDataChan h (runit fhencap)
)
(\_ ->
do case fhencap of
HVFSOpenEncap fh -> vClose fh
sendReply h 226 "Closing data connection; transfer complete."
return True
)
)
rtransmitString :: String -> FTPServer -> Socket -> IO ()
rtransmitString thestr (FTPServer _ _ state) sock =
let fixlines :: [String] -> [String]
fixlines x = map (\y -> y ++ "\r") x
copyit h =
hPutStr h $ unlines . fixlines . lines $ thestr
in
do writeh <- socketToHandle sock WriteMode
hSetBuffering writeh (BlockBuffering (Just 4096))
mode <- readIORef (datatype state)
case mode of
ASCII -> finally (copyit writeh)
(hClose writeh)
Binary -> finally (hPutStr writeh thestr)
(hClose writeh)
rtransmitH :: HVFSOpenEncap -> FTPServer -> Socket -> IO ()
rtransmitH fhencap h sock =
case fhencap of
HVFSOpenEncap fh ->
finally (do c <- vGetContents fh
rtransmitString c h sock
) (vClose fh)
genericTransmit :: FTPServer -> a -> (a -> FTPServer -> Socket -> IO ()) -> IO Bool
genericTransmit h dat func =
trapIOError h
(do sendReply h 150 "I'm going to open the data channel now."
runDataChan h (func dat)
) (\_ ->
do sendReply h 226 "Closing data connection; transfer complete."
return True
)
genericTransmitHandle :: FTPServer -> HVFSOpenEncap -> IO Bool
genericTransmitHandle h dat =
genericTransmit h dat rtransmitH
genericTransmitString :: FTPServer -> String -> IO Bool
genericTransmitString h dat =
genericTransmit h dat rtransmitString
help_retr = ("Retrieve a file", "")
cmd_retr :: CommandHandler
cmd_retr h@(FTPServer _ fs state) args =
if length args < 1
then do sendReply h 501 "Filename required"
return True
else trapIOError h (vOpen fs args ReadMode)
(\fhencap -> genericTransmitHandle h fhencap)
help_rnto = ("Specify TO name for a file name", "")
cmd_rnto :: CommandHandler
cmd_rnto h@(FTPServer _ fs state) args =
if length args < 1
then do sendReply h 501 "Filename required"
return True
else do fr <- readIORef (rename state)
case fr of
Nothing -> do sendReply h 503 "RNFR required before RNTO"
return True
Just fromname ->
do writeIORef (rename state) Nothing
trapIOError h (vRenameFile fs fromname args)
$ \_ -> do sendReply h 250
("File " ++ fromname ++
" renamed to " ++ args)
return True
help_dele = ("Delete files", "")
cmd_dele :: CommandHandler
cmd_dele h@(FTPServer _ fs _) args =
if length args < 1
then do sendReply h 501 "Filename required"
return True
else trapIOError h (vRemoveFile fs args) $
\_ -> do sendReply h 250 $ "File " ++ args ++ " deleted."
return True
help_nlst = ("Get plain listing of files", "")
cmd_nlst :: CommandHandler
cmd_nlst h@(FTPServer _ fs _) args =
let fn = case args of
"" -> "."
x -> x
in
trapIOError h (vGetDirectoryContents fs fn)
(\l -> genericTransmitString h (unlines l))
help_list = ("Get an annotated listing of files", "")
cmd_list :: CommandHandler
cmd_list h@(FTPServer _ fs _) args =
let fn = case args of
"" -> "."
x -> x
in
trapIOError h (lsl fs fn)
(\l -> genericTransmitString h l)
help_rmd = ("Remove directory", "")
cmd_rmd :: CommandHandler
cmd_rmd h@(FTPServer _ fs _) args =
if length args < 1
then do sendReply h 501 "Filename required"
return True
else trapIOError h (vRemoveDirectory fs args) $
\_ -> do sendReply h 250 $ "Directory " ++ args ++ " removed."
return True
help_mkd = ("Make directory", "")
cmd_mkd :: CommandHandler
cmd_mkd h@(FTPServer _ fs _) args =
if length args < 1
then do sendReply h 501 "Filename required"
return True
else trapIOError h (vCreateDirectory fs args) $
\_ -> do newname <- getFullPath fs args
sendReply h 257 $ "\"" ++ newname ++ "\" created."
return True
help_pwd = ("Print working directory", "")
cmd_pwd :: CommandHandler
cmd_pwd h@(FTPServer _ fs _) _ =
do d <- vGetCurrentDirectory fs
sendReply h 257 $ "\"" ++ d ++ "\" is the current working directory."
return True
help_mode = ("Provided for compatibility only", "")
cmd_mode :: CommandHandler
cmd_mode h args =
case args of
"S" -> do sendReply h 200 "Mode is Stream."
return True
x -> do sendReply h 504 $ "Mode \"" ++ x ++ "\" not supported."
return True
help_stru = ("Provided for compatibility only", "")
cmd_stru :: CommandHandler
cmd_stru h args =
case args of
"F" -> do sendReply h 200 "Structure is File."
return True
x -> do sendReply h 504 $ "Structure \"" ++ x ++ "\" not supported."
return True
help_syst = ("Display system type", "")
cmd_syst :: CommandHandler
cmd_syst h _ =
do sendReply h 215 "UNIX Type: L8"
return True
help_stat = ("Display sever statistics", "")
cmd_stat :: CommandHandler
cmd_stat h@(FTPServer _ _ state) _ =
do loc <- showSockAddr (local state)
rem <- showSockAddr (remote state)
auth <- readIORef (auth state)
datm <- readIORef (datatype state)
sendReply h 211 $ unlines $
[" *** Sever statistics and information"
," *** Please type HELP for more details"
,""
,"Server Software : MissingH, http://quux.org/devel/missingh"
,"Connected From : " ++ rem
,"Connected To : " ++ loc
,"Data Transfer Type : " ++ (show datm)
,"Auth Status : " ++ (show auth)
,"End of status."]
return True
help_help =
("Display help on available commands",
"When called without arguments, shows a summary of available system\n"
++ "commands. When called with an argument, shows detailed information\n"
++ "on that specific command.")
cmd_help :: CommandHandler
cmd_help h@(FTPServer _ _ state) args =
let genericreply addr = unlines $
[" --- General Help Response ---"
,""
,"Welcome to the FTP server, " ++ addr ++ "."
,"This server is implemented as the Network.FTP.Server"
,"component of the MissingH library. The MissingH library"
,"is available from http://quux.org/devel/missingh."
,""
,""
,"I know of the following commands:"
,concatMap (\ (Command name (_, (summary, _))) -> printf "%-10s %s\n" name summary)
(sort commands)
,""
,"You may type \"HELP command\" for more help on a specific command."
]
in
if args == ""
then do sastr <- showSockAddr (remote state)
sendReply h 214 (genericreply sastr)
return True
else let newargs = map toUpper args
in case lookupC newargs commands of
Nothing -> do
sendReply h 214 $ "No help for \"" ++ newargs
++ "\" is available.\nPlese send HELP"
++ " without arguments for a list of\n"
++ "valid commands."
return True
Just (Command _ (_, (summary, detail))) ->
do sendReply h 214 $ newargs ++ ": " ++ summary ++
"\n\n" ++ detail
return True