Changeset 78 for trunk/Modules

Timestamp:

Jun 18, 2012, 10:44:21 PM (12 years ago)

Author:

chronos

Message:

• Upraveno: Obsluha stránek rozdělena do samostatných sezení(TWebSession). Každé sezení si tak alokuje vlastní instanci TSqlDatabase. Zároveň při obsluze jednoduchých souborů se nyní již nenačítá info o přihlášeném uživateli a nevytváří se tak pro každé načítání souboru instance databázového připojení.

Location:

trunk/Modules

Files:

• UMainModule.lfm (modified) (1 diff)
• UMainModule.lrs (modified) (1 diff)
• UMainModule.pas (modified) (14 diffs)

trunk/Modules/UMainModule.lfm

@@ -2 +2 @@
   OldCreateOrder = False
   Height = 278
-  HorizontalOffset = 418
-  VerticalOffset = 205
+  HorizontalOffset = 554
+  VerticalOffset = 266
   Width = 431
-  object HTTPSessionStorageMySQL1: THTTPSessionStorageMySQL
-    Database = Database
-    Timeout = 10800
-    SessionIdCookieName = 'SessionId'
-    left = 304
-    top = 32
-  end
-  object Database: TSqlDatabase
-    Connected = False
-    Port = 3306
-    Encoding = 'utf8'
-    left = 81
-    top = 86
-  end
   object WebApp1: TWebApp
     OnPageProduce = WebApp1PageProduce
-    ServerType = stTCP
+    ServerType = stCGI
     left = 160
     top = 88

trunk/Modules/UMainModule.lrs

@@ -3 +3 @@
 LazarusResources.Add('TMainModule','FORMDATA',[
   'TPF0'#11'TMainModule'#10'MainModule'#14'OldCreateOrder'#8#6'Height'#3#22#1#16
-  +'HorizontalOffset'#3#162#1#14'VerticalOffset'#3#205#0#5'Width'#3#175#1#0#24
-  +'THTTPSessionStorageMySQL'#24'HTTPSessionStorageMySQL1'#8'Database'#7#8'Data'
-  +'base'#7'Timeout'#3'0*'#19'SessionIdCookieName'#6#9'SessionId'#4'left'#3'0'#1
-  +#3'top'#2' '#0#0#12'TSqlDatabase'#8'Database'#9'Connected'#8#4'Port'#3#234#12
-  +#8'Encoding'#6#4'utf8'#4'left'#2'Q'#3'top'#2'V'#0#0#7'TWebApp'#7'WebApp1'#13
-  +'OnPageProduce'#7#18'WebApp1PageProduce'#10'ServerType'#7#5'stTCP'#4'left'#3
-  +#160#0#3'top'#2'X'#0#0#0
+  +'HorizontalOffset'#3'*'#2#14'VerticalOffset'#3#10#1#5'Width'#3#175#1#0#7'TWe'
+  +'bApp'#7'WebApp1'#13'OnPageProduce'#7#18'WebApp1PageProduce'#10'ServerType'#7
+  +#5'stCGI'#4'left'#3#160#0#3'top'#2'X'#0#0#0
 ]);

trunk/Modules/UMainModule.pas

@@ -15 +15 @@
 
 type
-  TSession = class
-
+  TMainModule = class;
+
+  { TWebSession }
+
+  TWebSession = class(THTTPHandlerData)
+  private
+    procedure TopMenu;
+    procedure Footer;
+  public
+    MainModule: TMainModule;
+    Database: TSqlDatabase;
+    SessionStorage: THTTPSessionStorageMySQL;
+    User: TWebUser;
+    UserOnline: TWebOnlineUser;
+    HtmlDocument: THtmlDocument;
+    GlobalTitle: string;
+    TimeStart: TDateTime;
+    procedure LoadUserInfo;
+    procedure InitDatabase;
+    procedure GeneratePage(Page: TWebPage);
+    constructor Create; override;
+    destructor Destroy; override;
   end;
 
@@ -22 +42 @@
 
   TMainModule = class(TDataModule)
-    HTTPSessionStorageMySQL1: THTTPSessionStorageMySQL;
-    Database: TSqlDatabase;
     WebApp1: TWebApp;
     procedure WebApp1PageProduce(HandlerData: THTTPHandlerData);
   private
-    procedure Footer;
-    procedure InitDatabase;
     procedure Show(Content: string);
-    procedure TopMenu;
   public
-    TimeStart: TDateTime;
     Load: string;
     Unload: string;
-    GlobalTitle: string;
     ShowRuntimeInfo: Boolean;
     Charset: string;
     Admin: string;
     AdminEmail: string;
+    Keywords: string;
     Style: string;
-    Keywords: string;
-    HtmlDocument: THtmlDocument;
     BaseURL: string;
-    User: TWebUser;
-    UserOnline: TWebOnlineUser;
     FormatHTML: Boolean;
     NetworkAddress: string;
