source: branches/DirectWeb/UCustomWebServer.pas

unit UCustomWebServer;

{$mode Delphi}{$H+}

interface

uses
  Classes, SysUtils, UHTTPServer, UHTTPSessionFile,
  UTCPServer, Contnrs,
  UCommon, syncobjs,
  UMemoryStreamEx,
  UMIMEType, Synautil, UPool,
  USqlDatabase, DOM, XMLRead, UHTMLControls, UWebServer;

const
  ConfigFileName = 'Config.xml';

type
  { TDatabasePool }

    TDatabasePool = class(TThreadedPool)
    private
      FActive: Boolean;
      procedure SetActive(const AValue: Boolean);
    public
      property Active: Boolean read FActive write SetActive;
    public
      HostName: string;
      Schema: string;
      UserName: string;
      Password: string;
      constructor Create;
      destructor Destroy; override;
    end;

    { TCustomWebServer }

  TCustomWebServer = class(TWebServer)
  private
    SessionStorage: TFileHTTPSessionStorage;
    procedure ServerInfo(HandlerData: THTTPHandlerData);
  public
    DatabasePool: TDatabasePool;

    procedure ViewList(HandlerData: THTTPHandlerData);
    procedure ViewItem(HandlerData: THTTPHandlerData);
    procedure SendIndex(HandlerData: THTTPHandlerData);
    procedure WriteHeader(Stream: TMemoryStreamEx);
    procedure WriteFooter(Stream: TMemoryStreamEx);
    procedure WriteMainMenu(Stream: TMemoryStreamEx);
    constructor Create;
    destructor Destroy; override;
    procedure LoadConfiguration;
    procedure Run;
  end;

implementation

procedure TCustomWebServer.LoadConfiguration;
var
  Config: TXMLDocument;
  I1: Integer;
  I2: Integer;
  I3: Integer;
begin
  if FileExists(ConfigFileName) then begin
    ReadXMLFile(Config, ConfigFileName);
    for I1 := 0 to Config.ChildNodes.Count - 1 do 
    with Config.ChildNodes[I1] do begin
      if NodeName = 'configuration' then
      for I2 := 0 to ChildNodes.Count - 1 do 
      with ChildNodes[I2] do begin
        if NodeName = 'database' then
        for I3 := 0 to ChildNodes.Count - 1 do 
        with ChildNodes[I3] do begin
          if NodeName = 'hostname' then
            DatabasePool.HostName := TextContent;
          if NodeName = 'schema' then
            DatabasePool.Schema := TextContent;
          if NodeName = 'username' then
            DatabasePool.UserName := TextContent;
          if NodeName = 'password' then
            DatabasePool.Password := TextContent;
        end;
        if NodeName = 'server' then
        for I3 := 0 to ChildNodes.Count - 1 do 
        with ChildNodes[I3] do begin
          if NodeName = 'address' then
            HTTPServer.Socket.Address := TextContent;
          if NodeName = 'port' then
            HTTPServer.Socket.Port := StrToInt(TextContent);
        end;
      end;
    end;
    Config.Destroy;
  end;
end;

procedure TCustomWebServer.Run;
var
  Command: string;
begin
  LoadConfiguration;
  DatabasePool.Active := True;
  WriteLn('WoW hosting web server');
  with HTTPServer do begin
    Socket.Active := True;
    WriteLn('Accepting connections.');
    repeat
      Write('Server command: ');
      ReadLn(Command);
    until Command = 'quit';
    //WaitForFinish;
  end;
end;

procedure TCustomWebServer.ViewList(HandlerData: THTTPHandlerData);
var
  SqlDatabase: TSqlDatabase;
  DbRows: TDbRows;
  I, II: integer;
  OrderColumn: string;
  OrderDirection: string;
  Title: string;
  LinkQuery: TQueryParameterList;
  PageList: TPageList;
