
{*******************************************************}
{                                                       }
{       Borland Delphi Visual Component Library         }
{       Web server application components               }
{                                                       }
{       Copyright (c) 1997,98 Inprise Corporation       }
{                                                       }
{*******************************************************}

unit HTTPApp;

interface

uses SyncObjs, SysUtils, Classes, Forms, Masks;

const
  sDateFormat = '"%s", dd "%s" yyyy hh:mm:ss';

  MAX_STRINGS = 12;
  MAX_INTEGERS = 1;
  MAX_DATETIMES = 3;

type
  TMethodType = (mtAny, mtGet, mtPut, mtPost, mtHead);

{ Forward declaration }

  TWebResponse = class;

{ TWebRequest }

  TWebRequest = class(TObject)
  protected
    function GetStringVariable(Index: Integer): string; virtual; abstract;
    function GetDateVariable(Index: Integer): TDateTime; virtual; abstract;
    function GetIntegerVariable(Index: Integer): Integer; virtual; abstract;
  public
    constructor Create;
    destructor Destroy; override;
    // Read count bytes from client
    function ReadClient(var Buffer; Count: Integer): Integer; virtual; abstract;
    // Read count characters as a string from client
    function ReadString(Count: Integer): string; virtual; abstract;
    // Translate a relative URI to a local absolute path
    function TranslateURI(const URI: string): string; virtual; abstract;
    // Write count bytes back to client
    function WriteClient(var Buffer; Count: Integer): Integer; virtual; abstract;
    // Write string contents back to client
    function WriteString(const AString: string): Boolean; virtual; abstract;
    // Utility to extract fields from a given string buffer
    procedure ExtractFields(Separators, WhiteSpace: TSysCharSet;
      Content: PChar; Strings: TStrings);
    // Fills the given string list with the content fields as the result
    // of a POST method
    procedure ExtractContentFields(Strings: TStrings);
    // Fills the given string list with values from the cookie header field
    procedure ExtractCookieFields(Strings: TStrings);
    // Fills the given TStrings with the values from the Query data
    // (ie: data following the "?" in the URL)
    procedure ExtractQueryFields(Strings: TStrings);
    // Read an arbitrary HTTP/Server Field not lists here
    function GetFieldByName(const Name: string): string; virtual; abstract;
    // The request method as an enumeration
    property MethodType: TMethodType;
    // Field lists
    property ContentFields: TStrings;
    property CookieFields: TStrings;
    property QueryFields: TStrings;
    // HTTP header Fields
    property Method: string index 0;
    property ProtocolVersion: string index 1;
    property URL: string index 2;
    property Query: string index 3;
    property PathInfo: string index 4;
    property PathTranslated: string index 5;
    property Authorization: string index 28;
    property CacheControl: string index 6;
    property Cookie: string index 27;
    property Date: TDateTime index 7;
    property Accept: string index 8;
    property From: string index 9;
    property Host: string index 10;
    property IfModifiedSince: TDateTime index 11;
    property Referer: string index 12;
    property UserAgent: string index 13;
    property ContentEncoding: string index 14;
    property ContentType: string index 15;
    property ContentLength: Integer index 16;
    property ContentVersion: string index 17;
    property Content: string index 25;
    property Connection: string index 26;
    property DerivedFrom: string index 18;
    property Expires: TDateTime index 19;
    property Title: string index 20;
    property RemoteAddr: string index 21;
    property RemoteHost: string index 22;
    property ScriptName: string index 23;
    property ServerPort: Integer index 24;
  end;

{ TCookie }

  TCookie = class(TCollectionItem)
  protected
    function GetHeaderValue: string;
  public
    constructor Create(Collection: TCollection); override;
    procedure AssignTo(Dest: TPersistent); override;
    property Name: string;
    property Value: string;
    property Domain: string;
    property Path: string;
    property Expires: TDateTime;
    property Secure: Boolean;
    property HeaderValue: string;
  end;

{ TCookieCollection }

  TCookieCollection = class(TCollection)
  protected
    function GetCookie(Index: Integer): TCookie;
    procedure SetCookie(Index: Integer; Cookie: TCookie);
  public
    constructor Create(WebResponse: TWebResponse; ItemClass: TCollectionItemClass);
    function  Add: TCookie;
    property WebResponse: TWebResponse;
    property Items[Index: Integer]: TCookie; default;
  end;

