ucmddisp.pas

著名的SecureBlackBox控件完整源码

unit uCmdDisp;

{$INCLUDE defines.inc}

interface

uses
  rtcTrashcan,
  SysUtils, Classes, rtcInfo,
  rtcConn, rtcCrypt, rtcDataSrv,
  rtcParse, rtcParseEx,

  uTrans, uTypes, uMessages,
  uDB, uForumDB;

const
  LOGIN_ADMIN = 'admin';
  LOGIN_GUEST = '';

const
  ACCESS_LEVEL_DENIED = -1;
  ACCESS_LEVEL_USER   = 0;
  ACCESS_LEVEL_ADMIN  = 1;

const
  SELECTED = 'selected';
  CHECKED = 'checked';

type
  TCommandsDispatcher = class
  private
    fPageMessage : string;
    fSrv : TRtcDataServer;

    procedure ShowPageMessage(Page : TRtcParse); overload;
    procedure ShowPageMessage(Page : TRtcParseEx); overload;
    procedure SetPageMessage(const Value: string);
    function GetPageMessage: string;

    function GetRequestValue (name : string) : string;

    function FindSession : boolean;
    function GetSession: TRtcServerSession;
    function GetSessionID: string;

    function GetTemplatePath: string;
    function GetUploadPath: string;

  private
    property PageMessage : string read GetPageMessage write SetPageMessage;

  protected
    procedure Relocation (URL : string);
    function RelocationOnError(MsgID : string):string;
    //
    function DoCommonAccess(Cmd : string) : string;
    function DoAdminAccess(Cmd : string) : string;
    //
    function DoRedir : string;
    //
    function DoIndexPage (msg : string = '' ) : string;
    function HeaderArea(DocumentTitle : string = '') : string;
    //
    function DoAdmin : string;
    //
    // Login, Logout
    //
    function DoLogin (const Guest : boolean = false): integer; overload;
    function DoLogin (user, pwd : string): integer; overload;
    function DoLogOut : string;
    //
    // Users
    //
    function DoShowUsers : string;
    function DoEditUser : string;
    function DoSaveUser : string;
    function DoDelUser : string;
    //
    // User Access Rights
    //
    function DoShowSectionsAccess : string;
    function DoEditSectionsAccess : string;
    function DoSaveSectionsAccess : string;
    //
    // Sections
    //
    function DoShowSections : string;
    function DoAddSection : string;
    function DoEditSection : string;
    function DoSaveSection : string;
    function DoDelSection : string;
    function DoMoveSection : string;
    //
    // User's password
    //
    function DoSavePwd : string;
    function DoChangePwd : string;
    //
    // Packages and files
    //
    function DoShowPackAccess : string;
    function DoEditPackAccess : string;
    function DoSavePackAccess : string;
    //
    function DoShowPackages : string;
    function DoAddPack : string;
    function DoEditPack : string;
    function DoSavePack : string;
    function DoDelPack : string;
    //
    function DoPackFiles : string;
    function DoAddFile : string;
    function DoEditFile : string;
    function DoSaveFile : string;
    function DoDelFile : string;
    //-------------------------------------------------------------------------
    // Forum and Packages for user's access
    //-------------------------------------------------------------------------
    function DoForum : string;
    function DoPackagesSectionView : string;
    function DoSectionView : string;
    function DoNewTopic : string;
    function DoSaveTopic : string;
    function DoTopicView : string;
    function DoDeleteTopic : string;
    function DoDeleteReply: string;
    //
    function DoSetFilter : string;
    //
    //
  public
    constructor Create(aSrv : TRtcDataServer);
    function MakeDispatch : string;
    function GetSessionLogin : string;
    //
    property Srv : TRtcDataServer read fSrv;
    property Session : TRtcServerSession read GetSession;
    property SessionID : string read GetSessionID;

    property TemplatePath : string read GetTemplatePath;
    property UploadPath : string read GetUploadPath;
  end;

procedure InitForumData(data, templates, upload:string);

implementation

var
  Forum_Templates_Path,
  Forum_Upload_Path:string;

  ForumData:TRtcForumData;

procedure InitForumData(data, templates, upload:string);
  begin
  if assigned(ForumData) then
    begin
    ForumData.Free;
    ForumData:=nil;
    end;

  data:=_IncludeTrailingPathDelimiter(data);
  templates:=_IncludeTrailingPathDelimiter(templates);
  upload:=_IncludeTrailingPathDelimiter(upload);

  Forum_Templates_Path:=templates;
  Forum_Upload_Path:=upload;

  InitUserData(data);
  ForumData:=TRtcForumData.Create(data);
  end;