begin
  SqlDatabase := TSqlDatabase(DatabasePool.Acquire);
  with HandlerData, Response, Stream, SqlDatabase do
  begin
    WriteHeader(Stream);

    WriteString('<div class="Page">');

    // Prepare table paging
    DbRows := Query('SELECT COUNT(*) FROM ' + Request.Query.Values['Table']);
    PageList := TPageList.Create;
    PageList.HandlerData := HandlerData;
    with PageList do begin
      TotalCount := StrToInt(DbRows[0].ValuesAtIndex[0]);
      ItemPerPage := 20;
      NavigatorVisibleItems := 5;
      Process;
    end;
    DbRows.Destroy;

    //WriteString(Request.Query.Values['Table']);
    OrderColumn    := Request.Query.Values['OrderCol'];
    OrderDirection := Request.Query.Values['OrderDir'];
    if OrderDirection = '1' then
      OrderDirection := 'ASC'
    else
      OrderDirection := 'DESC';
    DbRows := Query('SELECT * FROM ' + Request.Query.Values['Table'] +
      ' ORDER BY ' + OrderColumn + ' ' + OrderDirection + PageList.SQLLimit);

    LinkQuery := TQueryParameterList.Create;
    LinkQuery.Assign(Request.Query);

    WriteString('<strong>Seznam typů karet</strong><br/>');
    WriteString(PageList.Output);
    WriteString('<table><tr>');
    if DbRows.Count > 0 then
      for I := 0 to DbRows[0].Count - 1 do
      begin
        Title := DbRows[0].Names[I];
        LinkQuery.Values['OrderCol'] := Title;
        if Title = OrderColumn then
          LinkQuery.Values['OrderDir'] :=
            IntToStr(1 - StrToInt(Request.Query.Values['OrderDir']))
        else
          LinkQuery.Values['OrderDir'] := Request.Query.Values['OrderDir'];
        Title := '<a href="?' + LinkQuery.Syntetize + '">' + Title + '</a>';

        WriteString('<th>' + Title + '</th>');
      end;
    WriteString('</tr>');

    LinkQuery.Destroy;
    for II := 0 to DbRows.Count - 1 do
    begin
      WriteString('<tr>');
      for I := 0 to DbRows[II].Count - 1 do
        WriteString('<td>' + DbRows[II].ValuesAtIndex[I] + '</td>');
      WriteString('</tr>');
    end;
    WriteString('</table>');
    WriteString(PageList.Output);
    WriteString('</div>');

    DbRows.Destroy;
    WriteFooter(Stream);
  end;
  PageList.Destroy;
  DatabasePool.Release(SqlDatabase);
end;

procedure TCustomWebServer.ViewItem(HandlerData: THTTPHandlerData);
var
  SqlDatabase: TSqlDatabase;
  DbRows: TDbRows;
  I, II: Integer;
  OrderColumn: string;
  OrderDirection: string;
  Title: string;
  LinkQuery: TQueryParameterList;
begin
  SqlDatabase := TSqlDatabase(DatabasePool.Acquire);
  with HandlerData, Response, Stream, SqlDatabase do
  begin
    WriteHeader(Stream);
    DbRows := Query('SELECT * FROM ' + Request.Query.Values['Table'] +
      ' WHERE Id=' + Request.Query.Values['Id']);
    if DbRows.Count > 0 then begin
      WriteString('<strong>Zobrazení položky</strong>');
      WriteString('<table><tr><th>Vlastnost</th><th>Hodnota</th></tr>');
      for I := 0 to DbRows[0].Count - 1 do begin
        WriteString('<tr><td>' + DbRows[0].Names[I] + '</td><td>' +
          DbRows[0].ValuesAtIndex[I] + '</td></tr>');
      end;
    end else WriteString('Položka nenalezena.');
    WriteString('</table>');
    DbRows.Destroy;
    WriteFooter(Stream);
  end;
  DatabasePool.Release(SqlDatabase);
end;

procedure TCustomWebServer.ServerInfo(HandlerData: THTTPHandlerData);
var
  I: Integer;
begin
  with HandlerData, Response.Stream do begin
    //Response.Cookies.Values['Test'] := 'Halo';
    //Response.Cookies.Values['Test2'] := 'Halo2';

    //HTTPServer.SessionHandler.Variables.Values['Session1'] := 'Value1';
    //HTTPServer.SessionHandler.Variables.Values['Session2'] := 'Value2';

    WriteString('<a href="?ServerInfo">Refresh</a>');

    WriteString('<h5>Request HTTP headers</h5>');
    for I := 0 to Request.Headers.Count - 1 do begin;
      WriteString(Request.Headers.Strings[I] + '<br/>');
    end;

    WriteString('<h5>Request HTTP cookies</h5>');
    for I := 0 to Request.Cookies.Count - 1 do begin;
      WriteString(Request.Cookies.Strings[I] + '<br/>');
    end;

    WriteString('<h5>Session variables</h5>');
    for I := 0 to Session.Count - 1 do begin;
      WriteString(Session.Strings[I] + '<br/>');
    end;

    WriteString('<h5>Response HTTP headers</h5>');
    with Response.Stream do
    for I := 0 to Response.Headers.Count - 1 do begin;
      WriteString(Response.Headers.Strings[I] + '<br/>');
    end;
  end;
