udb.pas

著名的SecureBlackBox控件完整源码

unit uDB;

{$INCLUDE defines.inc}
{$include rtcDefs.inc}

interface

uses rtcTrashcan, Classes, IniFiles;

const
  DEFAULT_ADMIN_USER:string='admin';
  DEFAULT_ADMIN_PWD:string='admin';
  USER_DATA_FILENAME:string='users.data';

type
  TCallBackProc = procedure (Login : string);

procedure InitUserData(folder:string);

// Users support
function GetUserInfo(login : string; var name, pwd : string) : boolean; overload;
function GetUserInfo(login : string; var name : string) : boolean; overload;
function GetUserName(login : string) : string;
function SaveUserInfo(login, name, pwd : string) : boolean;
function CheckUser(login, pwd : string) : boolean;
procedure GetUsers(Users : TStrings);
function DeleteUser(login : string) : boolean;
function ChangePassword(login, old_pwd, pwd : string) : boolean;
function IsUserExists(login : string) : boolean;
function SetLastLogon(login: string; Timestamp: TDateTime) : boolean;
function GetLastLogon(login: string; var Timestamp: TDateTime) : boolean;

// Packages support
function AddPack(name, order_link, extend_lic_link : string; var id : string) : boolean;
function GetPackInfo(id: string; var name, order_link, extend_lic_link : string) : boolean;
function SavePackInfo(id, name, order_link, extend_lic_link : string) : boolean;
procedure GetPacks(Packs : TStrings);
function DeletePack(id : string) : boolean;
function IsPackExists(packname : string) : boolean;
function SetPackVisibility(pack_id, vis_level : string) : boolean;
function GetPackVisibility(pack_id : string) : string;

// Files support
function AddFile(pack_id, fname, description, size, datetime : string; var id : string) : boolean;
function GetFileInfo(pack_id, file_id : string; var fname, description, filedatetime, size : string) : boolean;
procedure GetFiles(pack_id : string; Files : TStrings);
procedure GetFilesTiny(pack_id : string; Files : TStrings);
procedure GetFilesAll(Files : TStrings);
function SaveFileDesc(file_id, description : string) : boolean;
function BindFile(pack_id, file_id : string) : boolean;
function DelFile(pack_id, file_id : string) : boolean;
function IsFileInPackExists(pack_id, fname : string) : boolean;
function IsFileExists(fname : string; var packname : string) : boolean;

// Access support
function GetGrant(login, pack_id : string; var expiredate : string) : boolean;
function SaveUserAccess(login, pack_id : string; grant: boolean; expiredate : string) : boolean;
function IsFileAvailableForUser(login, filename : string) : boolean;

//Common functions
function GetNextID(entity : string) : string;   //entity: names, packages, files

const
  DEFAULT_PACK_VISIBILITY_LEVEL = 'private';

function _GetValueFromIndex(SL:TStringList; Index: Integer): string;

implementation

uses SysUtils, rtcInfo, rtcSyncObjs, Windows;

var
  DB : TMemIniFile = nil;
  RW : TRtcRWSec = nil;

const
  //
  // Misc
  //
  T_IDS             = 'last used id';
  //
  // Users
  //
  T_USERS           = 'users';
  T_USERS_NAMES     = 'users::names';
  T_USERS_PASSWORDS = 'users::passwords';
  T_USERS_GRANTS    = 'users::grants::%s';
  T_USERS_LAST_LOGON= 'users::last logon';
  //
  // Packages
  //
  T_PACKS           = 'packages';
  T_PACKS_FILES     = 'files::package::%s';
  T_PACKS_LINKS     = 'links::package::%s';
  T_PACKS_VISIBILITY= 'packages::visibility';
  ORDER             = 'Order';
  EXTEND_LIC        = 'Extend license';
  //
  // Files
  //
  T_FILES           = 'files';

