source: trunk/Packages/CoolWeb/WebServer/WebApp.pas

unit WebApp;

interface

uses
  Classes, SysUtils, WebPage, HTTPSessionFile, HTTPServer, Forms, FileUtil,
  Generics.Collections;

type
  THTTPServerType = (stCGI, stTCP, stTurboPower);

  { TRegistredPage }

  TRegistredPage = class
    Name: string;
    Page: TWebPage;
    destructor Destroy; override;
  end;

  { TPageList }

  TPageList = class(TObjectList<TRegistredPage>)
    RootDir: string;
    function FindByPage(Page: TWebPage): TRegistredPage;
    function FindByName(Name: string): TRegistredPage;
    procedure RegisterPage(Page: TWebPage; Path: string);
    procedure UnregisterPage(Page: TWebPage);
    function ProducePage(HandlerData: THTTPHandlerData): Boolean;
    constructor Create(FreeObjects: Boolean = True);
  end;

  { TWebApp }

  TWebApp = class(TComponent)
  private
    FOnPageProduce: TOnProduceEvent;
    FOnInitialize: TNotifyEvent;
    FServerType: THTTPServerType;
    function DumpExceptionCallStack(E: Exception): string;
    procedure HTTPServerRequest(HandlerData: THTTPHandlerData);
    procedure SetServerType(AValue: THTTPServerType);
  public
    HTTPServer: THTTPServer;
    HTTPSessionStorageFile: THTTPSessionStorageFile;
    LogException: Boolean;
    procedure ShowException(E: Exception);
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Run;
  published
    property OnPageProduce: TOnProduceEvent read FOnPageProduce write FOnPageProduce;
    property OnInitialize: TNotifyEvent read FOnInitialize write FOnInitialize;
    property ServerType: THTTPServerType read FServerType write SetServerType;
  end;


procedure Register;

implementation

uses
  HTTPServerCGI, HTTPServerTCP, HTTPServerTurboPower;

procedure Register;
begin
  RegisterComponents('CoolWeb', [TWebApp]);
end;

{ TRegistredPage }

destructor TRegistredPage.Destroy;
begin
  if Assigned(Page) then FreeAndNil(Page);
end;

{ TPageList }

function TPageList.FindByPage(Page: TWebPage): TRegistredPage;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (Items[I].Page <> Page) do Inc(I);
  if I < Count then Result := Items[I]
    else Result := nil;
end;

function TPageList.FindByName(Name: string): TRegistredPage;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (Items[I].Name <> Name) do Inc(I);
  if I < Count then Result := Items[I]
    else Result := nil;
end;

{ TWebApp }

procedure TWebApp.Run;
begin
  if Assigned(FOnInitialize) then FOnInitialize(Self);
  HTTPServer.Run;
  if (ServerType = stCGI) or (ServerType = stTCP) then
    Application.Terminate;
end;

function TWebApp.DumpExceptionCallStack(E: Exception): string;
var
  I: Integer;
  Frames: PPointer;
  Report: string;
begin
  Report := 'Program exception! ' + LineEnding +
    'Stacktrace:' + LineEnding + LineEnding;
  if E <> nil then begin
    Report := Report + 'Exception class: ' + E.ClassName + LineEnding +
    'Message: ' + E.Message + LineEnding;
  end;
  Report := Report + BackTraceStrFunc(ExceptAddr);
  Frames := ExceptFrames;
  for I := 0 to ExceptFrameCount - 1 do
    Report := Report + LineEnding + BackTraceStrFunc(PointerArray(Frames)[I]);
  Result := Report;
end;

procedure TPageList.RegisterPage(Page: TWebPage; Path: string);
var
  NewPage: TRegistredPage;
begin
  NewPage := TRegistredPage.Create;
//  NewPage.Page := PageClass.Create(Self);
  NewPage.Page := Page;
  NewPage.Name := Path;
  Add(NewPage);
end;

procedure TPageList.UnregisterPage(Page: TWebPage);
var
  RegPage: TRegistredPage;
begin
  RegPage := FindByPage(Page);
  Remove(RegPage);
end;

function TPageList.ProducePage(HandlerData: THTTPHandlerData): Boolean;
var
  Page: TRegistredPage;
  PageName: string;
begin
  with HandlerData do begin
    if Request.Path.Count > 0 then PageName := Request.Path[0]
      else PageName := '';
    Page := FindByName(PageName);
    if Assigned(Page) then begin
      Page.Page.OnProduce(HandlerData);
      Result := True;
    end else Result := False;
  end;
end;

constructor TPageList.Create;
begin
  inherited;
  FreeObjects := False;
end;

procedure TWebApp.HTTPServerRequest(HandlerData: THTTPHandlerData);
begin
  if Assigned(FOnPageProduce) then
    FOnPageProduce(HandlerData);
end;

procedure TWebApp.SetServerType(AValue: THTTPServerType);
begin
  if FServerType = AValue then Exit;
  FServerType := AValue;
  HTTPServer.Free;
  case FServerType of
    stCGI: HTTPServer := THTTPServerCGI.Create(nil);
    stTCP: HTTPServer := THTTPServerTCP.Create(nil);
    stTurboPower: HTTPServer := THTTPServerTurboPower.Create(nil);
  end;
  HTTPServer.OnRequest := HTTPServerRequest;
end;

procedure TWebApp.ShowException(E: Exception);
var
  hstdout: ^Text;
begin
  if not LogException then begin
    hstdout := @stdout;
    WriteLn(hstdout^, 'Content-type: text/html');
    WriteLn(hstdout^);
    Writeln(hstdout^, 'An unhandled exception occurred: ' + E.Message + '<br>');
    WriteLn(hstdout^, StringReplace(DumpExceptionCallStack(E), LineEnding, '<br>', [rfReplaceAll]));
  end else begin
    hstdout := @stdout;
    WriteLn(hstdout^, 'Content-type: text/html');
    WriteLn(hstdout^);
    WriteLn(hstdout^, 'Error occured during page generation.');
    hstdout := @stderr;
    Writeln(hstdout^, 'An unhandled exception occurred: ' + E.Message + '<br>');
    WriteLn(hstdout^, DumpExceptionCallStack(E));
  end;
end;

constructor TWebApp.Create(AOwner: TComponent);
begin
  inherited;
  HTTPServer := THTTPServerCGI.Create(nil);
  HTTPServer.OnRequest := HTTPServerRequest;
end;

destructor TWebApp.Destroy;
begin
  FreeAndNil(HTTPServer);
  inherited;
end;

end.