ftpsrvr.pas

Source code Delphi FTP-server

{$A+,B-,C+,D+,E-,F-,G+,H-,I-,J+,K-,L+,M-,N+,O-,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+,Z1}
unit FtpSrvr;

{--------------------------------------------------------------------}
{ FtpSrvr module. Definition of the FtpSrvr object.                  }
{ 11/15/1999 Drt.                                                    }
{--------------------------------------------------------------------}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  FtpObj, CntrlTrd, TrdBase, WinSock, SrvCtrl;

type
 TEventInfo = record
   Event  : word;
   Error  : word;
   User   : string;
   Pwd    : string;
   Group  : string;
   Home   : string;
   CDir   : string;
   Fname  : string;
   Cmd    : string;
   Par    : string;
   IP     : array [1..4] of byte;
   Done   : boolean;
   Result : boolean;
   end;

type
  TLogEvent   = procedure (Sender : TFtpThreades; var Event : TEventInfo) of object;
  TUserEvent  = procedure (Sender : TObject; var Event : TEventInfo) of object;
  TErrorEvent = procedure (Sender : TObject; ErrNo : integer) of object;

type
  TFtpSrvr = class(TFtpComponent)
  private
    FEnabled       : Boolean;
    FOnLog         : TLogEvent;
    FOnLogin       : TUserEvent;
    FOnLogout      : TUserEvent;
    FOnChDir       : TUserEvent;
    FOnDownload    : TUserEvent;
    FOnUpload      : TUserEvent;
    FOnCommand     : TUserEvent;
    FOnError       : TErrorEvent;
    { -------------------------- }
    ControlThread  : TControlThread;
    WD             : tWsaData;
    procedure WEnabled(AEnabled : Boolean);
    procedure ControlLog(AThreade : TFtpThreades; var AResult : boolean);
  public
    Error  : integer;
    constructor create(AOwner : TComponent); override;
    destructor destroy; override;
    procedure Open;
    procedure Close;
    procedure FillEventInfo(AThread : TFtpThreades; var AEventInfo : TEventInfo; Event,Error : word);
    function Load : boolean;
    function Save : boolean;
  published
    { Properties }
    property Enabled       : Boolean read FEnabled write WEnabled;
    { Events }
    property OnLog         : TLogEvent read FOnLog write FOnLog;
    property OnLogin       : TUserEvent read FOnLogin write FOnLogin;
    property OnLogout      : TUserEvent read FOnLogout write FOnLogout;
    property OnChDir       : TUserEvent read FOnChDir write FOnChDir;
    property OnDownload    : TUserEvent read FOnDownload write FOnDownload;
    property OnUpload      : TUserEvent read FOnUpload write FOnUpload;
    property OnCommand     : TUserEvent read FOnCommand write FOnCommand;
    property OnError       : TErrorEvent read FOnError write FOnError;
  end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Drt', [TFtpSrvr]);
end;

{$B+}
function TFtpSrvr.Load;
var
 h,h1 : hKey;
 i : word;
 w : dword;
 s : string[20];
 s1: string[81];
 p : boolean;
begin
result:=false;
RegOpenKey(HKEY_LOCAL_MACHINE,'SOFTWARE',h1);
if RegOpenKey(h1,'Drt.',h) <> ERROR_SUCCESS then
  begin
  RegCloseKey(h1);
  exit;
  end;
RegCloseKey(h1);
if RegOpenKey(h,'TFTP',h1) <> ERROR_SUCCESS then
  begin
  RegCloseKey(h);
  exit;
  end;
RegCloseKey(h);
w:=sizeof(FDirRestrict);
if RegQueryValueEx(h1,'DirRestrict',nil,nil,@FDirRestrict,@w) <> ERROR_SUCCESS then
  FDirRestrict:=false;
w:=sizeof(FListFormat);
if RegQueryValueEx(h1,'ListFormat',nil,nil,@FListFormat,@w) <> ERROR_SUCCESS then
  FListFormat:=lf_UNIX;
