main.~pa

his an ecapsulation of the ICS - Internet Component Suite. ICS can be found at : http://users.swing

unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, ImgList, ToolWin, Menus, Buttons, FtpSrv,FtpSrvC,
  Spin,FileCtrl, ExtCtrls,Winsock;

type
  TfrmMain = class(TForm)
    StatusBar1: TStatusBar;
    ImageList1: TImageList;
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    ListView1: TListView;
    RichEdit1: TRichEdit;
    MainMenu1: TMainMenu;
    PopupMenu1: TPopupMenu;
    TabSheet3: TTabSheet;
    TabSheet4: TTabSheet;
    FtpServer1: TFtpServer;
    Label4: TLabel;
    txtBanner: TEdit;
    SpinEdit1: TSpinEdit;
    Label5: TLabel;
    ImageList2: TImageList;
    File1: TMenuItem;
    StartFTP1: TMenuItem;
    StopFTP1: TMenuItem;
    N1: TMenuItem;
    Exit1: TMenuItem;
    Users1: TMenuItem;
    Help1: TMenuItem;
    About1: TMenuItem;
    N2: TMenuItem;
    Help2: TMenuItem;
    BootUser2: TMenuItem;
    ImageList3: TImageList;
    ToolBar2: TToolBar;
    ListView2: TListView;
    ImageList4: TImageList;
    ToolButton10: TToolButton;
    ToolButton12: TToolButton;
    ToolButton13: TToolButton;
    ToolButton14: TToolButton;
    Panel1: TPanel;
    Label1: TLabel;
    txtUser: TEdit;
    Label2: TLabel;
    txtPassword: TEdit;
    Label3: TLabel;
    txtRoot: TEdit;
    BitBtn1: TBitBtn;
    chkDelete: TCheckBox;
    chkRename: TCheckBox;
    chkDownload: TCheckBox;
    chkUpload: TCheckBox;
    Panel2: TPanel;
    Timer1: TTimer;
    BitBtn2: TBitBtn;
    BitBtn3: TBitBtn;
    ToolButton8: TToolButton;
    ToolButton9: TToolButton;
    BitBtn4: TBitBtn;
    SpinEdit2: TSpinEdit;
    Label6: TLabel;
    ToolBar1: TToolBar;
    ToolButton1: TToolButton;
    ToolButton2: TToolButton;
    ToolButton5: TToolButton;
    ToolButton4: TToolButton;
    ToolBar3: TToolBar;
    ImageList5: TImageList;
    ToolButton6: TToolButton;
    ToolButton7: TToolButton;
    SaveDialog1: TSaveDialog;
    TheServer1: TMenuItem;
    ActivityLog1: TMenuItem;
    AllowedUsers1: TMenuItem;
    ExtraOptions1: TMenuItem;
    procedure ToolButton1Click(Sender: TObject);
    procedure FtpServer1ChangeDirectory(Sender: TObject;
      Client: TFtpCtrlSocket; Directory: TFtpString; var Allowed: Boolean);
    procedure FtpServer1Authenticate(Sender: TObject;
      Client: TFtpCtrlSocket; UserName, Password: TFtpString;
      var Authenticated: Boolean);
    procedure FtpServer1ValidateDele(Sender: TObject;
      Client: TFtpCtrlSocket; var FilePath: TFtpString;
      var Allowed: Boolean);
    procedure FtpServer1ValidateGet(Sender: TObject;
      Client: TFtpCtrlSocket; var FilePath: TFtpString;
      var Allowed: Boolean);
    procedure FtpServer1ValidatePut(Sender: TObject;
      Client: TFtpCtrlSocket; var FilePath: TFtpString;
      var Allowed: Boolean);
    procedure FtpServer1ClientConnect(Sender: TObject;
      Client: TFtpCtrlSocket; Error: Word);
    procedure FtpServer1ClientDisconnect(Sender: TObject;
      Client: TFtpCtrlSocket; Error: Word);
    procedure FtpServer1ClientCommand(Sender: TObject;
      Client: TFtpCtrlSocket; var Keyword, Params, Answer: TFtpString);
    procedure FtpServer1Stop(Sender: TObject);
    procedure FtpServer1Start(Sender: TObject);
    procedure ToolButton2Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure ToolButton7Click(Sender: TObject);
    function AddClient(sUser : String; sAction : String; sDir : String) : boolean;
    procedure ModifyClient(sUser : String;  sAction : String; sDir : String);
    procedure RemoveClient(sUser : String);
    function isClientThere(sUser : string): Boolean;
    function isClient(sUser : String; sPass : String;Client: TFtpCtrlSocket): string;
    procedure getClientpermissions(sUser : String);
    procedure FormCreate(Sender: TObject);
    procedure ToolButton4Click(Sender: TObject);
    procedure TabSheet3Exit(Sender: TObject);
    procedure TabSheet3Enter(Sender: TObject);
    function getClientRootDir(sUser : string): String;
    procedure Timer1Timer(Sender: TObject);
    procedure BitBtn2Click(Sender: TObject);
    procedure BitBtn3Click(Sender: TObject);
    procedure ToolButton10Click(Sender: TObject);
    procedure ToolButton13Click(Sender: TObject);
    procedure ToolButton14Click(Sender: TObject);
    procedure LoadUserList;
    procedure SaveUserList;
    procedure ListView2SelectItem(Sender: TObject; Item: TListItem;
      Selected: Boolean);
    procedure EditClient;
    procedure BitBtn1Click(Sender: TObject);
    procedure BitBtn4Click(Sender: TObject);
    procedure ListView2MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
      procedure bSaveUserList;
    procedure ToolButton9Click(Sender: TObject);
    procedure ToolButton6Click(Sender: TObject);
    procedure TheServer1Click(Sender: TObject);
    procedure ActivityLog1Click(Sender: TObject);
    procedure AllowedUsers1Click(Sender: TObject);
    procedure ExtraOptions1Click(Sender: TObject);
    function IsAllowedTo(sUser : String; IAction : Integer) : Boolean;
    procedure Help2Click(Sender: TObject);
    procedure About1Click(Sender: TObject);
    procedure Exit1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;
  bConnected: Boolean;
  UserFile: String;
  cliDir: String;
