freepascal.compiler/packages/fcl-web/examples/fptemplate/sessions/urlsessions-login/webmodule/webmodule.pas

unit webmodule;

{$mode objfpc}{$H+}

interface

uses
  SysUtils, Classes, HTTPDefs, fpHTTP, fpWeb;

type

  { TFPWebModule1 }

  TFPWebModule1 = class(TFPWebModule)
    procedure DataModuleAfterResponse(Sender: TObject; AResponse: TResponse);
    procedure DataModuleCreate(Sender: TObject);
    procedure loginRequest(Sender: TObject; ARequest: TRequest;
      AResponse: TResponse; var Handled: Boolean);
    procedure logoutRequest(Sender: TObject; ARequest: TRequest;
      AResponse: TResponse; var Handled: Boolean);
    procedure someactionRequest(Sender: TObject; ARequest: TRequest;
      AResponse: TResponse; var Handled: Boolean);
  private
    { private declarations }
    LoggedInLoginName : String;
    SessionID: String;
    SessionDBFile : String;
    UserDBFile : String;
    SessionVariable: String;
    TimeoutMinutes: Integer;
    function RemoveExpiredSessions(SL:TStringList; const SIDToDelete:String):Boolean;
    function NotLoggedIn:Boolean;
    function CommonTemplateTagReplaces(const TagString:String;
      TagParams: TStringList; Out ReplaceText: String):Boolean;

    procedure loginReplaceTag(Sender: TObject; const TagString:String;
      TagParams: TStringList; Out ReplaceText: String);
    procedure logoutReplaceTag(Sender: TObject; const TagString:String;
      TagParams: TStringList; Out ReplaceText: String);
    procedure welcomeReplaceTag(Sender: TObject; const TagString:String;
      TagParams: TStringList; Out ReplaceText: String);
    procedure someactionReplaceTag(Sender: TObject; const TagString:String;
      TagParams: TStringList; Out ReplaceText: String);
  public
    { public declarations }
  end; 

var
  FPWebModule1: TFPWebModule1; 

implementation

{$R *.lfm}

{ TFPWebModule1 }

procedure TFPWebModule1.DataModuleAfterResponse(Sender: TObject;
  AResponse: TResponse);
var
  sessiondatabase:TStringList;
  SIDLastRefresh:String;
begin
  //update the session DB for the current session
  if (SessionID <> '')and(LoggedinLoginName <> '') then
  begin//for many concurrent request websites this part needs to be modified to have some kind of locking while writing into the file/relational database
    SIDLastRefresh := '';
    sessiondatabase := TStringList.Create;
    if FileExists(sessiondbfile) then
      sessiondatabase.LoadFromFile(sessiondbfile);
    SIDLastRefresh := sessiondatabase.Values[SessionID];
    if SIDLastRefresh <> '' then
    begin
      sessiondatabase.Values[SessionID] := DateTimeToStr(Now) + LoggedinLoginName;//update the Last refresh time
      sessiondatabase.SaveToFile(sessiondbfile);
    end;
    sessiondatabase.Free;
  end;

  //reset global variables for apache modules for the next incoming request
  LoggedInLoginName := '';
  SessionID := '';
  //
end;

procedure TFPWebModule1.DataModuleCreate(Sender: TObject);
begin
  ModuleTemplate.AllowTagParams := true;
  ModuleTemplate.StartDelimiter := '{+'; //The default is { and } which is usually not good if we use Javascript in our templates
  ModuleTemplate.EndDelimiter := '+}';
  sessiondbfile := 'session-db.txt';//This will contain the sessionID=expiration pairs
  userdbfile := 'userdb.txt';      //This simulates a user database with passwords
  TimeOutMinutes := 2;             //With a session timeout of 2 minutes
  SessionVariable := 'sid';        //Query parameter name for the session ID, for all links in the templates
  LongTimeFormat := 'hh:mm:ss';    //to save on date time conversion code
  ShortDateFormat := 'YYYY/MM/DD'; //to save on date time conversion code
end;

function FindNameInList(const SL:TStrings; const N:String):String;
var
    i : Integer;
begin
  Result := '';
  for i := 0 to SL.Count - 1 do
    if SL.Names[i] = N then
    begin
      Result := SL.Values[SL.Names[i]];
      break;
    end;
end;

function TFPWebModule1.RemoveExpiredSessions(SL:TStringList; const SIDToDelete:String):Boolean;
var
  DT:TDateTime;
  i, j: Integer;
  s, SIDLastRefresh: String;
