////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2026 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// CRW-DAQ security guard service.                                            //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20050725 - Creation & test                                                 //
// 20050808 - Add ga_Lock level                                               //
// 20050809 - Add TrustList, Trusted                                          //
// 20050810 - Startup                                                         //
// 20050811 - Log                                                             //
// 20221208 - CheckAction,GetActionLevel,LevelToName,NameToLevel              //
// 20230618 - Modified for FPC (A.K.)                                         //
////////////////////////////////////////////////////////////////////////////////

unit _crw_guard; // CRW-DAQ security guard service

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

{$WARN 5023 off : Unit "$1" not used in $2}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 sysutils, classes, inifiles, forms, actnlist,
 _crw_alloc, _crw_fpu, _crw_rtc, _crw_ef, _crw_snd, _crw_str,
 _crw_fio, _crw_crypt, _crw_fifo, _crw_hl, _crw_spcfld;

const                                   // Guard assess levels:
 ga_Lock  = 0;                          // Locked, lowest access level
 ga_Guest = 1;                          // Guest, lower access level
 ga_User  = 2;                          // User, middle access level
 ga_Root  = 3;                          // Root, full   access level

const                                   // Guard flags:
 gf_Raise   = $01;                      // Raise exception on deny
 gf_Echo    = $02;                      // Echo message on deny
 gf_Open    = $04;                      // Open console window on deny
 gf_Warning = $08;                      // Show warning on deny
 gf_Sound   = $10;                      // Play sound on deny
 gf_Log     = $20;                      // Write to log file
 gf_Default = gf_Echo+gf_Open+gf_Sound+gf_Log;

const
 GuardLogFileLimit : Integer = 1 shl 20;// Max. size of guard log file

 // Usage to check guard access:
 // case Guard.Check(ga_User,'Нет доступа!') of
 //  -1 : HaveNoRights;
 //   0 : HaveRights;
 //  +1 : HaveMoreRights;
 // end;
type                                    // Uses types:
 TGuard     = class;                    // Forward declaration
 TGuardFunc = function(                 // Function to check guard security level
               aGuard   : TGuard;       // Current security guard
               aLevel   : Cardinal;     // Wanted security level
               aMessage : LongString;   // Message if access deny
               aFlags   : Cardinal      // What to do if access deny
                      ) : Integer;      // -1,0,+1 if current level <,=,> then wanted
 EGuard     = class(ESoftException);    // Exceptions on guard deny
 TGuard     = class(TMasterObject)      // General guard class
 private
  myLevel     : Cardinal;               // Current access level
  mySound     : LongString;             // Sound on deny
  myDomain    : LongString;             // Application directory like CRW-DAQ
  myIniPath   : LongString;             // All Users\Application data path
  myIniName   : LongString;             // Short *.ini file name as Guard.ini
  myChecker   : TGuardFunc;             // Guard function
  myTrustList : TText;                  // List of trusted items
  myLogFifo   : TFifo;                  // Log fifo
  myActPerm   : THashList;              // [Guard.Permissions]
  procedure   InitActPerm;
  function    GetLevel:Cardinal;
  procedure   SetLevel(aLevel:Cardinal);
  function    GetSound:LongString;
  procedure   SetSound(aSound:LongString);
  function    GetDomain:LongString;
  procedure   SetDomain(aDomain:LongString);
  function    GetIniName:LongString;
  procedure   SetIniName(aIniName:LongString);
  function    GetIniPath:LongString;
  procedure   SetIniPath(aIniPath:LongString);
  function    GetIniFile:LongString;
  function    GetLogFile:LongString;
  procedure   SetLog(const aLog:LongString);
  procedure   SetChecker(aChecker:TGuardFunc);
  function    GetTrustList:LongString;
  procedure   SetTrustList(const aList:LongString);
 public
  constructor Create;
  destructor  Destroy; override;
 public
  function    Check(aLevel:Cardinal; aMessage:LongString='*'; aFlags:Cardinal=gf_Default):Integer;
  function    CheckAction(aLevel:Cardinal; const aAction:LongString; aMessage:LongString='*'; aFlags:Cardinal=gf_Default):Integer; overload;
  function    CheckAction(aLevel:Cardinal; aAction:TAction; aMessage:LongString='*'; aFlags:Cardinal=gf_Default):Integer; overload;
  function    ReadPassword(aLevel:Cardinal):LongString;
  function    WritePassword(aLevel:Cardinal; aPassword:LongString):Boolean;
  function    Trusted(const What:LongString):Boolean;
  function    ReadTrustList:Boolean;
  function    WriteTrustList:Boolean;
  procedure   Startup;
 public
  class function IsValidLevel(aLevel:Integer):Boolean;
 public
  function    LevelToName(aLevel:Cardinal):LongString;
  function    NameToLevel(aName:String; def:Integer):Integer;
  function    GetActionLevel(const aAction:LongString; def:Integer):Integer;
  function    GetActionName(aObject:TObject):LongString;
 public
  property    Level     : Cardinal   read GetLevel write SetLevel;
  property    Sound     : LongString read GetSound write SetSound;
  property    Domain    : LongString read GetDomain write SetDomain;
  property    IniName   : LongString read GetIniName write SetIniName;
  property    IniPath   : LongString read GetIniPath write SetIniPath;
  property    IniFile   : LongString read GetIniFile;
  property    LogFile   : LongString read GetLogFile;
  property    Checker   : TGuardFunc write SetChecker;
  property    LevelName[n:Cardinal] : LongString read LevelToName;
  property    TrustList : LongString read GetTrustList write SetTrustList;
  property    Log       : LongString write SetLog;
 end;

 // Default guard function
