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

unit HTTPServer;

interface

uses
  Classes, SysUtils, Common, MemoryStreamEx, MIMEType, Synautil, Syncobjs,
  Generics.Collections, Generics;

type
  THTTPServer = class;
  EEmptyHTTPHandler = class(Exception);

  TQueryParameterList = class(TDictionaryStringString)
    procedure Parse(Text: string);
    function Syntetize: string;
  end;

  { TCookieList }

  TCookieList = class(TDictionaryStringString)
    procedure Parse(Text: string);
    function Syntetize: string;
  end;

  { THTTPRequest }

  THTTPRequest = class
    ContentType: string;
    Content: TMemoryStreamEx;
    Query: TQueryParameterList;
    Path: TListString;
    Method: string;
    Headers: TDictionaryStringString;
    Cookies: TCookieList;
    Post: TQueryParameterList;
    procedure Assign(Source: THTTPRequest);
    procedure Clear;
    constructor Create;
    destructor Destroy; override;
  end;

  { THTTPResponse }

  THTTPResponse = class
    StatusCode: string;
    ContentType: string;
    Content: TMemoryStreamEx;
    Headers: TDictionaryStringString;
    Cookies: TCookieList;
    procedure Assign(Source: THTTPResponse);
    procedure Clear;
    constructor Create;
    destructor Destroy; override;
  end;

  { THTTPHandlerData }

  THTTPHandlerData = class
    Server: THTTPServer;
    Request: THTTPRequest;
    Response: THTTPResponse;
    SessionId: string;
    Session: TStringList;
    procedure Assign(Source: THTTPHandlerData);
    constructor Create; virtual;
    destructor Destroy; override;
  end;

  TRequestEvent = procedure(HandlerData: THTTPHandlerData) of object;

  TRequestHandler = class
    Name: string;
    Handler: TRequestEvent;
  end;

  { TRequestHandlerList }

  TRequestHandlerList = class(TObjectList<TRequestHandler>)
    function AddNew(AName: string; AHandler: TRequestEvent): TRequestHandler;
    function IndexOfName(AName: string): TRequestHandler;
  end;

  { THTTPSessionStorage }

  THTTPSessionStorage = class(TComponent)
  public
    procedure Load(HandlerData: THTTPHandlerData); virtual;
    procedure Save(HandlerData: THTTPHandlerData); virtual;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

  { THTTPServer }

  THTTPServer = class(TComponent)
  private
    FDocumentRoot: string;
    FOnRequest: TRequestEvent;
    FSessionStorage: THTTPSessionStorage;
    FShowExceptions: Boolean;
    procedure SetShowExceptions(const AValue: Boolean);
  public
    Lock: TCriticalSection;
    procedure Run; virtual;
    procedure ErrorResponse(HandlerData: THTTPHandlerData);
    procedure FileResponse(HandlerData: THTTPHandlerData);
    procedure ServerInfo(HandlerData: THTTPHandlerData); virtual;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property ShowExceptions: Boolean read FShowExceptions write SetShowExceptions;
    property DocumentRoot: string read FDocumentRoot write FDocumentRoot;
    property SessionStorage: THTTPSessionStorage read FSessionStorage
      write FSessionStorage;
    property OnRequest: TRequestEvent read FOnRequest write FOnRequest;
  end;

procedure HTTPExceptionShow(Obj: TObject; Addr: Pointer; FrameCount: Longint; Frames: PPointer);
procedure HTTPExceptionHide(Obj: TObject; Addr: Pointer; FrameCount: Longint; Frames: PPointer);

resourcestring
  SEmptyHTTPHandler = 'No handler defined for HTTP server.';
  SFileNotFound = 'File %s not found.';
  SPageNotFound = 'Page %s not found.';

const
  StatusCodeNotFound = '404 Not Found';


implementation

{ THTTPServer }

procedure THTTPServer.ServerInfo(HandlerData: THTTPHandlerData);
var
  I: Integer;
  Item: TPair<string, string>;
begin
  with HandlerData, Response.Content do begin
    WriteString('<a href="?ServerInfo">Refresh</a>');

    WriteString('<h5>Request HTTP content:</h5>');
    WriteStream(Request.Content, Request.Content.Size);

    WriteString('<h5>Request HTTP headers</h5>');
    for Item in Request.Headers do begin;
      WriteString(Item.Key + ': ' + Item.Value + '<br/>');
    end;

    WriteString('<h5>Request HTTP GET</h5>');
    for Item in Request.Query do begin
      WriteString(Item.Key + ': ' + Item.Value + '<br/>');
    end;

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

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

    WriteString('<h5>Request HTTP POST</h5>');
    for Item in Request.Post do begin
      WriteString(Item.Key + ': ' + Item.Value + '<br/>');
    end;


    WriteString('<h5>Response HTTP content:</h5>');
    WriteStream(Response.Content, Response.Content.Size);

    WriteString('<h5>Response HTTP headers</h5>');
    with Response.Content do
    for Item in Response.Headers do begin
      WriteString(Item.Key + ': ' + Item.Value + '<br/>');
    end;

    WriteString('<h5>Response HTTP cookies</h5>');
    for Item in Response.Cookies do begin;
      WriteString(Item.Key + ': ' + Item.Value + '<br/>');
    end;
  end;