{ TWebResponse }

  TWebResponse = class(TObject)
  protected
    FHTTPRequest: TWebRequest;
    procedure AddCustomHeaders(var Headers: string);
    function GetStringVariable(Index: Integer): string; virtual; abstract;
    procedure SetStringVariable(Index: Integer; const Value: string); virtual; abstract;
    function GetDateVariable(Index: Integer): TDateTime; virtual; abstract;
    procedure SetDateVariable(Index: Integer; const Value: TDateTime); virtual; abstract;
    function GetIntegerVariable(Index: Integer): Integer; virtual; abstract;
    procedure SetIntegerVariable(Index: Integer; Value: Integer); virtual; abstract;
    function GetContent: string; virtual; abstract;
    procedure SetContent(const Value: string); virtual; abstract;
    procedure SetContentStream(Value: TStream); virtual;
    function GetStatusCode: Integer; virtual; abstract;
    procedure SetStatusCode(Value: Integer); virtual; abstract;
    function GetLogMessage: string; virtual; abstract;
    procedure SetLogMessage(const Value: string); virtual; abstract;
  public
    constructor Create(HTTPRequest: TWebRequest);
    destructor Destroy; override;
    function GetCustomHeader(const Name: string): String;
    procedure SendResponse; virtual; abstract;
    procedure SendRedirect(const URI: string); virtual; abstract;
    procedure SendStream(AStream: TStream); virtual; abstract;
    function Sent: Boolean; virtual;
    procedure SetCookieField(Values: TStrings; const ADomain, APath: string;
      AExpires: TDateTime; ASecure: Boolean);
    procedure SetCustomHeader(const Name, Value: string);
    property Cookies: TCookieCollection;
    property HTTPRequest: TWebRequest;
    property Version: string index 0;
    property ReasonString: string index 1;
    property Server: string index 2;
    property WWWAuthenticate: string index 3;
    property Realm: string index 4;
    property Allow: string index 5;
    property Location: string index 6;
    property ContentEncoding: string index 7;
    property ContentType: string index 8;
    property ContentVersion: string index 9;
    property DerivedFrom: string index 10;
    property Title: string index 11;

    property StatusCode: Integer;
    property ContentLength: Integer index 0;

    property Date: TDateTime index 0;
    property Expires: TDateTime index 1;
    property LastModified: TDateTime index 2;

    property Content: string;
    property ContentStream: TStream;

    property LogMessage: string;

    property CustomHeaders: TStrings;
  end;

{ TWebDispatcherEditor }

  TCustomWebDispatcher = class;
  TCustomContentProducer = class;

{ THTMLTagAttributes }

  THTMLAlign = (haDefault, haLeft, haRight, haCenter);
  THTMLVAlign = (haVDefault, haTop, haMiddle, haBottom, haBaseline);
  THTMLBgColor = type string;

  THTMLTagAttributes = class(TPersistent)
  protected
    procedure Changed;
  public
    constructor Create(Producer: TCustomContentProducer);
    procedure RestoreDefaults; virtual;
    property Producer: TCustomContentProducer;
    property OnChange: TNotifyEvent;
  published
    property Custom: string;
  end;

  THTMLTableAttributes = class(THTMLTagAttributes)
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create(Producer: TCustomContentProducer);
    procedure RestoreDefaults; override;
  published
    property Align: THTMLAlign default haDefault;
    property BgColor: THTMLBgColor;
    property Border: Integer default -1;
    property CellSpacing: Integer default -1;
    property CellPadding: Integer default -1;
    property Width: Integer default 100;
  end;

  THTMLTableElementAttributes = class(THTMLTagAttributes)
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public  
    procedure RestoreDefaults; override;
  published
    property Align: THTMLAlign default haDefault;
    property BgColor: THTMLBgColor;
    property VAlign: THTMLVAlign default haVDefault;
  end;

  THTMLTableHeaderAttributes = class(THTMLTableElementAttributes)
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    procedure RestoreDefaults; override;
  published
    property Caption: string;
  end;

  THTMLTableRowAttributes = class(THTMLTableElementAttributes);
  THTMLTableCellAttributes = class(THTMLTableElementAttributes);

{ TCustomContentProducer }

  TCustomContentProducer = class(TComponent)
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    function Content: string; virtual;
    function ContentFromStream(Stream: TStream): string; virtual;
    function ContentFromString(const S: string): string; virtual;
  published
    property Dispatcher: TCustomWebDispatcher;
  end;

{ TCustomHTTPPageProducer }

  TCustomPageProducer = class(TCustomContentProducer)
  protected
    function HandleTag(const TagString: string; TagParams: TStrings): string; virtual;
    property HTMLDoc: TStrings;
    property HTMLFile: TFileName;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Content: string; override;
    function ContentFromStream(Stream: TStream): string; override;
    function ContentFromString(const S: string): string; override;
  end;

