← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to components/fpweb/demo/fptemplate/sessions/urlsessions-login/apache/webmodule.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
components/fpweb/demo/fptemplate/sessions/urlsessions-login/apache/webmodule.pas
1
 
 unit webmodule;
2
 
 
3
 
{$mode objfpc}{$H+}
4
 
 
5
 
interface
6
 
 
7
 
uses
8
 
  Classes, SysUtils, FileUtil, LResources, HTTPDefs, websession, fpHTTP, fpWeb; 
9
 
 
10
 
type
11
 
 
12
 
  { TFPWebModule1 }
13
 
 
14
 
  TFPWebModule1 = class(TFPWebModule)
15
 
    procedure DataModuleAfterResponse(Sender: TObject; AResponse: TResponse);
16
 
    procedure DataModuleCreate(Sender: TObject);
17
 
    procedure loginRequest(Sender: TObject; ARequest: TRequest;
18
 
      AResponse: TResponse; var Handled: Boolean);
19
 
    procedure logoutRequest(Sender: TObject; ARequest: TRequest;
20
 
      AResponse: TResponse; var Handled: Boolean);
21
 
    procedure someactionRequest(Sender: TObject; ARequest: TRequest;
22
 
      AResponse: TResponse; var Handled: Boolean);
23
 
  private
24
 
    { private declarations }
25
 
    LoggedInLoginName : String;
26
 
    SessionID: String;
27
 
    SessionDBFile : String;
28
 
    UserDBFile : String;
29
 
    SessionVariable: String;
30
 
    TimeoutMinutes: Integer;
31
 
    function RemoveExpiredSessions(SL:TStringList; const SIDToDelete:String):Boolean;
32
 
    function NotLoggedIn:Boolean;
33
 
    function CommonTemplateTagReplaces(const TagString:String;
34
 
      TagParams: TStringList; Out ReplaceText: String):Boolean;
35
 
 
36
 
    procedure loginReplaceTag(Sender: TObject; const TagString:String;
37
 
      TagParams: TStringList; Out ReplaceText: String);
38
 
    procedure logoutReplaceTag(Sender: TObject; const TagString:String;
39
 
      TagParams: TStringList; Out ReplaceText: String);
40
 
    procedure welcomeReplaceTag(Sender: TObject; const TagString:String;
41
 
      TagParams: TStringList; Out ReplaceText: String);
42
 
    procedure someactionReplaceTag(Sender: TObject; const TagString:String;
43
 
      TagParams: TStringList; Out ReplaceText: String);
44
 
  public
45
 
    { public declarations }
46
 
  end; 
47
 
 
48
 
var
49
 
  FPWebModule1: TFPWebModule1; 
50
 
 
51
 
implementation
52
 
 
53
 
{ TFPWebModule1 }
54
 
 
55
 
procedure TFPWebModule1.DataModuleAfterResponse(Sender: TObject;
56
 
  AResponse: TResponse);
57
 
var
58
 
  sessiondatabase:TStringList;
59
 
  SIDLastRefresh:String;
60
 
begin
61
 
  //update the session DB for the current session
62
 
  if (SessionID <> '')and(LoggedinLoginName <> '') then
63
 
  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
64
 
    SIDLastRefresh := '';
65
 
    sessiondatabase := TStringList.Create;
66
 
    if FileExists(sessiondbfile) then
67
 
      sessiondatabase.LoadFromFile(sessiondbfile);
68
 
    SIDLastRefresh := sessiondatabase.Values[SessionID];
69
 
    if SIDLastRefresh <> '' then
70
 
    begin
71
 
      sessiondatabase.Values[SessionID] := DateTimeToStr(Now) + LoggedinLoginName;//update the Last refresh time
72
 
      sessiondatabase.SaveToFile(sessiondbfile);
73
 
    end;
74
 
    sessiondatabase.Free;
75
 
  end;
76
 
 
77
 
  //reset global variables for apache modules for the next incoming request
78
 
  LoggedInLoginName := '';
79
 
  SessionID := '';
80
 
  //
81
 
end;
82
 
 
83
 
procedure TFPWebModule1.DataModuleCreate(Sender: TObject);
84
 
begin
85
 
  Template.AllowTagParams := true;
86
 
  Template.StartDelimiter := '{+'; //The default is { and } which is usually not good if we use Javascript in our templates
87
 
  Template.EndDelimiter := '+}';