end;

procedure TCustomWebServer.SendIndex(HandlerData: THTTPHandlerData);
begin
  with HandlerData, Response, Stream do
  begin
    WriteHeader(Stream);
    WriteString('Index');
    WriteFooter(Stream);
  end;
end;

procedure TCustomWebServer.WriteHeader(Stream: TMemoryStreamEx);
begin
  with Stream do
  begin
    WriteString('<?xml version="1.0" encoding="UTF-8"?>');
    WriteString('<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">');
    WriteString('<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="cs">');
    WriteString('<head>');
    WriteString('<title>');
    WriteString('Dispečink výtahů');
    WriteString('</title>');
    WriteString('<meta http-equiv="content-type" content="application/xhtml+xml; charset=utf-8"/>');
    WriteString('<link rel="stylesheet" href="Style.css" type="text/css" media="all"/>');
    WriteString('<script type="text/javascript" src="Application/Style/Custom/Global.js">');
    WriteString('</script>');
    WriteString('<script type="text/javascript" src="Base/Style/jquery.js">');
    WriteString('</script>');
    WriteString('</head>');
    WriteString('<body>');
    WriteMainMenu(Stream);
  end;
end;

procedure TCustomWebServer.WriteFooter(Stream: TMemoryStreamEx);
begin
  with Stream do
  begin
    WriteString('</body>');
    WriteString('</html>');
  end;
end;

procedure TCustomWebServer.WriteMainMenu(Stream: TMemoryStreamEx);
var
  SqlDatabase: TSqlDatabase;
  DbRows: TDbRows;
  I, II: integer;
begin
  SqlDatabase := TSqlDatabase(DatabasePool.Acquire);
  with SqlDatabase, Stream do begin
    WriteString('<div class="MainMenu">');
    DbRows := Query('SELECT Name FROM Object');
    for I := 0 to DbRows.Count - 1 do begin
      WriteString('<span><a href="?Table=' + DbRows[I].ValuesAtIndex[0] + '&OrderCol=Id&OrderDir=0">' +
      DbRows[I].ValuesAtIndex[0] + '</span>');
    end;
    DbRows.Destroy;
    WriteString('</div>');
  end;
  DatabasePool.Release(SqlDatabase);
end;

constructor TCustomWebServer.Create;
begin
  inherited Create;
  DatabasePool := TDatabasePool.Create;
  DatabasePool.TotalCount := 20;

  SessionStorage := TFileHTTPSessionStorage.Create;
  with HTTPServer, Socket do begin
    SessionStorage := Self.SessionStorage;
    DocumentRoot := 'Data';
    with RequestHandlerList do begin
      Add('/', SendIndex);
      Add('/index.htm', SendIndex);
      Add('/index.html', SendIndex);
      Add('/logo.png', FileResponse);
      Add('/Style.css', FileResponse);
      Add('/ViewList', ViewList);
      Add('/ViewItem', ViewItem);
      Add('/ServerInfo', ServerInfo);
    end;
  end;
end;

destructor TCustomWebServer.Destroy;
begin
  DatabasePool.Destroy;
  SessionStorage.Destroy;
  inherited Destroy;
end;

{ TDatabasePool }

procedure TDatabasePool.SetActive(const AValue: Boolean);
var
  I: Integer;
begin
  if not FActive and AValue then begin
    for I := 0 to TotalCount - 1 do
    with TThreadedPoolItem(Items[I]) do begin
      Item := TSqlDatabase.Create;
      with TSqlDatabase(Item) do begin
        HostName := Self.HostName;
        UserName := Self.UserName;
        Password := Self.Password;
        Database := Self.Schema;
        Connect;
      end;
    end;
  end else
  if FActive and not AValue then begin

  end;
  FActive := AValue;
end;

constructor TDatabasePool.Create;
begin
  inherited;
end;

destructor TDatabasePool.Destroy;
begin
  inherited Destroy;
end;

end.