{ TPageProducer }

  TTag = (tgCustom, tgLink, tgImage, tgTable, tgImageMap, tgObject, tgEmbed);

  THTMLTagEvent = procedure (Sender: TObject; Tag: TTag; const TagString: string;
    TagParams: TStrings; var ReplaceText: string) of object;

  TPageProducer = class(TCustomPageProducer)
  protected
    function HandleTag(const TagString: string; TagParams: TStrings): string; override;
    procedure DoTagEvent(Tag: TTag; const TagString: string; TagParams: TStrings;
      var ReplaceText: string); dynamic;
  published
    property HTMLDoc;
    property HTMLFile;
    property OnHTMLTag: THTMLTagEvent;
  end;

{ TWebActionItem }

  THTTPMethodEvent = procedure (Sender: TObject; Request: TWebRequest;
    Response: TWebResponse; var Handled: Boolean) of object;

  TWebActionItem = class(TCollectionItem)
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure AssignTo(Dest: TPersistent); override;
  published
    property Default: Boolean default False;
    property Enabled: Boolean default True;
    property MethodType: TMethodType default mtAny;
    property Name: string;
    property PathInfo: string;
    property OnAction: THTTPMethodEvent;
  end;

{ TWebActionItems }

  TWebActionItems = class(TCollection)
  protected
    function GetAttrCount: Integer; override;
    function GetAttr(Index: Integer): string; override;
    function GetItemAttr(Index, ItemIndex: Integer): string; override;
    function GetOwner: TPersistent; override;
    procedure SetItemName(Item: TCollectionItem); override;
    procedure Update(Item: TCollectionItem); override;
  public
    constructor Create(WebDispatcher: TCustomWebDispatcher;
      ItemClass: TCollectionItemClass);
    function  Add: TWebActionItem;
    property WebDispatcher: TCustomWebDispatcher;
    property Items[Index: Integer]: TWebActionItem; default;
  end;

{ TCustomWebDispatcher }

  TCustomWebDispatcher = class(TDataModule)
  protected
    function DoAfterDispatch(Request: TWebRequest; Response: TWebResponse): Boolean;
    function DoBeforeDispatch(Request: TWebRequest; Response: TWebResponse): Boolean;
    function DispatchAction(Request: TWebRequest;
      Response: TWebResponse): Boolean;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    property BeforeDispatch: THTTPMethodEvent;
    property AfterDispatch: THTTPMethodEvent;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function ActionByName(const AName: string): TWebActionItem;
    property Actions: TWebActionItems;
    property Action[Index: Integer]: TWebActionItem;
    property Request: TWebRequest;
    property Response: TWebResponse;
  end;

{ TWebDispatcher }

  TWebDispatcher = class(TCustomWebDispatcher)
  published
    property Actions;
    property BeforeDispatch;
    property AfterDispatch;
  end;

{ TWebModule }

  TWebModule = class(TCustomWebDispatcher)
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Actions;
    property BeforeDispatch;
    property AfterDispatch;
  end;

  TWebApplication = class(TComponent)
  protected
    function ActivateWebModule: TDataModule;
    procedure DeactivateWebModule(DataModule: TDataModule);
    procedure DoHandleException(E: Exception); dynamic;
    function HandleRequest(Request: TWebRequest; Response: TWebResponse): Boolean;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    // The following is uses the current behaviour of the IDE module manager
    procedure CreateForm(InstanceClass: TComponentClass; var Reference); virtual;
    procedure Initialize; virtual;
    procedure Run; virtual;
    property ActiveCount: Integer;
    property CacheConnections: Boolean;
    property InactiveCount: Integer;
    property MaxConnections: Integer;
    property Title: string;
  end;

function DosPathToUnixPath(const Path: string): string;
function HTTPDecode(const AStr: String): string;
function HTTPEncode(const AStr: String): string;
function ParseDate(const DateStr: string): TDateTime;
procedure ExtractHTTPFields(Separators, WhiteSpace: TSysCharSet; Content: PChar;
  Strings: TStrings);
procedure ExtractHeaderFields(Separators, WhiteSpace: TSysCharSet; Content: PChar;
  Strings: TStrings; Decode: Boolean);
function StatusString(StatusCode: Integer): string;
function UnixPathToDosPath(const Path: string): string;
function MonthStr(DateTime: TDateTime): string;
function DayOfWeekStr(DateTime: TDateTime): string;

var
  Application: TWebApplication = nil;

implementation
