开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Delphi控件源码 > 查看源码
FTPSRV.PAS
资源名称：ftpsrv.zip　[点击查看]
上传用户：xdgkgcw
上传日期：2007-01-04
资源大小：92k
文件大小：95k
源码类别：

Delphi控件源码

开发平台：

WINDOWS

FTPSRV.PAS：源码内容
  1. {*_* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  3. Author:       Fran鏾is PIETTE
  4. Description:  TFtpServer class encapsulate the FTP protocol (server side)
  5.               See RFC-959 for a complete protocol description.
  6. EMail:        francois.piette@pophost.eunet.be
  7.               francois.piette@rtfm.be             http://www.rtfm.be/fpiette
  8. Creation:     April 21, 1998
  9. Version:      1.04
  10. Support:      Use the mailing list twsocket@rtfm.be See website for details.
  11. Legal issues: Copyright (C) 1997, 1998 by Fran鏾is PIETTE
  12.               Rue de Grady 24, 4053 Embourg, Belgium. Fax: +32-4-365.74.56
  13.               <francois.piette@pophost.eunet.be>
  15.               This software is provided 'as-is', without any express or
  16.               implied warranty.  In no event will the author be held liable
  17.               for any  damages arising from the use of this software.
  19.               Permission is granted to anyone to use this software for any
  20.               purpose, including commercial applications, and to alter it
  21.               and redistribute it freely, subject to the following
  22.               restrictions:
  24.               1. The origin of this software must not be misrepresented,
  25.                  you must not claim that you wrote the original software.
  26.                  If you use this software in a product, an acknowledgment
  27.                  in the product documentation would be appreciated but is
  28.                  not required.
  30.               2. Altered source versions must be plainly marked as such, and
  31.                  must not be misrepresented as being the original software.
  33.               3. This notice may not be removed or altered from any source
  34.                  distribution.
  36.               4. You must register this software by sending a picture postcard
  37.                  to the author. Use a nice stamp and mention your name, street
  38.                  address, EMail address and any comment you like to say.
  40. History:
  41. Apr 29, 1998  V0.90 released for beta testing.
  42. May 01, 1998  V0.92 Adapted for Delphi 1.0
  43. May 03, 1998  V0.93 Adapted for Delphi 2.0 and C++Builder
  44. May 04, 1998  V0.94 Use '/' or '' as path delimiter. Expose only '/' to the
  45.               outside. Stripped any telnet options (IE send two !). Handled
  46.               absolute path. Implemented SIZE and REST commands.
  47.               Added support for UNC (not finished !)
  48. May 06, 1998  V0.95 Corrected spurious 226 message on PASV mode STOR.
  49.               Made GetInteger retunrs a LongInt.
  50.               Use a LongInt for N in CommandPORT (needed for 16 bits)
  51.               Added slash substitution in BuildFilePath command.
  52. Jul 09, 1998  V1.00 Adapted for Delphi 4, removed beta status.
  53. Jul 21, 1998  V1.01 Added OnValidateDele event
  54.               Changed function to get file size (do not open the file)
  55. Feb 14, 1999  V1.02 Replaced straight winsock call by indirect calls thru
  56.               wsocket (this provide runtime link to winsock DLL).
  57. Mar 06, 1999  V1.03 Added code from  Plegge, Steve <jsp@nciinc.com> to add
  58.               APPE, XMKD, KRMD and STRU commands support.
  59. Jul 24, 1999  V1.04 Replaced msgStorDisabled value from '500 Cannot STOR.' to
  60.               '501 Permission Denied' because CuteFTP doesn't like error 500.
  61.               Suggested by Cedric Veilleux <webmaster@smashweb.com>.
  64.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  65. unit FtpSrv;
  67. {$B-}           { Enable partial boolean evaluation   }
  68. {$T-}           { Untyped pointers                    }
  69. {$IFNDEF VER80}
  70.     {$J+}       { Allow typed constant to be modified }
  71. {$ENDIF}
  72. {$IFDEF VER110} { C++ Builder V3.0                    }
  73.     {$ObjExportAll On}
  74. {$ENDIF}
  76. interface
  78. uses
  79.     WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  80.     Dialogs, Winsock, WSocket, FtpSrvC;
  82. const
  83.     FtpServerVersion         = 104;
  84.     CopyRight : String       = ' TFtpServer (c) 1998 F. Piette V1.04 ';
  85.     WM_FTPSRV_CLOSE_REQUEST  = WM_USER + 1;
  86.     WM_FTPSRV_CLIENT_CLOSED  = WM_USER + 2;
  87.     WM_FTPSRV_ABORT_TRANSFER = WM_USER + 3;
  88.     WM_FTPSRV_CLOSE_DATA     = WM_USER + 4;
  90. type
  91.     FtpServerException  = class(Exception);
  92. { Various Delphi and C++Builder version handle string parameter passed as var }
  93. { differently. To get application code compatible across all versions, we     }
  94. { need to define our own string type. We use the larger we can with the given }
  95. { compiler version. btw: the 255 limit is not a problem because it applies to }
  96. { the command laines sent to the server and 255 should be enough except if    }
  97. { you use incredibly long file names.                                         }
  98. {$IFDEF VER100}                     { Delphi 3   }
  99.     TFtpString = String;
  100. {$ELSE}                             { All others }
  101.     TFtpString = String[255];
  102. {$ENDIF}
  103.     TFtpCtrlSocketClass = class of TFtpCtrlSocket;
  104.     TFtpSrvAuthenticateEvent  =  procedure (Sender   : TObject;
  105.                                             Client   : TFtpCtrlSocket;
  106.                                             UserName : TFtpString;
  107.                                             Password : TFtpString;
  108.                                             var Authenticated : Boolean) of object;
  109.     TFtpSrvChangeDirectoryEvent =  procedure (Sender      : TObject;
  110.                                               Client      : TFtpCtrlSocket;
  111.                                               Directory   : TFtpString;
  112.                                               var Allowed : Boolean) of object;
  113.     TFtpSrvBuildDirectoryEvent =  procedure (Sender        : TObject;
  114.                                              Client        : TFtpCtrlSocket;
  115.                                              var Directory : TFtpString;
  116.                                              Detailed      : Boolean) of object;
  117.     TFtpSrvClientConnectEvent = procedure (Sender : TObject;
  118.                                            Client : TFtpCtrlSocket;
  119.                                            Error  : Word) of object;
  120.     TFtpSrvDataSessionConnectedEvent = procedure (Sender : TObject;
  121.                                                   Client : TFtpCtrlSocket;
  122.                                                   Data   : TWSocket;
  123.                                                   Error  : Word) of object;
  124.     TFtpSrvClientCommandEvent = procedure (Sender        : TObject;
  125.                                            Client        : TFtpCtrlSocket;
  126.                                            var Keyword   : TFtpString;
  127.                                            var Params    : TFtpString;
  128.                                            var Answer    : TFtpString) of object;
  129.     TFtpSrvAnswerToClientEvent = procedure (Sender        : TObject;
  130.                                             Client        : TFtpCtrlSocket;
  131.                                             var Answer    : TFtpString) of object;
  132.     TFtpSrvValidateXferEvent  = procedure (Sender        : TObject;
  133.                                            Client        : TFtpCtrlSocket;
  134.                                            var FilePath  : TFtpString;
  135.                                            var Allowed   : Boolean) of object;
  136.     TFtpSrvDataAvailableEvent = procedure (Sender : TObject;
  137.                                            Client : TFtpCtrlSocket;
  138.                                            Data   : TWSocket;
  139.                                            Buf    : PChar;
  140.                                            Len    : LongInt;
  141.                                            Error  : Word) of object;
  142.     TFtpSrvRetrDataSentEvent  = procedure (Sender : TObject;
  143.                                            Client : TFtpCtrlSocket;
  144.                                            Data   : TWSocket;
  145.                                            Error  : Word) of object;
  146.     TFtpSrvCommandProc        = procedure (Client        : TFtpCtrlSocket;
  147.                                            var Keyword   : TFtpString;
  148.                                            var Params    : TFtpString;
  149.                                            var Answer    : TFtpString) of object;
  150.     TFtpSrvCommandTableItem   = record
  151.                                     KeyWord : String;
  152.                                     Proc    : TFtpSrvCommandProc;
  153.                                 end;
  154.     TFtpServer = class(TComponent)
  155.     protected
  156.         FPort                   : String;
  157.         FBanner                 : String;
  158.         FServSocket             : TWSocket;
  159.         FWindowHandle           : HWND;
  160.         FClientClass            : TFtpCtrlSocketClass;
  161.         FClientList             : TList;
  162.         FClientNum              : LongInt;
  163.         FMaxClients             : LongInt;
  164.         FCmdTable               : array [0..31] of TFtpSrvCommandTableItem;
  165.         FLastCmd                : Integer;
  166.         FUserData               : LongInt;      { Reserved for component user }
  167.         FOnStart                : TNotifyEvent;
  168.         FOnStop                 : TNotifyEvent;
  169.         FOnAuthenticate         : TFtpSrvAuthenticateEvent;
  170.         FOnClientConnect        : TFtpSrvClientConnectEvent;
  171.         FOnClientDisconnect     : TFtpSrvClientConnectEvent;
  172.         FOnClientCommand        : TFtpSrvClientCommandEvent;
  173.         FOnAnswerToClient       : TFtpSrvAnswerToClientEvent;
  174.         FOnChangeDirectory      : TFtpSrvChangeDirectoryEvent;
  175.         FOnMakeDirectory        : TFtpSrvChangeDirectoryEvent;
  176.         FOnBuildDirectory       : TFtpSrvBuildDirectoryEvent;
  177.         FOnAlterDirectory       : TFtpSrvBuildDirectoryEvent;
  178.         FOnValidatePut          : TFtpSrvValidateXferEvent;
  179.         FOnValidateDele         : TFtpSrvValidateXferEvent;
  180.         FOnStorSessionConnected : TFtpSrvDataSessionConnectedEvent;
  181.         FOnStorSessionClosed    : TFtpSrvDataSessionConnectedEvent;
  182.         FOnStorDataAvailable    : TFtpSrvDataAvailableEvent;
  183.         FOnValidateGet          : TFtpSrvValidateXferEvent;
  184.         FOnRetrSessionConnected : TFtpSrvDataSessionConnectedEvent;
  185.         FOnRetrSessionClosed    : TFtpSrvDataSessionConnectedEvent;
  186.         FOnRetrDataSent         : TFtpSrvRetrDataSentEvent;
  187.         procedure Notification(AComponent: TComponent; operation: TOperation); override;
  188.         procedure ServSocketSessionAvailable(Sender : TObject; Error : Word);
  189.         procedure ServSocketStateChange(Sender : TObject; OldState, NewState : TSocketState);
  190.         procedure ClientSessionClosed(Sender : TObject; Error : Word);
  191.         procedure ClientDataSent(Sender : TObject; Error : Word);
  192.         procedure ClientCommand(Sender : TObject; CmdBuf : PChar; CmdLen : Integer);
  193.         procedure ClientPassiveSessionAvailable(Sender : TObject; Error : Word);
  194.         procedure ClientStorSessionConnected(Sender : TObject; Error : Word);
  195.         procedure ClientStorSessionClosed(Sender : TObject; Error : Word);
  196.         procedure ClientStorDataAvailable(Sender: TObject; Error : word);
  197.         procedure ClientRetrSessionConnected(Sender : TObject; Error : Word);
  198.         procedure ClientRetrSessionClosed(Sender : TObject; Error : Word);
  199.         procedure ClientRetrDataSent(Sender : TObject; Error : Word);
  200.         procedure SendAnswer(Client : TFtpCtrlSocket; Answer : TFtpString);
  201.         procedure SendNextDataChunk(Client : TFtpCtrlSocket; Data : TWSocket);
  202.         procedure StartSendData(Client : TFtpCtrlSocket);
  203.         procedure BuildDirectory(Client : TFtpCtrlSocket; var Params : TFtpString; Stream : TStream; Detailed   : Boolean);
  204.         procedure TriggerServerStart; virtual;
  205.         procedure TriggerServerStop; virtual;
  206.         procedure TriggerAuthenticate(Client            : TFtpCtrlSocket;
  207.                                       UserName          : String;
  208.                                       PassWord          : String;
  209.                                       var Authenticated : Boolean); virtual;
  210.         procedure TriggerChangeDirectory(Client         : TFtpCtrlSocket;
  211.                                          Directory      : String;
  212.                                          var Allowed    : Boolean); virtual;
  213.         procedure TriggerMakeDirectory(Client         : TFtpCtrlSocket;
  214.                                        Directory      : String;
  215.                                        var Allowed    : Boolean); virtual;
  216.         procedure TriggerBuildDirectory(Client        : TFtpCtrlSocket;
  217.                                         var Params    : TFtpString;
  218.                                         Detailed      : Boolean);
  219.         procedure TriggerAlterDirectory(Client        : TFtpCtrlSocket;
  220.                                         var Params    : TFtpString;
  221.                                         Detailed      : Boolean);
  222.         procedure TriggerSendAnswer(Client : TFtpCtrlSocket;
  223.                                     var Answer : TFtpString); virtual;
  224.         procedure TriggerClientConnect(Client : TFtpCtrlSocket; Error : Word); virtual;
  225.         procedure TriggerClientDisconnect(Client : TFtpCtrlSocket; Error : Word); virtual;
  226.         procedure TriggerClientCommand(Client      : TFtpCtrlSocket;
  227.                                        var Keyword : TFtpString;
  228.                                        var Params  : TFtpString;
  229.                                        var Answer  : TFtpString); virtual;
  230.         procedure TriggerStorSessionConnected(Client : TFtpCtrlSocket;
  231.                                               Data   : TWSocket;
  232.                                               Error  : Word); virtual;
  233.         procedure TriggerStorSessionClosed(Client : TFtpCtrlSocket;
  234.                                            Data   : TWSocket;
  235.                                            Error  : Word); virtual;
  236.         procedure TriggerValidatePut(Client        : TFtpCtrlSocket;
  237.                                      var FilePath  : TFtpString;
  238.                                      var Allowed   : Boolean); virtual;
  239.         procedure TriggerValidateDele(Client        : TFtpCtrlSocket;
  240.                                       var FilePath  : TFtpString;
  241.                                       var Allowed   : Boolean); virtual;
  242.         procedure TriggerRetrSessionConnected(Client : TFtpCtrlSocket;
  243.                                               Data   : TWSocket;
  244.                                               Error  : Word); virtual;
  245.         procedure TriggerRetrSessionClosed(Client : TFtpCtrlSocket;
  246.                                            Data   : TWSocket;
  247.                                            Error  : Word); virtual;
  248.         procedure TriggerValidateGet(Client        : TFtpCtrlSocket;
  249.                                      var FilePath  : TFtpString;
  250.                                      var Allowed   : Boolean); virtual;
  251.         procedure TriggerStorDataAvailable(Client : TFtpCtrlSocket;
  252.                                        Data   : TWSocket;
  253.                                        Buf    : PChar;
  254.                                        Len    : LongInt;
  255.                                        Error  : Word); virtual;
  256.         procedure TriggerRetrDataSent(Client : TFtpCtrlSocket;
  257.                                        Data   : TWSocket;
  258.                                        Error  : Word); virtual;
  259.         function  GetClientCount : Integer; virtual;
  260.         function  GetActive : Boolean;
  261.         procedure SetActive(newValue : Boolean);
  262.         procedure AddCommand(const Keyword : String;
  263.                              const Proc : TFtpSrvCommandProc); virtual;
  264.         procedure WMFtpSrvCloseRequest(var msg: TMessage);
  265.                                        message WM_FTPSRV_CLOSE_REQUEST;
  266.         procedure WMFtpSrvClientClosed(var msg: TMessage);
  267.                                        message WM_FTPSRV_CLIENT_CLOSED;
  268.         procedure WMFtpSrvAbortTransfer(var msg: TMessage);
  269.                                        message WM_FTPSRV_ABORT_TRANSFER;
  270.         procedure WMFtpSrvCloseData(var msg: TMessage);
  271.                                        message WM_FTPSRV_CLOSE_DATA;
  272.         procedure CommandDirectory(Client      : TFtpCtrlSocket;
  273.                                    var Keyword : TFtpString;
  274.                                    var Params  : TFtpString;
  275.                                    var Answer  : TFtpString;
  276.                                    Detailed    : Boolean);
  277.         procedure CommandUSER(Client      : TFtpCtrlSocket;
  278.                               var Keyword : TFtpString;
  279.                               var Params  : TFtpString;
  280.                               var Answer  : TFtpString); virtual;
  281.         procedure CommandPASS(Client      : TFtpCtrlSocket;
  282.                               var Keyword : TFtpString;
  283.                               var Params  : TFtpString;
  284.                               var Answer  : TFtpString); virtual;
  285.         procedure CommandQUIT(Client      : TFtpCtrlSocket;
  286.                               var Keyword : TFtpString;
  287.                               var Params  : TFtpString;
  288.                               var Answer  : TFtpString); virtual;
  289.         procedure CommandNOOP(Client      : TFtpCtrlSocket;
  290.                               var Keyword : TFtpString;
  291.                               var Params  : TFtpString;
  292.                               var Answer  : TFtpString); virtual;
  293.         procedure CommandLIST(Client      : TFtpCtrlSocket;
  294.                               var Keyword : TFtpString;
  295.                               var Params  : TFtpString;
  296.                               var Answer  : TFtpString); virtual;
  297.         procedure CommandNLST(Client      : TFtpCtrlSocket;
  298.                               var Keyword : TFtpString;
  299.                               var Params  : TFtpString;
  300.                               var Answer  : TFtpString); virtual;
  301.         procedure CommandDELE(Client      : TFtpCtrlSocket;
  302.                               var Keyword : TFtpString;
  303.                               var Params  : TFtpString;
  304.                               var Answer  : TFtpString); virtual;
  305.         procedure CommandSIZE(Client      : TFtpCtrlSocket;
  306.                               var Keyword : TFtpString;
  307.                               var Params  : TFtpString;
  308.                               var Answer  : TFtpString); virtual;
  309.         procedure CommandREST(Client      : TFtpCtrlSocket;
  310.                               var Keyword : TFtpString;
  311.                               var Params  : TFtpString;
  312.                               var Answer  : TFtpString); virtual;
  313.         procedure CommandRNFR(Client      : TFtpCtrlSocket;
  314.                               var Keyword : TFtpString;
  315.                               var Params  : TFtpString;
  316.                               var Answer  : TFtpString); virtual;
  317.         procedure CommandRNTo(Client      : TFtpCtrlSocket;
  318.                               var Keyword : TFtpString;
  319.                               var Params  : TFtpString;
  320.                               var Answer  : TFtpString); virtual;
  321.         procedure CommandPORT(Client      : TFtpCtrlSocket;
  322.                               var Keyword : TFtpString;
  323.                               var Params  : TFtpString;
  324.                               var Answer  : TFtpString); virtual;
  325.         procedure CommandSTOR(Client      : TFtpCtrlSocket;
  326.                               var Keyword : TFtpString;
  327.                               var Params  : TFtpString;
  328.                               var Answer  : TFtpString); virtual;
  329.         procedure CommandRETR(Client      : TFtpCtrlSocket;
  330.                               var Keyword : TFtpString;
  331.                               var Params  : TFtpString;
  332.                               var Answer  : TFtpString); virtual;
  333.         procedure CommandTYPE(Client      : TFtpCtrlSocket;
  334.                               var Keyword : TFtpString;
  335.                               var Params  : TFtpString;
  336.                               var Answer  : TFtpString); virtual;
  337.         procedure CommandCWD (Client      : TFtpCtrlSocket;
  338.                               var Keyword : TFtpString;
  339.                               var Params  : TFtpString;
  340.                               var Answer  : TFtpString); virtual;
  341.         procedure CommandChangeDir(Client : TFtpCtrlSocket;
  342.                               var Keyword : TFtpString;
  343.                               var Params  : TFtpString;
  344.                               var Answer  : TFtpString); virtual;
  345.         procedure CommandMKD (Client      : TFtpCtrlSocket;
  346.                               var Keyword : TFtpString;
  347.                               var Params  : TFtpString;
  348.                               var Answer  : TFtpString); virtual;
  349.         procedure CommandRMD (Client      : TFtpCtrlSocket;
  350.                               var Keyword : TFtpString;
  351.                               var Params  : TFtpString;
  352.                               var Answer  : TFtpString); virtual;
  353.         procedure CommandCDUP(Client      : TFtpCtrlSocket;
  354.                               var Keyword : TFtpString;
  355.                               var Params  : TFtpString;
  356.                               var Answer  : TFtpString); virtual;
  357.         procedure CommandXPWD(Client      : TFtpCtrlSocket;
  358.                               var Keyword : TFtpString;
  359.                               var Params  : TFtpString;
  360.                               var Answer  : TFtpString); virtual;
  361.         procedure CommandPWD (Client      : TFtpCtrlSocket;
  362.                               var Keyword : TFtpString;
  363.                               var Params  : TFtpString;
  364.                               var Answer  : TFtpString); virtual;
  365.         procedure CommandSYST(Client      : TFtpCtrlSocket;
  366.                               var Keyword : TFtpString;
  367.                               var Params  : TFtpString;
  368.                               var Answer  : TFtpString); virtual;
  369.         procedure CommandABOR(Client      : TFtpCtrlSocket;
  370.                               var Keyword : TFtpString;
  371.                               var Params  : TFtpString;
  372.                               var Answer  : TFtpString); virtual;
  373.         procedure CommandPASV(Client      : TFtpCtrlSocket;
  374.                               var Keyword : TFtpString;
  375.                               var Params  : TFtpString;
  376.                               var Answer  : TFtpString); virtual;
  377.         procedure CommandAPPE(Client      : TFtpCtrlSocket;
  378.                               var Keyword : TFtpString;
  379.                               var Params  : TFtpString;
  380.                               var Answer  : TFtpString); virtual;
  381.         procedure CommandSTRU(Client      : TFtpCtrlSocket;
  382.                               var Keyword : TFtpString;
  383.                               var Params  : TFtpString;
  384.                               var Answer  : TFtpString); virtual;
  385.     public
  386.         constructor Create(AOwner: TComponent); override;
  387.         destructor  Destroy; override;
  388.         procedure   Start;
  389.         procedure   Stop;
  390.         procedure   DisconnectAll;
  391.         procedure WndProc(var MsgRec: TMessage);
  392.         property  ServSocket    : TWSocket            read  FServSocket;
  393.         property  Handle        : HWND                read  FWindowHandle;
  394.         property  ClientCount   : Integer             read  GetClientCount;
  395.         property  Active        : Boolean             read  GetActive
  396.                                                       write SetActive;
  397.         property  ClientClass            : TFtpCtrlSocketClass
  398.                                                       read  FClientClass
  399.                                                       write FClientClass;
  400.     published
  401.         property  Port                   : String     read  FPort
  402.                                                       write FPort;
  403.         property  Banner                 : String     read  FBanner
  404.                                                       write FBanner;
  405.         property  UserData               : LongInt    read  FUserData
  406.                                                       write FUserData;
  407.         property  MaxClients             : LongInt    read  FMaxClients
  408.                                                       write FMaxClients;
  409.         property  OnStart                : TNotifyEvent
  410.                                                       read  FOnStart
  411.                                                       write FOnStart;
  412.         property  OnStop                 : TNotifyEvent
  413.                                                       read  FOnStop
  414.                                                       write FOnStop;
  415.         property  OnAuthenticate         : TFtpSrvAuthenticateEvent
  416.                                                       read  FOnAuthenticate
  417.                                                       write FOnAuthenticate;
  418.         property  OnClientDisconnect     : TFtpSrvClientConnectEvent
  419.                                                       read  FOnClientDisconnect
  420.                                                       write FOnClientDisconnect;
  421.         property  OnClientConnect        : TFtpSrvClientConnectEvent
  422.                                                       read  FOnClientConnect
  423.                                                       write FOnClientConnect;
  424.         property  OnClientCommand        : TFtpSrvClientCommandEvent
  425.                                                       read  FOnClientCommand
  426.                                                       write FOnClientCommand;
  427.         property  OnAnswerToClient       : TFtpSrvAnswerToClientEvent
  428.                                                       read  FOnAnswerToClient
  429.                                                       write FOnAnswerToClient;
  430.         property  OnChangeDirectory      : TFtpSrvChangeDirectoryEvent
  431.                                                       read  FOnChangeDirectory
  432.                                                       write FOnChangeDirectory;
  433.         property  OnMakeDirectory        : TFtpSrvChangeDirectoryEvent
  434.                                                       read  FOnMakeDirectory
  435.                                                       write FOnMakeDirectory;
  436.         property  OnBuildDirectory       : TFtpSrvBuildDirectoryEvent
  437.                                                       read  FOnBuildDirectory
  438.                                                       write FOnBuildDirectory;
  439.         property  OnAlterDirectory       : TFtpSrvBuildDirectoryEvent
  440.                                                       read  FOnAlterDirectory
  441.                                                       write FOnAlterDirectory;
  442.         property  OnStorSessionConnected : TFtpSrvDataSessionConnectedEvent
  443.                                                       read  FOnStorSessionConnected
  444.                                                       write FOnStorSessionConnected;
  445.         property  OnRetrSessionConnected : TFtpSrvDataSessionConnectedEvent
  446.                                                       read  FOnRetrSessionConnected
  447.                                                       write FOnRetrSessionConnected;
  448.         property  OnStorSessionClosed    : TFtpSrvDataSessionConnectedEvent
  449.                                                       read  FOnStorSessionClosed
  450.                                                       write FOnStorSessionClosed;
  451.         property  OnRetrSessionClosed    : TFtpSrvDataSessionConnectedEvent
  452.                                                       read  FOnRetrSessionClosed
  453.                                                       write FOnRetrSessionClosed;
  454.         property  OnRetrDataSent         : TFtpSrvRetrDataSentEvent
  455.                                                       read  FOnRetrDataSent
  456.                                                       write FOnRetrDataSent;
  457.         property  OnValidatePut          : TFtpSrvValidateXferEvent
  458.                                                       read  FOnValidatePut
  459.                                                       write FOnValidatePut;
  460.         property  OnValidateDele         : TFtpSrvValidateXferEvent
  461.                                                       read  FOnValidateDele
  462.                                                       write FOnValidateDele;
  463.         property  OnValidateGet          : TFtpSrvValidateXferEvent
  464.                                                       read  FOnValidateGet
  465.                                                       write FOnValidateGet;
  466.         property  OnStorDataAvailable    : TFtpSrvDataAvailableEvent
  467.                                                       read  FOnStorDataAvailable
  468.                                                       write FOnStorDataAvailable;
  469.     end;
  471. procedure Register;
  473. implementation
  475. const
  476.     msgDftBanner      = '220 ICS FTP Server ready.';
  477.     msgTooMuchClients = '421 Too many users connected.';
  478.     msgCmdUnknown     = '500 ''%s'': command not understood.';
  479.     msgLoginFailed    = '530 Login incorrect.';
  480.     msgNotLogged      = '530 Please login with USER and PASS.';
  481.     msgNoUser         = '503 Login with USER first.';
  482.     msgLogged         = '230 User %s logged in.';
  483.     msgPassRequired   = '331 Password required for %s.';
  484.     msgCWDSuccess     = '250 CWD command successful. "%s" is current directory.';
  485.     msgCWDFailed      = '501 CWD failed. %s';
  486.     msgPWDSuccess     = '257 "%s" is current directory.';
  487.     msgQuit           = '221 Goodbye.';
  488.     msgPortSuccess    = '200 Port command successful.';
  489.     msgPortFailed     = '501 Invalid PORT command.';
  490.     msgStorDisabled   = '501 Permission Denied'; {'500 Cannot STOR.';}
  491.     msgStorSuccess    = '150 Opening data connection for %s.';
  492.     msgStorFailed     = '501 Cannot STOR. %s';
  493.     msgStorAborted    = '426 Connection closed; %s.';
  494.     msgStorOk         = '226 File received ok';
  495.     msgStorError      = '426 Connection closed; transfer aborted. Error #%d';
  496.     msgRetrDisabled   = '500 Cannot RETR.';
  497.     msgRetrSuccess    = '150 Opening data connection for %s.';
  498.     msgRetrFailed     = '501 Cannot RETR. %s';
  499.     msgRetrAborted    = '426 Connection closed; %s.';
  500.     msgRetrOk         = '226 File sent ok';
  501.     msgRetrError      = '426 Connection closed; transfer aborted. Error #%d';
  502.     msgSystem         = '215 UNIX Type: L8 Internet Component Suite';
  503.     msgDirOpen        = '150 Opening data connection for directory list.';
  504.     msgDirFailed      = '451 Failed: %s.';
  505.     msgTypeOk         = '200 Type set to %s.';
  506.     msgTypeFailed     = '500 ''TYPE %s'': command not understood.';
  507.     msgDeleNotExists  = '550 ''%s'': no such file or directory.';
  508.     msgDeleOk         = '250 File ''%s'' deleted.';
  509.     msgDeleFailed     = '450 File ''%s'' can''t be deleted.';
  510.     msgDeleSyntax     = '501 Syntax error in parameter.';
  511.     msgDeleDisabled   = '500 Cannot DELE.';
  512.     msgRnfrNotExists  = '550 ''%s'': no such file or directory.';
  513.     msgRnfrSyntax     = '501 Syntax error is parameter.';
  514.     msgRnfrOk         = '350 File exists, ready for destination name.';
  515.     msgRntoNotExists  = '550 ''%s'': no such file or directory.';
  516.     msgRntoAlready    = '553 ''%s'': file already exists.';
  517.     msgRntoOk         = '250 File ''%s'' renamed to ''%s''.';
  518.     msgRntoFailed     = '450 File ''%s'' can''t be renamed.';
  519.     msgRntoSyntax     = '501 Syntax error in parameter.';
  520.     msgMkdOk          = '257 ''%s'': directory created.';
  521.     msgMkdAlready     = '550 ''%s'': file or directory already exists.';
  522.     msgMkdFailed      = '550 ''%s'': can''t create directory.';
  523.     msgMkdSyntax      = '501 Syntax error in parameter.';
  524.     msgRmdOk          = '250 ''%s'': directory removed.';
  525.     msgRmdNotExists   = '550 ''%s'': no such directory.';
  526.     msgRmdFailed      = '550 ''%s'': can''t remove directory.';
  527.     msgRmdSyntax      = '501 Syntax error in parameter.';
  528.     msgNoopOk         = '200 Ok. Parameter was ''%s''.';
  529.     msgAborOk         = '225 ABOR command successful.';
  530.     msgPasvLocal      = '227 Entering Passive Mode (127,0,0,1,%d,%d).';
  531.     msgPasvRemote     = '227 Entering Passive Mode (%d,%d,%d,%d,%d,%d).';
  532.     msgPasvExcept     = '500 PASV exception: ''%s''.';
  533.     msgSizeOk         = '213 %d';
  534.     msgSizeFailed     = '550 Command failed: %s.';
  535.     msgSizeSyntax     = '501 Syntax error in parameter.';
  536.     msgRestOk         = '350 REST supported. Ready to resume at byte offset %d.';
  537.     msgRestZero       = '501 Required byte offset parameter bad or missing.';
  538.     msgRestFailed     = '501 Syntax error in parameter: %s.';
  539.     msgAppeFailed     = '550 APPE failed.';
  540.     msgAppeSuccess    = '150 Opening data connection for %s (append).';
  541.     msgAppeDisabled   = '500 Cannot APPE.';
  542.     msgAppeAborted    = '426 Connection closed; %s.';
  543.     msgAppeOk         = '226 File received ok';
  544.     msgAppeError      = '426 Connection closed; transfer aborted. Error #%d';
  545.     msgAppeReady      = '150 APPE supported.  Ready to append file "%s" at offset %d.';
  546.     msgStruOk         = '200 Ok. STRU parameter ''%s'' ignored.';
  548. function SlashesToBackSlashes(const S : String) : String; forward;
  549. function BackSlashesToSlashes(const S : String) : String; forward;
  550. function BuildFilePath(const Directory : String;
  551.                        FileName        : String) : String; forward;
  553. var
  554.     ThisYear, ThisMonth, ThisDay : Word;
  557. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  558. procedure Register;
  559. begin
  560.     RegisterComponents('FPiette', [TFtpServer]);
  561. end;
  564. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  565. {$IFDEF VER80}
  566. procedure SetLength(var S: string; NewLength: Integer);
  567. begin
  568.     S[0] := chr(NewLength);
  569. end;
  572. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  573. function TrimRight(Str : String) : String;
  574. var
  575.     i : Integer;
  576. begin
  577.     i := Length(Str);
  578.     while (i > 0) and (Str[i] = ' ') do
  579.         i := i - 1;
  580.     Result := Copy(Str, 1, i);
  581. end;
  584. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  585. function TrimLeft(Str : String) : String;
  586. var
  587.     i : Integer;
  588. begin
  589.     if Str[1] <> ' ' then
  590.         Result := Str
  591.     else begin
  592.         i := 1;
  593.         while (i <= Length(Str)) and (Str[i] = ' ') do
  594.             i := i + 1;
  595.         Result := Copy(Str, i, Length(Str) - i + 1);
  596.     end;
  597. end;
  600. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  601. function Trim(Str : String) : String;
  602. begin
  603.     Result := TrimLeft(TrimRight(Str));
  604. end;
  605. {$ENDIF}
  608. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  609. function GetFileSize(FileName : String) : LongInt;
  610. var
  611.     SR : TSearchRec;
  612. begin
  613.     if FindFirst(FileName, faReadOnly or faHidden or
  614.                  faSysFile or faArchive, SR) = 0 then
  615.         Result := SR.Size
  616.     else
  617.         Result := -1;
  618.     FindClose(SR);
  619. end;
  622. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  623. constructor TFtpServer.Create(AOwner: TComponent);
  624. begin
  625.     inherited Create(AOwner);
  626.     FWindowHandle    := AllocateHWnd(WndProc);
  627.     FServSocket      := TWSocket.Create(Self);
  628.     FServSocket.Name := 'ServerWSocket';
  629.     FClientList      := TList.Create;
  630.     FPort            := 'ftp';
  631.     FBanner          := msgDftBanner;
  632.     FClientClass     := TFtpCtrlSocket;
  633.     AddCommand('PORT', CommandPORT);
  634.     AddCommand('STOR', CommandSTOR);
  635.     AddCommand('RETR', CommandRETR);
  636.     AddCommand('CWD',  CommandCWD);
  637.     AddCommand('XPWD', CommandXPWD);
  638.     AddCommand('PWD',  CommandPWD);
  639.     AddCommand('USER', CommandUSER);
  640.     AddCommand('PASS', CommandPASS);
  641.     AddCommand('LIST', CommandLIST);
  642.     AddCommand('NLST', CommandNLST);
  643.     AddCommand('TYPE', CommandTYPE);
  644.     AddCommand('SYST', CommandSYST);
  645.     AddCommand('QUIT', CommandQUIT);
  646.     AddCommand('DELE', CommandDELE);
  647.     AddCommand('SIZE', CommandSIZE);
  648.     AddCommand('REST', CommandREST);
  649.     AddCommand('RNFR', CommandRNFR);
  650.     AddCommand('RNTO', CommandRNTO);
  651.     AddCommand('MKD',  CommandMKD);
  652.     AddCommand('RMD',  CommandRMD);
  653.     AddCommand('ABOR', CommandABOR);
  654.     AddCommand('PASV', CommandPASV);
  655.     AddCommand('NOOP', CommandNOOP);
  656.     AddCommand('CDUP', CommandCDUP);
  657.     AddCommand('APPE', CommandAPPE);
  658.     AddCommand('STRU', CommandSTRU);
  659.     AddCommand('XMKD', CommandMKD);
  660.     AddCommand('XRMD', CommandRMD);
  661. end;
  664. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  665. destructor TFtpServer.Destroy;
  666. begin
  667.     if Assigned(FServSocket) then begin
  668.         FServSocket.Destroy;
  669.         FServSocket := nil;
  670.     end;
  671.     if Assigned(FClientList) then begin
  672.         FClientList.Destroy;
  673.         FClientList := nil;
  674.     end;
  675.     DeallocateHWnd(FWindowHandle);
  676.     inherited Destroy;
  677. end;
  680. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  681. procedure TFtpServer.WndProc(var MsgRec: TMessage);
  682. begin
  683.     with MsgRec do begin
  684.         case Msg of
  685.         WM_FTPSRV_CLOSE_REQUEST  : WMFtpSrvCloseRequest(MsgRec);
  686.         WM_FTPSRV_CLIENT_CLOSED  : WMFtpSrvClientClosed(MsgRec);
  687.         WM_FTPSRV_ABORT_TRANSFER : WMFtpSrvAbortTransfer(MsgRec);
  688.         WM_FTPSRV_CLOSE_DATA     : WMFtpSrvCloseData(MsgRec);
  689.         else
  690.             Result := DefWindowProc(Handle, Msg, wParam, lParam);
  691.         end;
  692.     end;
  693. end;
  696. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  697. procedure TFtpServer.WMFtpSrvCloseRequest(var msg: TMessage);
  698. var
  699.     Client : TFtpCtrlSocket;
  700. begin
  701.     Client := TFtpCtrlSocket(msg.LParam);
  702.     if Client.AllSent then
  703.         Client.Close
  704.     else
  705.         Client.CloseRequest := TRUE;
  706. end;
  709. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  710. procedure TFtpServer.Notification(AComponent: TComponent; operation: TOperation);
  711. begin
  712.     inherited Notification(AComponent, operation);
  713.     if operation = opRemove then begin
  714.         if AComponent = FServSocket then
  715.             FServSocket := nil;
  716.     end;
  717. end;
  720. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  721. procedure TFtpServer.AddCommand(
  722.     const Keyword : String;
  723.     const Proc    : TFtpSrvCommandProc);
  724. begin
  725.     if FLastCmd > High(FCmdTable) then
  726.         raise FtpServerException.Create('Too many command');
  727.     FCmdTable[FLastCmd].KeyWord := KeyWord;
  728.     FCmdTable[FLastCmd].Proc    := Proc;
  729.     Inc(FLastCmd);
  730. end;
  733. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  734. procedure TFtpServer.Start;
  735. begin
  736.     if FServSocket.State = wsListening then
  737.         Exit;             { Server is already running }
  738.     FServSocket.Port  := Port;
  739.     FServSocket.Proto := 'tcp';
  740.     FServSocket.Addr  := '0.0.0.0';
  741.     FServSocket.OnSessionAvailable := ServSocketSessionAvailable;
  742.     FServSocket.OnChangeState      := ServSocketStateChange;
  743.     FServSocket.Listen;
  744. end;
  747. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  748. procedure TFtpServer.Stop;
  749. begin
  750.     FServSocket.Close;
  751. end;
  754. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  755. procedure TFtpServer.DisconnectAll;
  756. var
  757.     Client : TFtpCtrlSocket;
  758. begin
  759.     while FClientList.Count > 0 do begin
  760.         Client := TFtpCtrlSocket(FClientList.Items[0]);
  761.         Client.Close;
  762.         FClientList.Remove(Client);
  763.     end;
  764. end;
  767. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  768. function TFtpServer.GetActive : Boolean;
  769. begin
  770.     Result := (FServSocket.State = wsListening);
  771. end;
  774. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  775. procedure TFtpServer.SetActive(newValue : Boolean);
  776. begin
  777.     if newValue then
  778.         Start
  779.     else
  780.         Stop;
  781. end;
  784. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  785. procedure TFtpServer.ServSocketStateChange(Sender : TObject; OldState, NewState : TSocketState);
  786. begin
  787.     if csDestroying in ComponentState then
  788.         Exit;
  789.     if NewState = wsListening then
  790.         TriggerServerStart
  791.     else if NewState = wsClosed then
  792.         TriggerServerStop;
  793. end;
  796. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  797. procedure TFtpServer.ServSocketSessionAvailable(Sender : TObject; Error : Word);
  798. var
  799.     Client : TFtpCtrlSocket;
  800. begin
  801.     if Error <> 0 then
  802.         raise FtpServerException.Create('Session available error #' + IntToStr(Error));
  803.     Inc(FClientNum);
  804.     Client                 := FClientClass.Create(Self);
  805.     FClientList.Add(Client);
  806.     Client.Name            := 'ClientWSocket' + IntToStr(FClientNum);
  807.     Client.DataSocket.Name := 'DataWSocket' + IntToStr(FClientNum);
  808.     Client.Banner          := FBanner;
  809.     Client.HSocket         := ServSocket.Accept;
  810.     Client.OnCommand       := ClientCommand;
  811.     Client.OnSessionClosed := ClientSessionClosed;
  812.     Client.OnDataSent      := ClientDataSent;
  813.     TriggerClientConnect(Client, Error);
  814.     { The event handler may have destroyed the client ! }
  815.     if FClientList.IndexOf(Client) < 0 then
  816.         Exit;
  817.     { The event handler may have closed the connection }
  818.     if Client.State <> wsConnected then
  819.         Exit;
  820.     { Ok, the client is still there, process with the connection }
  821.     if (FMaxClients > 0) and (FMaxClients < ClientCount) then begin
  822.         { Sorry, toomuch clients }
  823.         Client.Banner := msgTooMuchClients;
  824.         Client.StartConnection;
  825.         Client.Close;
  826.     end
  827.     else
  828.         Client.StartConnection;
  829. end;
  832. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  833. procedure TFtpServer.SendAnswer(Client : TFtpCtrlSocket; Answer : TFtpString);
  834. begin
  835.     try
  836.         TriggerSendAnswer(Client, Answer);
  837.         Client.SendAnswer(Answer);
  838.     except
  839.         { Just ignore any exception here }
  840.     end;
  841. end;
  844. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  845. procedure TFtpServer.ClientCommand(
  846.     Sender : TObject;
  847.     CmdBuf : PChar;
  848.     CmdLen : Integer);
  849. const
  850.     TELNET_IAC       = #255;
  851.     TELNET_IP        = #244;
  852.     TELNET_DATA_MARK = #242;
  853. var
  854.     Client  : TFtpCtrlSocket;
  855.     Answer  : TFtpString;
  856.     Params  : TFtpString;
  857.     KeyWord : TFtpString;
  858.     I, J    : Integer;
  859. begin
  860.     Client := Sender as TFtpCtrlSocket;
  861.     Answer := '';
  863.     { Copy the command received, removing any telnet option }
  864.     try
  865.         Params := '';
  866.         I      := 0;
  867.         while I < CmdLen do begin
  868.             if CmdBuf[I] <> TELNET_IAC then begin
  869.                 Params := Params + CmdBuf[I];
  870.                 Inc(I);
  871.             end
  872.             else begin
  873.                 Inc(I);
  874.                 if CmdBuf[I] = TELNET_IAC then
  875.                     Params := Params + CmdBuf[I];
  876.                 Inc(I);
  877.             end;
  878.         end;
  880.         { Extract keyword, ignoring leading spaces and tabs }
  881.         I := 1;
  882.         while (I <= Length(Params)) and (Params[I] in [' ', #9]) do
  883.             Inc(I);
  884.         J := I;
  885.         while (J <= Length(Params)) and (Params[J] in ['A'..'Z', 'a'..'z', '0'..'9']) do
  886.             Inc(J);
  887.         KeyWord := UpperCase(Copy(Params, I, J - I));
  889.         { Extract parameters, ignoring leading spaces and tabs }
  890.         while (J <= Length(Params)) and (Params[J] in [' ', #9]) do
  891.             Inc(J);
  892.         Params := Copy(Params, J, Length(Params));
  894.         { Pass the command to the component user to let him a chance to }
  895.         { handle it. If it does, he must return the answer.             }
  896.         TriggerClientCommand(Client, Keyword, Params, Answer);
  897.         if Answer <> '' then begin
  898.             { Event handler has processed the client command, send the answer }
  899.             SendAnswer(Client, Answer);
  900.             Exit;
  901.         end;
  903.         { The command has not been processed, we'll process it }
  904.         if Keyword = '' then begin
  905.             { Empty keyword (should never occurs) }
  906.             SendAnswer(Client, Format(msgCmdUnknown, [Params]));
  907.             Exit;
  908.         end;
  910.         { We need to process the client command, search our command table }
  911.         I := 0;
  912.         while I <= High(FCmdTable) do begin
  913.             if FCmdTable[I].KeyWord = KeyWord then begin
  914.                 FCmdTable[I].Proc(Client, KeyWord, Params, Answer);
  915.                 SendAnswer(Client, Answer);
  916.                 Exit;
  917.             end;
  918.             Inc(I);
  919.         end;
  920.         SendAnswer(Client, Format(msgCmdUnknown, [KeyWord]));
  921.     except
  922.         on E:Exception do begin
  923.             SendAnswer(Client, '501 ' + E.Message);
  924.         end;
  925.     end;
  926. end;
  929. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  930. procedure TFtpServer.ClientDataSent(Sender : TObject; Error : Word);
  931. var
  932.     Client  : TFtpCtrlSocket;
  933. begin
  934.     Client := Sender as TFtpCtrlSocket;
  935.     if Client.CloseRequest then begin
  936.         Client.CloseRequest := FALSE;
  937.         PostMessage(FWindowHandle, WM_FTPSRV_CLOSE_REQUEST, 0, LongInt(Client));
  938.     end;
  939. end;
  942. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  943. procedure TFtpServer.ClientSessionClosed(Sender : TObject; Error : Word);
  944. begin
  945.     PostMessage(FWindowHandle, WM_FTPSRV_CLIENT_CLOSED, 0, LongInt(Sender));
  946. end;
  949. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  950. procedure TFtpServer.WMFtpSrvClientClosed(var msg: TMessage);
  951. var
  952.     Client : TFtpCtrlSocket;
  953. begin
  954.     Client := TFtpCtrlSocket(Msg.LParam);
  955.     try
  956.         FClientList.Remove(Client);
  957.         TriggerClientDisconnect(Client, Error);
  958.     finally
  959.         Client.Destroy;
  960.     end;
  961. end;
  964. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  965. procedure TFtpServer.WMFtpSrvAbortTransfer(var msg: TMessage);
  966. var
  967.     Data : TWSocket;
  968. begin
  969.     Data := TWSocket(Msg.LParam);
  970.     Data.ShutDown(2);
  971.     Data.Close;
  972. end;
  975. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  976. procedure TFtpServer.WMFtpSrvCloseData(var msg: TMessage);
  977. var
  978.     Data : TWSocket;
  979. begin
  980.     if msg.WParam > 0 then begin
  981. {$IFNDEF VER80}
  982.         Sleep(0);  { Release time slice }
  983. {$ENDIF}
  984.         PostMessage(FWindowHandle, Msg.Msg, msg.WParam - 1, msg.LParam);
  985.     end
  986.     else begin
  987.         Data := TWSocket(Msg.LParam);
  988.         Data.Close;
  989.     end;
  990. end;
  993. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  994. function TFtpServer.GetClientCount : Integer;
  995. begin
  996.     if Assigned(FClientList) then
  997.         Result := FClientList.Count
  998.     else
  999.         Result := 0;
  1000. end;
  1003. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1004. procedure TFtpServer.TriggerServerStart;
  1005. begin
  1006.     if Assigned(FOnStart) then
  1007.         FOnStart(Self);
  1008. end;
  1011. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1012. procedure TFtpServer.TriggerServerStop;
  1013. begin
  1014.     if Assigned(FOnStop) then
  1015.         FOnStop(Self);
  1016. end;
  1019. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1020. procedure TFtpServer.TriggerAuthenticate(
  1021.     Client            : TFtpCtrlSocket;
  1022.     UserName          : String;
  1023.     PassWord          : String;
  1024.     var Authenticated : Boolean);
  1025. begin
  1026.     if Assigned(FOnAuthenticate) then
  1027.         FOnAuthenticate(Self, Client, UserName, Password, Authenticated);
  1028. end;
  1031. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1032. procedure TFtpServer.TriggerChangeDirectory(
  1033.     Client         : TFtpCtrlSocket;
  1034.     Directory      : String;
  1035.     var Allowed    : Boolean);
  1036. begin
  1037.     if Assigned(FOnChangeDirectory) then
  1038.         FOnChangeDirectory(Self, Client, Directory, Allowed);
  1039. end;
  1042. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1043. procedure TFtpServer.TriggerMakeDirectory(
  1044.     Client         : TFtpCtrlSocket;
  1045.     Directory      : String;
  1046.     var Allowed    : Boolean);
  1047. begin
  1048.     if Assigned(FOnMakeDirectory) then
  1049.         FOnMakeDirectory(Self, Client, Directory, Allowed);
  1050. end;
  1053. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1054. procedure TFtpServer.TriggerBuildDirectory(
  1055.     Client        : TFtpCtrlSocket;
  1056.     var Params    : TFtpString;
  1057.     Detailed      : Boolean);
  1058. begin
  1059.     if Assigned(FOnBuildDirectory) then
  1060.         FOnBuildDirectory(Self, Client, Params, Detailed);
  1061. end;
  1064. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1065. procedure TFtpServer.TriggerAlterDirectory(
  1066.     Client        : TFtpCtrlSocket;
  1067.     var Params    : TFtpString;
  1068.     Detailed      : Boolean);
  1069. begin
  1070.     if Assigned(FOnAlterDirectory) then
  1071.         FOnAlterDirectory(Self, Client, Params, Detailed);
  1072. end;
  1075. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1076. procedure TFtpServer.TriggerSendAnswer(
  1077.     Client     : TFtpCtrlSocket;
  1078.     var Answer : TFtpString);
  1079. begin
  1080.     if Assigned(FOnAnswerToClient) then
  1081.         FOnAnswerToClient(Self, Client, Answer);
  1082. end;
  1085. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1086. procedure TFtpServer.TriggerClientDisconnect(Client : TFtpCtrlSocket; Error : Word);
  1087. begin
  1088.     if Assigned(FOnClientDisconnect) then
  1089.         FOnClientDisconnect(Self, Client, Error);
  1090. end;
  1093. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1094. procedure TFtpServer.TriggerClientConnect(Client : TFtpCtrlSocket; Error : Word);
  1095. begin
  1096.     if Assigned(FOnClientConnect) then
  1097.         FOnClientConnect(Self, Client, Error);
  1098. end;
  1101. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1102. procedure TFtpServer.TriggerStorSessionConnected(
  1103.     Client : TFtpCtrlSocket; Data : TWSocket; Error : Word);
  1104. begin
  1105.     if Assigned(FOnStorSessionConnected) then
  1106.         FOnStorSessionConnected(Self, Client, Data, Error);
  1107. end;
  1110. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1111. procedure TFtpServer.TriggerRetrSessionConnected(
  1112.     Client : TFtpCtrlSocket; Data : TWSocket; Error : Word);
  1113. begin
  1114.     if Assigned(FOnRetrSessionConnected) then
  1115.         FOnRetrSessionConnected(Self, Client, Data, Error);
  1116. end;
  1119. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1120. procedure TFtpServer.TriggerStorSessionClosed(
  1121.     Client : TFtpCtrlSocket; Data : TWSocket; Error : Word);
  1122. begin
  1123.     if Assigned(FOnStorSessionClosed) then
  1124.         FOnStorSessionClosed(Self, Client, Data, Error);
  1125. end;
  1128. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1129. procedure TFtpServer.TriggerRetrSessionClosed(
  1130.     Client : TFtpCtrlSocket; Data : TWSocket; Error : Word);
  1131. begin
  1132.     if Assigned(FOnRetrSessionClosed) then
  1133.         FOnRetrSessionClosed(Self, Client, Data, Error);
  1134. end;
  1137. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1138. procedure TFtpServer.TriggerClientCommand(
  1139.     Client      : TFtpCtrlSocket;
  1140.     var Keyword : TFtpString;
  1141.     var Params  : TFtpString;
  1142.     var Answer  : TFtpString);
  1143. begin
  1144.     if Assigned(FOnClientCommand) then
  1145.         FOnClientCommand(Self, Client, KeyWord, Params, Answer);
  1146. end;
  1149. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1150. procedure TFtpServer.TriggerValidatePut(
  1151.     Client        : TFtpCtrlSocket;
  1152.     var FilePath  : TFtpString;
  1153.     var Allowed   : Boolean);
  1154. begin
  1155.     if Assigned(FOnValidatePut) then
  1156.         FOnValidatePut(Self, Client, FilePath, Allowed);
  1157. end;
  1160. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1161. procedure TFtpServer.TriggerValidateDele(
  1162.     Client        : TFtpCtrlSocket;
  1163.     var FilePath  : TFtpString;
  1164.     var Allowed   : Boolean);
  1165. begin
  1166.     if Assigned(FOnValidateDele) then
  1167.         FOnValidateDele(Self, Client, FilePath, Allowed);
  1168. end;
  1171. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1172. procedure TFtpServer.TriggerValidateGet(
  1173.     Client        : TFtpCtrlSocket;
  1174.     var FilePath  : TFtpString;
  1175.     var Allowed   : Boolean);
  1176. begin
  1177.     if Assigned(FOnValidateGet) then
  1178.         FOnValidateGet(Self, Client, FilePath, Allowed);
  1179. end;
  1182. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1183. procedure TFtpServer.TriggerStorDataAvailable(
  1184.     Client : TFtpCtrlSocket;
  1185.     Data   : TWSocket;
  1186.     Buf    : PChar;
  1187.     Len    : LongInt;
  1188.     Error  : Word);
  1189. begin
  1190.     if Assigned(FOnStorDataAvailable) then
  1191.         FOnStorDataAvailable(Self, Client, Data, Buf, Len, Error);
  1192. end;
  1195. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1196. procedure TFtpServer.TriggerRetrDataSent(
  1197.     Client : TFtpCtrlSocket;
  1198.     Data   : TWSocket;
  1199.     Error  : Word);
  1200. begin
  1201.     if Assigned(FOnRetrDataSent) then
  1202.         FOnRetrDataSent(Self, Client, Data, Error);
  1203. end;
  1206. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1207. procedure TFtpServer.CommandUSER(
  1208.     Client      : TFtpCtrlSocket;
  1209.     var Keyword : TFtpString;
  1210.     var Params  : TFtpString;
  1211.     var Answer  : TFtpString);
  1212. begin
  1213.     Client.CurCmdType := ftpcUSER;
  1214.     Client.UserName   := Trim(Params);
  1215.     Client.FtpState   := ftpcWaitingPassword;
  1216.     Answer            := Format(msgPassRequired, [Client.UserName]);
  1217. end;
  1220. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1221. procedure TFtpServer.CommandPASS(
  1222.     Client      : TFtpCtrlSocket;
  1223.     var Keyword : TFtpString;
  1224.     var Params  : TFtpString;
  1225.     var Answer  : TFtpString);
  1226. var
  1227.     Authenticated : Boolean;
  1228. begin
  1229.     if Client.FtpState <> ftpcWaitingPassword then
  1230.         Answer := msgNoUser
  1231.     else begin
  1232.         Client.CurCmdType    := ftpcPASS;
  1233.         Client.PassWord      := Trim(Params);
  1234.         Authenticated        := TRUE;
  1235.         TriggerAuthenticate(Client, Client.UserName, Client.PassWord, Authenticated);
  1236.         if Authenticated then begin
  1237.             Client.FtpState  := ftpcReady;
  1238.             Client.Directory := Client.HomeDir;
  1239.             Answer           := Format(msgLogged, [Client.UserName])
  1240.         end
  1241.         else begin
  1242.             Client.FtpState  := ftpcWaitingUserCode;
  1243.             Answer           := msgLoginFailed;
  1244.         end;
  1245.     end;
  1246. end;
  1249. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1250. procedure TFtpServer.CommandCDUP(
  1251.     Client      : TFtpCtrlSocket;
  1252.     var Keyword : TFtpString;
  1253.     var Params  : TFtpString;
  1254.     var Answer  : TFtpString);
  1255. begin
  1256.     if Client.FtpState <> ftpcReady then begin
  1257.         Answer := msgNotLogged;
  1258.         Exit;
  1259.     end;
  1260.     Client.CurCmdType := ftpcCDUP;
  1261.     Params := '..';
  1262.     CommandChangeDir(Client, Keyword, Params, Answer);
  1263. end;
  1266. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1267. procedure TFtpServer.CommandCWD(
  1268.     Client      : TFtpCtrlSocket;
  1269.     var Keyword : TFtpString;
  1270.     var Params  : TFtpString;
  1271.     var Answer  : TFtpString);
  1272. begin
  1273.     if Client.FtpState <> ftpcReady then begin
  1274.         Answer := msgNotLogged;
  1275.         Exit;
  1276.     end;
  1277.     Client.CurCmdType    := ftpcCWD;
  1278.     CommandChangeDir(Client, Keyword, Params, Answer);
  1279. end;
  1282. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1283. function SlashesToBackSlashes(const S : String) : String;
  1284. var
  1285.     I : Integer;
  1286. begin
  1287.     Result := S;
  1288.     for I := 1 to Length(Result) do begin
  1289.         if Result [I] = '/' then
  1290.             Result[I] := '';
  1291.     end;
  1292. end;
  1295. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1296. function BackSlashesToSlashes(const S : String) : String;
  1297. var
  1298.     I : Integer;
  1299. begin
  1300.     Result := S;
  1301.     for I := 1 to Length(Result) do begin
  1302.         if Result [I] = '' then
  1303.             Result[I] := '/';
  1304.     end;
  1305. end;
  1308. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1309. procedure TFtpServer.CommandChangeDir(
  1310.     Client      : TFtpCtrlSocket;
  1311.     var Keyword : TFtpString;
  1312.     var Params  : TFtpString;
  1313.     var Answer  : TFtpString);
  1314. var
  1315.     Allowed : Boolean;
  1316.     OldDir  : String;
  1317. begin
  1318.     OldDir := Client.Directory;
  1319.     try
  1320.         Params               := SlashesToBackSlashes(Params);
  1321.         Client.Directory     := Trim(Params);
  1322.         Allowed              := TRUE;
  1323.         TriggerChangeDirectory(Client, Client.Directory, Allowed);
  1324.         if Allowed then
  1325.             Answer           := Format(msgCWDSuccess,
  1326.                                        [BackSlashesToSlashes(Client.Directory)])
  1327.         else begin
  1328.             Client.Directory := OldDir;
  1329.             Answer           := Format(msgCWDFailed, ['No permission']);
  1330.         end;
  1331.     except
  1332.         on E:Exception do begin
  1333.             Client.Directory := OldDir;
  1334.             Answer           := Format(msgCWDFailed, [E.Message]);
  1335.         end;
  1336.     end;
  1337. end;
  1340. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1341. procedure TFtpServer.CommandXPWD(
  1342.     Client      : TFtpCtrlSocket;
  1343.     var Keyword : TFtpString;
  1344.     var Params  : TFtpString;
  1345.     var Answer  : TFtpString);
  1346. begin
  1347.     if Client.FtpState <> ftpcReady then begin
  1348.         Answer := msgNotLogged;
  1349.         Exit;
  1350.     end;
  1352.     Client.CurCmdType := ftpcXPWD;
  1353.     Answer            := Format(msgPWDSuccess,
  1354.                                 [BackSlashesToSlashes(Client.Directory)]);
  1355. end;
  1358. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1359. procedure TFtpServer.CommandPWD(
  1360.     Client      : TFtpCtrlSocket;
  1361.     var Keyword : TFtpString;
  1362.     var Params  : TFtpString;
  1363.     var Answer  : TFtpString);
  1364. begin
  1365.     if Client.FtpState <> ftpcReady then begin
  1366.         Answer := msgNotLogged;
  1367.         Exit;
  1368.     end;
  1370.     Client.CurCmdType := ftpcPWD;
  1371.     Answer            := Format(msgPWDSuccess,
  1372.                                 [BackSlashesToSlashes(Client.Directory)]);
  1373. end;
  1376. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1377. procedure TFtpServer.CommandQUIT(
  1378.     Client      : TFtpCtrlSocket;
  1379.     var Keyword : TFtpString;
  1380.     var Params  : TFtpString;
  1381.     var Answer  : TFtpString);
  1382. begin
  1383.     Client.CurCmdType := ftpcQUIT;
  1384.     Answer            := msgQuit;
  1385.     PostMessage(FWindowHandle, WM_FTPSRV_CLOSE_REQUEST, 0, LongInt(Client));
  1386. end;
  1389. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1390. function GetInteger(var I : Integer; const Src : String) : LongInt;
  1391. begin
  1392.     { Skip leading white spaces }
  1393.     while (I <= Length(Src)) and (Src[I] in [' ' , #9]) do
  1394.         Inc(I);
  1395.     Result := 0;
  1396.     while (I <= Length(Src)) and (Src[I] in ['0'..'9']) do begin
  1397.         Result := Result * 10 + Ord(Src[I]) - Ord('0');
  1398.         Inc(I);
  1399.     end;
  1400.     { Skip trailing white spaces }
  1401.     while (I <= Length(Src)) and (Src[I] in [' ' , #9]) do
  1402.         Inc(I);
  1403.     { Check if end of string of comma. If not, error, returns -1 }
  1404.     if I <= Length(Src) then begin
  1405.         if Src[I] = ',' then
  1406.             Inc(I)        { skip comma           }
  1407.         else
  1408.             raise Exception.Create('unexpected char'); { error, must be comma }
  1409.     end;
  1410. end;
  1413. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1414. procedure TFtpServer.CommandPORT(
  1415.     Client      : TFtpCtrlSocket;
  1416.     var Keyword : TFtpString;
  1417.     var Params  : TFtpString;
  1418.     var Answer  : TFtpString);
  1419. var
  1420.     I : Integer;
  1421.     N : LongInt;
  1422. begin
  1423.     if Client.FtpState <> ftpcReady then begin
  1424.         Answer := msgNotLogged;
  1425.         Exit;
  1426.     end;
  1428.     try
  1429.         Client.CurCmdType := ftpcPORT;
  1430.         I                 := 1;
  1431.         Client.DataAddr   := IntToStr(GetInteger(I, Params));
  1432.         Client.DataAddr   := Client.DataAddr + '.' + IntToStr(GetInteger(I, Params));
  1433.         Client.DataAddr   := Client.DataAddr + '.' + IntToStr(GetInteger(I, Params));
  1434.         Client.DataAddr   := Client.DataAddr + '.' + IntToStr(GetInteger(I, Params));
  1435.         N := GetInteger(I, Params);
  1436.         N := (N shl 8) + GetInteger(I, Params);
  1437.         Client.DataPort := IntToStr(N);
  1438.         Answer := msgPortSuccess;
  1439.     except
  1440.         Answer := msgPortFailed;
  1441.     end;
  1442. end;
  1445. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1446. procedure TFtpServer.CommandSTOR(
  1447.     Client      : TFtpCtrlSocket;
  1448.     var Keyword : TFtpString;
  1449.     var Params  : TFtpString;
  1450.     var Answer  : TFtpString);
  1451. var
  1452.     Allowed  : Boolean;
  1453.     FilePath : TFtpString;
  1454. begin
  1455.     if Client.FtpState <> ftpcReady then begin
  1456.         Answer := msgNotLogged;
  1457.         Exit;
  1458.     end;
  1460.     try
  1461.         Client.CurCmdType       := ftpcSTOR;
  1462.         Client.FileName         := SlashesToBackSlashes(Params);
  1463.         Client.HasOpenedFile    := FALSE;
  1464.         Client.AbortingTransfer := FALSE;
  1465.         Client.TransferError    := 'Transfer Ok';
  1466.         Allowed                 := TRUE;
  1467.         FilePath                := BuildFilePath(Client.Directory, Client.FileName);
  1468.         TriggerValidatePut(Client, FilePath, Allowed);
  1469.         if not Allowed then begin
  1470.             Answer := msgStorDisabled;
  1471.             Exit;
  1472.         end;
  1473.         Client.FilePath := FilePath;
  1474.         if Client.PassiveMode then begin
  1475.             Client.DataSocket.OnSessionConnected  := ClientStorSessionConnected;
  1476.             Client.DataSocket.OnSessionClosed     := ClientStorSessionClosed;
  1477.             Client.DataSocket.OnDataAvailable     := ClientStorDataAvailable;
  1478.             Client.DataSocket.OnDataSent          := nil;
  1479.             if Client.PassiveConnected then
  1480.                 Client.DataSocket.OnSessionConnected(Client.DataSocket, 0)
  1481.             else
  1482.                 Client.PassiveStart := TRUE;
  1483.         end
  1484.         else begin
  1485.             Client.DataSocket.Proto               := 'tcp';
  1486.             Client.DataSocket.Addr                := Client.DataAddr;
  1487.             Client.DataSocket.Port                := Client.DataPort;
  1488.             Client.DataSocket.OnSessionConnected  := ClientStorSessionConnected;
  1489.             Client.DataSocket.OnSessionClosed     := ClientStorSessionClosed;
  1490.             Client.DataSocket.OnDataAvailable     := ClientStorDataAvailable;
  1491.             Client.DataSocket.OnDataSent          := nil;
  1492.             Client.DataSocket.LingerOnOff         := wsLingerOff;
  1493.             Client.DataSocket.LingerTimeout       := 0;
  1494.             Client.DataSocket.Connect;
  1495.         end;
  1496.         Answer := Format(msgStorSuccess, [Params]);
  1497.     except
  1498.         on E:Exception do begin
  1499.             Answer := Format(msgStorFailed, [E.Message]);
  1500.         end;
  1501.     end;
  1502. end;
  1505. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1506. procedure TFtpServer.ClientStorSessionConnected(Sender : TObject; Error : Word);
  1507. var
  1508.     Client      : TFtpCtrlSocket;
  1509.     Data        : TWSocket;
  1510. begin
  1511.     Data                     := TWSocket(Sender);
  1512.     Client                   := TFtpCtrlSocket(Data.Owner);
  1513.     Client.DataSessionActive := TRUE;
  1514.     Client.PassiveMode       := FALSE;
  1515.     TriggerStorSessionConnected(Client, Data, Error);
  1516. end;
  1519. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1520. procedure TFtpServer.ClientStorSessionClosed(Sender : TObject; Error : Word);
  1521. var
  1522.     Client      : TFtpCtrlSocket;
  1523.     Data        : TWSocket;
  1524. begin
  1525.     Data                     := TWSocket(Sender);
  1526.     Client                   := TFtpCtrlSocket(Data.Owner);
  1527.     Client.DataSessionActive := FALSE;
  1528.     Client.PassiveStart      := FALSE;
  1529.     Client.PassiveConnected  := FALSE;
  1530.     Client.RestartPos        := 0;
  1531.     { Reset data port to standard value }
  1532.     Client.DataPort          := 'ftp-data';
  1534.     { If we had opened a data stream ourself, then close it }
  1535.     if Client.HasOpenedFile then begin
  1536.         if Assigned(Client.DataStream) then
  1537.             Client.DataStream.Destroy;
  1538.         Client.DataStream    := nil;
  1539.         Client.HasOpenedFile := FALSE;
  1540.     end;
  1542.     TriggerStorSessionClosed(Client, Data, Error);
  1544.     if Client.CurCmdType = ftpcSTOR then begin
  1545.         if Client.AbortingTransfer then
  1546.             SendAnswer(Client, Format(msgStorAborted, [Client.TransferError]))
  1547.         else if Error = 0 then
  1548.             SendAnswer(Client, msgStorOk)
  1549.         else
  1550.             SendAnswer(Client, Format(msgStorError, [Error]));
  1551.     end
  1552.     else if Client.CurCmdType = ftpcAPPE then begin
  1553.         if Client.AbortingTransfer then
  1554.             SendAnswer(Client, Format(msgAppeAborted, [Client.TransferError]))
  1555.         else if Error = 0 then
  1556.             SendAnswer(Client, msgAppeOk)
  1557.         else
  1558.             SendAnswer(Client, Format(msgAppeError, [Error]));
  1559.     end
  1560.     else { Should never comes here }
  1561.         raise Exception.Create('Program error in ClientStorSessionClosed');
  1562. end;
  1565. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1566. procedure TFtpServer.ClientStorDataAvailable(Sender: TObject; Error : word);
  1567. var
  1568.     Len    : Integer;
  1569.     Client : TFtpCtrlSocket;
  1570.     Data   : TWSocket;
  1571. begin
  1572.     Data   := TWSocket(Sender);
  1573.     Client := TFtpCtrlSocket(Data.Owner);
  1574.     Len    := Data.Receive(Client.RcvBuf, Client.RcvSize);
  1575.     if Len <= 0 then
  1576.         Exit;
  1578.     if Client.AbortingTransfer then
  1579.         Exit;
  1581.     try
  1582.         { Trigger the user event for the received data }
  1583.         TriggerStorDataAvailable(Client, Data, Client.RcvBuf, Len, Error);
  1585.         { We need to open a datastream if not already done and a FilePath }
  1586.         { exists (the component user can have nullified the FilePath      }
  1587.         if (not Client.HasOpenedFile) and
  1588.            (Length(Client.FilePath) > 0) and
  1589.            (not Assigned(Client.DataStream)) then begin
  1590.             { Use different file modes for APPE vs STOR }
  1591.             if (Client.CurCmdType = ftpcAPPE) and
  1592.                (GetFileSize(Client.FilePath) > -1) then
  1593.                 Client.DataStream    := TFileStream.Create(Client.FilePath,
  1594.                                         fmOpenReadWrite or fmShareDenyWrite)
  1595.             else
  1596.                 Client.DataStream    := TFileStream.Create(Client.FilePath,
  1597.                                         fmCreate);
  1598.             Client.DataStream.Seek(Client.RestartPos, soFromBeginning);
  1599.             Client.HasOpenedFile := TRUE;
  1600.         end;
  1602.         { If we have a DataStream, then we need to write the data }
  1603.         if Assigned(Client.DataStream) then
  1604.             Client.DataStream.WriteBuffer(Client.RcvBuf^, Len);
  1605.     except
  1606.         { An exception occured, so we abort the transfer }
  1607.         on E:Exception do begin
  1608.             Client.TransferError    := E.Message;
  1609.             Client.AbortingTransfer := TRUE;
  1610.             PostMessage(FWindowHandle, WM_FTPSRV_ABORT_TRANSFER, 0, LongInt(Data));
  1611.         end;
  1612.     end;
  1613. end;
  1616. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1617. function BuildFilePath(
  1618.     const Directory : String;
  1619.     FileName        : String) : String;
  1620. var
  1621.     Drive : String;
  1622.     Path  : String;
  1623. begin
  1624.     FileName := SlashesToBackSlashes(FileName);
  1625.     if IsUNC(FileName) then
  1626.         Result := FileName
  1627.     else if IsUNC(Directory) then begin
  1628.         if (Length(FileName) > 0) and (FileName[1] = '') then
  1629.             Result := ExtractFileDrive(Directory) + FileName
  1630.         else
  1631.             Result := Directory + FileName;
  1632.     end
  1633.     else begin
  1634.         if (Length(FileName) > 1) and (FileName[2] = ':') then begin
  1635.             Drive := UpperCase(Copy(FileName, 1, 2));
  1636.             Path  := Copy(FileName, 3, Length(FileName));
  1637.         end
  1638.         else begin
  1639.             Drive := Copy(Directory, 1, 2);
  1640.             Path  := FileName;
  1641.         end;
  1643.         if (Length(Path) > 0) and (Path[1] = '') then
  1644.             Result := Drive + Path
  1645.         else begin
  1646.             if Drive <> Copy(Directory, 1, 2) then
  1647.                 raise Exception.Create('No current dir for ''' + Drive + '''');
  1648.             Result := Directory + Path;
  1649.         end;
  1650.     end;
  1651. end;
  1654. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1655. procedure TFtpServer.CommandRETR(
  1656.     Client      : TFtpCtrlSocket;
  1657.     var Keyword : TFtpString;
  1658.     var Params  : TFtpString;
  1659.     var Answer  : TFtpString);
  1660. var
  1661.     Allowed  : Boolean;
  1662.     FilePath : TFtpString;
  1663. begin
  1664.     if Client.FtpState <> ftpcReady then begin
  1665.         Answer := msgNotLogged;
  1666.         Exit;
  1667.     end;
  1669.     try
  1670.         Client.CurCmdType    := ftpcRETR;
  1671.         Client.HasOpenedFile := FALSE;
  1672.         Client.FileName      := SlashesToBackSlashes(Params);
  1673.         Allowed              := TRUE;
  1674.         FilePath             := BuildFilePath(Client.Directory, Client.FileName);
  1675.         TriggerValidateGet(Client, FilePath, Allowed);
  1676.         if not Allowed then begin
  1677.             Answer := msgRetrDisabled;
  1678.             Exit;
  1679.         end;
  1680.         Client.FilePath := FilePath;
  1681.         Answer          := Format(msgRetrSuccess, [Params]);
  1682.         StartSendData(Client);
  1683.     except
  1684.         on E:Exception do begin
  1685.             Answer := Format(msgRetrFailed, [E.Message]);
  1686.         end;
  1687.     end;
  1688. end;
  1691. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1692. procedure TFtpServer.ClientPassiveSessionAvailable(Sender : TObject; Error : Word);
  1693. var
  1694.     HSocket : TSocket;
  1695.     Client  : TFtpCtrlSocket;
  1696.     Data    : TWSocket;
  1697. begin
  1698.     Data    := TWSocket(Sender);
  1699.     Client  := TFtpCtrlSocket(Data.Owner);
  1700.     HSocket := Data.Accept;
  1701.     Data.OnSessionClosed := nil;
  1702.     Data.Close;   { We don't need to listen any more }
  1704.     if Client.CurCmdType in [ftpcSTOR, ftpcAPPE] then begin
  1705.         Client.DataSocket.OnSessionConnected  := ClientStorSessionConnected;
  1706.         Client.DataSocket.OnSessionClosed     := ClientStorSessionClosed;
  1707.         Client.DataSocket.OnDataAvailable     := ClientStorDataAvailable;
  1708.         Client.DataSocket.OnDataSent          := nil;
  1709.     end
  1710.     else if Client.CurCmdType in [ftpcRETR, ftpcLIST, ftpcNLST] then begin
  1711.         Client.DataSocket.OnSessionConnected  := ClientRetrSessionConnected;
  1712.         Client.DataSocket.OnSessionClosed     := ClientRetrSessionClosed;
  1713.         Client.DataSocket.OnDataAvailable     := nil;
  1714.         Client.DataSocket.OnDataSent          := ClientRetrDataSent;
  1715.     end
  1716.     else begin
  1717.         Client.DataSocket.OnSessionConnected  := nil;
  1718.         Client.DataSocket.OnSessionClosed     := nil;
  1719.         Client.DataSocket.OnDataAvailable     := nil;
  1720.         Client.DataSocket.OnDataSent          := nil;
  1721.     end;
  1722.     Client.DataSocket.LingerOnOff             := wsLingerOff;
  1723.     Client.DataSocket.LingerTimeout           := 0;
  1724.     Client.DataSocket.HSocket                 := HSocket;
  1725.     Client.PassiveConnected                   := TRUE;
  1726.     if Client.PassiveStart then
  1727.         Client.DataSocket.OnSessionConnected(Client.DataSocket, 0);
  1728. end;
  1731. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1732. procedure TFtpServer.StartSendData(Client : TFtpCtrlSocket);
  1733. begin
  1734.     Client.AbortingTransfer              := FALSE;
  1735.     Client.DataSent                      := FALSE;
  1736.     Client.TransferError                 := 'Transfer Ok';
  1737.     if Client.PassiveMode then begin
  1738.         Client.DataSocket.OnSessionConnected  := ClientRetrSessionConnected;
  1739.         Client.DataSocket.OnSessionClosed     := ClientRetrSessionClosed;
  1740.         Client.DataSocket.OnDataAvailable     := nil;
  1741.         Client.DataSocket.OnDataSent          := ClientRetrDataSent;
  1742.         if Client.PassiveConnected then
  1743.             Client.DataSocket.OnSessionConnected(Client.DataSocket, 0)
  1744.         else
  1745.             Client.PassiveStart := TRUE;
  1746.     end
  1747.     else begin
  1748.         Client.DataSocket.Close;
  1749.         Client.DataSocket.Proto              := 'tcp';
  1750.         Client.DataSocket.Addr               := Client.DataAddr;
  1751.         Client.DataSocket.Port               := Client.DataPort;
  1752.         Client.DataSocket.OnSessionConnected := ClientRetrSessionConnected;
  1753.         Client.DataSocket.OnSessionClosed    := ClientRetrSessionClosed;
  1754.         Client.DataSocket.OnDataAvailable    := nil;
  1755.         Client.DataSocket.OnDataSent         := ClientRetrDataSent;
  1756.         Client.DataSocket.LingerOnOff        := wsLingerOff;
  1757.         Client.DataSocket.LingerTimeout      := 0;
  1758.         Client.DataSocket.Connect;
  1759.     end;
  1760. end;
  1763. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1764. procedure TFtpServer.ClientRetrSessionConnected(Sender : TObject; Error : Word);
  1765. var
  1766.     Client      : TFtpCtrlSocket;
  1767.     Data        : TWSocket;
  1768. begin
  1769.     Data                     := TWSocket(Sender);
  1770.     Client                   := TFtpCtrlSocket(Data.Owner);
  1771.     Client.DataSessionActive := TRUE;
  1772.     Client.PassiveMode       := FALSE;
  1774.     try
  1775.         TriggerRetrSessionConnected(Client, Data, Error);
  1777.         { We need to open a datastream if not already done and a FilePath }
  1778.         { exists the component user can have nullified the FilePath or    }
  1779.         { created his own data stream (virtual file feature)              }
  1780.         if (not Client.HasOpenedFile) and
  1781.            (Length(Client.FilePath) > 0) and
  1782.            (not Assigned(Client.DataStream)) then begin
  1783.             Client.DataStream    := TFileStream.Create(Client.FilePath,
  1784.                                                        fmOpenRead + fmShareDenyNone);
  1785.             Client.DataStream.Seek(Client.RestartPos, soFromBeginning);
  1786.             Client.HasOpenedFile := TRUE;
  1787.         end;
  1788.     except
  1789.         on E:Exception do begin
  1790.             Client.AbortingTransfer := TRUE;
  1791.             Client.TransferError    := E.Message;
  1792.             PostMessage(FWindowHandle, WM_FTPSRV_ABORT_TRANSFER,
  1793.                         0, LongInt(Data));
  1794.             Exit;
  1795.         end;
  1796.     end;
  1798.     SendNextDataChunk(Client, Data);
  1799. end;
  1802. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1803. procedure TFtpServer.ClientRetrSessionClosed(Sender : TObject; Error : Word);
  1804. var
  1805.     Client      : TFtpCtrlSocket;
  1806.     Data        : TWSocket;
  1807. begin
  1808.     Data                     := TWSocket(Sender);
  1809.     Client                   := TFtpCtrlSocket(Data.Owner);
  1810.     Client.DataSessionActive := FALSE;
  1811.     Client.PassiveStart      := FALSE;
  1812.     Client.PassiveConnected  := FALSE;
  1813.     Client.RestartPos        := 0;
  1814.     { Reset data port to standard value }
  1815.     Client.DataPort          := 'ftp-data';
  1817.     { If we had opened a data stream ourself, then close it }
  1818.     if Client.HasOpenedFile then begin
  1819.         if Assigned(Client.DataStream) then begin
  1820.             Client.DataStream.Destroy;
  1821.         end;
  1822.         Client.DataStream    := nil;
  1823.         Client.HasOpenedFile := FALSE;
  1824.     end;
  1826.     if Client.AbortingTransfer then
  1827.         SendAnswer(Client, Format(msgRetrFailed, [Client.TransferError]))
  1828.     else if Error <> 0 then
  1829.         SendAnswer(Client, Format(msgRetrFailed, ['Error #' + IntToStr(Error)]))
  1830.     else
  1831.         SendAnswer(Client, msgRetrOk);
  1833.     TriggerRetrSessionClosed(Client, Data, Error);
  1834. end;
  1837. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1838. procedure TFtpServer.SendNextDataChunk(
  1839.     Client : TFtpCtrlSocket;
  1840.     Data   : TWSocket);
  1841. var
  1842.     Count : LongInt;
  1843. begin
  1844.     try
  1845.         if Assigned(Client.DataStream) then
  1846.             Count := Client.DataStream.Read(Client.RcvBuf^, Client.RcvSize)
  1847.         else
  1848.             Count := 0;
  1850.         if Count > 0 then begin
  1851.             Client.ByteCount := Client.ByteCount + Count;
  1852.             Data.Send(Client.RcvBuf, Count);
  1853.         end
  1854.         else begin { EOF }
  1855.             if not Client.DataSent then begin
  1856.                 Client.DataSent := TRUE;
  1857.                 PostMessage(Handle, WM_FTPSRV_CLOSE_DATA, 0, LongInt(Data));
  1858.             end;
  1859.         end;
  1860.     except
  1861.         { An exception occured, so we abort the transfer }
  1862.         on E:Exception do begin
  1863.             Client.TransferError    := E.Message;
  1864.             Client.AbortingTransfer := TRUE;
  1865.             PostMessage(FWindowHandle, WM_FTPSRV_ABORT_TRANSFER, 0, LongInt(Data));
  1866.         end;
  1867.     end;
  1868. end;
  1871. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1872. procedure TFtpServer.ClientRetrDataSent(Sender : TObject; Error : Word);
  1873. var
  1874.     Client : TFtpCtrlSocket;
  1875.     Data   : TWSocket;
  1876. begin
  1877.     Data   := TWSocket(Sender);
  1878.     Client := TFtpCtrlSocket(Data.Owner);
  1880.     if Client.AbortingTransfer then
  1881.         Exit;
  1883.     try
  1884.         { Trigger the user event for the received data }
  1885.         TriggerRetrDataSent(Client, Data, Error);
  1886.         if Error <> 0 then
  1887.             raise Exception.Create('Send: error #' + IntToStr(Error));
  1888.         SendNextDataChunk(Client, Data);
  1889.     except
  1890.         { An exception occured, so we abort the transfer }
  1891.         on E:Exception do begin
  1892.             Client.TransferError    := E.Message;
  1893.             Client.AbortingTransfer := TRUE;
  1894.             SendAnswer(Client, Format(msgRetrAborted, [Client.TransferError]));
  1895.             PostMessage(FWindowHandle, WM_FTPSRV_ABORT_TRANSFER, 0, LongInt(Data));
  1896.         end;
  1897.     end;
  1898. end;
  1901. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1902. procedure TFtpServer.CommandSYST(
  1903.     Client      : TFtpCtrlSocket;
  1904.     var Keyword : TFtpString;
  1905.     var Params  : TFtpString;
  1906.     var Answer  : TFtpString);
  1907. begin
  1908.     if Client.FtpState <> ftpcReady then begin
  1909.         Answer := msgNotLogged;
  1910.         Exit;
  1911.     end;
  1913.     Client.CurCmdType := ftpcSYST;
  1914.     Answer            := msgSystem;
  1915. end;
  1918. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1919. procedure TFtpServer.CommandDirectory(
  1920.     Client      : TFtpCtrlSocket;
  1921.     var Keyword : TFtpString;
  1922.     var Params  : TFtpString;
  1923.     var Answer  : TFtpString;
  1924.     Detailed    : Boolean);
  1925. begin
  1926.     if Assigned(Client.DataStream) then begin
  1927.         Client.DataStream.Destroy;
  1928.         Client.DataStream := nil;
  1929.     end;
  1931.     try
  1932.         Params := SlashesToBackSlashes(Params);
  1933.         TriggerBuildDirectory(Client, Params, Detailed);
  1934.         if not Assigned(Client.DataStream) then begin
  1935.             Client.DataStream    := TMemoryStream.Create;
  1936.             Client.HasOpenedFile := TRUE;
  1937.             BuildDirectory(Client, Params, Client.DataStream, Detailed);
  1938.             TriggerAlterDirectory(Client, Params, Detailed);
  1939.             Client.DataStream.Seek(0, 0);
  1940.         end;
  1941.         Client.FilePath := '';
  1942.         Answer := msgDirOpen;
  1943.         StartSendData(Client);
  1944.     except
  1945.         on E:Exception do begin
  1946.             Answer := Format(msgDirFailed, [E.Message])
  1947.         end;
  1948.     end;
  1949. end;
  1952. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1953. procedure TFtpServer.CommandLIST(
  1954.     Client      : TFtpCtrlSocket;
  1955.     var Keyword : TFtpString;
  1956.     var Params  : TFtpString;
  1957.     var Answer  : TFtpString);
  1958. begin
  1959.     if Client.FtpState <> ftpcReady then begin
  1960.         Answer := msgNotLogged;
  1961.         Exit;
  1962.     end;
  1964.     Client.CurCmdType := ftpcLIST;
  1965.     CommandDirectory(Client, KeyWord, Params, Answer, TRUE);
  1966. end;
  1969. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1970. procedure TFtpServer.CommandNLST(
  1971.     Client      : TFtpCtrlSocket;
  1972.     var Keyword : TFtpString;
  1973.     var Params  : TFtpString;
  1974.     var Answer  : TFtpString);
  1975. begin
  1976.     if Client.FtpState <> ftpcReady then begin
  1977.         Answer := msgNotLogged;
  1978.         Exit;
  1979.     end;
  1981.     Client.CurCmdType := ftpcNLST;
  1982.     CommandDirectory(Client, KeyWord, Params, Answer, FALSE);
  1983. end;
  1986. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  1987. function FormatUnixDirEntry(F : TSearchRec) : String;
  1988. var
  1989.     Attr : String;
  1990.     Ext  : String;
  1991.     Day, Month, Year : Integer;
  1992.     Hour, Min        : Integer;
  1993. const
  1994.     StrMonth : array [1..12] of String =
  1995.         ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
  1996.          'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
  1997. begin
  1998.     if ((F.Attr and faVolumeID) <> 0) or
  1999.        ((F.Attr and faHidden)   <> 0) then begin
  2000.         { Ignore hidden files and volume ID entries }
  2001.         Result := '';
  2002.         Exit;
  2003.     end;
  2005.     Attr := '-rw-rw-rw-';
  2006.     if (F.Attr and faDirectory) <> 0 then
  2007.         Attr[1] := 'd';
  2009.     if (F.Attr and faReadOnly) <> 0 then begin
  2010.         Attr[3] := '-';
  2011.         Attr[6] := '-';
  2012.         Attr[9] := '-';
  2013.     end;
  2015.     Ext := UpperCase(ExtractFileExt(F.Name));
  2016.     if (Ext = '.EXE') or (Ext = '.COM') or (Ext = '.BAT') then begin
  2017.         Attr[4]  := 'x';
  2018.         Attr[7]  := 'x';
  2019.         Attr[10] := 'x';
  2020.     end;
  2022.     Day   := (HIWORD(F.Time) and $1F);
  2023.     Month := ((HIWORD(F.Time) shr 5) and $0F);
  2024.     Year  := ((HIWORD(F.Time) shr 9) and $3F) + 1980;
  2025. {   Sec   := ((F.Time and $1F) shl 1); }
  2026.     Min   := ((F.Time shr 5) and $3F);
  2027.     Hour  := ((F.Time shr 11) and $1F);
  2029.     Result := Attr + '   1 ftp      ftp  ' + Format('%11d ', [F.Size]);
  2031.     Result := Result + Format('%s %2.2d ', [StrMonth[Month], Day]);
  2032.     if Year = ThisYear then
  2033.         Result := Result + Format('%2.2d:%2.2d ', [Hour, Min])
  2034.     else
  2035.         Result := Result + Format('%5d ', [Year]);
  2037.     Result := Result + F.Name + #13#10;
  2038. end;
  2041. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  2042. procedure TFtpServer.BuildDirectory(
  2043.     Client     : TFtpCtrlSocket;
  2044.     var Params : TFtpString;
  2045.     Stream     : TStream;
  2046.     Detailed   : Boolean);
  2047. var
  2048.     F      : TSearchRec;
  2049.     Path   : String;
  2050.     Status : Integer;
  2051.     Buf    : String;
  2052. begin
  2053.     DecodeDate(Now, ThisYear, ThisMonth, ThisDay);
  2055.     if Params = '' then
  2056.         Path := Client.Directory + '*.*'
  2057.     else
  2058.         Path := BuildFilePath(Client.Directory, Params);
  2060.     if Path[Length(Path)] = '' then
  2061.         Path := Path + '*.*';
  2063.     Status := FindFirst(Path, faAnyFile, F);
  2064.     while Status = 0 do begin
  2065.         if Detailed then
  2066.             Buf := FormatUnixDirEntry(F)
  2067.         else
  2068.             Buf := F.Name + #13#10;
  2069.         if Length(Buf) > 0 then
  2070.             Stream.Write(Buf[1], Length(Buf));
  2071.         Status := FindNext(F);
  2072.     end;
  2073.     FindClose(F);
  2075.     if Stream.Size = 0 then begin
  2076.         Buf := Path + ' not found' + #13#10;
  2077.         Stream.Write(Buf[1], Length(Buf));
  2078.     end;
  2079. end;
  2082. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  2083. procedure TFtpServer.CommandTYPE(
  2084.     Client      : TFtpCtrlSocket;
  2085.     var Keyword : TFtpString;
  2086.     var Params  : TFtpString;
  2087.     var Answer  : TFtpString);
  2088. var
  2089.     Buf : String;
  2090. begin
  2091.     if Client.FtpState <> ftpcReady then begin
  2092.         Answer := msgNotLogged;
  2093.         Exit;
  2094.     end;
  2096.     Client.CurCmdType := ftpcTYPE;
  2097.     Buf := UpperCase(Trim(Params));
  2098.     if (Buf = 'A') or (Buf = 'I') then begin
  2099.         Answer            := Format(msgTypeOk, [Params]);
  2100.         Client.BinaryMode := (Buf = 'I');
  2101.     end
  2102.     else
  2103.         Answer := Format(msgTypeFailed, [Params]);
  2104. end;
  2107. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  2108. procedure TFtpServer.CommandDELE(
  2109.     Client      : TFtpCtrlSocket;
  2110.     var Keyword : TFtpString;
  2111.     var Params  : TFtpString;
  2112.     var Answer  : TFtpString);
  2113. var
  2114.     FileName : TFtpString;
  2115.     Allowed  : Boolean;
  2116. begin
  2117.     if Client.FtpState <> ftpcReady then begin
  2118.         Answer := msgNotLogged;
  2119.         Exit;
  2120.     end;
  2122.     Client.CurCmdType := ftpcDELE;
  2123.     FileName          := BuildFilePath(Client.Directory, Params);
  2124.     TriggerValidateDele(Client, FileName, Allowed);
  2125.     if not Allowed then begin
  2126.         Answer := msgDeleDisabled;
  2127.         Exit;
  2128.     end;
  2129.     if Params = '' then
  2130.         Answer := Format(msgDeleSyntax, [Params])
  2131.     else if FileExists(FileName) then begin
  2132.         if DeleteFile(FileName) then
  2133.             Answer := Format(msgDeleOk, [FileName])
  2134.         else
  2135.             Answer := Format(msgDeleFailed, [FileName]);
  2136.     end
  2137.     else
  2138.         Answer := Format(msgDeleNotExists, [FileName]);
  2139. end;
  2142. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  2143. procedure TFtpServer.CommandSIZE(
  2144.     Client      : TFtpCtrlSocket;
  2145.     var Keyword : TFtpString;
  2146.     var Params  : TFtpString;
  2147.     var Answer  : TFtpString);
  2148. var
  2149.     FileName : String;
  2150.     Size     : LongInt;
  2151. begin
  2152.     if Client.FtpState <> ftpcReady then begin
  2153.         Answer := msgNotLogged;
  2154.         Exit;
  2155.     end;
  2157.     Client.CurCmdType := ftpcSIZE;
  2158.     FileName          := BuildFilePath(Client.Directory, Params);
  2159.     if Params = '' then
  2160.         Answer := Format(msgSizeSyntax, [Params])
  2161.     else begin
  2162.         try
  2163.             Size := GetFileSize(FileName);
  2164.             if Size >= 0 then
  2165.                 Answer := Format(msgSizeOk, [Size])
  2166.             else
  2167.                 Answer := Format(msgSizeFailed, ['File not found'])
  2168.         except
  2169.             on E:Exception do begin
  2170.                 Answer := Format(msgSizeFailed, [E.Message])
  2171.             end;
  2172.         end;
  2173.     end;
  2174. end;
  2177. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  2178. procedure TFtpServer.CommandREST(
  2179.     Client      : TFtpCtrlSocket;
  2180.     var Keyword : TFtpString;
  2181.     var Params  : TFtpString;
  2182.     var Answer  : TFtpString);
  2183. begin
  2184.     if Client.FtpState <> ftpcReady then begin
  2185.         Answer := msgNotLogged;
  2186.         Exit;
  2187.     end;
  2189.     Client.CurCmdType := ftpcREST;
  2190.     try
  2191.         Client.RestartPos := StrToInt(Params);
  2192.         if Client.RestartPos <= 0 then begin
  2193.             Answer            := msgRestZero;
  2194.             Client.RestartPos := 0;
  2195.         end
  2196.         else
  2197.             Answer := Format(msgRestOk, [Client.RestartPos]);
  2198.     except
  2199.         on E:Exception do begin
  2200.             Answer            := Format(msgRestFailed, [E.Message]);
  2201.             Client.RestartPos := 0;
  2202.         end;
  2203.     end;
  2204. end;
  2207. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  2208. procedure TFtpServer.CommandRNFR(
  2209.     Client      : TFtpCtrlSocket;
  2210.     var Keyword : TFtpString;
  2211.     var Params  : TFtpString;
  2212.     var Answer  : TFtpString);
  2213. var
  2214.     FileName : String;
  2215. begin
  2216.     if Client.FtpState <> ftpcReady then begin
  2217.         Answer := msgNotLogged;
  2218.         Exit;
  2219.     end;
  2221.     Client.CurCmdType   := ftpcRNFR;
  2222.     FileName            := BuildFilePath(Client.Directory, Params);
  2223.     if Params = '' then
  2224.         Answer := Format(msgRnfrSyntax, [Params])
  2225.     else if FileExists(FileName) then begin
  2226.         Client.FromFileName := FileName;
  2227.         Answer              := Format(msgRnfrOk, [FileName])
  2228.     end
  2229.     else
  2230.         Answer := Format(msgRnfrNotExists, [FileName]);
  2231. end;
  2234. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  2235. procedure TFtpServer.CommandRNTO(
  2236.     Client      : TFtpCtrlSocket;
  2237.     var Keyword : TFtpString;
  2238.     var Params  : TFtpString;
  2239.     var Answer  : TFtpString);
  2240. var
  2241.     FileName : String;
  2242. begin
  2243.     if Client.FtpState <> ftpcReady then begin
  2244.         Answer := msgNotLogged;
  2245.         Exit;
  2246.     end;
  2248.     Client.CurCmdType := ftpcRNTO;
  2249.     FileName          := BuildFilePath(Client.Directory, Params);
  2250.     if Params = '' then
  2251.         Answer := Format(msgRntoSyntax, [Params])
  2252.     else if FileExists(FileName) then
  2253.         Answer := Format(msgRntoAlready, [FileName])
  2254.     else if not FileExists(Client.FromFileName) then
  2255.         Answer := Format(msgRntoNotExists, [Client.FromFileName])
  2256.     else begin
  2257.         Client.ToFileName := FileName;
  2258.         if RenameFile(Client.FromFileName, Client.ToFileName) then
  2259.             Answer := Format(msgRntoOk, [Client.FromFileName, Client.ToFileName])
  2260.         else
  2261.             Answer := Format(msgRntoFailed, [Client.FromFileName]);
  2262.     end;
  2263. end;
  2266. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  2267. procedure TFtpServer.CommandNOOP(
  2268.     Client      : TFtpCtrlSocket;
  2269.     var Keyword : TFtpString;
  2270.     var Params  : TFtpString;
  2271.     var Answer  : TFtpString);
  2272. begin
  2273.     Client.CurCmdType := ftpcNOOP;
  2274.     Answer            := Format(MsgNoopOk, [Params]);
  2275. end;
  2278. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  2279. procedure TFtpServer.CommandMKD(
  2280.     Client      : TFtpCtrlSocket;
  2281.     var Keyword : TFtpString;
  2282.     var Params  : TFtpString;
  2283.     var Answer  : TFtpString);
  2284. var
  2285.     FileName : String;
  2286.     Allowed  : Boolean;
  2287. begin
  2288.     if Client.FtpState <> ftpcReady then begin
  2289.         Answer := msgNotLogged;
  2290.         Exit;
  2291.     end;
  2293.     try
  2294.         Client.CurCmdType := ftpcMKD;
  2295.         FileName          := BuildFilePath(Client.Directory, Params);
  2296.         Allowed           := TRUE;
  2297.         TriggerMakeDirectory(Client, FileName, Allowed);
  2298.         if not Allowed then
  2299.             Answer := Format(msgMkdFailed, [FileName])
  2300.         else if Params = '' then
  2301.             Answer := Format(msgMkdSyntax, [Params])
  2302.         else if FileExists(FileName) then
  2303.             Answer := Format(msgMkdAlready, [FileName])
  2304.         else begin
  2305.             {$I-}
  2306.             MkDir(FileName);
  2307.             if IOResult = 0 then
  2308.                 Answer := Format(msgMkdOk, [FileName])
  2309.             else
  2310.                 Answer := Format(msgMkdFailed, [FileName]);
  2311.             {$I+}
  2312.         end;
  2313.     except
  2314.         on E:Exception do begin
  2315.             Answer := Format(msgMkdFailed, [E.Message])
  2316.         end;
  2317.     end;
  2318. end;
  2321. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  2322. procedure TFtpServer.CommandAPPE(
  2323.     Client      : TFtpCtrlSocket;
  2324.     var Keyword : TFtpString;
  2325.     var Params  : TFtpString;
  2326.     var Answer  : TFtpString);
  2327. var
  2328.     Allowed  : Boolean;
  2329.     FilePath : TFtpString;
  2330. begin
  2331.     if Client.FtpState <> ftpcReady then begin
  2332.         Answer := msgNotLogged;
  2333.         Exit;
  2334.     end;
  2336.     try
  2337.         Client.CurCmdType       := ftpcAPPE;
  2338.         Client.FileName         := SlashesToBackSlashes(Params);
  2339.         Client.HasOpenedFile    := FALSE;
  2340.         Client.AbortingTransfer := FALSE;
  2341.         Client.TransferError    := 'Transfer Ok';
  2342.         Allowed                 := TRUE;
  2343.         FilePath                := BuildFilePath(Client.Directory, Client.FileName);
  2344.         TriggerValidatePut(Client, FilePath, Allowed);
  2345.         if not Allowed then begin
  2346.             Answer := msgAppeDisabled;
  2347.             Exit;
  2348.         end;
  2349.         Client.FilePath := FilePath;
  2350.         if Client.PassiveMode then begin
  2351.             Client.DataSocket.OnSessionConnected  := ClientStorSessionConnected;
  2352.             Client.DataSocket.OnSessionClosed     := ClientStorSessionClosed;
  2353.             Client.DataSocket.OnDataAvailable     := ClientStorDataAvailable;
  2354.             Client.DataSocket.OnDataSent          := nil;
  2355.             if Client.PassiveConnected then
  2356.                 Client.DataSocket.OnSessionConnected(Client.DataSocket, 0)
  2357.             else
  2358.                 Client.PassiveStart := TRUE;
  2359.         end
  2360.         else begin
  2361.             Client.DataSocket.Proto               := 'tcp';
  2362.             Client.DataSocket.Addr                := Client.DataAddr;
  2363.             Client.DataSocket.Port                := Client.DataPort;
  2364.             Client.DataSocket.OnSessionConnected  := ClientStorSessionConnected;
  2365.             Client.DataSocket.OnSessionClosed     := ClientStorSessionClosed;
  2366.             Client.DataSocket.OnDataAvailable     := ClientStorDataAvailable;
  2367.             Client.DataSocket.OnDataSent          := nil;
  2368.             Client.DataSocket.LingerOnOff         := wsLingerOff;
  2369.             Client.DataSocket.LingerTimeout       := 0;
  2370.             Client.DataSocket.Connect;
  2371.         end;
  2372.             Client.RestartPos := GetFileSize(Client.FilePath);
  2373.             if Client.RestartPos < 0 then
  2374.                 Client.RestartPos := 0;
  2375.             Answer := Format(msgAppeReady, [Params,Client.RestartPos]);
  2376.     except
  2377.         on E:Exception do begin
  2378.             Answer := Format(msgAppeFailed, [E.Message]);
  2379.         end;
  2380.     end;
  2381. end;
  2384. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  2385. procedure TFtpServer.CommandSTRU(
  2386.     Client      : TFtpCtrlSocket;
  2387.     var Keyword : TFtpString;
  2388.     var Params  : TFtpString;
  2389.     var Answer  : TFtpString);
  2390. begin
  2391.     Client.CurCmdType := ftpcSTRU;
  2392.     Answer            := Format(MsgStruOk, [Params]);
  2393. end;
  2396. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  2397. function DirExists(Dir : String) : Boolean;
  2398. var
  2399.     F : TSearchRec;
  2400. begin
  2401.     Result := (FindFirst(Dir, faDirectory, F) = 0);
  2402.     FindClose(F);
  2403. end;
  2406. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  2407. procedure TFtpServer.CommandRMD(
  2408.     Client      : TFtpCtrlSocket;
  2409.     var Keyword : TFtpString;
  2410.     var Params  : TFtpString;
  2411.     var Answer  : TFtpString);
  2412. var
  2413.     FileName : String;
  2414. begin
  2415.     if Client.FtpState <> ftpcReady then begin
  2416.         Answer := msgNotLogged;
  2417.         Exit;
  2418.     end;
  2420.     Client.CurCmdType := ftpcRMD;
  2421.     FileName          := BuildFilePath(Client.Directory, Params);
  2422.     if Params = '' then
  2423.         Answer := Format(msgMkdSyntax, [Params])
  2424.     else if not DirExists(FileName) then
  2425.         Answer := Format(msgRmdNotExists, [FileName])
  2426.     else begin
  2427.         {$I-}
  2428.         RmDir(FileName);
  2429.         if IOResult = 0 then
  2430.             Answer := Format(msgRmdOk, [FileName])
  2431.         else
  2432.             Answer := Format(msgRmdFailed, [FileName]);
  2433.         {$I+}
  2434.     end;
  2435. end;
  2438. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  2439. procedure TFtpServer.CommandABOR(
  2440.     Client      : TFtpCtrlSocket;
  2441.     var Keyword : TFtpString;
  2442.     var Params  : TFtpString;
  2443.     var Answer  : TFtpString);
  2444. begin
  2445.     if Client.DataSocket.State = wsConnected then begin
  2446.         Client.TransferError    := 'ABORT requested by client';
  2447.         Client.AbortingTransfer := TRUE;
  2448.         Client.DataSocket.Close;
  2449.     end;
  2450.     Answer := msgAborOk;
  2451. end;
  2454. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  2455. procedure TFtpServer.CommandPASV(
  2456.     Client      : TFtpCtrlSocket;
  2457.     var Keyword : TFtpString;
  2458.     var Params  : TFtpString;
  2459.     var Answer  : TFtpString);
  2460. var
  2461.     saddr    : TSockAddrIn;
  2462.     saddrlen : Integer;
  2463.     DataPort : Integer;
  2464.     IPAddr   : TInAddr;
  2465. begin
  2466.     if Client.FtpState <> ftpcReady then begin
  2467.         Answer := msgNotLogged;
  2468.         Exit;
  2469.     end;
  2471.     try
  2472.         { Get our IP address from our control socket }
  2473.         saddrlen := SizeOf(saddr);
  2474.         Client.GetSockName(saddr, saddrlen);
  2475.         IPAddr   := saddr.sin_addr;
  2477.         Client.DataSocket.Close;
  2478.         Client.DataSocket.Addr  := '0.0.0.0';   { Any addr }
  2479.         Client.DataSocket.Port  := '0';         { Any port }
  2480.         Client.DataSocket.Proto := 'tcp';
  2481.         Client.DataSocket.OnSessionAvailable := ClientPassiveSessionAvailable;
  2482.         Client.DataSocket.OnSessionConnected := nil;
  2483.         Client.DataSocket.OnSessionClosed    := nil;
  2484.         Client.DataSocket.OnDataAvailable    := nil;
  2485.         Client.DataSocket.Listen;
  2486. {        if Client.DataSocket.Listen <> 0 then
  2487.             raise Exception.Create('Listen failed'); 18/11/98 }
  2489.         { Get the port assigned by winsock }
  2490.         saddrlen := SizeOf(saddr);
  2491.         Client.DataSocket.GetSockName(saddr, saddrlen);
  2492.         DataPort := WSocket_ntohs(saddr.sin_port);
  2494.         if Client.sin.sin_addr.s_addr = WSocket_htonl($7F000001) then
  2495.             Answer := Format(msgPasvLocal,
  2496.                           [HiByte(DataPort),
  2497.                            LoByte(DataPort)])
  2498.         else
  2499.             Answer := Format(msgPasvRemote,
  2500.                           [ord(IPAddr.S_un_b.s_b1),
  2501.                            ord(IPAddr.S_un_b.s_b2),
  2502.                            ord(IPAddr.S_un_b.s_b3),
  2503.                            ord(IPAddr.S_un_b.s_b4),
  2504.                            HiByte(DataPort),
  2505.                            LoByte(DataPort)]);
  2506.         Client.PassiveMode      := TRUE;
  2507.         Client.PassiveStart     := FALSE;
  2508.         Client.PassiveConnected := FALSE;
  2509.     except
  2510.         on E:Exception do begin
  2511.             Answer := Format(msgPasvExcept, [E.Message]);
  2512.             try
  2513.                 Client.DataSocket.Close;
  2514.             except
  2515.                 { Ignore any exception here }
  2516.             end;
  2517.         end;
  2518.     end;
  2519. end;
  2522. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  2524. end.