function DefaultGuardChecker(aGuard:TGuard; aLevel:Cardinal; aMessage:LongString; aFlags:Cardinal):Integer;

 // The single TGuard instance
function Guard:TGuard;

implementation

const
 gs_Section        = 'Guard';
 gs_Lock           = 'Lock';
 gs_Guest          = 'Guest';
 gs_User           = 'User';
 gs_Root           = 'Root';
 gs_TrustListItem  = 'TrustList.';
 gs_TrustListCount = 'TrustList.Count';

constructor TGuard.Create;
begin
 inherited;
 mySound:='deny';
 myDomain:='crwdaq';
 myIniPath:=GetSpecialShellFolderPath(CSIDL_APPDATA);
 if not DirExists(myIniPath) then myIniPath:=TempDir;
 myIniPath:=AddPathDelim(myIniPath)+Domain;
 myIniName:='guard.ini';
 myLevel:=ga_Lock;
 myChecker:=DefaultGuardChecker;
 myTrustList:=NewText(0,16);
 myTrustList.Master:=@myTrustList;
 myLogFifo:=NewFifo(1024);
 myLogFifo.Master:=@myLogFifo;
 myActPerm:=nil;
 //InitActPerm;
end;

destructor  TGuard.Destroy;
begin
 Log:='Leave '+LevelName[Level];
 mySound:='';
 myIniPath:='';
 myIniName:='';
 myLevel:=ga_Lock;
 myChecker:=DefaultGuardChecker;
 Kill(myTrustList);
 Kill(myLogFifo);
 Kill(myActPerm);
 inherited;
end;

procedure TGuard.InitActPerm;
var Lines:TText; i,ga:Integer; Line,w1,w2,w3:LongString;
begin
 if (Self=nil) then Exit;
 if (myActPerm<>nil) then Exit;
 try
  myActPerm:=NewHashList(false,HashList_DefaultHasher);
  myActPerm.Master:=@myActPerm;
  Lines:=ExtractListSection(SysIniFile,'[Guard.Permissions]',efConfigNC);
  try
   for i:=0 to Lines.Count-1 do begin
    Line:=Lines[i]; ga:=-1;
    w1:=ExtractWord(1,Line,ScanSpaces);
    w2:=ExtractWord(2,Line,ScanSpaces);
    w3:=ExtractWord(3,Line,ScanSpaces);
    if (w1='') or (w3='') then continue;
    if SameText(w2,'require') then ga:=NameToLevel(w3,-1);
    if IsValidLevel(ga) then myActPerm.KeyedLinks[w1]:=ga;
   end;
   DebugOut(stdfDebug,EOL+'[Guard.Permissions]');
   for i:=0 to myActPerm.Count-1 do begin
    w1:=myActPerm.Keys[i]; w3:=LevelToName(myActPerm.KeyedLinks[w1]);
    DebugOut(stdfDebug,Format('%-60s require %s',[w1,w3]));
   end;
   DebugOut(stdfDebug,'[]');
  finally
   Kill(Lines);
  end;
 except
  on E:Exception do BugReport(E,Self,'InitActPerm');
 end;
end;

function TGuard.GetLevel:Cardinal;
begin
 Result:=ga_Lock;
 if Assigned(Self) then Result:=myLevel;
end;

procedure TGuard.SetLevel(aLevel:Cardinal);
begin
 if (aLevel<=ga_Root) then
 if Assigned(Self) then begin
  if (myLevel<>aLevel) then Log:='Login '+LevelName[aLevel];
  myLevel:=aLevel;
 end;
