{- 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'.
-}moduleNetwork.FTP.Server(anonFtpHandler)whereimportNetwork.FTP.Server.ParserimportNetwork.FTP.Client.ParserimportNetwork.BSDimportNetwork.SocketimportqualifiedNetworkimportSystem.IO.UtilsimportSystem.IO.ErrorimportSystem.Log.LoggerimportNetwork.UtilsimportNetwork.SocketServerimportData.String.UtilsimportSystem.IO.HVIOimportSystem.IO.HVFSimportSystem.IO.HVFS.InstanceHelpersimportSystem.IO.HVFS.UtilsimportText.PrintfimportData.CharimportData.IORefimportData.ListimportControl.Exception(finally)importSystem.IOdataDataType=ASCII|Binaryderiving(Eq,Show)dataAuthState=NoAuth|UserString|AuthenticatedStringderiving(Eq,Show)dataDataChan=NoChannel|PassiveModeSocketServer|PortModeSockAddrdataFTPState=FTPState{auth::IORefAuthState,datatype::IORefDataType,rename::IORef(MaybeString),datachan::IORefDataChan,local::SockAddr,remote::SockAddr}dataFTPServer=foralla.HVFSOpenablea=>FTPServerHandleaFTPStates_crlf="\r\n"logname="Network.FTP.Server"ftpPutStrLn::FTPServer->String->IO()ftpPutStrLn(FTPServerh__)text=dohPutStrh(text++s_crlf)hFlushh{- | Send a reply code, handling multi-line text as necessary. -}sendReply::FTPServer->Int->String->IO()sendReplyhcodeitext=letcodes=printf"%03d"codeiwritethis[]=ftpPutStrLnh(codes++" ")writethis[item]=ftpPutStrLnh(codes++" "++item)writethis(item:xs)=doftpPutStrLnh(codes++"-"++item)writethisxsinwritethis(map(rstrip)(linestext)){- | Main FTP handler; pass the result of applying this to one argument to
'Network.SocketServer.handleHandler' -}anonFtpHandler::foralla.HVFSOpenablea=>a->Handle->SockAddr->SockAddr->IO()anonFtpHandlerfhsaremotesalocal=letservr=FTPServerhfrintraplogginglognameNOTICE""$doauthr<-newIORef(NoAuth)typer<-newIORefASCIIrenamer<-newIORef(Nothing::MaybeString)chanr<-newIORef(NoChannel)lets=serv(FTPState{auth=authr,datatype=typer,rename=renamer,datachan=chanr,local=salocal,remote=saremote})sendReplys220"Welcome to Network.FTP.Server."commandLoopstypeCommandHandler=FTPServer->String->IOBooldataCommand=CommandString(CommandHandler,(String,String))instanceEqCommandwhere(Commandx_)==(Commandy_)=x==yinstanceOrdCommandwherecompare(Commandx_)(Commandy_)=comparexytrapIOError::FTPServer->IOa->(a->IOBool)->IOBooltrapIOErrorhtestActionremainingAction=doresult<-trytestActioncaseresultofLefterr->dosendReplyh550(showerr)returnTrueRightresult->remainingActionresultforceLogin::CommandHandler->CommandHandlerforceLoginfunch@(FTPServer__state)args=dostate<-readIORef(authstate)casestateofAuthenticated_->funchargsx->dosendReplyh530"Command not possible in non-authenticated state."returnTruecommands::[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"(forceLogincmd_cwd,help_cwd)),(Command"CDUP"(forceLogincmd_cdup,help_cdup)),(Command"TYPE"(forceLogincmd_type,help_type)),(Command"NOOP"(forceLogincmd_noop,help_noop)),(Command"RNFR"(forceLogincmd_rnfr,help_rnfr)),(Command"RNTO"(forceLogincmd_rnto,help_rnto)),(Command"DELE"(forceLogincmd_dele,help_dele)),(Command"RMD"(forceLogincmd_rmd,help_rmd)),(Command"MKD"(forceLogincmd_mkd,help_mkd)),(Command"PWD"(forceLogincmd_pwd,help_pwd)),(Command"MODE"(forceLogincmd_mode,help_mode)),(Command"STRU"(forceLogincmd_stru,help_stru)),(Command"PASV"(forceLogincmd_pasv,help_pasv)),(Command"PORT"(forceLogincmd_port,help_port)),(Command"RETR"(forceLogincmd_retr,help_retr)),(Command"STOR"(forceLogincmd_stor,help_stor)),(Command"STAT"(forceLogincmd_stat,help_stat)),(Command"SYST"(forceLogincmd_syst,help_syst)),(Command"NLST"(forceLogincmd_nlst,help_nlst)),(Command"LIST"(forceLogincmd_list,help_list))]commandLoop::FTPServer->IO()commandLooph@(FTPServerfh__)=leterrorhandlere=donoticeMlogname("Closing due to error: "++(showe))hClosefhreturnFalseindocontinue<-(flipcatch)errorhandler(dox<-parseCommandfhcasexofLefterr->dosendReplyh500$" Couldn't parse command: "++(showerr)returnTrueRight(cmd,args)->caselookupCcmdcommandsofNothing->dosendReplyh502$"Unrecognized command "++cmdreturnTrueJust(Command_hdlr)->(fsthdlr)hargs)ifcontinuethencommandLoophelsereturn()lookupCcmdcl=find(\(Commandx_)->x==cmd)clhelp_quit=("Terminate the session","")cmd_quit::CommandHandlercmd_quithargs=dosendReplyh221"OK, Goodbye."returnFalsehelp_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::CommandHandlercmd_userh@(FTPServer__state)passedargs=letargs=strippassedargsincaseargsof"anonymous"->dosendReplyh331"User name accepted; send password."writeIORef(authstate)(Userargs)returnTrue_->dosendReplyh530"Unrecognized user name; please try \"anonymous\""writeIORef(authstate)NoAuthreturnTruehelp_pass=("Provide a password","PASS password will provide the password for authentication.")cmd_pass::CommandHandlercmd_passh@(FTPServer__state)passedargs=docurstate<-readIORef(authstate)casecurstateofUser"anonymous"->dosendReplyh230"Anonymous login successful."writeIORef(authstate)(Authenticated"anonymous")infoMlogname"Anonymous authentication successful"returnTrue_->dosendReplyh530"Out of sequence PASS command"returnTruehelp_cwd=("Change working directory",unlines$["Syntax: CWD cwd","","Changes the working directory to the specified item"])cmd_cwd::CommandHandlercmd_cwdh@(FTPServer_fs_)args=dotrapIOErrorh(vSetCurrentDirectoryfsargs)$\_->donewdir<-vGetCurrentDirectoryfssendReplyh250$"New directory now "++newdirreturnTruehelp_cdup=("Change to parent directory","Same as CWD ..")cmd_cduph_=cmd_cwdh".."help_type=("Change the type of data transfer","Valid args are A, AN, and I")cmd_type::CommandHandlercmd_typeh@(FTPServer__state)args=letchangetypenewt=dooldtype<-readIORef(datatypestate)writeIORef(datatypestate)newtsendReplyh200$"Type changed from "++showoldtype++" to "++shownewtreturnTrueincaseargsof"I"->changetypeBinary"L 8"->changetypeBinary"A"->changetypeASCII"AN"->changetypeASCII"AT"->changetypeASCII_->dosendReplyh504$"Type \""++args++"\" not supported."returnTruecloseconn::FTPServer->IO()closeconnh@(FTPServer__state)=dodc<-readIORef(datachanstate)writeIORef(datachanstate)NoChannelhelp_port=("Initiate a port-mode connection","")cmd_port::CommandHandlercmd_porth@(FTPServer__state)args=letdoItclientsa=dowriteIORef(datachanstate)(PortModeclientsa)str<-showSockAddrclientsasendReplyh200$"OK, later I will connect to "++strreturnTrueindocloseconnh-- Close any existing connectiontrapIOErrorh(fromPortStringargs)$(\clientsa->caseclientsaofSockAddrInet_ha->case(localstate)ofSockAddrInet_ha2->ifha/=ha2thendosendReplyh501"Will only connect to same client as command channel."returnTrueelsedoItclientsa_->dosendReplyh501"Require IPv4 on client"returnTrue_->dosendReplyh501"Require IPv4 in specified address"returnTrue)runDataChan::FTPServer->(FTPServer->Socket->IO())->IO()runDataChanh@(FTPServer__state)func=dochan<-readIORef(datachanstate)casechanofNoChannel->fail"Can't connect when no data channel exists"PassiveModess->dofinally(handleOness(\sock__->funchsock))(docloseSocketServersscloseconnh)PortModesa->doproto<-getProtocolNumber"tcp"s<-socketAF_INETStreamprotoconnectssafinally(funchs)$closeconnhhelp_pasv=("Initiate a passive-mode connection","")cmd_pasv::CommandHandlercmd_pasvh@(FTPServer__state)args=docloseconnh-- Close any existing connectionaddr<-case(localstate)of(SockAddrInet_ha)->returnha_->fail"Require IPv4 sockets"letssopts=InetServerOptions{listenQueueSize=1,portNumber=aNY_PORT,interface=addr,reuse=False,family=AF_INET,sockType=Stream,protoStr="tcp"}ss<-setupSocketServerssoptssa<-getSocketName(sockSSss)portstring<-toPortStringsasendReplyh227$"Entering passive mode ("++portstring++")"writeIORef(datachanstate)(PassiveModess)returnTruehelp_noop=("Do nothing","")cmd_noop::CommandHandlercmd_nooph_=dosendReplyh200"OK"returnTruehelp_rnfr=("Specify FROM name for a file rename","")cmd_rnfr::CommandHandlercmd_rnfrh@(FTPServer__state)args=iflengthargs<1thendosendReplyh501"Filename required"returnTrueelsedowriteIORef(renamestate)(Justargs)sendReplyh350"Noted rename from name; please send RNTO."returnTruehelp_stor=("Upload a file","")cmd_stor::CommandHandlercmd_storh@(FTPServer_fsstate)args=letdatamap::[String]->[String]datamapinstr=letlinemap::String->Stringlinemapx=ifendswith"\r"xthentake((lengthx)-1)xelsexinmaplinemapinstrrunitfhencap_sock=casefhencapofHVFSOpenEncapfh->doreadh<-socketToHandlesockReadModemode<-readIORef(datatypestate)casemodeofASCII->finally(hLineInteractreadhfhdatamap)(hClosereadh)Binary->finally(dovSetBufferingfh(BlockBuffering(Just4096))hCopyreadhfh)(hClosereadh)iniflengthargs<1thendosendReplyh501"Filename required"returnTrueelsetrapIOErrorh(vOpenfsargsWriteMode)(\fhencap->trapIOErrorh(dosendReplyh150"File OK; about to open data channel"runDataChanh(runitfhencap))(\_->docasefhencapofHVFSOpenEncapfh->vClosefhsendReplyh226"Closing data connection; transfer complete."returnTrue))rtransmitString::String->FTPServer->Socket->IO()rtransmitStringthestr(FTPServer__state)sock=letfixlines::[String]->[String]fixlinesx=map(\y->y++"\r")xcopyith=hPutStrh$unlines.fixlines.lines$thestrindowriteh<-socketToHandlesockWriteModehSetBufferingwriteh(BlockBuffering(Just4096))mode<-readIORef(datatypestate)casemodeofASCII->finally(copyitwriteh)(hClosewriteh)Binary->finally(hPutStrwritehthestr)(hClosewriteh)rtransmitH::HVFSOpenEncap->FTPServer->Socket->IO()rtransmitHfhencaphsock=casefhencapofHVFSOpenEncapfh->finally(doc<-vGetContentsfhrtransmitStringchsock)(vClosefh)genericTransmit::FTPServer->a->(a->FTPServer->Socket->IO())->IOBoolgenericTransmithdatfunc=trapIOErrorh(dosendReplyh150"I'm going to open the data channel now."runDataChanh(funcdat))(\_->dosendReplyh226"Closing data connection; transfer complete."returnTrue)genericTransmitHandle::FTPServer->HVFSOpenEncap->IOBoolgenericTransmitHandlehdat=genericTransmithdatrtransmitHgenericTransmitString::FTPServer->String->IOBoolgenericTransmitStringhdat=genericTransmithdatrtransmitStringhelp_retr=("Retrieve a file","")cmd_retr::CommandHandlercmd_retrh@(FTPServer_fsstate)args=iflengthargs<1thendosendReplyh501"Filename required"returnTrueelsetrapIOErrorh(vOpenfsargsReadMode)(\fhencap->genericTransmitHandlehfhencap)help_rnto=("Specify TO name for a file name","")cmd_rnto::CommandHandlercmd_rntoh@(FTPServer_fsstate)args=iflengthargs<1thendosendReplyh501"Filename required"returnTrueelsedofr<-readIORef(renamestate)casefrofNothing->dosendReplyh503"RNFR required before RNTO"returnTrueJustfromname->dowriteIORef(renamestate)NothingtrapIOErrorh(vRenameFilefsfromnameargs)$\_->dosendReplyh250("File "++fromname++" renamed to "++args)returnTruehelp_dele=("Delete files","")cmd_dele::CommandHandlercmd_deleh@(FTPServer_fs_)args=iflengthargs<1thendosendReplyh501"Filename required"returnTrueelsetrapIOErrorh(vRemoveFilefsargs)$\_->dosendReplyh250$"File "++args++" deleted."returnTruehelp_nlst=("Get plain listing of files","")cmd_nlst::CommandHandlercmd_nlsth@(FTPServer_fs_)args=letfn=caseargsof""->"."x->xintrapIOErrorh(vGetDirectoryContentsfsfn)(\l->genericTransmitStringh(unlinesl))help_list=("Get an annotated listing of files","")cmd_list::CommandHandlercmd_listh@(FTPServer_fs_)args=letfn=caseargsof""->"."x->xintrapIOErrorh(lslfsfn)(\l->genericTransmitStringhl)help_rmd=("Remove directory","")cmd_rmd::CommandHandlercmd_rmdh@(FTPServer_fs_)args=iflengthargs<1thendosendReplyh501"Filename required"returnTrueelsetrapIOErrorh(vRemoveDirectoryfsargs)$\_->dosendReplyh250$"Directory "++args++" removed."returnTruehelp_mkd=("Make directory","")cmd_mkd::CommandHandlercmd_mkdh@(FTPServer_fs_)args=iflengthargs<1thendosendReplyh501"Filename required"returnTrueelsetrapIOErrorh(vCreateDirectoryfsargs)$\_->donewname<-getFullPathfsargssendReplyh257$"\""++newname++"\" created."returnTruehelp_pwd=("Print working directory","")cmd_pwd::CommandHandlercmd_pwdh@(FTPServer_fs_)_=dod<-vGetCurrentDirectoryfssendReplyh257$"\""++d++"\" is the current working directory."returnTruehelp_mode=("Provided for compatibility only","")cmd_mode::CommandHandlercmd_modehargs=caseargsof"S"->dosendReplyh200"Mode is Stream."returnTruex->dosendReplyh504$"Mode \""++x++"\" not supported."returnTruehelp_stru=("Provided for compatibility only","")cmd_stru::CommandHandlercmd_struhargs=caseargsof"F"->dosendReplyh200"Structure is File."returnTruex->dosendReplyh504$"Structure \""++x++"\" not supported."returnTruehelp_syst=("Display system type","")cmd_syst::CommandHandlercmd_systh_=-- I have no idea what this L8 means, but everyone else seems to do-- this, so I do too..dosendReplyh215"UNIX Type: L8"returnTruehelp_stat=("Display sever statistics","")cmd_stat::CommandHandlercmd_stath@(FTPServer__state)_=doloc<-showSockAddr(localstate)rem<-showSockAddr(remotestate)auth<-readIORef(authstate)datm<-readIORef(datatypestate)sendReplyh211$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 : "++(showdatm),"Auth Status : "++(showauth),"End of status."]returnTruehelp_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::CommandHandlercmd_helph@(FTPServer__state)args=letgenericreplyaddr=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(\(Commandname(_,(summary,_)))->printf"%-10s %s\n"namesummary)(sortcommands),"","You may type \"HELP command\" for more help on a specific command."]inifargs==""thendosastr<-showSockAddr(remotestate)sendReplyh214(genericreplysastr)returnTrueelseletnewargs=maptoUpperargsincaselookupCnewargscommandsofNothing->dosendReplyh214$"No help for \""++newargs++"\" is available.\nPlese send HELP"++" without arguments for a list of\n"++"valid commands."returnTrueJust(Command_(_,(summary,detail)))->dosendReplyh214$newargs++": "++summary++"\n\n"++detailreturnTrue