unit1.pas

Source code Delphi FTP-server

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, FtpSrvr, TrdBase, ExtCtrls, SrvCtrl, ShellApi;

const
 WM_FULL       = WM_USER + 5200;

type
  TForm1 = class(TForm)
    FtpSrvr1: TFtpSrvr;
    ComboBox1: TComboBox;
    Label1: TLabel;
    ComboBox2: TComboBox;
    Label2: TLabel;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button6: TButton;
    GroupBox1: TGroupBox;
    ComboBox3: TComboBox;
    Button7: TButton;
    Button8: TButton;
    Button9: TButton;
    Button10: TButton;
    Button11: TButton;
    GroupBox2: TGroupBox;
    Panel1: TPanel;
    RadioButton1: TRadioButton;
    RadioButton2: TRadioButton;
    RadioButton3: TRadioButton;
    Edit1: TEdit;
    Label3: TLabel;
    Panel2: TPanel;
    CheckBox1: TCheckBox;
    CheckBox2: TCheckBox;
    CheckBox3: TCheckBox;
    CheckBox4: TCheckBox;
    lb: TListBox;
    Label4: TLabel;
    procedure Button11Click(Sender: TObject);
    procedure Button10Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button7Click(Sender: TObject);
    procedure Button8Click(Sender: TObject);
    procedure RadioButton1Click(Sender: TObject);
    procedure RadioButton2Click(Sender: TObject);
    procedure RadioButton3Click(Sender: TObject);
    procedure Edit1Change(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
    procedure CheckBox2Click(Sender: TObject);
    procedure CheckBox3Click(Sender: TObject);
    procedure CheckBox4Click(Sender: TObject);
    procedure FtpSrvr1Log(Sender: TFtpThreades; var Event : TEventInfo);
    procedure WriteLog(PID : LongWord; Msg : string);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    nif   : tNotifyIconData;
    exit1 : boolean;
    OldWndProc : TWndMethod;
    Show : boolean;
    procedure Full(var msg : tmessage); message WM_FULL;
    procedure ToFull;
    procedure MyDispatch(var msg : tMessage);
    procedure Small;
    procedure reload;
    procedure Load;
    procedure Save;
    constructor Create(AOwner : TComponent); override;
  end;

var
  Form1: TForm1;

implementation

uses Unit2, Unit3, Unit4;

{$R *.DFM}

procedure TForm1.Full;
begin
if msg.lparam = WM_LBUTTONDOWN then
  begin
  ToFull;
  Application.BringToFront;
  end;
end;

procedure TForm1.ToFull;
begin
nif.cbSize:=sizeof(nif);
nif.Wnd:=Handle;
nif.uID:=1;
nif.uFlags:=NIF_ICON + NIF_MESSAGE + NIF_TIP;
nif.uCallbackMessage:=WM_FULL;
nif.hIcon:=Application.Icon.Handle;
strpcopy(pchar(@nif.szTip),'IP Callback. Click to configure.');
shell_notifyicon(NIM_DELETE,@nif);
ShowWindow(Application.Handle,SW_SHOW);
ShowWindow(Handle,SW_SHOW);
SetFocus;
Show:=true;
end;

procedure TForm1.Small;
begin
if exit1 then exit;
nif.cbSize:=sizeof(nif);
nif.Wnd:=Handle;
nif.uID:=1;
nif.uFlags:=NIF_ICON + NIF_MESSAGE + NIF_TIP;
nif.uCallbackMessage:=WM_FULL;
nif.hIcon:=application.Icon.Handle;
strpcopy(pchar(@nif.szTip),'IP Callback. Click to configure.');
shell_notifyicon(NIM_ADD,@nif);
ShowWindow(Application.Handle,SW_HIDE);
ShowWindow(Handle,SW_HIDE);
Show:=false;
end;

constructor TForm1.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
Load;
Reload;
case FtpSrvr1.ListFormat of
  lf_UNIX: RadioButton1.Checked:=true;
  lf_DOS: RadioButton2.Checked:=true;
  lf_CUSTOM: RadioButton3.Checked:=true;
  end;
CheckBox1.Checked:=FtpSrvr1.AllowAnonymous;
CheckBox2.Checked:=FtpSrvr1.AllowRedirect;
CheckBox3.Checked:=FtpSrvr1.ShowHidden;
CheckBox4.Checked:=FtpSrvr1.ShowReadOnly;
OldWndProc:=WndProc;
WindowProc:=MyDispatch;
Show:=true;
end;

procedure TForm1.Load;
begin
FtpSrvr1.Load;
end;

procedure TForm1.Save;
begin
FtpSrvr1.Save;
end;

procedure TForm1.reload;
var
 i : integer;
begin
ComboBox1.Clear;
ComboBox2.Clear;
ComboBox3.Clear;
for i:=0 to FtpSrvr1.UserList.Count-1 do
  begin
  ComboBox1.Items.Add(FtpSrvr1.UserList.Name[i]);
  end;
for i:=0 to FtpSrvr1.GrpList.Count-1 do
  begin
  ComboBox2.Items.Add(FtpSrvr1.GrpList.Name[i]);
  end;
for i:=0 to FtpSrvr1.DirList.Count-1 do
  begin
  ComboBox3.Items.Add(FtpSrvr1.DirList.Path[i]);
  end;
end;

procedure TForm1.Button11Click(Sender: TObject);
begin
Save;
FtpSrvr1.Enabled:=false;
close;
end;

procedure TForm1.Button10Click(Sender: TObject);
begin
if FtpSrvr1.Enabled then
  begin
  FtpSrvr1.Enabled:=false;
  Button10.Caption:='Start';
  end
else
  begin
  FtpSrvr1.Enabled:=true;
  Button10.Caption:='Stop';
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Form2.Name:='';
Form2.ShowModal;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
Form2.Name:=ComboBox1.Items[ComboBox1.ItemIndex];
Form2.ShowModal;
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
reload;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
FtpSrvr1.UserList.Delete(FtpSrvr1.UserList.IndexOf(ComboBox1.Items[ComboBox1.ItemIndex]));
Reload;
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
Form3.Name:='';
Form3.ShowModal;
end;

procedure TForm1.Button7Click(Sender: TObject);
begin
Form4.Path:='';
Form4.ShowModal;
end;

procedure TForm1.Button8Click(Sender: TObject);
begin
Form4.Path:=ComboBox3.Items[ComboBox3.ItemIndex];
Form4.ShowModal;
end;

procedure TForm1.RadioButton1Click(Sender: TObject);
begin
FtpSrvr1.ListFormat:=lf_UNIX;
edit1.enabled:=false;
end;

procedure TForm1.RadioButton2Click(Sender: TObject);
begin
FtpSrvr1.ListFormat:=lf_DOS;
edit1.enabled:=false;
end;

procedure TForm1.RadioButton3Click(Sender: TObject);
begin
FtpSrvr1.ListFormat:=lf_CUSTOM;
edit1.enabled:=true;
end;

procedure TForm1.Edit1Change(Sender: TObject);
begin
FtpSrvr1.CustomList:=edit1.text;
end;

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
FtpSrvr1.AllowAnonymous:=CheckBox1.Checked;
end;

procedure TForm1.CheckBox2Click(Sender: TObject);
begin
FtpSrvr1.AllowRedirect:=CheckBox2.Checked;
end;

procedure TForm1.CheckBox3Click(Sender: TObject);
begin
FtpSrvr1.ShowHidden:=CheckBox3.Checked;
end;

procedure TForm1.CheckBox4Click(Sender: TObject);
begin
FtpSrvr1.ShowReadonly:=CheckBox4.Checked;
end;

function space(n : integer) : string;
var
 s : string;
begin
s:='';
while n > 0 do
  begin
  s:=s+' ';
  dec(n);
  end;
result:=s;
end;

procedure TForm1.FtpSrvr1Log(Sender: TFtpThreades; var Event : TEventInfo);
var
 PID : word;
 i : word;
 s : string[20];
 ip: string[20];
begin
PID:=Sender.PID;
ip:=format('%u.%u.%u.%u',[Event.IP[1],Event.IP[2],Event.IP[3],Event.IP[4]]);
WriteLog(PID,ip+', E: '+format('%u',[Event.Event])+', U: '+Event.User+', G: '+Event.Group+', P: '+Event.Pwd+', H: '+Event.Home+', D: '+Event.CDir+', C: '+Event.Cmd+', CP: '+Event.Par+', F: '+Event.FName);
lb.clear;
for i:=1 to MaxConn do
  begin
  if ProcessList[i] <> nil then
    begin
    if length(ProcessList[i].usr) < 15 then s:=space(15-length(ProcessList[i].usr));
    lb.Items.Add(format('%s%s %15s %s',[ProcessList[i].usr,s,ip,ProcessList[i].cdir]));
    end;
  end;
end;

procedure TForm1.WriteLog(PID : LongWord; Msg : string);
var
 t : textfile;
begin
assignfile(t,'c:\ftp.log');
append(t);
if ioresult <> 0 then rewrite(t);
if ioresult <> 0 then exit;
writeln(t,format('[%5.5u]',[PID])+': '+Msg);
closefile(t);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
 nif : tNotifyIconData;
begin
Save;
FtpSrvr1.Enabled:=false;
if not show then
  begin
  nif.cbSize:=sizeof(nif);
  nif.Wnd:=Handle;
  nif.uID:=1;
  nif.uFlags:=NIF_ICON + NIF_MESSAGE;
  nif.uCallbackMessage:=WM_User+200;
  nif.hIcon:=Icon.Handle;
  nif.szTip[0]:=#0;
  shell_notifyicon(NIM_DELETE,@nif);
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
WindowProc:=OldWndProc;
end;

procedure TForm1.MyDispatch(var msg : tMessage);
begin
if msg.msg = WM_SYSCOMMAND then
  begin
  if (msg.wparam = SC_MINIMIZE) or (msg.wparam = SC_ICON) then
    begin
    small;
    exit;
    end;
  end;
OldWndProc(msg);
end;

end.