implementation

uses NewUser, Dir, About;

{$R *.DFM}
function GetLocalIP : string;
// 
// Return  computer磗 IP if you are connected in a network
// Declare  Winsock in the uses clause 
// 
type 
    TaPInAddr = array [0..10] of PInAddr; 
    PaPInAddr = ^TaPInAddr; 
var 
    phe : PHostEnt; 
    pptr : PaPInAddr; 
    Buffer : array [0..63] of char; 
    I : Integer; 
    GInitData : TWSADATA; 
begin 
    WSAStartup($101, GInitData); 
    Result := ''; 
    GetHostName(Buffer, SizeOf(Buffer)); 
    phe :=GetHostByName(buffer); 
    if phe = nil then 
    begin 
       Exit; 
    end; 
    pptr := PaPInAddr(Phe^.h_addr_list); 
    I := 0; 
    while pptr^[I] <> nil do 
    begin 
       result:=StrPas(inet_ntoa(pptr^[I]^)); 
       Inc(I); 
    end; 
    WSACleanup; 
end; 
function bMakeBoolean(sStr : String): Boolean;
begin
if lowercase(sstr) = 'no' then
begin
bMakeBoolean := false;
end
else
begin
bMakeBoolean := true;
end;

end;

function bMakeString(bBool : Boolean): String;
begin
if bbool = false then
begin
bMakeString := 'No'
end
else
begin
bMakeString := 'Yes';
end;

end;

procedure Logit(sTXT : String);
begin
try
frmMain.RichEdit1.Lines.Insert(0,DateTimeToStr(Now) + ' - ' + stxt);
except
frmMain.RichEdit1.Lines.Clear;
frmMain.RichEdit1.Lines.Insert(0,DateTimeToStr(Now) + ' - ' + stxt);
end;


