ftpobj.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 FtpObj;

{--------------------------------------------------------------------}
{ FtpObj module. Support for the User, Group and Directory objects.  }
{ 11/15/1999 Drt.                                                    }
{--------------------------------------------------------------------}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  GetWrd;

type
 TDirAttrib = set of
   (da_ReadList,      { Anyone can read the directory  }
    da_GrReadList,    { Directory group members can read the directory }
    da_ReadFiles,     { Anyone can read the directory files }
    da_WriteFiles,    { Anyone can write the directory files }
    da_GrReadFiles,   { Directory group members can read the directory files }
    da_GrWriteFiles,  { Directory group members can write the directory files }
    da_Enter,         { Anyone can enter the directory }
    da_GrEnter);      { Directory group members can enter the directory }

type
  TDirItem = class (TObject)
  public
    Alias    : string[130];
    Attrib   : TDirAttrib;
    UID      : word;
    GID      : word;
    end;

  TDirList = class (TStringList)
  private
    function RdPath(Index : integer) : string;
    procedure WrPath(Index : integer; Value : string);
    function RdAlias(Index : integer) : string;
    procedure WrAlias(Index : integer; Value : string);
    function RdUID(Index : integer) : word;
    procedure WrUID(Index : integer; Value : word);
    function RdGID(Index : integer) : word;
    procedure WrGID(Index : integer; Value : word);
    function RdAttrib(Index : integer) : TDirAttrib;
    procedure WrAttrib(Index : integer; Value : TDirAttrib);
  public
    constructor create;
    function AddDir(Path,Alias : string; Attrib : TDirAttrib; UID,GID : word) : integer;
    function Load : boolean; virtual;
    function Save : boolean; virtual;
    {$H+}
    function IndexOf(const S : String) : integer; override;
    {$H-}
    property Path[Index : integer] : string read RdPath write WrPath;
    property Alias[Index : integer] : string read RdAlias write WrAlias;
    property UID[Index : integer] : word read RdUID write WrUID;
    property GID[Index : integer] : word read RdGID write WrGID;
    property Attrib[Index : integer] : TDirAttrib read RdAttrib write WrAttrib;
    end;

  TGroupList = array [1..20] of word;

  TUserItem = class (TObject)
  public
    UID      : word;
    GID      : TGroupList;
    Password : string[30];
    Root     : boolean;
    Home     : string[130];
    end;

  TUserList = class (TStringList)
  private
    function RdUID(Index : integer) : word;
    function RdGID(Index,GIndex : integer) : word;
    procedure WrGID(Index,GIndex : integer; Value : word);
    function RdName(Index : integer) : string;
    function RdPassword(Index : integer) : string;
    procedure WrPassword(Index : integer; Value : string);
    function RdRoot(Index : integer) : boolean;
    procedure WrRoot(Index : integer; Value : boolean);
    function RdHome(Index : integer) : string;
    procedure WrHome(Index : integer; Value : string);
    function RdNameUID(UID : word) : string;
    function RdGIDUID(UID : word;GIndex : integer) : word;
    procedure WrGIDUID(UID : word; GIndex : integer; Value : word);
    function RdPassUID(UID : word) : string;
    procedure WrPassUID(UID : word; Value : string);
    function RdRootUID(UID : word) : boolean;
    procedure WrRootUID(UID : word; Value : boolean);
    function RdHomeUID(UID : word) : string;
    procedure WrHomeUID(UID : word; Value : string);
    function GetUID : word;
    procedure AddEntry(Name : string; UID : word; GID : TGroupList;
      Password : string; Root : boolean; Home : string);
  public
    constructor create;
    function AddUser(Name : string; GID : TGroupList; Password : string;
      Root : boolean; Home : string) : integer;
    function Load : boolean; virtual;
    function Save : boolean; virtual;
    function AddGroup(AUID,AGID : word) : boolean;
    function GroupsCount(AUID : word) : integer;
    function UIDByName(AName : string) : word;
    function GIDByName(AName : string;GIndex : integer) : word;
    function PassByName(AName : string) : string;
    function RootByName(AName : string) : boolean;
    function HomeByName(AName : string) : string;
    function InGroupByName(AName : string; AGID : word) : boolean;
    procedure GroupsClear(AUID : word);
    property UID[Index : integer] : word read RdUID;
    property GID[Index : integer;GIndex : integer] : word read RdGID write WrGID;
    property Name[Index : integer] : string read RdName;
    property Password[Index : integer] : string read RdPassword write WrPassword;
    property Root[Index : integer] : boolean read RdRoot write WrRoot;
    property Home[Index : integer] : string read RdHome write WrHome;
    property GIDByUID[UID : word;GIndex : integer] : word read RdGIDUID write WrGIDUID;
    property NameByUID[UID : word] : string read RdNameUID;
    property PassByUID[UID : word] : string read RdPassUID write WrPassUID;
    property RootByUID[UID : word] : boolean read RdRootUID write WrRootUID;
    property HomeByUID[UID : word] : string read RdHomeUID write WrHomeUID;
    end;

  TGrpItem = class (TObject)
  public
    GID       : word;
    end;

  TGrpList = class (TStringList)
  private
    function RdName(Index : integer) : string;
    function RdGID(Index : integer) : word;
    function RdNameGID(GID : word) : string;
    function GetGID : word;
    procedure AddEntry(Name : string; GID : word);
  public
    constructor create;
    function AddGrp(Name : string) : integer;
    function Load : boolean; virtual;
    function Save : boolean; virtual;
    function GIDByName(Name : string) : word;
    property Name[Index : integer] : string read RdName;
    property GID[Index : integer] : word read RdGID;
    property NameByGID[GID : word] : string read RdNameGID;
    end;

