1 unit webmodule;
2
3 {$mode objfpc}{$H+}
4
5 interface
6
7 uses
8 SysUtils, Classes, httpdefs, fpHTTP, fpWeb, iniwebsession;
9
10 type
11
12 { TFPWebModule1 }
13
14 TFPWebModule1 = class(TFPWebModule)
15 procedure DataModuleAfterResponse(Sender: TObject; AResponse: TResponse);
16 procedure DataModuleCreate(Sender: TObject);
17 //web action handlers
18 procedure loginRequest(Sender: TObject; ARequest: TRequest; AResponse: TResponse; var Handled: Boolean);
19 procedure logoutRequest(Sender: TObject; ARequest: TRequest; AResponse: TResponse; var Handled: Boolean);
20 procedure someactionRequest(Sender: TObject; ARequest: TRequest; AResponse: TResponse; var Handled: Boolean);
21 private
22 { private declarations }
23 MySessionDir : String;
24 LoggedInLoginName : String;
25 SessionDBFile : String;
26 UserDBFile : String;
NotLoggedInnull27 function NotLoggedIn:Boolean;
CommonTemplateTagReplacesnull28 function CommonTemplateTagReplaces(const TagString:String; TagParams: TStringList; out ReplaceText: String):Boolean;
29 //template tag handlers
30 procedure loginReplaceTag(Sender: TObject; const TagString: String; TagParams: TStringList; Out ReplaceText: String);
31 procedure welcomeReplaceTag(Sender: TObject; const TagString:String; TagParams: TStringList; Out ReplaceText: String);
32 procedure logoutReplaceTag(Sender: TObject; const TagString:String; TagParams: TStringList; Out ReplaceText: String);
33 procedure someactionReplaceTag(Sender: TObject; const TagString:String; TagParams: TStringList; Out ReplaceText: String);
34 public
35 { public declarations }
36 end;
37
38 var
39 FPWebModule1: TFPWebModule1;
40
41 implementation
42
43 {$R *.lfm}
44
45 { TFPWebModule1 }
46
FindNameInListnull47 function FindNameInList(const SL:TStrings; const N:String):String;
48 var
49 i : Integer;
50 begin
51 Result := '';
52 for i := 0 to SL.Count - 1 do
53 if SL.Names[i] = N then
54 begin
55 Result := SL.Values[SL.Names[i]];//return with the sessionID
56 break;
57 end;
58 end;
59
60 procedure RemoveValueIfExists(SL:TStrings; const S_ID:String);
61 var
62 s : String;
63 i : Integer;
64 begin
65 if SL.Count <= 0 then Exit;
66 s := '=' + S_ID;
67 i := 0;
68 repeat
69 if pos(s, SL[i]) > 0 then
70 SL.Delete(i)
71 else
72 inc(i);
73 until i >= SL.Count;
74 end;
75
FindValueInListnull76 function FindValueInList(const SL:TStrings; const Sess:String):String;
77 var
78 s : String;
79 i : Integer;
80 begin
81 Result := '';
82 if SL.Count <= 0 then Exit;
83 s := '=' + Sess;
84 i := 0;
85 repeat
86 if pos(s, SL[i]) > 0 then
87 begin
88 Result := SL.Names[i];
89 break;
90 end;
91 inc(i);
92 until i >= SL.Count;
93 end;
94
95 procedure RemoveNameIfExists(SL:TStrings; const N:String);
96 var
97 i: Integer;
98 begin
99 if SL.Count <= 0 then Exit;
100 i := 0;
101 repeat
102 if SL.Names[i] = N then
103 SL.Delete(i)
104 else
105 inc(i);
106 until i >= SL.Count;
107 end;
108
109 procedure TFPWebModule1.DataModuleAfterResponse(Sender: TObject;
110 AResponse: TResponse);
111 begin
112 //reset global variables for apache modules and fcgi applications for the next incoming request
113 LoggedInLoginName := '';
114 //
115 end;
116
117 procedure TFPWebModule1.DataModuleCreate(Sender: TObject);
118 begin
119 ModuleTemplate.AllowTagParams := true;
120 ModuleTemplate.StartDelimiter := '{+'; //The default is { and } which is usually not good if we use Javascript in our templates
121 ModuleTemplate.EndDelimiter := '+}';
122
123 CreateSession := true; //Turn on automatic session handling for this web module
124 MySessionDir := '';//'/Path/To/A/Directory/';{Use this if you don't want the automatic Temp dir to store the sessionID files under "fpwebsessions" sub-directory}
125 with (SessionFactory as TIniSessionFactory) do
126 begin
127 DefaultTimeoutMinutes := 2; //Session timeout in minutes
128 SessionDir := MySessionDir;
129 // SessionCookie:='ACustomCookieName'; {Use this to set the cookie name that will be used for the session management. Default is 'FPWebSession'}
130 end;
131
132 sessiondbfile := 'sessiondb.txt'; //This will contain the name=sessionID pairs to simulate the session database
133 userdbfile := 'userdb.txt'; //This simulates a user database with passwords
134 end;
135
136 procedure TFPWebModule1.loginRequest(Sender: TObject; ARequest: TRequest;
137 AResponse: TResponse; var Handled: Boolean);
138 var
139 loginname, pwd, pwd1 : String;
140 userdatabase, sessiondatabase : TStringlist;
141 begin
142 Handled := true;
143 ModuleTemplate.FileName := 'testlogin.html';
144 ModuleTemplate.OnReplaceTag := @loginReplaceTag;
145 AResponse.CustomHeaders.Add('Pragma=no-cache');//do not cache the response in the web browser so the Back key can not be used to see the pages without reloads.
146
147 if FindNameInList(ARequest.ContentFields, 'LoginName') = '' then
148 begin//called the login action without parameters -> display the login page
149 ARequest.QueryFields.Add('MSG=NORMAL');
150 AResponse.Content := ModuleTemplate.GetContent;
151 Exit;
152 end;
153
154 loginname := Trim(ARequest.ContentFields.Values['LoginName']);
155 pwd := Trim(ARequest.ContentFields.Values['Password']);
156 if (pwd = '') or (loginname = '') then
157 begin//empty login name or password -> return to the login screen
158 ARequest.QueryFields.Add('MSG=MISSING');
159 AResponse.Content := ModuleTemplate.GetContent;
160 Exit;
161 end;
162
163 //simulate a user database loaded into a stringlist
164 userdatabase := TStringlist.Create;
165 userdatabase.LoadFromFile(userdbfile);
166 pwd1 := userdatabase.Values[LoginName];//get the correct password for the LoginName if it is there
167 userdatabase.free;
168 //
169
170 if pwd <> pwd1 then
171 begin//either the password or the login name was invalid
172 ARequest.QueryFields.Add('MSG=INVLOGIN');
173 AResponse.Content := ModuleTemplate.GetContent;
174 Exit;
175 end;
176
177 //successful login
178 LoggedInLoginName := loginname;
179
180 //session starting, need to store it somewhere next to the name of the logged in person
181 sessiondatabase := TStringList.Create;
182 if FileExists(sessiondbfile) then
183 sessiondatabase.LoadFromFile(sessiondbfile); //simulating the session database access
184 if sessiondatabase.Count > 0 then
185 RemoveValueIfExists(sessiondatabase, Session.SessionID); //New login, kill all sessions with this session ID (same computer, same browser, multiple persons)
186 if FindNameInList(sessiondatabase, LoginName) <> '' then
187 sessiondatabase.Values[LoginName] := Session.SessionID //overwrite with the new session ID
188 else
189 sessiondatabase.Add(LoginName + '=' + Session.SessionID); //create a new entry for this person
190 sessiondatabase.SaveToFile(sessiondbfile); //simulating the session database update
191 sessiondatabase.Free;
192
193 //generate the Welcome page content
194 ModuleTemplate.FileName := 'testwelcome.html';
195 ModuleTemplate.OnReplaceTag := @welcomeReplaceTag;
196 AResponse.Content := ModuleTemplate.GetContent;
197 end;
198
199 procedure TFPWebModule1.loginReplaceTag(Sender: TObject; const TagString:
200 String; TagParams: TStringList; Out ReplaceText: String);
201 begin
202 {Handle tags used in multiple templates}
203 if CommonTemplateTagReplaces(TagString, TagParams, ReplaceText) then
204 Exit;
205
206 {Handle tags specific to this template if there are any}
207 if AnsiCompareText(TagString, 'MESSAGE') = 0 then
208 begin
209 ReplaceText := TagParams.Values[Request.QueryFields.Values['MSG']];
210 end else
211
212 {Message for tags not handled}
213 begin
214 ReplaceText := '[Template tag "' + TagString + '" is not implemented yet.]';
215 end;
216 end;
217
218 procedure TFPWebModule1.welcomeReplaceTag(Sender: TObject; const TagString:String;
219 TagParams: TStringList; Out ReplaceText: String);
220 begin
221 {Handle tags used in multiple templates}
222 if CommonTemplateTagReplaces(TagString, TagParams, ReplaceText) then
223 Exit;
224
225 {Handle tags specific to this template if there are any}
226
227 {Message for tags not handled}
228 begin
229 ReplaceText := '[Template tag "' + TagString + '" is not implemented yet.]';
230 end;
231 end;
232
CommonTemplateTagReplacesnull233 function TFPWebModule1.CommonTemplateTagReplaces(const TagString:String;
234 TagParams: TStringList; out ReplaceText: String):Boolean;
235 begin
236 Result := true;
237
238 if AnsiCompareText(TagString, 'DATETIME') = 0 then
239 begin
240 ReplaceText := FormatDateTime(TagParams.Values['FORMAT'], Now);
241 end else
242
243 if AnsiCompareText(TagString, 'SESSIONID') = 0 then
244 begin
245 if Assigned(Session) then
246 ReplaceText := Session.SessionID;
247 end else
248
249 if AnsiCompareText(TagString, 'MINUTESLEFT') = 0 then
250 begin
251 if Assigned(Session) then
252 ReplaceText := IntToStr(Session.TimeOutMinutes);
253 end else
254
255 if AnsiCompareText(TagString, 'SESSIONFILE') = 0 then
256 begin
257 if Assigned(Session) then
258 if MySessionDir = '' then
259 ReplaceText := IncludeTrailingPathDelimiter(GetTempDir(True)) + IncludeTrailingPathDelimiter('fpwebsessions') + Session.SessionID
260 else
261 ReplaceText := IncludeTrailingPathDelimiter(MySessionDir) + Session.SessionID;
262 {NOTE: GetTempDir
263 used by the session manager. Returns the OS temporary directory if possible, or from the
264 environment variable TEMP . For CGI programs you need to pass global environment
265 variables, it is not automatic. For example in the Apache httpd.conf with a
266 "PassEnv TEMP" or "SetEnv TEMP /pathtotmpdir" line so the web server passes this
267 global environment variable to the CGI programs' local environment variables.
268 }
269 end else
270
271 if AnsiCompareText(TagString, 'LOGINNAME') = 0 then
272 begin
273 ReplaceText := LoggedInLoginName;
274 end else
275
276 Result := false;
277 end;
278
NotLoggedInnull279 function TFPWebModule1.NotLoggedIn:Boolean;
280 var
281 sessiondatabase : TStringlist;
282 begin
283 Result := false;
284
285 //check if the current sessionID is in the sessionDB
286 sessiondatabase := TStringList.Create;
287 if FileExists(sessiondbfile) then
288 sessiondatabase.LoadFromFile(sessiondbfile);
289 LoggedInLoginName := FindValueInList(sessiondatabase, Session.sessionID);
290 sessiondatabase.Free;
291 //
292
293 if LoggedInLoginName = '' then
294 begin
295 Result := true; //not found -> not logged in or previous session has expired
296
297 //show the login screen again with the expired session message
298 ModuleTemplate.FileName := 'testlogin.html';
299 ModuleTemplate.OnReplaceTag := @loginReplaceTag;
300 Request.QueryFields.Add('MSG=SESSIONEXPIRED');
301 Response.Content := ModuleTemplate.GetContent;
302 end;
303 end;
304
305 procedure TFPWebModule1.logoutRequest(Sender: TObject; ARequest: TRequest;
306 AResponse: TResponse; var Handled: Boolean);
307 var
308 sessiondatabase : TStringList;
309 begin
310 Handled := true;
311
312 if NotLoggedIn then Exit;
313
314 //delete the sessionID and all occurences of the login name assigned to it from the sessiondb
315 sessiondatabase := TStringList.Create;
316 if FileExists(sessiondbfile) then
317 sessiondatabase.LoadFromFile(sessiondbfile);
318 if sessiondatabase.Count > 0 then
319 begin
320 RemoveValueIfExists(sessiondatabase, Session.SessionID);
321 RemoveNameIfExists(sessiondatabase, LoggedInLoginName);
322 sessiondatabase.SaveToFile(sessiondbfile);
323 end;
324 sessiondatabase.Free;
325 //
326
327 //terminate the session
328 Session.Terminate;
329
330 //Generate the response page
331 ModuleTemplate.FileName := 'testlogout.html';
332 ModuleTemplate.OnReplaceTag := @logoutReplaceTag;
333 AResponse.Content := ModuleTemplate.GetContent;//generate the Logout page content.
334 end;
335
336 procedure TFPWebModule1.logoutReplaceTag(Sender: TObject; const TagString:String;
337 TagParams: TStringList; Out ReplaceText: String);
338 begin
339 {Handle tags used in multiple templates}
340 if CommonTemplateTagReplaces(TagString, TagParams, ReplaceText) then
341 Exit;
342
343 {Handle tags specific to this template if there are any}
344
345 {Message for tags not handled}
346 begin
347 ReplaceText := '[Template tag "' + TagString + '" is not implemented yet.]';
348 end;
349 end;
350
351 procedure TFPWebModule1.someactionRequest(Sender: TObject; ARequest: TRequest;
352 AResponse: TResponse; var Handled: Boolean);
353 begin
354 Handled := true;
355
356 if NotLoggedIn then Exit;
357
358 ModuleTemplate.FileName := 'testsomepage.html';
359 ModuleTemplate.OnReplaceTag := @someactionReplaceTag;
360 AResponse.Content := ModuleTemplate.GetContent;//generate the testpage content
361 end;
362
363 procedure TFPWebModule1.someactionReplaceTag(Sender: TObject; const TagString:
364 String; TagParams: TStringList; Out ReplaceText: String);
365 begin
366 {Handle tags used in multiple templates}
367 if CommonTemplateTagReplaces(TagString, TagParams, ReplaceText) then
368 Exit;
369
370 {Handle tags specific to this template if there are any}
371
372 {Message for tags not handled}
373 begin
374 ReplaceText := '[Template tag {+' + TagString + '+} is not implemented yet.]';
375 end;
376 end;
377
378 initialization
379 RegisterHTTPModule('TFPWebModule1', TFPWebModule1);
380 end.
381
382