88
 
  sessiondbfile := 'session-db.txt';//This will contain the sessionID=expiration pairs
89
 
  userdbfile := 'userdb.txt';      //This simulates a user database with passwords
90
 
  TimeOutMinutes := 2;             //With a session timeout of 2 minutes
91
 
  SessionVariable := 'sid';        //Query parameter name for the session ID, for all links in the templates
92
 
  LongTimeFormat := 'hh:mm:ss';    //to save on date time conversion code
93
 
  ShortDateFormat := 'YYYY/MM/DD'; //to save on date time conversion code
94
 
end;
95
 
 
96
 
function FindNameInList(const SL:TStrings; const N:String):String;
97
 
var
98
 
    i : Integer;
99
 
begin
100
 
  Result := '';
101
 
  for i := 0 to SL.Count - 1 do
102
 
    if SL.Names[i] = N then
103
 
    begin
104
 
      Result := SL.Values[SL.Names[i]];
105
 
      break;
106
 
    end;
107
 
end;
108
 
 
109
 
function TFPWebModule1.RemoveExpiredSessions(SL:TStringList; const SIDToDelete:String):Boolean;
110
 
var
111
 
  DT:TDateTime;
112
 
  i, j: Integer;
113
 
  s, SIDLastRefresh: String;
114
 
begin
115
 
  Result := false;
116
 
 
117
 
  if SL.Count <= 0 then Exit;
118
 
  i := 0;
119
 
  repeat
120
 
    s := SL[i];
121
 
    j := pos('=', s);
122
 
    if j > 0 then
123
 
    begin
124
 
      if copy(s, 1, j - 1) = SIDToDelete then
125
 
      begin
126
 
        SL.Delete(i);
127
 
        dec(i);
128
 
      end else begin
129
 
        SIDLastRefresh := copy(s, j + 1, 19);{YYYY/MM/DD hh:mm:ss}
130
 
        DT := StrToDateTime(SIDLastRefresh);
131
 
        if ((Now - DT) > (TimeOutMinutes/1440)) then
132
 
        begin
133
 
          Result := true;
134
 
          SL.Delete(i);
135
 
          dec(i);
136
 
        end;
137
 
      end;
138
 
    end;
139
 
    inc(i);
140
 
  until i >= SL.Count;
141
 
end;
142
 
 
143
 
function TFPWebModule1.NotLoggedIn:Boolean;
144
 
var
145
 
  sessiondatabase:TStringlist;
146
 
  SIDLastRefresh:String;
147
 
begin
148
 
  Result := false;
149
 
 
150
 
  //check if the current sessionID is valid
151
 
  SessionID := UpperCase(Request.QueryFields.Values[SessionVariable]);
152
 
  if SessionID <> '' then
153
 
  begin
154
 
    sessiondatabase := TStringList.Create;
155
 
    if FileExists(sessiondbfile) then
156
 
      sessiondatabase.LoadFromFile(sessiondbfile);
157
 
//    if RemoveExpiredSessions(sessiondatabase, '') then  //Remove all expired sessions
158
 
//      sessiondatabase.SaveToFile(sessiondbfile);   {enough to purge only at logout events}
159
 
    RemoveExpiredSessions(sessiondatabase, '');      {                                     }
160
 
    SIDLastRefresh := sessiondatabase.Values[SessionID];
161
 
    sessiondatabase.Free;
162
 
 
163
 
    if SIDLastRefresh <> '' then
164
 
    begin
165
 
      LoggedinLoginName := copy(SIDLastRefresh, 20, 1024);
166
 
      Exit;//OK
167
 
    end;
168
 
  end;
169
 
 
170
 
  //show the login screen again with the expired session message
171
 
  Template.FileName := 'testurllogin.html';
172
 
  Template.OnReplaceTag := @loginReplaceTag;
173
 
  Request.QueryFields.Add('MSG=SESSIONEXPIRED');
174
 
  Response.Content := Template.GetContent;
175
 
  Result := true;
176
 
end;
177
 
 
178
 
procedure TFPWebModule1.loginRequest(Sender: TObject; ARequest: TRequest;
179
 
  AResponse: TResponse; var Handled: Boolean);
180
 
var
181
 
  loginname, pwd, pwd1 : String;
182
 
  userdatabase, sessiondatabase : TStringlist;
183
 
  G : TGUID;
184
 
begin
185
 
  Handled := true;
186
 
  Template.FileName := 'testurllogin.html';