procedure SetStringSize(var s : string; n : word);
procedure DeleteSubkeys(k : hKey);

implementation

procedure SetStringSize(var s : string; n : word);
var
 i : word;
begin
for i:=1 to n do
  if s[i] = #0 then
    begin
    s[0]:=char(i-1);
    exit;
    end;
s[0]:=#0;
end;

type
 pTree = ^tTree;
 tTree = record
   s : string[100];
   n : pTree;
   end;

procedure DeleteSubkeys(k : hKey);
var
 t,t1 : pTree;
 i : integer;
 s : string;
 h : hKey;
begin
t:=nil;
t1:=nil;
i:=0;
while RegEnumKey(k,i,@s[1],253) = ERROR_SUCCESS do
  begin
  SetStringSize(s,253);
  inc(byte(s[0]));
  if t = nil then
    begin
    new(t);
    t1:=t;
    end
  else
    begin
    new(t1^.n);
    t1:=t1^.n;
    end;
  t1^.n:=nil;
  t1^.s:=s;
  inc(i);
  end;
while t <> nil do
  begin
  RegOpenKey(k,@t^.s[1],h);
  DeleteSubkeys(h);
  RegCloseKey(h);
  RegDeleteKey(k,@t^.s[1]);
  t1:=t^.n;
  dispose(t);
  t:=t1;
  end;
end;

{ ---------- TDirList ---------- }

constructor TDirList.create;
begin
inherited create;
sorted:=true;
end;

function TDirList.AddDir(Path,Alias : string; Attrib : TDirAttrib; UID,GID : word) : integer;
var
 i : integer;
 o : TDirItem;
begin
Path:=NormalizePath(trim(Path));
if (Path <> '') and (Path[byte(Path[0])] <> '/') then Path:=Path+'/';
o:=TDirItem.create;
o.Alias:=Alias;
o.Attrib:=Attrib;
o.UID:=UID;
o.GID:=GID;
i:=IndexOf(Path);
if i = -1 then
  begin
  result:=AddObject(Path,o);
  exit;
  end;
Objects[i].destroy;
Objects[i]:=o;
result:=i;
end;

{$H+}
function TDirList.IndexOf(const S : String) : integer;
var
 i : integer;
 s1: shortstring;
begin
s1:=s;
i:=inherited indexof(s1);
if i < 0 then
  begin
  if s <> '' then
    begin
    if s1[byte(s1[0])] = '/' then
      dec(byte(s1[0]))
    else
      s1:=s+'/';
    result:=inherited indexof(s1);
    end
  else
    begin
    result:=inherited indexof('/');
    end;
  end