end;

procedure THTTPServer.ErrorResponse(HandlerData: THTTPHandlerData);
begin
  with HandlerData, Response.Content do begin
    Response.StatusCode := StatusCodeNotFound;
    WriteString('<html><body>' + Format(SPageNotFound, [Implode('/', Request.Path)]) + '</body></html>');
  end;
end;

procedure THTTPServer.SetShowExceptions(const AValue: Boolean);
begin
  FShowExceptions := AValue;
  if AValue then ExceptProc := HTTPExceptionShow
    else ExceptProc := HTTPExceptionHide;
end;

procedure THTTPServer.Run;
begin
end;

procedure THTTPServer.FileResponse(HandlerData: THTTPHandlerData);
var
  BinaryFile: TFileStream;
  FileName: string;
begin
  with HandlerData do begin
    FileName := DocumentRoot + DirectorySeparator + Implode('/', Request.Path);
    if FileExists(FileName) then begin
      Response.Headers.Items['Content-Type'] := GetMIMEType(Copy(ExtractFileExt(FileName), 2, 255));
      try
        BinaryFile := TFileStream.Create(FileName, fmOpenRead);
        Response.Content.WriteStream(BinaryFile, BinaryFile.Size);
      finally
        BinaryFile.Free;
      end;
    end else
    with Response.Content do begin
      Response.StatusCode := StatusCodeNotFound;
      WriteString('<html><body>' + Format(SFileNotFound, [Implode('/', Request.Path)]) + '</body></html>');
    end;
  end;
end;

constructor THTTPServer.Create(AOwner: TComponent);
begin
  inherited;
  Lock := TCriticalSection.Create;
  ShowExceptions := True;
  DocumentRoot := './';
end;

destructor THTTPServer.Destroy;
begin
  FreeAndNil(Lock);
  inherited;
end;

{ THTTPResponse }

procedure THTTPResponse.Assign(Source: THTTPResponse);
begin
  StatusCode := Source.StatusCode;
  Content.Assign(Source.Content);
  ContentType := Source.ContentType;
  Cookies.Assign(Source.Cookies);
  Headers.Assign(Source.Headers);
end;

procedure THTTPResponse.Clear;
begin
  Content.Clear;
  Cookies.Clear;
  Headers.Clear;
end;

constructor THTTPResponse.Create;
begin
  StatusCode := '200 OK';
  Content := TMemoryStreamEx.Create;
  Cookies := TCookieList.Create;
  Headers := TDictionaryStringString.Create;
end;

destructor THTTPResponse.Destroy;
begin
  FreeAndNil(Content);
  FreeAndNil(Headers);
  FreeAndNil(Cookies);
  inherited;
end;

{ TRequestHandlerList }

function TRequestHandlerList.AddNew(AName: string; AHandler: TRequestEvent): TRequestHandler;
begin
  Result := TRequestHandler.Create;
  Result.Name := AName;
  Result.Handler := AHandler;
  Add(Result);
end;

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

{ THTTPRequest }

procedure THTTPRequest.Assign(Source: THTTPRequest);
begin
  Content.Assign(Source.Content);
  ContentType := Source.ContentType;
  Cookies.Assign(Source.Cookies);
  Headers.Assign(Source.Headers);
  Post.Assign(Source.Post);
  Method := Source.Method;
  Query.Assign(Source.Query);
  Path.Assign(Source.Path);
end;

procedure THTTPRequest.Clear;
begin
  Post.Clear;
  Content.Clear;
  Path.Clear;
  Cookies.Clear;
  Headers.Clear;
  Query.Clear;
end;

constructor THTTPRequest.Create;
begin
  Post := TQueryParameterList.Create;
  Query := TQueryParameterList.Create;
  Path := TListString.Create;
  Headers := TDictionaryStringString.Create;
  Cookies := TCookieList.Create;
  Content := TMemoryStreamEx.Create;
end;

destructor THTTPRequest.Destroy;
begin
  FreeAndNil(Content);
  FreeAndNil(Post);
  FreeAndNil(Query);
  FreeAndNil(Path);
  FreeAndNil(Headers);
  FreeAndNil(Cookies);
  inherited;
end;

{ TQueryParameterList }

procedure TQueryParameterList.Parse(Text: string);
var
  I: Integer;
  Parts: TListString;
  Pair: TListString;
begin
  try
    Parts := TListString.Create;
    Pair := TListString.Create;
    Clear;
    Parts.Explode('&', Text);
    for I := 0 to Parts.Count - 1 do begin
      Pair.Explode('=', Parts[I]);
      if Pair.Count >= 2 then
        Add(Pair[0], Pair[1]);
    end;
  finally
    Parts.Free;
    Pair.Free;
  end;
