httpsrv.pas

ics Internet 控件

    if Assigned(FOnPostedData) then
        FOnPostedData(Self, Sender, Error);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpServer.TriggerPostDocument(
     Sender     : TObject;
     var Flags  : THttpGetFlag);
begin
    if Assigned(FOnPostDocument) then
        FOnPostDocument(Self, Sender, Flags);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpServer.TriggerHTTPRequestDone(
    Client : TObject);
begin
    if Assigned(FOnHttpRequestDone) then
        FOnHttpRequestDone(Self, Client);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpServer.TriggerBeforeProcessRequest(  {DAVID}
    Client : TObject);
begin
    if Assigned(FOnBeforeProcessRequest) then
        FOnBeforeProcessRequest(Self, Client);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpServer.TriggerFilterDirEntry(
    Sender   : TObject;
    Client   : TObject;
    DirEntry : THttpDirEntry);
begin
    if Assigned(FOnFilterDirEntry) then
        FOnFilterDirEntry(Self, Client, DirEntry);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor THttpConnection.Create(AOwner : TComponent);
begin
    inherited Create(AOwner);
    LineMode            := TRUE;
    LineEdit            := FALSE;
    LineEnd             := #10;
    FRequestHeader      := TStringList.Create;
    FState              := hcRequest;
    OnDataAvailable     := ConnectionDataAvailable;
    FRequestRangeValues := THttpRangeList.Create; {ANDREAS}
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor THttpConnection.Destroy;
begin
    if Assigned(FRequestHeader) then begin
        FRequestHeader.Free;
        FRequestHeader := nil;
    end;
    if Assigned(FDocStream) then begin
        FDocStream.Free;
        FDocStream := nil;
    end;
    if Assigned(FDocBuf) then begin
        FreeMem(FDocBuf, BufSize);
        FDocBuf := nil;
    end;
    if Assigned(FRequestRangeValues) then begin
        FRequestRangeValues.Free; {ANDREAS}
        FRequestRangeValues := nil;
    end;
    inherited Destroy;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.WndProc(var MsgRec: TMessage);
begin
    with MsgRec do begin
        { We *MUST* handle all exception to avoid application shutdown }
        try
            if Msg = WM_HTTP_DONE then
                WMHttpDone(MsgRec)
            else
                inherited WndProc(MsgRec);
        except
            on E:Exception do
                HandleBackGroundException(E);
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.WMHttpDone(var msg: TMessage);
begin
     FState := hcRequest;
     TriggerHttpRequestDone;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This procedure is called each time data is available from a client.       }
{ We use FState variable to keep track of the where we are in the http      }
{ protocol: request command, header line or posted data.                    }
procedure THttpConnection.ConnectionDataAvailable(Sender: TObject; Error : Word);
var
    Len     : Integer;
    I, J    : Integer;
