www.pudn.com > ftpsrv.zip > FTPSRV.PAS
{*_* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Author: François PIETTE
Description: TFtpServer class encapsulate the FTP protocol (server side)
See RFC-959 for a complete protocol description.
EMail: francois.piette@pophost.eunet.be
francois.piette@rtfm.be http://www.rtfm.be/fpiette
Creation: April 21, 1998
Version: 1.04
Support: Use the mailing list twsocket@rtfm.be See website for details.
Legal issues: Copyright (C) 1997, 1998 by François PIETTE
Rue de Grady 24, 4053 Embourg, Belgium. Fax: +32-4-365.74.56
This software is provided 'as-is', without any express or
implied warranty. In no event will the author be held liable
for any damages arising from the use of this software.
Permission is granted to anyone to use this software for any
purpose, including commercial applications, and to alter it
and redistribute it freely, subject to the following
restrictions:
1. The origin of this software must not be misrepresented,
you must not claim that you wrote the original software.
If you use this software in a product, an acknowledgment
in the product documentation would be appreciated but is
not required.
2. Altered source versions must be plainly marked as such, and
must not be misrepresented as being the original software.
3. This notice may not be removed or altered from any source
distribution.
4. You must register this software by sending a picture postcard
to the author. Use a nice stamp and mention your name, street
address, EMail address and any comment you like to say.
History:
Apr 29, 1998 V0.90 released for beta testing.
May 01, 1998 V0.92 Adapted for Delphi 1.0
May 03, 1998 V0.93 Adapted for Delphi 2.0 and C++Builder
May 04, 1998 V0.94 Use '/' or '\' as path delimiter. Expose only '/' to the
outside. Stripped any telnet options (IE send two !). Handled
absolute path. Implemented SIZE and REST commands.
Added support for UNC (not finished !)
May 06, 1998 V0.95 Corrected spurious 226 message on PASV mode STOR.
Made GetInteger retunrs a LongInt.
Use a LongInt for N in CommandPORT (needed for 16 bits)
Added slash substitution in BuildFilePath command.
Jul 09, 1998 V1.00 Adapted for Delphi 4, removed beta status.
Jul 21, 1998 V1.01 Added OnValidateDele event
Changed function to get file size (do not open the file)
Feb 14, 1999 V1.02 Replaced straight winsock call by indirect calls thru
wsocket (this provide runtime link to winsock DLL).
Mar 06, 1999 V1.03 Added code from Plegge, Steve to add
APPE, XMKD, KRMD and STRU commands support.
Jul 24, 1999 V1.04 Replaced msgStorDisabled value from '500 Cannot STOR.' to
'501 Permission Denied' because CuteFTP doesn't like error 500.
Suggested by Cedric Veilleux .
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
unit FtpSrv;
{$B-} { Enable partial boolean evaluation }
{$T-} { Untyped pointers }
{$IFNDEF VER80}
{$J+} { Allow typed constant to be modified }
{$ENDIF}
{$IFDEF VER110} { C++ Builder V3.0 }
{$ObjExportAll On}
{$ENDIF}
interface
uses
WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, Winsock, WSocket, FtpSrvC;
const
FtpServerVersion = 104;
CopyRight : String = ' TFtpServer (c) 1998 F. Piette V1.04 ';
WM_FTPSRV_CLOSE_REQUEST = WM_USER + 1;
WM_FTPSRV_CLIENT_CLOSED = WM_USER + 2;
WM_FTPSRV_ABORT_TRANSFER = WM_USER + 3;
WM_FTPSRV_CLOSE_DATA = WM_USER + 4;
type
FtpServerException = class(Exception);
{ Various Delphi and C++Builder version handle string parameter passed as var }
{ differently. To get application code compatible across all versions, we }
{ need to define our own string type. We use the larger we can with the given }
{ compiler version. btw: the 255 limit is not a problem because it applies to }
{ the command laines sent to the server and 255 should be enough except if }
{ you use incredibly long file names. }
{$IFDEF VER100} { Delphi 3 }
TFtpString = String;
{$ELSE} { All others }
TFtpString = String[255];
{$ENDIF}
TFtpCtrlSocketClass = class of TFtpCtrlSocket;
TFtpSrvAuthenticateEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
UserName : TFtpString;
Password : TFtpString;
var Authenticated : Boolean) of object;
TFtpSrvChangeDirectoryEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
Directory : TFtpString;
var Allowed : Boolean) of object;
TFtpSrvBuildDirectoryEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
var Directory : TFtpString;
Detailed : Boolean) of object;
TFtpSrvClientConnectEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
Error : Word) of object;
TFtpSrvDataSessionConnectedEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
Data : TWSocket;
Error : Word) of object;
TFtpSrvClientCommandEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString) of object;
TFtpSrvAnswerToClientEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
var Answer : TFtpString) of object;
TFtpSrvValidateXferEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
var FilePath : TFtpString;
var Allowed : Boolean) of object;
TFtpSrvDataAvailableEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
Data : TWSocket;
Buf : PChar;
Len : LongInt;
Error : Word) of object;
TFtpSrvRetrDataSentEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
Data : TWSocket;
Error : Word) of object;
TFtpSrvCommandProc = procedure (Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString) of object;
TFtpSrvCommandTableItem = record
KeyWord : String;
Proc : TFtpSrvCommandProc;
end;
TFtpServer = class(TComponent)
protected
FPort : String;
FBanner : String;
FServSocket : TWSocket;
FWindowHandle : HWND;
FClientClass : TFtpCtrlSocketClass;
FClientList : TList;
FClientNum : LongInt;
FMaxClients : LongInt;
FCmdTable : array [0..31] of TFtpSrvCommandTableItem;
FLastCmd : Integer;
FUserData : LongInt; { Reserved for component user }
FOnStart : TNotifyEvent;
FOnStop : TNotifyEvent;
FOnAuthenticate : TFtpSrvAuthenticateEvent;
FOnClientConnect : TFtpSrvClientConnectEvent;
FOnClientDisconnect : TFtpSrvClientConnectEvent;
FOnClientCommand : TFtpSrvClientCommandEvent;
FOnAnswerToClient : TFtpSrvAnswerToClientEvent;
FOnChangeDirectory : TFtpSrvChangeDirectoryEvent;
FOnMakeDirectory : TFtpSrvChangeDirectoryEvent;
FOnBuildDirectory : TFtpSrvBuildDirectoryEvent;
FOnAlterDirectory : TFtpSrvBuildDirectoryEvent;
FOnValidatePut : TFtpSrvValidateXferEvent;
FOnValidateDele : TFtpSrvValidateXferEvent;
FOnStorSessionConnected : TFtpSrvDataSessionConnectedEvent;
FOnStorSessionClosed : TFtpSrvDataSessionConnectedEvent;
FOnStorDataAvailable : TFtpSrvDataAvailableEvent;
FOnValidateGet : TFtpSrvValidateXferEvent;
FOnRetrSessionConnected : TFtpSrvDataSessionConnectedEvent;
FOnRetrSessionClosed : TFtpSrvDataSessionConnectedEvent;
FOnRetrDataSent : TFtpSrvRetrDataSentEvent;
procedure Notification(AComponent: TComponent; operation: TOperation); override;
procedure ServSocketSessionAvailable(Sender : TObject; Error : Word);
procedure ServSocketStateChange(Sender : TObject; OldState, NewState : TSocketState);
procedure ClientSessionClosed(Sender : TObject; Error : Word);
procedure ClientDataSent(Sender : TObject; Error : Word);
procedure ClientCommand(Sender : TObject; CmdBuf : PChar; CmdLen : Integer);
procedure ClientPassiveSessionAvailable(Sender : TObject; Error : Word);
procedure ClientStorSessionConnected(Sender : TObject; Error : Word);
procedure ClientStorSessionClosed(Sender : TObject; Error : Word);
procedure ClientStorDataAvailable(Sender: TObject; Error : word);
procedure ClientRetrSessionConnected(Sender : TObject; Error : Word);
procedure ClientRetrSessionClosed(Sender : TObject; Error : Word);
procedure ClientRetrDataSent(Sender : TObject; Error : Word);
procedure SendAnswer(Client : TFtpCtrlSocket; Answer : TFtpString);
procedure SendNextDataChunk(Client : TFtpCtrlSocket; Data : TWSocket);
procedure StartSendData(Client : TFtpCtrlSocket);
procedure BuildDirectory(Client : TFtpCtrlSocket; var Params : TFtpString; Stream : TStream; Detailed : Boolean);
procedure TriggerServerStart; virtual;
procedure TriggerServerStop; virtual;
procedure TriggerAuthenticate(Client : TFtpCtrlSocket;
UserName : String;
PassWord : String;
var Authenticated : Boolean); virtual;
procedure TriggerChangeDirectory(Client : TFtpCtrlSocket;
Directory : String;
var Allowed : Boolean); virtual;
procedure TriggerMakeDirectory(Client : TFtpCtrlSocket;
Directory : String;
var Allowed : Boolean); virtual;
procedure TriggerBuildDirectory(Client : TFtpCtrlSocket;
var Params : TFtpString;
Detailed : Boolean);
procedure TriggerAlterDirectory(Client : TFtpCtrlSocket;
var Params : TFtpString;
Detailed : Boolean);
procedure TriggerSendAnswer(Client : TFtpCtrlSocket;
var Answer : TFtpString); virtual;
procedure TriggerClientConnect(Client : TFtpCtrlSocket; Error : Word); virtual;
procedure TriggerClientDisconnect(Client : TFtpCtrlSocket; Error : Word); virtual;
procedure TriggerClientCommand(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure TriggerStorSessionConnected(Client : TFtpCtrlSocket;
Data : TWSocket;
Error : Word); virtual;
procedure TriggerStorSessionClosed(Client : TFtpCtrlSocket;
Data : TWSocket;
Error : Word); virtual;
procedure TriggerValidatePut(Client : TFtpCtrlSocket;
var FilePath : TFtpString;
var Allowed : Boolean); virtual;
procedure TriggerValidateDele(Client : TFtpCtrlSocket;
var FilePath : TFtpString;
var Allowed : Boolean); virtual;
procedure TriggerRetrSessionConnected(Client : TFtpCtrlSocket;
Data : TWSocket;
Error : Word); virtual;
procedure TriggerRetrSessionClosed(Client : TFtpCtrlSocket;
Data : TWSocket;
Error : Word); virtual;
procedure TriggerValidateGet(Client : TFtpCtrlSocket;
var FilePath : TFtpString;
var Allowed : Boolean); virtual;
procedure TriggerStorDataAvailable(Client : TFtpCtrlSocket;
Data : TWSocket;
Buf : PChar;
Len : LongInt;
Error : Word); virtual;
procedure TriggerRetrDataSent(Client : TFtpCtrlSocket;
Data : TWSocket;
Error : Word); virtual;
function GetClientCount : Integer; virtual;
function GetActive : Boolean;
procedure SetActive(newValue : Boolean);
procedure AddCommand(const Keyword : String;
const Proc : TFtpSrvCommandProc); virtual;
procedure WMFtpSrvCloseRequest(var msg: TMessage);
message WM_FTPSRV_CLOSE_REQUEST;
procedure WMFtpSrvClientClosed(var msg: TMessage);
message WM_FTPSRV_CLIENT_CLOSED;
procedure WMFtpSrvAbortTransfer(var msg: TMessage);
message WM_FTPSRV_ABORT_TRANSFER;
procedure WMFtpSrvCloseData(var msg: TMessage);
message WM_FTPSRV_CLOSE_DATA;
procedure CommandDirectory(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString;
Detailed : Boolean);
procedure CommandUSER(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandPASS(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandQUIT(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandNOOP(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandLIST(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandNLST(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandDELE(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandSIZE(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandREST(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandRNFR(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandRNTo(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandPORT(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandSTOR(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandRETR(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandTYPE(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandCWD (Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandChangeDir(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandMKD (Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandRMD (Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandCDUP(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandXPWD(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandPWD (Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandSYST(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandABOR(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandPASV(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandAPPE(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandSTRU(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Start;
procedure Stop;
procedure DisconnectAll;
procedure WndProc(var MsgRec: TMessage);
property ServSocket : TWSocket read FServSocket;
property Handle : HWND read FWindowHandle;
property ClientCount : Integer read GetClientCount;
property Active : Boolean read GetActive
write SetActive;
property ClientClass : TFtpCtrlSocketClass
read FClientClass
write FClientClass;
published
property Port : String read FPort
write FPort;
property Banner : String read FBanner
write FBanner;
property UserData : LongInt read FUserData
write FUserData;
property MaxClients : LongInt read FMaxClients
write FMaxClients;
property OnStart : TNotifyEvent
read FOnStart
write FOnStart;
property OnStop : TNotifyEvent
read FOnStop
write FOnStop;
property OnAuthenticate : TFtpSrvAuthenticateEvent
read FOnAuthenticate
write FOnAuthenticate;
property OnClientDisconnect : TFtpSrvClientConnectEvent
read FOnClientDisconnect
write FOnClientDisconnect;
property OnClientConnect : TFtpSrvClientConnectEvent
read FOnClientConnect
write FOnClientConnect;
property OnClientCommand : TFtpSrvClientCommandEvent
read FOnClientCommand
write FOnClientCommand;
property OnAnswerToClient : TFtpSrvAnswerToClientEvent
read FOnAnswerToClient
write FOnAnswerToClient;
property OnChangeDirectory : TFtpSrvChangeDirectoryEvent
read FOnChangeDirectory
write FOnChangeDirectory;
property OnMakeDirectory : TFtpSrvChangeDirectoryEvent
read FOnMakeDirectory
write FOnMakeDirectory;
property OnBuildDirectory : TFtpSrvBuildDirectoryEvent
read FOnBuildDirectory
write FOnBuildDirectory;
property OnAlterDirectory : TFtpSrvBuildDirectoryEvent
read FOnAlterDirectory
write FOnAlterDirectory;
property OnStorSessionConnected : TFtpSrvDataSessionConnectedEvent
read FOnStorSessionConnected
write FOnStorSessionConnected;
property OnRetrSessionConnected : TFtpSrvDataSessionConnectedEvent
read FOnRetrSessionConnected
write FOnRetrSessionConnected;
property OnStorSessionClosed : TFtpSrvDataSessionConnectedEvent
read FOnStorSessionClosed
write FOnStorSessionClosed;
property OnRetrSessionClosed : TFtpSrvDataSessionConnectedEvent
read FOnRetrSessionClosed
write FOnRetrSessionClosed;
property OnRetrDataSent : TFtpSrvRetrDataSentEvent
read FOnRetrDataSent
write FOnRetrDataSent;
property OnValidatePut : TFtpSrvValidateXferEvent
read FOnValidatePut
write FOnValidatePut;
property OnValidateDele : TFtpSrvValidateXferEvent
read FOnValidateDele
write FOnValidateDele;
property OnValidateGet : TFtpSrvValidateXferEvent
read FOnValidateGet
write FOnValidateGet;
property OnStorDataAvailable : TFtpSrvDataAvailableEvent
read FOnStorDataAvailable
write FOnStorDataAvailable;
end;
procedure Register;
implementation
const
msgDftBanner = '220 ICS FTP Server ready.';
msgTooMuchClients = '421 Too many users connected.';
msgCmdUnknown = '500 ''%s'': command not understood.';
msgLoginFailed = '530 Login incorrect.';
msgNotLogged = '530 Please login with USER and PASS.';
msgNoUser = '503 Login with USER first.';
msgLogged = '230 User %s logged in.';
msgPassRequired = '331 Password required for %s.';
msgCWDSuccess = '250 CWD command successful. "%s" is current directory.';
msgCWDFailed = '501 CWD failed. %s';
msgPWDSuccess = '257 "%s" is current directory.';
msgQuit = '221 Goodbye.';
msgPortSuccess = '200 Port command successful.';
msgPortFailed = '501 Invalid PORT command.';
msgStorDisabled = '501 Permission Denied'; {'500 Cannot STOR.';}
msgStorSuccess = '150 Opening data connection for %s.';
msgStorFailed = '501 Cannot STOR. %s';
msgStorAborted = '426 Connection closed; %s.';
msgStorOk = '226 File received ok';
msgStorError = '426 Connection closed; transfer aborted. Error #%d';
msgRetrDisabled = '500 Cannot RETR.';
msgRetrSuccess = '150 Opening data connection for %s.';
msgRetrFailed = '501 Cannot RETR. %s';
msgRetrAborted = '426 Connection closed; %s.';
msgRetrOk = '226 File sent ok';
msgRetrError = '426 Connection closed; transfer aborted. Error #%d';
msgSystem = '215 UNIX Type: L8 Internet Component Suite';
msgDirOpen = '150 Opening data connection for directory list.';
msgDirFailed = '451 Failed: %s.';
msgTypeOk = '200 Type set to %s.';
msgTypeFailed = '500 ''TYPE %s'': command not understood.';
msgDeleNotExists = '550 ''%s'': no such file or directory.';
msgDeleOk = '250 File ''%s'' deleted.';
msgDeleFailed = '450 File ''%s'' can''t be deleted.';
msgDeleSyntax = '501 Syntax error in parameter.';
msgDeleDisabled = '500 Cannot DELE.';
msgRnfrNotExists = '550 ''%s'': no such file or directory.';
msgRnfrSyntax = '501 Syntax error is parameter.';
msgRnfrOk = '350 File exists, ready for destination name.';
msgRntoNotExists = '550 ''%s'': no such file or directory.';
msgRntoAlready = '553 ''%s'': file already exists.';
msgRntoOk = '250 File ''%s'' renamed to ''%s''.';
msgRntoFailed = '450 File ''%s'' can''t be renamed.';
msgRntoSyntax = '501 Syntax error in parameter.';
msgMkdOk = '257 ''%s'': directory created.';
msgMkdAlready = '550 ''%s'': file or directory already exists.';
msgMkdFailed = '550 ''%s'': can''t create directory.';
msgMkdSyntax = '501 Syntax error in parameter.';
msgRmdOk = '250 ''%s'': directory removed.';
msgRmdNotExists = '550 ''%s'': no such directory.';
msgRmdFailed = '550 ''%s'': can''t remove directory.';
msgRmdSyntax = '501 Syntax error in parameter.';
msgNoopOk = '200 Ok. Parameter was ''%s''.';
msgAborOk = '225 ABOR command successful.';
msgPasvLocal = '227 Entering Passive Mode (127,0,0,1,%d,%d).';
msgPasvRemote = '227 Entering Passive Mode (%d,%d,%d,%d,%d,%d).';
msgPasvExcept = '500 PASV exception: ''%s''.';
msgSizeOk = '213 %d';
msgSizeFailed = '550 Command failed: %s.';
msgSizeSyntax = '501 Syntax error in parameter.';
msgRestOk = '350 REST supported. Ready to resume at byte offset %d.';
msgRestZero = '501 Required byte offset parameter bad or missing.';
msgRestFailed = '501 Syntax error in parameter: %s.';
msgAppeFailed = '550 APPE failed.';
msgAppeSuccess = '150 Opening data connection for %s (append).';
msgAppeDisabled = '500 Cannot APPE.';
msgAppeAborted = '426 Connection closed; %s.';
msgAppeOk = '226 File received ok';
msgAppeError = '426 Connection closed; transfer aborted. Error #%d';
msgAppeReady = '150 APPE supported. Ready to append file "%s" at offset %d.';
msgStruOk = '200 Ok. STRU parameter ''%s'' ignored.';
function SlashesToBackSlashes(const S : String) : String; forward;
function BackSlashesToSlashes(const S : String) : String; forward;
function BuildFilePath(const Directory : String;
FileName : String) : String; forward;
var
ThisYear, ThisMonth, ThisDay : Word;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure Register;
begin
RegisterComponents('FPiette', [TFtpServer]);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{$IFDEF VER80}
procedure SetLength(var S: string; NewLength: Integer);
begin
S[0] := chr(NewLength);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TrimRight(Str : String) : String;
var
i : Integer;
begin
i := Length(Str);
while (i > 0) and (Str[i] = ' ') do
i := i - 1;
Result := Copy(Str, 1, i);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TrimLeft(Str : String) : String;
var
i : Integer;
begin
if Str[1] <> ' ' then
Result := Str
else begin
i := 1;
while (i <= Length(Str)) and (Str[i] = ' ') do
i := i + 1;
Result := Copy(Str, i, Length(Str) - i + 1);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function Trim(Str : String) : String;
begin
Result := TrimLeft(TrimRight(Str));
end;
{$ENDIF}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function GetFileSize(FileName : String) : LongInt;
var
SR : TSearchRec;
begin
if FindFirst(FileName, faReadOnly or faHidden or
faSysFile or faArchive, SR) = 0 then
Result := SR.Size
else
Result := -1;
FindClose(SR);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TFtpServer.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FWindowHandle := AllocateHWnd(WndProc);
FServSocket := TWSocket.Create(Self);
FServSocket.Name := 'ServerWSocket';
FClientList := TList.Create;
FPort := 'ftp';
FBanner := msgDftBanner;
FClientClass := TFtpCtrlSocket;
AddCommand('PORT', CommandPORT);
AddCommand('STOR', CommandSTOR);
AddCommand('RETR', CommandRETR);
AddCommand('CWD', CommandCWD);
AddCommand('XPWD', CommandXPWD);
AddCommand('PWD', CommandPWD);
AddCommand('USER', CommandUSER);
AddCommand('PASS', CommandPASS);
AddCommand('LIST', CommandLIST);
AddCommand('NLST', CommandNLST);
AddCommand('TYPE', CommandTYPE);
AddCommand('SYST', CommandSYST);
AddCommand('QUIT', CommandQUIT);
AddCommand('DELE', CommandDELE);
AddCommand('SIZE', CommandSIZE);
AddCommand('REST', CommandREST);
AddCommand('RNFR', CommandRNFR);
AddCommand('RNTO', CommandRNTO);
AddCommand('MKD', CommandMKD);
AddCommand('RMD', CommandRMD);
AddCommand('ABOR', CommandABOR);
AddCommand('PASV', CommandPASV);
AddCommand('NOOP', CommandNOOP);
AddCommand('CDUP', CommandCDUP);
AddCommand('APPE', CommandAPPE);
AddCommand('STRU', CommandSTRU);
AddCommand('XMKD', CommandMKD);
AddCommand('XRMD', CommandRMD);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TFtpServer.Destroy;
begin
if Assigned(FServSocket) then begin
FServSocket.Destroy;
FServSocket := nil;
end;
if Assigned(FClientList) then begin
FClientList.Destroy;
FClientList := nil;
end;
DeallocateHWnd(FWindowHandle);
inherited Destroy;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.WndProc(var MsgRec: TMessage);
begin
with MsgRec do begin
case Msg of
WM_FTPSRV_CLOSE_REQUEST : WMFtpSrvCloseRequest(MsgRec);
WM_FTPSRV_CLIENT_CLOSED : WMFtpSrvClientClosed(MsgRec);
WM_FTPSRV_ABORT_TRANSFER : WMFtpSrvAbortTransfer(MsgRec);
WM_FTPSRV_CLOSE_DATA : WMFtpSrvCloseData(MsgRec);
else
Result := DefWindowProc(Handle, Msg, wParam, lParam);
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.WMFtpSrvCloseRequest(var msg: TMessage);
var
Client : TFtpCtrlSocket;
begin
Client := TFtpCtrlSocket(msg.LParam);
if Client.AllSent then
Client.Close
else
Client.CloseRequest := TRUE;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.Notification(AComponent: TComponent; operation: TOperation);
begin
inherited Notification(AComponent, operation);
if operation = opRemove then begin
if AComponent = FServSocket then
FServSocket := nil;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.AddCommand(
const Keyword : String;
const Proc : TFtpSrvCommandProc);
begin
if FLastCmd > High(FCmdTable) then
raise FtpServerException.Create('Too many command');
FCmdTable[FLastCmd].KeyWord := KeyWord;
FCmdTable[FLastCmd].Proc := Proc;
Inc(FLastCmd);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.Start;
begin
if FServSocket.State = wsListening then
Exit; { Server is already running }
FServSocket.Port := Port;
FServSocket.Proto := 'tcp';
FServSocket.Addr := '0.0.0.0';
FServSocket.OnSessionAvailable := ServSocketSessionAvailable;
FServSocket.OnChangeState := ServSocketStateChange;
FServSocket.Listen;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.Stop;
begin
FServSocket.Close;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.DisconnectAll;
var
Client : TFtpCtrlSocket;
begin
while FClientList.Count > 0 do begin
Client := TFtpCtrlSocket(FClientList.Items[0]);
Client.Close;
FClientList.Remove(Client);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TFtpServer.GetActive : Boolean;
begin
Result := (FServSocket.State = wsListening);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.SetActive(newValue : Boolean);
begin
if newValue then
Start
else
Stop;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.ServSocketStateChange(Sender : TObject; OldState, NewState : TSocketState);
begin
if csDestroying in ComponentState then
Exit;
if NewState = wsListening then
TriggerServerStart
else if NewState = wsClosed then
TriggerServerStop;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.ServSocketSessionAvailable(Sender : TObject; Error : Word);
var
Client : TFtpCtrlSocket;
begin
if Error <> 0 then
raise FtpServerException.Create('Session available error #' + IntToStr(Error));
Inc(FClientNum);
Client := FClientClass.Create(Self);
FClientList.Add(Client);
Client.Name := 'ClientWSocket' + IntToStr(FClientNum);
Client.DataSocket.Name := 'DataWSocket' + IntToStr(FClientNum);
Client.Banner := FBanner;
Client.HSocket := ServSocket.Accept;
Client.OnCommand := ClientCommand;
Client.OnSessionClosed := ClientSessionClosed;
Client.OnDataSent := ClientDataSent;
TriggerClientConnect(Client, Error);
{ The event handler may have destroyed the client ! }
if FClientList.IndexOf(Client) < 0 then
Exit;
{ The event handler may have closed the connection }
if Client.State <> wsConnected then
Exit;
{ Ok, the client is still there, process with the connection }
if (FMaxClients > 0) and (FMaxClients < ClientCount) then begin
{ Sorry, toomuch clients }
Client.Banner := msgTooMuchClients;
Client.StartConnection;
Client.Close;
end
else
Client.StartConnection;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.SendAnswer(Client : TFtpCtrlSocket; Answer : TFtpString);
begin
try
TriggerSendAnswer(Client, Answer);
Client.SendAnswer(Answer);
except
{ Just ignore any exception here }
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.ClientCommand(
Sender : TObject;
CmdBuf : PChar;
CmdLen : Integer);
const
TELNET_IAC = #255;
TELNET_IP = #244;
TELNET_DATA_MARK = #242;
var
Client : TFtpCtrlSocket;
Answer : TFtpString;
Params : TFtpString;
KeyWord : TFtpString;
I, J : Integer;
begin
Client := Sender as TFtpCtrlSocket;
Answer := '';
{ Copy the command received, removing any telnet option }
try
Params := '';
I := 0;
while I < CmdLen do begin
if CmdBuf[I] <> TELNET_IAC then begin
Params := Params + CmdBuf[I];
Inc(I);
end
else begin
Inc(I);
if CmdBuf[I] = TELNET_IAC then
Params := Params + CmdBuf[I];
Inc(I);
end;
end;
{ Extract keyword, ignoring leading spaces and tabs }
I := 1;
while (I <= Length(Params)) and (Params[I] in [' ', #9]) do
Inc(I);
J := I;
while (J <= Length(Params)) and (Params[J] in ['A'..'Z', 'a'..'z', '0'..'9']) do
Inc(J);
KeyWord := UpperCase(Copy(Params, I, J - I));
{ Extract parameters, ignoring leading spaces and tabs }
while (J <= Length(Params)) and (Params[J] in [' ', #9]) do
Inc(J);
Params := Copy(Params, J, Length(Params));
{ Pass the command to the component user to let him a chance to }
{ handle it. If it does, he must return the answer. }
TriggerClientCommand(Client, Keyword, Params, Answer);
if Answer <> '' then begin
{ Event handler has processed the client command, send the answer }
SendAnswer(Client, Answer);
Exit;
end;
{ The command has not been processed, we'll process it }
if Keyword = '' then begin
{ Empty keyword (should never occurs) }
SendAnswer(Client, Format(msgCmdUnknown, [Params]));
Exit;
end;
{ We need to process the client command, search our command table }
I := 0;
while I <= High(FCmdTable) do begin
if FCmdTable[I].KeyWord = KeyWord then begin
FCmdTable[I].Proc(Client, KeyWord, Params, Answer);
SendAnswer(Client, Answer);
Exit;
end;
Inc(I);
end;
SendAnswer(Client, Format(msgCmdUnknown, [KeyWord]));
except
on E:Exception do begin
SendAnswer(Client, '501 ' + E.Message);
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.ClientDataSent(Sender : TObject; Error : Word);
var
Client : TFtpCtrlSocket;
begin
Client := Sender as TFtpCtrlSocket;
if Client.CloseRequest then begin
Client.CloseRequest := FALSE;
PostMessage(FWindowHandle, WM_FTPSRV_CLOSE_REQUEST, 0, LongInt(Client));
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.ClientSessionClosed(Sender : TObject; Error : Word);
begin
PostMessage(FWindowHandle, WM_FTPSRV_CLIENT_CLOSED, 0, LongInt(Sender));
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.WMFtpSrvClientClosed(var msg: TMessage);
var
Client : TFtpCtrlSocket;
begin
Client := TFtpCtrlSocket(Msg.LParam);
try
FClientList.Remove(Client);
TriggerClientDisconnect(Client, Error);
finally
Client.Destroy;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.WMFtpSrvAbortTransfer(var msg: TMessage);
var
Data : TWSocket;
begin
Data := TWSocket(Msg.LParam);
Data.ShutDown(2);
Data.Close;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.WMFtpSrvCloseData(var msg: TMessage);
var
Data : TWSocket;
begin
if msg.WParam > 0 then begin
{$IFNDEF VER80}
Sleep(0); { Release time slice }
{$ENDIF}
PostMessage(FWindowHandle, Msg.Msg, msg.WParam - 1, msg.LParam);
end
else begin
Data := TWSocket(Msg.LParam);
Data.Close;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TFtpServer.GetClientCount : Integer;
begin
if Assigned(FClientList) then
Result := FClientList.Count
else
Result := 0;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerServerStart;
begin
if Assigned(FOnStart) then
FOnStart(Self);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerServerStop;
begin
if Assigned(FOnStop) then
FOnStop(Self);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerAuthenticate(
Client : TFtpCtrlSocket;
UserName : String;
PassWord : String;
var Authenticated : Boolean);
begin
if Assigned(FOnAuthenticate) then
FOnAuthenticate(Self, Client, UserName, Password, Authenticated);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerChangeDirectory(
Client : TFtpCtrlSocket;
Directory : String;
var Allowed : Boolean);
begin
if Assigned(FOnChangeDirectory) then
FOnChangeDirectory(Self, Client, Directory, Allowed);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerMakeDirectory(
Client : TFtpCtrlSocket;
Directory : String;
var Allowed : Boolean);
begin
if Assigned(FOnMakeDirectory) then
FOnMakeDirectory(Self, Client, Directory, Allowed);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerBuildDirectory(
Client : TFtpCtrlSocket;
var Params : TFtpString;
Detailed : Boolean);
begin
if Assigned(FOnBuildDirectory) then
FOnBuildDirectory(Self, Client, Params, Detailed);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerAlterDirectory(
Client : TFtpCtrlSocket;
var Params : TFtpString;
Detailed : Boolean);
begin
if Assigned(FOnAlterDirectory) then
FOnAlterDirectory(Self, Client, Params, Detailed);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerSendAnswer(
Client : TFtpCtrlSocket;
var Answer : TFtpString);
begin
if Assigned(FOnAnswerToClient) then
FOnAnswerToClient(Self, Client, Answer);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerClientDisconnect(Client : TFtpCtrlSocket; Error : Word);
begin
if Assigned(FOnClientDisconnect) then
FOnClientDisconnect(Self, Client, Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerClientConnect(Client : TFtpCtrlSocket; Error : Word);
begin
if Assigned(FOnClientConnect) then
FOnClientConnect(Self, Client, Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerStorSessionConnected(
Client : TFtpCtrlSocket; Data : TWSocket; Error : Word);
begin
if Assigned(FOnStorSessionConnected) then
FOnStorSessionConnected(Self, Client, Data, Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerRetrSessionConnected(
Client : TFtpCtrlSocket; Data : TWSocket; Error : Word);
begin
if Assigned(FOnRetrSessionConnected) then
FOnRetrSessionConnected(Self, Client, Data, Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerStorSessionClosed(
Client : TFtpCtrlSocket; Data : TWSocket; Error : Word);
begin
if Assigned(FOnStorSessionClosed) then
FOnStorSessionClosed(Self, Client, Data, Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerRetrSessionClosed(
Client : TFtpCtrlSocket; Data : TWSocket; Error : Word);
begin
if Assigned(FOnRetrSessionClosed) then
FOnRetrSessionClosed(Self, Client, Data, Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerClientCommand(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
begin
if Assigned(FOnClientCommand) then
FOnClientCommand(Self, Client, KeyWord, Params, Answer);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerValidatePut(
Client : TFtpCtrlSocket;
var FilePath : TFtpString;
var Allowed : Boolean);
begin
if Assigned(FOnValidatePut) then
FOnValidatePut(Self, Client, FilePath, Allowed);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerValidateDele(
Client : TFtpCtrlSocket;
var FilePath : TFtpString;
var Allowed : Boolean);
begin
if Assigned(FOnValidateDele) then
FOnValidateDele(Self, Client, FilePath, Allowed);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerValidateGet(
Client : TFtpCtrlSocket;
var FilePath : TFtpString;
var Allowed : Boolean);
begin
if Assigned(FOnValidateGet) then
FOnValidateGet(Self, Client, FilePath, Allowed);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerStorDataAvailable(
Client : TFtpCtrlSocket;
Data : TWSocket;
Buf : PChar;
Len : LongInt;
Error : Word);
begin
if Assigned(FOnStorDataAvailable) then
FOnStorDataAvailable(Self, Client, Data, Buf, Len, Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerRetrDataSent(
Client : TFtpCtrlSocket;
Data : TWSocket;
Error : Word);
begin
if Assigned(FOnRetrDataSent) then
FOnRetrDataSent(Self, Client, Data, Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandUSER(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
begin
Client.CurCmdType := ftpcUSER;
Client.UserName := Trim(Params);
Client.FtpState := ftpcWaitingPassword;
Answer := Format(msgPassRequired, [Client.UserName]);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandPASS(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
var
Authenticated : Boolean;
begin
if Client.FtpState <> ftpcWaitingPassword then
Answer := msgNoUser
else begin
Client.CurCmdType := ftpcPASS;
Client.PassWord := Trim(Params);
Authenticated := TRUE;
TriggerAuthenticate(Client, Client.UserName, Client.PassWord, Authenticated);
if Authenticated then begin
Client.FtpState := ftpcReady;
Client.Directory := Client.HomeDir;
Answer := Format(msgLogged, [Client.UserName])
end
else begin
Client.FtpState := ftpcWaitingUserCode;
Answer := msgLoginFailed;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandCDUP(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
Client.CurCmdType := ftpcCDUP;
Params := '..';
CommandChangeDir(Client, Keyword, Params, Answer);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandCWD(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
Client.CurCmdType := ftpcCWD;
CommandChangeDir(Client, Keyword, Params, Answer);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function SlashesToBackSlashes(const S : String) : String;
var
I : Integer;
begin
Result := S;
for I := 1 to Length(Result) do begin
if Result [I] = '/' then
Result[I] := '\';
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function BackSlashesToSlashes(const S : String) : String;
var
I : Integer;
begin
Result := S;
for I := 1 to Length(Result) do begin
if Result [I] = '\' then
Result[I] := '/';
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandChangeDir(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
var
Allowed : Boolean;
OldDir : String;
begin
OldDir := Client.Directory;
try
Params := SlashesToBackSlashes(Params);
Client.Directory := Trim(Params);
Allowed := TRUE;
TriggerChangeDirectory(Client, Client.Directory, Allowed);
if Allowed then
Answer := Format(msgCWDSuccess,
[BackSlashesToSlashes(Client.Directory)])
else begin
Client.Directory := OldDir;
Answer := Format(msgCWDFailed, ['No permission']);
end;
except
on E:Exception do begin
Client.Directory := OldDir;
Answer := Format(msgCWDFailed, [E.Message]);
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandXPWD(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
Client.CurCmdType := ftpcXPWD;
Answer := Format(msgPWDSuccess,
[BackSlashesToSlashes(Client.Directory)]);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandPWD(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
Client.CurCmdType := ftpcPWD;
Answer := Format(msgPWDSuccess,
[BackSlashesToSlashes(Client.Directory)]);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandQUIT(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
begin
Client.CurCmdType := ftpcQUIT;
Answer := msgQuit;
PostMessage(FWindowHandle, WM_FTPSRV_CLOSE_REQUEST, 0, LongInt(Client));
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function GetInteger(var I : Integer; const Src : String) : LongInt;
begin
{ Skip leading white spaces }
while (I <= Length(Src)) and (Src[I] in [' ' , #9]) do
Inc(I);
Result := 0;
while (I <= Length(Src)) and (Src[I] in ['0'..'9']) do begin
Result := Result * 10 + Ord(Src[I]) - Ord('0');
Inc(I);
end;
{ Skip trailing white spaces }
while (I <= Length(Src)) and (Src[I] in [' ' , #9]) do
Inc(I);
{ Check if end of string of comma. If not, error, returns -1 }
if I <= Length(Src) then begin
if Src[I] = ',' then
Inc(I) { skip comma }
else
raise Exception.Create('unexpected char'); { error, must be comma }
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandPORT(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
var
I : Integer;
N : LongInt;
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
try
Client.CurCmdType := ftpcPORT;
I := 1;
Client.DataAddr := IntToStr(GetInteger(I, Params));
Client.DataAddr := Client.DataAddr + '.' + IntToStr(GetInteger(I, Params));
Client.DataAddr := Client.DataAddr + '.' + IntToStr(GetInteger(I, Params));
Client.DataAddr := Client.DataAddr + '.' + IntToStr(GetInteger(I, Params));
N := GetInteger(I, Params);
N := (N shl 8) + GetInteger(I, Params);
Client.DataPort := IntToStr(N);
Answer := msgPortSuccess;
except
Answer := msgPortFailed;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandSTOR(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
var
Allowed : Boolean;
FilePath : TFtpString;
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
try
Client.CurCmdType := ftpcSTOR;
Client.FileName := SlashesToBackSlashes(Params);
Client.HasOpenedFile := FALSE;
Client.AbortingTransfer := FALSE;
Client.TransferError := 'Transfer Ok';
Allowed := TRUE;
FilePath := BuildFilePath(Client.Directory, Client.FileName);
TriggerValidatePut(Client, FilePath, Allowed);
if not Allowed then begin
Answer := msgStorDisabled;
Exit;
end;
Client.FilePath := FilePath;
if Client.PassiveMode then begin
Client.DataSocket.OnSessionConnected := ClientStorSessionConnected;
Client.DataSocket.OnSessionClosed := ClientStorSessionClosed;
Client.DataSocket.OnDataAvailable := ClientStorDataAvailable;
Client.DataSocket.OnDataSent := nil;
if Client.PassiveConnected then
Client.DataSocket.OnSessionConnected(Client.DataSocket, 0)
else
Client.PassiveStart := TRUE;
end
else begin
Client.DataSocket.Proto := 'tcp';
Client.DataSocket.Addr := Client.DataAddr;
Client.DataSocket.Port := Client.DataPort;
Client.DataSocket.OnSessionConnected := ClientStorSessionConnected;
Client.DataSocket.OnSessionClosed := ClientStorSessionClosed;
Client.DataSocket.OnDataAvailable := ClientStorDataAvailable;
Client.DataSocket.OnDataSent := nil;
Client.DataSocket.LingerOnOff := wsLingerOff;
Client.DataSocket.LingerTimeout := 0;
Client.DataSocket.Connect;
end;
Answer := Format(msgStorSuccess, [Params]);
except
on E:Exception do begin
Answer := Format(msgStorFailed, [E.Message]);
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.ClientStorSessionConnected(Sender : TObject; Error : Word);
var
Client : TFtpCtrlSocket;
Data : TWSocket;
begin
Data := TWSocket(Sender);
Client := TFtpCtrlSocket(Data.Owner);
Client.DataSessionActive := TRUE;
Client.PassiveMode := FALSE;
TriggerStorSessionConnected(Client, Data, Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.ClientStorSessionClosed(Sender : TObject; Error : Word);
var
Client : TFtpCtrlSocket;
Data : TWSocket;
begin
Data := TWSocket(Sender);
Client := TFtpCtrlSocket(Data.Owner);
Client.DataSessionActive := FALSE;
Client.PassiveStart := FALSE;
Client.PassiveConnected := FALSE;
Client.RestartPos := 0;
{ Reset data port to standard value }
Client.DataPort := 'ftp-data';
{ If we had opened a data stream ourself, then close it }
if Client.HasOpenedFile then begin
if Assigned(Client.DataStream) then
Client.DataStream.Destroy;
Client.DataStream := nil;
Client.HasOpenedFile := FALSE;
end;
TriggerStorSessionClosed(Client, Data, Error);
if Client.CurCmdType = ftpcSTOR then begin
if Client.AbortingTransfer then
SendAnswer(Client, Format(msgStorAborted, [Client.TransferError]))
else if Error = 0 then
SendAnswer(Client, msgStorOk)
else
SendAnswer(Client, Format(msgStorError, [Error]));
end
else if Client.CurCmdType = ftpcAPPE then begin
if Client.AbortingTransfer then
SendAnswer(Client, Format(msgAppeAborted, [Client.TransferError]))
else if Error = 0 then
SendAnswer(Client, msgAppeOk)
else
SendAnswer(Client, Format(msgAppeError, [Error]));
end
else { Should never comes here }
raise Exception.Create('Program error in ClientStorSessionClosed');
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.ClientStorDataAvailable(Sender: TObject; Error : word);
var
Len : Integer;
Client : TFtpCtrlSocket;
Data : TWSocket;
begin
Data := TWSocket(Sender);
Client := TFtpCtrlSocket(Data.Owner);
Len := Data.Receive(Client.RcvBuf, Client.RcvSize);
if Len <= 0 then
Exit;
if Client.AbortingTransfer then
Exit;
try
{ Trigger the user event for the received data }
TriggerStorDataAvailable(Client, Data, Client.RcvBuf, Len, Error);
{ We need to open a datastream if not already done and a FilePath }
{ exists (the component user can have nullified the FilePath }
if (not Client.HasOpenedFile) and
(Length(Client.FilePath) > 0) and
(not Assigned(Client.DataStream)) then begin
{ Use different file modes for APPE vs STOR }
if (Client.CurCmdType = ftpcAPPE) and
(GetFileSize(Client.FilePath) > -1) then
Client.DataStream := TFileStream.Create(Client.FilePath,
fmOpenReadWrite or fmShareDenyWrite)
else
Client.DataStream := TFileStream.Create(Client.FilePath,
fmCreate);
Client.DataStream.Seek(Client.RestartPos, soFromBeginning);
Client.HasOpenedFile := TRUE;
end;
{ If we have a DataStream, then we need to write the data }
if Assigned(Client.DataStream) then
Client.DataStream.WriteBuffer(Client.RcvBuf^, Len);
except
{ An exception occured, so we abort the transfer }
on E:Exception do begin
Client.TransferError := E.Message;
Client.AbortingTransfer := TRUE;
PostMessage(FWindowHandle, WM_FTPSRV_ABORT_TRANSFER, 0, LongInt(Data));
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function BuildFilePath(
const Directory : String;
FileName : String) : String;
var
Drive : String;
Path : String;
begin
FileName := SlashesToBackSlashes(FileName);
if IsUNC(FileName) then
Result := FileName
else if IsUNC(Directory) then begin
if (Length(FileName) > 0) and (FileName[1] = '\') then
Result := ExtractFileDrive(Directory) + FileName
else
Result := Directory + FileName;
end
else begin
if (Length(FileName) > 1) and (FileName[2] = ':') then begin
Drive := UpperCase(Copy(FileName, 1, 2));
Path := Copy(FileName, 3, Length(FileName));
end
else begin
Drive := Copy(Directory, 1, 2);
Path := FileName;
end;
if (Length(Path) > 0) and (Path[1] = '\') then
Result := Drive + Path
else begin
if Drive <> Copy(Directory, 1, 2) then
raise Exception.Create('No current dir for ''' + Drive + '''');
Result := Directory + Path;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandRETR(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
var
Allowed : Boolean;
FilePath : TFtpString;
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
try
Client.CurCmdType := ftpcRETR;
Client.HasOpenedFile := FALSE;
Client.FileName := SlashesToBackSlashes(Params);
Allowed := TRUE;
FilePath := BuildFilePath(Client.Directory, Client.FileName);
TriggerValidateGet(Client, FilePath, Allowed);
if not Allowed then begin
Answer := msgRetrDisabled;
Exit;
end;
Client.FilePath := FilePath;
Answer := Format(msgRetrSuccess, [Params]);
StartSendData(Client);
except
on E:Exception do begin
Answer := Format(msgRetrFailed, [E.Message]);
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.ClientPassiveSessionAvailable(Sender : TObject; Error : Word);
var
HSocket : TSocket;
Client : TFtpCtrlSocket;
Data : TWSocket;
begin
Data := TWSocket(Sender);
Client := TFtpCtrlSocket(Data.Owner);
HSocket := Data.Accept;
Data.OnSessionClosed := nil;
Data.Close; { We don't need to listen any more }
if Client.CurCmdType in [ftpcSTOR, ftpcAPPE] then begin
Client.DataSocket.OnSessionConnected := ClientStorSessionConnected;
Client.DataSocket.OnSessionClosed := ClientStorSessionClosed;
Client.DataSocket.OnDataAvailable := ClientStorDataAvailable;
Client.DataSocket.OnDataSent := nil;
end
else if Client.CurCmdType in [ftpcRETR, ftpcLIST, ftpcNLST] then begin
Client.DataSocket.OnSessionConnected := ClientRetrSessionConnected;
Client.DataSocket.OnSessionClosed := ClientRetrSessionClosed;
Client.DataSocket.OnDataAvailable := nil;
Client.DataSocket.OnDataSent := ClientRetrDataSent;
end
else begin
Client.DataSocket.OnSessionConnected := nil;
Client.DataSocket.OnSessionClosed := nil;
Client.DataSocket.OnDataAvailable := nil;
Client.DataSocket.OnDataSent := nil;
end;
Client.DataSocket.LingerOnOff := wsLingerOff;
Client.DataSocket.LingerTimeout := 0;
Client.DataSocket.HSocket := HSocket;
Client.PassiveConnected := TRUE;
if Client.PassiveStart then
Client.DataSocket.OnSessionConnected(Client.DataSocket, 0);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.StartSendData(Client : TFtpCtrlSocket);
begin
Client.AbortingTransfer := FALSE;
Client.DataSent := FALSE;
Client.TransferError := 'Transfer Ok';
if Client.PassiveMode then begin
Client.DataSocket.OnSessionConnected := ClientRetrSessionConnected;
Client.DataSocket.OnSessionClosed := ClientRetrSessionClosed;
Client.DataSocket.OnDataAvailable := nil;
Client.DataSocket.OnDataSent := ClientRetrDataSent;
if Client.PassiveConnected then
Client.DataSocket.OnSessionConnected(Client.DataSocket, 0)
else
Client.PassiveStart := TRUE;
end
else begin
Client.DataSocket.Close;
Client.DataSocket.Proto := 'tcp';
Client.DataSocket.Addr := Client.DataAddr;
Client.DataSocket.Port := Client.DataPort;
Client.DataSocket.OnSessionConnected := ClientRetrSessionConnected;
Client.DataSocket.OnSessionClosed := ClientRetrSessionClosed;
Client.DataSocket.OnDataAvailable := nil;
Client.DataSocket.OnDataSent := ClientRetrDataSent;
Client.DataSocket.LingerOnOff := wsLingerOff;
Client.DataSocket.LingerTimeout := 0;
Client.DataSocket.Connect;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.ClientRetrSessionConnected(Sender : TObject; Error : Word);
var
Client : TFtpCtrlSocket;
Data : TWSocket;
begin
Data := TWSocket(Sender);
Client := TFtpCtrlSocket(Data.Owner);
Client.DataSessionActive := TRUE;
Client.PassiveMode := FALSE;
try
TriggerRetrSessionConnected(Client, Data, Error);
{ We need to open a datastream if not already done and a FilePath }
{ exists the component user can have nullified the FilePath or }
{ created his own data stream (virtual file feature) }
if (not Client.HasOpenedFile) and
(Length(Client.FilePath) > 0) and
(not Assigned(Client.DataStream)) then begin
Client.DataStream := TFileStream.Create(Client.FilePath,
fmOpenRead + fmShareDenyNone);
Client.DataStream.Seek(Client.RestartPos, soFromBeginning);
Client.HasOpenedFile := TRUE;
end;
except
on E:Exception do begin
Client.AbortingTransfer := TRUE;
Client.TransferError := E.Message;
PostMessage(FWindowHandle, WM_FTPSRV_ABORT_TRANSFER,
0, LongInt(Data));
Exit;
end;
end;
SendNextDataChunk(Client, Data);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.ClientRetrSessionClosed(Sender : TObject; Error : Word);
var
Client : TFtpCtrlSocket;
Data : TWSocket;
begin
Data := TWSocket(Sender);
Client := TFtpCtrlSocket(Data.Owner);
Client.DataSessionActive := FALSE;
Client.PassiveStart := FALSE;
Client.PassiveConnected := FALSE;
Client.RestartPos := 0;
{ Reset data port to standard value }
Client.DataPort := 'ftp-data';
{ If we had opened a data stream ourself, then close it }
if Client.HasOpenedFile then begin
if Assigned(Client.DataStream) then begin
Client.DataStream.Destroy;
end;
Client.DataStream := nil;
Client.HasOpenedFile := FALSE;
end;
if Client.AbortingTransfer then
SendAnswer(Client, Format(msgRetrFailed, [Client.TransferError]))
else if Error <> 0 then
SendAnswer(Client, Format(msgRetrFailed, ['Error #' + IntToStr(Error)]))
else
SendAnswer(Client, msgRetrOk);
TriggerRetrSessionClosed(Client, Data, Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.SendNextDataChunk(
Client : TFtpCtrlSocket;
Data : TWSocket);
var
Count : LongInt;
begin
try
if Assigned(Client.DataStream) then
Count := Client.DataStream.Read(Client.RcvBuf^, Client.RcvSize)
else
Count := 0;
if Count > 0 then begin
Client.ByteCount := Client.ByteCount + Count;
Data.Send(Client.RcvBuf, Count);
end
else begin { EOF }
if not Client.DataSent then begin
Client.DataSent := TRUE;
PostMessage(Handle, WM_FTPSRV_CLOSE_DATA, 0, LongInt(Data));
end;
end;
except
{ An exception occured, so we abort the transfer }
on E:Exception do begin
Client.TransferError := E.Message;
Client.AbortingTransfer := TRUE;
PostMessage(FWindowHandle, WM_FTPSRV_ABORT_TRANSFER, 0, LongInt(Data));
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.ClientRetrDataSent(Sender : TObject; Error : Word);
var
Client : TFtpCtrlSocket;
Data : TWSocket;
begin
Data := TWSocket(Sender);
Client := TFtpCtrlSocket(Data.Owner);
if Client.AbortingTransfer then
Exit;
try
{ Trigger the user event for the received data }
TriggerRetrDataSent(Client, Data, Error);
if Error <> 0 then
raise Exception.Create('Send: error #' + IntToStr(Error));
SendNextDataChunk(Client, Data);
except
{ An exception occured, so we abort the transfer }
on E:Exception do begin
Client.TransferError := E.Message;
Client.AbortingTransfer := TRUE;
SendAnswer(Client, Format(msgRetrAborted, [Client.TransferError]));
PostMessage(FWindowHandle, WM_FTPSRV_ABORT_TRANSFER, 0, LongInt(Data));
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandSYST(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
Client.CurCmdType := ftpcSYST;
Answer := msgSystem;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandDirectory(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString;
Detailed : Boolean);
begin
if Assigned(Client.DataStream) then begin
Client.DataStream.Destroy;
Client.DataStream := nil;
end;
try
Params := SlashesToBackSlashes(Params);
TriggerBuildDirectory(Client, Params, Detailed);
if not Assigned(Client.DataStream) then begin
Client.DataStream := TMemoryStream.Create;
Client.HasOpenedFile := TRUE;
BuildDirectory(Client, Params, Client.DataStream, Detailed);
TriggerAlterDirectory(Client, Params, Detailed);
Client.DataStream.Seek(0, 0);
end;
Client.FilePath := '';
Answer := msgDirOpen;
StartSendData(Client);
except
on E:Exception do begin
Answer := Format(msgDirFailed, [E.Message])
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandLIST(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
Client.CurCmdType := ftpcLIST;
CommandDirectory(Client, KeyWord, Params, Answer, TRUE);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandNLST(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
Client.CurCmdType := ftpcNLST;
CommandDirectory(Client, KeyWord, Params, Answer, FALSE);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function FormatUnixDirEntry(F : TSearchRec) : String;
var
Attr : String;
Ext : String;
Day, Month, Year : Integer;
Hour, Min : Integer;
const
StrMonth : array [1..12] of String =
('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
begin
if ((F.Attr and faVolumeID) <> 0) or
((F.Attr and faHidden) <> 0) then begin
{ Ignore hidden files and volume ID entries }
Result := '';
Exit;
end;
Attr := '-rw-rw-rw-';
if (F.Attr and faDirectory) <> 0 then
Attr[1] := 'd';
if (F.Attr and faReadOnly) <> 0 then begin
Attr[3] := '-';
Attr[6] := '-';
Attr[9] := '-';
end;
Ext := UpperCase(ExtractFileExt(F.Name));
if (Ext = '.EXE') or (Ext = '.COM') or (Ext = '.BAT') then begin
Attr[4] := 'x';
Attr[7] := 'x';
Attr[10] := 'x';
end;
Day := (HIWORD(F.Time) and $1F);
Month := ((HIWORD(F.Time) shr 5) and $0F);
Year := ((HIWORD(F.Time) shr 9) and $3F) + 1980;
{ Sec := ((F.Time and $1F) shl 1); }
Min := ((F.Time shr 5) and $3F);
Hour := ((F.Time shr 11) and $1F);
Result := Attr + ' 1 ftp ftp ' + Format('%11d ', [F.Size]);
Result := Result + Format('%s %2.2d ', [StrMonth[Month], Day]);
if Year = ThisYear then
Result := Result + Format('%2.2d:%2.2d ', [Hour, Min])
else
Result := Result + Format('%5d ', [Year]);
Result := Result + F.Name + #13#10;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.BuildDirectory(
Client : TFtpCtrlSocket;
var Params : TFtpString;
Stream : TStream;
Detailed : Boolean);
var
F : TSearchRec;
Path : String;
Status : Integer;
Buf : String;
begin
DecodeDate(Now, ThisYear, ThisMonth, ThisDay);
if Params = '' then
Path := Client.Directory + '*.*'
else
Path := BuildFilePath(Client.Directory, Params);
if Path[Length(Path)] = '\' then
Path := Path + '*.*';
Status := FindFirst(Path, faAnyFile, F);
while Status = 0 do begin
if Detailed then
Buf := FormatUnixDirEntry(F)
else
Buf := F.Name + #13#10;
if Length(Buf) > 0 then
Stream.Write(Buf[1], Length(Buf));
Status := FindNext(F);
end;
FindClose(F);
if Stream.Size = 0 then begin
Buf := Path + ' not found' + #13#10;
Stream.Write(Buf[1], Length(Buf));
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandTYPE(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
var
Buf : String;
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
Client.CurCmdType := ftpcTYPE;
Buf := UpperCase(Trim(Params));
if (Buf = 'A') or (Buf = 'I') then begin
Answer := Format(msgTypeOk, [Params]);
Client.BinaryMode := (Buf = 'I');
end
else
Answer := Format(msgTypeFailed, [Params]);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandDELE(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
var
FileName : TFtpString;
Allowed : Boolean;
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
Client.CurCmdType := ftpcDELE;
FileName := BuildFilePath(Client.Directory, Params);
TriggerValidateDele(Client, FileName, Allowed);
if not Allowed then begin
Answer := msgDeleDisabled;
Exit;
end;
if Params = '' then
Answer := Format(msgDeleSyntax, [Params])
else if FileExists(FileName) then begin
if DeleteFile(FileName) then
Answer := Format(msgDeleOk, [FileName])
else
Answer := Format(msgDeleFailed, [FileName]);
end
else
Answer := Format(msgDeleNotExists, [FileName]);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandSIZE(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
var
FileName : String;
Size : LongInt;
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
Client.CurCmdType := ftpcSIZE;
FileName := BuildFilePath(Client.Directory, Params);
if Params = '' then
Answer := Format(msgSizeSyntax, [Params])
else begin
try
Size := GetFileSize(FileName);
if Size >= 0 then
Answer := Format(msgSizeOk, [Size])
else
Answer := Format(msgSizeFailed, ['File not found'])
except
on E:Exception do begin
Answer := Format(msgSizeFailed, [E.Message])
end;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandREST(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
Client.CurCmdType := ftpcREST;
try
Client.RestartPos := StrToInt(Params);
if Client.RestartPos <= 0 then begin
Answer := msgRestZero;
Client.RestartPos := 0;
end
else
Answer := Format(msgRestOk, [Client.RestartPos]);
except
on E:Exception do begin
Answer := Format(msgRestFailed, [E.Message]);
Client.RestartPos := 0;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandRNFR(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
var
FileName : String;
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
Client.CurCmdType := ftpcRNFR;
FileName := BuildFilePath(Client.Directory, Params);
if Params = '' then
Answer := Format(msgRnfrSyntax, [Params])
else if FileExists(FileName) then begin
Client.FromFileName := FileName;
Answer := Format(msgRnfrOk, [FileName])
end
else
Answer := Format(msgRnfrNotExists, [FileName]);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandRNTO(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
var
FileName : String;
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
Client.CurCmdType := ftpcRNTO;
FileName := BuildFilePath(Client.Directory, Params);
if Params = '' then
Answer := Format(msgRntoSyntax, [Params])
else if FileExists(FileName) then
Answer := Format(msgRntoAlready, [FileName])
else if not FileExists(Client.FromFileName) then
Answer := Format(msgRntoNotExists, [Client.FromFileName])
else begin
Client.ToFileName := FileName;
if RenameFile(Client.FromFileName, Client.ToFileName) then
Answer := Format(msgRntoOk, [Client.FromFileName, Client.ToFileName])
else
Answer := Format(msgRntoFailed, [Client.FromFileName]);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandNOOP(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
begin
Client.CurCmdType := ftpcNOOP;
Answer := Format(MsgNoopOk, [Params]);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandMKD(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
var
FileName : String;
Allowed : Boolean;
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
try
Client.CurCmdType := ftpcMKD;
FileName := BuildFilePath(Client.Directory, Params);
Allowed := TRUE;
TriggerMakeDirectory(Client, FileName, Allowed);
if not Allowed then
Answer := Format(msgMkdFailed, [FileName])
else if Params = '' then
Answer := Format(msgMkdSyntax, [Params])
else if FileExists(FileName) then
Answer := Format(msgMkdAlready, [FileName])
else begin
{$I-}
MkDir(FileName);
if IOResult = 0 then
Answer := Format(msgMkdOk, [FileName])
else
Answer := Format(msgMkdFailed, [FileName]);
{$I+}
end;
except
on E:Exception do begin
Answer := Format(msgMkdFailed, [E.Message])
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandAPPE(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
var
Allowed : Boolean;
FilePath : TFtpString;
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
try
Client.CurCmdType := ftpcAPPE;
Client.FileName := SlashesToBackSlashes(Params);
Client.HasOpenedFile := FALSE;
Client.AbortingTransfer := FALSE;
Client.TransferError := 'Transfer Ok';
Allowed := TRUE;
FilePath := BuildFilePath(Client.Directory, Client.FileName);
TriggerValidatePut(Client, FilePath, Allowed);
if not Allowed then begin
Answer := msgAppeDisabled;
Exit;
end;
Client.FilePath := FilePath;
if Client.PassiveMode then begin
Client.DataSocket.OnSessionConnected := ClientStorSessionConnected;
Client.DataSocket.OnSessionClosed := ClientStorSessionClosed;
Client.DataSocket.OnDataAvailable := ClientStorDataAvailable;
Client.DataSocket.OnDataSent := nil;
if Client.PassiveConnected then
Client.DataSocket.OnSessionConnected(Client.DataSocket, 0)
else
Client.PassiveStart := TRUE;
end
else begin
Client.DataSocket.Proto := 'tcp';
Client.DataSocket.Addr := Client.DataAddr;
Client.DataSocket.Port := Client.DataPort;
Client.DataSocket.OnSessionConnected := ClientStorSessionConnected;
Client.DataSocket.OnSessionClosed := ClientStorSessionClosed;
Client.DataSocket.OnDataAvailable := ClientStorDataAvailable;
Client.DataSocket.OnDataSent := nil;
Client.DataSocket.LingerOnOff := wsLingerOff;
Client.DataSocket.LingerTimeout := 0;
Client.DataSocket.Connect;
end;
Client.RestartPos := GetFileSize(Client.FilePath);
if Client.RestartPos < 0 then
Client.RestartPos := 0;
Answer := Format(msgAppeReady, [Params,Client.RestartPos]);
except
on E:Exception do begin
Answer := Format(msgAppeFailed, [E.Message]);
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandSTRU(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
begin
Client.CurCmdType := ftpcSTRU;
Answer := Format(MsgStruOk, [Params]);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function DirExists(Dir : String) : Boolean;
var
F : TSearchRec;
begin
Result := (FindFirst(Dir, faDirectory, F) = 0);
FindClose(F);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandRMD(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
var
FileName : String;
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
Client.CurCmdType := ftpcRMD;
FileName := BuildFilePath(Client.Directory, Params);
if Params = '' then
Answer := Format(msgMkdSyntax, [Params])
else if not DirExists(FileName) then
Answer := Format(msgRmdNotExists, [FileName])
else begin
{$I-}
RmDir(FileName);
if IOResult = 0 then
Answer := Format(msgRmdOk, [FileName])
else
Answer := Format(msgRmdFailed, [FileName]);
{$I+}
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandABOR(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
begin
if Client.DataSocket.State = wsConnected then begin
Client.TransferError := 'ABORT requested by client';
Client.AbortingTransfer := TRUE;
Client.DataSocket.Close;
end;
Answer := msgAborOk;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.CommandPASV(
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString);
var
saddr : TSockAddrIn;
saddrlen : Integer;
DataPort : Integer;
IPAddr : TInAddr;
begin
if Client.FtpState <> ftpcReady then begin
Answer := msgNotLogged;
Exit;
end;
try
{ Get our IP address from our control socket }
saddrlen := SizeOf(saddr);
Client.GetSockName(saddr, saddrlen);
IPAddr := saddr.sin_addr;
Client.DataSocket.Close;
Client.DataSocket.Addr := '0.0.0.0'; { Any addr }
Client.DataSocket.Port := '0'; { Any port }
Client.DataSocket.Proto := 'tcp';
Client.DataSocket.OnSessionAvailable := ClientPassiveSessionAvailable;
Client.DataSocket.OnSessionConnected := nil;
Client.DataSocket.OnSessionClosed := nil;
Client.DataSocket.OnDataAvailable := nil;
Client.DataSocket.Listen;
{ if Client.DataSocket.Listen <> 0 then
raise Exception.Create('Listen failed'); 18/11/98 }
{ Get the port assigned by winsock }
saddrlen := SizeOf(saddr);
Client.DataSocket.GetSockName(saddr, saddrlen);
DataPort := WSocket_ntohs(saddr.sin_port);
if Client.sin.sin_addr.s_addr = WSocket_htonl($7F000001) then
Answer := Format(msgPasvLocal,
[HiByte(DataPort),
LoByte(DataPort)])
else
Answer := Format(msgPasvRemote,
[ord(IPAddr.S_un_b.s_b1),
ord(IPAddr.S_un_b.s_b2),
ord(IPAddr.S_un_b.s_b3),
ord(IPAddr.S_un_b.s_b4),
HiByte(DataPort),
LoByte(DataPort)]);
Client.PassiveMode := TRUE;
Client.PassiveStart := FALSE;
Client.PassiveConnected := FALSE;
except
on E:Exception do begin
Answer := Format(msgPasvExcept, [E.Message]);
try
Client.DataSocket.Close;
except
{ Ignore any exception here }
end;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
end.