Indy TFtp Server

here's something that i wrote (added from original demo) to do windows dir listings and file send/receive

unit Unit1;

interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  IdBaseComponent, IdComponent, IdTCPServer, IdFTPList, IdFTPServer,
  StdCtrls, scktcomp;

type
  TfFTPServerMain = class(TForm)
    IdFTPServer1: TIdFTPServer;
    bStartStopServer: TButton;
    mLog: TMemo;
    procedure IdFTPServer1ListDirectory(ASender: TIdFTPServerThread;
      const APath: String; ADirectoryListing: TIdFTPListItems);
    procedure bStartStopServerClick(Sender: TObject);
    procedure IdFTPServer1UserLogin(ASender: TIdFTPServerThread;
      const AUsername, APassword: String; var AAuthenticated: Boolean);
    procedure IdFTPServer1ChangeDirectory(ASender: TIdFTPServerThread;
      var VDirectory: String);
    procedure IdFTPServer1StoreFile(ASender: TIdFTPServerThread;
      const AFileName: String; AAppend: Boolean; var VStream: TStream);
    procedure IdFTPServer1RetrieveFile(ASender: TIdFTPServerThread;
      const AFileName: String; var VStream: TStream);
    procedure IdFTPServer1Connect(AThread: TIdPeerThread);
    procedure IdFTPServer1Disconnect(AThread: TIdPeerThread);
  private
    procedure AddToLog(s: string);
    { Private declarations }
  public
    { Public declarations }
  end;

var
  fFTPServerMain: TfFTPServerMain;
function CorrectFTPPath(s: string): string;

IMPLEMENTATION
(* }-=Loki=-{  lokiwashere@yahoo.co.nz   *)
{$R *.DFM}