begin
    { If we are in data state, then the application has to receive data }
    if FState = hcPostedData then begin
        if FAcceptPostedData and Assigned(FOnPostedData) then
            FOnPostedData(Self, Error)
        else
            { No one is willing data, received it and throw it away }
            FRcvdLine := ReceiveStr;
        Exit;
    end;
    { We use line mode. We will receive complete lines }
    FRcvdLine := ReceiveStr;
    { Remove trailing CR/LF }
    Len := Length(FRcvdLine);
    if (Len > 0) and (FRcvdLine[Len] = #10) then begin
        Dec(Len);
        if (Len > 0) and (FRcvdLine[Len] = #13) then
            Dec(Len);
        SetLength(FRcvdLine, Len);
    end;
    if FState = hcRequest then begin
        { We just start a new request. Initialize all header variables }
        FRequestContentType    := '';
        FRequestContentLength  := 0;
        FRequestContentType    := '';
        FRequestAccept         := '';
        FRequestReferer        := '';
        FRequestAcceptLanguage := '';
        FRequestAcceptEncoding := '';
        FRequestUserAgent      := '';
        FRequestAuth           := '';     {DAVID}
        FRequestCookies        := '';
        FRequestHost           := '';
        FRequestHostName       := '';     {DAVID}
        FRequestHostPort       := '';     {DAVID}
        FRequestConnection     := '';
        FDataSent              := 0;      {TURCAN}
        FDocSize               := 0;      {TURCAN}
        FRequestRangeValues.Clear;        {ANDREAS}
        FRequestHeader.Clear;
        { The line we just received is HTTP command, parse it  }
        ParseRequest;
        { Next lines will be header lines }
        FState := hcHeader;
        Exit;
    end;
    { We can comes here only in hcHeader state }
    if FRcvdLine = '' then begin
        { Last header line is an empty line. Then we enter data state }
        if FRequestContentLength <> 0 then    { Only if we have data  }
             FState := hcPostedData
        { With a GET method, we _never_ have any document        10/02/2004 }
        else if FMethod = 'GET' then                           { 10/02/2004 }
            FState := hcRequest;                               { 10/02/2004 }
        { We will process request before receiving data because application }
        { has to setup things to be able to receive posted data             }
        ProcessRequest;
        Exit;
    end;
    { We comes here for normal header line. Extract some interesting variables }
    I := Pos(':', FRcvdLine);
    if I > 0 then begin
        try
            repeat
                Inc(I);
            until (I > Length(FRcvdLine)) or (FRcvdLine[I] <> ' ');
            if StrLIComp(@FRcvdLine[1], 'content-type:', 13) = 0 then
                FRequestContentType := Copy(FRcvdLine, I, Length(FRcvdLine))
            else if StrLIComp(@FRcvdLine[1], 'content-length:', 15) = 0 then
                FRequestContentLength := StrToInt(Copy(FRcvdLine, I, Length(FRcvdLine)))
            else if StrLIComp(@FRcvdLine[1], 'Accept:', 7) = 0 then
                FRequestAccept:= Copy(FRcvdLine, I, Length(FRcvdLine))
            else if StrLIComp(@FRcvdLine[1], 'Referer:', 8) = 0 then
                FRequestReferer := Copy(FRcvdLine, I, Length(FRcvdLine))
            else if StrLIComp(@FRcvdLine[1], 'Accept-Language:', 16) = 0 then
                FRequestAcceptLanguage := Copy(FRcvdLine, I, Length(FRcvdLine))
            else if StrLIComp(@FRcvdLine[1], 'Accept-Encoding:', 16) = 0 then
                FRequestAcceptEncoding := Copy(FRcvdLine, I, Length(FRcvdLine))
            else if StrLIComp(@FRcvdLine[1], 'User-Agent:', 11) = 0 then
                FRequestUserAgent := Copy(FRcvdLine, I, Length(FRcvdLine))
            else if StrLIComp(@FRcvdLine[1], 'Authorization:', 14) = 0 then {DAVID}
                FRequestAuth := Copy(FRcvdLine, I, Length(FRcvdLine))
            else if StrLIComp(@FRcvdLine[1], 'Cookie:', 7) = 0 then {DAVID}
                FRequestCookies := Copy(FRcvdLine, I, Length(FRcvdLine))
            else if StrLIComp(@FRcvdLine[1], 'Host:', 5) = 0 then begin
                FRequestHost := Copy(FRcvdLine, I, Length(FRcvdLine));
                J := Pos(':', FRequestHost); {DAVID}
                if J > 0 then begin
                    FRequestHostName := Copy(FRequestHost, 1, J - 1);
                    FRequestHostPort := Copy(FRequestHost, J + 1, 100);
                end
                else begin
                    FRequestHostName := FRequestHost;
                    FRequestHostPort := FServer.Port; { by default server port }
                end;
            end
            else if StrLIComp(@FRcvdLine[1], 'Connection:', 11) = 0 then
                FRequestConnection := Copy(FRcvdLine, I, Length(FRcvdLine))
            {ANDREAS}
            else if StrLIComp(@FRcvdLine[1], 'Range:', 6) = 0 then begin
                { Init the Byte-range object }
                RequestRangeValues.InitFromString(Trim(Copy(FRcvdLine, I,
                                                           Length(FRcvdLine))));
            end;
        except
            { Ignore any exception in parsing header line }
        end;
    end;
    FRequestHeader.Add(FRcvdLine);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Request is in FRcvdLine property.                                         }
{ Split it into FMethod, FPath, FVersion and parameters.                    }
procedure THttpConnection.ParseRequest;
var
    I, J : Integer;
begin
    I := 1;
    while (I <= Length(FRcvdLine)) and (FRcvdLine[I] <> ' ') do
        Inc(I);
    FMethod := UpperCase(Copy(FRcvdLine, 1, I - 1));
    Inc(I);
    while (I <= Length(FRcvdLine)) and (FRcvdLine[I] = ' ') do
        Inc(I);
    J := I;
    while (I <= Length(FRcvdLine)) and (FRcvdLine[I] <> ' ') do
        Inc(I);
    FPath := Copy(FRcvdLine, J, I - J);
    { Find parameters }
    J := Pos('?', FPath);
    if J <= 0 then
        FParams := ''
    else begin
        FParams := Copy(FPath, J + 1, Length(FPath));
        FPath   := Copy(FPath, 1, J - 1);
    end;
    Inc(I);
    while (I <= Length(FRcvdLine)) and (FRcvdLine[I] = ' ') do
        Inc(I);
    J := I;
    while (I <= Length(FRcvdLine)) and (FRcvdLine[I] <> ' ') do
        Inc(I);
    FVersion := Trim(UpperCase(Copy(FRcvdLine, J, I - J)));
    if FVersion = '' then
        FVersion := 'HTTP/1.0';
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure RowDataGetterProc(
    const TableName : String;
    Row             : Integer;
    TagData         : TStringIndex;
    var More        : Boolean;
    UserData        : TObject);
var
    UD : THttpSrvRowDataGetterUserData;
begin
    UD := UserData as THttpSrvRowDataGetterUserData;
    if Assigned(UD.Event) then
        UD.Event(TableName, Row, TagData, More, UD.UserData)
    else
        More := FALSE;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.TriggerGetRowData(
    const TableName : String;
    Row             : Integer;
    T