187
 
  Template.OnReplaceTag := @loginReplaceTag;
188
 
  AResponse.CustomHeaders.Add('Pragma=no-cache');//do not cache the response in the web browser
189
 
 
190
 
  if FindNameInList(ARequest.ContentFields, 'LoginName') = '' then
191
 
  begin//called the login action without parameters -> display the login page
192
 
    ARequest.QueryFields.Add('MSG=NORMAL');
193
 
    AResponse.Content := Template.GetContent;
194
 
    Exit;
195
 
  end;
196
 
 
197
 
  loginname := Trim(ARequest.ContentFields.Values['LoginName']);
198
 
  pwd := Trim(ARequest.ContentFields.Values['Password']);
199
 
  if (pwd = '') or (loginname = '') then
200
 
  begin//empty login name or password -> return to the login screen
201
 
    ARequest.QueryFields.Add('MSG=MISSING');
202
 
    AResponse.Content := Template.GetContent;
203
 
    Exit;
204
 
  end;
205
 
 
206
 
  //simulate a user database loaded into a stringlist
207
 
  userdatabase := TStringlist.Create;
208
 
  userdatabase.LoadFromFile(userdbfile);
209
 
  //
210
 
 
211
 
  if userdatabase.Count <= 0 then
212
 
  begin//cannot find user DB or it is empty
213
 
    ARequest.QueryFields.Add('MSG=NODB');
214
 
    AResponse.Content := Template.GetContent;
215
 
    Exit;
216
 
  end;
217
 
  pwd1 := userdatabase.values[LoginName];
218
 
  userdatabase.free;
219
 
 
220
 
  if pwd <> pwd1 then
221
 
  begin//either the password or the login name was invalid
222
 
    ARequest.QueryFields.Add('MSG=INVLOGIN');
223
 
    AResponse.Content := Template.GetContent;
224
 
    Exit;
225
 
  end;
226
 
 
227
 
  //succesful login
228
 
  LoggedInLoginName := loginname;
229
 
 
230
 
  //session starting, need to store it somewhere next to the name of the logged in person
231
 
  sessiondatabase := TStringList.Create;
232
 
  if FileExists(sessiondbfile) then
233
 
    sessiondatabase.LoadFromFile(sessiondbfile);
234
 
  CreateGUID(G);
235
 
  SessionID:=UpperCase(GuiDToString(G));
236
 
  sessiondatabase.Add(SessionID + '=' + DateTimeToStr(Now) + LoggedinLoginName);//create a new entry for this session
237
 
  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
238
 
  sessiondatabase.Free;
239
 
 
240
 
  //generate the Welcome page content
241
 
  Template.FileName := 'testurlwelcome.html';
242
 
  Template.OnReplaceTag := @welcomeReplaceTag;
243
 
  AResponse.Content := Template.GetContent;
244
 
end;
245
 
 
246
 
procedure TFPWebModule1.loginReplaceTag(Sender: TObject; const TagString:
247
 
  String; TagParams: TStringList; Out ReplaceText: String);
248
 
begin
249
 
  {Handle tags used in multiple templates}
250
 
  if CommonTemplateTagReplaces(TagString, TagParams, ReplaceText) then
251
 
    Exit;
252
 
 
253
 
  {Handle tags specific to this template if there are any}
254
 
  if AnsiCompareText(TagString, 'MESSAGE') = 0 then
255
 
  begin
256
 
    ReplaceText := TagParams.Values[Request.QueryFields.Values['MSG']];
257
 
  end else
258
 
 
259
 
  {Message for tags not handled}
260
 
  begin
261
 
    ReplaceText := '[Template tag {+' + TagString + '+} is not implemented yet.]';
262
 
  end;
263
 
end;
264
 
 
265
 
procedure TFPWebModule1.welcomeReplaceTag(Sender: TObject; const TagString:String;
266
 
      TagParams: TStringList; Out ReplaceText: String);
267
 
begin
268
 
  {Handle tags used in multiple templates}
269
 
  if CommonTemplateTagReplaces(TagString, TagParams, ReplaceText) then
270
 
    Exit;
271
 
 
272
 
  {Handle tags specific to this template if there are any}
273
 
 
274
 
 
275
 
  {Message for tags not handled}
276
 
  begin
277
 
    ReplaceText := '[Template tag {+' + TagString + '+} is not implemented yet.]';
278
 
  end;
279
 
end;
280
 
 
281
 