end;

function AppPath: String ;
//get the path of this file
begin
AppPath := ExtractFilePath(application.ExeName);
end;
function FileDelete(sFile :String):Boolean ;
begin
if FileExists(sFile) = True then
FileDelete := DeleteFile(sfile)
else
FileDelete := False;
end;
function DirDel(sPath : String):Boolean ;
begin
if DirectoryExists(sPath) = True then
DirDel := RemoveDir(sPath)
else
dirdel := false;
end;
function FileORDirDel(sPath : String; sFile : String): Boolean;
begin
if StrLen(pChar(sfile)) >0 then
//it is a file
FileORDirDel := filedelete(spath + sfile)
else
//it is a dir
FileORDirDel := dirdel(spath);
end;
function FileORDirRNTO(sPath : String; sFile : String): Boolean;
Var
iPos : Integer;
begin
 ipos := pos('.',sFile);
 if ipos > 0 then
//it is a file - handled by ftp
FileORDirRNTO := True
 else
// it is a directory - manual rename  c:\test\ / 222
     if DirectoryExists(sPath) = True then
     begin
     FileORDirRNTO := MoveFile(pchar(spath),pchar(sfile));
     end
     else
     begin
     FileORDirRNTO := false;
     end;



end;
function CheckStartDir(sDir : String):Boolean ;
begin
   //make sure it is a dir
   if sdir = '' then
   CheckStartDir := false;

   //it is a dir, check it
   if sdir <> '' then
   begin
       CheckStartDir := DirectoryExists(sdir);
   end;
end;

procedure FTPStart;
begin
frmmain.FtpServer1.Start;
Logit('FTP Started');
end;

procedure FTPStop;
begin
if bConnected = true then
begin
if MessageDlg('Warning stoping the FTP server will disconnect any clients!' + chr(10) + 'Are you sure you want to stop the FTP server?',mtConfirmation, [mbYes, mbNo], 0) = mrYes then
  begin
frmmain.FtpServer1.DisconnectAll;
frmmain.FtpServer1.Stop;
Logit('FTP Stopped');
  end;
end;

end;

function GetLineEle(sTmp : String; Delimi1 : String; Delimi2 : String): String;
 Var
Ipos :Integer;
Epos : Integer;
begin
try
ipos := pos(Delimi1,stmp);
if ipos = 0  then
begin
 GetLineEle := '';
 exit;
end;
epos := pos(Delimi2,stmp);
if epos = 0  then
begin
 GetLineEle := '';
 exit;
end;
ipos := ipos + Length(Delimi1);

GetLineEle := copy(stmp,ipos ,epos - ipos);
except
GetLineEle := '';
end;
end;

function QualifyDir(sDir : String):String ;
  Var
Ipos :Integer;
TmpDir : String;
begin
  ipos := StrLen(pchar(sdir));
  tmpdir := copy(sdir,ipos,strlen(pchar(sdir)));
  if tmpdir <> '\' then
  QualifyDir := sdir + '\';
  if tmpdir = '\' then
  QualifyDir := sdir;
end;

procedure TfrmMain.ToolButton1Click(Sender: TObject);
begin
ftpstart;
end;

procedure TfrmMain.FtpServer1ChangeDirectory(Sender: TObject;
  Client: TFtpCtrlSocket; Directory: TFtpString; var Allowed: Boolean);
begin
{ It the right place to check if a user has access to a given directory }
    { The example below disable C:\ access to non root user.                }
    //if (UpperCase(Client.UserName) <> 'ROOT') and
    //   (UpperCase(Client.Directory) = 'C:\') then
    //   Allowed := FALSE;

    if length(Client.Directory) < length(client.HomeDir) then begin
    Allowed := FALSE;
    exit;
    end;
//logit(client.username + ' CD ' +
    Allowed := TRUE;
end;