procedure InitUserData(folder:string);
  var
    S : string;
  begin
  if Assigned(DB) then
    begin
    DB.Free;
    DB:=nil;
    end;
  S := folder + USER_DATA_FILENAME;
  CopyFile(PChar(S), PChar(S + '.bak'), False);
  DB := TMemIniFile.Create(S);
  end;

function GetNextID(entity : string) : string;   //entity: users, packages, files
var
  id : integer;
begin
  id := DB.ReadInteger(T_IDS, entity, 0) + 1;
  DB.WriteInteger(T_IDS, entity, id);
  Result := IntToStr(id);
end;

function GetUserInfo(login : string; var name, pwd : string) : boolean;
begin
  RW.EnterRead;
  try
    Result := DB.ValueExists(T_USERS, login);
    if Result then
      begin
        name := DB.ReadString(T_USERS_NAMES, login, '');
        pwd := DB.ReadString(T_USERS_PASSWORDS, login, '');
      end
    else
      begin
        name := '';
        pwd := '';
      end;
  finally
    RW.LeaveRead
  end;
end;

function GetUserInfo(login : string; var name : string) : boolean; overload;
var
  pwd : string;
begin
  Result := GetUserInfo(login, name, pwd);
end;

function GetUserName(login : string) : string;
begin
  if not GetUserInfo(login, Result) then
    Result := login;
end;

function SaveUserInfo(login, name, pwd : string) : boolean;
begin
  RW.EnterWrite;
  try
    if login <> '' then
      begin
        DB.WriteString(T_USERS, login, '');
        DB.WriteString(T_USERS_NAMES, login, URL_Decode(name));
        if pwd <> '' then
          DB.WriteString(T_USERS_PASSWORDS, login, pwd);
        DB.UpdateFile;
        Result := True;
      end
    else
      Result := False;
  finally
    RW.LeaveWrite;
  end;
end;

function CheckUser(login, pwd : string) : boolean;
var
  S : string;
begin
  RW.EnterRead;
  try
    if DB.ValueExists(T_USERS, login) then
      begin
        S := DB.ReadString(T_USERS_PASSWORDS, login, '');
        Result := S = pwd
      end
    else if (login=DEFAULT_ADMIN_USER) and (pwd=DEFAULT_ADMIN_PWD) then
      Result:=True
    else
      Result := False;
  finally
    RW.LeaveRead
  end;
end;

procedure GetUsers(Users : TStrings);
var
  I : integer;
begin
  RW.EnterRead;
  try
    DB.ReadSection(T_USERS, Users);
    for I := 0 to Users.Count - 1 do
      Users[I] := Format('%s=%s', [Users[I], DB.ReadString(T_USERS_NAMES, Users[I], '')]);
  finally
    RW.LeaveRead
  end;
end;

function DeleteUser(login : string) : boolean;
begin
  RW.EnterWrite;
  try
    if DB.ValueExists(T_USERS, login) then
      begin
        DB.DeleteKey(T_USERS, login);
        DB.DeleteKey(T_USERS_NAMES, login);
        DB.DeleteKey(T_USERS_PASSWORDS, login);
        DB.UpdateFile;
        Result := True;
      end
    else
      Result := False;
  finally
    RW.LeaveWrite
  end;
end;

function ChangePassword(login, old_pwd, pwd : string) : boolean;
begin
  RW.EnterWrite;
  try
    if (login <> '') and (old_pwd <> '') and (pwd <> '') and
       (old_pwd = DB.ReadString(T_USERS_PASSWORDS, login, '')) then
      begin
        DB.WriteString(T_USERS_PASSWORDS, login, pwd);
        DB.UpdateFile;
        Result := True;
      end
    else if (login=DEFAULT_ADMIN_USER) and (old_pwd=DEFAULT_ADMIN_PWD) and (pwd<>'') and
       not DB.ValueExists(T_USERS, login) then
      begin
        DB.WriteString(T_USERS_PASSWORDS, login, pwd);
        DB.UpdateFile;
        Result := True;
      end
    else
      Result := False;
  finally
    RW.LeaveWrite
  end;
end;