@@ -51 +61 @@
     MaxConnections: Integer;
     Pages: TPageList;
-    procedure LoadUserInfo(HandlerData: THTTPHandlerData);
+    DatabaseHostname: string;
+    DatabaseUserName: string;
+    DatabasePassword: string;
+    DatabaseSchema: string;
     procedure LoadFromRegistry;
     procedure SaveToRegistry;
-    procedure GeneratePage(HandlerData: THTTPHandlerData; Page: TWebPage);
     procedure Run;
     constructor Create(AOwner: TComponent); override;
@@ -71 +83 @@
   UNetworkPage, UAboutPage, UContactPage;
 
-{ TMainModule }
-
-procedure TMainModule.GeneratePage(HandlerData: THTTPHandlerData; Page: TWebPage);
+{ TWebSession }
+
+constructor TWebSession.Create;
+begin
+  inherited;
+  Database := TSqlDatabase.Create(nil);
+  SessionStorage := THTTPSessionStorageMySQL.Create(nil);
+  SessionStorage.Database := Database;
+  HtmlDocument := THtmlDocument.Create;
+  User := TWebUser.Create;
+  User.Database := Database;
+  UserOnline := TWebOnlineUser.Create;
+  UserOnline.Database := Database;
+end;
+
+destructor TWebSession.Destroy;
+begin
+  HtmlDocument.Free;
+  User.Free;
+  UserOnline.Free;
+  SessionStorage.Free;
+  Database.Free;
+  inherited Destroy;
+end;
+
+procedure TWebSession.InitDatabase;
+var
+  DbRows: TDbRows;
+begin
+  with Database do begin
+    Connect;
+  end;
+  try
+    DbRows := TDbRows.Create;
+    Database.Query(DbRows, 'SET NAMES utf8');
+  finally
+    DbRows.Free;
+  end;
+end;
+
+procedure TWebSession.LoadUserInfo;
+begin
+  User.HandlerData := Self;
+  UserOnline.HandlerData := Self;
+  UserOnline.Update;
+  User.Id := UserOnline.User;
+  User.Load;
+end;
+
+procedure TWebSession.GeneratePage(Page: TWebPage);
 var
   I: Integer;
   TitleTag: THtmlString;
 begin
-  with HandlerData do begin
     HtmlDocument.ContentLanguage := 'cs';
     GlobalTitle := 'ZděchovNET';
-    HtmlDocument.Styles.Add(NavigationLink('/Style/' + Style + '/Style.css'));
-    HtmlDocument.Scripts.Add(NavigationLink('/Style/' + Style + '/Global.js'));
-    HtmlDocument.Scripts.Add(NavigationLink('/Style/' + Style + '/jquery.js'));
+    HtmlDocument.Styles.Add(NavigationLink('/Style/' + MainModule.Style + '/Style.css'));
+    HtmlDocument.Scripts.Add(NavigationLink('/Style/' + MainModule.Style + '/Global.js'));
+    HtmlDocument.Scripts.Add(NavigationLink('/Style/' + MainModule.Style + '/jquery.js'));
 
       TitleTag := THtmlString.Create;
@@ -95 +153 @@
       with HtmlDocument.AsXmlDocument do
       try
-        Formated := FormatHTML;
+        Formated := MainModule.FormatHTML;
         Response.Content.WriteString(AsString);
       finally
         Free;
       end;
-  end;
-end;
-
-procedure TMainModule.InitDatabase;
-var
-  DbRows: TDbRows;
-begin
-  with Database do begin
-    Connect;
-  end;
-  try
-    DbRows := TDbRows.Create;
-    Database.Query(DbRows, 'SET NAMES utf8');
-  finally
-    DbRows.Free;
-  end;
-end;
+end;
+
+
+{ TMainModule }
 
 constructor TMainModule.Create(AOwner: TComponent);
@@ -122 +167 @@
   inherited;
   Pages := TPageList.Create;
-  HtmlDocument := THtmlDocument.Create;
-  User := TWebUser.Create;
-  User.Database := Database;
-  UserOnline := TWebOnlineUser.Create;
-  UserOnline.Database := Database;
   LoadFromRegistry;
   with Pages do begin
@@ -156 +196 @@
 begin
   //SaveToRegistry;
-  HtmlDocument.Free;
-  User.Free;
-  UserOnline.Free;
   Pages.Free;
   inherited Destroy;
 end;
 
-procedure TMainModule.Footer;
+procedure TWebSession.Footer;
 var
   Tag: TXMLTag;
@@ -178 +215 @@
       Name := 'li';
       with TXmlString(SubElements.AddNew(TXmlString.Create)) do begin
-        Text := Admin;
+        Text := MainModule.Admin;
       end;
     end;
@@ -184 +221 @@
       Name := 'li';
       with TXmlString(SubElements.AddNew(TXmlString.Create)) do begin