begin
  Result := false;

  if SL.Count <= 0 then Exit;
  i := 0;
  repeat
    s := SL[i];
    j := pos('=', s);
    if j > 0 then
    begin
      if copy(s, 1, j - 1) = SIDToDelete then
      begin
        SL.Delete(i);
        dec(i);
      end else begin
        SIDLastRefresh := copy(s, j + 1, 19);{YYYY/MM/DD hh:mm:ss}
        DT := StrToDateTime(SIDLastRefresh);
        if ((Now - DT) > (TimeOutMinutes/1440)) then
        begin
          Result := true;
          SL.Delete(i);
          dec(i);
        end;
      end;
    end;
    inc(i);
  until i >= SL.Count;
end;

function TFPWebModule1.NotLoggedIn:Boolean;
var
  sessiondatabase:TStringlist;
  SIDLastRefresh:String;
begin
  Result := false;

  //check if the current sessionID is valid
  SessionID := UpperCase(Request.QueryFields.Values[SessionVariable]);
  if SessionID <> '' then
  begin
    sessiondatabase := TStringList.Create;
    if FileExists(sessiondbfile) then
      sessiondatabase.LoadFromFile(sessiondbfile);
//    if RemoveExpiredSessions(sessiondatabase, '') then  //Remove all expired sessions
//      sessiondatabase.SaveToFile(sessiondbfile);   {enough to purge only at logout events}
    RemoveExpiredSessions(sessiondatabase, '');      {                                     }
    SIDLastRefresh := sessiondatabase.Values[SessionID];
    sessiondatabase.Free;

    if SIDLastRefresh <> '' then
    begin
      LoggedinLoginName := copy(SIDLastRefresh, 20, 1024);
      Exit;//OK
    end;
  end;

  //show the login screen again with the expired session message
  ModuleTemplate.FileName := 'testurllogin.html';
  ModuleTemplate.OnReplaceTag := @loginReplaceTag;
  Request.QueryFields.Add('MSG=SESSIONEXPIRED');
  Response.Content := ModuleTemplate.GetContent;
  Result := true;
end;

procedure TFPWebModule1.loginRequest(Sender: TObject; ARequest: TRequest;
  AResponse: TResponse; var Handled: Boolean);
var
  loginname, pwd, pwd1 : String;
  userdatabase, sessiondatabase : TStringlist;
  G : TGUID;
begin
  Handled := true;
  ModuleTemplate.FileName := 'testurllogin.html';
  ModuleTemplate.OnReplaceTag := @loginReplaceTag;
  AResponse.CustomHeaders.Add('Pragma=no-cache');//do not cache the response in the web browser

  if FindNameInList(ARequest.ContentFields, 'LoginName') = '' then
  begin//called the login action without parameters -> display the login page
    ARequest.QueryFields.Add('MSG=NORMAL');
    AResponse.Content := ModuleTemplate.GetContent;
    Exit;
  end;

  loginname := Trim(ARequest.ContentFields.Values['LoginName']);
  pwd := Trim(ARequest.ContentFields.Values['Password']);
  if (pwd = '') or (loginname = '') then
  begin//empty login name or password -> return to the login screen
    ARequest.QueryFields.Add('MSG=MISSING');
    AResponse.Content := ModuleTemplate.GetContent;
    Exit;
  end;

  //simulate a user database loaded into a stringlist
  userdatabase := TStringlist.Create;
  userdatabase.LoadFromFile(userdbfile);
  pwd1 := userdatabase.values[LoginName];//get the correct password for the LoginName if it is there
  userdatabase.free;
  //

  if pwd <> pwd1 then
  begin//either the password or the login name was invalid
    ARequest.QueryFields.Add('MSG=INVLOGIN');
    AResponse.Content := ModuleTemplate.GetContent;
    Exit;
  end;

  //succesful login
  LoggedInLoginName := loginname;

  //session starting, need to store it somewhere next to the name of the logged in person
  sessiondatabase := TStringList.Create;
  if FileExists(sessiondbfile) then
    sessiondatabase.LoadFromFile(sessiondbfile);
  CreateGUID(G);
  SessionID:=UpperCase(GuiDToString(G));
  sessiondatabase.Add(SessionID + '=' + DateTimeToStr(Now) + LoggedinLoginName);//create a new entry for this session
  sessiondatabase.SaveToFile(sessiondbfile);//for many concurrent request websites this part needs to be modified to have some kind of locking while writing into the file/relational database
  sessiondatabase.Free;

  //generate the Welcome page content
  ModuleTemplate.FileName := 'testurlwelcome.html';
  ModuleTemplate.OnReplaceTag := @welcomeReplaceTag;
  AResponse.Content := ModuleTemplate.GetContent;
end;

