dws2sessionlibmodule.pas

script language

{**********************************************************************}
{                                                                      }
{    "The contents of this file are subject to the Mozilla Public      }
{    License Version 1.1 (the "License"); you may not use this         }
{    file except in compliance with the License. You may obtain        }
{    a copy of the License at                                          }
{                                                                      }
{    http://www.mozilla.org/MPL/                                       }
{                                                                      }
{    Software distributed under the License is distributed on an       }
{    "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express       }
{    or implied. See the License for the specific language             }
{    governing rights and limitations under the License.               }
{                                                                      }
{    The Original Code is DelphiWebScriptII source code, released      }
{    January 1, 2001                                                   }
{                                                                      }
{    http://www.dwscript.com                                           }
{                                                                      }
{    The Initial Developers of the Original Code are Matthias          }
{    Ackermann and hannes hernler.                                     }
{    Portions created by Matthias Ackermann are Copyright (C) 2001     }
{    Matthias Ackermann, Switzerland. All Rights Reserved.             }
{    Portions created by hannes hernler are Copyright (C) 2001         }
{    hannes hernler, Austria. All Rights Reserved.                     }
{                                                                      }
{    Contributor(s): ______________________________________.           }
{                                                                      }
{**********************************************************************}

unit dws2SessionLibModule;

interface

uses
{$IFDEF LINUX}
  Libc,
{$ELSE}
  Windows, Forms,
{$ENDIF}
  SysUtils, Classes, contnrs, HTTPApp,
  dws2Comp, dws2Exprs, SyncObjs, dws2WebBasics, dws2SessionGlobals, dws2SessionBasics;

const
  DWS_ACTION_TDIFF = 0.001; // 10 / (24 * 60); // 14 minutes session timeout
  DWS_TOUCH_TDIFF = 0.0001; // 1 / (24 * 60); // 1.4 minutes session timeout
  DWS_COOKIEPREFIX = 'DWSC'; // prefix that is sent with user tracking cookies
  DWS_TOUCHBRAND_PREFIX = 'TOUCH';

type
  Tdws2SessionLib = class;

  TOnCustomUSTEvent = procedure(SessionLib: Tdws2SessionLib; USession: TUserSession) of object;

  Tdws2SessionLib = class(TDatamodule, IUnknown, ISessionManager)
    customSessionUnit: Tdws2Unit;
    procedure dws2UnitClassesUserMethodsSetIpAddrEval(Info: TProgramInfo;
      ExtObject: TObject);
    procedure dws2UnitClassesUserMethodsSetSstateEval(Info: TProgramInfo;
      ExtObject: TObject);
    procedure dws2UnitClassesUserMethodsSetSBrandEval(Info: TProgramInfo;
      ExtObject: TObject);
    procedure dws2UnitClassesUserMethodsSetTLoginEval(Info: TProgramInfo;
      ExtObject: TObject);
    procedure dws2UnitClassesUserMethodsSetTLastActionEval(
      Info: TProgramInfo; ExtObject: TObject);
    procedure dws2UnitClassesUserMethodsGetActiveUsersEval(
      Info: TProgramInfo; ExtObject: TObject);
    procedure dws2UnitClassesUserMethodsGetIpAddrEval(Info: TProgramInfo;
      ExtObject: TObject);
    procedure dws2UnitClassesUserMethodsGetSstateEval(Info: TProgramInfo;
      ExtObject: TObject);
    procedure dws2UnitClassesUserMethodsGetSBrandEval(Info: TProgramInfo;
      ExtObject: TObject);
    procedure dws2UnitClassesUserMethodsGetTLoginEval(Info: TProgramInfo;
      ExtObject: TObject);
    procedure dws2UnitClassesUserMethodsGetTLastActionEval(
      Info: TProgramInfo; ExtObject: TObject);
    procedure dws2UnitFunctionsTIDEval(Info: TProgramInfo);
    procedure dws2UnitClassesUserMethodsGetUserdataEval(Info: TProgramInfo;
      ExtObject: TObject);
    procedure customSessionUnitClassesUserMethodsSetUserDataEval(
      Info: TProgramInfo; ExtObject: TObject);
    procedure customSessionUnitFunctionsActivSessionEval(
      Info: TProgramInfo);
    procedure customSessionUnitFunctionsURLEval(Info: TProgramInfo);
  private
    { Private-Deklarationen }
    FScript: TDelphiWebScriptII;
    FUseSessionCookie: boolean; // use cookies for user tracking
    FSessionBrandLabel: string; // name for unique lable for active user session
    FSessionCookiePrefix: string;
    FSessionCookieExpireTime: real;
    FSessionExpireTime: real;
    FSessionTouchTime: real;
    FHttpInfo: THttpInfo;
    FOnCloseUserSession, FOnNewUserSession: TOnCustomUSTEvent;
    FFailedAuthMessage: TStringList; // OnCustomUSTEvent eventhandler
    procedure AddSBrandFunction;
    procedure RemoveSBrandFunction;
    procedure SetScript(const Value: TDelphiWebScriptII);
    procedure SetFailedAuthMessage(const Value: TStringList);
  public
    constructor create(AOwner: TComponent); override;
    destructor destroy; override;
//    function QueryInterface(const IID: TGUID; out Obj): HResult; override;
//    function _AddRef: Integer; stdcall;
//    function _Release: Integer; stdcall;

    function GetUserSession: TUserSession; // interface
    function GetSessionBrand: string; // interface
    function LocateUserSession(HttpInfo: THttpInfo): TSessionTrackingState; // interface
    function CreateUserSession: TUserSession; // interface
    procedure CloseUserSession(USession: TUserSession); // interface

    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    property HttpInfo: THttpInfo read FHttpInfo;
  published
    property Script: TDelphiWebScriptII read FScript write SetScript;
    property SessionCookiePrefix: string read FSessionCookiePrefix write FSessionCookiePrefix;
    property SessionCookieExpireTime: real read FSessionCookieExpireTime write FSessionCookieExpireTime;
    property SessionExpireTime: real read FSessionExpireTime write FSessionExpireTime;
    property SessionTouchTime: real read FSessionTouchTime write FSessionTouchTime;
    property SessionBrandLabel: string read FSessionBrandLabel write FSessionBrandLabel;
    property UseSessionCookie: boolean read FUseSessionCookie write FUseSessionCookie;
    property FailedAuthMessage: TStringList read FFailedAuthMessage write SetFailedAuthMessage;
    property OnNewUserSession: TOnCustomUSTEvent read FOnNewUserSession write FOnNewUserSession;
    property OnCloseUserSession: TOnCustomUSTEvent read FOnCloseUserSession write FOnCloseUserSession;
  end;

var
  GlobalSessionList: TGlobalSessionList;

procedure Register;


implementation

{$R *.dfm}

procedure Register;
begin
  RegisterComponents('DWS2', [Tdws2SessionLib]);
end;

// ************************** Tdws2SessionLib  *************************

constructor Tdws2SessionLib.create(AOwner: TComponent);
begin
  inherited;
  FFailedAuthMessage:= TStringList.Create;
  FSessionCookiePrefix := DWS_COOKIEPREFIX;
  FSessionCookieExpireTime := 0.2;
  FSessionExpireTime := DWS_ACTION_TDIFF;
  FSessionTouchTime := DWS_ACTION_TDIFF;
  FSessionBrandLabel := 'TID';
end;

procedure Tdws2SessionLib.AddSBrandFunction;
var
  sbfunc: Tdws2Function;
begin
  if Assigned(FScript) and not (csDesigning in ComponentState) then
  begin
    sbfunc := Tdws2Function(customSessionUnit.Functions.Add);
    sbfunc.ResultType := 'String';
    sbfunc.Name := FSessionBrandLabel;
    sbfunc.OnEval := dws2UnitFunctionsTIDEval;
  end;
end;

procedure Tdws2SessionLib.RemoveSBrandFunction;
var
  i: Integer;
begin
  if Assigned(FScript) and not (csDesigning in ComponentState) then
    with customSessionUnit.Functions do
    begin
      for i := 0 to count - 1 do
      begin
        if Tdws2Function(items[i]).name = FSessionBrandLabel then
        begin
          delete(i);
          exit;
        end;
      end;
    end;
end;

procedure Tdws2SessionLib.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  if (Operation = opRemove) and (AComponent = FScript) then
    SetScript(nil);
  inherited;
end;

procedure Tdws2SessionLib.SetScript(const Value: TDelphiWebScriptII);
var
  x: Integer;
begin
  if Assigned(FScript) then
  begin
    FScript.RemoveFreeNotification(Self);
    RemoveSBrandFunction;
  end;
  FScript := Value;
  if Assigned(FScript) then
  begin
    Value.FreeNotification(FScript);
    AddSBrandFunction;
  end;
  if not (csDesigning in ComponentState) then
    for x := 0 to ComponentCount - 1 do
      if Components[x] is Tdws2Unit then
        Tdws2Unit(Components[x]).Script := Value;
//    customSessionUnit.Script := Value;
end;

function Tdws2SessionLib.GetUserSession: TUserSession;
begin
  Result := FHttpInfo.UserSession;
end;

function Tdws2SessionLib.LocateUserSession(HttpInfo: THttpInfo): TSessionTrackingState;
var
  sH, sBrand, sTouchBrand: string;
begin
  Result := dssNoSession;
  FHttpInfo := HttpInfo;
  with FHttpInfo do
  begin
    UserSession := nil;
    if UseSessionCookie then // Session ID in cookie
    begin
      sH := FSessionCookiePrefix + SessionBrandLabel;
      sBrand := HttpInfo.HttpRequest.CookieFields.Values[sH];
    end