httpsrv.pas

ics Internet 控件

        { instanciated to handle client connection                        }
        property    ClientClass : THttpConnectionClass
                                                    read  FClientClass
                                                    write FClientClass;
        property    WSocketServer : TWSocketServer  read  FWSocketServer
                                                    write FWSocketServer;
    published
        property ListenBacklog  : Integer           read  FListenBacklog
                                                    write FListenBacklog; {Bj鴕nar}
        { Component source version }
        property SrcVersion    : String          read GetSrcVersion;
        { We will listen to that port. Default to 80 for http service }
        property Port          : String          read  FPort
                                                 write SetPortValue;
        { We will use that interface to listen. 0.0.0.0 means all     }
        { available interfaces                                        }
        property Addr          : String          read  FAddr
                                                 write SetAddr;
        property MaxClients    : Integer         read  FMaxClients   {DAVID}
                                                 write FMaxClients;
        { Where all documents are stored. Default to c:\wwwroot }
        property DocDir        : String          read  FDocDir
                                                 write SetDocDir;
        { Where all template documents are stored. Default to c:\wwwroot\templates }
        property TemplateDir    : String            read  FTemplateDir
                                                    write FTemplateDir;
        { Default document name. Default to index.html }
        property DefaultDoc    : String          read  FDefaultDoc
                                                 write FDefaultDoc;
        property LingerOnOff   : TSocketLingerOnOff
                                                 read  FLingerOnOff
                                                 write FLingerOnOff;
        property LingerTimeout : Integer         read  FLingerTimeout
                                                 write FLingerTimeout;
        { Selected HTTP server optional behaviour }
        property Options        : THttpOptions      read  FOptions
                                                    write FOptions;
        { OnServerStrated is triggered when server has started listening }
        property OnServerStarted    : TNotifyEvent
                                                 read  FOnServerStarted
                                                 write FOnServerStarted;
        { OnServerStopped is triggered when server has stopped listening }
        property OnServerStopped    : TNotifyEvent
                                                 read  FOnServerStopped
                                                 write FOnServerStopped;
        { OnClientConnect is triggered when a client has connected }
        property OnClientConnect    : THttpConnectEvent
                                                 read  FOnClientConnect
                                                 write FOnClientConnect;
        { OnClientDisconnect is triggered when a client is about to }
        { disconnect.                                               }
        property OnClientDisconnect : THttpConnectEvent
                                                 read  FOnClientDisconnect
                                                 write FOnClientDisconnect;
        { OnGetDocument is triggered when a client sent GET request    }
        { You can either do nothing and let server handle all work, or }
        { you can build a document on the fly or refuse access.        }
        property OnGetDocument      : THttpGetEvent
                                                 read  FOnGetDocument
                                                 write FOnGetDocument;
        { OnGetDocument is triggered when a client sent HEAD request   }
        { You can either do nothing and let server handle all work, or }
        { you can build a document header on the fly or refuse access. }
        property OnHeadDocument     : THttpGetEvent
                                                 read  FOnHeadDocument
                                                 write FOnHeadDocument;
        { OnGetDocument is triggered when a client sent POST request   }
        { You have to tell if you accept data or not. If you accept,   }
        { you'll get OnPostedData event with incomming data.           }
        property OnPostDocument     : THttpGetEvent
                                                 read  FOnPostDocument
                                                 write FOnPostDocument;
        { On PostedData is triggered when client post data and you     }
        { accepted it from OnPostDocument event.                       }
        { When you've got all data, you have to build a reply to be    }
        { sent to client.                                              }
        property OnPostedData       : THttpPostedDataEvent
                                                 read  FOnPostedData
                                                 write FOnPostedData;
        property OnHttpRequestDone  : THttpRequestDoneEvent
                                                 read  FOnHttpRequestDone
                                                 write FOnHttpRequestDone;

        property OnBeforeProcessRequest : THttpBeforeProcessEvent  {DAVID}
                                                 read  FOnBeforeProcessRequest
                                                 write FOnBeforeProcessRequest;

        property OnFilterDirEntry   : THttpFilterDirEntry
                                                 read  FOnFilterDirEntry
                                                 write FOnFilterDirEntry;
    end;

    THttpDirEntry = class
        Visible   : Boolean;    { TRUE if the entry is to be shown in list  }
        Name      : String;
        SizeLow   : Cardinal;
        SizeHigh  : Cardinal;
        Year      : Integer;
        Month     : Integer;
        Day       : Integer;
        Hour      : Integer;
        Min       : Integer;
        Sec       : Integer;
        VolumeID  : Boolean;
        Directory : Boolean;
        ReadOnly  : Boolean;
        SysFile   : Boolean;
        Hidden    : Boolean;   { File is hidden, not the same as Visible !  }
    end;

    TStringIndex = class(TObject)
    protected
        FList : TStringList;
    public
        constructor Create;
        destructor Destroy; override;
        procedure Add(const Key, Value : String);
        function  Find(const Key : String; var Value : String) : Boolean;
        function  Count : Integer;
        procedure Clear;
    end;

    TStringIndexObject = class(TObject)
    public
        Value : String;
        constructor Create(const Data : String);
    end;

    TTableRowDataGetter = procedure(const TableName : String;
                                    Row             : Integer;
                                    TagData         : TStringIndex;
                                    var More        : Boolean;
                                    UserData        : TObject);
    PTableRowDataGetter = ^TTableRowDataGetter;
    THttpSrvRowDataGetter = procedure(const TableName : String;
                                      Row             : Integer;
                                      TagData         : TStringIndex;
                                      var More        : Boolean;
                                      UserData        : TObject) of object;
    THttpSrvRowDataGetterUserData = class
    public
        Event    : THttpSrvRowDataGetter;
        UserData : TObject;
    end;


{ You must define USE_SSL so that SSL code is included in the component.    }
{ To be able to compile the component, you must have the SSL related files  }
{ which are _NOT_ freeware. See http://www.overbyte.be for details.         }
{$IFDEF USE_SSL}
    {$I HttpSrvIntfSsl.inc}
{$ENDIF}

{ Retrieve a single value by name out of an cookies string.                 }
function GetCookieValue(
    const CookieString : String;    { Cookie string from header line        }
    const Name         : String;    { Cookie name to look for               }
    var Value          : String)    { Where to put variable value           }
    : Boolean;                      { Found or not found that's the question}
{ Retrieve a single value by name out of an URL encoded data stream.        }
function ExtractURLEncodedValue(
    Msg       : PChar;             { URL Encoded stream                     }
    Name      : String;            { Variable name to look for              }
    var Value : String): Boolean;  { Where to put variable value            }
function UrlEncode(const S : String) : String;
function UrlDecode(const Url : String) : String;
function htoi2(value : PChar) : Integer;
function IsXDigit(Ch : char) : Boolean;
function XDigit(Ch : char) : Integer;
function FileDate(FileName : String) : TDateTime;
function RFC1123_Date(aDate : TDateTime) : String;
function DocumentToContentType(FileName : String) : String;
function TextToHtmlText(const Src : String) : String;
function TranslateChar(const Str: String; FromChar, ToChar: Char): String;
function UnixPathToDosPath(const Path: String): String;
function DosPathToUnixPath(const Path: String): String;
function IsDirectory(const Path : String) : Boolean;
function AbsolutisePath(const Path : String) : String;
function MakeCookie(const Name, Value : String;
                    Expires           : TDateTime;
                    const Path        : String) : String;
function HtmlPageProducer(const HtmlFileName : String;
                          Tags               : array of const;
                          RowDataGetter      : PTableRowDataGetter;
                          UserData           : TObject;
                          DestStream         : TStream) : Boolean;
function HtmlPageProducerFromMemory(
    Buf                : PChar;
    BufLen             : Integer;
    TagData            : TStringIndex;
    RowDataGetter      : PTableRowDataGetter;
    UserData           : TObject;
    DestStream         : TStream) : Boolean;
function RemoveHtmlSpecialChars(const S : String) : String;

procedure Register;

const
    HttpConnectionStateName : array [THttpConnectionState] of String =
         ('hcRequest', 'hcHeader', 'hcPostedData');

implementation


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure Register;
begin
    RegisterComponents('FPiette', [THttpServer
{$IFDEF USE_SSL}
                                   ,TSslHttpServer
{$ENDIF}
                                   ]);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{$IFDEF VER80}
procedure SetLength(var S: string; NewLength: Integer);
begin
    S[0] := chr(NewLength);
end;
{$ENDIF}


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{$IFDEF VER80}
function TrimRight(Str : String) : String;
var
    i : Integer;
begin
    i := Length(Str);
    while (i > 0) and (Str[i] = ' ') do
        i := i - 1;
    Result := Copy(Str, 1, i);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TrimLeft(Str : String) : String;
var
    i : Integer;
begin
    if Str[1] <> ' ' then
        Result := Str
    else begin
        i := 1;
        while (i <= Length(Str)) and (Str[i] = ' ') do
            i := i + 1;
        Result := Copy(Str, i, Length(Str) - i + 1);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function Trim(Str : String) : String;
begin
    Result := TrimLeft(TrimRight(Str));
end;
{$ENDIF}


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor THttpServer.Create(AOwner: TComponent);
begin
    inherited Create(AOwner);
    CreateSocket;
    FClientClass   := THttpConnection;
    FOptions       := [];
    FAddr          := '0.0.0.0';
    FPort          := '80';
    FMaxClients    := 0;                {DAVID}
    FListenBacklog := 5; {Bj鴕nar}
    FDefaultDoc    := 'index.html';
    FDocDir        := 'c:\wwwroot';
    FTemplateDir   := 'c:\wwwroot\templates';
    FLingerOnOff   := wsLingerNoSet;
    FLingerTimeout := 0;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor THttpServer.Destroy;
begin
    if Assigned(FWSocketServer) then begin
        FWSocketServer.Destroy;
        FWSocketServer := nil;
    end;
    inherited Destroy;
end;