else
  result:=i;
end;
{$H-}

function TDirList.Load;
var
 h,h1 : hKey;
 i : word;
 w : dword;
 Al : string;
 At : TDirAttrib;
 ID1,ID2 : word;
 sk : string[100];
begin
Clear;
result:=false;
{ -- Opening Main Key Path -- }
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);
if RegOpenKey(h1,'Dirs',h) <> ERROR_SUCCESS then
  begin
  RegCloseKey(h1);
  exit;
  end;
RegCloseKey(h1);
i:=0;
while RegEnumKey(h,i,@sk[1],99) = ERROR_SUCCESS do
  begin
  if RegOpenKey(h,@sk[1],h1) = ERROR_SUCCESS then
    begin
    w:=253;
    if RegQueryValueEx(h1,'Alias',nil,nil,@al[1],@w) <> ERROR_SUCCESS then
      Al:=''
    else
      SetStringSize(Al,253);
    w:=sizeof(At);
    if RegQueryValueEx(h1,'Attrib',nil,nil,@at,@w) <> ERROR_SUCCESS then
      At:=[];
    w:=sizeof(ID1);
    if RegQueryValueEx(h1,'UID',nil,nil,@ID1,@w) <> ERROR_SUCCESS then
      ID1:=0;
    if RegQueryValueEx(h1,'GID',nil,nil,@ID2,@w) <> ERROR_SUCCESS then
      ID2:=0;
    SetStringSize(sk,100);
    AddDir(sk,Al,At,ID1,ID2);
    RegCloseKey(h1);
    end;
  inc(i);
  end;
RegCloseKey(h);
result:=true;
end;

function TDirList.Save;
var
 h,h1 : hKey;
 w : word;
 n : word;
 i : word;
 Pt,Al : string;
 At : TDirAttrib;
 ID1,ID2 : word;
begin
{ -- Opening Main Key Path -- }
RegOpenKey(HKEY_LOCAL_MACHINE,'SOFTWARE',h1);
RegCreateKey(h1,'Drt.',h);
RegCloseKey(h1);
RegCreateKey(h,'TFTP',h1);
RegCloseKey(h);
RegCreateKey(h1,'Dirs',h);
RegCloseKey(h1);
DeleteSubkeys(h);
n:=Count;
for i:=1 to n do
  begin
  Pt:=Path[i-1]+#0;
  Al:=Alias[i-1]+#0;
  At:=Attrib[i-1];
  ID1:=UID[i-1];
  ID2:=GID[i-1];
  RegCreateKey(h,@Pt[1],h1);
  w:=length(Al);
  RegSetValueEx(h1,'Alias',0,REG_SZ,@Al[1],w);
  w:=sizeof(At);
  RegSetValueEx(h1,'Attrib',0,REG_BINARY,@At,w);
  w:=sizeof(ID1);
  RegSetValueEx(h1,'UID',0,REG_BINARY,@ID1,w);
  w:=sizeof(ID2);
  RegSetValueEx(h1,'GID',0,REG_BINARY,@ID2,w);
  RegCloseKey(h1);
  end;
RegCloseKey(h);
result:=true;
end;

function TDirList.RdPath(Index : integer) : string;
begin
if (Index < 0) or (Index >= count) then
  begin
  result:='';
  exit;
  end;
result:=Strings[Index];
end;

procedure TDirList.WrPath(Index : integer; Value : string);
var
 s : string[130];
begin
if (Index < 0) or (Index >= count) then exit;
s:=NormalizePath(Value);
if (s = '') or (s[byte(s[0])] <> '/') then s:=s+'/';
Strings[Index]:=s;
end;

function TDirList.RdAlias(Index : integer) : string;
begin
if (Index < 0) or (Index >= count) then
  begin
  result:='';
  exit;
  end;
result:=TDirItem(objects[Index]).Alias;
end;

