{ $Project$ $Workfile$ $Revision$ $DateUTC$ $Id$ This file is part of the Indy (Internet Direct) project, and is offered under the dual-licensing agreement described on the Indy website. (http://www.indyproject.org/) Copyright: (c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved. } { $Log$ } { Rev 1.146 3/23/2005 5:16:56 AM JPMugaas Should compile. Rev 1.145 3/14/05 11:28:50 AM RLebeau Bug fix for CommandSIZE() not checking the FTPFileSystem property. Updated to reflect changes in TIdReply.NumericCode handling. Rev 1.144 3/5/2005 3:33:58 PM JPMugaas Fix for some compiler warnings having to do with TStream.Read being platform specific. This was fixed by changing the Compressor API to use TIdStreamVCL instead of TStream. I also made appropriate adjustments to other units for this. Rev 1.143 11/22/2004 8:29:20 PM JPMugaas Fix for a compiler warning. Rev 1.142 11/22/2004 7:49:36 PM JPMugaas You now can access help before you are logged in. This is done to conform to RFC 959. Rev 1.141 2004.10.27 9:17:48 AM czhower For TIdStrings Rev 1.140 10/26/2004 9:40:42 PM JPMugaas Updated ref. Rev 1.139 9/15/2004 5:01:00 PM DSiders Added localization comments. Rev 1.138 2004.08.13 11:03:22 czhower Removed unused var. Rev 1.137 7/29/2004 1:33:10 AM JPMugaas Reordered AUTH command values for a new property under development. This should make things more logical. Rev 1.136 7/18/2004 3:00:42 PM DSiders Added localization comments. Rev 1.135 7/15/2004 1:33:00 AM JPMugaas Bug fix for error 105. I fixed this by changing data channel command processing. If the command is not ABOR or STAT, the command is put into a FIFO queue. After the data channel operation is completed, the commands from the FIFO queue are processed. I have tested FlashFXP 3.0 RC4 and it does worki as expected. The behavior is also the same as what NcFTPD does with a NOOP being sent during a data transfer. This may also help with FTP command pipelining as proposed by: http://cr.yp.to/ftp/pipelining.html Note that we can not use the regular command handler framework for data channel commands because STAT and ABOR need to be handled IMMEDIATELY. Rev 1.134 7/13/04 9:08:10 PM RLebeau Renamed OnPASV event to OnPASVBeforeBind and added new OnPASVReply event Rev 1.133 7/13/04 8:13:56 PM RLebeau Various changed for DefaultDataPort handling Rev 1.132 7/13/2004 3:34:12 AM JPMugaas CCC command and a few other minor modifications to comply with http://www.ietf.org/internet-drafts/draft-murray-auth-ftp-ssl-14.txt . I also fixed a few minor bugs in the help and a problem with some error replies sending an extra 200 after a 5xxx code messing up some clients. I also expanded the Security options to selectively disable CCC per user. Some administrators may want to do this for security reasons. Rev 1.131 7/12/2004 11:46:44 PM JPMugaas Improvement in OPTS MODE Z handling. It will give an error if there's only one param. Params must be in pairs. If no valid parameters are present, we give an error. Rev 1.130 07/07/2004 17:34:38 ANeillans Corrected compile bug. Line 6026, if PosInStrArray(IntToStr(LNoVal),STATES,False)>-1 then Function expected a string, not an integer. Rev 1.129 7/6/2004 4:52:16 PM DSiders Corrected spelling of Challenge in properties, methods, types. Rev 1.128 6/29/2004 4:09:04 PM JPMugaas OPTS MODE Z now supported as per draft-preston-ftpext-deflate-02.txt. This should keep FTP Voyager 11 happy. Rev 1.127 6/28/2004 7:23:20 PM JPMugaas Bugfix. An invalid site command would cause no reply to be given. Now a syntax is given in such cases. Rev 1.126 6/27/2004 1:45:30 AM JPMugaas Can now optionally support LastAccessTime like Smartftp's FTP Server could. I also made the MLST listing object and parser support this as well. Rev 1.125 6/17/2004 3:56:28 PM JPMugaas Fix for AV that happens after data channel operation. Rev 1.124 6/16/2004 2:29:32 PM JPMugaas Removed direct access to a FConnection. We now use the Connection property in the TIdContext. Rev 1.123 6/12/2004 9:05:52 AM JPMugaas Telnet control sequences should now work during a data transfer. Removed HandleTelnetSequences. It was part of a crude workaround which had never works and the matter was fixed in another way. OnCustomDir should now work if the DirStyle is custom. Rev 1.122 6/11/2004 9:35:12 AM DSiders Added "Do not Localize" comments. Rev 1.121 2004.05.20 11:37:26 AM czhower IdStreamVCL Rev 1.120 5/16/04 5:30:26 PM RLebeau Added setter methods to the ReplyUnknownSITECommand and SITECommands properties Added GetRepliesClass() overrides Rev 1.119 5/1/2004 1:52:20 PM JPMugaas Updated for PeekBytes API change. Rev 1.118 4/8/2004 12:19:08 PM JPMugaas Should work with new code. Rev 1.117 3/3/2004 6:34:46 PM JPMugaas Improved help system. Some manditory (RFC 1123 were rutning syntax errors instead of not implemented. Add some mention of some other RFC 2228 commands for completness. Not that there are not supported or implemented. Rev 1.116 3/3/2004 6:02:14 AM JPMugaas Command descriptions. Rev 1.115 3/2/2004 8:13:28 AM JPMugaas Fixup for minor API change. Rev 1.113 3/1/2004 12:41:40 PM JPMugaas Should compile with new code. Rev 1.112 2/29/2004 6:02:38 PM JPMugaas Improved bug fix for problem with Telnet sequences not being handled properly in the FTP server. Litteral CR and LF are now handled properly (according to the Telnet Specification). Rev 1.111 2/25/2004 3:27:04 PM JPMugaas STAT -l now works like a LIST command except that it returns output on the control channel. This is for consistancy with microsoft FTP Service, RaidenFTPD, and a few other servers. FlashFXP can take advantage of this feature as well to gain some efficiency. Note that I do not do not advocate doing this on the FTP client because some servers will act differently than you would assume. I may see about possible options for using STAT -l but I can NOT promise anything. Rev 1.110 2/17/2004 6:37:28 PM JPMugaas OnPASV event added for people needing to change the IP address or port value in commands such as PASV. This should only be done if you have a compelling reason to do it. Note that the IP address parameter can NOT work with EPSV and SPSV because only the port number is returned. The IP address is presumed to be the same one that the host is connecting to. Rev 1.109 2/17/2004 12:26:06 PM JPMugaas The client now supports MODE Z (deflate) uploads and downloads as specified by http://www.ietf.org/internet-drafts/draft-preston-ftpext-deflate-00.txt Rev 1.108 2/15/2004 12:11:04 AM JPMugaas SPSV support. SPSV is an old propoal to help FTP support IPv6. This was mentioned at: http://cr.yp.to/ftp/retr.html and is supported by PureFTPD. Rev 1.107 2/14/2004 10:00:40 PM JPMugaas Both upload and download should now work in MODE Z. Dir already worked properly. Rev 1.106 2/12/2004 11:34:38 PM JPMugaas FTP Deflate preliminary support. Work still needs to be done for upload and downloading. Rev 1.105 2004.02.08 3:08:10 PM czhower .Net fix. Rev 1.104 2004.02.07 5:03:10 PM czhower .net fixes. Rev 1.103 2004.02.03 5:45:54 PM czhower Name changes Rev 1.102 1/29/2004 3:15:52 PM JPMugaas Fix for P@SW in InitCommandHandlers used "PASV" isntead of "P@SW". Fixed. Rev 1.101 1/22/2004 8:29:06 AM JPMugaas Removed Ansi*. Rev 1.100 1/21/2004 2:34:38 PM JPMugaas Fixed SITE ZONE reply. InitComponent Rev 1.99 1/19/2004 4:37:02 AM JPMugaas MinutesFromGMT was moved to IdFTPCommon because the client now uses it. Rev 1.98 1/18/2004 9:19:08 AM JPMugaas P@SW now supported. This is necessary as some routers that replace a PASV with a P@SW as part of a misguided attempt to add a feature. A router would do a replacement so a client would think that PASV wasn't supported and then the client would do a PORT command instead. That doesn't happen so this just caused the client not to work. See: http://www.gbnetwork.co.uk/smcftpd/ Rev 1.97 1/17/2004 7:40:08 PM JPMugaas MLSD added to FEAT list for consistancy with other FTP servers. Fixed bug that would cause FXP transfers to fail when receiving a PASV. Rev 1.96 1/16/2004 12:25:06 AM JPMugaas Fixes for MTDM set modified time. Rev 1.94 1/15/2004 2:36:50 AM JPMugaas XMD5 command support. SITE ZONE command added for FTP Voyager. Minor adjustment in AUTH line in the FEAT response to indicate that we support the AUTH TLS, AUTH TLS-C, AUTH SSL, and AUTH TLS-P explicit TLS commands. Rev 1.93 1/14/2004 4:11:30 PM JPMugaas CPSV support added. This is like PASV but indicates that we use ssl_connect instead of ssl_accept. CPSV is used in FlashFXP for secure site-to-site file transfers. Rev 1.92 1/14/2004 12:24:06 PM JPMugaas SSCN Support for secure Site to Site Transfers using SSL. SSCN is defined at: http://www.raidenftpd.com/kb/kb000000037.htm Rev 1.91 1/13/2004 6:30:38 AM JPMugaas Numerous bug fixes. Now supports XCWD (a predicessor to CWD). Command Reply for unknown command works again. Started putting some formatting into common routines. CuteFTP goes bonkers with a "215 " reply to SYST command. Now indicate that SYST isn't implemented instead of giving that "215 ". Note that a "CustomSystID" should be provided when DirFormat is ftpdfCustom. If DirFormat is ftpdfCustom and OnListDirectory is provided; MLST, MLSD, and OPTS MLSD will be DISABLED. OnListDirectory is used in the custom format for structed standardized output with the MLSD and MLST commands. A not implemented is now given for some commands. Rev 1.90 1/5/2004 11:53:00 PM JPMugaas Some messages moved to resource strings. Minor tweeks. EIdException no longer raised. Rev 1.88 1/4/2004 3:51:32 PM JPMugaas Fixed a CWD bug. The parameter was being ignored. Rev 1.87 1/3/2004 8:05:18 PM JPMugaas Bug fix: Sometimes, replies will appear twice due to the way functionality was enherited. Rev 1.86 1/3/2004 5:37:56 PM JPMugaas Changes from Bas: added function GetReplyClass, this function returns the class of reply this server class uses, this is because in dotnet there can be no code before the inherited in the constructor ( that is used mow to determine the reply class )   changed System.Delete to IdDelete (in coreglobal) because System.Delete is not in dotnet   SplitLines is not enabled in dotnet yet, so i made it a todo, make sure to enable it and remove the todo if you check it in    Rev 1.85 1/2/2004 1:02:08 AM JPMugaas Made comment about why the SYST descriptor is determined the way it is. Rev 1.84 1/2/2004 12:55:32 AM JPMugaas Now compiles. Removed the EmulateSystem property. Replaced one part with the DirFormat property. Rev 1.83 1/1/2004 10:55:10 PM JPMugaas Remy Lebeau found a bug with path processing in the FTP server. I was passing an emptry Result string instead of APath in FTPNormalize. Rev 1.77 10/11/2003 10:17:28 AM JPMugaas Checked in a more recent version which should be worked on instead. Rev 1.75 9/19/2003 12:50:18 PM JPMugaas Started attempt to get the server to compile. Rev 1.74 9/18/2003 10:20:06 AM JPMugaas Updated for new API. Rev 1.73 8/24/2003 06:50:02 PM JPMugaas API Change in the FileSystem component so that a thread is passed instead of some data from the thread. This should also make the API's easier to manage than before and provide more flexibility for developers writing their own file system components. Rev 1.72 7/13/2003 7:56:00 PM SPerry fixed problem with commandhandlers Rev 1.69 6/17/2003 09:30:20 PM JPMugaas Fixed an AV with the ALLO command if no parameters were passed. Stated in HELP command that we don't support some old FTP E-Mail commands from RFC 765 which have not been in use for many years. We now give a reply saying those aren't implemented to be consistant with some Unix FTP deamons. Rev 1.68 6/17/2003 03:16:36 PM JPMugaas I redid the help and site help implementations so that they list commands. It did mean loosing the FHelpText TIdStrings property but this should be more consistant with common practices. Rev 1.67 6/17/2003 09:07:40 AM JPMugaas Improved SITE HELP handling. Rev 1.65 5/26/2003 12:22:50 PM JPMugaas Rev 1.64 5/25/2003 03:54:28 AM JPMugaas Rev 1.63 5/21/2003 3:59:32 PM BGooijen removed with in InitializeCommandHandlers, and changed exception replies Rev 1.62 5/21/2003 09:29:40 AM JPMugaas Rev 1.61 5/19/2003 08:11:44 PM JPMugaas Now should compile properly with new code in Core. Rev 1.60 4/10/2003 02:54:14 PM JPMugaas Improvement for FTP STOU command. Unique filename now uses IdGlobal.GetUniqueFileName instead of Rand. I also fixed GetUniqueFileName so that it can accept an empty path specification. Rev 1.59 3/30/2003 12:18:38 AM BGooijen bug fix + ssl one data channel fixed Rev 1.58 3/24/2003 11:08:42 PM BGooijen 'transfer'-commands now block, until the transfer is done/aborted. this made it possible to send the reply after the transfer in the control-thread Rev 1.57 3/16/2003 06:11:18 PM JPMugaas Server now derrives from a TLS framework. Rev 1.56 3/14/2003 11:33:46 PM JPMugaas Rev 1.55 3/14/2003 10:44:38 PM BGooijen Removed warnings, changed StartSSL to PassThrough:=false; Rev 1.54 3/14/2003 10:00:24 PM BGooijen Removed TIdServerIOHandlerSSLBase.PeerPassthrough, the ssl is now enabled in the server-protocol-files Rev 1.53 3/13/2003 05:21:18 PM JPMugaas Bas's bug fix. There was a wrong typecast. Rev 1.52 3/13/2003 8:57:30 PM BGooijen changed TIdSSLIOHandlerSocketBase to TIdIOHandlerSocket in TIdDataChannelContext.SetupDataChannel Rev 1.51 3/13/2003 09:49:06 AM JPMugaas Now uses an abstract SSL base class instead of OpenSSL so 3rd-party vendors can plug-in their products. Rev 1.50 3/13/2003 06:11:54 AM JPMugaas Updated with Bas's change. Rev 1.49 3/10/2003 09:12:46 PM JPMugaas Most command handlers now use Do methods for consistancy with other Indy code. Rev 1.48 3/10/2003 05:09:22 PM JPMugaas MLST now works as expected with the file system. Note that the MLST means simply to give information about an item instead of its contents. GetRealFileName in IdFTPFileSystem now can accept the wildcard *. When doing dirs in EPLF, only information about a directory is retruned if it is specified. Rev 1.47 3/9/2003 02:11:34 PM JPMugaas Removed server support for MODE B and MODE C. It turns out that we do not support those modes properly. We only implemented Stream mode. We now simply return a 504 for modes we don't support instead of a 200 okay. This was throwing off Opera 7.02. Rev 1.46 3/6/2003 11:00:12 AM JPMugaas Now handles the MFMT command and the MFCT (Modified Date fact) command. Rev 1.45 3/6/2003 08:26:28 AM JPMugaas Bug fixes. FTP COMB command can now work in the FTPFileSystem component. Rev 1.44 3/5/2003 03:28:16 PM JPMugaas MD5, MMD5, and XCRC are now supported in the Virtual File System. Rev 1.43 3/5/2003 11:46:38 AM JPMugaas Rename now works in Virtual FileSystem. Rev 1.42 3/2/2003 04:54:34 PM JPMugaas Now does recursive dir lists with the Virtual File System layer as well as honors other switches. Rev 1.41 3/2/2003 02:18:32 PM JPMugaas Bug fix for where a reply was not returned when using a file system component. Rev 1.40 3/2/2003 02:23:38 AM JPMugaas fix for problem with pathes in the virtual file system. Rev 1.39 2/24/2003 08:50:44 PM JPMugaas Rev 1.38 2/24/2003 07:56:22 PM JPMugaas Now uses /bin/ls strings. Rev 1.37 2/24/2003 07:21:10 AM JPMugaas FTP Server now strips out any -R switches when emulating EPLF servers. Recursive lists aren't supported with EPLF. Rev 1.36 2/21/2003 06:54:10 PM JPMugaas The FTP list processing has been restructured so that Directory output is not done by IdFTPList. This now also uses the IdFTPListParserBase for parsing so that the code is more scalable. Rev 1.35 2/15/2003 10:29:42 AM JPMugaas Added support for some Unix specific facts with MLSD and MLST. Rev 1.34 2/14/2003 05:42:08 PM JPMugaas Moved everything from IdFTPUtils to IdFTPCommon at Kudzu's suggestion. Rev 1.33 2/14/2003 11:57:48 AM JPMugaas Updated for new API. Made sure that there were no calls to a function we removed. Rev 1.32 2/14/2003 10:45:18 AM JPMugaas Updated for minor API change. Rev 1.30 2/13/2003 01:28:08 AM JPMugaas MLSD and MLST should now work better. Rev 1.29 2/12/2003 12:30:56 PM JPMugaas Now honors parameters with the NLIST command. Rev 1.28 2/5/2003 10:30:04 PM BGooijen Re-enabled ssl-support Rev 1.27 2/4/2003 05:31:40 PM JPMugaas Added ASwitches parameter to the ListEvent so we can pass parameters such as "-R" in addition to the standard path. Rev 1.26 2/3/2003 11:01:50 AM JPMugaas Moved list export to IdFTPList. Rev 1.25 1/31/2003 01:59:18 PM JPMugaas Security options are now reenabled. Rev 1.24 1/31/2003 01:19:00 PM JPMugaas Now passes the ControlConnection context instead of the ControlConnection object itself. Rev 1.23 1/31/2003 06:34:52 AM JPMugaas Now SYST command works as expected. Rev 1.22 1/31/2003 04:23:24 AM JPMugaas FTP Server security options can be set for individual users and the server will now use the Context's security options. THis should permit more flexibility in security. Rev 1.21 1/30/2003 03:31:06 AM JPMugaas Now should also properly handle exceptions in the MLSx commands. Rev 1.20 1/30/2003 02:55:26 AM JPMugaas Now properly handles exceptions in the ListEvent for the STAT and LIST commands. Rev 1.19 1/29/2003 01:17:18 AM JPMugaas Exception handling should mostly work as it should. There's still a problem with the list. Rev 1.18 1/28/2003 02:27:26 AM JPMugaas Improved exception handling in several events to try to be more consistant. Now can optionally hide the exception message when giving an error reply to the user. This should prevent some inadvertant information about a computer going to a troublemaker. Rev 1.17 1/27/2003 05:03:16 AM JPMugaas Now a developer can provide status information to a user with the STAT command if they want. We format the reply in a standard manner for them. They just provide the information. Rev 1.16 1/27/2003 02:13:30 AM JPMugaas Added more security options as suggested by: http://www.sans.org/rr/infowar/fingerprint.php to help slow down an attack. You can optionally disable both SYST and the STAT commands. Trouble makers can use those to help determine server type and then use known flaws to compromise it. Note that these do not completely prevent attacks and should not lull administrators into a false sense of security. Rev 1.15 1/27/2003 12:32:08 AM JPMugaas Now can optionally return the identifier for the real operating system. By default, this property is false for security reasons. Rev 1.14 1/26/2003 11:59:16 PM JPMugaas SystemDescriptor behavior change as well as SYST command change. SystemDescriptor no longer needs an OS type as the first word. That is now handled by the SYST commandhandler to better comply with RFC 959. Rev 1.13 1/25/2003 02:00:58 AM JPMugaas MMD5 (for multiple MD5 checksums) is now supported. Refined MD5 command support slgihtly. This is based on: http://www.ietf.org/internet-drafts/draft-twine-ftpmd5-00.txt Rev 1.12 1/24/2003 6:07:24 PM BGooijen Changed TIdDataChannelThread to TIdDataChannelContext Rev 1.11 1/23/2003 9:06:26 PM BGooijen changed the CommandAbor Rev 1.10 1/23/2003 10:39:38 AM BGooijen TIdDataChannelContext.FServer was never assigned Rev 1.9 1/20/2003 1:15:40 PM BGooijen Changed to TIdTCPServer / TIdCmdTCPServer classes Rev 1.8 1/17/2003 06:21:02 PM JPMugaas Now works with new design. Rev 1.7 1/17/2003 05:28:42 PM JPMugaas Rev 1.6 1-9-2003 14:45:30 BGooijen Added ABOR command with telnet escape characters Fixed hanging of ABOR command STOR and STOU now use REST-position ABOR now returns 226 instead of 200 Rev 1.5 1-9-2003 14:35:52 BGooijen changed TIdFTPServerContext(ASender.Context.Thread) to TIdFTPServerContext(ASender.Context) on some places Rev 1.4 1/9/2003 06:08:10 AM JPMugaas Updated to be based on IdContext. Rev 1.3 1-1-2003 20:13:06 BGooijen Changed to support the new TIdContext class Rev 1.2 12-15-2002 21:15:46 BGooijen IFDEF-ed all SSL code, the IFDEF-s are removed as soon as the SSL works again. Rev 1.1 11/14/2002 02:55:58 PM JPMugaas FEAT and MLST now completely use the RFC Reply objects instead of Connection.WriteLn. The Connection.WriteLn was a workaround for a deficit in the original RFC Reply object. The workaround is no longer needed. } unit IdFTPServer; { Original Author: Sergio Perry Date: 04/21/2001 Fixes and modifications: Doychin Bondzhev Date: 08/10/2001 Further Extensive changes by Chad Z. Hower (Kudzu) EPSV/EPRT support for IPv6 by Johannes Berg TODO: both EPSV and EPRT only allow data connections that have the same protocol as the control connection, because the ftp server could be used in a network only supporting one of them TODO: Change events to use DoXXXX } interface {$i IdCompilerDefines.inc} uses Classes, IdAssignedNumbers, IdCommandHandlers, IdGlobal, IdContext, IdException, IdExplicitTLSClientServerBase, IdFTPBaseFileSystem, IdFTPCommon, IdBaseComponent, IdFTPList, IdFTPListOutput, IdFTPServerContextBase, IdReply, IdReplyFTP, IdReplyRFC, IdScheduler, IdServerIOHandler, IdTCPConnection, IdCmdTCPServer, IdTCPServer, IdThread, IdUserAccounts, IdYarn, IdZLibCompressorBase, SysUtils; type TIdFTPDirFormat = (ftpdfDOS, ftpdfUnix, ftpdfEPLF, ftpdfCustom, ftpdfOSDependent); TIdFTPPathProcessing = (ftppDOS, ftppUnix, ftpOSDependent, ftppCustom); TIdFTPOperation = (ftpRetr, ftpStor); TIdMLSDAttr = (mlsdUniqueID, mlsdPerms, mlsdUnixModes, mlsdUnixOwner, mlsdUnixGroup, mlsdFileCreationTime, mlsdFileLastAccessTime, mlsdWin32Attributes, mlsdWin32DriveType, mlstWin32DriveLabel); TIdMLSDAttrs = set of TIdMLSDAttr; const DEF_DIRFORMAT = ftpdfUnix; //ftpdfOSDependent; Id_DEF_AllowAnon = False; Id_DEF_PassStrictCheck = True; DEF_FTP_IMPLICIT_FTP = False; DEF_FTP_HIDE_INVALID_USER = True; DEF_FTP_PASSWORDATTEMPTS = 3; DEF_FTP_INVALIDPASS_DELAY = 3000; //3 seconds DEF_FTP_PASV_SAME_IP = True; DEF_FTP_PORT_SAME_IP = True; DEF_FTP_NO_RESERVED_PORTS = True; DEF_FTP_BLOCK_ALL_PORTS = False; DEF_FTP_DISABLE_SYST = False; DEF_FTP_DISABLE_STAT = False; DEF_FTP_PERMIT_CCC = False; DEF_FTP_REPORT_EX_MSG = False; DEF_PASV_BOUND_MIN = 0; DEF_PASV_BOUND_MAX = 0; DEF_PATHPROCESSING = ftpOSDependent; {Do not change these as it could break some clients} SYST_ID_UNIX = 'UNIX Type: L8'; {Do not translate} SYST_ID_NT = 'Windows_NT'; {Do not translate} const AAlwaysValidOpts : array [0..2] of string = ('SIZE', 'TYPE', 'MODIFY'); {Do not translate} type TIdFTPServerContext = class; //The final parameter could've been one item but I decided against that //because occaisionally, you might have a situation where you need to specify //the "type" fact to be several different things. // //http://www.ietf.org/internet-drafts/draft-ietf-ftpext-mlst-16.txt TIdOnMLST = procedure(ASender : TIdFTPServerContext; const APath: TIdFTPFileName; ADirectoryListing: TIdFTPListOutput) of object; //data port binding events TOnDataPortBind = procedure(ASender : TIdFTPServerContext) of object; //note that the CHMOD value is now a VAR because we also want to support a "MFF UNIX.mode=" //to do the same thing as a chmod. MFF is to "Modify a file fact". TOnSetATTRIB = procedure(ASender: TIdFTPServerContext; var VAttr : UInt32; const AFileName : TIdFTPFileName; var VAUth : Boolean) of object; //Note that VAuth : Boolean is used because you may want to deny permission for //users to change their Unix permissions or UMASK - which is done in anonymous FTP TOnSiteUMASK = procedure(ASender: TIdFTPServerContext; var VUMASK : Integer; var VAUth : Boolean) of object; //note that the CHMOD value is now a VAR because we also want to support a "MFF UNIX.mode=" //to do the same thing as a chmod. MFF is to "Modify a file fact". TOnSiteCHMOD = procedure(ASender: TIdFTPServerContext; var APermissions : Integer; const AFileName : TIdFTPFileName; var VAUth : Boolean) of object; //chown as an option can specify group TOnSiteCHOWN = procedure(ASender: TIdFTPServerContext; var AOwner, AGroup : String; const AFileName : TIdFTPFileName; var VAUth : Boolean) of object; TOnSiteCHGRP = procedure(ASender: TIdFTPServerContext; var AGroup : String; const AFileName : TIdFTPFileName; var VAUth : Boolean) of object; TOnCustomPathProcess = procedure(ASender: TIdFTPServerContext; var VPath : TIdFTPFileName) of object; // TOnFTPUserLoginEvent = procedure(ASender: TIdFTPServerContext; const AUsername, APassword: string; var AAuthenticated: Boolean) of object; TOnFTPUserAccountEvent = procedure(ASender : TIdFTPServerContext; const AUsername, APassword,AAcount: string; var AAuthenticated: Boolean) of object; TOnAfterUserLoginEvent = procedure(ASender: TIdFTPServerContext) of object; TOnDirectoryEvent = procedure(ASender: TIdFTPServerContext; var VDirectory: TIdFTPFileName) of object; TOnGetFileSizeEvent = procedure(ASender: TIdFTPServerContext; const AFilename: TIdFTPFileName; var VFileSize: Int64) of object; TOnGetFileDateEvent = procedure(ASender: TIdFTPServerContext; const AFilename: TIdFTPFileName; var VFileDate: TDateTime) of object; //note we have to use a switches parameter because LIST in practice can have both a path and some //some switches such as -R for recursive. TOnListDirectoryEvent = procedure(ASender: TIdFTPServerContext; const APath: TIdFTPFileName; ADirectoryListing: TIdFTPListOutput; const ACmd : String; const ASwitches : String) of object; TOnCustomListDirectoryEvent = procedure(ASender: TIdFTPServerContext; const APath: TIdFTPFileName; ADirectoryListing: TStrings; const ACmd : String; const ASwitches : String) of object; TOnFileEvent = procedure(ASender: TIdFTPServerContext; const APathName: TIdFTPFileName) of object; TOnCheckFileEvent = procedure(ASender: TIdFTPServerContext; const APathName: TIdFTPFileName; var VExist : Boolean) of object; TOnRenameFileEvent = procedure(ASender: TIdFTPServerContext; const ARenameFromFile, ARenameToFile: TIdFTPFileName) of object; TOnRetrieveFileEvent = procedure(ASender: TIdFTPServerContext; const AFileName: TIdFTPFileName; var VStream: TStream) of object; TOnStoreFileEvent = procedure(ASender: TIdFTPServerContext; const AFileName: TIdFTPFileName; AAppend: Boolean; var VStream: TStream) of object; TOnCombineFiles = procedure(ASender: TIdFTPServerContext; const ATargetFileName: TIdFTPFileName; AParts : TStrings) of object; TOnCheckSumFile = procedure(ASender: TIdFTPServerContext; const AFileName : TIdFTPFileName; var VStream : TStream) of object; TOnCacheChecksum = procedure(ASender: TIdFTPServerContext; const AFileName : TIdFTPFileName; var VCheckSum : String) of object; TOnVerifyChecksum = procedure(ASender: TIdFTPServerContext; const AFileName : TIdFTPFileName; const ACheckSum : String) of object; TOnSetFileDateEvent = procedure(ASender: TIdFTPServerContext; const AFileName : TIdFTPFileName; var AFileTime : TDateTime) of object; TOnHostCheck = procedure(ASender:TIdFTPServerContext; const AHost : String; var VAccepted : Boolean) of object; //This is just to be efficient with the SITE UTIME command and for setting the windows.lastaccesstime fact TOnSiteUTIME = procedure(ASender: TIdFTPServerContext; const AFileName : TIdFTPFileName; var VLastAccessTime, VLastModTime, VCreateDate : TDateTime; var VAUth : Boolean) of object; EIdFTPServerException = class(EIdException); EIdFTPServerNoOnListDirectory = class(EIdFTPServerException); EIdFTPImplicitTLSRequiresSSL = class(EIdFTPServerException); EIdFTPBoundPortMaxGreater = class(EIdFTPServerException); EIdFTPBoundPortMinLess = class(EIdFTPServerException); EIdFTPCannotBeNegative = class(EIdFTPServerException); //we don't parse CLNT parameters as they might be freeform for all we know TIdOnClientID = procedure(ASender: TIdFTPServerContext; const AID : String) of object; TIdOnFTPStatEvent = procedure(ASender: TIdFTPServerContext; AStatusInfo : TStrings) of object; TIdOnBanner = procedure(ASender: TIdFTPServerContext; AGreeting : TIdReply) of object; //This is for EPSV and PASV support - do not change the values unless you //have an extremely compelling reason to do so. This even is ONLY for those compelling case. TIdOnPASV = procedure(ASender: TIdFTPServerContext; var VIP : String; var VPort : TIdPort; const AIPVer : TIdIPVersion) of object; TIdOnPASVRange = procedure(ASender: TIdFTPServerContext; var VIP : String; var VPortMin, VPortMax : TIdPort; const AIPVer : TIdIPVersion) of object; TIdOnDirSizeInfo = procedure(ASender : TIdFTPServerContext; const APathName : TIdFTPFileName; var VIsAFile : Boolean; var VSpace : Int64) of object; TIdFTPServer = class; TIdFTPSecurityOptions = class(TPersistent) protected // RFC 2577 Recommends these // Note that the current code already hides user ID's by // only authenticating after the password FPasswordAttempts : UInt32; FInvalidPassDelay : UInt32; // http://cr.yp.to/ftp/security.html Recommends these FRequirePASVFromSameIP : Boolean; FRequirePORTFromSameIP : Boolean; FNoReservedRangePORT : Boolean; FBlockAllPORTTransfers : Boolean; FDisableSYSTCommand : Boolean; FDisableSTATCommand : Boolean; FPermitCCC : Boolean; public constructor Create; virtual; procedure Assign(Source: TPersistent); override; published //limit login attempts - some hackers will try guessing passwords from a dictionary property PasswordAttempts : UInt32 read FPasswordAttempts write FPasswordAttempts default DEF_FTP_PASSWORDATTEMPTS; //should slow-down a password guessing attack - note those dictionaries property InvalidPassDelay : UInt32 read FInvalidPassDelay write FInvalidPassDelay default DEF_FTP_INVALIDPASS_DELAY; //client IP Address is the only one that we will accept a PASV //transfer from //http://cr.yp.to/ftp/security.html property RequirePASVFromSameIP : Boolean read FRequirePASVFromSameIP write FRequirePASVFromSameIP default DEF_FTP_PASV_SAME_IP; //Accept port transfers from the same IP address as the client - //should prevent bounce attacks property RequirePORTFromSameIP : Boolean read FRequirePORTFromSameIP write FRequirePORTFromSameIP default DEF_FTP_PORT_SAME_IP; //Do not accept port requests to ports in the reserved range. That is dangerous on some systems property NoReservedRangePORT : Boolean read FNoReservedRangePORT write FNoReservedRangePORT default DEF_FTP_NO_RESERVED_PORTS; //Do not accept any PORT transfers at all. This is a little extreme but reduces troubles further. //This will break the the Win32 console clients and a number of other programs. property BlockAllPORTTransfers : Boolean read FBlockAllPORTTransfers write FBlockAllPORTTransfers default DEF_FTP_BLOCK_ALL_PORTS; //Disable SYST command. SYST usually gives the system description. //Disabling it may make it harder for a trouble maker to know about your computer //but will not be a complete security solution. See http://www.sans.org/rr/infowar/fingerprint.php for details //On the other hand, disabling it will break RFC 959 complience and may break some FTP programs. property DisableSYSTCommand : Boolean read FDisableSYSTCommand write FDisableSYSTCommand default DEF_FTP_DISABLE_SYST; //Disable STAT command. STAT gives freeform information about the connection status. // http://www.sans.org/rr/infowar/fingerprint.php advises administrators to disable this //because servers tend to give distinct patterns of information and some trouble makers //can figure out what type of server you are running simply with this. property DisableSTATCommand : Boolean read FDisableSTATCommand write FDisableSTATCommand default DEF_FTP_DISABLE_STAT; //Permit CCC (Clear Command Connection) in TLS FTP property PermitCCC : Boolean read FPermitCCC write FPermitCCC default DEF_FTP_PERMIT_CCC; end; TIdDataChannel = class(TObject) protected FNegotiateTLS : Boolean; FControlContext: TIdFTPServerContext; FDataChannel: TIdTCPConnection; FErrorReply: TIdReplyRFC; FFtpOperation: TIdFTPOperation; FOKReply: TIdReplyRFC; FReply: TIdReplyRFC; FServer : TIdFTPServer; FRequirePASVFromSameIP : Boolean; FStopped : Boolean; FData : TObject; procedure SetErrorReply(const AValue: TIdReplyRFC); procedure SetOKReply(const AValue: TIdReplyRFC); function GetPeerIP: String; function GetPeerPort: TIdPort; function GetLocalIP: String; function GetLocalPort: TIdPort; public constructor Create(APASV: Boolean; AControlContext: TIdFTPServerContext; const ARequirePASVFromSameIP : Boolean; AServer : TIdFTPServer); reintroduce; destructor Destroy; override; procedure InitOperation(const AConnectMode : Boolean = False); property PeerIP : String read GetPeerIP; property PeerPort : TIdPort read GetPeerPort; property LocalIP : String read GetLocalIP; property LocalPort : TIdPort read GetLocalPort; property Stopped : Boolean read FStopped write FStopped; property Data : TObject read FData write FData; property Server : TIdFTPServer read FServer; property OKReply: TIdReplyRFC read FOKReply write SetOKReply; property ErrorReply: TIdReplyRFC read FErrorReply write SetErrorReply; end; TIdFTPServerContext = class(TIdFTPServerContextBase) protected FXAUTKey : UInt32; FRESTPos: Integer; FDataChannel : TIdDataChannel; FAuthMechanism : String; FCCC : Boolean; //flag for CCC issuance FDataType: TIdFTPTransferType; FDataMode : TIdFTPTransferMode; FDataPort: TIdPort; FDataProtBufSize : UInt32; FDataStruct: TIdFTPDataStructure; FPasswordAttempts : UInt32; FPASV: Boolean; FEPSVAll: Boolean; FDataPortDenied : Boolean; FDataProtection : TIdFTPDataPortSecurity; FDataPBSZCalled : Boolean; FMLSOpts : TIdFTPFactOutputs; FSSCNOn : Boolean; FServer : TIdFTPServer; FUserSecurity : TIdFTPSecurityOptions; FUMask : Integer; //for SITE UMASK command //only used for Windows NT imitation FMSDOSMode : Boolean; //False - off imitate Unix, //True - On imitate DOS //This is a queued request to quite. //if it's issued during a data transfer, we treat it as quit //only after the request is completed. FQuitReply : String; //ZLib settings FZLibCompressionLevel : Integer; //7 FZLibWindowBits : Integer; //-15 FZLibMemLevel : Integer; //8 FZLibStratagy : Integer; //0 - default // procedure ResetZLibSettings; procedure PortOnAfterBind(ASender : TObject); procedure PortOnBeforeBind(ASender : TObject); procedure SetUserSecurity(const Value: TIdFTPSecurityOptions); procedure CreateDataChannel(APASV: Boolean = False); function IsAuthenticated(ASender: TIdCommand): Boolean; procedure ReInitialize; override; public constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override; destructor Destroy; override; procedure KillDataChannel; property DataChannel : TIdDataChannel read FDataChannel; property Server : TIdFTPServer read FServer write FServer; property UserSecurity : TIdFTPSecurityOptions read FUserSecurity write SetUserSecurity; // //This is for tracking what AUTH mechanism was specified and that //we support. This may not matter as much now, but it could later on //RFC 2228 property AuthMechanism : String read FAuthMechanism write FAuthMechanism; property DataType: TIdFTPTransferType read FDataType write FDataType; property DataMode : TIdFTPTransferMode read FDataMode write FDataMode; property DataPort: TIdPort read FDataPort; //We do not use this much for now but if more AUTH mechanisms are added, //we may need this property property DataProtBufSize : UInt32 read FDataProtBufSize write FDataProtBufSize; property DataPBSZCalled : Boolean read FDataPBSZCalled write FDataPBSZCalled; property DataStruct: TIdFTPDataStructure read FDataStruct write FDataStruct; //currently, only lear and

rivate are used. This could change //later on property DataProtection : TIdFTPDataPortSecurity read FDataProtection write FDataProtection; property PasswordAttempts : UInt32 read FPasswordAttempts write FPasswordAttempts; property PASV: Boolean read FPASV write FPASV; property RESTPos: Integer read FRESTPos write FRESTPos; property MLSOpts : TIdFTPFactOutputs read FMLSOpts write FMLSOpts; //SSCN secure FTPX - http://www.raidenftpd.com/kb/kb000000037.htm property SSCNOn : Boolean read FSSCNOn write FSSCNOn; //SITE DIRSTYLE flag - true for MSDOS, false for Unix property MSDOSMode : Boolean read FMSDOSMode write FMSDOSMode; //SITE UMASK settings property UMask : Integer read FUMask write FUMask; //ZLib settings property ZLibCompressionLevel : Integer read FZLibCompressionLevel write FZLibCompressionLevel; //7 property ZLibWindowBits : Integer read FZLibWindowBits write FZLibWindowBits; //-15 property ZLibMemLevel : Integer read FZLibMemLevel write FZLibMemLevel; //8 property ZLibStratagy : Integer read FZLibStratagy write FZLibStratagy; //0 - default end; TIdOnGetCustomListFormat = procedure(ASender: TIdFTPServer; AItem: TIdFTPListItem; var VText: string) of object; { FTP Server } TIdFTPServer = class(TIdExplicitTLSServer) protected FSupportXAUTH: Boolean; FDirFormat : TIdFTPDirFormat; FPathProcessing : TIdFTPPathProcessing; FOnClientID : TIdOnClientID; FDataChannelCommands: TIdCommandHandlers; FSITECommands: TIdCommandHandlers; FOPTSCommands: TIdCommandHandlers; FMLSDFacts : TIdMLSDAttrs; FAnonymousAccounts: TStrings; FAllowAnonymousLogin: Boolean; FAnonymousPassStrictCheck: Boolean; // FEmulateSystem: TIdFTPSystems; FPASVBoundPortMin : TIdPort; FPASVBoundPortMax : TIdPort; FSystemType: string; FDefaultDataPort : TIdPort; {$IFDEF USE_OBJECT_ARC}[Weak]{$ENDIF} FUserAccounts: TIdCustomUserManager; FOnUserAccount : TOnFTPUserAccountEvent; FOnAfterUserLogin: TOnAfterUserLoginEvent; FOnUserLogin: TOnFTPUserLoginEvent; FOnChangeDirectory: TOnDirectoryEvent; FOnGetFileSize: TOnGetFileSizeEvent; FOnGetFileDate:TOnGetFileDateEvent; FOnListDirectory: TOnListDirectoryEvent; FOnCustomListDirectory : TOnCustomListDirectoryEvent; FOnRenameFile: TOnRenameFileEvent; FOnDeleteFile: TOnFileEvent; FOnRetrieveFile: TOnRetrieveFileEvent; FOnStoreFile: TOnStoreFileEvent; FOnMakeDirectory: TOnDirectoryEvent; FOnRemoveDirectory: TOnDirectoryEvent; FOnStat : TIdOnFTPStatEvent; FFTPSecurityOptions : TIdFTPSecurityOptions; FOnCRCFile : TOnCheckSumFile; FOnCombineFiles : TOnCombineFiles; FOnSetModifiedTime : TOnSetFileDateEvent; FOnFileExistCheck : TOnCheckFileEvent; //for MDTM variation to set the file time FOnSetCreationTime : TOnSetFileDateEvent; FOnMD5Cache : TOnCacheChecksum; FOnMD5Verify : TOnVerifyChecksum; FOnGreeting : TIdOnBanner; FOnLoginSuccessBanner : TIdOnBanner; FOnLoginFailureBanner : TIdOnBanner; FOnQuitBanner : TIdOnBanner; FOnSetATTRIB : TOnSetATTRIB; FOnSiteUMASK : TOnSiteUMASK; FOnSiteCHMOD : TOnSiteCHMOD; FOnSiteCHOWN : TOnSiteCHOWN; FOnSiteCHGRP : TOnSiteCHGRP; FOnAvailDiskSpace : TIdOnDirSizeInfo; FOnCompleteDirSize : TIdOnDirSizeInfo; FOnRemoveDirectoryAll: TOnDirectoryEvent; FOnCustomPathProcess : TOnCustomPathProcess; FOnDataPortBeforeBind : TOnDataPortBind; FOnDataPortAfterBind : TOnDataPortBind; FOnPASVBeforeBind : TIdOnPASVRange; FOnPASVReply : TIdOnPASV; {$IFDEF USE_OBJECT_ARC}[Weak]{$ENDIF} FFTPFileSystem: TIdFTPBaseFileSystem; FEndOfHelpLine : String; FCustomSystID : String; FReplyUnknownSITECommand : TIdReply; FCompressor : TIdZLibCompressorBase; FOnMLST : TIdOnMLST; FOnSiteUTIME : TOnSiteUTIME; FOnHostCheck : TOnHostCheck; procedure SetOnUserAccount(AValue : TOnFTPUserAccountEvent); procedure AuthenticateUser(ASender: TIdCommand); function SupportTaDirSwitches(AContext : TIdFTPServerContext) : Boolean; function IgnoreLastPathDelim(const APath : String) : String; procedure DoOnPASVBeforeBind(ASender : TIdFTPServerContext; var VIP : String; var VPortMin, VPortMax : TIdPort; const AIPVersion : TIdIPVersion); procedure DoOnPASVReply(ASender : TIdFTPServerContext; var VIP : String; var VPort : TIdPort; const AIPVersion : TIdIPVersion); function InternalPASV(ASender: TIdCommand; var VIP : String; var VPort: TIdPort; var VIPVersion : TIdIPVersion): Boolean; function DoSysType(ASender : TIdFTPServerContext) : String; function DoProcessPath(ASender : TIdFTPServerContext; const APath: TIdFTPFileName): TIdFTPFileName; function FTPNormalizePath(const APath: String) : String; function MLSFEATLine(const AFactMask : TIdMLSDAttrs; const AFacts : TIdFTPFactOutputs) : String; function HelpText(Cmds : TStrings) : String; function IsValidPermNumbers(const APermNos : String) : Boolean; procedure SetRFCReplyFormat(AReply : TIdReply); function CDUPDir(AContext : TIdFTPServerContext) : String; procedure DisconUser(ASender: TIdCommand); //command reply common code procedure CmdNotImplemented(ASender : TIdCommand); procedure CmdFileActionAborted(ASender : TIdCommand); procedure CmdSyntaxError(AContext: TIdContext; ALine: string; const AReply : TIdReply = nil); overload; procedure CmdSyntaxError(ASender : TIdCommand); overload; procedure CmdInvalidParams(ASender: TIdCommand); procedure CmdInvalidParamNum(ASender:TIdCommand); //The http://www.potaroo.net/ietf/idref/draft-twine-ftpmd5/ //draft didn't specify 550 as an error. It said use 504. procedure CmdTwineFileActionAborted(ASender : TIdCommand); //success reply codes can vary amoung commands procedure CmdCommandSuccessful(ASender: TIdCommand; const AReplyCode : Integer = 250); //Command replies procedure CommandQUIT(ASender:TIdCommand); procedure CommandUSER(ASender: TIdCommand); procedure CommandPASS(ASender: TIdCommand); procedure CommandACCT(ASender: TIdCommand); procedure CommandXAUT(ASender : TIdCommand); procedure CommandCWD(ASender: TIdCommand); procedure CommandCDUP(ASender: TIdCommand); procedure CommandREIN(ASender: TIdCommand); procedure CommandPORT(ASender: TIdCommand); procedure CommandPASV(ASender: TIdCommand); procedure CommandTYPE(ASender: TIdCommand); procedure CommandSTRU(ASender: TIdCommand); procedure CommandMODE(ASender: TIdCommand); procedure CommandRETR(ASender: TIdCommand); procedure CommandSSAP(ASender: TIdCommand); procedure CommandALLO(ASender: TIdCommand); procedure CommandREST(ASender: TIdCommand); procedure CommandRNFR(ASender: TIdCommand); procedure CommandRNTO(ASender: TIdCommand); procedure CommandABOR(ASender: TIdCommand); //AVBL from Streamlined FTP Command Extensions // draft-peterson-streamlined-ftp-command-extensions-01.txt procedure CommandAVBL(ASender: TIdCommand); procedure CommandDELE(ASender: TIdCommand); //DSIZ from Streamlined FTP Command Extensions // draft-peterson-streamlined-ftp-command-extensions-01.txt procedure CommandDSIZ(ASender : TIdCommand); procedure CommandRMDA(ASender : TIdCommand); procedure CommandRMD(ASender: TIdCommand); procedure CommandMKD(ASender: TIdCommand); procedure CommandPWD(ASender: TIdCommand); procedure CommandLIST(ASender: TIdCommand); procedure CommandSYST(ASender: TIdCommand); procedure CommandSTAT(ASender: TIdCommand); procedure CommandSIZE(ASender: TIdCommand); procedure CommandFEAT(ASender: TIdCommand); procedure CommandOPTS(ASender: TIdCommand); procedure CommandAUTH(ASender: TIdCommand); procedure CommandCCC(ASender: TIdCommand); // rfc 2428: procedure CommandEPSV(ASender: TIdCommand); procedure CommandEPRT(ASender: TIdCommand); // procedure CommandMDTM(ASender: TIdCommand); procedure CommandMFF(ASender: TIdCommand); // procedure CommandMD5(ASender: TIdCommand); procedure CommandMMD5(ASender: TIdCommand); // procedure CommandPROT(ASender: TIdCommand); procedure CommandPBSZ(ASender: TIdCommand); procedure CommandMFMT(ASender: TIdCommand); procedure CommandMFCT(ASender: TIdCommand); procedure CommandMLSD(ASender: TIdCommand); procedure CommandMLST(ASender: TIdCommand); procedure CommandCheckSum(ASender: TIdCommand); procedure CommandCOMB(ASender: TIdCommand); procedure CommandCLNT(ASender: TIdCommand); //SSCN Secure FTPX - http://www.raidenftpd.com/kb/kb000000037.htm procedure CommandSSCN(ASender: TIdCommand); //Informal - like PASV accept SSL is in client mode - used by FlashXP procedure CommandCPSV(ASender: TIdCommand); //Informal - like PASV except that only the port is communicated. // procedure CommandSPSV(ASender: TIdCommand); procedure CommandHOST(ASender : TIdCommand); procedure CommandSecRFC(ASender : TIdCommand); //stub for some commands in 2228 procedure CommandSITE(ASender: TIdCommand); procedure CommandSiteHELP(ASender : TIdCommand); //site commands - Unix procedure CommandSiteUMASK(ASender : TIdCommand); procedure CommandSiteCHMOD(ASender : TIdCommand); //SITE CHOWN - supported by some Unix servers procedure CommandSiteCHOWN(ASender : TIdCommand); //SITE CHGRP - supported by some Unix servers procedure CommandSiteCHGRP(ASender : TIdCommand); //site commans - MS IIS procedure CommandSiteDIRSTYLE(ASender : TIdCommand); //used by FTP Voyager procedure CommandSiteZONE(ASender : TIdCommand); //supported by RaidenFTP - http://www.raidenftpd.com/kb/kb000000049.htm procedure CommandSiteATTRIB(ASender : TIdCommand); //McFTP client uses this to set the time stamps for a file. procedure CommandSiteUTIME(ASender : TIdCommand); // end site commands procedure CommandOptsMLST(ASender : TIdCommand); procedure CommandOptsMODEZ(ASender : TIdCommand); procedure CommandOptsUTF8(ASender: TIdCommand); procedure CommandHELP(ASender: TIdCommand); // procedure DoOnRenameFile(ASender: TIdFTPServerContext; const ARenameFromFile, ARenameToFile: string); procedure DoOnDeleteFile(ASender: TIdFTPServerContext; const APathName: string); procedure DoOnChangeDirectory(AContext: TIdFTPServerContext; var VDirectory: TIdFTPFileName); procedure DoOnMakeDirectory(AContext: TIdFTPServerContext; var VDirectory: TIdFTPFileName); procedure DoOnRemoveDirectory(AContext: TIdFTPServerContext; var VDirectory: TIdFTPFileName); procedure DoOnGetFileSize(ASender: TIdFTPServerContext; const AFilename: string; var VFileSize: Int64); procedure DoOnGetFileDate(ASender: TIdFTPServerContext; const AFilename: string; var VFileDate: TDateTime); procedure DoOnSetModifiedTime(AContext: TIdFTPServerContext; const AFileName : String; var VDateTime: TDateTime); overload; procedure DoOnSetModifiedTime(AContext: TIdFTPServerContext; const AFileName : String; var VDateTimeStr : String); overload; procedure DoOnFileExistCheck(AContext: TIdFTPServerContext; const AFileName : String; var VExist : Boolean); procedure DoOnSetModifiedTimeGMT(AContext: TIdFTPServerContext; const AFileName : String; var VDateTime: TDateTime); procedure DoOnSetCreationTime(AContext: TIdFTPServerContext; const AFileName : String; var VDateTime: TDateTime); overload; procedure DoOnSetCreationTime(AContext: TIdFTPServerContext; const AFileName : String; var VDateTimeStr : String); overload; procedure DoOnSetCreationTimeGMT(AContext: TIdFTPServerContext; const AFileName : String; var VDateTime: TDateTime); procedure DoOnCRCFile(ASender: TIdFTPServerContext; const AFileName : String; var VStream : TStream); procedure DoOnMD5Verify(ASender: TIdFTPServerContext; const AFileName : String; const ACheckSum : String); procedure DoOnMD5Cache(ASender: TIdFTPServerContext; const AFileName : String; var VCheckSum : String); procedure DoOnCombineFiles(ASender: TIdFTPServerContext; const ATargetFileName: string; AParts : TStrings); procedure DoOnSetATTRIB(ASender: TIdFTPServerContext; var VAttr : UInt32; const AFileName : String; var VAUth : Boolean); procedure DoOnSiteUMASK(ASender: TIdFTPServerContext; var VUMASK : Integer; var VAUth : Boolean); procedure DoOnSiteCHMOD(ASender: TIdFTPServerContext; var APermissions : Integer; const AFileName : String; var VAUth : Boolean); procedure DoOnSiteCHOWN(ASender: TIdFTPServerContext; var AOwner, AGroup : String; const AFileName : String; var VAUth : Boolean); procedure DoOnSiteCHGRP(ASender: TIdFTPServerContext; var AGroup : String; const AFileName : String; var VAUth : Boolean); procedure SetUseTLS(AValue: TIdUseTLS); override; procedure SetSupportXAUTH(AValue : Boolean); procedure InitializeCommandHandlers; override; procedure ListDirectory(ASender: TIdFTPServerContext; ADirectory: string; ADirContents: TStrings; ADetails: Boolean; const ACmd : String = 'LIST'; const ASwitches : String = ''); {do not localize} {$IFNDEF USE_OBJECT_ARC} procedure Notification(AComponent: TComponent; Operation: TOperation); override; {$ENDIF} procedure SetAnonymousAccounts(const AValue: TStrings); procedure SetUserAccounts(const AValue: TIdCustomUserManager); procedure SetFTPSecurityOptions(const AValue: TIdFTPSecurityOptions); procedure SetPASVBoundPortMax(const AValue: TIdPort); procedure SetPASVBoundPortMin(const AValue: TIdPort); procedure SetReplyUnknownSITECommand(AValue: TIdReply); procedure SetSITECommands(AValue: TIdCommandHandlers); procedure ThreadException(AThread: TIdThread; AException: Exception); procedure SetFTPFileSystem(const AValue: TIdFTPBaseFileSystem); function GetMD5Checksum(ASender : TIdFTPServerContext; const AFileName : String) : String; //overrides from TIdTCPServer procedure DoConnect(AContext:TIdContext); override; procedure DoDisconnect(AContext:TIdContext); override; procedure ContextCreated(AContext:TIdContext); override; procedure DoOnDataPortBeforeBind(ASender : TIdFTPServerContext); virtual; procedure DoDataChannelOperation(ASender: TIdCommand; const AConnectMode : Boolean = False);virtual; procedure DoOnDataPortAfterBind(ASender : TIdFTPServerContext); virtual; procedure DoOnCustomListDirectory(ASender: TIdFTPServerContext; const APath: string; ADirectoryListing: TStrings; const ACmd : String; const ASwitches : String); function GetReplyClass: TIdReplyClass; override; function GetRepliesClass: TIdRepliesClass; override; procedure InitComponent; override; procedure DoReplyUnknownCommand(AContext: TIdContext; ALine: string); override; // overriden so we can close active transfers during a shutdown procedure DoTerminateContext(AContext: TIdContext); override; //overriden so we can handle telnet sequences function ReadCommandLine(AContext: TIdContext): string; override; public destructor Destroy; override; property SupportXAUTH : Boolean read FSupportXAUTH write SetSupportXAUTH; published {This is an object that can compress and decompress HTTP Deflate encoding} property Compressor : TIdZLibCompressorBase read FCompressor write FCompressor; property CustomSystID : String read FCustomSystID write FCustomSystID; property DirFormat : TIdFTPDirFormat read FDirFormat write FDirFormat default DEF_DIRFORMAT; property PathProcessing : TIdFTPPathProcessing read FPathProcessing write FPathProcessing default DEF_PATHPROCESSING; property UseTLS; property DefaultPort default IDPORT_FTP; property AllowAnonymousLogin: Boolean read FAllowAnonymousLogin write FAllowAnonymousLogin default Id_DEF_AllowAnon; property AnonymousAccounts: TStrings read FAnonymousAccounts write SetAnonymousAccounts; property AnonymousPassStrictCheck: Boolean read FAnonymousPassStrictCheck write FAnonymousPassStrictCheck default Id_DEF_PassStrictCheck; property DefaultDataPort : TIdPort read FDefaultDataPort write FDefaultDataPort default IdPORT_FTP_DATA; property FTPFileSystem:TIdFTPBaseFileSystem read FFTPFileSystem write SetFTPFileSystem; property FTPSecurityOptions : TIdFTPSecurityOptions read FFTPSecurityOptions write SetFTPSecurityOptions; property EndOfHelpLine : String read FEndOfHelpLine write FEndOfHelpLine; property PASVBoundPortMin : TIdPort read FPASVBoundPortMin write SetPASVBoundPortMin default DEF_PASV_BOUND_MIN; property PASVBoundPortMax : TIdPort read FPASVBoundPortMax write SetPASVBoundPortMax default DEF_PASV_BOUND_MAX; property UserAccounts: TIdCustomUserManager read FUserAccounts write SetUserAccounts; property SystemType: string read FSystemType write FSystemType; property OnGreeting : TIdOnBanner read FOnGreeting write FOnGreeting; property OnLoginSuccessBanner : TIdOnBanner read FOnLoginSuccessBanner write FOnLoginSuccessBanner; property OnLoginFailureBanner : TIdOnBanner read FOnLoginFailureBanner write FOnLoginFailureBanner; //for retreiving MD5 Checksums from a cache property OnMD5Cache : TOnCacheChecksum read FOnMD5Cache write FOnMD5Cache; property OnMD5Verify : TOnVerifyChecksum read FOnMD5Verify write FOnMD5Verify; property OnQuitBanner : TIdOnBanner read FOnQuitBanner write FOnQuitBanner; property OnCustomListDirectory : TOnCustomListDirectoryEvent read FOnCustomListDirectory write FOnCustomListDirectory; property OnCustomPathProcess : TOnCustomPathProcess read FOnCustomPathProcess write FOnCustomPathProcess; property OnAfterUserLogin: TOnAfterUserLoginEvent read FOnAfterUserLogin write FOnAfterUserLogin; property OnChangeDirectory: TOnDirectoryEvent read FOnChangeDirectory write FOnChangeDirectory; property OnGetFileSize: TOnGetFileSizeEvent read FOnGetFileSize write FOnGetFileSize; property OnGetFileDate: TOnGetFileDateEvent read FOnGetFileDate write FOnGetFileDate; property OnUserLogin: TOnFTPUserLoginEvent read FOnUserLogin write FOnUserLogin; property OnUserAccount : TOnFTPUserAccountEvent read FOnUserAccount write SetOnUserAccount; property OnListDirectory: TOnListDirectoryEvent read FOnListDirectory write FOnListDirectory; property OnDataPortBeforeBind : TOnDataPortBind read FOnDataPortBeforeBind write FOnDataPortBeforeBind; property OnDataPortAfterBind : TOnDataPortBind read FOnDataPortAfterBind write FOnDataPortAfterBind; property OnRenameFile: TOnRenameFileEvent read FOnRenameFile write FOnRenameFile; property OnDeleteFile: TOnFileEvent read FOnDeleteFile write FOnDeleteFile; property OnRetrieveFile: TOnRetrieveFileEvent read FOnRetrieveFile write FOnRetrieveFile; property OnStoreFile: TOnStoreFileEvent read FOnStoreFile write FOnStoreFile; property OnMakeDirectory: TOnDirectoryEvent read FOnMakeDirectory write FOnMakeDirectory; property OnRemoveDirectory: TOnDirectoryEvent read FOnRemoveDirectory write FOnRemoveDirectory; property OnStat : TIdOnFTPStatEvent read FOnStat write FOnStat; property OnCombineFiles : TOnCombineFiles read FOnCombineFiles write FOnCombineFiles; property OnCRCFile : TOnCheckSumFile read FOnCRCFile write FOnCRCFile; property OnSetCreationTime : TOnSetFileDateEvent read FOnSetCreationTime write FOnSetCreationTime; property OnSetModifiedTime : TOnSetFileDateEvent read FOnSetModifiedTime write FOnSetModifiedTime; property OnFileExistCheck : TOnCheckFileEvent read FOnFileExistCheck write FOnFileExistCheck; property OnHostCheck : TOnHostCheck read FOnHostCheck write FOnHostCheck; property OnSetATTRIB : TOnSetATTRIB read FOnSetATTRIB write FOnSetATTRIB; property OnSiteUMASK : TOnSiteUMASK read FOnSiteUMASK write FOnSiteUMASK; property OnSiteCHMOD : TOnSiteCHMOD read FOnSiteCHMOD write FOnSiteCHMOD; property OnSiteCHOWN : TOnSiteCHOWN read FOnSiteCHOWN write FOnSiteCHOWN; property OnSiteCHGRP : TOnSiteCHGRP read FOnSiteCHGRP write FOnSiteCHGRP; { READ THIS!!! Do not change values in the OnPASV event unless you have a compelling reason to do so. In SPSV, the PORT is the only thing that can work because that's all which is given as a reply. The server IP is the same one that the client connects to. In EPSV, the PORT is the only thing that can work because that's all which is given as a reply. The server IP is the same one that the client connects to. } property OnPASVBeforeBind : TIdOnPASVRange read FOnPASVBeforeBind write FOnPASVBeforeBind; property OnPASVReply : TIdOnPASV read FOnPASVReply write FOnPASVReply; property OnMLST : TIdOnMLST read FOnMLST write FOnMLST; property OnSiteUTIME : TOnSiteUTIME read FOnSiteUTIME write FOnSiteUTIME; property OnAvailDiskSpace : TIdOnDirSizeInfo read FOnAvailDiskSpace write FOnAvailDiskSpace; property OnCompleteDirSize : TIdOnDirSizeInfo read FOnCompleteDirSize write FOnCompleteDirSize; property SITECommands: TIdCommandHandlers read FSITECommands write SetSITECommands; property MLSDFacts : TIdMLSDAttrs read FMLSDFacts write FMLSDFacts; property OnClientID : TIdOnClientID read FOnClientID write FOnClientID; property ReplyUnknownSITCommand: TIdReply read FReplyUnknownSITECommand write SetReplyUnknownSITECommand; end; {This is used internally for some Telnet sequence parsing} type TIdFTPTelnetState = (tsData, tsCheckCR, tsIAC, tsWill, tsDo, tsWont, tsDont, tsNegotiate, tsNegotiateData, tsNegotiateIAC, tsInterrupt, tsInterruptIAC); implementation uses {$IFDEF DOTNET} {$IFDEF USE_INLINE} System.Threading, {$ENDIF} {$ENDIF} {$IFDEF USE_VCL_POSIX} Posix.SysSelect, Posix.SysTime, {$ENDIF} IdFIPS, IdHash, IdHashCRC, IdHashMessageDigest, IdHashSHA, IdIOHandlerSocket, IdResourceStringsProtocols, IdGlobalProtocols, IdSimpleServer, IdSSL, IdIOHandlerStack, IdSocketHandle, IdStrings, IdTCPClient, IdEMailAddress, IdStack, IdFTPListTypes; const //THese commands need some special treatment in the Indy 10 FTP Server help system //as they will not always work HELP_SPEC_CMDS : array [0..25] of string = ('SIZE','MDTM', {do not localize} 'AUTH','PBSZ','PROT','CCC','MIC','CONF','ENC', 'SSCN','CPSV', {do not localize} 'MFMT','MFF', 'MD5','MMD5','XCRC','XMD5','XSHA1','XSHA256','XSHA512', {do not localize} 'COMB','AVBL','DSIZ','RMDA','HOST','XAUT'); {do not localize} //These commands must always be present even if not implemented //alt help topics and superscripts should be used sometimes. //These are mandated by RFC 1123 HELP_ALT_MD_CMD : array [0..17] of string = ('RETR', {do not localize} 'STOR','STOU', {do not localize} 'APPE', {do not localize} 'RNFR', 'RNTO', {do not localize} 'DELE', {do not localize} 'LIST','NLST', {do not localize} 'CWD','XCWD', {do not localize} 'CDUP','XCUP', {do not localize} 'RMD','XRMD', {do not localize} 'MKD', 'XMKD', {do not localize} 'SYST'); {do not localize} HELP_ALT_MD_TP : array [0..17] of string = ('RETR (retrieve); unimplemented.', {do not localize} 'STOR (store); unimplemented.', {do not localize} 'STOU (store unique); unimplemented.', {do not localize} 'APPE (append); unimplemented.', {do not localize} 'RNFR (rename from); unimplemented.', {do not localize} 'RNTO (rename to); unimplemented.', {do not localize} 'DELE (delete); unimplemented.', {do not localize} 'LIST (list); unimplemented.', {do not localize} 'NLIST (name-list); unimplemented.', {do not localize} 'CWD (change working directory); unimplemented.', {do not localize} 'XCWD (change working directory); unimplemented.', {do not localize} 'CDUP (change to parent directory); unimplemented.', {do not localize} 'XCDUP (change to parent directory); unimplemented.', {do not localize} 'RMD (remove Directory); unimplemented.', {do not localize} 'XRMD (remove Directory); unimplemented.', {do not localize} 'MKD (make Directory); unimplemented.', {do not localize} 'XMKD (make Directory); unimplemented.', {do not localize} 'SYST (system); unimplemented.' {do not localize} ); //SSCN, OPTS MODE Z EXTRA, and OPTS UTF8 states OnOffStates : array [0..1] of string = ('ON', {do not localize} 'OFF' {do not localize} ); const //%s = host //%n = xauth key XAUTHBANNER = '%s X2 WS_FTP Server Compatible(%d)'; ACCT_HELP_DISABLED = 'ACCT (specify account); unimplemented.'; {do not localize} ACCT_HELP_ENABLED = 'Syntax: ACCT '; const NLSTEncType: array[Boolean] of IdTextEncodingType = (encASCII, encUTF8); function CalculateCheckSum(AHashClass: TIdHashClass; AStrm: TStream; ABeginPos, AEndPos: TIdStreamSize): String; {$IFDEF USE_INLINE} inline; {$ENDIF} var LHash: TIdHash; begin LHash := AHashClass.Create; try Result := LHash.HashStreamAsHex(AStrm, ABeginPos, AEndPos-ABeginPos); finally LHash.Free; end; end; procedure XAutGreeting(AContext: TIdContext; AGreeting : TIdReply; const AHostName : String); {$IFDEF USE_INLINE} inline; {$ENDIF} var s : String; begin //for XAUT to work with WS-FTP Pro, you need a banner mentioning "WS_FTP Server" //and that banner can only be one line in length. s := IndyFormat(XAUTHBANNER, [ GStack.HostName, (AContext as TIdFTPServerContext).FXAUTKey]) + ' '+AGreeting.Text.Text; s := Fetch(s,CR); s := Fetch(s,LF); AGreeting.Text.Text := s; end; { TIdFTPServer } constructor TIdFTPServerContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); begin inherited Create(AConnection, AYarn, AList); FUserSecurity := TIdFTPSecurityOptions.Create; //we don't initialize FCCC flag here because that shouldn't be cleared with implicit SSL FCCC := False; FDataMode := dmStream; FMLSOpts := [ItemType, Modify, Size]; //no write permissions for group and others FUMask := 22; ResetZLibSettings; ReInitialize; end; procedure TIdFTPServerContext.SetUserSecurity(const Value: TIdFTPSecurityOptions); begin FUserSecurity.Assign( Value); end; destructor TIdFTPServerContext.Destroy; begin KillDataChannel; FreeAndNil(FUserSecurity); inherited Destroy; end; procedure TIdFTPServerContext.CreateDataChannel(APASV: Boolean = False); begin KillDataChannel; //let the old one terminate FDataChannel := TIdDataChannel.Create(APASV, Self, UserSecurity.RequirePASVFromSameIP, Server); end; procedure TIdFTPServerContext.KillDataChannel; begin if Assigned(FDataChannel) then begin if not FDataChannel.Stopped then begin FDataChannel.Stopped := True; FDataChannel.FDataChannel.Disconnect(False); end; FreeAndNil(FDataChannel); end; end; procedure TIdFTPServerContext.ReInitialize; begin inherited; FDataType := ftASCII; // FDataMode := dmStream; FDataPort := 0; FDataStruct := dsFile; FPASV := False; FEPSVAll := False; FDataProtection := ftpdpsClear; DataPBSZCalled := False; FDataProtBufSize := 0; end; function TIdFTPServerContext.IsAuthenticated(ASender: TIdCommand): Boolean; begin Result := FAuthenticated; if not Result then begin ASender.Reply.SetReply(530, RSFTPUserNotLoggedIn); end; end; { TIdFTPServer } procedure TIdFTPServer.InitComponent; begin inherited InitComponent; HelpReply.Code := ''; //we will handle the help ourselves FDataChannelCommands := TIdCommandHandlers.Create(Self, FReplyClass, ReplyTexts, ExceptionReply); FSITECommands := TIdCommandHandlers.Create(Self, FReplyClass, ReplyTexts, ExceptionReply); FOPTSCommands := TIdCommandHandlers.Create(Self, FReplyClass, ReplyTexts, ExceptionReply); //inherited from TLS classes FRegularProtPort := IdPORT_FTP; FImplicitTLSProtPort := IdPORT_ftps; // FAnonymousAccounts := TStringList.Create; // By default these user names will be treated as anonymous. FAnonymousAccounts.Add('anonymous'); { do not localize } FAnonymousAccounts.Add('ftp'); { do not localize } FAnonymousAccounts.Add('guest'); { do not localize } FAllowAnonymousLogin := Id_DEF_AllowAnon; FAnonymousPassStrictCheck := Id_DEF_PassStrictCheck; DefaultPort := IDPORT_FTP; DefaultDataPort := IdPORT_FTP_DATA; // FEmulateSystem := Id_DEF_SystemType; Greeting.SetReply(220, RSFTPDefaultGreeting); FContextClass := TIdFTPServerContext; ReplyUnknownCommand.SetReply(500, 'Unknown Command'); {do not localize} FReplyUnknownSITECommand := FReplyClass.Create(nil); FReplyUnknownSITECommand.SetReply(500, 'Invalid SITE command.'); {do not localize} FFTPSecurityOptions := TIdFTPSecurityOptions.Create; FPASVBoundPortMin := DEF_PASV_BOUND_MIN; FPASVBoundPortMax := DEF_PASV_BOUND_MAX; FPathProcessing := DEF_PATHPROCESSING; FDirFormat := DEF_DIRFORMAT; end; function TIdFTPServer.GetReplyClass: TIdReplyClass; begin Result := TIdReplyFTP; end; function TIdFTPServer.GetRepliesClass: TIdRepliesClass; begin Result := TIdRepliesFTP; end; procedure TIdFTPServer.CommandHELP(ASender: TIdCommand); var s : String; LCmds : TStringList; i : Integer; LExp : String; function ShouldShowCommand(const ACommand : String) : Boolean; begin Result := False; case PosInStrArray(ACommand, HELP_SPEC_CMDS, False) of -1 : Result := True; 0 : //'SIZE' if Assigned(FOnGetFileSize) then begin Result := True; end; 1 :// 'MDTM', if Assigned(FOnGetFileDate) or Assigned(FTPFileSystem) then begin Result := True; end; 2 : // 'AUTH' if (FUseTLS in ExplicitTLSVals) then begin Result := True; end; 3,4,5,6,7,8,9,10 : //'PBSZ','PROT', 'CCC','MIC','CONF','ENC','SSCN','CPSV', if (FUseTLS <> utNoTLSSupport) then begin Result := True; end; 11,12 : // 'MFMT','MFF', if Assigned(FOnSetModifiedTime) or Assigned(FTPFileSystem) then begin Result := True; end; 13,14, 15,16 : //'MD5','MMD5','XCRC','XMD5', begin Result := False; if not GetFIPSMode then begin if Assigned(FOnCRCFile) or Assigned(FTPFileSystem) then begin Result := True; end; end; end; 17 : // 'XSHA1', if Assigned(FOnCRCFile) or Assigned(FTPFileSystem) then begin Result := True; end; 18 : //'XSHA256' if (Assigned(FOnCRCFile) or Assigned(FTPFileSystem)) and TIdHashSHA256.IsAvailable then begin Result := True; end; 19 : //'XSHA512' if (Assigned(FOnCRCFile) or Assigned(FTPFileSystem)) and TIdHashSHA512.IsAvailable then begin Result := True; end; 20 : // 'COMB'); if Assigned(OnCombineFiles) or Assigned(FTPFileSystem) then begin Result := True; end; 21 : // AVBL if Assigned(FOnAvailDiskSpace) then begin Result := True; end; 22 : // DSIZ if Assigned(FOnCompleteDirSize) then begin Result := True; end; 23 : // RMDA if Assigned(FOnRemoveDirectoryAll) then begin Result := True; end; 24 : // HOST if Assigned( FOnHostCheck ) then begin Result := True; end; 25 : // XAUT if (not GetFIPSMode) and Self.FSupportXAUTH then begin Result := True; end; end; end; function IsNotImplemented(const ACommand : String; var VHelp : String) : Boolean; var idx : Integer; begin Result := False; //presume that the command is implemented idx := PosInStrArray(ACommand, HELP_ALT_MD_CMD, False); if idx = -1 then begin Exit; end; case idx of 0 : // 'RETR' begin if (not Assigned(FOnRetrieveFile)) and (not Assigned(FFTPFileSystem)) then begin Result := True; end; end; 1,2,3 : //'STOR','STOU', 'APPE', begin if (not Assigned(FOnStoreFile)) and (not Assigned(FFTPFileSystem)) then begin Result := True; end; end; 4,5 : // 'RNFR', 'RNTO', begin if (not Assigned(FOnRenameFile)) and (not Assigned(FFTPFileSystem)) then begin Result := True; end; end; 6 : // 'DELE', begin if (not Assigned(FOnDeleteFile)) and (not Assigned(FFTPFileSystem)) then begin Result := True; end; end; 7,8 :// 'LIST','NLST', begin if (not Assigned(FOnListDirectory)) or ((FDirFormat = ftpdfCustom) and (not Assigned(OnCustomListDirectory))) then begin Result := True; end; end; 9, 10, //'CWD','XCWD', 11, 12 : // 'CDUP','XCUP', begin if (not Assigned(FOnChangeDirectory)) and (not Assigned(FFTPFileSystem)) then begin Result := True; end; end; 13, 14 : //'RMD','XRMD', begin if (not Assigned(FOnRemoveDirectory)) and (not Assigned(FFTPFileSystem)) then begin Result := True; end; end; 15,16 : //'MKD', 'XMKD', begin if (not Assigned(FOnMakeDirectory)) and (not Assigned(FFTPFileSystem)) then begin Result := True; end; end; 17 :// 'SYST', begin if (not Assigned(FOnMakeDirectory)) and (not Assigned(FFTPFileSystem)) then begin Result := True; end; end; end; if Result then begin LExp := HELP_ALT_MD_TP[idx]; end; end; begin if ASender.Params.Count > 0 then begin for i := 0 to CommandHandlers.Count-1 do begin if TextIsSame(ASender.Params[0], CommandHandlers.Items[i].Command) then begin if CommandHandlers.Items[i].HelpVisible and ShouldShowCommand(ASender.Params[0]) then begin if IsNotImplemented(CommandHandlers.Items[i].Command, LExp) then begin ASender.Reply.SetReply(214, LExp); end else begin ASender.Reply.SetReply(214, CommandHandlers.Items[i].Description.Text); end; end else begin ASender.Reply.SetReply(502, IndyFormat(RSFTPCmdHelpNotKnown, [UpperCase(ASender.Params[0])])); end; Exit; end; end; ASender.Reply.SetReply(502, IndyFormat(RSFTPCmdHelpNotKnown, [UpperCase(ASender.Params[0])])); end else begin s := RSFTPHelpBegining + EOL; LCmds := TStringList.Create; try // for i := 0 to CommandHandlers.Count -1 do begin if CommandHandlers.Items[i].HelpVisible and ShouldShowCommand(CommandHandlers.Items[i].Command) then begin if IsNotImplemented(CommandHandlers.Items[i].Command, LExp) then begin LCmds.Add(CommandHandlers.Items[i].Command + '*'); {do not localize} end else begin LCmds.Add(CommandHandlers.Items[i].Command + CommandHandlers.Items[i].HelpSuperScript); end; end; end; LCmds.Sort; s := s + HelpText(LCmds) + FEndOfHelpLine; if FEndOfHelpLine = '' then begin s := s + EOL; //prevent ugliness if last row out of alignment with the rest end; ASender.Reply.SetReply(214, s); finally FreeAndNil(LCmds); end; end; end; procedure TIdFTPServer.CommandHOST(ASender: TIdCommand); var LTmp : String; LValid : Boolean; LContext : TIdFTPServerContext; begin LContext := TIdFTPServerContext(ASender.Context); if Assigned(OnHostCheck) then begin if LContext.Username <> '' then begin ASender.Reply.SetReply(530, RSFTPNotAfterAuthentication ); Exit; end; if (ASender.Params.Count > 0) then begin LTmp := ASender.Params[0]; if Copy(LTmp,1,1)='[' then begin Delete(LTmp,1,1); end; LTmp := Fetch(LTmp,']'); LValid := False; FOnHostCheck(LContext,LTmp,LValid); if LValid then begin LContext.Host := LTmp; if Assigned(OnGreeting) then begin OnGreeting(LContext,ASender.Reply); end; if ASender.Reply.NumericCode = 421 then begin ASender.Disconnect := True; end else begin if not GetFIPSMode then begin //setting the reply code number directly causes the text to be cleared if FSupportXAUTH and (ASender.Reply.NumericCode = 220) then begin XAutGreeting(LContext,ASender.Reply, LTmp); end; end; ASender.Reply.SetReply(220,ASender.Reply.Text.Text); end; ASender.SendReply; end else begin ASender.Reply.SetReply(530,RSFTPHostNotFound); end; end; end else begin CmdSyntaxError(ASender); end; end; procedure TIdFTPServer.InitializeCommandHandlers; var LCmd : TIdCommandHandler; begin inherited InitializeCommandHandlers; //ACCESS CONTROL COMMANDS //USER LCmd := CommandHandlers.Add; LCmd.Command := 'USER'; {Do not Localize} LCmd.OnCommand := CommandUSER; LCmd.Description.Text := 'Syntax: USER username'; {do not localize} //PASS LCmd := CommandHandlers.Add; LCmd.Command := 'PASS'; {Do not Localize} LCmd.OnCommand := CommandPASS; LCmd.Description.Text := 'Syntax: PASS password'; {do not localize} //ACCT LCmd := CommandHandlers.Add; LCmd.Command := 'ACCT'; {Do not Localize} // LCMd.NormalReply.SetReply(502, IndyFormat(RSFTPCmdNotImplemented, ['ACCT'])); {do not localize} LCmd.OnCommand := CommandACCT; if Assigned(Self.FOnUserAccount) then begin LCmd.HelpSuperScript := ''; //not supported LCmd.Description.Text := ACCT_HELP_ENABLED; end else begin LCmd.HelpSuperScript := '*'; //not supported LCmd.Description.Text := ACCT_HELP_DISABLED; end; // 'ACCT (specify account); unimplemented.'; {do not localize} { LCmd.NormalReply.SetReply(502, Format(RSFTPCmdNotImplemented, ['ACCT'])); {Do not Localize} //CWD LCmd := CommandHandlers.Add; LCmd.Command := 'CWD'; {Do not Localize} LCmd.OnCommand := CommandCWD; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: CWD [ directory-name ]'; {do not localize} //CDUP LCmd := CommandHandlers.Add; LCmd.Command := 'CDUP'; {Do not Localize} LCmd.OnCommand := CommandCDUP; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: CDUP (change to parent directory)'; {do not localize} //SMNT LCmd := CommandHandlers.Add; LCmd.Command := 'SMNT'; {Do not Localize} LCmd.NormalReply.SetReply(502, RSFTPFileActionCompleted);//250 for success LCmd.HelpSuperScript := '*'; LCmd.Description.Text := 'SMNT (structure mount); unimplemented.'; {do not localize} //QUIT LCmd := CommandHandlers.Add; LCmd.Command := 'QUIT'; {Do not Localize} LCmd.OnCommand := CommandQUIT; LCmd.Disconnect := True; LCmd.NormalReply.SetReply(221, RSFTPQuitGoodby); {Do not Localize} LCmd.Description.Text := 'Syntax: QUIT (terminate service)'; {do not localize} //REIN LCmd := CommandHandlers.Add; LCmd.Command := 'REIN'; {Do not Localize} LCmd.OnCommand := CommandREIN; LCmd.Description.Text := 'Syntax: REIN (reinitialize server state)'; {do not localize} //PORT LCmd := CommandHandlers.Add; LCmd.Command := 'PORT'; {Do not Localize} LCmd.OnCommand := CommandPORT; LCmd.Description.Text := 'Syntax: PORT b0, b1, b2, b3, b4'; {do not localize} //PASV LCmd := CommandHandlers.Add; LCmd.Command := 'PASV'; {Do not Localize} LCmd.OnCommand := CommandPASV; LCmd.Description.Text := 'Syntax: PASV (set server in passive mode)'; {do not localize} //P@SW //This is for some routers that replace a PASV with a P@SW //as part of a misguided attempt to add a feature. //A router would do a replacement so a client would think that //PASV wasn't supported and then the client would do a PORT command //instead. That doesn't happen so this just caused the client not to work. //See: http://www.gbnetwork.co.uk/smcftpd/ LCmd := CommandHandlers.Add; LCmd.Command := 'P@SW'; {Do not Localize} LCmd.OnCommand := CommandPASV; LCmd.HelpVisible := False; //this is just a workaround //TYPE LCmd := CommandHandlers.Add; LCmd.Command := 'TYPE'; {Do not Localize} LCmd.OnCommand := CommandTYPE; LCmd.Description.Text := 'Syntax: TYPE [ A | E | I | L ]'; {do not localize} //STRU LCmd := CommandHandlers.Add; LCmd.Command := 'STRU'; {Do not Localize} LCmd.OnCommand := CommandSTRU; LCmd.Description.Text := 'Syntax: STRU (specify file structure)'; {do not localize} //MODE LCmd := CommandHandlers.Add; LCmd.Command := 'MODE'; {Do not Localize} LCmd.OnCommand := CommandMODE; LCmd.ExceptionReply.NumericCode := 501; LCmd.Description.Text := 'Syntax: MODE (specify transfer mode)'; {do not localize} //FTP SERVICE COMMANDS //RETR LCmd := CommandHandlers.Add; LCmd.Command := 'RETR'; {Do not Localize} LCmd.OnCommand := CommandRETR; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: RETR file-name'; {do not localize} //STOR LCmd := CommandHandlers.Add; LCmd.Command := 'STOR'; {Do not Localize} LCmd.OnCommand := CommandSSAP; LCmd.ExceptionReply.NumericCode := 551; LCmd.Description.Text := 'Syntax: STOR file-name'; {do not localize} //STOU LCmd := CommandHandlers.Add; LCmd.Command := 'STOU'; {Do not Localize} LCmd.OnCommand := CommandSSAP; LCmd.ExceptionReply.NumericCode := 551; LCmd.Description.Text := 'Syntax: STOU file-name'; {do not localize} //APPE LCmd := CommandHandlers.Add; LCmd.Command := 'APPE'; {Do not Localize} LCmd.OnCommand := CommandSSAP; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: APPE file-name'; {do not localize} //ALLO // [ R ] LCmd := CommandHandlers.Add; LCmd.Command := 'ALLO'; {Do not Localize} LCmd.OnCommand := CommandALLO; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: ALLO allocate storage (vacuously)'; {do not localize} //REST LCmd := CommandHandlers.Add; LCmd.Command := 'REST'; {Do not Localize} LCmd.OnCommand := CommandREST; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: REST (restart command)'; {do not localize} //RNFR LCmd := CommandHandlers.Add; LCmd.Command := 'RNFR'; {Do not Localize} LCmd.OnCommand := CommandRNFR; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: RNFR file-name'; {do not localize} //RNTO LCmd := CommandHandlers.Add; LCmd.Command := 'RNTO'; {Do not Localize} LCmd.OnCommand := CommandRNTO; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: RNTO file-name'; {do not localize} //ABOR LCmd := CommandHandlers.Add; LCmd.Command := 'ABOR'; {Do not Localize} LCmd.OnCommand := CommandABOR; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: ABOR (abort operation)'; {do not localize} //DELE LCmd := CommandHandlers.Add; LCmd.Command := 'DELE'; {Do not Localize} LCmd.OnCommand := CommandDELE; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: DELE file-name'; {do not localize} // 'SMNT (structure mount); unimplemented.'; //RMD LCmd := CommandHandlers.Add; LCmd.Command := 'RMD'; {Do not Localize} LCmd.OnCommand := CommandRMD; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: RMD path-name'; {do not localize} //MKD LCmd := CommandHandlers.Add; LCmd.Command := 'MKD'; {Do not Localize} LCmd.OnCommand := CommandMKD; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: MKD path-name'; {do not localize} //PWD LCmd := CommandHandlers.Add; LCmd.Command := 'PWD'; {Do not Localize} LCmd.OnCommand := CommandPWD; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: PWD (return current directory)'; {do not localize} //LIST [ ] LCmd := CommandHandlers.Add; LCmd.Command := 'LIST'; {Do not Localize} LCmd.OnCommand := CommandLIST; LCmd.ExceptionReply.NumericCode := 450; LCmd.Description.Text := 'Syntax: LIST [ path-name ]'; {do not localize} //NLST [ ] LCmd := CommandHandlers.Add; LCmd.Command := 'NLST'; {Do not Localize} LCmd.OnCommand := CommandLIST; LCmd.ExceptionReply.NumericCode := 450; LCmd.Description.Text := 'Syntax: NLST [ path-name ]'; {do not localize} //SITE LCmd := CommandHandlers.Add; LCmd.Command := 'SITE'; {Do not Localize} LCmd.OnCommand := CommandSITE; LCmd.ExceptionReply.NumericCode := 501; LCmd.Description.Text := 'Syntax: SITE (site-specific commands)'; //SYST LCmd := CommandHandlers.Add; LCmd.Command := 'SYST'; {Do not Localize} LCmd.OnCommand := CommandSYST; LCmd.ExceptionReply.NumericCode := 501; LCmd.Description.Text := 'Syntax: SYST (get type of operating system)'; {do not localize} //STAT [ ] LCmd := CommandHandlers.Add; LCmd.Command := 'STAT'; {Do not Localize} LCmd.OnCommand := CommandSTAT; LCmd.ExceptionReply.NumericCode := 450; LCmd.Description.Text := 'Syntax: CWD [ directory-name ]'; {do not localize} //NOOP LCmd := CommandHandlers.Add; LCmd.Command := 'NOOP'; {Do not Localize} LCmd.NormalReply.SetReply(200, IndyFormat(RSFTPCmdSuccessful, ['NOOP'])); {Do not Localize} LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: NOOP'; {do not localize} //RFC 775 LCmd := CommandHandlers.Add; LCmd.Command := 'XMKD'; {Do not Localize} LCmd.OnCommand := CommandMKD; LCmd.ExceptionReply.NumericCode := 551; //use the ones in parathensies LCmd.Description.Text := 'Syntax: XMKD path-name'; {do not localize} //XCWD LCmd := CommandHandlers.Add; LCmd.Command := 'XCWD'; {Do not Localize} LCmd.OnCommand := CommandCWD; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: XCWD [ directory-name ]'; {do not localize} LCmd := CommandHandlers.Add; LCmd.Command := 'XRMD'; {Do not Localize} LCmd.OnCommand := CommandRMD; LCmd.ExceptionReply.NumericCode := 551; //use the ones in parathensies LCmd.Description.Text := 'Syntax: XRMD path-name'; {do not localize} LCmd := CommandHandlers.Add; LCmd.Command := 'XPWD'; {Do not Localize} LCmd.OnCommand := CommandPWD; LCmd.ExceptionReply.NumericCode := 502; LCmd.Description.Text := 'Syntax: PWD (return current directory)'; {do not localize} LCmd := CommandHandlers.Add; LCmd.Command := 'XCUP'; {Do not Localize} LCmd.OnCommand := CommandCDUP; LCmd.ExceptionReply.NumericCode := 551; //use the ones in parathensies LCmd.Description.Text := 'Syntax: XCUP (change to parent directory)'; {do not localize} //RFC 2389 LCmd := CommandHandlers.Add; LCmd.Command := 'FEAT'; {Do not Localize} LCmd.OnCommand := CommandFEAT; SetRFCReplyFormat(LCmd.NormalReply); LCmd.ExceptionReply.NumericCode := 501; LCmd.Description.Text := 'Syntax: FEAT (returns feature list)'; {do not localize} //RFC 2389 LCmd := CommandHandlers.Add; LCmd.Command := 'OPTS'; {Do not Localize} LCmd.OnCommand := CommandOPTS; LCmd.ExceptionReply.NumericCode := 501; LCmd.Description.Text := 'Syntax: OPTS command [ options]'; {do not localize} //SIZE [] CRLF LCmd := CommandHandlers.Add; LCmd.Command := 'SIZE'; {Do not Localize} LCmd.OnCommand := CommandSIZE; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: SIZE path-name'; {do not localize} //EPSV [protocol] LCmd := CommandHandlers.Add; LCmd.Command := 'EPSV'; {Do not Localize} LCmd.OnCommand := CommandEPSV; LCmd.ExceptionReply.NumericCode := 501; LCmd.Description.Text := 'Syntax: EPSV (returns port |||port|)'; {do not localize} //EPRT [address/port string] LCmd := CommandHandlers.Add; LCmd.Command := 'EPRT'; {Do not Localize} LCmd.OnCommand := CommandEPRT; LCmd.ExceptionReply.NumericCode := 501; LCmd.Description.Text := 'Syntax: EPRT |proto|addr|port|'; {do not localize} //MDTM [] LCmd := CommandHandlers.Add; LCmd.Command := 'MDTM'; {Do not Localize} LCmd.OnCommand := CommandMDTM; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: MDTM path-name'; {do not localize} //RFC 2228 //AUTH [Mechanism] LCmd := CommandHandlers.Add; LCmd.Command := 'AUTH'; {Do not translate} LCmd.OnCommand := CommandAUTH; LCmd.ExceptionReply.NumericCode := 501; LCmd.Description.Text := 'Syntax: AUTH mechanism-name'; {do not localize} //PBSZ [Protection Buffer Size] LCmd := CommandHandlers.Add; LCmd.Command := 'PBSZ'; {Do not translate} LCmd.OnCommand := CommandPBSZ; LCmd.ExceptionReply.NumericCode := 501; LCmd.Description.Text := 'Syntax: PBSZ protection buffer size'; {do not localize} //PROT Protection Type LCmd := CommandHandlers.Add; LCmd.Command := 'PROT'; {Do not translate} LCmd.OnCommand := CommandPROT; LCmd.ExceptionReply.NumericCode := 501; LCmd.Description.Text := 'Syntax: PROT protection code'; {do not localize} //CCC Clear Command Channel LCmd := CommandHandlers.Add; LCmd.Command := 'CCC'; {Do not translate} LCmd.OnCommand := CommandCCC; LCmd.Description.Text := 'Syntax: CCC (clear command channel)'; {do not localize} //MIC Integrity Protected Command LCmd := CommandHandlers.Add; LCmd.Command := 'MIC'; {Do not translate} LCmd.OnCommand := CommandSecRFC; LCmd.HelpSuperScript := '*'; LCmd.Description.Text := 'MIC (integrity protected command); unimplemented.'; {do not localize} //CONF Confidentiality protected command LCmd := CommandHandlers.Add; LCmd.Command := 'CONF'; {Do not translate} LCmd.OnCommand := CommandSecRFC; LCmd.HelpSuperScript := '*'; LCmd.Description.Text := 'CONF (confidentiality protected command); unimplemented.'; {do not localize} //ENC Privacy Protected command LCmd := CommandHandlers.Add; LCmd.Command := 'ENC'; {Do not translate} LCmd.OnCommand := CommandSecRFC; LCmd.HelpSuperScript := '*'; LCmd.Description.Text := 'ENC (privacy protected command); unimplemented.'; {do not localize} //These are from IETF Draft "Extensions to FTP" //MLSD [Pathname] LCmd := CommandHandlers.Add; LCmd.Command := 'MLSD'; {Do not translate} LCmd.OnCommand := CommandMLSD; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: MLSD [ path-name ]'; {do not localize} //MLST [Pathname] LCmd := CommandHandlers.Add; LCmd.Command := 'MLST'; {Do not translate} LCmd.OnCommand := CommandMLST; SetRFCReplyFormat(LCmd.NormalReply); LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: MLST [ path-name ]'; {do not localize} //Defined in http://www.trevezel.com/downloads/draft-somers-ftp-mfxx-00.html //Modify File Modification Time //MFMT [ATime] [Path-name] LCmd := CommandHandlers.Add; LCmd.Command := 'MFMT'; {Do not translate} LCmd.OnCommand := CommandMFMT; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: MFMT [ATime] [Path-name]'; {do not localize} //Defined in http://www.trevezel.com/downloads/draft-somers-ftp-mfxx-00.html //Modify File Creation Time //MFMT [ATime] [Pathname] LCmd := CommandHandlers.Add; LCmd.Command := 'MFCT'; {Do not translate} LCmd.OnCommand := CommandMFCT; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: MFCT [ATime] [Path-name]'; {do not localize} //params are the same format as the MLS output LCmd := CommandHandlers.Add; LCmd.Command := 'MFF'; {Do not translate} LCmd.OnCommand := CommandMFF; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: MFF [ mff-facts ] SP path-name'; {do not localize} //From http://www.ietf.org/internet-drafts/draft-twine-ftpmd5-00.txt //MD5 [Pathname] LCmd := CommandHandlers.Add; LCmd.Command := 'MD5'; {Do not translate} LCmd.OnCommand := CommandMD5; LCmd.ExceptionReply.NumericCode := 504; LCmd.Description.Text := 'Syntax: MD5 [Pathname]'; {do not localize} //MMD5 [Filepath1], [Filepath2] [...] LCmd := CommandHandlers.Add; LCmd.Command := 'MMD5'; {Do not translate} LCmd.OnCommand := CommandMMD5; LCmd.ExceptionReply.NumericCode := 504; LCmd.Description.Text := 'Syntax: MMD5 [Filepath1], [Filepath2] [...]'; {do not localize} //These two commands are not in RFC's or drafts // but are documented in: // GlobalSCAPE Secure FTP Server User’s Guide //XCRC "[filename]" [start] [finish] LCmd := CommandHandlers.Add; LCmd.Command := 'XCRC'; {Do not translate} LCmd.OnCommand := CommandCheckSum; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: XCRC "[file-name]" [start] [finish]'; {do not localize} //COMB "[filename]" [start] [finish] LCmd := CommandHandlers.Add; LCmd.Command := 'COMB'; {Do not translate} LCmd.OnCommand := CommandCOMB; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: COMB "[file-name]" [start] [finish]'; {do not localize} //informal but we might want to support this anyway //SSCN - specified by: //http://www.raidenftpd.com/kb/kb000000037.htm LCmd := CommandHandlers.Add; LCmd.Command := 'SSCN'; {Do not translate} LCmd.OnCommand := CommandSSCN; LCmd.ExceptionReply.NumericCode := 550; LCmd.NormalReply.NumericCode := 200; LCmd.Description.Text := 'Syntax: SSCN [ON|OFF]'; {do not localize} //CPSV LCmd := CommandHandlers.Add; LCmd.Command := 'CPSV'; {Do not Localize} LCmd.OnCommand := CommandCPSV; LCmd.Description.Text := 'Syntax: CPSV (set server in passive mode with SSL Connect)'; {do not localize} //Seen in RaidenFTPD documentation //XCRC "[filename]" [start] [finish] LCmd := CommandHandlers.Add; LCmd.Command := 'XMD5'; {Do not translate} LCmd.OnCommand := CommandCheckSum; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: XMD5 "[filename]" [start] [finish]'; {do not localize} //Seen in RaidenFTPD documentation //XCRC "[filename]" [start] [finish] LCmd := CommandHandlers.Add; LCmd.Command := 'XSHA1'; {Do not translate} LCmd.OnCommand := CommandCheckSum; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: XSHA1 "[filename]" [start] [finish]'; {do not localize} LCmd := CommandHandlers.Add; LCmd.Command := 'XSHA256'; {Do not translate} LCmd.OnCommand := CommandCheckSum; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'Syntax: XSHA256 "[filename]" [start] [finish]'; {do not localize} LCmd := CommandHandlers.Add; LCmd.Command := 'XSHA512'; {Do not translate} LCmd.OnCommand := CommandCheckSum; LCmd.ExceptionReply.NumericCode := 550; LCmd.HelpVisible := True; LCmd.Description.Text := 'Syntax: XSHA512 "[filename]" [start] [finish]'; {do not localize} //commands from // draft-peterson-streamlined-ftp-command-extensions-01.txt //http://tools.ietf.org/html/draft-peterson-streamlined-ftp-command-extensions-01#section-2.4 LCmd := CommandHandlers.Add; LCmd.Command := 'AVBL'; {Do not localize} LCmd.OnCommand := CommandAVBL; LCmd.ExceptionReply.NumericCode := 500; LCmd.Description.Text := 'Syntax: AVBL [ dirpath] (returns the number of '+ 'bytes available for uploading in the directory or current working directory)'; LCmd := CommandHandlers.Add; LCmd.Command := 'DSIZ'; {Do not localize} LCmd.OnCommand := CommandDSIZ; LCmd.ExceptionReply.NumericCode := 500; LCmd.Description.Text := 'DSIZ [ dirpath] (returns the number of bytes '+ 'in the directory or current working directory, including sub directories)'; LCmd := CommandHandlers.Add; LCmd.Command := 'RMDA'; LCmd.OnCommand := CommandRMDA; LCmd.ExceptionReply.NumericCode := 550; LCmd.Description.Text := 'RMDA pathname (deletes (removes) the '+ 'specified directory and it s contents)'; //informal but we might want to support this anyway //CLNT LCmd := CommandHandlers.Add; LCmd.Command := 'CLNT'; {do not localize} LCmd.OnCommand := CommandCLNT; LCmd.ExceptionReply.NumericCode := 550; LCmd.NormalReply.SetReply(200, RSFTPClntNoted); {Do not Localize} LCmd.Description.Text := 'Syntax: CLNT'; {do not localize} //Informal - an old proposed solution to IPv6 support in FTP. //Mentioned at: http://cr.yp.to/ftp/retr.html //and supported by PureFTPD. LCmd := CommandHandlers.Add; LCmd.Command := 'SPSV'; {do not localize} LCmd.OnCommand := CommandSPSV; LCmd.Description.Text := 'Syntax: SPSV (set server in passive mode)'; {do not localize} LCmd := CommandHandlers.Add; LCmd.Command := 'HOST'; {Do not localize} LCmd.OnCommand := CommandHOST; LCmd.ExceptionReply.NumericCode := 504; LCmd.Description.Text := 'Syntax: HOST domain (select a domain prior to logging in)'; {Do not localize} //Note that these commands are mentioned in old RFC's //and we will not support them at all. The commands //were there because FTP was a predisessor of SMTP //These are from RFC 765 //MLFL [ ] LCmd := CommandHandlers.Add; LCmd.Command := 'MLFL'; {Do not Localize} LCmd.NormalReply.SetReply(502, IndyFormat(RSFTPCmdNotImplemented, ['MLFL'])); {Do not Localize} LCmd.HelpSuperScript := '*'; LCmd.Description.Text := 'MLFL (mail file); unimplemented.'; {do not localize} //MAIL [ ] LCmd := CommandHandlers.Add; LCmd.Command := 'MAIL'; {Do not Localize} LCmd.NormalReply.SetReply(502, IndyFormat(RSFTPCmdNotImplemented, ['MAIL'])); {Do not Localize} LCmd.HelpSuperScript := '*'; LCmd.Description.Text := 'MAIL (mail to user); unimplemented.'; {do not localize} // MSND [ ] LCmd := CommandHandlers.Add; LCmd.Command := 'MSND'; {Do not Localize} LCmd.NormalReply.SetReply(502, IndyFormat(RSFTPCmdNotImplemented, ['MSND'])); {Do not Localize} LCmd.HelpSuperScript := '*'; LCmd.Description.Text := 'MSND (mail send to terminal); unimplemented.'; {do not localize} // MSOM [ ] LCmd := CommandHandlers.Add; LCmd.Command := 'MSOM'; {Do not Localize} LCmd.NormalReply.SetReply(502, IndyFormat(RSFTPCmdNotImplemented, ['MSOM'])); {Do not Localize} LCmd.HelpSuperScript := '*'; LCmd.Description.Text := 'MSOM (mail send to terminal or mailbox); unimplemented.'; {do not localize} // MSAM [ ] LCmd := CommandHandlers.Add; LCmd.Command := 'MSAM'; {Do not Localize} LCmd.NormalReply.SetReply(502, IndyFormat(RSFTPCmdNotImplemented, ['MSAM'])); {Do not Localize} LCmd.HelpSuperScript := '*'; LCmd.Description.Text := 'MSAM (mail send to terminal and mailbox); unimplemented.'; {do not localize} // MRSQ [ ] LCmd := CommandHandlers.Add; LCmd.Command := 'MRSQ'; {Do not Localize} LCmd.NormalReply.SetReply(502, IndyFormat(RSFTPCmdNotImplemented, ['MRSQ'])); {Do not Localize} LCmd.HelpSuperScript := '*'; LCmd.Description.Text := 'MRSQ (mail recipient scheme question); unimplemented.'; {do not localize} // MRCP LCmd := CommandHandlers.Add; LCmd.Command := 'MRCP'; {Do not Localize} LCmd.NormalReply.SetReply(502, IndyFormat(RSFTPCmdNotImplemented, ['MRCP'])); {Do not Localize} LCmd.HelpSuperScript := '*'; LCmd.Description.Text := 'MRCP (mail recipient); unimplemented.'; {do not localize} // LCmd := CommandHandlers.Add; LCmd.Command := 'HELP'; {Do not Localize} LCmd.OnCommand := COmmandHELP; LCmd.NormalReply.NumericCode := 214; LCmd.Description.Text := 'Syntax: HELP [ ]'; {do not localize} //We use a separate command handler collection for some things which are //valid durring the data connection. //ABOR LCmd := FDataChannelCommands.Add; LCmd.Command := 'ABOR'; {Do not Localize} LCmd.OnCommand := CommandABOR; LCmd.ExceptionReply.NumericCode := 550; //STAT [ ] LCmd := FDataChannelCommands.Add; LCmd.Command := 'STAT'; {Do not Localize} LCmd.OnCommand := CommandSTAT; LCmd.ExceptionReply.NumericCode := 450; //This is for SITE commands to make it easy for the user to add their own site commands //as they wish //These are Unix site commands LCmd := FSITECommands.Add; LCmd.Command := 'HELP'; {Do not localize} LCmd.ExceptionReply.NumericCode := 501; LCmd.OnCommand := CommandSiteHELP; LCmd.Description.Text := 'Syntax: SITE HELP [ ]'; {do not localize} //SITE ATTRIBAttribsFileName LCmd := FSITECommands.Add; LCmd.Command := 'ATTRIB'; {Do not Localize} LCmd.OnCommand := CommandSiteATTRIB; LCmd.ExceptionReply.NumericCode := 501; LCmd.Description.Text := 'Syntax: SITE ATTRIBAttribsFilename'; {do not localize} //SITE UMASK[mask] LCmd := FSITECommands.Add; LCmd.Command := 'UMASK'; {Do not Localize} LCmd.OnCommand := CommandSiteUMASK; LCmd.ExceptionReply.NumericCode := 501; LCmd.Description.Text := 'Syntax: SITE UMASK'; {do not localize} //SITE CHMODPermission numbersFilename LCmd := FSITECommands.Add; LCmd.Command := 'CHMOD'; {Do not Localize} LCmd.OnCommand := CommandSiteCHMOD; LCmd.ExceptionReply.NumericCode := 501; LCmd.Description.Text := 'Syntax: SITE CHMODPermission numbersFilename'; {do not localize} //additional Unix server commands that aren't supported but should be supported, IMAO //SITE CHOWNOwner[:Group]Filename LCmd := FSITECommands.Add; LCmd.Command := 'CHOWN'; {Do not Localize} LCmd.OnCommand := CommandSiteCHOWN; LCmd.ExceptionReply.NumericCode := 501; LCmd.Description.Text := 'Syntax: SITE CHOWNOwner[:Group]Filename'; {do not localize} //SITE CHGRPGroupFilename LCmd := FSITECommands.Add; LCmd.Command := 'CHGRP'; {Do not Localize} LCmd.OnCommand := CommandSiteCHGRP; LCmd.ExceptionReply.NumericCode := 501; LCmd.Description.Text := 'Syntax: SITE CHGRPGroupFilename'; {do not localize} //Microsoft IIS SITE commands //SITE DIRSTYLE LCmd := FSITECommands.Add; LCmd.Command := 'DIRSTYLE'; {Do not Localize} LCmd.ExceptionReply.NumericCode := 501; LCmd.OnCommand := CommandSiteDIRSTYLE; LCmd.Description.Text := 'Syntax: SITE DIRSTYLE (toggle directory format)'; {do not localize} //SITE ZONE LCmd := FSITECommands.Add; LCmd.Command := 'ZONE'; {Do not localize} LCmd.ExceptionReply.NumericCode := 530; LCmd.OnCommand := CommandSiteZONE; LCmd.Description.Text := 'Syntax: SITE ZONE (returns the server offset from GMT)'; {do not localize} //SITE UTIME LCmd := FSITECommands.Add; LCmd.Command := 'UTIME'; {Do not localize} LCmd.NormalReply.NumericCode := 200; LCmd.NormalReply.Text.Text := 'Date/time changed okay.'; LCmd.ExceptionReply.NumericCode := 530; LCmd.OnCommand := CommandSiteUTIME; LCmd.Description.Text := 'Syntax: SITE UTIME '+CR+LF+ {do not localize} ' Each timestamp must be in the format YYYYMMDDhhmmss'; {do not localize} //OPTS MLST LCmd := FOPTSCommands.Add; LCmd.Command := 'MLST'; {Do not localize} LCmd.ExceptionReply.NumericCode := 501; LCmd.OnCommand := CommandOptsMLST; //OPTS MODE Z LCmd := FOPTSCommands.Add; LCmd.Command := 'MODE Z'; {Do not localize} LCmd.ExceptionReply.NumericCode := 501; LCmd.OnCommand := CommandOptsMODEZ; // OPTS UTF-8 LCmd := FOPTSCommands.Add; LCmd.Command := 'UTF-8'; {Do not localize} LCmd.ExceptionReply.NumericCode := 501; LCmd.NormalReply.NumericCode := 200; LCmd.OnCommand := CommandOptsUTF8; // OPTS UTF8 LCmd := FOPTSCommands.Add; LCmd.Command := 'UTF8'; {Do not localize} LCmd.ExceptionReply.NumericCode := 501; LCmd.NormalReply.NumericCode := 200; LCmd.OnCommand := CommandOptsUTF8; //XAUT LCmd := CommandHandlers.Add; LCmd.Command := 'XAUT'; {Do not Localize} LCmd.OnCommand := CommandXAUT; LCmd.Description.Text := 'Syntax: XAUT 2 '; {do not localize} end; procedure TIdFTPServer.ContextCreated(AContext: TIdContext); var LContext : TIdFTPServerContext; begin LContext := (AContext as TIdFTPServerContext); LContext.Server := Self; //from Before run method LContext.FDataPort := 0; LContext.FPasswordAttempts := 0; LContext.FDataPortDenied := False; LContext.FUserSecurity.Assign(FTPSecurityOptions); if (DirFormat = ftpdfOSDependent) and (GOSType = otWindows) then begin LContext.MSDOSMode := True; end; // if mlsdUnixModes in FMLSDFacts then begin LContext.MLSOpts := LContext.MLSOpts + [UnixMODE]; end; if mlsdUnixOwner in FMLSDFacts then begin LContext.MLSOpts := LContext.MLSOpts + [UnixOwner]; end; if mlsdUnixGroup in FMLSDFacts then begin LContext.MLSOpts := LContext.MLSOpts + [UnixGroup]; end; if mlsdFileCreationTime in FMLSDFacts then begin LContext.MLSOpts := LContext.MLSOpts + [CreateTime]; end; if mlsdPerms in FMLSDFacts then begin LContext.MLSOpts := LContext.MLSOpts + [Perm]; end; if mlsdUniqueID in FMLSDFacts then begin LContext.MLSOpts := LContext.MLSOpts + [Unique]; end; if mlsdFileLastAccessTime in FMLSDFacts then begin LContext.MLSOpts := LContext.MLSOpts + [LastAccessTime]; end; if mlsdWin32Attributes in FMLSDFacts then begin LContext.MLSOpts := LContext.MLSOpts + [WinAttribs]; end; if mlsdWin32DriveType in FMLSDFacts then begin LContext.MLSOpts := LContext.MLSOpts + [WinDriveType]; end; if mlstWin32DriveLabel in FMLSDFacts then begin LContext.MLSOpts := LContext.MLSOpts + [WinDriveLabel]; end; //MS-DOS mode on for MS-DOS if FDirFormat = ftpdfDOS then begin LContext.FMSDOSMode := True; end; end; destructor TIdFTPServer.Destroy; begin FreeAndNil(FAnonymousAccounts); FreeAndNil(FFTPSecurityOptions); FreeAndNil(FOPTSCommands); FreeAndNil(FDataChannelCommands); FreeAndNil(FSITECommands); FreeAndNil(FReplyUnknownSITECommand); inherited Destroy; end; procedure TIdFTPServer.ListDirectory(ASender: TIdFTPServerContext; ADirectory: string; ADirContents: TStrings; ADetails: Boolean; const ACmd : String = 'LIST'; const ASwitches : String = ''); {do not localize} var LDirectoryList: TIdFTPListOutput; LPathSep: string; LIsMLST: Boolean; // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFilesystem; begin LIsMLST := PosInStrArray(ACmd, ['MLSD', 'MLST']) <> -1; {do not localize} if (FDirFormat = ftpdfCustom) and (not LIsMLST) then begin DoOnCustomListDirectory(ASender, ADirectory, ADirContents, ACmd, ASwitches); Exit; end; LFileSystem := FFTPFileSystem; if Assigned(FOnListDirectory) or Assigned(LFileSystem) then begin LDirectoryList := TIdFTPListOutput.Create; try case FDirFormat of ftpdfEPLF : LDirectoryList.DirFormat := doEPLF; ftpdfDOS : if ASender.FMSDOSMode then begin LDirectoryList.DirFormat := DoWin32; end else begin LDirectoryList.DirFormat := DoUnix; end; ftpdfOSDependent : if (GOSType = otWindows) and (ASender.FMSDOSMode) then begin LDirectoryList.DirFormat := DoWin32; end else begin LDirectoryList.DirFormat := DoUnix; end; else LDirectoryList.DirFormat := DoUnix; end; //someone might be using the STAT -l to get a dir without a data channel if IndyPos('l', ASwitches) > 0 then begin LDirectoryList.Switches := LDirectoryList.Switches + 'l'; end; //we do things this way because the 'a' and 'T' swithces only make sense //when listing Unix dirs. if SupportTaDirSwitches(ASender) then begin if IndyPos('a', ASwitches) > 0 then begin LDirectoryList.Switches := LDirectoryList.Switches + 'a'; end; if IndyPos('T', ASwitches) > 0 then begin LDirectoryList.Switches := LDirectoryList.Switches + 'T'; end; end; LDirectoryList.ExportTotalLine := True; LPathSep := '/'; {Do not Localize} if not TextEndsWith(ADirectory, LPathSep) then begin ADirectory := ADirectory + LPathSep; end; if Assigned(LFileSystem) then begin LFileSystem.ListDirectory(ASender, ADirectory, LDirectoryList, ACmd, ASwitches); end else begin FOnListDirectory(ASender, ADirectory, LDirectoryList, ACmd, ASwitches); // Event end; if LIsMLST then begin {Do not translate} LDirectoryList.MLISTOutputDir(ADirContents, ASender.MLSOpts); end else if ADetails then begin LDirectoryList.LISTOutputDir(ADirContents); end else begin LDirectoryList.NLISTOutputDir(ADirContents); end; finally FreeAndNil(LDirectoryList); end; end else begin raise EIdFTPServerNoOnListDirectory.Create(RSFTPNoOnDirEvent); {Do not Localize} end; end; procedure TIdFTPServer.SetUserAccounts(const AValue: TIdCustomUserManager); var // under ARC, convert a weak reference to a strong reference before working with it LUserAccounts: TIdCustomUserManager; begin LUserAccounts := FUserAccounts; if LUserAccounts <> AValue then begin // under ARC, all weak references to a freed object get nil'ed automatically {$IFNDEF USE_OBJECT_ARC} if Assigned(LUserAccounts) then begin LUserAccounts.RemoveFreeNotification(Self); end; {$ENDIF} FUserAccounts := AValue; if Assigned(AValue) then begin {$IFNDEF USE_OBJECT_ARC} AValue.FreeNotification(Self); {$ENDIF} FOnUserAccount := nil; //XAUT can not work with an account manager that sends //a challange because that command is a USER/PASS rolled into //one command. if AValue.SendsChallange then begin FSupportXAUTH := False; end; end; end; end; procedure TIdFTPServer.SetFTPFileSystem(const AValue: TIdFTPBaseFileSystem); begin {$IFDEF USE_OBJECT_ARC} // under ARC, all weak references to a freed object get nil'ed automatically FFTPFileSystem := AValue; {$ELSE} if FFTPFileSystem <> AValue then begin if Assigned(FFTPFileSystem) then begin FFTPFileSystem.RemoveFreeNotification(Self); end; FFTPFileSystem := AValue; if Assigned(AValue) then begin AValue.FreeNotification(Self); end; end; {$ENDIF} end; procedure TIdFTPServer.SetReplyUnknownSITECommand(AValue: TIdReply); begin FReplyUnknownSITECommand.Assign(AValue); end; procedure TIdFTPServer.SetSITECommands(AValue: TIdCommandHandlers); begin FSITECommands.Assign(AValue); end; // under ARC, all weak references to a freed object get nil'ed automatically {$IFNDEF USE_OBJECT_ARC} procedure TIdFTPServer.Notification(AComponent: TComponent; Operation: TOperation); begin if Operation = opRemove then begin if AComponent = FUserAccounts then begin FUserAccounts := nil; end else if AComponent = FFTPFileSystem then begin FFTPFileSystem := nil; end; end; inherited Notification(AComponent, Operation); end; {$ENDIF} procedure TIdFTPServer.SetAnonymousAccounts(const AValue: TStrings); begin if Assigned(AValue) then begin FAnonymousAccounts.Assign(AValue); end; end; procedure TIdFTPServer.SetSupportXAUTH(AValue : Boolean); var // under ARC, convert a weak reference to a strong reference before working with it LUserAccounts: TIdCustomUserManager; begin if FSupportXAUTH <> AValue then begin LUserAccounts := FUserAccounts; if Assigned(LUserAccounts) then begin if LUserAccounts.SendsChallange then begin Exit; end; end; FSupportXAUTH := AValue; end; end; procedure TIdFTPServer.ThreadException(AThread: TIdThread; AException: Exception); begin //we do not want to show an exception in a dialog-box end; //Command Replies/Handling procedure TIdFTPServer.CommandUSER(ASender: TIdCommand); var LSafe: Boolean; LChallenge: String; LContext: TIdFTPServerContext; // under ARC, convert a weak reference to a strong reference before working with it LUserAccounts: TIdCustomUserManager; begin LChallenge := ''; LContext := ASender.Context as TIdFTPServerContext; if (FUseTLS = utUseRequireTLS) and (LContext.AuthMechanism <> 'TLS') then begin {do not localize} DisconUser(ASender); Exit; end; LContext.Authenticated := False; if (FAnonymousAccounts.IndexOf(LowerCase(ASender.UnparsedParams)) >= 0) and AllowAnonymousLogin then begin LContext.UserType := utAnonymousUser; LContext.Username := ASender.UnparsedParams; ASender.Reply.SetReply(331, RSFTPAnonymousUserOkay); end else begin LContext.UserType := utNormalUser; if Length(ASender.UnparsedParams) > 0 then begin LContext.Username := ASender.UnparsedParams; LUserAccounts := FUserAccounts; if Assigned(LUserAccounts) then begin LChallenge := LUserAccounts.ChallengeUser(LSafe, LContext.Username); {$IFDEF USE_OBJECT_ARC}LUserAccounts := nil;{$ENDIF} if not LSafe then begin //we do this to prevent a potential race attack DisconUser(ASender); Exit; end; end; if LChallenge = '' then begin ASender.Reply.SetReply(331, RSFTPUserOkay); end else begin ASender.Reply.SetReply(331, LChallenge); end; end else begin ASender.Reply.SetReply(332, RSFTPNeedAccountForLogin); end; end; end; procedure TIdFTPServer.AuthenticateUser(ASender: TIdCommand); var LValidated: Boolean; LContext: TIdFTPServerContext; // under ARC, convert a weak reference to a strong reference before working with it LUserAccounts: TIdCustomUserManager; begin LContext:= ASender.Context as TIdFTPServerContext; try LContext.FAuthenticated := False; case LContext.FUserType of utAnonymousUser: begin LValidated := Length(LContext.Password ) > 0; if FAnonymousPassStrictCheck and LValidated then begin LValidated := False; if FindFirstOf('@.', LContext.Password) > 0 then begin {Do not Localize} LValidated := True; end; end; if LValidated then begin LContext.FAuthenticated := True; ASender.Reply.SetReply(230, RSFTPAnonymousUserLogged); if Assigned(OnLoginSuccessBanner) then begin OnLoginSuccessBanner(LContext, ASender.Reply); ASender.Reply.SetReply(230, ASender.Reply.Text.Text); end; LContext.FPasswordAttempts := 0; end else begin LContext.FUserType := utNone; LContext.FAuthenticated := False; LContext.FPassword := ''; {Do not Localize} Inc(LContext.FPasswordAttempts); if LContext.UserSecurity.InvalidPassDelay > 0 then begin //Delay our error response to slow down a dictionary attack IndySleep(FFTPSecurityOptions.InvalidPassDelay); end; if (LContext.UserSecurity.PasswordAttempts > 0) and (LContext.FPasswordAttempts >= LContext.UserSecurity.PasswordAttempts) then begin DisconUser(ASender); Exit; end; ASender.Reply.SetReply(530, RSFTPUserNotLoggedIn); end; end; utNormalUser: begin LUserAccounts := FUserAccounts; if Assigned(LUserAccounts) then begin LContext.FAuthenticated := LUserAccounts.AuthenticateUser(LContext.FUsername, ASender.UnparsedParams); {$IFDEF USE_OBJECT_ARC}LUserAccounts := nil;{$ENDIF} if LContext.FAuthenticated then begin LContext.FPasswordAttempts := 0; ASender.Reply.SetReply(230, RSFTPUserLogged); end else begin LContext.FPassword := ''; {Do not Localize} Inc(LContext.FPasswordAttempts); if LContext.UserSecurity.InvalidPassDelay > 0 then begin //Delay our error response to slow down a dictionary attack IndySleep(LContext.UserSecurity.InvalidPassDelay); end; if (LContext.UserSecurity.PasswordAttempts > 0) and (LContext.FPasswordAttempts >= LContext.UserSecurity.PasswordAttempts) then begin //Max login attempts exceeded, close the connection DisconUser(ASender); Exit; end; ASender.Reply.SetReply(530, RSFTPUserNotLoggedIn); end; end else if Assigned(FOnUserLogin) then begin LValidated := False; FOnUserLogin(LContext, LContext.FUsername, LContext.Password, LValidated); LContext.FAuthenticated := LValidated; if LValidated then begin if (LContext.AccountNeeded = True) and Assigned(FOnUserAccount) then begin LContext.FAuthenticated := False; ASender.Reply.SetReply(332,'Need account for login.'); Exit; end else begin LContext.FAuthenticated := LValidated; ASender.Reply.SetReply(230, RSFTPUserLogged); if Assigned(OnLoginSuccessBanner) then begin OnLoginSuccessBanner(LContext, ASender.Reply); ASender.Reply.SetReply(230, ASender.Reply.Text.Text); end; LContext.FPasswordAttempts := 0; end; end else begin LContext.FPassword := ''; {Do not Localize} Inc(LContext.FPasswordAttempts); if (LContext.UserSecurity.PasswordAttempts > 0) and (LContext.FPasswordAttempts >= LContext.UserSecurity.PasswordAttempts) then begin //Max login attempts exceeded, close the connection DisconUser(ASender); Exit; end; ASender.Reply.SetReply(530, RSFTPUserNotLoggedIn); end; end else begin //APR 020423 ASender.Reply.SetReply(530, RSFTPUserNotLoggedIn); // user manager not found end; end; else ASender.Reply.SetReply(503, RSFTPNeedLoginWithUser); end;//case except on E : Exception do begin ASender.Reply.SetReply(503, E.Message); end; end; //After login if LContext.FAuthenticated and Assigned(FOnAfterUserLogin) then begin FOnAfterUserLogin(LContext); end; end; procedure TIdFTPServer.CommandPASS(ASender: TIdCommand); var LContext: TIdFTPServerContext; begin LContext:= ASender.Context as TIdFTPServerContext; if (FUseTLS = utUseRequireTLS) and (LContext.AuthMechanism <> 'TLS') then begin {do not localize} DisconUser(ASender); Exit; end; LContext.FAuthenticated := False; LContext.FPassword := ASender.UnparsedParams; AuthenticateUser(ASender); end; procedure TIdFTPServer.CommandXAUT(ASender : TIdCommand); var LContext : TIdFTPServerContext; s : String; LPos : Integer; begin LContext := ASender.Context as TIdFTPServerContext; if (FUseTLS = utUseRequireTLS) and (LContext.AuthMechanism <> 'TLS') then begin {do not localize} DisconUser(ASender); Exit; end; LContext := ASender.Context as TIdFTPServerContext; s := ASender.UnparsedParams; s := IdFTPCommon.ExtractAutInfoFromXAUT(s, LContext.FXAUTKey ); LPos := RPos(':',s); if LPos > 1 then begin LContext.Username := Copy(s,1,LPos - 1); s := Copy(s,LPos + 1,$FF); //for some reason, WS-FTP Pro likes to add the string "^vta4r2" to //the authentication information if you aren't using anonymous login. //I'm not sure what the significance of "^vta4r2" really is. // 1234567 if TextEndsWith(s,'^vta4r2') then begin LContext.Password := Copy(s,1,Length(s)-7); end; end else begin LContext.Username := s; LContext.Password := ''; end; LContext.Authenticated := False; if (FAnonymousAccounts.IndexOf(LowerCase(ASender.UnparsedParams)) >= 0) and AllowAnonymousLogin then begin LContext.UserType := utAnonymousUser; end else begin LContext.UserType := utNormalUser; end; AuthenticateUser(ASender); end; procedure TIdFTPServer.CommandACCT(ASender: TIdCommand); var LContext : TIdFTPServerContext; LValidated : Boolean; begin LValidated := False; if Assigned(FOnUserAccount) then begin LContext := ASender.Context as TIdFTPServerContext; LContext.Account := ASender.UnparsedParams; FOnUserAccount(LContext,LContext.Username, LContext.Password, LContext.Account, LValidated); LContext.Authenticated := LValidated; if LValidated then begin LContext.AccountNeeded := False; ASender.Reply.SetReply(230, RSFTPUserLogged); if Assigned(OnLoginSuccessBanner) then begin OnLoginSuccessBanner(LContext, ASender.Reply); ASender.Reply.SetReply(230, ASender.Reply.Text.Text); LContext.PasswordAttempts := 0; end; end else begin LContext.FPassword := ''; {Do not Localize} Inc(LContext.FPasswordAttempts); if (LContext.UserSecurity.PasswordAttempts > 0) and (LContext.FPasswordAttempts >= LContext.UserSecurity.PasswordAttempts) then begin //Max login attempts exceeded, close the connection DisconUser(ASender); Exit; end; ASender.Reply.SetReply(530, RSFTPUserNotLoggedIn); end; end else begin ASender.Reply.SetReply(502, IndyFormat(RSFTPCmdNotImplemented, ['ACCT'])); {do not localize} end; end; procedure TIdFTPServer.CommandCWD(ASender: TIdCommand); var s: TIdFTPFileName; LContext : TIdFTPServerContext; // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFilesystem; begin LContext := ASender.Context as TIdFTPServerContext; s := ASender.UnparsedParams; if LContext.IsAuthenticated(ASender) then begin s := IgnoreLastPathDelim(s); LFileSystem := FFTPFileSystem; if Assigned(OnChangeDirectory) or Assigned(LFileSystem) then begin if s = '..' then begin {do not localize} s := CDUPDir(LContext); end else if s = '.' then begin {do not localize} s := LContext.CurrentDir; end else begin s := DoProcessPath(LContext, s); end; s := RemoveDuplicatePathSyms(s); DoOnChangeDirectory(LContext, s); LContext.CurrentDir := s; CmdCommandSuccessful(ASender); end else begin CmdNotImplemented(ASender); end; end; end; procedure TIdFTPServer.CommandCDUP(ASender: TIdCommand); var s: TIdFTPFileName; LContext : TIdFTPServerContext; // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin s := CDUPDir(LContext); s := DoProcessPath(LContext, s); LFileSystem := FFTPFileSystem; if Assigned(FOnChangeDirectory) or Assigned(LFileSystem) then begin DoOnChangeDirectory(LContext, s); LContext.FCurrentDir := s; ASender.Reply.SetReply(250, IndyFormat(RSFTPCurrentDirectoryIs, [LContext.FCurrentDir])); end else begin CmdNotImplemented(ASender); end; end; end; procedure TIdFTPServer.CommandREIN(ASender: TIdCommand); var LIO : TIdSSLIOHandlerSocketBase; LContext : TIdFTPServerContext; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin LContext.ReInitialize; LContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_8Bit; ASender.Reply.SetReply(220, RSFTPServiceOpen); if (FUseTLS in ExplicitTLSVals) then begin LIO := ASender.Context.Connection.IOHandler as TIdSSLIOHandlerSocketBase; if not LIO.PassThrough then begin LIO.Passthrough := True; end; LContext.FCCC := False; end; end; end; procedure TIdFTPServer.CommandPORT(ASender: TIdCommand); var LLo, LHi : Integer; LPort: TIdPort; LParm, LIP : string; LContext : TIdFTPServerContext; LDataChannel: TIdTCPClient; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin if LContext.FEPSVAll then begin ASender.Reply.SetReply(501, IndyFormat(RSFTPNotAllowedAfterEPSVAll, [ASender.CommandHandler.Command])); Exit; end; if LContext.UserSecurity.BlockAllPORTTransfers then begin LContext.FDataPort := 0; LContext.FDataPortDenied := True; ASender.Reply.SetReply(502, RSFTPPORTDisabled); Exit; end; LContext.FPASV := False; LParm := ASender.UnparsedParams; LIP := ''; {Do not Localize} { h1 } LIP := LIP + Fetch(LParm, ',') + '.'; {Do not Localize} { h2 } LIP := LIP + Fetch(LParm, ',') + '.'; {Do not Localize} { h3 } LIP := LIP + Fetch(LParm, ',') + '.'; {Do not Localize} { h4 } LIP := LIP + Fetch(LParm, ','); {Do not Localize} { p1 } LLo := IndyStrToInt(Fetch(LParm, ',')); {Do not Localize} { p2 } LHi := IndyStrToInt(LParm); LPort := TIdPort((LLo * 256) + LHi); if LContext.UserSecurity.NoReservedRangePORT and ((LPort > 0) and (LPort <= 1024)) then begin LContext.FDataPort := 0; LContext.FDataPortDenied := True; ASender.Reply.SetReply(504, RSFTPPORTRange); Exit; end; {//BGO} if LContext.UserSecurity.FRequirePORTFromSameIP and (LIP <> LContext.Binding.PeerIP) then begin LContext.FDataPort := 0; LContext.FDataPortDenied := True; ASender.Reply.SetReply(504, RSFTPSameIPAddress); Exit; end; {//BGO} LContext.CreateDataChannel(False); LDataChannel := TIdTCPClient(LContext.FDataChannel.FDataChannel); LDataChannel.Host := LIP; LDataChannel.Port := LPort; LDataChannel.IPVersion := Id_IPv4; LContext.FDataPort := LPort; LContext.FDataPortDenied := False; CmdCommandSuccessful(ASender, 200); end; end; procedure TIdFTPServer.CommandPASV(ASender: TIdCommand); var LParam: string; LBPort: Word; LIPVersion : TIdIPVersion; begin //InternalPASV does all of the checking if InternalPASV(ASender, LParam, LBPort, LIPVersion) then begin DoOnPASVReply(TIdFTPServerContext(ASender.Context), LParam, LBPort, LIPVersion); LParam := ReplaceAll(LParam, '.', ','); {Do not Localize} LParam := LParam + ',' + IntToStr(LBPort div 256) + ',' + IntToStr(LBPort mod 256); {Do not Localize} ASender.Reply.SetReply(227, IndyFormat(RSFTPPassiveMode, [LParam])); end; end; procedure TIdFTPServer.CommandTYPE(ASender: TIdCommand); var LContext : TIdFTPServerContext; s: string; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin s := ASender.UnparsedParams; s := UpperCase(Fetch(s)); if Length(s) = 1 then begin //Default data type is ASCII case s[1] of 'A': LContext.FDataType := ftASCII; {Do not Localize} 'I': LContext.FDataType := ftBinary; {Do not Localize} else Exit; end; ASender.Reply.SetReply(200, IndyFormat(RSFTPTYPEChanged, [s])); end; end; end; procedure TIdFTPServer.CommandSTRU(ASender: TIdCommand); var LContext : TIdFTPServerContext; s: String; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin s := ASender.UnparsedParams; s := UpperCase(Fetch(s)); if Length(s) = 1 then begin //Default structure is file case s[1] of 'F': LContext.FDataStruct := dsFile; {Do not Localize} 'R': LContext.FDataStruct := dsRecord; {Do not Localize} 'P': LContext.FDataStruct := dsPage; {Do not Localize} else Exit; end; ASender.Reply.SetReply(200, IndyFormat(RSFTPSTRUChanged, [s])); end; end; end; procedure TIdFTPServer.CommandMODE(ASender: TIdCommand); var LContext : TIdFTPServerContext; s: String; begin LContext := TIdFTPServerContext(ASender.Context); if LContext.IsAuthenticated(ASender) then begin s := ASender.UnparsedParams; s := UpperCase(Fetch(s)); if Length(s) = 1 then begin //Default data mode is stream case s[1] of 'S' : //stream mode begin LContext.DataMode := dmStream; ASender.Reply.SetReply(200, IndyFormat(RSFTPMODEChanged, [s])); Exit; end; 'Z' : //deflate begin if Assigned(FCompressor) then begin LContext.DataMode := dmDeflate; ASender.Reply.SetReply(200, IndyFormat(RSFTPMODEChanged, [s])); Exit; end; end; end; ASender.Reply.SetReply(504, RSFTPMODENotSupported); end; end; end; procedure TIdFTPServer.CommandRETR(ASender: TIdCommand); var s: string; LStream: TStream; LContext : TIdFTPServerContext; // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin if (not Assigned(LContext.FDataChannel)) or LContext.FDataPortDenied then begin ASender.Reply.SetReply(425, RSFTPCantOpenData); Exit; end; //TODO: Fix reference to / s := DoProcessPath(LContext, ASender.UnparsedParams); LFileSystem := FFTPFileSystem; if Assigned(FOnRetrieveFile) or Assigned(LFileSystem) then begin LStream := nil; try //some file stream creations can fail with an exception so //we need to handle this gracefully. if Assigned(LFileSystem) then begin LFileSystem.RetrieveFile(LContext, s, LStream) end else begin FOnRetrieveFile(LContext, s, LStream); end; except on E : Exception do begin LContext.KillDataChannel; ASender.Reply.SetReply(550, E.Message); Exit; end; end; if Assigned(LStream) then begin try LStream.Position := LContext.FRESTPos; LContext.FRESTPos := 0; //it should be safe to assume that the FDataChannel object exists because //we checked it earlier LContext.FDataChannel.FFtpOperation := ftpRetr; LContext.FDataChannel.FData := LStream; LContext.FDataChannel.OKReply.SetReply(226, RSFTPDataConnClosed); LContext.FDataChannel.ErrorReply.SetReply(426, RSFTPDataConnClosedAbnormally); ASender.Reply.SetReply(150, RSFTPDataConnToOpen); ASender.SendReply; DoDataChannelOperation(ASender, LContext.SSCNOn); finally LStream.Free; end; end else begin //make sure the data connection is closed LContext.KillDataChannel; CmdFileActionAborted(ASender); end; end else begin //make sure the data connection is closed LContext.KillDataChannel; CmdNotImplemented(ASender); end; end; end; procedure TIdFTPServer.CommandSSAP(ASender: TIdCommand); var LStream: TStream; LTmp1: string; LAppend: Boolean; LContext : TIdFTPServerContext; // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin if (not Assigned(LContext.FDataChannel)) or LContext.FDataPortDenied then begin ASender.Reply.SetReply(425, RSFTPCantOpenData); Exit; end; if TextIsSame(ASender.CommandHandler.Command, 'STOU') then begin {Do not Localize} LTmp1 := GetUniqueFileName('', 'Temp', ''); {Do not localize} //This is a standardized format ASender.Reply.SetReply(150, IndyFormat('FILE: %s', [LTmp1])); {Do not translate} end else begin LTmp1 := ASender.UnparsedParams; ASender.Reply.SetReply(150, RSFTPDataConnToOpen); end; LTmp1 := DoProcessPath(LContext, LTmp1); LAppend := TextIsSame(ASender.CommandHandler.Command, 'APPE'); {Do not Localize} LFileSystem := FFTPFileSystem; if Assigned(FOnStoreFile) or Assigned(LFileSystem) then begin LStream := nil; try if Assigned(LFileSystem) then begin LFileSystem.StoreFile(LContext, LTmp1, LAppend, LStream); {$IFDEF USE_OBJECT_ARC}LFileSystem := nil;{$ENDIF} end else begin FOnStoreFile(LContext, LTmp1, LAppend, LStream); end; except on E : Exception do begin ASender.Reply.SetReply(550, E.Message); LContext.KillDataChannel; Exit; end; end; if Assigned(LStream) then begin try //Issued previously by ALLO cmd if LContext.ALLOSize > 0 then begin LStream.Size := LContext.FALLOSize; end; if LAppend then begin LStream.Position := LStream.Size; end else begin LStream.Position := LContext.FRESTPos; LContext.FRESTPos := 0; end; { Data transfer } //it should be safe to assume that the FDataChannel object exists because //we checked it earlier LContext.FDataChannel.FFtpOperation := ftpStor; LContext.FDataChannel.Data := LStream; LContext.FDataChannel.OKReply.SetReply(226, RSFTPDataConnClosed); LContext.FDataChannel.ErrorReply.SetReply(426, RSFTPDataConnClosedAbnormally); ASender.SendReply; DoDataChannelOperation(ASender, LContext.SSCNOn); finally LStream.Free; end; end else begin //make sure the data connection is closed LContext.KillDataChannel; CmdFileActionAborted(ASender); end; end else begin //make sure the data connection is closed LContext.KillDataChannel; CmdNotImplemented(ASender); end; end; end; procedure TIdFTPServer.CommandALLO(ASender: TIdCommand); var LContext: TIdFTPServerContext; LALLOSize, s: string; begin LContext := TIdFTPServerContext(ASender.Context); if LContext.IsAuthenticated(ASender) then begin LALLOSize := ''; if Length(ASender.UnparsedParams) > 0 then begin if TextStartsWith(ASender.UnparsedParams, 'R ') then begin {Do not localize} LALLOSize := TrimLeft(Copy(s, 3, MaxInt)); end else begin LALLOSize := TrimLeft(ASender.UnparsedParams); end; LALLOSize := Fetch(LALLOSize); end; if LALLOSize <> '' then begin LContext.FALLOSize := IndyStrToInt(LALLOSize, 0); CmdCommandSuccessful(ASender, 200); end else begin ASender.Reply.SetReply(504, RSFTPInvalidForParam); end; end; end; procedure TIdFTPServer.CommandREST(ASender: TIdCommand); var LContext: TIdFTPServerContext; begin LContext := TIdFTPServerContext(ASender.Context); if LContext.IsAuthenticated(ASender) then begin LContext.FRESTPos := IndyStrToInt(ASender.UnparsedParams, 0); ASender.Reply.SetReply(350, RSFTPFileActionPending); end; end; procedure TIdFTPServer.CommandRNFR(ASender: TIdCommand); var LContext: TIdFTPServerContext; s: string; begin LContext := TIdFTPServerContext(ASender.Context); if LContext.IsAuthenticated(ASender) then begin s := ASender.UnparsedParams; if Assigned(FOnRenameFile) or Assigned(FTPFileSystem) then begin ASender.Reply.SetReply(350, RSFTPFileActionPending); LContext.FRNFR := DoProcessPath(TIdFTPServerContext(LContext), s); end else begin CmdNotImplemented(ASender); end; end; end; procedure TIdFTPServer.CommandRNTO(ASender: TIdCommand); var s: string; LContext : TIdFTPServerContext; // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin s := ASender.UnparsedParams; LFileSystem := FFTPFileSystem; if Assigned(LFileSystem) or Assigned(FOnRenameFile) then begin DoOnRenameFile(LContext, LContext.FRNFR, DoProcessPath(LContext, s)); ASender.Reply.NumericCode := 250; end else begin CmdNotImplemented(ASender); end; end; end; procedure TIdFTPServer.CommandABOR(ASender: TIdCommand); var LContext: TIdFTPServerContext; begin LContext := TIdFTPServerContext(ASender.Context); if LContext.IsAuthenticated(ASender) then begin if Assigned(LContext.FDataChannel) then begin if not LContext.FDataChannel.Stopped then begin LContext.FDataChannel.OkReply.SetReply(426, RSFTPDataConnClosedAbnormally); LContext.FDataChannel.ErrorReply.SetReply(426, RSFTPDataConnClosedAbnormally); LContext.KillDataChannel; ASender.Reply.SetReply(226, RSFTPDataConnClosed); Exit; end; end; CmdCommandSuccessful(ASender, 226); end; end; procedure TIdFTPServer.CommandDELE(ASender: TIdCommand); var LContext : TIdFTPServerContext; // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; (* DELE 250 Requested file action okay, completed. 450 Requested file action not taken. - File is busy 550 Requested action not taken. - File unavailable, no access permitted, etc 500 Syntax error, command unrecognized. 501 Syntax error in parameters or arguments. 502 Command not implemented. 421 Service not available, closing control connection. - During server shutdown, etc 530 Not logged in. *) //TODO: Need to set replies when not authenticated and set NormalReply to 250 // do for all procs, list valid replies in comments. Or maybe default is 550 begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin LFileSystem := FTPFileSystem; if Assigned(FOnDeleteFile) or Assigned(LFileSystem) then begin DoOnDeleteFile(LContext, DoProcessPath(LContext, ASender.UnparsedParams)); ASender.Reply.SetReply(250, RSFTPFileActionCompleted); end else begin CmdNotImplemented(ASender); end; end else begin ASender.Reply.SetReply(550, RSFTPFileActionNotTaken); end; end; procedure TIdFTPServer.CommandRMD(ASender: TIdCommand); var s: TIdFTPFileName; LContext : TIdFTPServerContext; // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin S := IgnoreLastPathDelim(S); s := DoProcessPath(LContext, ASender.UnparsedParams); LFileSystem := FFTPFileSystem; if Assigned(LFileSystem) or Assigned(FOnRemoveDirectory) then begin DoOnRemoveDirectory(LContext, s); ASender.Reply.SetReply(250, RSFTPFileActionCompleted); end else begin CmdNotImplemented(ASender); end; end; end; procedure TIdFTPServer.CommandMKD(ASender: TIdCommand); var S: TIdFTPFileName; LContext : TIdFTPServerContext; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin S := IgnoreLastPathDelim(S); S := DoProcessPath(LContext, ASender.UnparsedParams); DoOnMakeDirectory(LContext, s); ASender.Reply.SetReply(257, RSFTPFileActionCompleted); end; end; procedure TIdFTPServer.CommandPWD(ASender: TIdCommand); var LContext: TIdFTPServerContext; begin LContext := TIdFTPServerContext(ASender.Context); if LContext.IsAuthenticated(ASender) then begin ASender.Reply.SetReply(257, IndyFormat(RSFTPCurrentDirectoryIs, [LContext.FCurrentDir])); end; end; procedure TIdFTPServer.CommandLIST(ASender: TIdCommand); var LStream: TStringList; LSendData : Boolean; LPath, LSwitches : String; LContext : TIdFTPServerContext; function DeletRSwitch(const AString : String): String; var i : Integer; begin Result := ''; for i := 1 to Length(AString) do begin if AString[i] <> 'R' then begin Result := Result + AString[i]; end; end; end; begin LSendData := False; LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin if (not Assigned(LContext.FDataChannel)) or LContext.FDataPortDenied then begin ASender.Reply.SetReply(425, RSFTPCantOpenData); Exit; end; if (not Assigned(FOnListDirectory)) and ((FDirFormat = ftpdfCustom) and (not Assigned(FOnCustomListDirectory))) then begin LContext.KillDataChannel; CmdNotImplemented(ASender); Exit; end; LStream := TStringList.Create; try LSwitches := ''; LPath := ASender.UnparsedParams; if TextStartsWith(LPath, '-') then begin {Do not Localize} LSwitches := Fetch(LPath); end; //we can't support recursive lists with EPLF if DirFormat = ftpdfEPLF then begin LSwitches := DeletRSwitch(LSwitches); end; ListDirectory(LContext, DoProcessPath(LContext, LPath), LStream, TextIsSame(ASender.CommandHandler.Command, 'LIST'), ASender.CommandHandler.Command, LSwitches); LSendData := True; finally try if LSendData then begin //it should be safe to assume that the FDataChannel object exists because //we checked it earlier LContext.FDataChannel.Data := LStream; LContext.FDataChannel.FFtpOperation := ftpRetr; LContext.FDataChannel.OKReply.SetReply(226, RSFTPDataConnClosed); LContext.FDataChannel.ErrorReply.SetReply(426, RSFTPDataConnClosedAbnormally); if FDirFormat = ftpdfEPLF then begin ASender.Reply.SetReply(125, RSFTPDataConnToOpen); LContext.FDataChannel.OKReply.SetReply(226, RSFTPDataConnClosed); end else if TextIsSame(ASender.CommandHandler.Command, 'LIST') or (LSwitches <> '') then begin {do not localize} ASender.Reply.SetReply(125, RSFTPDataConnList); end else begin ASender.Reply.SetReply(125, RSFTPDataConnNList); end; ASender.SendReply; DoDataChannelOperation(ASender); end else begin LContext.KillDataChannel; ASender.Reply.SetReply(426, RSFTPDataConnClosedAbnormally); end; finally LStream.Free; end; end; end; end; procedure TIdFTPServer.DoDataChannelOperation(ASender: TIdCommand; const AConnectMode : Boolean = False); const DEF_BLOCKSIZE = 10*10240; {CH DEF_CHECKCMD_WAIT = 1; } var LContext : TIdFTPServerContext; LCmdQueue : TStringList; LLine : String; LStrm : TStream; procedure CheckControlConnection(AContext : TIdFTPServerContext; ACmdQueue : TStrings); var LLocalLine : String; begin LLocalLine := ReadCommandLine(AContext); if LLocalLine <> '' then begin if not FDataChannelCommands.HandleCommand(AContext, LLocalLine) then begin ACmdQueue.Add(LLocalLine); end; end; end; procedure ReadFromStream(AContext : TIdFTPServerContext; ACmdQueue : TStrings; ADestStream : TStream); var LM : TStream; begin if AContext.DataMode = dmDeflate then begin LM := TMemoryStream.Create; end else begin LM := ADestStream; end; try repeat AContext.FDataChannel.FDataChannel.IOHandler.CheckForDisconnect(False); AContext.FDataChannel.FDataChannel.IOHandler.ReadStream(LM, DEF_BLOCKSIZE, True); CheckControlConnection(AContext, ACmdQueue); until not AContext.FDataChannel.FDataChannel.IOHandler.Connected; if AContext.DataMode = dmDeflate then begin LM.Position := 0; FCompressor.DecompressFTPDeflate(LM, ADestStream, AContext.ZLibWindowBits); end; finally if AContext.DataMode = dmDeflate then begin FreeAndNil(LM); end; end; end; procedure WriteToStream(AContext : TIdFTPServerContext; ACmdQueue : TStrings; ASrcStream : TStream; const AIgnoreCompression : Boolean = False); var LBufSize : TIdStreamSize; LOutStream : TStream; begin if AContext.DataMode = dmDeflate then begin LOutStream := TMemoryStream.Create; end else begin LOutStream := ASrcStream; end; try if AContext.DataMode = dmDeflate then begin FCompressor.CompressFTPDeflate(ASrcStream, LOutStream, AContext.ZLibCompressionLevel, AContext.ZLibWindowBits, AContext.ZLibMemLevel, AContext.ZLibStratagy); LOutStream.Position := 0; end; repeat LBufSize := LOutStream.Size - LOutStream.Position; if LBufSize > DEF_BLOCKSIZE then begin LBufSize := DEF_BLOCKSIZE; end; if LBufSize > 0 then begin AContext.FDataChannel.FDataChannel.IOHandler.Write(LOutStream, LBufSize, False); if LOutStream.Position < LOutStream.Size then begin CheckControlConnection(AContext, ACmdQueue); end; end; until (LBufSize = 0) or (not AContext.FDataChannel.FDataChannel.IOHandler.Connected); finally if AContext.DataMode = dmDeflate then begin FreeAndNil(LOutStream); end; end; end; procedure WriteStrings(AContext : TIdFTPServerContext; ACmdQueue : TStrings; ASrcStrings : TStrings); var i : Integer; LM : TStream; LEncoding: IIdTextEncoding; begin //for loops will execute at least once triggering an out of range error. //write nothing if AStrings is empty. if ASrcStrings.Count < 1 then begin Exit; end; { IMPORTANT!!! If LIST data is sent as 8bit, you have a FTP list that is unparsable by some FTP clients. If UTF8 OPTS OFF, you should send the data as 7bit for the LIST and NLST commands. That way, unprintable charactors are returned as ?. While the file name is not valid, at least, there some thing that looks better than binary junk. } if PosInStrArray(ASender.CommandHandler.Command, ['LIST', 'NLST', 'MLSD'], False) > -1 then begin LEncoding := IndyTextEncoding(NLSTEncType[AContext.NLSTUtf8]); end else begin LEncoding := IndyTextEncoding_8Bit; end; if AContext.DataMode = dmDeflate then begin LM := TMemoryStream.Create; try for i := 0 to ASrcStrings.Count-1 do begin WriteStringToStream(LM, ASrcStrings[i] + EOL, LEncoding); end; LM.Position := 0; WriteToStream(AContext, ACmdQueue, LM, True); finally FreeAndNil(LM); end; Exit; end; for i := 0 to ASrcStrings.Count-1 do begin if AContext.FDataChannel.FDataChannel.IOHandler.Connected then begin AContext.FDataChannel.FDataChannel.IOHandler.WriteLn(ASrcStrings[i], LEncoding); if ((i mod 10) = 0) and (i <> (ASrcStrings.Count-1)) then begin if AContext.FDataChannel.FDataChannel.IOHandler.Connected then begin CheckControlConnection(AContext, ACmdQueue); end else begin Break; end; end; end else begin Break; end; end; end; begin if not Assigned(ASender) then begin Exit; end; if not Assigned(ASender.Context) then begin Exit; end; LContext := ASender.Context as TIdFTPServerContext; if not Assigned(LContext.FDataChannel) then begin Exit; end; try LCmdQueue := TStringList.Create; try LContext.FDataChannel.InitOperation(AConnectMode); try try try if LContext.FDataChannel.Data is TStream then begin LStrm := TStream(LContext.FDataChannel.Data); case LContext.FDataChannel.FFtpOperation of ftpRetr: WriteToStream(LContext, LCmdQueue, LStrm); ftpStor: ReadFromStream(LContext, LCmdQueue, LStrm); end; end else begin case LContext.FDataChannel.FFtpOperation of ftpRetr: if Assigned(LContext.FDataChannel.Data) then begin WriteStrings(LContext, LCmdQueue, LContext.FDataChannel.Data as TStrings); end; ftpStor: if Assigned(LContext.FDataChannel.Data) then begin LStrm := TMemoryStream.Create; try ReadFromStream(LContext, LCmdQueue, LStrm); //TODO; // SplitLines(TMemoryStream(LStrm).Memory, LMemStream.Size, LContext.FDataChannel.FData as TStrings); finally LStrm.Free; end; end;//ftpStor end;//case end; finally if Assigned(LContext.FDataChannel.FDataChannel) then begin LContext.FDataChannel.FDataChannel.Disconnect(False); end; end; LContext.FDataChannel.FReply.Assign(LContext.FDataChannel.FOKReply); //226 except on E: Exception do begin if not (E is EIdSilentException) then begin LContext.FDataChannel.FReply.Assign(LContext.FDataChannel.FErrorReply); //426 end; end; end; finally ASender.Reply.Assign(LContext.FDataChannel.FReply); ASender.SendReply; //now we have to handle the FIFO queue we had made while LCmdQueue.Count > 0 do begin LLine := LCmdQueue[0]; if not FCommandHandlers.HandleCommand(ASender.Context, LLine) then begin DoReplyUnknownCommand(ASender.Context, LLine); end; if Assigned(ASender.Context.Connection) then begin if not ASender.Context.Connection.Connected then begin Break; end; end else begin Break; end; LCmdQueue.Delete(0); end; end; finally FreeAndNil(LCmdQueue); end; finally FreeAndNil(LContext.FDataChannel); end; end; procedure TIdFTPServer.CommandSYST(ASender: TIdCommand); var LContext : TIdFTPServerContext; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.UserSecurity.DisableSYSTCommand then begin CmdNotImplemented(ASender); Exit; end; //this should keep CuteFTP Pro 3.0 from stopping there's no custom ID and //the Dir format is custonm. if (FDirFormat = ftpdfCustom) and (Trim(FCustomSystID) = '') then begin CmdNotImplemented(ASender); Exit; end; if LContext.IsAuthenticated(ASender) then begin ASender.Reply.SetReply(215, DoSysType(LContext)); end; end; procedure TIdFTPServer.CommandSTAT(ASender: TIdCommand); var LStream: TStringList; LActAsList: boolean; LSwitches, LPath : String; i : Integer; LContext : TIdFTPServerContext; begin LContext := ASender.Context as TIdFTPServerContext; LActAsList := (ASender.Params.Count > 0); if not LActAsList then begin if LContext.UserSecurity.DisableSTATCommand then begin if ASender.UnparsedParams = '' then begin CmdNotImplemented(ASender); Exit; end; end; end; if LContext.IsAuthenticated(ASender) then begin if Assigned(LContext.DataChannel) then begin if not LContext.DataChannel.Stopped then begin LActAsList := False; end; end; if not LActAsList then begin ASender.Reply.NumericCode := 211; ASender.Reply.Text.Clear; if Assigned(FOnStat) then begin LStream := TStringList.Create; try SetRFCReplyFormat(ASender.Reply); FOnStat(LContext, LStream); for i := 0 to LStream.Count - 1 do begin ASender.Reply.Text.Add(' ' + TrimLeft(LStream[i])); {Do not Localize} end; finally FreeAndNil(LStream); end; end; ASender.Reply.Text.Insert(0,RSFTPCmdStartOfStat); ASender.Reply.Text.Add(RSFTPCmdEndOfStat); end else begin //else act as LIST command without a data channel LStream := TStringList.Create; try LSwitches := ''; LPath := ASender.UnparsedParams; if TextStartsWith(LPath, '-') then begin LSwitches := Fetch(LPath); end; ListDirectory(LContext, DoProcessPath(LContext, LPath), LStream, True, LSwitches); //we use IOHandler.WriteLn here because we need better control over what //we send than what Reply.SendReply offers. This is important as the dir //is written using WriteStrings and I found that with Reply.SetReply, a stat //reply could throw off a FTP client. LContext.Connection.IOHandler.WriteLn(IndyFormat('213-%s', [RSFTPDataConnToOpen])); {Do not Localize} LContext.Connection.IOHandler.Write(LStream, False, IndyTextEncoding(NLSTEncType[LContext.NLSTUtf8])); ASender.PerformReply := True; ASender.Reply.SetReply(213, RSFTPCmdEndOfStat); finally FreeAndNil(LStream); end; end; end; end; procedure TIdFTPServer.CommandFEAT(ASender: TIdCommand); const MFFPREFIX = 'MFF '; {Do not Localize} var LTmp : String; LContext: TIdFTPServerContext; // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LContext := TIdFTPServerContext(ASender.Context); LFileSystem := FTPFileSystem; ASender.Reply.Clear; SetRFCReplyFormat(ASender.Reply); ASender.Reply.NumericCode := 211; ASender.Reply.Text.Add(RSFTPCmdExtsSupportedStart); {Do not translate} //AUTH if IOHandler is TIdServerIOHandlerSSLBase then begin if (FUseTLS <> utUseImplicitTLS) then begin ASender.Reply.Text.Add('AUTH TLS;AUTH TLS-C;SSL;TLS-P;'); {Do not translate} end; end; //AVBL if Assigned(FOnAvailDiskSpace) then begin ASender.Reply.Text.Add('AVBL'); end; //CCC if (FUseTLS <> utNoTLSSupport) then begin ASender.Reply.Text.Add('CCC'); {Do not translate} end; //CLNT if Assigned(FOnClientID) then begin ASender.Reply.Text.Add('CLNT'); {Do not translate} end; //COMB if Assigned(FOnCombineFiles) or Assigned(LFileSystem) then begin ASender.Reply.Text.Add('COMB target;source_list'); {Do not translate} end; //CPSV //CPSV is not supported in IPv6 - same problem as PASV if (UseTLS <> utNoTLSSupport) and (LContext.Binding.IPVersion = Id_IPv4) then begin ASender.Reply.Text.Add('CPSV'); {Do not translate} end; //DSIZ if Assigned(OnCompleteDirSize) then begin ASender.Reply.Text.Add('DSIZ'); {Do not localize} end; //EPRT ASender.Reply.Text.Add('EPRT'); {Do not translate} //EPSV ASender.Reply.Text.Add('EPSV'); {Do not translate} //Host if Assigned(FOnHostCheck) then begin ASender.Reply.Text.Add('HOST domain'); {Do not localize} end; // //This is not proper but FTP Voyager uses it to determine if the -T parameter //will work. if Assigned(FOnListDirectory) then begin //we do things this way because the 'a' and 'T' swithces only make sense //when listing Unix dirs. LTmp := 'LIST -l'; {Do not translate} if SupportTaDirSwitches(LContext) then begin LTmp := LTmp + 'aT'; {Do not translate} end; ASender.Reply.Text.Add(LTmp); {do not localize} end; //MDTM if Assigned(FOnGetFileDate) or Assigned(LFileSystem) then begin ASender.Reply.Text.Add('MDTM'); {Do not translate} //MDTM YYYYMMDDHHMMSS filename if Assigned(FOnSetModifiedTime) then begin // ASender.Reply.Text.Add('MDTM YYYYMMDDHHMMSS[+-TZ];filename'); //Indicate that we wish to use FTP Voyager's old MDTM variation for seting time. //time is returned as local (relative to server's timezone. We do this for compatibility ASender.Reply.Text.Add('MDTM YYYYMMDDHHMMSS filename'); {Do not translate} end; end; //MFCT if Assigned(FOnSetCreationTime) then begin ASender.Reply.Text.Add('MFCT'); {Do not Localize} //TODO: The logic for the MMF entry may need to change if we //support modifying more facts end; //MFF LTmp := MFFPREFIX; {Do not localize} if Assigned(FOnSetCreationTime) and (mlsdFileLastAccessTime in FMLSDFacts) then begin LTmp := LTmp + 'Create;'; {Do not Localize} end; if Assigned(FOnSetModifiedTime) or Assigned(LFileSystem) then begin LTmp := LTmp + 'Modify;'; {Do not Localize} end; if Assigned(FOnSiteCHMOD) then begin LTmp := LTmp + 'Unix.mode;'; end; if Assigned(FOnSiteCHOWN) then begin LTmp := LTmp + 'Unix.owner;'; end; if Assigned(FOnSiteCHGRP) then begin LTmp := LTmp + 'Unix.group;'; end; if Assigned(FOnSiteUTIME) and (mlsdFileLastAccessTime in FMLSDFacts) then begin LTmp := LTmp + 'Windows.lastaccesstime;'; end; if Assigned(FOnSetATTRIB) then begin LTmp := LTmp + 'Win32.ea;'; end; if LTmp <> MFFPREFIX then begin ASender.Reply.Text.Add(LTmp); end; //MFMT if Assigned(FOnSetModifiedTime) or Assigned(LFileSystem) then begin ASender.Reply.Text.Add('MFMT'); {Do not Localize} end; //MLST if Assigned(FOnListDirectory) then begin ASender.Reply.Text.Add('MLSD'); {Do not translate} ASender.Reply.Text.Add(MLSFEATLine(FMLSDFacts, LContext.MLSOpts)); {Do not translate} end; //MODE Z if Assigned(FCompressor) then begin ASender.Reply.Text.Add('MODE Z'); {do not localize} end; //OPTS LTmp := 'OPTS '; if Assigned(FOnListDirectory) then begin LTmp := LTmp + 'MLST;'; end; if Assigned(FCompressor) then begin LTmp := LTmp + 'MODE;'; end; LTmp := LTmp + 'UTF8'; ASender.Reply.Text.Add(LTmp); //PBSZ if (FUseTLS <> utNoTLSSupport) then begin ASender.Reply.Text.Add('PBSZ'); {Do not translate} end; //PROT if (FUseTLS <> utNoTLSSupport) then begin ASender.Reply.Text.Add('PROT'); {Do not translate} end; //REST STREAM ASender.Reply.Text.Add('REST STREAM'); {Do not translate} //RMDA if Assigned(FOnRemoveDirectoryAll) then begin ASender.Reply.Text.Add('RMDA directoryname'); {Do not localize} end; //SITE ZONE //Listing a SITE command in feature negotiation is unusual and //may be a little off-spec. FTP Voyager scans this looking for //SITE ZONE and if it's present, it will use the SITE ZONE //to help it convert the time to the user's local time zone. //The only other way that FTP Voyager would know is if the initial //FTP greeting banner started with "Serv-U FTP-Server v2.5f" which //is more problematic because Serve-U is a trademark and we would then //then be stuck with a situation where everyone has to use it down the road. //This would amount to the same mess we had with "Mozilla" in the HTTP //User-Agent header field. //also list other supported site commands; LTmp := 'SITE ZONE'; if Assigned(FOnSetATTRIB) then begin LTmp := LTmp + ';ATTRIB'; end; if Assigned(FOnSiteUMASK) then begin LTmp := LTmp + 'UMASK'; end; if Assigned(FOnSiteCHMOD) then begin LTmp := LTmp + ';CHMOD'; end; if (FDirFormat = ftpdfDOS) or ((FDirFormat = ftpdfOSDependent) and (GOSType = otWindows)) then begin LTmp := LTmp + ';DIRSTYLE'; end; if Assigned(OnSiteUTIME) or Assigned(OnSetModifiedTime) then begin LTmp := LTmp + ';UTIME'; end; if Assigned(OnSiteCHOWN) then begin LTmp := LTmp + ';CHOWN'; end; if Assigned(OnSiteCHGRP) then begin LTmp := LTmp + ';CHGRP'; end; ASender.Reply.Text.Add(LTmp); {do not localize} //SIZE if Assigned(FOnGetFileSize) or Assigned(LFileSystem) then begin ASender.Reply.Text.Add('SIZE'); {do not localize} end; //SPSV ASender.Reply.Text.Add('SPSV'); {do not localize} //SSCN if UseTLS <> utNoTLSSupport then begin ASender.Reply.Text.Add('SSCN'); {do not localize} end; //STAT -l //Some servers such as Microsoft FTP Service, RaidenFTPD, and a few others, //treat a STAT -l as a LIST command, only it's sent on the control connection. //Some versions of Flash FXP can also use this as an option to improve efficiency. if Assigned(FOnListDirectory) then begin //we do things this way because the 'a' and 'T' swithces only make sense //when listing Unix dirs. LTmp := 'STAT -l'; {Do not translate} if SupportTaDirSwitches(LContext) then begin LTmp := LTmp + 'aT'; {Do not translate} end; ASender.Reply.Text.Add(LTmp); {do not localize} end; //TVFS if FPathProcessing <> ftppCustom then begin //TVFS should not be indicated for custom parsing because //we don't know what a person will do. ASender.Reply.Text.Add('TVFS'); {Do not localize} end; // UTF-8 // RFC 2640 says that "Servers MUST support the UTF-8 feature in response to the FEAT command [RFC2389]." // TODO: finish actually implementing UTF-8 support ASender.Reply.Text.Add('UTF8'); {Do not localize} //XCRC if Assigned(FOnCRCFile) or Assigned(LFileSystem) then begin if not GetFIPSMode then begin ASender.Reply.Text.Add('XCRC "filename" SP EP');//filename;start;end'); {Do not Localize} ASender.Reply.Text.Add('XMD5 "filename" SP EP');//filename;start;end'); {Do not Localize} end; ASender.Reply.Text.Add('XSHA1 "filename" SP EP');//filename;start;end'); {Do not Localize} if TIdHashSHA256.IsAvailable then begin ASender.Reply.Text.Add('XSHA256 "filename" SP EP'); //file;start/end end; if TIdHashSHA512.IsAvailable then begin ASender.Reply.Text.Add('XSHA512 "filename" SP EP'); //file;start/end end; end; //I'm doing things this way with complience level to match the current //version of NcFTPD LTmp := 'RFC 959 2389 '; if LContext.UserSecurity.FInvalidPassDelay <> 0 then begin LTmp := LTmp + '2577 '; end; LTmp := LTmp + '3659 '; {Do not Localize} if IOHandler is TIdServerIOHandlerSSLBase then begin if (FUseTLS <> utUseImplicitTLS) then begin LTmp := LTmp + '4217 '; {Do not localize} end; end; ASender.Reply.Text.Add(Trim(LTmp)); {Do not Localize} ASender.Reply.Text.Add(RSFTPCmdExtsSupportedEnd); end; procedure TIdFTPServer.CommandOPTS(ASender: TIdCommand); var LCmd : String; begin LCmd := ASender.UnparsedParams; ASender.Reply.Clear; if TextIsSame(Fetch(LCmd, ' ', False), 'MLST') then begin {do not localize} //just in case the user doesn't create a ListDirectory event. if not Assigned(FOnListDirectory) then begin ASender.Reply.SetReply(501, RSFTPOptNotRecog); Exit; end; end; if not FOPTSCommands.HandleCommand(ASender.Context, LCmd) then begin ASender.Reply.SetReply(501, RSFTPOptNotRecog); end else begin //we don't want an extra 200 reply. ASender.PerformReply := False; end; end; procedure TIdFTPServer.CommandSIZE(ASender: TIdCommand); var s: string; LSize: Int64; LContext : TIdFTPServerContext; // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin LFileSystem := FFTPFileSystem; if Assigned(FOnGetFileSize) or Assigned(LFileSystem) then begin LSize := -1; s := DoProcessPath(LContext, ASender.UnparsedParams); DoOnGetFileSize(LContext, s, LSize); if LSize > -1 then begin ASender.Reply.SetReply(213, IntToStr(LSize)); end else begin CmdFileActionAborted(ASender); end; end else begin CmdSyntaxError(ASender); end; end; end; procedure TIdFTPServer.DoOnChangeDirectory(AContext: TIdFTPServerContext; var VDirectory: TIdFTPFileName); var // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LFileSystem := FFTPFileSystem; if Assigned(LFileSystem) then begin LFileSystem.ChangeDir(AContext, VDirectory); end else if Assigned(FOnChangeDirectory) then begin FOnChangeDirectory(AContext, VDirectory); end; end; procedure TIdFTPServer.DoOnRemoveDirectory(AContext: TIdFTPServerContext; var VDirectory: TIdFTPFileName); var // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LFileSystem := FFTPFileSystem; if Assigned(LFileSystem) then begin LFileSystem.RemoveDirectory(AContext, VDirectory); end else if Assigned(FOnRemoveDirectory) then begin FOnRemoveDirectory(AContext, VDirectory); end; end; procedure TIdFTPServer.DoOnMakeDirectory(AContext: TIdFTPServerContext; var VDirectory: TIdFTPFileName); var // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LFileSystem := FFTPFileSystem; if Assigned(LFileSystem) then begin LFileSystem.MakeDirectory(AContext, VDirectory); end else if Assigned(FOnMakeDirectory) then begin FOnMakeDirectory(AContext, VDirectory); end; end; procedure TIdFTPServer.CommandEPRT(ASender: TIdCommand); var LParm, LIP: string; LDelim: char; LReqIPVersion: TIdIPVersion; LContext : TIdFTPServerContext; LDataChannel: TIdTCPClient; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin LContext.FPASV := False; LParm := ASender.UnparsedParams; if Length(LParm) = 0 then begin LContext.FDataPortDenied := True; CmdInvalidParamNum(ASender); Exit; end; if FFTPSecurityOptions.BlockAllPORTTransfers then begin LContext.FDataPortDenied := True; ASender.Reply.SetReply(502, RSFTPPORTDisabled); Exit; end; LDelim := LParm[1]; Fetch(LParm, LDelim); case IndyStrToInt(Fetch(LParm, LDelim), -1) of 1: LReqIPVersion := Id_IPv4; 2: if GStack.SupportsIPv6 then begin LReqIPVersion := Id_IPv6; end else begin LContext.FDataPort := 0; LContext.FDataPortDenied := True; ASender.Reply.SetReply(522, IndyFormat(RSFTPNetProtNotSup, ['1'])); {Do not translate} Exit; end; else begin LContext.FDataPort := 0; LContext.FDataPortDenied := True; ASender.Reply.SetReply(522, IndyFormat(RSFTPNetProtNotSup, [iif(GStack.SupportsIPv6, '1,2', '1')])); {Do not translate} Exit; end; end; LIP := Fetch(LParm, LDelim); if Length(LIP) = 0 then begin LContext.FDataPort := 0; LContext.FDataPortDenied := True; ASender.Reply.SetReply(500, RSFTPInvalidIP); Exit; end; LContext.FDataPort := TIdPort(IndyStrToInt(Fetch(LParm, LDelim), 0)); if LContext.FDataPort = 0 then begin LContext.FDataPortDenied := True; ASender.Reply.SetReply(500, RSFTPInvalidPort); Exit; end; if FFTPSecurityOptions.NoReservedRangePORT and ((LContext.FDataPort > 0) and (LContext.FDataPort <= 1024)) then begin LContext.FDataPort := 0; LContext.FDataPortDenied := True; ASender.Reply.SetReply(504, RSFTPPORTRange); Exit; end; if FFTPSecurityOptions.FRequirePORTFromSameIP then begin case LReqIPVersion of Id_IPv4: LIP := MakeCanonicalIPv4Address(LIP); Id_IPv6: LIP := MakeCanonicalIPv6Address(LIP); end; if LIP <> LContext.Binding.PeerIP then begin LContext.FDataPort := 0; LContext.FDataPortDenied := True; ASender.Reply.SetReply(504, RSFTPSameIPAddress); Exit; end; end; LContext.CreateDataChannel(False); LDataChannel := TIdTCPClient(LContext.FDataChannel.FDataChannel); LDataChannel.Host := LIP; LDataChannel.Port := LContext.FDataPort; LDataChannel.IPVersion := LReqIPVersion; LContext.FDataPortDenied := False; CmdCommandSuccessful(ASender, 200); end; end; procedure TIdFTPServer.CommandEPSV(ASender: TIdCommand); var LParam: string; LBPortMin, LBPortMax: Word; LIP : String; LIPVersion: TIdIPVersion; LReqIPVersion: TIdIPVersion; LContext : TIdFTPServerContext; LDataChannel: TIdSimpleServer; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin LIPVersion := LContext.Binding.IPVersion; LReqIPVersion := LIPVersion; LParam := ASender.UnparsedParams; if Length(LParam) > 0 then begin case IndyStrToInt(LParam, -1) of 1: LReqIPVersion := Id_IPv4; 2: if GStack.SupportsIPv6 then begin LReqIPVersion := Id_IPv6; end else begin ASender.Reply.SetReply(522, IndyFormat(RSFTPNetProtNotSup, ['1'])); {do not localize} Exit; end; else begin if TextIsSame(LParam, 'ALL') then begin { do not localize } LContext.FEPSVAll := True; ASender.Reply.SetReply(200, RSFTPEPSVAllEntered); end else begin ASender.Reply.SetReply(522, IndyFormat(RSFTPNetProtNotSup, [iif(GStack.SupportsIPv6, '1,2', '1')])); {do not localize} end; Exit; end; end; end; if LReqIPVersion = LIPVersion then begin LIP := LContext.Binding.IP; end; if (FPASVBoundPortMin <> 0) and (FPASVBoundPortMax <> 0) then begin LBPortMin := FPASVBoundPortMin; LBPortMax := FPASVBoundPortMax; end else begin LBPortMin := FDefaultDataPort; LBPortMax := LBPortMin; end; DoOnPASVBeforeBind(LContext, LIP, LBPortMin, LBPortMax, LReqIPVersion); LContext.CreateDataChannel(True); LDataChannel := TIdSimpleServer(LContext.FDataChannel.FDataChannel); LDataChannel.BoundIP := LIP; if LBPortMin = LBPortMax then begin LDataChannel.BoundPort := LBPortMin; LDataChannel.BoundPortMin := 0; LDataChannel.BoundPortMax := 0; end else begin LDataChannel.BoundPort := 0; LDataChannel.BoundPortMin := LBPortMin; LDataChannel.BoundPortMax := LBPortMax; end; LDataChannel.IPVersion := LReqIPVersion; LDataChannel.BeginListen; LIP := LDataChannel.Binding.IP; LBPortMin := LDataChannel.Binding.Port; //Note that only one Port can work with EPSV DoOnPASVReply(LContext, LIP, LBPortMin, LReqIPVersion); LParam := '|||' + IntToStr(LBPortMin) + '|'; {Do not localize} ASender.Reply.SetReply(229, IndyFormat(RSFTPEnteringEPSV, [LParam])); ASender.SendReply; LContext.FPASV := True; end; end; procedure TIdFTPServer.CommandMDTM(ASender: TIdCommand); var s: string; LDate: TDateTime; LContext : TIdFTPServerContext; LSDate : String; LExists : Boolean; // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; { I know that this code and design are a mess. There are actually two forms of MDTM and they mean different things. The formal spec indicates that anything after the space in MDTM is the filename. FTP Voyager and some other clients abuse the MDTM command by using it to specify a timestamp for the "Modified Time" on a file. The format is like this: MDTM YYYYMMDDHHMMSS filename Thus, there's an ambiguity. Does MDTM 20031229152022 ESBAdDemo.exe mean 1) Set the date time on ESBAdDemo.exe to 12/29/2003 3:20:22 PM or 2) Get the time for a file named 20031229152022 ESBAdDemo.exe To resolve this ambiguity, we check specifically for a valid date, and then see if a file, 20031229152022 ESBAdDemo.exe really does exist. If not, we interpret MDTM as a set date command. Otherwise, we will traat it as a request for the timestamp of a file, 20031229152022 ESBAdDemo.exe. Note also that the time is sometimes given as either relative to the local server or an offset is provided. Note from: http://www.ftpvoyager.com/releasenotes.asp ==== Added support for RFC change and the MDTM. MDTM requires sending the server GMT (UTC) instead of a "fixed" date and time. FTP Voyager supports this with Serv-U automatically by checking the Serv-U version number and by checking the response to the FEAT command for MDTM. Servers returning "MDTM" or "MDTM YYYYMMDDHHMMSS[+-TZ] filename" will use the old method. Servers returning "MDTM YYYYMMDDHHMMSS" only will use the new method where the date a and time is GMT (UTC). === We will use the old form for compatiability with some older FTP Voyager clients and because a few servers support the old form as well. I do this even though, this is really inconsistant with what MDTM returns for a query request. I might consider some type of support for the new form but I do not feel that such things are just abuse of the MDTM command. That's why I prefer a separate command for modifying file modification dates (MFMT). } begin LFileSystem := FFTPFileSystem; if Assigned(FOnGetFileDate) or Assigned(LFileSystem) then begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin s := ASender.UnparsedParams; LSDate := Fetch(s); if IsMDTMDate(LSDate) then begin s := DoProcessPath(LContext, ASender.UnparsedParams ); DoOnFileExistCheck(LContext, s, LExists); if not LExists then begin s := ASender.UnparsedParams; Fetch(s); s := DoProcessPath(LContext, s); LDate := FTPMDTMToGMTDateTime(LSDate); DoOnSetModifiedTime(LContext, s, LDate); // Self.DoOnSetModifiedTime(LF,s, LSDate); ASender.Reply.SetReply(253, 'Date/time changed okay.'); {do not localize} Exit; end; end; s := DoProcessPath(LContext, ASender.UnparsedParams); LDate := 0; DoOnGetFileDate(LContext, s, LDate); if LDate > 0 then begin ASender.Reply.SetReply(213, FTPGMTDateTimeToMLS(LDate)); end else begin CmdFileActionAborted(ASender); end; end; end else begin CmdSyntaxError(ASender); end; end; procedure TIdFTPServer.SetFTPSecurityOptions(const AValue: TIdFTPSecurityOptions); begin FFTPSecurityOptions.Assign(AValue); end; procedure TIdFTPServer.SetOnUserAccount(AValue: TOnFTPUserAccountEvent); var LCmd : TIdCommandHandler; i : Integer; begin if FUserAccounts = nil then begin FOnUserAccount := AValue; for i := 0 to CommandHandlers.Count - 1 do begin LCmd := CommandHandlers.Items[i]; if LCmd.Command = 'ACCT' then begin if Assigned(AValue) then begin LCmd.HelpSuperScript := ''; LCmd.Description.Text := ACCT_HELP_ENABLED; end else begin LCmd.HelpSuperScript := '*'; LCmd.Description.Text := ACCT_HELP_DISABLED; end; end; end; end; end; procedure TIdFTPServer.CommandAUTH(ASender: TIdCommand); var LIO : TIdSSLIOHandlerSocketBase; LContext : TIdFTPServerContext; begin LContext := ASender.Context as TIdFTPServerContext; if (PosInStrArray(ASender.UnparsedParams, TLS_AUTH_NAMES) > -1) and (IOHandler is TIdServerIOHandlerSSLBase) and (FUseTLS in ExplicitTLSVals) then begin ASender.Reply.SetReply(234,RSFTPAuthSSL); ASender.SendReply; LIO := ASender.Context.Connection.IOHandler as TIdSSLIOHandlerSocketBase; LIO.Passthrough := False; { This is from: http://www.ford-hutchinson.com/~fh-1-pfh/ftps-ext.html#bad and we implement things this way for historical reasons so we don't break older and newer clients. } case PosInStrArray(ASender.UnparsedParams, TLS_AUTH_NAMES) of 0,2 : LContext.DataProtection := ftpdpsClear; //AUTH TLS, AUTH TLS-C 1,3 : LContext.DataProtection := ftpdpsPrivate; //AUTH SSL, AUTH TLS-P end; LContext.AuthMechanism := 'TLS'; {Do not localize} end else begin CmdSyntaxError(ASender); end; end; procedure TIdFTPServer.CommandAVBL(ASender: TIdCommand); var LContext : TIdFTPServerContext; LIsFile : Boolean; LSize : Int64; LPath : String; begin LIsFile := True; LSize := 0; LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin if Assigned(FOnAvailDiskSpace) then begin LPath := DoProcessPath(LContext, ASender.UnparsedParams); FOnAvailDiskSpace(LContext, LPath, LIsFile, LSize); if LIsFile then begin ASender.Reply.SetReply(550, IndyFormat(RSFTPIsAFile,[LPath])); end else begin ASender.Reply.SetReply(213, IntToStr(LSize)); end; end else begin CmdNotImplemented(ASender); end; end else begin ASender.Reply.SetReply(550, RSFTPFileActionNotTaken); end; end; //FOnCompleteDirSize procedure TIdFTPServer.CommandDSIZ(ASender : TIdCommand); var LContext : TIdFTPServerContext; LIsFile : Boolean; LSize : Int64; LPath : String; begin LIsFile := True; LSize := 0; LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin if Assigned(FOnCompleteDirSize) then begin LPath := DoProcessPath(LContext, ASender.UnparsedParams); FOnCompleteDirSize(LContext, LPath, LIsFile, LSize); if LIsFile then begin ASender.Reply.SetReply(550, IndyFormat(RSFTPIsAFile,[LPath])); end else begin ASender.Reply.SetReply(213, IntToStr(LSize)); end; end else begin CmdNotImplemented(ASender); end; end else begin ASender.Reply.SetReply(550, RSFTPFileActionNotTaken); end; end; procedure TIdFTPServer.CommandRMDA(ASender : TIdCommand); var LContext : TIdFTPServerContext; LPath : TIdFTPFileName; begin //FOnRemoveDirectoryAll: TOnDirectoryEvent; LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin if Assigned(FOnRemoveDirectoryAll) then begin LPath := DoProcessPath(LContext, ASender.UnparsedParams); FOnRemoveDirectoryAll(LContext, LPath); ASender.Reply.SetReply(250, RSFTPFileActionCompleted); end else begin CmdNotImplemented(ASender); end; end else begin ASender.Reply.SetReply(550, RSFTPFileActionNotTaken); end; end; procedure TIdFTPServer.CommandCCC(ASender: TIdCommand); var LIO : TIdSSLIOHandlerSocketBase; LContext : TIdFTPServerContext; begin LContext := ASender.Context as TIdFTPServerContext; if FUseTLS <> utNoTLSSupport then begin //Not sure if it's proper to require authentication before a CCC //but it is a good idea anyway because you definately want to //prevent eavesdropping if LContext.IsAuthenticated(ASender) then begin if LContext.FUserSecurity.PermitCCC then begin ASender.Reply.SetReply(200, RSFTPClearCommandConnection); ASender.SendReply; LIO := ASender.Context.Connection.IOHandler as TIdSSLIOHandlerSocketBase; LIO.Passthrough := True; LContext.FCCC := True; end else begin ASender.Reply.SetReply(534, RSFTPClearCommandNotPermitted); end; end; end else begin CmdSyntaxError(ASender); end; end; procedure TIdFTPServer.CommandPBSZ(ASender: TIdCommand); {Note that this may have to be expanded and reworked for other AUTH mechanisms} var LContext : TIdFTPServerContext; begin LContext := ASender.Context as TIdFTPServerContext; if IOHandler is TIdServerIOHandlerSSLBase then begin if ASender.UnparsedParams = '' then begin CmdInvalidParamNum(ASender); Exit; end; if (LContext.AuthMechanism = '') and (FUseTLS <> utUseImplicitTLS) then begin ASender.Reply.SetReply(503, RSFTPPBSZAuthDataRequired); Exit; end; if LContext.FCCC then begin ASender.Reply.SetReply(503, RSFTPPBSZNotAfterCCC); Exit; end; if (LContext.AuthMechanism = 'TLS') or (FUseTLS = utUseImplicitTLS) then begin {Do not localize} ASender.Reply.SetReply(200,RSFTPDataProtBuffer0); LContext.DataPBSZCalled := True; end else if IsNumeric(ASender.UnparsedParams) then begin ASender.Reply.SetReply(200,'PBSZ=0'); {Do not translate} LContext.DataPBSZCalled := True; end else begin CmdInvalidParams(ASender); end; end else begin CmdSyntaxError(ASender); end; end; procedure TIdFTPServer.CommandPROT(ASender: TIdCommand); const LValidParams : array [0..3] of string = ('C','S','E','P'); {Do not translate} {Note that this may have to be expanded and reworked for other AUTH mechanisms} var LContext : TIdFTPServerContext; begin LContext := ASender.Context as TIdFTPServerContext; if IOHandler is TIdServerIOHandlerSSLBase then begin if LContext.FCCC then begin ASender.Reply.SetReply(503, RSFTPPBSZNotAfterCCC); Exit; end; if not LContext.DataPBSZCalled then begin ASender.Reply.SetReply(503, RSFTPPROTProtBufRequired); Exit; end; case PosInStrArray(ASender.UnparsedParams, LValidParams) of 0 : begin LContext.FDataProtection := ftpdpsClear; ASender.Reply.SetReply(200, RSFTPProtTypeClear); end; 1, 2 : ASender.Reply.SetReply(536, RSFTPInvalidProtTypeForMechanism); 3 : begin LContext.FDataProtection := ftpdpsPrivate; ASender.Reply.SetReply(200, RSFTPProtTypePrivate); end; else ASender.Reply.SetReply(504, RSFTPInvalidForParam); end; end else begin CmdNotImplemented(ASender); end; end; procedure TIdFTPServer.CommandCOMB(ASender: TIdCommand); var LFileParts : TStringList; LBuf : String; LTargetFileName : String; LContext : TIdFTPServerContext; // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LContext := ASender.Context as TIdFTPServerContext; LFileSystem := FTPFileSystem; if Assigned(FOnCombineFiles) or Assigned(LFileSystem) then begin if LContext.IsAuthenticated(ASender) then begin if ASender.UnparsedParams = '' then begin CmdInvalidParamNum(ASender); Exit; end; if Pos('"', ASender.UnparsedParams) > 0 then begin LBuf := ASender.UnparsedParams; Fetch(LBuf,'"'); LTargetFileName := Fetch(LBuf, '"'); LTargetFileName := DoProcessPath(LContext, LTargetFileName); LBuf := Trim(LBuf); LFileParts := TStringList.Create; try while LBuf <> '' do begin Fetch(LBuf,'"'); LFileParts.Add(DoProcessPath(LContext, Fetch(LBuf,'"'))); end; DoOnCombineFiles(LContext, LTargetFileName, LFileParts); ASender.Reply.SetReply(250, RSFTPFileOpSuccess); finally FreeAndNil(LFileParts); end; end else begin CmdInvalidParams(ASender); end; end; end else begin CmdNotImplemented(ASender); end; end; procedure TIdFTPServer.DoConnect(AContext: TIdContext); var LGreeting : TIdReplyRFC; begin AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_8Bit; if AContext.Connection.IOHandler is TIdSSLIOHandlerSocketBase then begin if FUseTLS = utUseImplicitTLS then begin TIdSSLIOHandlerSocketBase(AContext.Connection.IOHandler).PassThrough := False; end; end; (AContext as TIdFTPServerContext).FXAUTKey := MakeXAUTKey; if Assigned(OnGreeting) then begin LGreeting := TIdReplyRFC.Create(nil); try LGreeting.Assign(Greeting); OnGreeting(TIdFTPServerContext(AContext), LGreeting); ReplyTexts.UpdateText(LGreeting); if (not GetFIPSMode) and FSupportXAUTH and (LGreeting.NumericCode = 220) then begin (AContext as TIdFTPServerContext).FXAUTKey := IdFTPCommon.MakeXAUTKey; XAutGreeting(AContext,LGreeting, GStack.HostName); end; AContext.Connection.IOHandler.Write(LGreeting.FormattedReply); if Assigned(OnConnect) then begin OnConnect(AContext); end; if LGreeting.NumericCode = 421 then begin AContext.Connection.Disconnect(False); end; finally FreeAndNil(LGreeting); end; end else begin if (not GetFIPSMode) and FSupportXAUTH and (Greeting.NumericCode = 220) then begin LGreeting := TIdReplyRFC.Create(nil); try LGreeting.Assign(Greeting); XAutGreeting(AContext,LGreeting, GStack.HostName); AContext.Connection.IOHandler.Write(LGreeting.FormattedReply); if Assigned(OnConnect) then begin OnConnect(AContext); end; if LGreeting.NumericCode = 421 then begin AContext.Connection.Disconnect(False); end; finally FreeAndNil(LGreeting); end; end else begin inherited DoConnect(AContext); end; end; end; procedure TIdFTPServer.CommandQUIT(ASender: TIdCommand); begin if Assigned(FOnQuitBanner) then begin FOnQuitBanner(TIdFTPServerContext(ASender.Context), ASender.Reply); ASender.Disconnect := True; end else begin ASender.Reply.Assign(ASender.CommandHandler.NormalReply); end; ASender.Reply.SetReply(221, ASender.Reply.Text.Text); end; procedure TIdFTPServer.CommandMLSD(ASender: TIdCommand); var LStream: TStringList; LSendData : Boolean; LContext : TIdFTPServerContext; begin if not Assigned(OnListDirectory) then begin CmdSyntaxError(ASender); Exit; end; LContext := ASender.Context as TIdFTPServerContext; LSendData := False; if LContext.IsAuthenticated(ASender) then begin if (not Assigned(LContext.FDataChannel)) or LContext.FDataPortDenied then begin ASender.Reply.SetReply(425, RSFTPCantOpenData); Exit; end; LStream := TStringList.Create; try ListDirectory(LContext, DoProcessPath(LContext, ASender.UnparsedParams), LStream, TextIsSame(ASender.CommandHandler.Command, 'LIST'), 'MLSD'); {Do not translate} LSendData := True; finally try if LSendData then begin //it should be safe to assume that the FDataChannel object exists because //we checked it earlier LContext.FDataChannel.Data := LStream; LContext.FDataChannel.OKReply.SetReply(226, RSFTPDataConnClosed); LContext.FDataChannel.ErrorReply.SetReply(426, RSFTPDataConnClosedAbnormally); LContext.FDataChannel.FFtpOperation := ftpRetr; ASender.Reply.SetReply(125, RSFTPDataConnToOpen); ASender.SendReply; DoDataChannelOperation(ASender); end else begin LContext.KillDataChannel; ASender.Reply.SetReply(426, RSFTPDataConnClosedAbnormally); end; finally LStream.Free; end; end; end; end; procedure TIdFTPServer.CommandMLST(ASender: TIdCommand); var LStream : TStringList; i : Integer; LContext : TIdFTPServerContext; LPath : String; LDir : TIdFTPListOutput; begin if Assigned(OnListDirectory) or Assigned(FOnMLST) then begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin LStream := TStringList.Create; try LPath := DoProcessPath(LContext, ASender.UnparsedParams); if Assigned(FOnMLST) then begin LDir := TIdFTPListOutput.Create; try FOnMLST(LContext, LPath, LDir); LDir.MLISTOutputDir(LStream, LContext.MLSOpts); finally FreeAndNil(LDir); end; end else begin //this part is kept just for backwards compatibility ListDirectory(LContext, LPath, LStream, True, 'MLST'); {Do not translate} end; ASender.Reply.Clear; SetRFCReplyFormat(ASender.Reply); ASender.Reply.NumericCode := 250; ASender.Reply.Text.Add('Begin'); {do not localize} for i := 0 to LStream.Count -1 do begin ASender.Reply.Text.Add(' ' + LStream[i]); end; ASender.Reply.Text.Add('End'); {do not localize} ASender.SendReply; finally FreeAndNil(LStream); end; end; end else begin CmdSyntaxError(ASender); end; end; procedure TIdFTPServer.DoOnSetModifiedTime(AContext: TIdFTPServerContext; const AFileName : String; var VDateTime: TDateTime); var // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LFileSystem := FTPFileSystem; if Assigned(LFileSystem) then begin LFileSystem.SetModifiedFileDate(AContext, AFileName, VDateTime); end else if Assigned(FOnSetModifiedTime) then begin FOnSetModifiedTime(AContext, AFileName, VDateTime); end; end; procedure TIdFTPServer.DoOnSetModifiedTime(AContext: TIdFTPServerContext; const AFileName : String; var VDateTimeStr : String); var LTime : TDateTime; begin LTime := FTPMLSToGMTDateTime(VDateTimeStr); DoOnSetModifiedTime(AContext, AFileName, LTime); VDateTimeStr := FTPGMTDateTimeToMLS(LTime); end; procedure TIdFTPServer.DoOnSetCreationTime(AContext: TIdFTPServerContext; const AFileName : String; var VDateTime: TDateTime); var // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LFileSystem := FTPFileSystem; if Assigned(LFileSystem) then begin //LFileSystem.SetCreationFileDate(AContext,AFileName,VDateTime); end else if Assigned(FOnSetCreationTime) then begin FOnSetCreationTime(AContext, AFileName, VDateTime); end; end; procedure TIdFTPServer.DoOnSetCreationTimeGMT(AContext: TIdFTPServerContext; const AFileName: String; var VDateTime: TDateTime); begin if Assigned(FOnSetCreationTime) then begin FOnSetCreationTime(AContext, AFileName, VDateTime); end; end; procedure TIdFTPServer.DoOnSetModifiedTimeGMT(AContext: TIdFTPServerContext; const AFileName: String; var VDateTime: TDateTime); begin if Assigned(FOnSetModifiedTime) then begin FOnSetModifiedTime(AContext, AFileName, VDateTime); end; end; procedure TIdFTPServer.DoOnSetCreationTime(AContext: TIdFTPServerContext; const AFileName : String; var VDateTimeStr : String); var LTime : TDateTime; begin LTime := FTPMLSToLocalDateTime(VDateTimeStr); DoOnSetCreationTime(AContext, AFileName, LTime); VDateTimeStr := FTPLocalDateTimeToMLS(LTime); end; procedure TIdFTPServer.CommandMFMT(ASender: TIdCommand); var LTimeStr, LFileName : String; LContext : TIdFTPServerContext; // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin LFilesystem := FTPFileSystem; if Assigned(FOnSetModifiedTime) or Assigned(LFileSystem) then begin LFileName := ASender.UnparsedParams; LTimeStr := Fetch(LFileName); LFileName := DoProcessPath(LContext, LFileName); DoOnSetModifiedTime(LContext, LFileName, LTimeStr); ASender.Reply.SetReply(213, IndyFormat('Modify=%s %s', [LTimeStr, LFileName])); {Do not translate} end else begin CmdSyntaxError(ASender); end; end; end; procedure TIdFTPServer.CommandMFCT(ASender: TIdCommand); var LTimeStr, LFileName : String; LContext : TIdFTPServerContext; // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LContext := TIdFTPServerContext(ASender.Context); if LContext.IsAuthenticated(ASender) then begin LFileSystem := FTPFileSystem; if Assigned(FOnSetCreationTime) or Assigned(LFileSystem) then begin LFileName := ASender.UnparsedParams; LTimeStr := Fetch(LFileName); LFileName := DoProcessPath(LContext, LFileName); DoOnSetCreationTime(LContext, LFileName, LTimeStr); ASender.Reply.SetReply(213, IndyFormat('CreateTime=%s %s', [LTimeStr, LFileName])); {Do not translate} end else begin CmdSyntaxError(ASender); end; end; end; procedure TIdFTPServer.CommandMFF(ASender: TIdCommand); var LFacts : TStringList; LFileName : String; LValue : String; s : String; LContext : TIdFTPServerContext; LAttrib : UInt32; LAuth : Boolean; LDummyDate1, LDummyDate2 : TDateTime; LDate : TDateTime; LCHMOD : Integer; LDummy : String; begin LAuth := True; LDummy := ''; //empty value for passing a var in case we need to do that LContext := TIdFTPServerContext(ASender.Context); //this may need to change if we make more facts to modify if not Assigned(FOnSetModifiedTime) and not Assigned(FOnSetCreationTime) then begin CmdSyntaxError(ASender); Exit; end; s := ''; if ASender.UnparsedParams = '' then begin CmdInvalidParamNum(ASender); Exit; end; if LContext.IsAuthenticated(ASender) then begin LFacts := TStringList.Create; try LFileName := ParseFacts(ASender.UnparsedParams, LFacts); LFileName := DoProcessPath(LContext, LFileName); if LFacts.Values['Modify'] <> '' then begin {Do not translate} if Assigned(FOnSetModifiedTime) then begin LValue := LFacts.Values['Modify']; {Do not translate} DoOnSetModifiedTime(LContext, LFileName, LValue); s := s + IndyFormat('Modify=%s;', [LValue]); {Do not translate} end; end; if LFacts.Values['Create'] <> '' then begin {Do not translate} if Assigned(FOnSetCreationTime) then begin LValue := LFacts.Values['Create']; {Do not translate} DoOnSetCreationTime(LContext, LFileName, LValue); s := s + IndyFormat('Create=%s;', [LValue]); {Do not translate} end; end; if LFacts.Values['Win32.ea'] <> '' then begin if Assigned(FOnSetATTRIB) then begin LValue := LFacts.Values['Win32.ea']; {Do not localize} LAttrib := IndyStrToInt(LValue); DoOnSetAttrib(LContext, LAttrib, LFileName, LAuth); LValue := '0x' + IntToHex(LAttrib, 8); s := s + IndyFormat('Win32.ea=%s;', [LValue]); {Do not translate} end; end; if LFacts.Values['Unix.mode'] <> '' then begin LValue := LFacts.Values['Unix.mode']; {Do not localize} if Assigned(FOnSiteCHMOD) then begin If IsValidPermNumbers(LValue) then begin LCHMOD := IndyStrToInt(LValue); DoOnSiteCHMOD(LContext, LCHMOD, LFileName, LAuth); LValue := IndyFormat('%.4d', [LCHMOD]); s := s + IndyFormat('Unix.mode=%s;', [LValue]); {Do not translate} end; end; end; if LFacts.Values['Unix.owner'] <> '' then begin {Do not localize} LValue := LFacts.Values['Unix.owner']; {Do not localize} if Assigned(FOnSiteCHOWN) then begin DoOnSiteCHOWN(LContext, LValue, LDummy, LFileName, LAuth); s := s + IndyFormat('Unix.owner=%s;', [LValue]); {Do not localize} end; end; if LFacts.Values['Unix.group'] <> '' then begin {Do not localize} LValue := LFacts.Values['Unix.group']; {Do not localize} if Assigned(FOnSiteCHGRP) then begin DoOnSiteCHGRP(LContext, LValue, LFileName, LAuth); s := s + IndyFormat('Unix.group=%s;', [LValue]); {Do not localize} end; end; if LFacts.Values['Windows.lastaccesstime'] <> '' then begin LValue := LFacts.Values['Windows.lastaccesstime']; if Assigned(FOnSiteUTIME) and (mlsdFileLastAccessTime in FMLSDFacts) then begin LDate := FTPMLSToGMTDateTime(LValue); LDummyDate1 := 0; LDummyDate2 := 0; FOnSiteUTIME(LContext, LFileName, LDate, LDummyDate1, LDummyDate2, LAuth); LValue := FTPGMTDateTimeToMLS(LDate); s := s + IndyFormat('Windows.lastaccesstime=%s;', [LValue]); end; end; if s <> '' then begin ASender.Reply.SetReply(213, s + ' ' + LFileName); end else begin ASender.Reply.SetReply(504, IndyFormat(RSFTPParamError, ['MFF'])); {Do not translate} end; finally FreeAndNil(LFacts); end; end; end; function TIdFTPServer.GetMD5Checksum(ASender : TIdFTPServerContext; const AFileName : String ) : String; var LCalcStream : TStream; begin Result := ''; DoOnMD5Cache(ASender, AFileName, Result); if Result = '' then begin LCalcStream := nil; DoOnCRCFile(ASender, AFileName, LCalcStream); if Assigned(LCalcStream) then try LCalcStream.Position := 0; Result := CalculateCheckSum(TIdHashMessageDigest5, LCalcStream, 0, LCalcStream.Size); DoOnMD5Verify(ASender, AFileName, Result); finally FreeAndNil(LCalcStream); end; end; end; procedure TIdFTPServer.CommandMMD5(ASender: TIdCommand); var LChecksum : String; LRes : String; LFiles : TStringList; LError : Boolean; i : Integer; LContext : TIdFTPServerContext; // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LContext := ASender.Context as TIdFTPServerContext; if GetFIPSMode then begin CmdSyntaxError(ASender); Exit; end; LError := False; LChecksum := ''; LRes := ''; if LContext.IsAuthenticated(ASender) then begin LFileSystem := FTPFileSystem; if Assigned(FOnCRCFile) or Assigned(FOnMD5Cache) or Assigned(LFileSystem) then begin LFiles := TStringList.Create; try ParseQuotedArgs(ASender.UnparsedParams, LFiles); for i := 0 to LFiles.Count -1 do begin LChecksum := GetMD5Checksum(LContext, DoProcessPath(LContext, UnquotedStr(LFiles[i]))); if LChecksum = '' then begin LError := True; Break; end; LRes := LRes + ',' + LFiles[i] + ' '+ LChecksum; end; IdDelete(LRes,1,1); finally FreeAndNil(LFiles); end; if LError then begin //The http://www.potaroo.net/ietf/idref/draft-twine-ftpmd5/ //draft didn't specify 550 as an error. CmdTwineFileActionAborted(ASender); end else begin ASender.Reply.SetReply(252, LRes); end; end else begin CmdSyntaxError(ASender); end; end; end; procedure TIdFTPServer.CommandMD5(ASender: TIdCommand); var LChecksum : String; LContext : TIdFTPServerContext; // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LContext := TIdFTPServerContext(ASender.Context); if GetFIPSMode then begin CmdSyntaxError(ASender); Exit; end; LChecksum := ''; if LContext.IsAuthenticated(ASender) then begin LFileSystem := FTPFileSystem; if Assigned(FOnCRCFile) or Assigned(LFileSystem) then begin LChecksum := GetMD5Checksum(LContext, DoProcessPath(LContext, ASender.UnparsedParams)); if LChecksum = '' then begin CmdTwineFileActionAborted(ASender); end else begin ASender.Reply.SetReply(251, LChecksum); end; end else begin CmdSyntaxError(ASender); end; end; end; procedure TIdFTPServer.DoOnMD5Verify(ASender: TIdFTPServerContext; const AFileName, ACheckSum: String); begin if Assigned(OnMD5Verify) then begin OnMD5Verify(ASender, AFileName, AChecksum); end; end; procedure TIdFTPServer.DoOnMD5Cache(ASender: TIdFTPServerContext; const AFileName: String; var VCheckSum: String); begin if Assigned(OnMD5Cache) then begin OnMD5Cache(ASender, AFileName, VCheckSum); end; end; procedure TIdFTPServer.DoDisconnect(AContext: TIdContext); var // under ARC, convert a weak reference to a strong reference before working with it LUserAccounts: TIdCustomUserManager; begin LUserAccounts := FUserAccounts; if Assigned(LUserAccounts) then begin LUserAccounts.UserDisconnected(TIdFTPServerContext(AContext).UserName); {$IFDEF USE_OBJECT_ARC}LUserAccounts := nil;{$ENDIF} end; inherited DoDisconnect(AContext); end; procedure TIdFTPServer.DoOnCRCFile(ASender: TIdFTPServerContext; const AFileName: String; var VStream: TStream); var // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LFileSystem := FTPFileSystem; if Assigned(LFileSystem) then begin LFileSystem.GetCRCCalcStream(ASender, AFileName, VStream); end else if Assigned(FOnCRCFile) then begin FOnCRCFile(ASender, AFileName, VStream); end; end; procedure TIdFTPServer.DoOnCombineFiles(ASender: TIdFTPServerContext; const ATargetFileName: string; AParts: TStrings); var // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LFileSystem := FTPFileSystem; if Assigned(LFileSystem) then begin LFileSystem.CombineFiles(ASender, ATargetFileName, AParts); end else if Assigned(FOnCombineFiles) then begin FOnCombineFiles(ASender, ATargetFileName, AParts); end; end; procedure TIdFTPServer.DoOnRenameFile(ASender: TIdFTPServerContext; const ARenameFromFile, ARenameToFile: string); var // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LFileSystem := FTPFileSystem; if Assigned(LFileSystem) then begin LFileSystem.RenameFile(ASender, ARenameToFile); end else if Assigned(FOnRenameFile) then begin FOnRenameFile(ASender, ARenameFromFile, ARenameToFile); end; end; procedure TIdFTPServer.DoOnGetFileDate(ASender: TIdFTPServerContext; const AFilename: string; var VFileDate: TDateTime); var // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LFileSystem := FTPFileSystem; if Assigned(LFileSystem) then begin LFileSystem.GetFileDate(ASender, AFileName, VFileDate); VFileDate := VFileDate - OffsetFromUTC; end else if Assigned(FOnGetFileDate) then begin FOnGetFileDate(ASender, AFileName, VFileDate); end; end; procedure TIdFTPServer.DoOnGetFileSize(ASender: TIdFTPServerContext; const AFilename: string; var VFileSize: Int64); var // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LFileSystem := FTPFileSystem; if Assigned(LFileSystem) then begin LFileSystem.GetFileSize(ASender, AFileName, VFileSize); end else if Assigned(FOnGetFileSize) then begin FOnGetFileSize(ASender, AFileName, VFileSize); end; end; procedure TIdFTPServer.DoOnDeleteFile(ASender: TIdFTPServerContext; const APathName: string); var // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LFileSystem := FTPFileSystem; if Assigned(LFileSystem) then begin LFileSystem.DeleteFile(ASender, APathName); end else if Assigned(FOnDeleteFile) then begin FOnDeleteFile(ASender, APathName); end; end; procedure TIdFTPServer.SetUseTLS(AValue: TIdUseTLS); begin inherited SetUseTLS(AValue); if AValue = utUseImplicitTLS then begin if DefaultDataPort = IdPORT_FTP_DATA then begin DefaultDataPort := IdPORT_ftps_data; end; end else if DefaultDataPort = IdPORT_ftps_data then begin DefaultDataPort := IdPORT_FTP_DATA; end; end; procedure TIdFTPServer.DisconUser(ASender: TIdCommand); begin ASender.Disconnect := True; ASender.Reply.SetReply(421, RSFTPClosingConnection); if Assigned(OnLoginFailureBanner) then begin OnLoginFailureBanner(TIdFTPServerContext(ASender.Context), ASender.Reply); ASender.Reply.SetReply(421, ASender.Reply.Text.Text); end; end; procedure TIdFTPServer.SetRFCReplyFormat(AReply: TIdReply); begin if AReply is TIdReplyFTP then begin TIdReplyFTP(AReply).ReplyFormat := rfIndentMidLines; end; end; procedure TIdFTPServer.CommandSiteATTRIB(ASender : TIdCommand); var LContext : TIdFTPServerContext; LFileName, LAttrs : String; LAttrVal : UInt32; LPermitted : Boolean; function ValidAttribStr(const AAttrib : String) : Boolean; var i : Integer; begin Result := TextStartsWith(AAttrib, '+'); if Result then begin Result := Length(AAttrib)>1; if result then begin if AAttrib = '+N' then begin Exit; end; for i := 2 to Length(AAttrib) do begin if not CharIsInSet(AAttrib,i,'RASH') then begin Result := False; break; end; end; end; end; end; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin if Assigned(OnSetAttrib) then begin LFileName := ASender.UnparsedParams; LAttrs := Fetch(LFileName); LPermitted := True; LAttrs := UpperCase(LAttrs); if TextStartsWith(LAttrs, '+') then begin if ValidAttribStr(LAttrs) then begin LAttrVal := 0; ASender.Reply.Clear; ASender.Reply.SetReply(220,''); if IndyPos('R', LATTRS) > 0 then begin LAttrVal := LAttrVal or IdFILE_ATTRIBUTE_READONLY; ASender.Reply.Text.Add(RSFTPSiteATTRIBMsg+' : +FILE_ATTRIBUTE_READONLY'); {Do not localize} end; if IndyPos('A', LATTRS) > 0 then begin LAttrVal := LAttrVal or IdFILE_ATTRIBUTE_ARCHIVE; ASender.Reply.Text.Add(RSFTPSiteATTRIBMsg+' : +FILE_ATTRIBUTE_ARCHIVE'); {Do not localize} end; if IndyPos('S', LATTRS) > 0 then begin LAttrVal := LAttrVal or IdFILE_ATTRIBUTE_SYSTEM; ASender.Reply.Text.Add(RSFTPSiteATTRIBMsg+' : +FILE_ATTRIBUTE_SYSTEM'); {Do not localize} end; if IndyPos('H', LATTRS) > 0 then begin LAttrVal := LAttrVal or IdFILE_ATTRIBUTE_HIDDEN; ASender.Reply.Text.Add(RSFTPSiteATTRIBMsg+' : +FILE_ATTRIBUTE_HIDDEN'); {Do not localize} end; if IndyPos('N', LATTRS) > 0 then begin LAttrVal := LAttrVal or IdFILE_ATTRIBUTE_NORMAL; ASender.Reply.Text.Add(RSFTPSiteATTRIBMsg+' : +FILE_ATTRIBUTE_NORMAL'); {Do not localize} end; ASender.Reply.Text.Add(RSFTPSiteATTRIBMsg + IndyFormat(RSFTPSiteATTRIBDone, [IntToStr(Length(LAttrs)-1)])); LFileName := DoProcessPath(LContext, LFileName); DoOnSetATTRIB(LContext, LAttrVal, LFileName, LPermitted); end else begin ASender.Reply.SetReply(550,RSFTPSiteATTRIBInvalid); Exit; end; if not LPermitted then begin ASender.Reply.SetReply(553, RSFTPPermissionDenied); end; end else begin ASender.Reply.SetReply(550,RSFTPSiteATTRIBInvalid); Exit; end; end else begin ASender.Reply.Assign(FReplyUnknownSITECommand); end; end; end; procedure TIdFTPServer.CommandSiteUTIME(ASender: TIdCommand); procedure TryNewFTPSyntax(AContext: TIdFTPServerContext; ALSender: TIdCommand); var LgMTime : TDateTime; LgPermitted : Boolean; LFileName : String; LDummy1, LDummy2 : TDateTime; begin //this is for gFTP Syntax //such as: "SITE UTIME 20050815041129 /.bashrc" LgPermitted := True; if ALSender.Params.Count = 0 then begin CmdSyntaxError(ALSender); Exit; end; if IsValidTimeStamp(ALSender.Params[0]) then begin LFileName := ALSender.UnparsedParams; //This is local Time LgMTime := FTPMLSToGMTDateTime(Fetch(LFileName)) - OffsetFromUTC; LFileName := DoProcessPath(AContext, LFileName); if Assigned(FOnSiteUTIME) then begin //indicate that both creation time and last access time should not be set LDummy1 := 0; LDummy2 := 0; FOnSiteUTIME(AContext, LFileName, LDummy1, LgMTime, LDummy2, LgPermitted); end else if Assigned(FOnSetModifiedTime) then begin FOnSetModifiedTime(AContext, LFileName, LgMTime); end; if LgPermitted then begin ALSender.Reply.SetReply(200, RSFTPCHMODSuccessful); end else begin ALSender.Reply.SetReply(553, RSFTPPermissionDenied); end; end else begin CmdSyntaxError(ALSender); end; end; var LContext : TIdFTPServerContext; LPermitted : Boolean; LFileName : String; LIdx : Integer; LDateCount : Integer; LAccessTime, LModTime, LCreateTime : TDateTime; i : Integer; begin { This is used by NcFTP like this: SITE UTIME test.txt 20050731224504 20050731041205 20050731035940 UTC where the first date is the "Last Access Time" the second date is the "Last Modified Time" and the final date is the "Creation File Time" I think the third parameter is optional. The final parameter is "UTC" gFTP does something different. It does something like: SITE UTIME 20050815041129 /.bashrc where the timestamp is probably in based on the local time. } LPermitted := True; LAccessTime := 0; LModTime := 0; LCreateTime := 0; LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin if Assigned(OnSiteUTIME) or Assigned(OnSetModifiedTime) or Assigned(OnSetCreationTime) then begin LDateCount := 0; LIdx := ASender.Params.Count - 1; if ASender.Params.Count > 2 then begin LPermitted := True; if TextIsSame(ASender.Params[LIdx], 'UTC') then begin //figure out how many dates we have and where the end of the filename is Dec(LIdx); Inc(LDateCount); if IsValidTimeStamp(ASender.Params[LIdx]) then begin Dec(LIdx); Inc(LDateCount); if IsValidTimeStamp(ASender.Params[LIdx]) then begin Dec(LIdx); Inc(LDateCount); end; end else begin TryNewFTPSyntax(LContext, ASender); Exit; end; //now extract the date LAccessTime := FTPMLSToGMTDateTime(ASender.Params[LIdx]); if LDateCount > 1 then begin LModTime := FTPMLSToGMTDateTime(ASender.Params[LIdx+1]); end; if LDateCount > 2 then begin LCreateTime := FTPMLSToGMTDateTime(ASender.Params[LIdx+2]); end; //extract filename including any spaces LFileName := ''; for i := 0 to LIdx-1 do begin LFileName := LFileName + ' ' + ASender.Params[i]; end; IdDelete(LFileName,1,1); LFileName := DoProcessPath(LContext,LFileName); //now do it if Assigned(FOnSiteUTIME) then begin FOnSiteUTIME(LContext, LFileName, LAccessTime, LModTime, LCreateTime, LPermitted); end else begin if (LModTime <> 0) and Assigned(FOnSetModifiedTime) then begin FOnSetModifiedTime(LContext, LFileName, LModTime); end; if (LCreateTime <> 0) and Assigned(FOnSetCreationTime) then begin FOnSetCreationTime(LContext, LFileName, LCreateTime); end; end; if LPermitted then begin ASender.Reply.SetReply(200, RSFTPCHMODSuccessful); end else begin ASender.Reply.SetReply(553, RSFTPPermissionDenied); end; Exit; end; end; end; TryNewFTPSyntax(LContext, ASender); // CmdNotImplemented(ASender); end; end; procedure TIdFTPServer.DoOnSiteCHGRP(ASender: TIdFTPServerContext; var AGroup: String; const AFileName: String; var VAUth: Boolean); begin if Assigned(FOnSiteCHGRP) then begin FOnSiteCHGRP(ASender, AGroup, AFileName, VAuth); end; end; procedure TIdFTPServer.DoOnSiteCHOWN(ASender: TIdFTPServerContext; var AOwner, AGroup: String; const AFileName: String; var VAUth: Boolean); begin if Assigned(FOnSiteCHOWN) then begin OnSiteCHOWN(ASender, AOwner, AGroup, AFileName, VAuth); end; end; procedure TIdFTPServer.CommandSiteCHOWN(ASender: TIdCommand); var LContext : TIdFTPServerContext; LPermitted : Boolean; LFileName : String; LOwner, LGroup : string; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin if Assigned(OnSiteCHOWN) then begin LPermitted := True; LFileName := ASender.UnparsedParams; LGroup := Fetch(LFileName); LOwner := Fetch(LGroup,':'); DoOnSiteCHOWN(LContext, LOwner, LGroup, DoProcessPath(LContext, LFileName), LPermitted); if LPermitted then begin ASender.Reply.SetReply(220, IndyFormat(RSFTPCmdSuccessful, [ASender.RawLine])); end else begin ASender.Reply.SetReply(553, RSFTPPermissionDenied); end; end; end; end; procedure TIdFTPServer.CommandSiteCHGRP(ASender: TIdCommand); var LContext : TIdFTPServerContext; LPermitted : Boolean; LFileName : String; LGroup : String; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin if Assigned(FOnSiteCHGRP) then begin LPermitted := True; LFileName := ASender.UnparsedParams; LGroup := Fetch(LFileName); DoOnSiteCHGRP(LContext, LGroup, DoProcessPath(LContext, LFileName), LPermitted); if LPermitted then begin ASender.Reply.SetReply(200, IndyFormat(RSFTPCmdSuccessful, [ASender.RawLine])); end else begin ASender.Reply.SetReply(553, RSFTPPermissionDenied); end; end; end; end; procedure TIdFTPServer.CommandSiteCHMOD(ASender: TIdCommand); var LContext : TIdFTPServerContext; LPermitted : Boolean; LFileName : String; LPerms : String; LPermNo : Integer; // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin LFileSystem := FTPFileSystem; if Assigned(OnSiteCHMOD ) or Assigned(LFileSystem) then begin LFileName := ASender.UnparsedParams; LPerms := Fetch(LFileName); If IsValidPermNumbers(LPerms) then begin LPermitted := True; LPermNo := IndyStrToInt(LPerms, 0); DoOnSiteCHMOD(LContext, LPermNo, DoProcessPath(LContext, LFileName), LPermitted); if LPermitted then begin ASender.Reply.SetReply(220, RSFTPCHMODSuccessful); end else begin ASender.Reply.SetReply(553, RSFTPPermissionDenied); end; end else begin CmdNotImplemented(ASender); end; end else begin ASender.Reply.Assign(FReplyUnknownSITECommand); end; end; end; procedure TIdFTPServer.CommandSiteUMASK(ASender: TIdCommand); var LContext : TIdFTPServerContext; LNewMask : Integer; LPermitted : Boolean; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin if Assigned(FOnSiteUMASK) then begin if ASender.Params.Count > 0 then begin If IsValidPermNumbers(ASender.Params[0]) then begin LPermitted := True; LNewMask := IndyStrToInt(ASender.Params[0], 0); DoOnSiteUMASK(LContext, LNewMask, LPermitted); if LPermitted then begin ASender.Reply.SetReply(200, IndyFormat(RSFTPUMaskSet, [LNewMask, LContext.FUMask])); LContext.FUMask := LNewMask; end else begin ASender.Reply.SetReply(553, RSFTPPermissionDenied); end; end else begin CmdNotImplemented(ASender); end; end else begin ASender.Reply.SetReply(200, IndyFormat(RSFTPUMaskIs, [LContext.FUMask])); end; end else begin CmdNotImplemented(ASender); end; end; end; function TIdFTPServer.IsValidPermNumbers(const APermNos: String): Boolean; const PERMDIGITS = '01234567'; var i: Integer; begin Result := False; for i := 1 to Length(APermNos) do begin if not CharIsInSet(APermNos, i, PERMDIGITS) then begin Exit; end; end; Result := True; end; procedure TIdFTPServer.DoOnSiteUMASK(ASender: TIdFTPServerContext; var VUMASK: Integer; var VAUth: Boolean); begin if Assigned(FOnSiteUMASK) then begin FOnSiteUMASK(ASender,VUMASK,VAUth); end; end; procedure TIdFTPServer.DoOnSetATTRIB(ASender: TIdFTPServerContext; var VAttr : UInt32; const AFileName : String; var VAUth : Boolean); begin if Assigned( FOnSetATTRIB) then begin FOnSetATTRIB(ASender, VAttr, AFileName, VAUth); end; end; procedure TIdFTPServer.DoOnSiteCHMOD(ASender: TIdFTPServerContext; var APermissions: Integer; const AFileName: String; var VAUth: Boolean); begin if Assigned(FOnSiteCHMOD) then begin FOnSiteCHMOD(ASender,APermissions,AFileName,VAUth); end; end; procedure TIdFTPServer.CommandSiteDIRSTYLE(ASender: TIdCommand); //FMSDOSMode var LContext : TIdFTPServerContext; //SITE DIRSTYLE is only for MS-DOS formatted directory lists so //a program can flip to Unix directory list format. This is //for compatability purposes, ONLY. begin LContext := ASender.Context as TIdFTPServerContext; if (FDirFormat = ftpdfDOS) or ((FDirFormat = ftpdfOSDependent) and (GOSType = otWindows)) then begin if LContext.IsAuthenticated(ASender) then begin if ASender.Params.Count = 0 then begin LContext.FMSDOSMode := not LContext.FMSDOSMode; if LContext.FMSDOSMode then begin ASender.Reply.SetReply(200, IndyFormat(RSFTPDirStyle, [RSFTPOn])); end else begin ASender.Reply.SetReply(200, IndyFormat(RSFTPDirStyle, [RSFTPOff])); end; end; end; end else begin ASender.Reply.Assign(FReplyUnknownSITECommand); end; end; procedure TIdFTPServer.CommandSiteHELP(ASender: TIdCommand); var s : String; LCmds : TStringList; LContext : TIdFTPServerContext; begin LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin s := RSFTPSITECmdsSupported+EOL; LCmds := TStringList.Create; try if Assigned(OnSetAttrib) then begin LCmds.Add('ATTRIB'); {Do not translate} end; if Assigned(OnSiteCHMOD) then begin LCmds.Add('CHMOD'); {Do not translate} end; if (FDirFormat = ftpdfDOS) or ((FDirFormat = ftpdfOSDependent) and (GOSType = otWindows)) then begin LCmds.Add('DIRSTYLE'); {Do not translate} end; if Assigned(OnSiteUMASK) then begin LCmds.Add('UMASK'); {Do not translate} end; LCmds.Add('ZONE'); {Do not translate} s := s + HelpText(LCmds) + FEndOfHelpLine; ASender.Reply.SetReply(214, s); finally FreeAndNil(LCmds); end; end; end; function TIdFTPServer.HelpText(Cmds: TStrings): String; var LRows : Integer; LMod : Integer; i : Integer; begin Result := ''; if Cmds.Count =0 then begin Exit; end; LRows := Cmds.Count div 6; LMod := Cmds.Count mod 6; if Cmds.Count < 6 then begin Result := ' '; for i := 0 to Cmds.Count -1 do begin Result := Result + IndyFormat('%-10s', [Cmds[i]]); end; Result := Result + CR; end else begin for i := 0 to (LRows -1) do begin if (i <= LMod-1) and (LMod<>0) then begin Result := Result + IndyFormat(' %-10s%-10s%-10s%-10s%-10s%-10s%-10s', {Do not translate} [ Cmds[i],Cmds[i+LRows],Cmds[(LRows*2)+i], Cmds[(LRows*3)+i],Cmds[(LRows*4)+i],Cmds[(LRows*5)+i], Cmds[(LRows*6)+i]])+CR; end else begin Result := Result + IndyFormat(' %-10s%-10s%-10s%-10s%-10s%-10s', {Do not translate} [ Cmds[i],Cmds[i+LRows],Cmds[(LRows*2)+i], Cmds[(LRows*3)+i],Cmds[(LRows*4)+i],Cmds[(LRows*5)+i]])+CR; end; end; end; end; procedure TIdFTPServer.CommandSITE(ASender: TIdCommand); var LCmd : String; begin LCmd := ASender.UnparsedParams; ASender.Reply.Clear; ASender.PerformReply := False; if not FSITECommands.HandleCommand(ASender.Context, LCmd) then begin ASender.Reply.NumericCode := 500; CmdSyntaxError(ASender.Context, ASender.CommandHandler.Command + ' ' + LCmd, ASender.Reply); ASender.PerformReply := False; end; end; function TIdFTPServer.MLSFEATLine(const AFactMask: TIdMLSDAttrs; const AFacts: TIdFTPFactOutputs): String; begin Result := 'MLST size'; {Do not translate} //the * indicates if the option is selected for MLST if Size in AFacts then begin {Do not translate} Result := Result + '*;'; end else begin Result := Result + ';' end; Result := Result + 'Type'; {Do not translate} if ItemType in AFacts then begin {Do not translate} Result := Result + '*;'; {Do not translate} end else begin Result := Result + ';'; end; if mlsdPerms in FMLSDFacts then begin Result := Result + 'Perm'; {Do not translate} if Perm in AFacts then begin {Do not translate} Result := Result + '*;'; {Do not translate} end else begin Result := Result + ';'; end; end; if mlsdFileCreationTime in FMLSDFacts then begin Result := Result + 'Create'; {Do not translate} if CreateTime in AFacts then begin {Do not translate} Result := Result + '*;'; {Do not translate} end else begin Result := Result + ';'; end; end; Result := Result + 'Modify'; {Do not translate} if Modify in AFacts then begin Result := Result + '*;'; end else begin Result := Result + ';'; end; if mlsdUnixModes in FMLSDFacts then begin Result := Result + 'UNIX.mode'; {Do not translate} if UnixMODE in AFacts then begin {Do not translate} Result := Result + '*;'; {Do not translate} end else begin Result := Result + ';'; end; end; if mlsdUnixOwner in FMLSDFacts then begin Result := Result + 'UNIX.owner'; {Do not translate} if UnixOwner in AFacts then begin {Do not translate} Result := Result + '*;'; {Do not translate} end else begin Result := Result + ';'; end; end; if mlsdUnixGroup in FMLSDFacts then begin Result := Result + 'UNIX.group'; {Do not translate} if UnixGroup in AFacts then begin {Do not translate} Result := Result + '*;'; {Do not translate} end else begin Result := Result + ';'; end; end; if mlsdUniqueID in FMLSDFacts then begin Result := Result + 'Unique'; {Do not translate} if Unique in AFacts then begin {Do not translate} Result := Result + '*;'; {Do not translate} end else begin Result := Result + ';'; end; end; if mlsdFileLastAccessTime in FMLSDFacts then begin Result := Result + 'Windows.lastaccesstime'; {Do not translate} if CreateTime in AFacts then begin {Do not translate} Result := Result + '*;'; {Do not translate} end else begin Result := Result + ';'; end; end; if mlsdWin32Attributes in FMLSDFacts then begin Result := Result + 'Win32.ea'; {Do not translate} if WinAttribs in AFacts then begin {Do not translate} Result := Result + '*;'; {Do not translate} end else begin Result := Result + ';'; end; end; if mlsdWin32DriveType in FMLSDFacts then begin Result := Result + 'Win32.dt'; if WinDriveType in AFacts then begin Result := Result + '*;'; {Do not localize} end else begin Result := Result + ';'; {Do not localize} end; end; if mlstWin32DriveLabel in FMLSDFacts then begin Result := Result + 'Win32.dl'; if WinDriveLabel in AFacts then begin Result := Result + '*;'; {Do not localize} end else begin Result := Result + ';'; {Do not localize} end; end; if Length(Result)>0 then begin IdDelete(Result,Length(Result),1); end; end; procedure TIdFTPServer.CommandCLNT(ASender: TIdCommand); begin if Assigned(FOnClientID) then begin FOnClientID(ASender.Context as TIdFTPServerContext, ASender.UnparsedParams); end; end; procedure TIdFTPServer.SetPASVBoundPortMax(const AValue: TIdPort); begin if FPASVBoundPortMin <> 0 then begin if AValue <= FPASVBoundPortMin then begin raise EIdFTPBoundPortMaxGreater.Create(RSFTPPASVBoundPortMaxMustBeGreater); end; end; FPASVBoundPortMax := AValue; end; procedure TIdFTPServer.SetPASVBoundPortMin(const AValue: TIdPort); begin if FPASVBoundPortMax <> 0 then begin if FPASVBoundPortMax <= AValue then begin raise EIdFTPBoundPortMinLess.Create(RSFTPPASVBoundPortMinMustBeLess); end; end; FPASVBoundPortMin := AValue; end; procedure TIdFTPServer.DoOnDataPortAfterBind(ASender: TIdFTPServerContext); begin if Assigned(FOnDataPortAfterBind) then begin FOnDataPortAfterBind(ASender); end; end; procedure TIdFTPServer.DoOnDataPortBeforeBind(ASender: TIdFTPServerContext); begin if Assigned(FOnDataPortBeforeBind) then begin FOnDataPortBeforeBind(ASender); end; end; function TIdFTPServer.FTPNormalizePath(const APath: String): String; { Microsoft IIS accepts both a "/" and a "\" as path/file name separators. We have to flatten this out so that our FTP server can behave like Microsoft IIS. In Unix, a "\" is a valid filename character so we don't anything there. This WILL cause a "\" to be treated differently in Unix and Win32. I submit that this is really desirable as both file systems are like apples and oranges. } begin case FPathProcessing of ftppDOS : Result := ReplaceAll(APath, '\', '/'); ftpOSDependent : begin if GOSType = otWindows then begin Result := ReplaceAll(APath, '\', '/'); end else begin Result := APath; end; end; else Result := APath; end; end; function TIdFTPServer.DoProcessPath(ASender: TIdFTPServerContext; const APath: TIdFTPFileName): TIdFTPFileName; begin if FPathProcessing <> ftppCustom then begin Result := FTPNormalizePath(APath); Result := ProcessPath(ASender.CurrentDir, Result); {Do not Localize} end else begin Result := APath; if Assigned(FOnCustomPathProcess) then begin FOnCustomPathProcess(ASender, Result); end; end; end; function TIdFTPServer.CDUPDir(AContext : TIdFTPServerContext) : String; const LCDUP_DOS = '..\'; CDUP_UNIX = '../'; begin case FPathProcessing of ftppDOS : Result := LCDUP_DOS; ftpOSDependent : if GOSType = otWindows then begin Result := LCDUP_DOS; end else begin Result := CDUP_UNIX; end; ftppCustom : Result := DoProcessPath(AContext, '..'); else Result := CDUP_UNIX; end; end; function TIdFTPServer.DoSysType(ASender: TIdFTPServerContext): String; begin //We tie the SYST descriptor to the directory style for compatability //reasons. Some FTP clients use the SYST descriptor to determine what //type of FTP directory list parsing to do. I think TurboPower IPros does this. //Note that I personally do not find this to be sound as a general rule. case FDirFormat of ftpdfOSDependent : begin if GOSType = otWindows then begin Result := SYST_ID_NT; end else begin Result := SYST_ID_UNIX; end; end; ftpdfUnix, ftpdfEPLF : Result := SYST_ID_UNIX; ftpdfDOS : Result := SYST_ID_NT; ftpdfCustom : Result := FCustomSystID; end; end; procedure TIdFTPServer.DoOnCustomListDirectory( ASender: TIdFTPServerContext; const APath: string; ADirectoryListing: TStrings; const ACmd, ASwitches: String); begin if Assigned(OnCustomListDirectory) then begin OnCustomListDirectory(ASender,APath,ADirectoryListing,ACmd,ASwitches); end; end; procedure TIdFTPServer.CmdNotImplemented(ASender: TIdCommand); begin ASender.Reply.SetReply(550, IndyFormat(RSFTPCmdNotImplemented, [ASender.CommandHandler.Command ])); end; procedure TIdFTPServer.CmdFileActionAborted(ASender: TIdCommand); begin ASender.Reply.SetReply(550, RSFTPFileActionAborted); end; //This is for where the client didn't provide a valid number of parameters for a command procedure TIdFTPServer.CmdInvalidParamNum(ASender: TIdCommand); begin ASender.Reply.SetReply(501, IndyFormat(RSFTPInvalidNumberArgs, [ASender.CommandHandler.Command])); end; //This is for other command syntax issues. procedure TIdFTPServer.CmdInvalidParams(ASender: TIdCommand); begin ASender.Reply.SetReply(501, IndyFormat(RSFTPParamError, [ASender.CommandHandler.Command])); end; procedure TIdFTPServer.CmdTwineFileActionAborted(ASender: TIdCommand); begin ASender.Reply.SetReply(504, RSFTPFileActionAborted); end; procedure TIdFTPServer.CmdCommandSuccessful(ASender: TIdCOmmand; const AReplyCode : Integer = 250); begin ASender.Reply.SetReply(AReplyCode, IndyFormat(RSFTPCmdSuccessful, [ASender.CommandHandler.Command])); end; procedure TIdFTPServer.CommandSSCN(ASender: TIdCommand); const REPLY_SSCN_ON = 'SSCN:CLIENT METHOD'; {do not localize} REPLY_SSCN_OFF = 'SSCN:SERVER METHOD'; {do not localize} var LContext : TIdFTPServerContext; begin if UseTLS = utNoTLSSupport then begin CmdNotImplemented(ASender); Exit; end; LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin if ASender.Params.Count = 0 then begin //check state if LContext.SSCNOn then begin ASender.Reply.SetReply(200, REPLY_SSCN_ON); end else begin ASender.Reply.SetReply(200, REPLY_SSCN_OFF); end; end else begin //set state case PosInStrArray(ASender.Params[0], OnOffStates, False) of 0 : //'ON' begin LContext.SSCNOn := True; ASender.Reply.SetReply(200, REPLY_SSCN_ON); end; 1 : //'OFF' begin LContext.SSCNOn := False; ASender.Reply.SetReply(200, REPLY_SSCN_OFF); end; else ASender.Reply.SetReply(504, RSFTPInvalidForParam); end; end; end; end; procedure TIdFTPServer.CommandCPSV(ASender: TIdCommand); var LContext : TIdFTPServerContext; LIO : TIdSSLIOHandlerSocketBase; begin //CPSV must be used with SSL and can only be used with IPv4 if (UseTLS = utNoTLSSupport) or (ASender.Context.Binding.IPVersion <> Id_IPv4) then begin CmdSyntaxError(ASender); Exit; end; CommandPASV(ASender); LContext := TIdFTPServerContext(ASender.Context); LIO := LContext.DataChannel.FDataChannel.IOHandler as TIdSSLIOHandlerSocketBase; //tell IOHandler to use ssl_Conntect LIO.IsPeer := False; end; procedure TIdFTPServer.CommandSiteZONE(ASender: TIdCommand); var LMin : Integer; begin LMin := MinutesFromGMT; //plus must always be displayed for positive numbers if LMin < 0 then begin ASender.Reply.SetReply(210, IndyFormat('UTC%d', [MinutesFromGMT])); {do not localize} end else begin ASender.Reply.SetReply(210, IndyFormat('UTC+%d', [MinutesFromGMT])); {do not localize} end; end; procedure TIdFTPServer.CommandCheckSum(ASender: TIdCommand); const HashTypes: array[0..4] of TIdHashClass = (TIdHashCRC32, TIdHashMessageDigest5, TIdHashSHA1, TIdHashSHA256, TIdHashSHA512); var LCalcStream : TStream; LFileName, LCheckSum, LBuf : String; LBeginPos, LEndPos : TIdStreamSize; LContext : TIdFTPServerContext; LHashIdx: Integer; // under ARC, convert a weak reference to a strong reference before working with it LFileSystem: TIdFTPBaseFileSystem; begin if GetFIPSMode and (PosInStrArray(ASender.CommandHandler.Command, ['XCRC', 'XMD5']) > -1) then begin CmdSyntaxError(ASender); Exit; end; LFileSystem := FTPFileSystem; if Assigned(FOnCRCFile) or Assigned(LFileSystem) then begin LContext := TIdFTPServerContext(ASender.Context); if LContext.IsAuthenticated(ASender) then begin LBuf := ASender.UnparsedParams; if Pos('"', LBuf) > 0 then begin {do not localize} Fetch(LBuf, '"'); {do not localize} LFileName := Fetch(LBuf, '"'); {do not localize} end else begin LFileName := Fetch(LBuf); end; if LFileName = '' then begin CmdInvalidParamNum(ASender); Exit; end; LBuf := Trim(LBuf); if LBuf <> '' then begin LBeginPos := IndyStrToStreamSize(Fetch(LBuf), -1); if LBeginPos < 0 then begin CmdInvalidParams(ASender); Exit; end; LBuf := Trim(LBuf); if LBuf <> '' then begin LEndPos := IndyStrToStreamSize(Fetch(LBuf), -1); if LEndPos < 0 then begin CmdInvalidParams(ASender); Exit; end; end else begin LEndPos := -1; end; end else begin LBeginPos := 0; LEndPos := -1; end; LCalcStream := nil; LFileName := DoProcessPath(LContext, LFileName); DoOnCRCFile(LContext, LFileName, LCalcStream); if Assigned(LCalcStream) then begin if LEndPos = -1 then begin LEndPos := LCalcStream.Size; end; try LCalcStream.Position := 0; LHashIdx := PosInStrArray(ASender.CommandHandler.Command, ['XCRC', 'XMD5', 'XSHA1','XSHA256','XSHA512'], False); {do not localize} LCheckSum := CalculateCheckSum(HashTypes[LHashIdx], LCalcStream, LBeginPos, LEndPos); ASender.Reply.SetReply(250, LCheckSum); finally FreeAndNil(LCalcStream); end; end else begin CmdFileActionAborted(ASender); end; end; end else begin CmdSyntaxError(ASender); end; end; procedure TIdFTPServer.DoOnFileExistCheck(AContext: TIdFTPServerContext; const AFileName: String; var VExist: Boolean); begin if Assigned(FOnFileExistCheck) then begin FOnFileExistCheck(AContext, AFileName, VExist); end; end; procedure TIdFTPServer.CommandSPSV(ASender: TIdCommand); var LIP : String; LBPort : Word; LIPVer : TIdIPVersion; begin //just to keep the compiler happy LBPort := 0; if InternalPASV(ASender, LIP, LBPort, LIPVer) then begin ASender.Reply.SetReply(227, IntToStr(LBPort)); end; end; function TIdFTPServer.InternalPASV(ASender: TIdCommand; var VIP : String; var VPort: TIdPort; var VIPVersion : TIdIPVersion): Boolean; var LContext : TIdFTPServerContext; LBPortMin, LBPortMax: TIdPort; LDataChannel: TIdSimpleServer; begin Result := False; LContext := ASender.Context as TIdFTPServerContext; if LContext.IsAuthenticated(ASender) then begin if LContext.FEPSVAll then begin ASender.Reply.SetReply(501, IndyFormat(RSFTPNotAllowedAfterEPSVAll, [ASender.CommandHandler.Command])); Exit; end; VIP := LContext.Connection.Socket.Binding.IP; VIPVersion := LContext.Binding.IPVersion; if (FPASVBoundPortMin <> 0) and (FPASVBoundPortMax <> 0) then begin LBPortMin := FPASVBoundPortMin; LBPortMax := FPASVBoundPortMax; end else begin LBPortMin := FDefaultDataPort; LBPortMax := LBPortMin; end; DoOnPASVBeforeBind(LContext, VIP, LBPortMin, LBPortMax, VIPVersion); LContext.CreateDataChannel(True); LDataChannel := TIdSimpleServer(LContext.FDataChannel.FDataChannel); LDataChannel.BoundIP := VIP; if LBPortMin = LBPortMax then begin LDataChannel.BoundPort := LBPortMin; LDataChannel.BoundPortMin := 0; LDataChannel.BoundPortMax := 0; end else begin LDataChannel.BoundPort := 0; LDataChannel.BoundPortMin := LBPortMin; LDataChannel.BoundPortMax := LBPortMax; end; LDataChannel.IPVersion := VIPVersion; LDataChannel.BeginListen; VIP := LDataChannel.Binding.IP; VPort := LDataChannel.Binding.Port; LContext.FPASV := True; LContext.FDataPortDenied := False; Result := True; end; end; procedure TIdFTPServer.DoOnPASVBeforeBind(ASender: TIdFTPServerContext; var VIP: String; var VPortMin, VPortMax: TIdPort; const AIPVersion: TIdIPVersion); begin if Assigned(FOnPASVBeforeBind) then begin FOnPASVBeforeBind(ASender, VIP, VPortMin, VPortMax, AIPVersion); end; end; procedure TIdFTPServer.DoOnPASVReply(ASender: TIdFTPServerContext; var VIP: String; var VPort: TIdPort; const AIPVersion: TIdIPVersion); begin if Assigned(FOnPASVReply) then begin FOnPASVReply(ASender, VIP, VPort, AIPVersion); end; end; function TIdFTPServer.ReadCommandLine(AContext: TIdContext): string; var i : Integer; State: TIdFTPTelnetState; lb : Byte; LContext: TIdFTPServerContext; { Receive the line in 8-bit initially so that .NET can then decode any UTF-8 data into a Unicode string afterwards if needed } LLine: TIdBytes; LReply: TIdBytes; Finished: Boolean; begin Result := ''; LContext := AContext as TIdFTPServerContext; //we do it this way in case there's no data. We don't want to stop //a data channel operation if that's the case. AContext.Connection.IOHandler.CheckForDataOnSource(1); if AContext.Connection.IOHandler.InputBufferIsEmpty then begin Exit; end; // SetLength(LLine, 0); SetLength(LReply, 0); Finished := False; State := tsData; repeat lb := AContext.Connection.IOHandler.ReadByte; case State of tsData: begin case lb of $FF: //is a command begin State := tsIAC; end; $0D: //wait for the next character to see what to do begin State := tsCheckCR; end; else AppendByte(LLine, lb); end; end; tsCheckCR: begin case lb of $0: // preserve CR begin AppendByte(LLine, $0D); State := tsData; end; $0A: begin State := tsData; Finished := True; end; $FF: //unexpected IAC, just in case begin AppendByte(LLine, $0D); State := tsIAC; end; else ExpandBytes(LLine, Length(LLine), 2); LLine[Length(LLine)-2] := $0D; LLine[Length(LLine)-1] := lb; State := tsData; end; end; tsIAC: begin case lb of $F1, //no-operation - do nothing $F3: //break - do nothing for now begin State := tsData; end; $F4: //interrupt process - clear result and wait for data mark begin SetLength(LLine, 0); State := tsInterrupt; end; $F5: //abort output begin // note - the DM needs to be sent as OOB "Urgent" data SetLength(LReply, 4); // TELNET_IP LReply[0] := $FF; LReply[1] := $F4; // TELNET_DM LReply[2] := $FF; LReply[3] := $F2; AContext.Connection.IOHandler.Write(LReply); SetLength(LReply, 0); State := tsData; end; $F6: //are you there - do nothing for now begin State := tsData; end; $F7: //erase character begin i := Length(LLine); if i > 0 then begin SetLength(LLine, i-1); end; State := tsData; end; $F8 : //erase line begin SetLength(LLine, 0); State := tsData; end; $F9 : //go ahead - do nothing for now begin State := tsData; end; $FA : //begin sub-negotiation begin State := tsNegotiate; end; $FB : //I will use begin State := tsWill; end; $FC : //you won't use begin State := tsWont; end; $FD : //please, you use option begin State := tsDo; end; $FE : //please, you stop option begin State := tsDont; end; $FF : //data $FF begin AppendByte(LLine, $FF); State := tsData; end; else // unknown command, ignore State := tsData; end; end; tsWill: begin SetLength(LReply, 3); // TELNET_WONT LReply[0] := $FF; LReply[1] := $FC; LReply[2] := lb; AContext.Connection.IOHandler.Write(LReply); SetLength(LReply, 0); State := tsData; end; tsDo: begin SetLength(LReply, 3); // TELNET_DONT LReply[0] := $FF; LReply[1] := $FE; LReply[2] := lb; AContext.Connection.IOHandler.Write(LReply); SetLength(LReply, 0); State := tsData; end; tsWont, tsDont: begin State := tsData; end; tsNegotiate: begin State := tsNegotiateData; end; tsNegotiateData: begin case lb of $FF: //is a command? begin State := tsNegotiateIAC; end; end; end; tsNegotiateIAC: begin case lb of $F0: //end sub-negotiation begin State := tsData; end; else State := tsNegotiateData; end; end; tsInterrupt: begin case lb of $FF: //is a command? begin State := tsInterruptIAC; end; end; end; tsInterruptIAC: begin case lb of $F2: //data mark begin State := tsData; end; end; end; else State := tsData; end; until Finished or (not AContext.Connection.IOHandler.Connected); //The last char was #13, we have to make sure that we remove a trailing //#10 if it exists so that it doesn't appear in the next line. if (lb = $0D) and (State = tsData) then begin i := AContext.Connection.IOHandler.InputBuffer.Size; if i > 0 then begin lb := AContext.Connection.IOHandler.InputBuffer.PeekByte(i - 1); if lb = $0A then begin AContext.Connection.IOHandler.ReadByte; end; end; end; Result := BytesToString(LLine, 0, MaxInt, LContext.Connection.IOHandler.DefStringEncoding); end; procedure TIdFTPServer.DoReplyUnknownCommand(AContext: TIdContext; ALine: string); begin CmdSyntaxError(AContext, ALine); end; procedure TIdFTPServer.DoTerminateContext(AContext: TIdContext); begin try TIdFTPServerContext(AContext).KillDataChannel; finally inherited DoTerminateContext(AContext); end; end; procedure TIdFTPServer.CmdSyntaxError(AContext: TIdContext; ALine: string; const AReply : TIdReply = nil); var LTmp : String; LReply : TIdReply; begin //First make the first word upper-case LTmp := UpCaseFirstWord(ALine); try if Assigned(AReply) then begin LReply := AReply; end else begin LReply := FReplyClass.CreateWithReplyTexts(nil, ReplyTexts); LReply.Assign(ReplyUnknownCommand); end; LReply.Text.Clear; LReply.Text.Add(IndyFormat(RSFTPCmdNotRecognized, [LTmp])); AContext.Connection.IOHandler.Write(LReply.FormattedReply); finally if not Assigned(AReply) then begin FreeAndNil(LReply); end; end; end; procedure TIdFTPServer.CmdSyntaxError(ASender: TIdCommand); begin CmdSyntaxError(ASender.Context, ASender.RawLine, FReplyUnknownCommand ); ASender.PerformReply := False; end; procedure TIdFTPServer.CommandSecRFC(ASender: TIdCommand); //stub for RFC 2228 commands that we don't implement as //part of the SSL framework. begin if IOHandler is TIdServerIOHandlerSSLBase then begin CmdNotImplemented(ASender); end else begin CmdSyntaxError(ASender); end; end; procedure TIdFTPServer.CommandOptsMLST(ASender: TIdCommand); const LVALIDOPTS : array [0..12] of string = ('type', 'size', 'modify', 'UNIX.mode', 'UNIX.owner', 'UNIX.group', 'unique', 'perm', 'create', 'windows.lastaccesstime','win32.ea','win32.dt','win32.dl'); {Do not localize} var s: string; LContext : TIdFTPServerContext; function ParseMLSParms(ASvr : TIdFTPServer; const AParms : String) : TIdFTPFactOutputs; var Ls : String; begin Result := []; Ls := UpperCase(AParms); while Ls <> '' do begin case PosInStrArray(Fetch(Ls,';'), LVALIDOPTS, False) of 0 : Result := Result + [ItemType]; //type 1 : Result := Result + [Size]; //size 2 : Result := Result + [Modify]; //modify 3 : if mlsdUnixModes in ASvr.FMLSDFacts then begin Result := Result + [UnixMODE]; //UnixMode end; 4 : if mlsdUnixOwner in ASvr.FMLSDFacts then begin Result := Result + [UnixOwner]; //UNIX.owner end; 5 : if mlsdUnixGroup in ASvr.FMLSDFacts then begin Result := Result + [UnixGroup]; //UNIX.group end; 6 : if mlsdUniqueID in ASvr.FMLSDFacts then begin //Unique Result := Result + [Unique]; end; 7 : if mlsdPerms in ASvr.FMLSDFacts then begin //perm Result := Result + [Perm]; end; 8 : if mlsdFileCreationTime in ASvr.FMLSDFacts then begin Result := Result + [CreateTime]; end; 9 : if mlsdFileLastAccessTime in ASvr.FMLSDFacts then begin Result := Result + [LastAccessTime]; end; 10 : if mlsdWin32Attributes in ASvr.FMLSDFacts then begin Result := Result + [WinAttribs]; end; 11 : if mlsdWin32DriveType in ASvr.MLSDFacts then begin Result := Result + [WinDriveType]; end; 12 : if mlstWin32DriveLabel in ASvr.MLSDFacts then begin Result := Result + [WinDriveLabel]; end; end; end; end; function SetToOptsStr(AFacts : TIdFTPFactOutputs) : String; begin Result := ''; if Size in AFacts then begin {Do not translate} Result := Result + 'size;'; {Do not localize} end; if ItemType in AFacts then begin {Do not translate} Result := Result + 'type;'; {Do not translate} end; if Perm in AFacts then begin {Do not translate} Result := Result + 'perm;'; {Do not translate} end; if CreateTime in AFacts then begin {Do not translate} Result := Result + 'create;'; {Do not translate} end; if Modify in AFacts then begin Result := Result + 'modify;'; {Do not translate} end; if UnixMODE in AFacts then begin {Do not translate} Result := Result + 'UNIX.mode;'; {Do not translate} end; if UnixOwner in AFacts then begin{Do not translate} Result := Result + 'UNIX.owner;'; {Do not translate} end; if UnixGroup in AFacts then begin {Do not translate} Result := Result + 'UNIX.group;'; {Do not translate} end; if Unique in AFacts then begin {Do not translate} Result := Result + 'unique;'; {Do not translate} end; if LastAccessTime in AFacts then begin Result := Result + 'windows.lastaccesstime;'; {Do not translate} end; if IdFTPListOutput.WinAttribs in AFacts then begin Result := Result + 'win32.ea;'; {Do not translate} end; if IdFTPListOutput.WinDriveType in AFacts then begin Result := Result + 'Win32.dt;'; {Do not localize} end; if IdFTPListOutput.WinDriveLabel in AFacts then begin Result := Result + 'Win32.dl;'; {Do not localize} end; end; begin LContext := ASender.Context as TIdFTPServerContext; s := ASender.UnparsedParams; if IndyPos(' ', s) = 0 then begin LContext.MLSOpts := ParseMLSParms(Self, Trim(s)); //the string is standardized format ASender.Reply.SetReply(200, Trim(IndyFormat('MLST OPTS %s', [SetToOptsStr(LContext.MLSOpts)]))); {Do not Localize} end else begin ASender.Reply.SetReply(501, IndyFormat(RSFTPInvalidOps, ['MLST'])); {Do not Localize} end; end; procedure TIdFTPServer.CommandOptsMODEZ(ASender: TIdCommand); const OPT_NAMES : Array[0..4] of String = ('ENGINE','LEVEL','METHOD','BLOCKSIZE','EXTRA'); {do not localize} var s: string; LOptName, LOptVal : String; LContext : TIdFTPServerContext; LFirstPar : Boolean; LError : Boolean; LNoVal : Integer; LReset : Boolean; procedure ReportSettings(ACxt : TIdFTPServerContext; AReply : TIdReply); begin AReply.NumericCode := 200; AReply.Text.Clear; AReply.Text.Add('MODE Z ENGINE set to ZLIB.'); {do not localize} AReply.Text.Add('MODE Z LEVEL set to ' + IntToStr(ACxt.FZLibCompressionLevel) + '.'); {do not localize} AReply.Text.Add('MODE Z METHOD set to ' + IntToStr(DEF_ZLIB_METHOD) + '.'); {do not localize} end; procedure SyntaxError(AReply : TIdCommand); var LOpts : String; begin //drop the OPTS part of the command for display LOpts := ASender.RawLine; Fetch(LOpts); LOpts := TrimLeft(LOpts); ASender.Reply.SetReply(501, IndyFormat(RSFTPInvalidOps, [LOpts])); end; begin LFirstPar := True; LReset := True; LError := True; LContext := ASender.Context as TIdFTPServerContext; s := Trim(ASender.UnparsedParams); if s = '' then begin LContext.ResetZLibSettings; ReportSettings(LContext, ASender.Reply); end; repeat LOptName := Fetch(s); if s = '' then begin if LFirstPar then begin SyntaxError(ASender); Exit; end; end; LOptVal := Fetch(s); if Trim(s) <> '' then begin //if there's more, than we see if there's a valid option. LFirstPar := False; end; if LFirstPar and (PosInStrArray(LOptName, OPT_NAMES, False) = -1) then begin SyntaxError(ASender); Exit; end; LFirstPar := False; case PosInStrArray(LOptName, OPT_NAMES, False) of 0 : //'ENGINE' - we only support ZLIB begin LError := False; end; 1 : begin //,'LEVEL', - implemented LNoVal := IndyStrToInt(LOptVal, -1); if (LNoVal > -1) and (LNoVal < 8) then begin LContext.FZLibCompressionLevel := LNoVal; LReset := False; LError := False; end; end; 2 : begin //'METHOD', - not implemented - jst do syntax check LNoVal := IndyStrToInt(LOptVal, -1); if LNoVal <> -1 then begin LError := False; end; end; 3 : begin ///'BLOCKSIZE', -not implemented - just do syntax check LNoVal := IndyStrToInt(LOptVal, -1); if LNoVal <> -1 then begin LError := False; end; end; 4 : begin //'EXTRA') - not implemented - just do syntax check if PosInStrArray(LOptVal, OnOffStates, False) > -1 then begin LError := False; end; end; end; until (s = ''); if LError then begin SyntaxError(ASender); Exit; end; if LReset then begin LContext.ResetZLibSettings; end; ReportSettings(LContext, ASender.Reply); end; procedure TIdFTPServer.CommandOptsUTF8(ASender: TIdCommand); var s: String; LContext: TIdFTPServerContext; procedure SyntaxError(AReply : TIdCommand); var LOpts : String; begin //drop the OPTS part of the command for display LOpts := ASender.RawLine; Fetch(LOpts); LOpts := TrimLeft(LOpts); ASender.Reply.SetReply(501, IndyFormat(RSFTPInvalidOps, [LOpts])); end; begin LContext := ASender.Context as TIdFTPServerContext; s := Trim(ASender.UnparsedParams); if TextIsSame(ASender.CommandHandler.Command, 'UTF-8') then begin // OPTS UTF-8 // http://www.ietf.org/proceedings/02nov/I-D/draft-ietf-ftpext-utf-8-option-00.txt if s = '' then begin LContext.NLSTUtf8 := False; // disable UTF-8 over data connection end else if TextIsSame(s, 'NLST') then begin LContext.NLSTUtf8 := True; // enable UTF-8 over data connection end else begin SyntaxError(ASender); Exit; end; // enable UTF-8 over control connection LContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8; end else begin // OPTS UTF8 // non-standard Microsoft IE implementation!!!! case PosInStrArray(s, OnOffStates, False) of 0: begin // 'ON' LContext.NLSTUtf8 := True; LContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8; end; 1: begin // 'OFF' LContext.NLSTUtf8 := False; LContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_8Bit; end; else begin SyntaxError(ASender); Exit; end; end; end; ASender.Reply.NumericCode := 200; end; function TIdFTPServer.IgnoreLastPathDelim(const APath: String): String; //This internal function is needed because path processing is different in Windows //than in Linux. The path separators on a FTP server on either system will be different. // //On Windows machines, both '/' and '\' // //On a Linux machine, a FTP server would probably only use '/' because '\' is a valid //filename char. var i : Integer; LPathProcessing : TIdFTPPathProcessing; begin Result := APath; i := Length(Result); if FPathProcessing <> ftpOSDependent then begin LPathProcessing := FPathProcessing; end else begin case GOSType of otUnix : begin LPathProcessing := ftppUnix; end; otUnknown : begin LPathProcessing := ftppCustom; end else LPathProcessing := ftppDOS; end; end; case LPathProcessing of ftppDOS : begin if Result <>'' then begin if CharIsInSet(Result, i, '/\') then begin IdDelete(Result, i, 1); end; end; end; ftppUnix : begin if Result <>'' then begin if TextEndsWith(Result, '/') then begin IdDelete(Result, i, 1); end; end; end; ftppCustom : begin Exit; end; end; //Done so that something like "cd /" or "cd \" will go to //the main directory if Result = '' then begin Result := '/'; end; end; function TIdFTPServer.SupportTaDirSwitches(AContext : TIdFTPServerContext): Boolean; begin Result := True; case FDirFormat of ftpdfCustom, ftpdfEPLF: Result := False; ftpdfDOS: Result := not AContext.FMSDOSMode; ftpdfOSDependent: if (GOSType = otWindows) or (GOSType = otDotNET) then begin Result := not AContext.FMSDOSMode; end; end; end; { TIdFTPSecurityOptions } procedure TIdFTPSecurityOptions.Assign(Source: TPersistent); var LSrc : TIdFTPSecurityOptions; begin if Source is TIdFTPSecurityOptions then begin LSrc := Source as TIdFTPSecurityOptions; BlockAllPORTTransfers := LSrc.BlockAllPORTTransfers; DisableSTATCommand := LSrc.DisableSTATCommand; DisableSYSTCommand := LSrc.DisableSYSTCommand; PasswordAttempts := LSrc.PasswordAttempts; InvalidPassDelay := LSrc.InvalidPassDelay; NoReservedRangePORT := LSrc.NoReservedRangePORT; RequirePASVFromSameIP := LSrc.RequirePASVFromSameIP; RequirePORTFromSameIP := LSrc.RequirePORTFromSameIP; PermitCCC := LSrc.PermitCCC; end else begin inherited Assign(Source); end; end; constructor TIdFTPSecurityOptions.Create; begin inherited Create; //limit login attempts - some hackers will try guessing passwords from a dictionary PasswordAttempts := DEF_FTP_PASSWORDATTEMPTS; //should slow-down a password guessing attack - note those dictionaries InvalidPassDelay := DEF_FTP_INVALIDPASS_DELAY; //client IP Address is the only one that we will accept a PASV //transfer from //http://cr.yp.to/ftp/security.html RequirePASVFromSameIP := DEF_FTP_PASV_SAME_IP; //Accept port transfers from the same IP address as the client - //should prevent bounce attacks RequirePORTFromSameIP := DEF_FTP_PORT_SAME_IP; //Do not accept port requests to ports in the reserved range. That is dangerous on some systems NoReservedRangePORT := DEF_FTP_NO_RESERVED_PORTS; //Do not accept any PORT transfers at all. This is a little extreme but reduces troubles further. //This will break the the Win32 console clients and a number of other programs. BlockAllPORTTransfers := DEF_FTP_BLOCK_ALL_PORTS; //Disable SYST command. SYST usually gives the system description. //Disabling it may make it harder for a trouble maker to know about your computer //but will not be a complete security solution. See http://www.sans.org/rr/infowar/fingerprint.php for details //On the other hand, disabling it will break RFC 959 complience and may break some FTP programs. DisableSYSTCommand := DEF_FTP_DISABLE_SYST; //Disable STAT command. STAT gives freeform information about the connection status. // http://www.sans.org/rr/infowar/fingerprint.php advises administrators to disable this //because servers tend to give distinct patterns of information and some trouble makers //can figure out what type of server you are running simply with this. DisableSTATCommand := DEF_FTP_DISABLE_STAT; //Permit CCC command when using TLS with FTP to clear the control connection. //That may be helpful for someone behind a NAT where an IP address can NOT be altered by the NAT //when using SSL. On the other hand, some administrators may NOT permit this for security reasons. //That's a debate I'll leave up to the programmer in hopes that they will pass it to the user. PermitCCC := DEF_FTP_PERMIT_CCC; end; { TIdDataChannel } constructor TIdDataChannel.Create(APASV: Boolean; AControlContext: TIdFTPServerContext; const ARequirePASVFromSameIP: Boolean; AServer: TIdFTPServer); var LIO: TIdIOHandlerSocket; LDataChannelSvr: TIdSimpleServer; LDataChannelCli: TIdTCPClient; begin inherited Create; FNegotiateTLS := False; FOKReply := TIdReplyRFC.Create(nil); FErrorReply := TIdReplyRFC.Create(nil); FReply := TIdReplyRFC.Create(nil); FRequirePASVFromSameIP := ARequirePASVFromSameIP; FControlContext := AControlContext; FServer := AServer; // RLebeau: do not set both BoundPortMin/Max and BoundPort at the same time. // If they are all non-zero, BoundPort will take priority in TIdSocketHandle. // The DefaultDataPort property should not be assigned to zero in order to // support Active-mode transfers, but doing so will cause BoundPortMin/Max // to be ignored for Passive-mode transfers. So assign them in an either-or // manner. if APASV then begin FDataChannel := TIdSimpleServer.Create(nil); LDataChannelSvr := TIdSimpleServer(FDataChannel); LDataChannelSvr.BoundIP := FControlContext.Connection.Socket.Binding.IP; if (AServer.PASVBoundPortMin <> 0) and (AServer.PASVBoundPortMax <> 0) then begin LDataChannelSvr.BoundPortMin := AServer.PASVBoundPortMin; LDataChannelSvr.BoundPortMax := AServer.PASVBoundPortMax; end else begin LDataChannelSvr.BoundPort := AServer.DefaultDataPort; end; LDataChannelSvr.IPVersion := FControlContext.Binding.IPVersion; LDataChannelSvr.OnBeforeBind := AControlContext.PortOnBeforeBind; LDataChannelSvr.OnAfterBind := AControlContext.PortOnAfterBind; end else begin FDataChannel := TIdTCPClient.Create(nil); //the TCPClient for the dataport must be bound to a default port LDataChannelCli := TIdTCPClient(FDataChannel); LDataChannelCli.BoundIP := FControlContext.Connection.Socket.Binding.IP; LDataChannelCli.BoundPort := AServer.DefaultDataPort; LDataChannelCli.IPVersion := FControlContext.Binding.IPVersion; end; if AControlContext.Server.IOHandler is TIdServerIOHandlerSSLBase then begin if APASV then begin LIO := TIdServerIOHandlerSSLBase(AServer.IOHandler).MakeFTPSvrPasv; end else begin LIO := TIdServerIOHandlerSSLBase(AServer.IOHandler).MakeFTPSvrPort; end; (LIO as TIdSSLIOHandlerSocketBase).PassThrough := True; // always uses a ssl iohandler, but passthrough is true... end else begin LIO := FServer.IOHandler.MakeClientIOHandler(nil) as TIdIOHandlerSocket; end; LIO.OnBeforeBind := AControlContext.PortOnBeforeBind; LIO.OnAfterBind := AControlContext.PortOnAfterBind; FDataChannel.IOHandler := LIO; if LIO is TIdSSLIOHandlerSocketBase then begin case AControlContext.DataProtection of ftpdpsClear: begin TIdSSLIOHandlerSocketBase(LIO).PassThrough := True; end; ftpdpsPrivate: begin FNegotiateTLS := True; end; end; end; end; destructor TIdDataChannel.Destroy; begin FreeAndNil(FOKReply); FreeAndNil(FErrorReply); FreeAndNil(FReply); {$IFNDEF USE_OBJECT_ARC} FDataChannel.IOHandler.Free; {$ENDIF} FDataChannel.IOHandler := nil; FreeAndNil(FDataChannel); inherited Destroy; end; function TIdDataChannel.GetPeerIP: String; begin Result := ''; if Assigned(FDataChannel) then begin if Assigned(FDataChannel.Socket) then begin if Assigned(FDataChannel.Socket.Binding) then begin Result := FDataChannel.Socket.Binding.PeerIP; end; end; end; end; function TIdDataChannel.GetPeerPort: TIdPort; begin Result := 0; if Assigned(FDataChannel) then begin if Assigned(FDataChannel.Socket) then begin if Assigned(FDataChannel.Socket.Binding) then begin Result := FDataChannel.Socket.Binding.PeerPort; end; end; end; end; function TIdDataChannel.GetLocalIP: String; begin Result := ''; if Assigned(FDataChannel) then begin if Assigned(FDataChannel.Socket) then begin if Assigned(FDataChannel.Socket.Binding) then begin Result := FDataChannel.Socket.Binding.IP; end; end; end; end; function TIdDataChannel.GetLocalPort: TIdPort; begin Result := 0; if Assigned(FDataChannel) then begin if Assigned(FDataChannel.Socket) then begin if Assigned(FDataChannel.Socket.Binding) then begin Result := FDataChannel.Socket.Binding.Port; end; end; end; end; procedure TIdDataChannel.InitOperation(const AConnectMode : Boolean = False); var LIO : TIdSSLIOHandlerSocketBase; begin try if FDataChannel is TIdSimpleServer then begin TIdSimpleServer(FDataChannel).Listen; if FRequirePASVFromSameIP then begin {//BGO} if FControlContext.Binding.PeerIP <> TIdSimpleServer(FDataChannel).Binding.PeerIP then begin TIdFTPServerContext(FControlContext).FDataPortDenied := True; ErrorReply.SetReply(504, RSFTPSameIPAddress); FControlContext.Connection.IOHandler.Write(ErrorReply.FormattedReply); TIdSimpleServer(FDataChannel).Disconnect(False); Exit; end; end; {//BGO} if FNegotiateTLS then begin LIO := FDataChannel.IOHandler as TIdSSLIOHandlerSocketBase; if AConnectMode then begin LIO.IsPeer := False; end; LIO.Passthrough := False; end; end else if FDataChannel is TIdTCPClient then begin TIdTCPClient(FDataChannel).Connect; if FNegotiateTLS then begin LIO := FDataChannel.IOHandler as TIdSSLIOHandlerSocketBase; if AConnectMode then begin LIO.IsPeer := False; end; LIO.Passthrough := False; end; end; except FControlContext.Connection.IOHandler.Write(FErrorReply.FormattedReply); //426 raise; end; end; procedure TIdDataChannel.SetErrorReply(const AValue: TIdReplyRFC); begin FErrorReply.Assign(AValue); end; procedure TIdDataChannel.SetOKReply(const AValue: TIdReplyRFC); begin FOKReply.Assign(AValue); end; procedure TIdFTPServerContext.PortOnAfterBind(ASender: TObject); begin FServer.DoOnDataPortAfterBind(Self); end; procedure TIdFTPServerContext.PortOnBeforeBind(ASender: TObject); begin FServer.DoOnDataPortBeforeBind(Self); end; procedure TIdFTPServerContext.ResetZLibSettings; begin //Settings specified by // http://www.ietf.org/internet-drafts/draft-preston-ftpext-deflate-00.txt FZLibCompressionLevel := DEF_ZLIB_COMP_LEVEL; FZLibWindowBits := DEF_ZLIB_WINDOW_BITS; //-15 - no extra headers FZLibMemLevel := DEF_ZLIB_MEM_LEVEL; FZLibStratagy := DEF_ZLIB_STRATAGY; // - default end; end.