FTP Server demo with Indy components

Problem/Question/Abstract:

Make FTP server.

Answer:

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IdBaseComponent, IdComponent, IdTCPServer, IdFTPServer,idftplist,
  IdUserAccounts, StdCtrls;

  public
    function WindowsDirFixup(APath:String):String;
    { Public declarations }
  end;

var
  Form1: TForm1;
pRoot:string; //program directory.

implementation
uses JCLFileUtils;
{$R *.dfm}

function TForm1.WindowsDirFixup(APath:String):String;
var s:string;

  function ReplaceStr(const S, Srch, Replace: string): string;
  var
    I: Integer;
    Source: string;
  begin
    Source := S;
    Result := '';
    repeat
      I := Pos(Srch, Source);
      if I > 0 then begin
        Result := Result + Copy(Source, 1, I - 1) + Replace;
        Source := Copy(Source, I + Length(Srch), MaxInt);
      end
      else Result := Result + Source;
    until I <= 0;
  end;

begin
  s := ReplaceStr(APath,'/','\');
  s := ReplaceStr(s,'\\','\');
  Result := s;
end;


procedure TForm1.IdFTPServer1ListDirectory(ASender: TIdFTPServerThread;
  const APath: String; ADirectoryListing: TIdFTPListItems);
var Li :TIdFTPListItem;
    SRec : TSearchRec;
    a : word;
begin
  ADirectorylisting.DirectoryName :=Apath;
  ADirectorylisting.ListFormat:=flfdos;
  memo1.lines.add(apath);
//  a := FindFirst(pRoot+APath+'\*.*',$31,Srec); //ignore hidden/system files.
  a := FindFirst(pRoot+APath+'\*.*',faAnyFile        ,Srec); //all files.
  While a =0 do
  begin
    li := ADirectoryListing.Add;
    li.FileName := SRec.Name;
    li.Size := SRec.Size;
    li.ModifiedDate := FileDateToDateTime(SRec.Time);
    if (SRec.Attr and $10) > 0 then
      li.ItemType   := ditDirectory
      else
       li.ItemType   := ditFile;
    a := FindNext(SRec);
  end;
  FindClose(SRec);
//  SysUtils.SetCurrentDir(pRoot+APath+'\..'); //Release dir, so it can be deleted, possibly
end;


procedure TForm1.IdFTPServer1Disconnect(AThread: TIdPeerThread);
begin
    athread.Terminate;
end;

procedure TForm1.IdFTPServer1AfterUserLogin(ASender: TIdFTPServerThread);
begin
asender.CurrentDir:='c:\';
asender.HomeDir:='c:\';
end;

procedure TForm1.IdFTPServer1MakeDirectory(ASender: TIdFTPServerThread;
  var VDirectory: String);
begin
begin
  if not ForceDirectories(WindowsDirFixup(pRoot+Vdirectory)) then
  begin
//    Raise Exception.Create('Could not create directory');
  end;
end;

end;

procedure TForm1.IdFTPServer1RetrieveFile(ASender: TIdFTPServerThread;
  const AFileName: String; var VStream: TStream);
begin
try
  VStream := TFileStream.Create(WindowsDirFixup(pRoot+AFilename),fmOpenRead);
  except
  end;
end;


procedure TForm1.IdFTPServer1ChangeDirectory(ASender: TIdFTPServerThread;
  var VDirectory: String);
begin
//ASender.CurrentDir :=ASender.CurrentDir+Vdirectory;//'/';
if vdirectory='..\' then vdirectory:=ASender.CurrentDir+'\..\';
//if vdirectory='../' then vdirectory:='c:';
ASender.CurrentDir :=Vdirectory;//'/';
  memo1.lines.add('Changedir: '+vdirectory);

end;

procedure TForm1.IdFTPServer1StoreFile(ASender: TIdFTPServerThread;
  const AFileName: String; AAppend: Boolean; var VStream: TStream);
begin
  if not Aappend then
    VStream := TFileStream.Create(WindowsDirFixup(pRoot+AFilename),fmCreate)
   else
      VStream := TFileStream.Create(WindowsDirFixup(pRoot+AFilename),fmOpenWrite)
end;


procedure TForm1.IdFTPServer1GetFileSize(ASender: TIdFTPServerThread;
  const AFilename: String; var VFileSize: Int64);
  var s:string;
  begin
  s := WindowsDirFixup(pRoot+AFilename);
  try
  If FileExists(s) then
    VFileSize :=  GetSizeofFile(S)
    else VFileSize := 0;
  except
    VFileSize := 0;
  end;
end;



procedure TForm1.IdFTPServer1DeleteFile(ASender: TIdFTPServerThread;
  const APathName: String);
begin
  DeleteFile(WindowsDirFixup(pRoot+ASender.CurrentDir+'\'+APathname));
end;


procedure TForm1.IdFTPServer1RemoveDirectory(ASender: TIdFTPServerThread;
  var VDirectory: String);
var s:String;

begin
  s := WindowsDirFixup(pRoot+Vdirectory);
  if DirectoryExists(s) then
  begin
    SetCurrentDir(s+'\..\'); //get out of dir. so it can be deleted.
  if not DelTree(s) then //dir and all files.
  if not RemoveDir(s) then ;//
  begin
//    Raise Exception.Create('Could not remove directory');
  end;
  end;

end;

procedure TForm1.IdFTPServer1RenameFile(ASender: TIdFTPServerThread;
  const ARenameFromFile, ARenameToFile: String);
var sf,st:String;
begin
  sf := WindowsDirFixup(pRoot+ASender.CurrentDir+'\'+ARenameFromFile);
  st := WindowsDirFixup(pRoot+ASender.CurrentDir+'\'+ARenameToFile);
  if not Renamefile(sf,st) then
  begin
    Raise Exception.Create('Could not rename file');
  end;

end;