{ 
    SemTel version 1.0.0 ... comfortable telnet client
    Copyright (C) 1995-2000 Jan Tomasek <jan@tomasek.cz>

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
unit xFTPSrv;

interface
Uses
  Classes, FTPSrv, FTPSrvC;
Type
  TFTPServerLog = Procedure(Sender: TObject; S:String) of Object;
  TPerm  = (prmNone, prmRead, prmWrite);

  TxFTPServer = class(TFTPServer)
    private
      FOnLog          : TFTPServerLog;

      Function UserPerm(Dir:String):TPerm;
      Procedure Log(Const S:String);
      procedure TriggerServerStart; override;
      procedure TriggerServerStop; override;
      procedure TriggerClientConnect(Client: TFtpCtrlSocket; Error: Word); override;
      procedure TriggerClientDisconnect(Client: TFtpCtrlSocket; Error: Word); override;
      procedure TriggerClientCommand(Client: TFtpCtrlSocket; var Keyword, Params, Answer: TFtpString); override;
      procedure TriggerSendAnswer(Client: TFtpCtrlSocket; var Answer: TFtpString); override;
      procedure TriggerAuthenticate(Client:TFtpCtrlSocket;UserName,PassWord: String; var Authenticated : Boolean); override;
      procedure TriggerChangeDirectory(Client: TFtpCtrlSocket; Directory : String; var Allowed : Boolean); override;
      procedure TriggerMakeDirectory(Client: TFtpCtrlSocket; Directory: String; var Allowed: Boolean); override;
      procedure TriggerValidateGet(Client: TFtpCtrlSocket; var FilePath: TFtpString; var Allowed: Boolean); override;
      procedure TriggerValidatePut(Client: TFtpCtrlSocket; var FilePath: TFtpString; var Allowed: Boolean); override;
      procedure TriggerValidateDele(Client: TFtpCtrlSocket; var FilePath: TFtpString; var Allowed: Boolean); override;
    public
      RODirs   : TStringList;
      RWDirs   : TStringList;
      HomeDir  : String;
      UserName : String;
      Password : String;
      Constructor Create(aOwner:TComponent); override;
      Destructor Destroy; override;
      property OnLog: TFTPServerLog read FOnLog write FOnLog;
  End;

implementation
Uses
  Forms, SysUtils, WinProcs, C3216
  {$IFDEF WIN32},FileCtrl{$ENDIF};

Function TxFTPServer.UserPerm(Dir:String):TPerm;
  Function IsInList(List:TStringList;Dir:String):Boolean;
  Var
    I : Word;
    S : String;
  Begin
    Result:=False;
    If List.Count>0 Then For I:=0 To List.Count-1 Do Begin
      S := List.Strings[I];
      If Pos(S,Dir)>0 Then Begin Result:=True;Exit End;
    End;
  End;
Begin
  Dir:=strUpper(Dir);
  If(RWDirs.Count=0)and(RODirs.Count=0)Then Begin Result:=prmWrite; Exit End;
  If IsInList(RWDirs, Dir) Then Begin Result:=prmWrite; Exit End;
  If IsInList(RODirs, Dir) Then Begin Result:=prmRead; Exit End;
  Result:=prmNone;
End;

Procedure TxFTPServer.Log(Const S:String);
Begin
  If Assigned(FOnLog) Then FOnLog(Self,S);    
End;

Constructor TxFTPServer.Create(aOwner:TComponent);
Begin
  inherited Create(aOwner);

  RODirs := TStringList.Create;
  RWDirs := TStringList.Create;
End;

Destructor TxFTPServer.Destroy;
Begin
  RODirs.Free;
  RWDirs.Free;
  Inherited Destroy;
End;

Procedure TxFTPServer.TriggerServerStart;
Begin
  Inherited TriggerServerStart;
  Start;
  Log(Format('%d: FTP server started',[GetTickCount]));
End;

Procedure TxFTPServer.TriggerServerStop;
Begin
  Inherited TriggerServerStop;
  Stop;
  Log(Format('%d: FTP server stoped',[GetTickCount]));
End;

procedure TxFTPServer.TriggerClientConnect(Client: TFtpCtrlSocket; Error: Word);
begin
  Log(Format('%d: %s Client connect',[GetTickCount,Client.GetPeerAddr]));
  Inherited TriggerClientConnect(Client, Error);
  {$IFNDEF Win32}
  Client.TrumpetCompability:=True;
  {$ENDIF}
  Client.HomeDir:=HomeDir;
end;

procedure TxFTPServer.TriggerClientDisconnect(Client: TFtpCtrlSocket; Error: Word);
begin
  Inherited TriggerClientDisconnect(Client, Error);
  Log(Format('%d: %s Client disconnect',[GetTickCount,Client.GetPeerAddr]));
end;

procedure TxFTPServer.TriggerClientCommand(Client: TFtpCtrlSocket; var Keyword, Params, Answer: TFtpString);
begin
  Inherited TriggerClientCommand(Client, Keyword, Params, Answer);
  Log(Format('%d: %s ---> %s %s',[GetTickCount,Client.GetPeerAddr,Keyword,Params]));
end;

procedure TxFTPServer.TriggerSendAnswer(Client: TFtpCtrlSocket; var Answer: TFtpString);
begin
  Inherited TriggerSendAnswer(Client, Answer);
  Log(Format('%d: %s <--- %s',[GetTickCount,Client.GetPeerAddr,Answer]));
end;

procedure TxFTPServer.TriggerAuthenticate(Client:TFtpCtrlSocket;UserName,PassWord: String; var Authenticated : Boolean);
begin
  Authenticated:=True;
  If Self.UserName<>'' Then Authenticated:=Authenticated and(UserName=Self.UserName);
  If Self.Password<>'' Then Authenticated:=Authenticated and(Password=Self.Password);
  Inherited TriggerAuthenticate(Client,UserName,PassWord,Authenticated);
end;

procedure TxFTPServer.TriggerChangeDirectory(Client: TFtpCtrlSocket; Directory : String; var Allowed : Boolean);
begin
  Allowed := DirectoryExists(Directory);
  Inherited TriggerChangeDirectory(Client, Directory, Allowed);
  If Allowed Then
    Log(Format('%d: %s CWD to "%s" OK',[GetTickCount,Client.GetPeerAddr,Directory]))
  Else
    Log(Format('%d: %s CWD to "%s" Failed',[GetTickCount,Client.GetPeerAddr,Directory]));
end;

procedure TxFTPServer.TriggerMakeDirectory(Client: TFtpCtrlSocket; Directory: String; var Allowed: Boolean);
Begin
  Allowed := UserPerm(Directory)>=prmWrite;
  Inherited TriggerMakeDirectory(Client, Directory, Allowed);
End;

procedure TxFTPServer.TriggerValidateGet(Client: TFtpCtrlSocket; var FilePath: TFtpString; var Allowed: Boolean);
begin
  Allowed := UserPerm(FilePath)>=prmRead;
  Inherited TriggerValidateGet(Client, FilePath, Allowed);
end;

procedure TxFTPServer.TriggerValidatePut(Client: TFtpCtrlSocket; var FilePath: TFtpString; var Allowed: Boolean);
begin
  Allowed := UserPerm(FilePath)>=prmWrite;
  Inherited TriggerValidatePut(Client, FilePath, Allowed);
end;

procedure TxFTPServer.TriggerValidateDele(Client: TFtpCtrlSocket; var FilePath: TFtpString; var Allowed: Boolean);
begin
  Allowed := UserPerm(FilePath)>=prmWrite;
  Inherited TriggerValidateDele(Client, FilePath, Allowed);
end;

end.