w:=253;
if RegQueryValueEx(h1,'CustomList',nil,nil,@FCustomList[1],@w) <> ERROR_SUCCESS then
  FCustomList:='%r %I:3 %g:9 %s:10 %d:12 %f'
else
  SetStringSize(FCustomList,253);
w:=sizeof(FMaxConn);
if RegQueryValueEx(h1,'MaxConn',nil,nil,@FMaxConn,@w) <> ERROR_SUCCESS then
  FMaxConn:=10;
w:=sizeof(FFtpPort);
if RegQueryValueEx(h1,'FtpPort',nil,nil,@FFtpPort,@w) <> ERROR_SUCCESS then
  FFtpPort:=21;
w:=sizeof(FDataPort);
if RegQueryValueEx(h1,'DataPort',nil,nil,@FDataPort,@w) <> ERROR_SUCCESS then
  FDataPort:=20;
w:=sizeof(FShowHidden);
if RegQueryValueEx(h1,'ShowHidden',nil,nil,@FShowHidden,@w) <> ERROR_SUCCESS then
  FShowHidden:=false;
w:=sizeof(FShowReadOnly);
if RegQueryValueEx(h1,'ShowReadOnly',nil,nil,@FShowReadOnly,@w) <> ERROR_SUCCESS then
  FShowReadOnly:=false;
w:=sizeof(FMode);
if RegQueryValueEx(h1,'Mode',nil,nil,@FMode,@w) <> ERROR_SUCCESS then
  FMode:=md_ASCII;
w:=sizeof(FAllowRedirect);
if RegQueryValueEx(h1,'AllowRedirect',nil,nil,@FAllowRedirect,@w) <> ERROR_SUCCESS then
  FAllowRedirect:=true;
w:=sizeof(FAllowAnonymous);
if RegQueryValueEx(h1,'AllowAnonymous',nil,nil,@FAllowAnonymous,@w) <> ERROR_SUCCESS then
  FAllowAnonymous:=true;
FBannerMsg.Clear;
p:=true;
for i:=1 to 100 do
  begin
  s:=format('Banner%u',[i])+#0;
  w:=80;
  if RegQueryValueEx(h1,@s[1],nil,nil,@s1[1],@w) = ERROR_SUCCESS then
    begin
    SetStringSize(s1,81);
    FBannerMsg.Add(s1);
    p:=false;
    end;
  end;
if p then
  begin
  FBannerMsg.Add('------------------------------------------------------------------');
  FBannerMsg.Add('Experimental FTP server based on FtpSrvr component for Delphi 4.');
  FBannerMsg.Add('Please, report any error to [e-mail]');
  FBannerMsg.Add('------------------------------------------------------------------');
  end;
w:=253;
if RegQueryValueEx(h1,'PasswordMsg',nil,nil,@FPasswordMsg[1],@w) <> ERROR_SUCCESS then
  FPasswordMsg:='Please, enter the password for user %u (%h)'
else
  SetStringSize(FPasswordMsg,253);
w:=253;
if RegQueryValueEx(h1,'FreePasswdMsg',nil,nil,@FFreePasswdMsg[1],@w) <> ERROR_SUCCESS then
  FFreePasswdMsg:='Guest login ok. Enter e-mail as a password.'
else
  SetStringSize(FFreePasswdMsg,253);
w:=253;
if RegQueryValueEx(h1,'NoAnonymousMsg',nil,nil,@FNoAnonymousMsg[1],@w) <> ERROR_SUCCESS then
  FNoAnonymousMsg:='User %u is unknown. No anonymous login allowed.'
else
  SetStringSize(FNoAnonymousMsg,253);
w:=sizeof(FCaseSensitive);
if RegQueryValueEx(h1,'CaseSensitive',nil,nil,@FCaseSensitive,@w) <> ERROR_SUCCESS then
  FCaseSensitive:=false;
result:=DirList.Load and UserList.Load and GrpList.Load;
end;
{$B-}

{$B+}
function TFtpSrvr.Save;
var
 h,h1 : hKey;
 w : word;
 i : word;
 s : string[20];
 s1: string[81];
