{- arch-tag: FTP server support
Copyright (C) 2004 John Goerzen <jgoerzen@complete.org>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
-}

{- |
   Module     : Network.FTP.Server
   Copyright  : Copyright (C) 2004 John Goerzen
   License    : GNU LGPL, version 2.1 or above

   Maintainer : John Goerzen <jgoerzen@complete.org> 
   Stability  : experimental
   Portability: systems with networking

This module provides a server-side interface to the File Transfer Protocol
as defined by:

 * RFC959, basic protocol

 * RFC1123, clarifications

 * RFC1579, passive mode discussion

Written by John Goerzen, jgoerzen\@complete.org

This is a modular FTP server implementation in pure Haskell.  It is highly
adaptable to many different tasks, and can serve up not only real files
and directories, but also virtually any data structure you could represent
as a filesystem.  It does this by using the
"System.IO.HVFS" and "System.IO.HVIO" modules.

In addition, basic networking and multitasking configuration is handled
via "Network.SocketServer" and logging via 
"System.Log.Logger".

This module is believed to be secure, but it not believed to be robust enough
for use on a public FTP server.  In particular, it may be vulnerable to denial
of service attacks due to no timeouts or restrictions on data size, and
error catching is not yet completely pervasive.  These will be fixed in time.
Your patches would also be welcomed.

Here is an example server that serves up the entire local filesystem
in a read-only manner:

>import Network.FTP.Server
>import Network.SocketServer
>import System.Log.Logger
>import System.IO.HVFS
>import System.IO.HVFS.Combinators
>
>main = do
>       updateGlobalLogger "" (setLevel DEBUG)
>       updateGlobalLogger "Network.FTP.Server" (setLevel DEBUG)
>       let opts = (simpleTCPOptions 12345) {reuse = True}
>       serveTCPforever opts $
>            threadedHandler $
>            loggingHandler "" INFO $
>            handleHandler $
>            anonFtpHandler (HVFSReadOnly SystemFS)

Hint: if you wantto serve up only part of a filesystem, see
'System.IO.HVFS.Combinators.newHVFSChroot'.
-}

module Network.FTP.Server(
                                   anonFtpHandler
                                  )
where
import Network.FTP.Server.Parser
import Network.FTP.Client.Parser
import Network.BSD
import Network.Socket
import qualified Network
import System.IO.Utils
import System.IO.Error
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(finally)
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

{- | Send a reply code, handling multi-line text as necessary. -}
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))

{- | Main FTP handler; pass the result of applying this to one argument to 
'Network.SocketServer.handleHandler' -}

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 <- tryIOError testAction
       case result of
         Left err -> 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))
                            hClose fh
                            return False
        in do continue <- (flip catchIOError) 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                      -- Close any existing connection
           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                      -- Close any existing connection
       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 _ =
    -- I have no idea what this L8 means, but everyone else seems to do
    -- this, so I do too..
    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