procedure TFPWebModule1.loginReplaceTag(Sender: TObject; const TagString:
  String; TagParams: TStringList; Out ReplaceText: String);
begin
  {Handle tags used in multiple templates}
  if CommonTemplateTagReplaces(TagString, TagParams, ReplaceText) then
    Exit;

  {Handle tags specific to this template if there are any}
  if AnsiCompareText(TagString, 'MESSAGE') = 0 then
  begin
    ReplaceText := TagParams.Values[Request.QueryFields.Values['MSG']];
  end else

  {Message for tags not handled}
  begin
    ReplaceText := '[Template tag {+' + TagString + '+} is not implemented yet.]';
  end;
end;

procedure TFPWebModule1.welcomeReplaceTag(Sender: TObject; const TagString:String;
      TagParams: TStringList; Out ReplaceText: String);
begin
  {Handle tags used in multiple templates}
  if CommonTemplateTagReplaces(TagString, TagParams, ReplaceText) then
    Exit;

  {Handle tags specific to this template if there are any}


  {Message for tags not handled}
  begin
    ReplaceText := '[Template tag {+' + TagString + '+} is not implemented yet.]';
  end;
end;

procedure TFPWebModule1.logoutRequest(Sender: TObject; ARequest: TRequest;
  AResponse: TResponse; var Handled: Boolean);
var
  sessiondatabase : TStringList;
begin
  Handled := true;

  if NotLoggedIn then Exit;

  //delete the sessionID from the sessiondb with all expired sessions
  sessiondatabase := TStringList.Create;
  if FileExists(sessiondbfile) then
    sessiondatabase.LoadFromFile(sessiondbfile);
  RemoveExpiredSessions(sessiondatabase, SessionID);
  sessiondatabase.SaveToFile(sessiondbfile);//for many concurrent request websites this part needs to be modified to have some kind of locking while writing into the file/relational database
  sessiondatabase.Free;
  //

  ModuleTemplate.FileName := 'testurllogout.html';
  ModuleTemplate.OnReplaceTag := @logoutReplaceTag;
  AResponse.Content := ModuleTemplate.GetContent;//generate the Logout page content.
end;

procedure TFPWebModule1.logoutReplaceTag(Sender: TObject; const TagString:String;
  TagParams: TStringList; Out ReplaceText: String);
begin
  {Handle tags used in multiple templates}
  if CommonTemplateTagReplaces(TagString, TagParams, ReplaceText) then
    Exit;

  {Handle tags specific to this template if there are any}


  {Message for tags not handled}
  begin
    ReplaceText := '[Template tag {+' + TagString + '+} is not implemented yet.]';
  end;
end;

procedure TFPWebModule1.someactionRequest(Sender: TObject; ARequest: TRequest;
  AResponse: TResponse; var Handled: Boolean);
begin
  Handled := true;

  if NotLoggedIn then Exit;

  ModuleTemplate.FileName := 'testurlsomepage.html';
  ModuleTemplate.OnReplaceTag := @someactionReplaceTag;
  AResponse.Content := ModuleTemplate.GetContent;
end;

procedure TFPWebModule1.someactionReplaceTag(Sender: TObject; const TagString:
  String; TagParams: TStringList; Out ReplaceText: String);
begin
  {Handle tags used in multiple templates}
  if CommonTemplateTagReplaces(TagString, TagParams, ReplaceText) then
    Exit;

  {Handle tags specific to this template if there are any}


  {Message for tags not handled}
  begin
    ReplaceText := '[Template tag {+' + TagString + '+} is not implemented yet.]';
  end;
end;

function TFPWebModule1.CommonTemplateTagReplaces(const TagString:String;
  TagParams: TStringList; out ReplaceText: String):Boolean;
begin
  Result := true;

  if AnsiCompareText(TagString, 'SESSION-VARIABLE') = 0 then
  begin
    ReplaceText := SessionVariable + '=' + SessionID;
  end else

  if AnsiCompareText(TagString, 'DATETIME') = 0 then
  begin
    ReplaceText := FormatDateTime(TagParams.Values['FORMAT'], Now);
  end else

  if AnsiCompareText(TagString, 'SESSIONID') = 0 then
  begin
    ReplaceText := SessionID;
  end else

  if AnsiCompareText(TagString, 'MINUTESLEFT') = 0 then
  begin
    ReplaceText := IntToStr(TimeOutMinutes);
  end else

  if AnsiCompareText(TagString, 'LOGINNAME') = 0 then
  begin
    ReplaceText := LoggedInLoginName;
  end else

  Result := false;
end;

initialization
  RegisterHTTPModule('TFPWebModule1', TFPWebModule1);
end.