// Visibility of section. Look at matrix.xls for details...
function IsSectionVisible(SectionVisLevel : TVisibilityLevel;
  UserLevel : TUserAccessLevel) : boolean;
begin
  Result :=
    (SectionVisLevel = vlPublic) or
    ( (SectionVisLevel = vlPrivate) and (UserLevel > uaNone) );
end;

// Writable of section for user. Look at matrix.xls for details...
function IsSectionWritable(SectionAccessLevel : TAccessLevel;
  UserLevel : TUserAccessLevel) : boolean;
begin
  Result :=
    (SectionAccessLevel = alOpen) or
    ( (SectionAccessLevel = alClosed) and (UserLevel >= uaWrite) );
end;

// Moderatable of section for user. Look at matrix.xls for details...
function IsSectionModeratable(SectionAccessLevel : TAccessLevel;
  UserLevel : TUserAccessLevel) : boolean;
begin
  Result := (UserLevel >= uaModerate) ;
end;

{-- Encode/decode login information --------------------------------------------}
const
  __crypt_key = '{A73A8BE7-18FD-4D38-99BC-9BC2BFD5E6BC}';  // randomly generated key

function EncodeLoginInfo(user, pwd : string) : string;
var
  Arr : TRtcArray;
  S : string;
begin
  S := '';
  Result := '';

  Arr := TRtcArray.Create;
  try
    Arr.asString[0]:=user;
    Arr.asString[1]:=pwd;
    S := Arr.toCode;
  finally
    Arr.Kill;
  end;

  Crypt(S, __crypt_key);
  Result := URL_Encode(Mime_Encode(S));
end;

procedure DecodeLoginInfo(str : string; var user, pwd : string);
var
  Arr : TRtcArray;
  S : string;
begin
  try
    S := Mime_Decode(URL_Decode(str));
    Decrypt(S, __crypt_key);

    Arr := TRtcArray.FromCode(S);
    try
      user := Arr.asString[0];
      pwd := Arr.asString[1];
    finally
      Arr.Kill;
      end;
  except
    user:='';
    pwd:='';
    end;
end;

{-- TCommandsDispatcher  -------------------------------------------------------}

function TCommandsDispatcher.MakeDispatch : string;
var
  Cmd : string;
  Access_Level : integer;
  user, pwd : string;
  S : string;

  function _ChangeSID (S : string) : string;               //cmd=packages&sid=88464CC05F1244CFACA1C6584B498D48
  var
    P0, P1 : integer;
  begin
    Result := S;
    P0 := Pos('sid=', S);
    if P0 = 0 then begin
      S := Format('%s&sid=', [S]);
      P0 := Length(S) - 3;
    end;
    P0 := P0 + 4;
    P1 := P0 + 32;
    Result:=Copy(S, 1, P0-1);
    if assigned(Session) then
      Result := Result+SessionID;
    Result:=Result+Copy(S, P1+1, MAXINT);
  end;

begin
  Cmd := GetRequestValue('cmd');

  if (Cmd = 'logout') then
    begin
    if (Srv.Request.Cookie['rtc_forum_uid'] <> '') and
       (CompareText(Srv.Request.Cookie['rtc_forum_uid'],'null')<>0) then  // only if cookie present
      begin
      Srv.Response.Cookie['rtc_forum_uid'] := 'null; expires=Sat, 01-Jan-2000 00:00:00 GMT; path=/;';
      Srv.Request.Cookie['rtc_forum_uid']:='';
      end;
    if FindSession then
      begin
      Srv.Session.Close;
      Srv.UnLockSession;
      end;
    Relocation('?cmd=home');
    Exit; // **** EXIT ****
    end
  else if (Cmd = 'login') then
    begin
    Access_Level := DoLogin;
    if (Access_Level=ACCESS_LEVEL_ADMIN) then // Admin always logs into initial screen
      Srv.Request.Query['cmd']:='';
    end
  else if FindSession and Session.asBoolean['login'] then
    Access_Level := Session.asInteger['access_level']
  else
    begin
    S := Srv.Request.Cookie['rtc_forum_uid'];
    if (length(s)>0) and (CompareText(s,'null')<>0) then
      begin
      DecodeLoginInfo(S, user, pwd);
      if (user<>'') then
        Access_Level := DoLogin(user, pwd)
      else
        Access_Level := DoLogin(True);
      end
    else
      Access_Level := DoLogin(True);
    end;

  if (Cmd='login') or (Cmd='logout') then
    begin
    Srv.Request.Method:='GET';
    Cmd:=GetRequestValue('cmd');
    end;

  if assigned(Session) and
      (Access_Level<>ACCESS_LEVEL_DENIED) and
      (Srv.Request.Query['sid']<>Session.ID) then
    Relocation('?'+_ChangeSID(Srv.Request.Query.Text))
  else
    begin
    case Access_Level of
      ACCESS_LEVEL_USER :
        Result := DoCommonAccess(Cmd);
      ACCESS_LEVEL_ADMIN :
        Result := DoAdminAccess(Cmd);
      else
        begin
        PageMessage := GetMsg('error_login_failed');
        Result := DoCommonAccess(Cmd);
        end;
      end;
    end;
  end;

