//Delphi FTP-сервер
{ $HDR$}

program FTPServer_console;

{$APPTYPE console}
uses
  Classes, Windows, SysUtils, IdFTPList, IdFTPServer, idTCPServer,
  IdSocketHandle, idGlobal, IdHashCRC;

type
//Delphi FTP-сервер
  TFTPServer = class
  private
    { Private declarations }
    IdFTPServer: tIdFTPServer;
    procedure IdFTPServer1UserLogin(ASender: TIdFTPServerThread; const AUsername, APassword: string; var AAuthenticated: Boolean);
    procedure IdFTPServer1ListDirectory(ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems);
    procedure IdFTPServer1RenameFile(ASender: TIdFTPServerThread; const ARenameFromFile, ARenameToFile: string);
    procedure IdFTPServer1RetrieveFile(ASender: TIdFTPServerThread; const AFilename: string; var VStream: TStream);
    procedure IdFTPServer1StoreFile(ASender: TIdFTPServerThread; const AFilename: string; AAppend: Boolean; var VStream: TStream);
    procedure IdFTPServer1RemoveDirectory(ASender: TIdFTPServerThread; var VDirectory: string);
    procedure IdFTPServer1MakeDirectory(ASender: TIdFTPServerThread; var VDirectory: string);
    procedure IdFTPServer1GetFileSize(ASender: TIdFTPServerThread; const AFilename: string; var VFileSize: Int64);
    procedure IdFTPServer1DeleteFile(ASender: TIdFTPServerThread; const APathname: string);
    procedure IdFTPServer1ChangeDirectory(ASender: TIdFTPServerThread; var VDirectory: string);
    procedure IdFTPServer1CommandXCRC(ASender: TIdCommand);
    procedure IdFTPServer1DisConnect(AThread: TIdPeerThread);
  protected
    function TransLatePath(const APathname, homeDir: string): string;
  public
    constructor Create; reintroduce;
    destructor Destroy; override;
  end;

//Delphi FTP-сервер
constructor TFTPServer.Create;
begin
 IdFTPServer:=tIdFTPServer.create(nil);
 IdFTPServer.DefaultPort:=21;
 IdFTPServer.AllowAnonymousLogin:=false;
 IdFTPServer.EmulateSystem:=ftpsUNIX;
 IdFTPServer.HelpReply.text:='Help is not implemented';
 IdFTPServer.OnChangeDirectory:=IdFTPServer1ChangeDirectory;
 IdFTPServer.OnChangeDirectory:=IdFTPServer1ChangeDirectory;
 IdFTPServer.OnGetFileSize:=IdFTPServer1GetFileSize;
 IdFTPServer.OnListDirectory:=IdFTPServer1ListDirectory;
 IdFTPServer.OnUserLogin:=IdFTPServer1UserLogin;
 IdFTPServer.OnRenameFile:=IdFTPServer1RenameFile;
 IdFTPServer.OnDeleteFile:=IdFTPServer1DeleteFile;
 IdFTPServer.OnRetrieveFile:=IdFTPServer1RetrieveFile;
 IdFTPServer.OnStoreFile:=IdFTPServer1StoreFile;
 IdFTPServer.OnMakeDirectory:=IdFTPServer1MakeDirectory;
 IdFTPServer.OnRemoveDirectory:=IdFTPServer1RemoveDirectory;
 IdFTPServer.Greeting.NumericCode:=220;
 IdFTPServer.OnDisconnect:=IdFTPServer1DisConnect;
 with IdFTPServer.CommandHandlers.add do
  begin
   Command:='XCRC';
   OnCommand:=IdFTPServer1CommandXCRC;
  end;
 IdFTPServer.Active:=true;
end;

//Delphi FTP-сервер
function CalculateCRC(const path: string): string;
var
 f: tfilestream;
 value: dword;
 IdHashCRC32: TIdHashCRC32;