end;

function TGuard.GetSound:LongString;
begin
 Result:='';
 if Assigned(Self) then Result:=mySound;
end;

procedure TGuard.SetSound(aSound:LongString);
begin
 if Assigned(Self) then
 if IsNonEmptyStr(aSound) then mySound:=Trim(aSound);
end;

function TGuard.GetDomain:LongString;
begin
 Result:='';
 if Assigned(Self) then Result:=myDomain;
end;

procedure TGuard.SetDomain(aDomain:LongString);
begin
 if Assigned(Self) then
 if IsNonEmptyStr(aDomain) then myDomain:=Trim(aDomain);
end;

function TGuard.GetIniName:LongString;
begin
 Result:='';
 if Assigned(Self) then Result:=myIniName;
end;

procedure TGuard.SetIniName(aIniName:LongString);
begin
 if Assigned(Self) then
 if IsNonEmptyStr(aIniName) then myIniName:=DefaultExtension(aIniName,'.ini');
end;

function TGuard.GetIniPath:LongString;
begin
 Result:='';
 if Assigned(Self) then Result:=myIniPath;
end;

procedure TGuard.SetIniPath(aIniPath:LongString);
begin
 if Assigned(Self) then
 if IsNonEmptyStr(aIniPath) then myIniPath:=Trim(aIniPath);
end;

function TGuard.GetIniFile:LongString;
begin
 Result:='';
 if Assigned(Self) then Result:=AddPathDelim(IniPath)+IniName;
end;

function TGuard.GetLogFile:LongString;
begin
 Result:='';
 if Assigned(Self) then Result:=ForceExtension(IniFile,'.log');
end;

procedure TGuard.SetLog(const aLog:LongString);
var t:Double; f:Text; io:Integer;
begin
 if Assigned(Self) then
 try
  t:=msecnow;
  myLogFifo.PutText(StdDateTimeStr(t)+' '+aLog+EOL);
  if IsMainThread then begin
   if not MkDir(IniPath)
   then RAISE EGuard.Create(Format('Guard: could not mkdir %s',[IniPath]));
   if (GuardLogFileLimit>0) then
   if (GetFileSize(LogFile)>GuardLogFileLimit) then FileRename(LogFile,LogFile+'.old');
   io:=IoResult;
   System.Assign(f,LogFile);
   try
    if FileExists(LogFile) then System.Append(f) else System.Rewrite(f);
    System.Write(f,myLogFifo.GetText);
   finally
    System.Close(f);
    SetInOutRes(io);
   end;
  end;
 except
  on E:Exception do BugReport(E,Self,'SetLog');
 end;
end;

procedure TGuard.SetChecker(aChecker:TGuardFunc);
begin
 if Assigned(Self) then myChecker:=aChecker;
end;

function TGuard.LevelToName(aLevel:Cardinal):LongString;
begin
 case aLevel of
  ga_Lock:  Result:=gs_Lock;
  ga_Guest: Result:=gs_Guest;
  ga_User:  Result:=gs_User;
  ga_Root:  Result:=gs_Root;
  else Result:='';
 end;
end;

function TGuard.NameToLevel(aName:String; def:Integer):Integer;
const rfOpt=[rfReplaceAll,rfIgnoreCase];
begin
 Result:=def; if (aName='') then Exit;
 aName:=StringReplace(aName,'ga_','',rfOpt);
 if SameText(aName,gs_Lock)   then Result:=ga_Lock  else
 if SameText(aName,gs_Guest)  then Result:=ga_Guest else
 if SameText(aName,gs_User)   then Result:=ga_User  else
 if SameText(aName,gs_Root)   then Result:=ga_Root  else
 if not Str2Int(aName,Result) then Result:=def;
end;

function TGuard.GetTrustList:LongString;
begin
 Result:='';
 if Assigned(Self) then Result:=myTrustList.Text;
end;

procedure TGuard.SetTrustList(const aList:LongString);
var i:Integer;
begin
 if Assigned(Self) then begin
  myTrustList.Text:=ValidateEol(aList);
  for i:=myTrustList.Count-1 downto 0 do begin
   if IsEmptyStr(myTrustList[i]) then myTrustList.DelLn(i) else
   if myTrustList[i]<>Trim(myTrustList[i]) then myTrustList[i]:=Trim(myTrustList[i]);
  end;
 end;
end;