-        Text := AdminEmail;
-      end;
-    end;
-    if ShowRuntimeInfo then begin
+        Text := MainModule.AdminEmail;
+      end;
+    end;
+    if MainModule.ShowRuntimeInfo then begin
       with TXmlTag(SubElements.AddNew(TXmlTag.Create)) do begin
         Name := 'li';
@@ -232 +269 @@
 end;
 
-procedure TMainModule.TopMenu;
+procedure TWebSession.TopMenu;
 begin
   with THtmlString(HtmlDocument.Body.SubItems.InsertNew(1, THtmlString.Create)) do begin
@@ -269 +306 @@
 end;
 
-procedure TMainModule.LoadUserInfo(HandlerData: THTTPHandlerData);
-begin
-  User.HandlerData := HandlerData;
-  UserOnline.HandlerData := HandlerData;
-  UserOnline.Update;
-  User.Id := UserOnline.User;
-  User.Load;
-end;
-
 procedure TMainModule.WebApp1PageProduce(HandlerData: THTTPHandlerData);
 var
   FileName: string;
+  PageName: string;
+  Page: TRegistredPage;
+  NewSession: TWebSession;
+  BaseUrlParts: TListString;
 begin
   with HandlerData do begin
-    if not Pages.ProducePage(HandlerData) then begin
+    try
+      BaseUrlParts := TListString.Create;
+      BaseUrlParts.Explode(BaseURL, '/', StrToStr);
+      while (BaseUrlParts.Count > 0) and (Request.Path.Count > 0) and
+         (BaseUrlParts[0] = Request.Path[0]) do begin
+           BaseUrlParts.Delete(0);
+           Request.Path.Delete(0);
+         end;
+    finally
+      BaseUrlParts.Free;
+    end;
+    if Request.Path.Count > 0 then PageName := Request.Path[0]
+      else PageName := '';
+    Page := Pages.FindByName(PageName);
+    if Assigned(Page) then begin
+      NewSession := TWebSession.Create;
+      NewSession.MainModule := Self;
+      NewSession.Assign(HandlerData);
+      NewSession.TimeStart := Now;
+      NewSession.Database.HostName := DatabaseHostName;
+      NewSession.Database.Password := DatabasePassword;
+      NewSession.Database.Database := DatabaseSchema;
+      NewSession.Database.UserName := DatabaseUserName;
+      NewSession.InitDatabase;
+      Page.Page.OnProduce(NewSession);
+      HandlerData.Assign(NewSession);
+    end else begin
       WebApp1.HTTPServer.FileResponse(HandlerData)
     end;
@@ -301 +359 @@
     Style := ReadString(SectionGeneral, 'Style', 'Basic');
     BaseURL := ReadString(SectionGeneral, 'BaseURL', 'http://localhost');
-    Database.Hostname := ReadString(SectionDatabase, 'DatabaseHostName', 'localhost');
-    Database.Database := ReadString(SectionDatabase, 'DatabaseDatabase', 'web');
-    Database.UserName := ReadString(SectionDatabase, 'DatabaseUserName', 'user');
-    Database.Password := ReadString(SectionDatabase, 'DatabasePassword', 'password');
+    DatabaseHostname := ReadString(SectionDatabase, 'DatabaseHostName', 'localhost');
+    DatabaseSchema := ReadString(SectionDatabase, 'DatabaseDatabase', 'web');
+    DatabaseUserName := ReadString(SectionDatabase, 'DatabaseUserName', 'user');
+    DatabasePassword := ReadString(SectionDatabase, 'DatabasePassword', 'password');
     FormatHTML := ReadBool(SectionGeneral, 'FormatHTML', False);
     //MainModule.WebApp1.LogException := not ReadBool(SectionGeneral, 'ShowException', False);
@@ -327 +385 @@
     WriteString(SectionGeneral, 'Style', Style);
     WriteString(SectionGeneral, 'BaseURL', BaseURL);
-    WriteString(SectionDatabase, 'DatabaseHostName', Database.Hostname);
-    WriteString(SectionDatabase, 'DatabaseDatabase', Database.Database);
-    WriteString(SectionDatabase, 'DatabaseUserName', Database.UserName);
-    WriteString(SectionDatabase, 'DatabasePassword', Database.Password);
+    WriteString(SectionDatabase, 'DatabaseHostName', DatabaseHostname);
+    WriteString(SectionDatabase, 'DatabaseDatabase', DatabaseSchema);
+    WriteString(SectionDatabase, 'DatabaseUserName', DatabaseUserName);
+    WriteString(SectionDatabase, 'DatabasePassword', DatabasePassword);
     WriteBool(SectionGeneral, 'FormatHTML', FormatHTML);
     //WriteBool(SectionGeneral, 'ShowException', not MainModule.WebApp1.LogException);
@@ -343 +401 @@
 procedure TMainModule.Run;
 begin
-  InitDatabase;
-  //Database.Query('SELECT * FROM ssss');
-
+  WebApp1.HTTPServer.DocumentRoot := ExtractFileDir(ParamStrUTF8(0));
   WebApp1.Run;
 end;