function IsUserExists(login : string) : boolean;
begin
  RW.EnterRead;
  try
    Result := DB.ValueExists(T_USERS, login);
  finally
    RW.LeaveRead;
  end;
end;

function SetLastLogon(login: string; Timestamp: TDateTime) : boolean;
begin
  RW.EnterWrite;
  try
    Result := DB.ValueExists(T_USERS, login);
    if Result then
      DB.WriteDateTime(T_USERS_LAST_LOGON, login, Timestamp);
  finally
    RW.LeaveWrite;
  end;
end;

function GetLastLogon(login: string; var Timestamp: TDateTime) : boolean;
begin
  RW.EnterRead;
  try
    Result := DB.ValueExists(T_USERS, login);
    if Result then
      Timestamp := DB.ReadDateTime(T_USERS_LAST_LOGON, login, 0.0)
    else
      Timestamp := 0.0;
  finally
    RW.LeaveRead
  end;
end;

function AddPack(name, order_link, extend_lic_link : string; var id : string) : boolean;
begin
  RW.EnterWrite;
  try
    id := GetNextID(T_PACKS);
    DB.WriteString(T_PACKS, id, name);
    DB.WriteString(Format(T_PACKS_LINKS, [id]), ORDER, order_link);
    DB.WriteString(Format(T_PACKS_LINKS, [id]), EXTEND_LIC, extend_lic_link);
    DB.UpdateFile;
  finally
    RW.LeaveWrite
  end;
  Result := True;
end;

function GetPackInfo(id: string; var name, order_link, extend_lic_link : string) : boolean;
begin
  RW.EnterRead;
  try
    Result := DB.ValueExists(T_PACKS, id);
    if Result then
      begin
        name := DB.ReadString(T_PACKS, id, '');
        order_link := DB.ReadString(Format(T_PACKS_LINKS, [id]), ORDER, '');
        extend_lic_link := DB.ReadString(Format(T_PACKS_LINKS, [id]), EXTEND_LIC, '');
      end
    else
      begin
        name := '';
        order_link := '';
        extend_lic_link := '';
      end;
  finally
    RW.LeaveRead
  end;
end;

function SavePackInfo(id, name, order_link, extend_lic_link : string) : boolean;
begin
  RW.EnterWrite;
  try
    DB.WriteString(T_PACKS, id, name);
    DB.WriteString(Format(T_PACKS_LINKS, [id]), ORDER, order_link);
    DB.WriteString(Format(T_PACKS_LINKS, [id]), EXTEND_LIC, extend_lic_link);
    DB.UpdateFile;
  finally
    RW.LeaveWrite
  end;
  Result := True;
end;

procedure GetPacks(Packs : TStrings);
begin
  RW.EnterRead;
  try
    DB.ReadSectionValues(T_PACKS, Packs);
  finally
    RW.LeaveRead;
  end;
end;

function DeletePack(id : string) : boolean;
var
  Files : TStringList;
begin
  Result := False;

  RW.EnterWrite;
  try
    if DB.ValueExists(T_PACKS, id) then
      begin
        if DB.SectionExists(Format(T_PACKS_FILES, [id])) then begin
          Files := TStringList.Create;
          try
            DB.ReadSectionValues(Format(T_PACKS_FILES, [id]), Files);
            if Files.Count > 0 then
              Exit;
          finally
            Files.Free;
          end;
        end;
        DB.DeleteKey(T_PACKS, id);
        DB.DeleteKey(T_PACKS_VISIBILITY, id);
        DB.UpdateFile;
        Result := True;
      end;
  finally
    RW.LeaveWrite
  end;
end;

function _GetValueFromIndex(SL:TStringList; Index: Integer): string;
  begin
  if Index >= 0 then
    Result := Copy(SL.Strings[Index], Length(SL.Names[Index]) + 2, MaxInt) else
    Result := '';
  end;

function IsPackExists(packname : string) : boolean;
var
  SL : TStringList;
  I : integer;
begin
  Result := False;
  RW.EnterRead;
  try
    SL := TStringList.Create;
    try