function TGuard.Check(aLevel:Cardinal; aMessage:LongString='*'; aFlags:Cardinal=gf_Default):Integer;
begin
 Result:=-1;
 if Assigned(Self) then
 try
  if Assigned(myChecker) then Result:=myChecker(Self,aLevel,aMessage,aFlags);
 except
  on E:Exception do if HasFlags(aFlags,gf_Raise) then RAISE;
 end;
end;

function TGuard.CheckAction(aLevel:Cardinal; const aAction:LongString; aMessage:LongString='*'; aFlags:Cardinal=gf_Default):Integer;
begin
 Result:=-1;
 if Assigned(Self) then
 try
  if (aAction<>'') then aLevel:=GetActionLevel(aAction,aLevel);
  if (aMessage='*') and (aAction<>'') then aMessage:=aMessage+' '+Trim(aAction);
  if Assigned(myChecker) then Result:=myChecker(Self,aLevel,aMessage,aFlags);
 except
  on E:Exception do if HasFlags(aFlags,gf_Raise) then RAISE;
 end;
end;

function TGuard.CheckAction(aLevel:Cardinal; aAction:TAction; aMessage:LongString='*'; aFlags:Cardinal=gf_Default):Integer;
begin
 Result:=CheckAction(aLevel,GetActionName(aAction),aMessage,aFlags);
end;

function TGuard.GetActionLevel(const aAction:LongString; def:Integer):Integer;
var ga:Integer;
begin
 Result:=def;
 if Assigned(Self) then
 try
  if (aAction<>'') then begin
   InitActPerm; ga:=myActPerm.IndexOf(aAction);
   if (ga>=0) then ga:=myActPerm.KeyedLinks[aAction];
   if IsValidLevel(ga) then Result:=ga;
  end;
 except
  on E:Exception do BugReport(E,Self,'GetActionLevel');
 end;
end;

class function TGuard.IsValidLevel(aLevel:Integer):Boolean;
begin
 Result:=(aLevel>=ga_Lock) and (aLevel<=ga_Root);
end;

function TGuard.GetActionName(aObject:TObject):LongString;
var aAction:TAction; ClassRef:TClass; s:LongString;
 function Found(const arg:LongString):Boolean;
 begin
  Result:=(myActPerm.IndexOf(arg)>=0);
 end;
begin
 Result:='';
 try
  InitActPerm;
  if (aObject is TAction) then begin
   aAction:=(aObject as TAction);
   Result:=aAction.Name;
   if Found(Result) then Exit;
   if (aAction.Owner=nil) then Exit;
   Result:=aAction.Owner.ClassName+'.'+aAction.Name;
   if Found(Result) then Exit;
   ClassRef:=aAction.Owner.ClassType;
   while (ClassRef<>nil) do begin
    s:=ClassRef.ClassName+'.'+aAction.Name;
    if Found(s) then begin Result:=s; break; end;
    ClassRef:=ClassRef.ClassParent;
   end;
  end;
 except
  on E:Exception do BugReport(E,Self,'GetActionName');
 end;
end;

function TGuard.ReadPassword(aLevel:Cardinal):LongString;
var Ini:TIniFile;
begin
 Result:='';
 if Assigned(Self) then
 if (aLevel>ga_Lock) then
 if (aLevel<=ga_Root) then
 if FileExists(IniFile) then
 try
  Ini:=TIniFile.Create(IniFile);
  try
   Result:=Ini.ReadString(gs_Section,LevelName[aLevel],'');
   Result:=DecryptText(Result,FSign_PW,FSign_IV);
   Result:=Trim(Result);
  finally
   Ini.Free;
  end;
 except
  on E:Exception do begin
   BugReport(E,Self,'ReadPassword');
   Result:='';
  end;
 end;
end;

function TGuard.WritePassword(aLevel:Cardinal; aPassword:LongString):Boolean;
var Ini:TIniFile;
begin
 Result:=false;
 if Assigned(Self) then
 if (aLevel>ga_Lock) then
 if (aLevel<=ga_Root) then
 try
  if not MkDir(IniPath)
  then RAISE EGuard.Create(Format('Guard: could not mkdir %s',[IniPath]));
  Ini:=TIniFile.Create(IniFile);
  try
   aPassword:=Format('%-48s',[aPassword]);
   aPassword:=EncryptText(aPassword,FSign_PW,FSign_IV);
   Ini.WriteString(gs_Section,LevelName[aLevel],aPassword);
   Result:=true;
  finally
   Ini.Free;
  end;
 except
  on E:Exception do BugReport(E,Self,'WritePassword');
 end;
end;