begin
RegOpenKey(HKEY_LOCAL_MACHINE,'SOFTWARE',h1);
RegCreateKey(h1,'Drt.',h);
RegCloseKey(h1);
RegCreateKey(h,'TFTP',h1);
RegCloseKey(h);
DeleteSubkeys(h1);
w:=sizeof(FDirRestrict);
RegSetValueEx(h1,'DirRestrict',0,REG_BINARY,@FDirRestrict,w);
w:=sizeof(FListFormat);
RegSetValueEx(h1,'ListFormat',0,REG_BINARY,@FListFormat,w);
w:=length(FCustomList)+1;
FCustomList[length(FCustomList)+1]:=#0;
RegSetValueEx(h1,'CustomList',0,REG_SZ,@FCustomList[1],w);
w:=sizeof(FMaxConn);
RegSetValueEx(h1,'MaxConn',0,REG_BINARY,@FMaxConn,w);
w:=sizeof(FFtpPort);
RegSetValueEx(h1,'FtpPort',0,REG_BINARY,@FFtpPort,w);
w:=sizeof(FDataPort);
RegSetValueEx(h1,'DataPort',0,REG_BINARY,@FDataPort,w);
w:=sizeof(FShowHidden);
RegSetValueEx(h1,'ShowHidden',0,REG_BINARY,@FShowHidden,w);
w:=sizeof(FShowReadOnly);
RegSetValueEx(h1,'ShowReadOnly',0,REG_BINARY,@FShowReadOnly,w);
w:=sizeof(FMode);
RegSetValueEx(h1,'Mode',0,REG_BINARY,@FMode,w);
w:=sizeof(FAllowRedirect);
RegSetValueEx(h1,'AllowRedirect',0,REG_BINARY,@FAllowRedirect,w);
w:=sizeof(FAllowAnonymous);
RegSetValueEx(h1,'AllowAnonymous',0,REG_BINARY,@FAllowAnonymous,w);
if FBannerMsg.Count > 0 then
  begin
  for i:=0 to FBannerMsg.Count-1 do
    begin
    s:=format('Banner%u',[i+1])+#0;
    s1:=FBannerMsg[i]+#0;
    w:=length(s1);
    RegSetValueEx(h1,@s[1],0,REG_SZ,@s1[1],w);
    end;
  end;
w:=length(FPasswordMsg)+1;
FPasswordMsg[length(FPasswordMsg)+1]:=#0;
RegSetValueEx(h1,'PasswordMsg',0,REG_SZ,@FPasswordMsg[1],w);
w:=length(FFreePasswdMsg)+1;
FFreePasswdMsg[length(FFreePasswdMsg)+1]:=#0;
RegSetValueEx(h1,'FreePasswdMsg',0,REG_SZ,@FFreePasswdMsg[1],w);
w:=length(FNoAnonymousMsg)+1;
FNoAnonymousMsg[length(FNoAnonymousMsg)+1]:=#0;
RegSetValueEx(h1,'NoAnonymousMsg',0,REG_SZ,@FNoAnonymousMsg[1],w);
w:=sizeof(FCaseSensitive);
RegSetValueEx(h1,'CaseSensitive',0,REG_BINARY,@FCaseSensitive,w);
result:=DirList.Save and UserList.Save and GrpList.Save;
end;
{$B-}

procedure TFtpSrvr.FillEventInfo;
var
 i : integer;
begin
AEventInfo.Event:=Event;
AEventInfo.Error:=Error;
AEventInfo.User:='';
AEventInfo.Pwd:='';
AEventInfo.Group:='';
AEventInfo.Home:='';
AEventInfo.CDir:='';
AEventInfo.FName:='';
AEventInfo.Cmd:='';
AEventInfo.Par:='';
AEventInfo.IP[1]:=0;
AEventInfo.IP[2]:=0;
AEventInfo.IP[3]:=0;
AEventInfo.IP[4]:=0;
AEventInfo.Done:=true;
AEventInfo.Result:=true;
if AThread = nil then exit;
AEventInfo.User:=AThread.Usr;
AEventInfo.Pwd:=AThread.Pwd;
if AThread.Usr = '' then
  AEventInfo.Group:=''