function CorrectFTPPath(s: string): string;
    begin
        S := StringReplace(S, '//', '\', [rfReplaceAll]);
        S := StringReplace(S, '/', '\', [rfReplaceAll]);
        if ( (S <> '') and (S[1] <> '\') ) then
          S := '\' + S;
        result := s;
    end;

procedure TfFTPServerMain.IdFTPServer1ListDirectory(ASender: TIdFTPServerThread;
    const APath: String; ADirectoryListing: TIdFTPListItems);
    var
        newitem: TIdFTPListItem;
        SearchRec: TSearchRec;
        SearchResult: integer;
        SearchPath: string;
    begin
        AddToLog(ASender.Connection.Socket.Binding.PeerIP + ' - LIST ' + APath);
        SearchPath := CorrectFTPPath(APath);
       
        ADirectoryListing.ListFormat := flfDos;
        SearchResult := FindFirst(SearchPath + '*.*', faAnyFile, SearchRec);
        while SearchResult = 0 do
        begin
            if (SearchRec.Attr and faDirectory) = faDirectory  then
            begin
                newitem := ADirectoryListing.Add;
                newitem.FileName := SearchRec.Name;
                newitem.ItemType := ditDirectory;
                newitem.Size := SearchRec.Size;
                newitem.ModifiedDate := SearchRec.Time;
            end
            else
            begin
                newitem := ADirectoryListing.Add;
                newitem.FileName := SearchRec.Name;
                newitem.ItemType := ditFile;
                newitem.Size := SearchRec.Size;
                newitem.ModifiedDate := SearchRec.Time;
            end;
            SearchResult := FindNext(SearchRec);
        end;
        FindClose(SearchRec);
       
    end;

procedure TfFTPServerMain.bStartStopServerClick(Sender: TObject);
    begin
        IdFTPServer1.Active := (not IdFTPServer1.Active);
        if IdFTPServer1.Active then
        begin
            bStartStopServer.caption := 'Stop Server';
            AddToLog('Started FTP Server');
        end
        else
        begin
            bStartStopServer.caption := 'Start Server';
            AddToLog('Stopped FTP Server');
        end;
    end;

procedure TfFTPServerMain.IdFTPServer1UserLogin(ASender: TIdFTPServerThread;
    const AUsername, APassword: String; var AAuthenticated: Boolean);
    begin
// # Note - do any user authentication here (read user from ini file etc)
        if ( (AUserName = 'ftp') and (APassword = 'ftp') ) then
          AAuthenticated := true;

        if AAuthenticated then
          AddToLog(ASender.Connection.Socket.Binding.PeerIP + ' - LOGIN ' + AUsername)
        else
          AddToLog(ASender.Connection.Socket.Binding.PeerIP + ' - FAILED LOGIN ' + AUsername);
    end;

procedure TfFTPServerMain.IdFTPServer1ChangeDirectory(ASender: TIdFTPServerThread;
    var VDirectory: String);
    begin
        AddToLog(ASender.Connection.Socket.Binding.PeerIP + ' - CD ' + VDirectory);
        VDirectory := StringReplace(VDirectory, '/', '\', [rfReplaceAll]);
    end;

procedure TfFTPServerMain.IdFTPServer1StoreFile(ASender: TIdFTPServerThread;
    const AFileName: String; AAppend: Boolean; var VStream: TStream);
    var
        ActualFilename: string;
    begin
        AddToLog(ASender.Connection.Socket.Binding.PeerIP + ' - PUT ' + AFilename);
        ActualFilename := CorrectFTPPath(AFilename);
        VStream := TFileStream.Create(ActualFilename, fmCreate);
    end;

procedure TfFTPServerMain.IdFTPServer1RetrieveFile(ASender: TIdFTPServerThread;
    const AFileName: String; var VStream: TStream);
    var
        ActualFilename: string;
    begin
        AddToLog(ASender.Connection.Socket.Binding.PeerIP + ' - GET ' + AFilename);
        ActualFilename := CorrectFTPPath(AFilename);
        if FileExists(ActualFilename) then
          VStream := TFileStream.Create(ActualFilename, fmOpenRead+fmShareDenyNone);
    end;

procedure TfFTPServerMain.IdFTPServer1Connect(AThread: TIdPeerThread);
begin
    AddToLog(AThread.Connection.Socket.Binding.PeerIP + ' - Connected');
end;

procedure TfFTPServerMain.IdFTPServer1Disconnect(AThread: TIdPeerThread);
begin
    if assigned(AThread.Connection.Socket.Binding) then
      AddToLog(AThread.Connection.Socket.Binding.PeerIP + ' - Disconnected')
    else
      AddToLog('Remote client disconnected')
end;

procedure TfFTPServerMain.AddToLog(s: string);
    begin
        mLog.Lines.Add(FormatDateTime('dd"-"mmm"-"yyyy" "hh":"nn":"ss" "', Now) + S);
        mLog.Perform(EM_SCROLL,SB_LINEDOWN,0);
        while mLog.Lines.Count > 500 do mLog.Lines.Delete(0);
    end;

end.


// FORM FOLLOWS

object fFTPServerMain: TfFTPServerMain
  Left = 247
  Top = 230
  Width = 575
  Height = 391
  Caption = '}=-Loki=-{ FTP Server example (lokiwashere@yahoo.co.nz)'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object bStartStopServer: TButton
    Left = 8
    Top = 8
    Width = 75
    Height = 25
    Caption = 'Start Server'
    TabOrder = 0
    OnClick = bStartStopServerClick
  end
  object mLog: TMemo
    Left = 8
    Top = 48
    Width = 537
    Height = 297
    ScrollBars = ssBoth
    TabOrder = 1
  end
  object IdFTPServer1: TIdFTPServer
    Bindings = <>
    CommandHandlers = <>
    DefaultPort = 21
    Greeting.NumericCode = 220
    Greeting.Text.Strings = (
      'Indy FTP Server ready.')
    Greeting.TextCode = '220'
    MaxConnectionReply.NumericCode = 0
    OnConnect = IdFTPServer1Connect
    OnDisconnect = IdFTPServer1Disconnect
    ReplyExceptionCode = 0
    ReplyTexts = <>
    ReplyUnknownCommand.NumericCode = 500
    ReplyUnknownCommand.Text.Strings = (
      'Syntax error, command unrecognized.')
    ReplyUnknownCommand.TextCode = '500'
    AnonymousAccounts.Strings = (
      'anonymous'
      'ftp'
      'guest')
    EmulateSystem = ftpsOther
    SystemType = 'WIN32'
    OnChangeDirectory = IdFTPServer1ChangeDirectory
    OnUserLogin = IdFTPServer1UserLogin
    OnListDirectory = IdFTPServer1ListDirectory
    OnRetrieveFile = IdFTPServer1RetrieveFile
    OnStoreFile = IdFTPServer1StoreFile
    Left = 384
    Top = 24
  end
end