procedure TFPWebModule1.logoutRequest(Sender: TObject; ARequest: TRequest;
282
 
  AResponse: TResponse; var Handled: Boolean);
283
 
var
284
 
  sessiondatabase : TStringList;
285
 
begin
286
 
  Handled := true;
287
 
 
288
 
  if NotLoggedIn then Exit;
289
 
 
290
 
  //delete the sessionID from the sessiondb with all expired sessions
291
 
  sessiondatabase := TStringList.Create;
292
 
  if FileExists(sessiondbfile) then
293
 
    sessiondatabase.LoadFromFile(sessiondbfile);
294
 
  RemoveExpiredSessions(sessiondatabase, SessionID);
295
 
  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
296
 
  sessiondatabase.Free;
297
 
  //
298
 
 
299
 
  Template.FileName := 'testurllogout.html';
300
 
  Template.OnReplaceTag := @logoutReplaceTag;
301
 
  AResponse.Content := Template.GetContent;//generate the Logout page content.
302
 
end;
303
 
 
304
 
procedure TFPWebModule1.logoutReplaceTag(Sender: TObject; const TagString:String;
305
 
  TagParams: TStringList; Out ReplaceText: String);
306
 
begin
307
 
  {Handle tags used in multiple templates}
308
 
  if CommonTemplateTagReplaces(TagString, TagParams, ReplaceText) then
309
 
    Exit;
310
 
 
311
 
  {Handle tags specific to this template if there are any}
312
 
 
313
 
 
314
 
  {Message for tags not handled}
315
 
  begin
316
 
    ReplaceText := '[Template tag {+' + TagString + '+} is not implemented yet.]';
317
 
  end;
318
 
end;
319
 
 
320
 
procedure TFPWebModule1.someactionRequest(Sender: TObject; ARequest: TRequest;
321
 
  AResponse: TResponse; var Handled: Boolean);
322
 
begin
323
 
  Handled := true;
324
 
 
325
 
  if NotLoggedIn then Exit;
326
 
 
327
 
  Template.FileName := 'testurlsomepage.html';
328
 
  Template.OnReplaceTag := @someactionReplaceTag;
329
 
  AResponse.Content := Template.GetContent;
330
 
end;
331
 
 
332
 
procedure TFPWebModule1.someactionReplaceTag(Sender: TObject; const TagString:
333
 
  String; TagParams: TStringList; Out ReplaceText: String);
334
 
begin
335
 
  {Handle tags used in multiple templates}
336
 
  if CommonTemplateTagReplaces(TagString, TagParams, ReplaceText) then
337
 
    Exit;
338
 
 
339
 
  {Handle tags specific to this template if there are any}
340
 
 
341
 
 
342
 
  {Message for tags not handled}
343
 
  begin
344
 
    ReplaceText := '[Template tag {+' + TagString + '+} is not implemented yet.]';
345
 
  end;
346
 
end;
347
 
 
348
 
function TFPWebModule1.CommonTemplateTagReplaces(const TagString:String;
349
 
  TagParams: TStringList; out ReplaceText: String):Boolean;
350
 
begin
351
 
  Result := true;
352
 
 
353
 
  if AnsiCompareText(TagString, 'SESSION-VARIABLE') = 0 then
354
 
  begin
355
 
    ReplaceText := SessionVariable + '=' + SessionID;
356
 
  end else
357
 
 
358
 
  if AnsiCompareText(TagString, 'DATETIME') = 0 then
359
 
  begin
360
 
    ReplaceText := FormatDateTime(TagParams.Values['FORMAT'], Now);
361
 
  end else
362
 
 
363
 
  if AnsiCompareText(TagString, 'SESSIONID') = 0 then
364
 
  begin
365
 
    ReplaceText := SessionID;
366
 
  end else
367
 
 
368
 
  if AnsiCompareText(TagString, 'MINUTESLEFT') = 0 then
369
 
  begin
370
 
    ReplaceText := IntToStr(TimeOutMinutes);
371
 
  end else
372
 
 
373
 
  if AnsiCompareText(TagString, 'LOGINNAME') = 0 then
374
 
  begin
375
 
    ReplaceText := LoggedInLoginName;
376
 
  end else
377
 
 
378
 
  Result := false;
379
 
end;
380
 
 
381
 
initialization
382
 
  {$I webmodule.lrs}
383
 
 
384
 
  RegisterHTTPModule('TFPWebModule1', TFPWebModule1); 
385
 
end.