function TGuard.Trusted(const What:LongString):Boolean;
var i:Integer;
begin
 Result:=true;
 if Assigned(Self) then
 if (myTrustList.Count>0) then begin
  Result:=false;
  if IsNonEmptyStr(What) then
  for i:=0 to myTrustList.Count-1 do
  if IsSameText(Trim(myTrustList[i]),Trim(What)) then begin
   Result:=true;
   Break;
  end;
 end;
end;

function TGuard.ReadTrustList:Boolean;
var Ini:TIniFile; i:Integer;
begin
 Result:=false;
 if Assigned(Self) then
 if FileExists(IniFile) then
 try
  Ini:=TIniFile.Create(IniFile);
  try
   myTrustList.Count:=0;
   for i:=0 to Ini.ReadInteger(gs_Section,gs_TrustListCount,0)-1 do
   myTrustList.Addln(Trim(Ini.ReadString(gs_Section,gs_TrustListItem+IntToStr(i),'')));
   TrustList:=TrustList;
  finally
   Ini.Free;
  end;
 except
  on E:Exception do BugReport(E,Self,'ReadTrustList');
 end;
end;

function TGuard.WriteTrustList:Boolean;
var Ini:TIniFile; i:Integer;
begin
 Result:=false;
 if Assigned(Self) then
 try
  if not MkDir(IniPath)
  then RAISE EGuard.Create(Format('Guard: could not mkdir %s',[IniPath]));
  Ini:=TIniFile.Create(IniFile);
  try
   TrustList:=TrustList;
   for i:=0 to Ini.ReadInteger(gs_Section,gs_TrustListCount,0)-1 do
   Ini.DeleteKey(gs_Section,gs_TrustListItem+IntToStr(i));
   Ini.DeleteKey(gs_Section,gs_TrustListCount);
   for i:=0 to myTrustList.Count-1 do
   Ini.WriteString(gs_Section,gs_TrustListItem+IntToStr(i),Trim(myTrustList[i]));
   Ini.WriteInteger(gs_Section,gs_TrustListCount,myTrustList.Count);
   Result:=true;
  finally
   Ini.Free;
  end;
 except
  on E:Exception do BugReport(E,Self,'WriteTrustList');
 end;
end;

procedure TGuard.Startup;
begin
 if Assigned(Self) then
 try
  InitActPerm;
  ReadTrustList;
  myLevel:=ga_Root;
  if (ReadPassword(ga_Root)<>'') then myLevel:=ga_User;
  if (ReadPassword(ga_User)<>'') then myLevel:=ga_Guest;
  if (ReadPassword(ga_Guest)<>'') then myLevel:=ga_Lock;
  Log:='Enter '+LevelName[Level];
 except
  on E:Exception do BugReport(E,Self,'Startup');
 end;
end;

function DefaultGuardChecker(aGuard:TGuard; aLevel:Cardinal; aMessage:LongString; aFlags:Cardinal):Integer;
 function Act:LongString;
 begin
  Result:='';
  if (WordCount(aMessage,ScanSpaces)=2)
  then Result:=' '+ExtractWord(2,aMessage,ScanSpaces);
 end;
begin
 if (aGuard.Level<aLevel) then Result:=-1 else
 if (aGuard.Level>aLevel) then Result:=+1 else Result:=0;
 if (Result<0) and (Length(aMessage)>0) then begin
  if (ExtractWord(1,aMessage,ScanSpaces)='*')
  then aMessage:=RusEng('Доступ закрыт. Нет прав для выполнения действия'+Act+'.',
                        'Access denied. Not enough rights to execute action'+Act+'.');
  with aGuard do
  if HasFlags(aFlags,gf_Log) then aGuard.Log:='Deny '+LevelName[Level]+', need '+LevelName[aLevel]+' for action'+Act;
  if HasFlags(aFlags,gf_Sound) then Voice(aGuard.Sound);
  if HasFlags(aFlags,gf_Raise) then RAISE EGuard.Create('Guard: '+Trim(aMessage));
  if HasFlags(aFlags,gf_Echo+gf_Open+gf_Warning) then Echo('Guard: '+Trim(aMessage));
 end;
end;

const
 TheGuard : TGuard = nil;

function Guard:TGuard;
begin
 if not Assigned(TheGuard) then begin
  TheGuard:=TGuard.Create;
  TheGuard.Master:=@TheGuard;
 end;
 Result:=TheGuard;
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_guard;
begin
 Guard.Ok;
end;

procedure Free_crw_guard;
begin
 TheGuard.Free;
end;

initialization

 Init_crw_guard;

finalization

 Free_crw_guard;

end.

//////////////
// END OF FILE
//////////////