else
  begin
  i:=UserList.GIDByName(AThread.Usr,1);
  if i >= 0 then
  AEventInfo.Group:=GrpList.Name[i]
  end;
AEventInfo.Home:=UserList.HomeByName(AThread.Usr);
AEventInfo.CDir:=AThread.CDir;
AEventInfo.FName:=AThread.FName;
AEventInfo.Cmd:=AThread.Cmd;
AEventInfo.Par:=AThread.Par;
AEventInfo.IP[1]:=AThread.RAddr[1];
AEventInfo.IP[2]:=AThread.RAddr[2];
AEventInfo.IP[3]:=AThread.RAddr[3];
AEventInfo.IP[4]:=AThread.RAddr[4];
end;

procedure TFtpSrvr.WEnabled(AEnabled : Boolean);
begin
FEnabled:=AEnabled;
if not (csDesigning in componentstate) then
  begin
  if FEnabled then
    ControlThread:=TControlThread.Create(true,FFtpPort,self,ControlLog)
  else
    ControlThread.Stop;
  end;
end;

procedure TFtpSrvr.ControlLog;
var
 EventInfo : TEventInfo;
begin
if not assigned(AThreade) then exit;
FillEventInfo(AThreade,EventInfo,AThreade.Messg,AThreade.Error);
EventInfo.Result:=true;
if assigned(FOnLog) then FOnLog(AThreade,EventInfo);
if AThreade.Error <> 0 then if assigned(OnError) then OnError(AThreade,AThreade.Error);
case AThreade.Messg of
  CS_COMMAND: if assigned(OnCommand) then OnCommand(AThreade,EventInfo);
  CS_LOGIN: if assigned(OnLogin) then OnLogin(AThreade,EventInfo);
  CS_LOGOUT: if assigned(OnLogout) then OnLogout(AThreade,EventInfo);
  CS_CHDIR: if assigned(OnChdir) then OnChdir(AThreade,EventInfo);
  CS_DLOAD: if assigned(OnDownload) then OnDownload(AThreade,EventInfo);
  CS_ULOAD: if assigned(OnUpload) then OnUpload(AThreade,EventInfo);
  end;
AResult:=EventInfo.Result;
end;

procedure TFtpSrvr.Open;
var
 EventInfo : TEventInfo;
begin
FillEventInfo(nil,EventInfo,SS_START,Self.Error);
if assigned(OnLog) then FOnLog(nil,EventInfo);
Enabled:=true;
end;

procedure TFtpSrvr.Close;
var
 EventInfo : TEventInfo;
begin
FillEventInfo(nil,EventInfo,SS_STOP,Self.Error);
if assigned(OnLog) then FOnLog(nil,EventInfo);
Enabled:=false;
end;

constructor TFtpSrvr.create(AOwner : TComponent);
begin
inherited create(AOwner);
Randomize;
DirList:=TDirList.create;
UserList:=TUserList.create;
GrpList:=TGrpList.create;
FDirRestrict:=false;
FListFormat:=lf_UNIX;
FCustomList:='%r %u:8 %g:8 %d:8 %f';
FMaxConn:=100;
FFtpPort:=21;
FDataPort:=20;
FShowHidden:=false;
FShowReadOnly:=false;
FMode:=md_IMAGE;
FAllowRedirect:=false;
FAllowAnonymous:=false;
FBannerMsg:=TStringList.create;
FBannerMsg.Add('TFtpSrvr component for Delphi 4');
FBannerMsg.Add('(C) Drt. 1999');
FBannerMsg.Add('Please, send your comments to [e-mail]');
FPasswordMsg:='Please, enter the password for user %u';
FFreePasswdMsg:='Guest login ok. Enter e-mail as a password.';
FNoAnonymousMsg:='User %u is unknown. No anonymous login allowed.';
FEnabled:=false;
if not (csDesigning in componentstate) then
  begin
  Error:=WSAStartup($101,WD);
  end;
end;

destructor TFtpSrvr.destroy;
begin
WSACleanup;
inherited destroy;
end;

end.