begin
 IdHashCRC32:=nil;
 f:=nil;
 try
  IdHashCRC32:=TIdHashCRC32.create;
  f:=TFileStream.create(path, fmOpenRead or fmShareDenyWrite);
  value:=IdHashCRC32.HashValue(f);
  result:=IntToHex(value, 8);
 finally
  f.free;
  IdHashCRC32.free;
 end;
end;

//Delphi FTP-сервер
procedure TFTPServer.IdFTPServer1CommandXCRC(ASender: TIdCommand);
// note, this is made up, and not defined in any rfc
var
 s: string;
begin
 with TIdFTPServerThread(ASender.Thread) do
  begin
   if Authenticated
   then
    begin
     try
      s:=ProcessPath(CurrentDir, ASender.UnparsedParams);
      s:=TransLatePath(s, TIdFTPServerThread(ASender.Thread).HomeDir);
      ASender.Reply.SetReply(213, CalculateCRC(s));
     except
      ASender.Reply.SetReply(500, 'File Error!');
     end;
    end;
  end;
end;

//Delphi FTP-сервер
destructor TFTPServer.Destroy;
begin
 IdFTPServer.Free;
 inherited Destroy;
end;

//Delphi FTP-сервер
function StartsWith(const str, substr: string): boolean;
begin
 result:=Copy(str, 1, length(substr))=substr;
end;

//Delphi FTP-сервер
function BackSlashToSlash(const str: string): string;
var
 a: dword;
begin
 result:=str;
 for a:=1 to length(result) do
  if result[a]='\'
  then result[a]:='/';
end;

//Delphi FTP-сервер
function SlashToBackSlash(const str: string): string;
var
 a: dword;
begin
 result:=str;
 for a:=1 to length(result) do
   if result[a]='/'
   then result[a]:='\';
end;

//Delphi FTP-сервер
function TFTPServer.TransLatePath(const APathname, homeDir: string): string;
var
 tmppath: string;
begin
 result:=SlashToBackSlash(homeDir);
 tmppath:=SlashToBackSlash(APathname);
 if homedir = '/'
 then
  begin
   result:=tmppath;
   Exit;
  end;
 if length(APathname)=0
 then Exit;
 if result[length(result)]='\'
 then result:=copy(result, 1, length(result)-1);
 if tmppath[1]<>'\'
 then result:=result+'\';
 result:=result+tmppath;
end;

//Delphi FTP-сервер
function GetSizeOfFile(const APathname: string): int64;
begin
 result:=FileSizeByName(APathname);
end;

//Delphi FTP-сервер
function GetNewDirectory(old, action: string): string;
var
 a: integer;