procedure TDirList.WrAlias(Index : integer; Value : string);
begin
if (Index < 0) or (Index >= count) then exit;
TDirItem(objects[Index]).Alias:=Value;
end;

function TDirList.RdUID(Index : integer) : word;
begin
if (Index < 0) or (Index >= count) then
  begin
  result:=$ffff;
  exit;
  end;
result:=TDirItem(objects[Index]).UID;
end;

procedure TDirList.WrUID(Index : integer; Value : word);
begin
if (Index < 0) or (Index >= count) then exit;
TDirItem(objects[Index]).UID:=Value;
end;

function TDirList.RdGID(Index : integer) : word;
begin
if (Index < 0) or (Index >= count) then
  begin
  result:=$ffff;
  exit;
  end;
result:=TDirItem(objects[Index]).GID;
end;

procedure TDirList.WrGID(Index : integer; Value : word);
begin
if (Index < 0) or (Index >= count) then exit;
TDirItem(objects[Index]).GID:=Value;
end;

function TDirList.RdAttrib(Index : integer) : TDirAttrib;
begin
if (Index < 0) or (Index >= count) then
  begin
  result:=[];
  exit;
  end;
result:=TDirItem(objects[Index]).Attrib;
end;

procedure TDirList.WrAttrib(Index : integer; Value : TDirAttrib);
begin
if (Index < 0) or (Index >= count) then exit;
TDirItem(objects[Index]).Attrib:=Value;
end;

{ ---------- TUserList ---------- }

function TUserList.GetUID : word;
var
 a : array [0..8191] of byte;
 i : word;
 j : word;
 w : word;
begin
if Count = 0 then
  begin
  result:=0;
  exit;
  end;
for i:=0 to 8191 do
  a[i]:=0;
for i:=0 to Count-1 do
  begin
  w:=UID[i];
  a[w shr 3]:=a[w shr 3] or ($80 shr (w and 7));
  end;
for i:=0 to 8191 do
  begin
  if a[i] <> $ff then
    begin
    j:=0;
    while (a[i] and $80) <> 0 do
      begin
      inc(j);
      a[i]:=a[i] shl 1;
      end;
    result:=((i shl 3) and $fff8) or j;
    exit;
    end
  end;
result:=$fff0;
end;

constructor TUserList.create;
begin
inherited create;
sorted:=true;
end;

function TUserList.AddUser;
var
 i : integer;
 o : TUserItem;
begin
Name:=trim(Name);
o:=TUserItem.create;
o.UID:=GetUID;
o.GID:=GID;
o.Password:=Password;
o.Root:=Root;
o.Home:=Home;
i:=IndexOf(Name);
if i = -1 then
  begin
  result:=AddObject(Name,o);
  exit;
  end;
o.UID:=TUserItem(Objects[i]).UID;
Objects[i].destroy;
Objects[i]:=o;
result:=i;
end;

procedure TUserList.AddEntry;
var
 o : TUserItem;
begin
Name:=trim(Name);
o:=TUserItem.create;
o.UID:=UID;
o.GID:=GID;
o.Password:=Password;
o.Root:=Root;
o.Home:=Home;
AddObject(Name,o);
end;

function TUserList.AddGroup(AUID,AGID : word) : boolean;
var
 i : integer;
begin
result:=false;
for i:=1 to 20 do
  if GID[AUID,i] = AGID then exit;
for i:=1 to 20 do
  if GID[AUID,i] = $FFF0 then
    begin
    GID[AUID,i]:=AGID;
    result:=true;
    end;
end;

function TUserList.Load;
var
 h,h1 : hKey;
 i : word;
 w : dword;
 s : string[20];
 n : word;
 j,k : word;
 Nm,Pw,Hm  : string;
 ID1 : word;
 Rt : boolean;
 l : TGroupList;
begin
Clear;
result:=false;
{ -- Opening Main Key Path -- }
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);
if RegOpenKey(h1,'Users',h) <> ERROR_SUCCESS then
  begin
  RegCloseKey(h1);
  exit;
  end;
RegCloseKey(h1);
i:=0;
while RegEnumKey(h,i,@Nm[1],253) = ERROR_SUCCESS do
  begin