end;

function TQueryParameterList.Syntetize: string;
var
  Item: TPair<string, string>;
begin
  Result := '';
  for Item in Self do
    Result := Result + '&amp;' + Item.Key + '=' + Item.Value;
  Result := Copy(Result, 6, Length(Result));
end;

{ TCookieList }

procedure TCookieList.Parse(Text: string);
var
  I: Integer;
  Parts: TListString;
  Pair: TListString;
begin
  try
    Parts := TListString.Create;
    Pair := TListString.Create;
    Clear;
    Parts.Explode(';', Text);
    for I := 0 to Parts.Count - 1 do begin
      Pair.Explode('=', Parts[I]);
      if Pair.Count >= 2 then
        Add(Trim(Pair[0]), Trim(Pair[1]));
    end;
  finally
    Pair.Free;
    Parts.Free;
  end;
end;

function TCookieList.Syntetize: string;
var
  Item: TPair<string, string>;
begin
  Result := '';
  for Item in Self do
    Result := Result + '; ' + Item.Key + '=' + Item.Value;
  Result := Copy(Result, 2, Length(Result));
end;

{ THTTPSessionStorage }

procedure THTTPSessionStorage.Load(HandlerData: THTTPHandlerData);
begin
end;

procedure THTTPSessionStorage.Save(HandlerData: THTTPHandlerData);
begin
end;

constructor THTTPSessionStorage.Create;
begin
  inherited;
end;

destructor THTTPSessionStorage.Destroy;
begin
  inherited;
end;

{ THTTPHandlerData }

procedure THTTPHandlerData.Assign(Source: THTTPHandlerData);
begin
  Request.Assign(Source.Request);
  Response.Assign(Source.Response);
  Session.Assign(Source.Session);
  Server := Source.Server;
  SessionId := Source.SessionId;
end;

constructor THTTPHandlerData.Create;
begin
  Request := THTTPRequest.Create;
  Response := THTTPResponse.Create;
  Session := TStringList.Create;
end;

destructor THTTPHandlerData.Destroy;
begin
  FreeAndNil(Request);
  FreeAndNil(Response);
  FreeAndNil(Session);
  inherited;
end;

procedure HTTPExceptionShow(Obj: TObject; Addr: Pointer; FrameCount: Longint; Frames: PPointer);
type
  TArrayOfPointer = array of Pointer;
var
  Message: string;
  I: LongInt;
  hstdout: ^Text;
begin
  hstdout := @stdout;
  WriteLn(hstdout^, 'Content-type: text/html');
  WriteLn(hstdout^);
  Writeln(hstdout^, 'An unhandled exception occurred at $', HexStr(PtrUInt(Addr), SizeOf(PtrUInt) * 2), ' :<br/>');
  if Obj is exception then
   begin
     Message := Exception(Obj).ClassName + ' : ' + Exception(Obj).Message;
     Writeln(hstdout^, Message + '<br/>');
   end
  else
    WriteLn(hstdout^, 'Exception object ', Obj.ClassName, ' is not of class Exception.<br/>');
  WriteLn(hstdout^, BackTraceStrFunc(Addr) + '<br/>');
  if (FrameCount > 0) then
    begin
      for I := 0 to FrameCount - 1 do
        if I < Length(TArrayOfPointer(Frames)) then
          WriteLn(hstdout^, BackTraceStrFunc(TArrayOfPointer(Frames)[I]) + '<br/>');
    end;
  WriteLn(hstdout^, '');
end;

procedure HTTPExceptionHide(Obj: TObject; Addr: Pointer; FrameCount: Longint; Frames: PPointer);
type
  TArrayOfPointer = array of Pointer;
var
  Message: string;
  I: LongInt;
  hstdout: ^Text;
  hstderr: ^Text;
begin
  hstdout := @stdout;
  hstderr := @stderr;
  WriteLn(hstdout^, 'Content-type: text/html');
  WriteLn(hstdout^);
  WriteLn(hstdout^, 'Error occured during page generation.');
  WriteLn(hstderr^, 'An unhandled exception occurred at $', HexStr(PtrUInt(Addr), SizeOf(PtrUInt) * 2), ' :');
  if Obj is exception then
   begin
     Message := Exception(Obj).ClassName + ' : ' + Exception(Obj).Message;
     WriteLn(hstderr^, Message);
   end
  else
    WriteLn(hstderr^, 'Exception object ', Obj.ClassName, ' is not of class Exception.');
  WriteLn(hstderr^, BackTraceStrFunc(Addr));
  if (FrameCount > 0) then
    begin
      for I := 0 to FrameCount - 1 do
        if I < Length(TArrayOfPointer(Frames)) then
          WriteLn(hstderr^, BackTraceStrFunc(TArrayOfPointer(Frames)[I]));
    end;
  WriteLn(hstderr^, '');
end;

end.