begin
 if action='../'
 then
  begin
   if old='/'
   then
    begin
     result:=old;
     Exit;
    end;
   a:=length(old)-1;
   while(old[a]<>'\') and (old[a]<>'/') do
    dec(a) ;
   result:=copy(old, 1, a);
   Exit;
  end;
 if (action[1]='/') or (action[1]='\')
 then result:=action
 else result:=old+action;
end;

//Delphi FTP-сервер
procedure TFTPServer.IdFTPServer1UserLogin(ASender: TIdFTPServerThread;
  const AUsername, APassword: string; var AAuthenticated: Boolean);
begin
 //AAuthenticated:=(AUsername='123') and (APassword='123');
 AAuthenticated := true;
 if not AAuthenticated
 then Exit;
 ASender.HomeDir:='.';
 ASender.currentdir:='pool';
end;

//Delphi FTP-сервер
procedure TFTPServer.IdFTPServer1ListDirectory(ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems);

  procedure AddlistItem(aDirectoryListing: TIdFTPListItems; Filename: string; ItemType: TIdDirItemType; size: int64; date: tdatetime);
  var
   listitem: TIdFTPListItem;
  begin
   listitem:=aDirectoryListing.Add;
   listitem.ItemType:=ItemType;
   listitem.FileName:=Filename;
   listitem.OwnerName:='123';
   listitem.GroupName:='all';
   listitem.OwnerPermissions:='---';
   listitem.GroupPermissions:='---';
   listitem.UserPermissions:='---';
   listitem.Size:=size;
   listitem.ModifiedDate:=date;
  end;

var
 f: tsearchrec;
 a: integer;
begin
 ADirectoryListing.DirectoryName:=apath;
 a:=FindFirst(TransLatePath(apath, ASender.HomeDir)+'*.*', faAnyFile, f);
 while (a=0) do
  begin
   if (f.Attr and faDirectory> 0)
   then AddlistItem(ADirectoryListing, f.Name, ditDirectory, f.size, FileDateToDateTime(f.Time))
   else AddlistItem(ADirectoryListing, f.Name, ditFile, f.size, FileDateToDateTime(f.Time));
   a:=FindNext(f);
  end;
 FindClose(f);
end;

//Delphi FTP-сервер
procedure TFTPServer.IdFTPServer1RenameFile( ASender: TIdFTPServerThread;
  const ARenameFromFile, ARenameToFile: string);
begin
 if not MoveFile(pchar(TransLatePath(ARenameFromFile, ASender.HomeDir ) ) , pchar( TransLatePath( ARenameToFile, ASender.HomeDir)))
 then RaiseLastWin32Error;
end;

//Delphi FTP-сервер
procedure TFTPServer.IdFTPServer1RetrieveFile(ASender: TIdFTPServerThread;
  const AFilename: string; var VStream: TStream);
begin
 VStream:=TFileStream.create(translatepath(AFilename, ASender.HomeDir ) , fmopenread or fmShareDenyWrite);
end;

procedure TFTPServer.IdFTPServer1StoreFile(ASender: TIdFTPServerThread;
  const AFilename: string; AAppend: Boolean; var VStream: TStream);
begin
 if FileExists(translatepath(AFilename, ASender.HomeDir)) and AAppend
 then
  begin
   VStream:=TFileStream.create(translatepath(AFilename, ASender.HomeDir), fmOpenWrite or fmShareExclusive);
   VStream.Seek(0,soFromEnd);
  end
 else VStream:=TFileStream.create(translatepath(AFilename, ASender.HomeDir), fmCreate or fmShareExclusive);
end;

procedure TFTPServer.IdFTPServer1RemoveDirectory(ASender: TIdFTPServerThread;
  var VDirectory: string);
begin
 RmDir(TransLatePath(VDirectory, ASender.HomeDir));
end;

procedure TFTPServer.IdFTPServer1MakeDirectory(ASender: TIdFTPServerThread;
  var VDirectory: string);
begin
 MkDir(TransLatePath(VDirectory, ASender.HomeDir));
end;

procedure TFTPServer.IdFTPServer1GetFileSize(ASender: TIdFTPServerThread;
  const AFilename: string; var VFileSize: Int64);
begin
 VFileSize:=GetSizeOfFile(TransLatePath(AFilename, ASender.HomeDir));
end;

procedure TFTPServer.IdFTPServer1DeleteFile(ASender: TIdFTPServerThread;
  const APathname: string);
begin
 DeleteFile(pchar(TransLatePath(ASender.CurrentDir+'/'+APathname, ASender.HomeDir)));
end;

procedure TFTPServer.IdFTPServer1ChangeDirectory( ASender: TIdFTPServerThread;
  var VDirectory: string ) ;
begin
 VDirectory:=GetNewDirectory(ASender.CurrentDir, VDirectory);
end;

procedure TFTPServer.IdFTPServer1DisConnect(AThread: TIdPeerThread);
begin
 // nothing much here
end;

begin
 with TFTPServer.Create do
  try
   SetConsoleTitle('FTP Server running ...');
   writeln('Running, press [ Enter ] to terminate ...');
   readln;
 finally
  Free;
 end;
end.
//Delphi FTP-сервер