procedure TfrmMain.FtpServer1Authenticate(Sender: TObject;
  Client: TFtpCtrlSocket; UserName, Password: TFtpString;
  var Authenticated: Boolean);
begin
//authorize client


if isClientThere(UserName) = false then
begin
clidir := isClient(username,password,client);

     if clidir <> '' then
     begin

         //add the client to the list
        Authenticated := true;
        client.HomeDir := clidir;
        //client.FileName :='';
     end;
end
else
begin

//do not let them in multiple client error
Authenticated := false;
//client.Close;
end;
statusbar1.Panels[1].text := 'Number of Users: ' + inttostr(listview1.Items.count);
//Authenticated := True;
//client.HomeDir := 'd:\test\';
//client.FileName :='';
end;

procedure TfrmMain.FtpServer1ValidateDele(Sender: TObject;
  Client: TFtpCtrlSocket; var FilePath: TFtpString; var Allowed: Boolean);
begin
{
if CheckBox5.Checked = FALSE then begin
allowed := FALSE;
end;
}
end;

procedure TfrmMain.FtpServer1ValidateGet(Sender: TObject;
  Client: TFtpCtrlSocket; var FilePath: TFtpString; var Allowed: Boolean);
begin
{
if CheckBox5.Checked = FALSE then begin
allowed := FALSE;
end;
}
end;

procedure TfrmMain.FtpServer1ValidatePut(Sender: TObject;
  Client: TFtpCtrlSocket; var FilePath: TFtpString; var Allowed: Boolean);
begin
{
if CheckBox5.Checked = FALSE then begin
allowed := FALSE;
end;
}
end;

procedure TfrmMain.FtpServer1ClientConnect(Sender: TObject;
  Client: TFtpCtrlSocket; Error: Word);
begin
//do the connection here
Logit(client.UserName + ' - ' + client.DataSocket.Addr + ' Connected');
end;

procedure TfrmMain.FtpServer1ClientDisconnect(Sender: TObject;
  Client: TFtpCtrlSocket; Error: Word);
begin
//do the disconnection here
RemoveClient(client.UserName);
statusbar1.Panels[1].text := 'Number of Users: ' + inttostr(listview1.Items.count);
Logit(client.UserName + ' - ' + client.DataSocket.Addr + ' Disconnected');
end;

procedure TfrmMain.FtpServer1ClientCommand(Sender: TObject;
  Client: TFtpCtrlSocket; var Keyword, Params, Answer: TFtpString);
var
 hGood : Boolean;
 SFD1 : String;
 SFD2 : String;
  begin
  hgood:=False;

{
We are looking for the following commands
PUT - upload
STOR - Upload
GET - download
RETR - download
DELE - delete
RNFR - rename from

}
ModifyClient(client.username,Keyword,client.directory);
Logit(client.UserName + ' - ' + client.DataSocket.Addr + ' ' + Keyword + ' ' + client.directory  + params);
//DELE = delete
//if rename then begin
if (Keyword = 'PUT') or (Keyword = 'STOR') then
begin
   if IsAllowedTo(client.username,2) = false then
   begin
    client.SendAnswer('501 - Not Allowed!');
     exit;
   end;
end;

if (Keyword = 'GET') or (Keyword = 'RETR') then
begin
if IsAllowedTo(client.username,3) = false then
   begin
    client.SendAnswer('501 - Not Allowed!');
     exit;
   end;
end;

//if rename then begin
//RNTO = rename  from
if KeyWord ='RNFR' then
begin
if IsAllowedTo(client.username,4) = false then
   begin
    client.SendAnswer('501 - Not Allowed!');
     exit;
   end;
sfd1 := client.directory  + params;

end;
//RNTO = rename to
if Keyword = 'RNTO' then
   begin
   if IsAllowedTo(client.username,4) = false then
   begin
    client.SendAnswer('501 - Not Allowed!');
     exit;
   end;
 sfd2 := client.directory  + params;
 hgood := FileORDirRNTO(sfd1,sfd2);
 sfd1 := '';
 sfd2 := '';
end;