unit uFTPServer;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
IdBaseComponent, IdComponent, IdTCPServer, IdCmdTCPServer, IdFTPList,
IdExplicitTLSClientServerBase, IdFTPServer, StdCtrls, IdFTPListOutput;
type
TForm1 =
class(TForm)
btnClose: TButton;
moNotes: TMemo;
procedure IdFTPServer1UserLogin(ASender: TIdFTPServerContext;
const AUsername, APassword:
string;
var AAuthenticated: Boolean);
procedure IdFTPServer1RemoveDirectory(ASender: TIdFTPServerContext;
var VDirectory:
string);
procedure IdFTPServer1MakeDirectory(ASender: TIdFTPServerContext;
var VDirectory:
string);
procedure IdFTPServer1RetrieveFile(ASender: TIdFTPServerContext;
const AFileName:
string;
var VStream: TStream);
procedure IdFTPServer1GetFileSize(ASender: TIdFTPServerContext;
const AFilename:
string;
var VFileSize: Int64);
procedure IdFTPServer1StoreFile(ASender: TIdFTPServerContext;
const AFileName:
string; AAppend: Boolean;
var VStream: TStream);
procedure IdFTPServer1ListDirectory(ASender: TIdFTPServerContext;
const APath:
string; ADirectoryListing: TIdFTPListOutput;
const ACmd,
ASwitches:
string);
procedure FormCreate(Sender: TObject);
procedure IdFTPServer1DeleteFile(ASender: TIdFTPServerContext;
const APathName:
string);
procedure IdFTPServer1ChangeDirectory(ASender: TIdFTPServerContext;
var VDirectory:
string);
procedure btnCloseClick(Sender: TObject);
private
function ReplaceChars(APath:
String):
String;
function GetSizeOfFile(AFile :
String) : Integer;
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
IdFTPServer1: TIdFTPServer;
AppDir :
String;
implementation
{$R *.DFM}
procedure TForm1.btnCloseClick(Sender: TObject);
begin
IdFTPServer1.Active := false;
close;
end;
function TForm1.ReplaceChars(APath:
String):
String;
var
s:
string;
begin
s := StringReplace(APath, '
/', '
\', [rfReplaceAll]);
s := StringReplace(s, '
\\', '
\', [rfReplaceAll]);
Result := s;
end;
function TForm1.GetSizeOfFile(AFile :
String) : Integer;
var
FStream : TFileStream;
begin
Try
FStream := TFileStream.Create(AFile, fmOpenRead);
Try
Result := FStream.Size;
Finally
FreeAndNil(FStream);
End;
Except
Result := 0;
End;
end;
procedure TForm1.IdFTPServer1ChangeDirectory(
ASender: TIdFTPServerContext;
var VDirectory:
string);
begin
ASender.CurrentDir := VDirectory;
end;
procedure TForm1.IdFTPServer1DeleteFile(ASender: TIdFTPServerContext;
const APathName:
string);
begin
DeleteFile(ReplaceChars(AppDir+ASender.CurrentDir+'
\'+APathname));
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
idftpserver1 := tidftpserver.create(self);
with idftpserver1
do
begin
Active := True;
// Bindings := [];
DefaultPort := 21;
// CommandHandlers := [];
ExceptionReply.Code := '
500';
ExceptionReply.Text.Add('
Unknown Internal Error');
Greeting.Code := '
220';
Greeting.Text.Add('
Indy FTP Server ready.');
HelpReply.Text.Add('
Help follows');
MaxConnectionReply.Code := '
300';
MaxConnectionReply.Text.Add('
Too many connections. Try again later.');
// ReplyTexts = <>
ReplyUnknownCommand.Code := '
500';
ReplyUnknownCommand.Text.Add('
Syntax error, command unrecognized.');
AllowAnonymousLogin := True;
AnonymousAccounts.Add('
anonymous');
AnonymousAccounts.Add('
ftp');
AnonymousAccounts.Add('
guest');
AnonymousPassStrictCheck := False;
SystemType := '
WIN32';
OnChangeDirectory := IdFTPServer1ChangeDirectory;
OnGetFileSize := IdFTPServer1GetFileSize;
OnUserLogin := IdFTPServer1UserLogin;
OnListDirectory := IdFTPServer1ListDirectory;
OnDeleteFile := IdFTPServer1DeleteFile;
OnRetrieveFile := IdFTPServer1RetrieveFile;
OnStoreFile := IdFTPServer1StoreFile;
OnMakeDirectory := IdFTPServer1MakeDirectory;
OnRemoveDirectory := IdFTPServer1RemoveDirectory;
// SITECommands = <>
MLSDFacts := [];
ReplyUnknownSITCommand.Code := '
500';
ReplyUnknownSITCommand.Text.Add('
Invalid SITE command.');
{Active := true;
Bindings :=;
OnUserLogin := IdFTPServer1UserLogin;
OnRemoveDirectory := IdFTPServer1RemoveDirectory;
OnMakeDirectory := IdFTPServer1MakeDirectory;
OnRetrieveFile := IdFTPServer1RetrieveFile;
OnGetFileSize := IdFTPServer1GetFileSize;
OnStoreFile := IdFTPServer1StoreFile;
OnListDirectory := IdFTPServer1ListDirectory;
OnDeleteFile := IdFTPServer1DeleteFile;
OnChangeDirectory := IdFTPServer1ChangeDirectory; }
end;
AppDir := ExtractFilePath(Application.Exename);
end;
procedure TForm1.IdFTPServer1ListDirectory(ASender: TIdFTPServerContext;
const APath:
string; ADirectoryListing: TIdFTPListOutput;
const ACmd,
ASwitches:
string);
var
LFTPItem :TIdFTPListItem;
SR : TSearchRec;
SRI : Integer;
begin
ADirectoryListing.DirFormat := doUnix;
SRI := FindFirst(AppDir + APath + '
\*.*', faAnyFile - faHidden - faSysFile, SR);
While SRI = 0
do
begin
LFTPItem := ADirectoryListing.Add;
LFTPItem.FileName := SR.
Name;
LFTPItem.Size := SR.Size;
LFTPItem.ModifiedDate := FileDateToDateTime(SR.Time);
if SR.Attr = faDirectory
then
LFTPItem.ItemType := ditDirectory
else
LFTPItem.ItemType := ditFile;
SRI := FindNext(SR);
end;
FindClose(SR);
SetCurrentDir(AppDir + APath + '
\..');
end;
procedure TForm1.IdFTPServer1StoreFile(ASender: TIdFTPServerContext;
const AFileName:
string; AAppend: Boolean;
var VStream: TStream);
begin
if not Aappend
then
VStream := TFileStream.Create(ReplaceChars(AppDir+AFilename),fmCreate)
else
VStream := TFileStream.Create(ReplaceChars(AppDir+AFilename),fmOpenWrite)
end;
procedure TForm1.IdFTPServer1GetFileSize(ASender: TIdFTPServerContext;
const AFilename:
string;
var VFileSize: Int64);
Var
LFile :
String;
begin
LFile := ReplaceChars( AppDir + AFilename );
try
If FileExists(LFile)
then
VFileSize := GetSizeOfFile(LFile)
else
VFileSize := 0;
except
VFileSize := 0;
end;
end;
procedure TForm1.IdFTPServer1RetrieveFile(ASender: TIdFTPServerContext;
const AFileName:
string;
var VStream: TStream);
begin
VStream := TFileStream.Create(ReplaceChars(AppDir+AFilename),fmOpenRead);
end;
procedure TForm1.IdFTPServer1MakeDirectory(ASender: TIdFTPServerContext;
var VDirectory:
string);
begin
if not ForceDirectories(ReplaceChars(AppDir + VDirectory))
then
begin
Raise Exception.Create('
Unable to create directory');
end;
end;
procedure TForm1.IdFTPServer1RemoveDirectory(ASender: TIdFTPServerContext;
var VDirectory:
string);
Var
LFile :
String;
begin
LFile := ReplaceChars(AppDir + VDirectory);
// You should delete the directory here.
// TODO
end;
procedure TForm1.IdFTPServer1UserLogin(ASender: TIdFTPServerContext;
const AUsername, APassword:
string;
var AAuthenticated: Boolean);
begin
// We just set AAuthenticated to true so any username / password is accepted
// You should check them here - AUsername and APassword
showmessage('
asd');
AAuthenticated := True;
end;
end.