function TCommandsDispatcher.DoLogin(const Guest : boolean = false) : integer;
var
  user, pwd: string;
  guest_access : boolean;
  S : string;
  PreviousLogon : TDateTime;
begin
  if not Guest then
    user := GetRequestValue('user');

  if user = '' then
    user := LOGIN_GUEST;

  pwd := GetRequestValue('pwd');

  guest_access := Guest or SameText(user, LOGIN_GUEST);

  if Guest or CheckUser(user, pwd) then
    begin
    if not guest_access then
      begin
      Srv.OpenSession;
      if user = LOGIN_ADMIN then
        Session.asInteger['access_level'] := ACCESS_LEVEL_ADMIN
      else
        Session.asInteger['access_level'] := ACCESS_LEVEL_USER;
      Session.asString['user_name'] := user;
      Session.asBoolean['login'] := True;
      Session.KeepAlive := 60 * 60; //60 minutes
      {$IFDEF USE_COOKIE_SESSIONID}
      Srv.Response.Cookie['session'] := SessionID;
      {$ENDIF}

      // get previuos logon datetime
      GetLastLogon(user, PreviousLogon);
      Session.asDateTime['previous logon'] := PreviousLogon;
      SetLastLogon(user, Now);
      // set cookie for auto-open session next visit
      S := EncodeLoginInfo(user, pwd);
      Srv.Response.Cookie['rtc_forum_uid'] := Format('%s; expires=Sun, 01-Jan-2034 00:00:00 GMT; path=/;', [S]);

      Result := Session.asInteger['access_level'];
      end
    else
      Result := ACCESS_LEVEL_USER;
    end
  else
    Result := ACCESS_LEVEL_DENIED;
end;

function TCommandsDispatcher.DoShowUsers : string;
var
  Page : TRtcParse;
  TableRow : TRtcParse;
  S : string;
  Users : TStringList;
  I : integer;
begin
  Page := TRtcParse.Create(TemplatePath + 'users.htm');
  try
    ShowPageMessage(Page);
    Page['header_area'] := HeaderArea;
    S := '';
    TableRow := TRtcParse.Create(TemplatePath + 'users_table_row.htm');
    try
      Users := TStringList.Create;
      try
        GetUsers(Users);
        for I := 0 to Users.Count - 1 do begin
          TableRow.Clear;
          TableRow['user_login'] := Users.Names[I];
          TableRow['user_login_enc'] := URL_Encode(Users.Names[I]);
          TableRow['user_name'] := Users.ValueFromIndex[I];
          TableRow['sid'] := SessionID;
          S := S + TableRow.Output;
        end;
      finally
        Users.Free;
      end;
    finally
      TableRow.Free;
    end;

    Page['table_rows'] := S;
    Page['sid'] := SessionID;
    Result := Page.Output;
  finally
    Page.Free;
  end;
end;

function TCommandsDispatcher.DoEditUser : string;
var
  Page : TRtcParse;
  name, pwd : string;
  login: string;
begin
  Page := TRtcParse.Create(TemplatePath + 'edituser.htm');
  try
    Page['header_area'] := HeaderArea;
    login := GetRequestValue('user');
    GetUserInfo(login, name, pwd);
    if name = '' then
      begin
        Page['caption'] := 'Add user';
        Page['new'] := 'true';
      end
    else
      begin
        Page['caption'] := 'Edit user';
        Page['new'] := '';
      end;
    Page['name'] := name;
    Page['login'] := login;
    Page['sid'] := SessionID;
    Result := Page.Output;
  finally
    Page.Free;
  end;
end;

function TCommandsDispatcher.DoSaveUser : string;
var
  login : string;
begin
  login := GetRequestValue('login');
  if (GetRequestValue('new')='true') and IsUserExists(login) then
    PageMessage := Format(GetMsg('error_user_exists'), [login])
  else
    SaveUserInfo(login, GetRequestValue('name'), GetRequestValue('pwd'));

  //Result := DoShowUsers;
  Relocation(Format('?cmd=showusers&sid=%s', [SessionID]));
end;

function TCommandsDispatcher.DoDelUser : string;
var
  login: string;
begin
  login := GetRequestValue('user');