httpsrv.pas

灰鸽子1.23源码,,,,,,,

end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.ProcessGet;
var
    Flags      : THttpGetFlag;
    TempStream : TFileStream;
    OK         : Boolean;
begin
    Flags := hgSendDoc;
    TriggerGetDocument(Flags);
    case Flags of
    hg404:
        begin
            Answer404;
            CloseDelayed;
        end;
    hgSendDoc:
        begin
            OK := FALSE;
            try
                if not FileExists(FDocument) then begin
                    { File not found }
                    Answer404;
                    CloseDelayed;
                end
                else begin
                    TempStream := TFileStream.Create(FDocument, fmOpenRead + fmShareDenyWrite);
                    TempStream.Destroy;
                    OK := TRUE;
                end;
            except
                Answer404;
                CloseDelayed;
            end;
            if OK then
                SendDocument(httpSendDoc)
        end;
    hgSendStream:
        SendStream;
    hgWillSendMySelf:
        { Nothing to do };
    else
        CloseDelayed;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function DocumentToContentType(FileName : String) : String;
var
    Ext : String;
begin
    { We probably should the registry to find MIME type for known file types }
    Ext := LowerCase(ExtractFileExt(FileName));
    if Length(Ext) > 1 then
        Ext := Copy(Ext, 2, Length(Ext));
    if (Ext = 'htm') or (Ext = 'html') then
        Result := 'text/html'
    else if Ext = 'gif' then
        Result := 'image/gif'
    else if Ext = 'bmp' then
        Result := 'image/bmp'
    else if (Ext = 'jpg') or (Ext = 'jpeg') then
        Result := 'image/jpeg'
    else if Ext = 'txt' then
        Result := 'text/plain'
    else
        Result := 'application/binary';
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function RFC1123_Date(aDate : TDateTime) : String;
const
    StrWeekDay : String = 'MonTueWedThuFriSatSun';
    StrMonth   : String = 'JanFebMarAprMayJunJulAugSepOctNovDec';
var
    Year, Month, Day       : Word;
    Hour, Min,   Sec, MSec : Word;
    DayOfWeek              : Word;
begin
    DecodeDate(aDate, Year, Month, Day);
    DecodeTime(aDate, Hour, Min,   Sec, MSec);
    DayOfWeek := ((Trunc(aDate) - 2) mod 7);
    Result := Copy(StrWeekDay, 1 + DayOfWeek * 3, 3) + ', ' +
              Format('%2.2d %s %4.4d %2.2d:%2.2d:%2.2d',
                     [Day, Copy(StrMonth, 1 + 3 * (Month - 1), 3),
                      Year, Hour, Min, Sec]);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Return document file date from document filename.                         }
{ Return 0 if file not found.                                               }
function FileDate(FileName : String) : TDateTime;
var
    SearchRec : TSearchRec;
    Status    : Integer;
begin
    Status := FindFirst(FileName, faAnyFile, SearchRec);
    try
        if Status <> 0 then
            Result := 0
        else
            Result := FileDateToDateTime(SearchRec.Time);
    finally
        FindClose(SearchRec);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ SendDocument will send FDocument file to remote client, build header and  }
{ sending data (if required)                                                }
procedure THttpConnection.SendDocument(SendType : THttpSendType);
var
    DocSize : Integer;
begin
    FLastModified      := FileDate(FDocument);
    FAnswerContentType := DocumentToContentType(FDocument);

    if Assigned(FDocStream) then begin
        FDocStream.Destroy;
        FDocStream := nil;
    end;
    FDocStream := TFileStream.Create(FDocument, fmOpenRead + fmShareDenyWrite);
    DocSize    := FDocStream.Size;
    { Seek to end of document because HEAD will not send actual document }
    if SendType = httpSendHead then
        FDocStream.Seek(0, soFromEnd);
    OnDataSent := ConnectionDataSent;
    { Send Header }
    PutStringInSendBuffer(
            FVersion + ' 200 OK' + #13#10 +
            'Content-Type: ' + FAnswerContentType + #13#10 +
            'Content-Length: ' + IntToStr(DocSize) + #13#10);
    if FLastModified <> 0 then
        PutStringInSendBuffer(
            'Last-Modified: ' + RFC1123_Date(FLastModified) + 'GMT' + #13#10);
    PutStringInSendBuffer(#13#10);
    { Send(nil, 0);  Removed 15/04/02 }
    if SendType = httpSendDoc then
        SendStream
    else
        Send(nil, 0); { Added 15/04/02 }
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.SendStream;
begin
    if not Assigned(FDocStream) then begin
        CloseDelayed;
        Exit;
    end;
    if not Assigned(FDocBuf) then
        GetMem(FDocBuf, BufSize);
    OnDataSent := ConnectionDataSent;
    ConnectionDataSent(Self, 0);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ All data in TWSocket has been sent. Read next lock from stream and send.  }
{ When end of stream is reached, closed communication.                      }
procedure THttpConnection.ConnectionDataSent(Sender : TObject; Error : WORD);
var
    Count : Integer;
begin
    if not Assigned(FDocStream) then begin
        { End of file has been reached }
        Exit;
    end;
    Count := FDocStream.Read(FDocBuf^, BufSize);
    if Count <= 0 then begin
        { End of file found }
        FDocStream.Destroy;
        FDocStream := nil;
        ShutDown(1);
{$IFNDEF VER80}
        Sleep(0);
{$ENDIF}
        PostMessage(Handle, WM_HTTP_DONE, 0, 0);
        Exit;
    end;
    if State = wsConnected then          { Be sure to be still connected... }
        Send(FDocBuf, Count);            { before actually send any data.   }
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function xdigit(Ch : char) : Integer;
begin
    if ch in ['0'..'9'] then
        Result := ord(Ch) - ord('0')
    else
        Result := (ord(Ch) and 15) + 9;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function isxdigit(Ch : char) : Boolean;
begin
    Result := (ch in ['0'..'9']) or (ch in ['a'..'z']) or (ch in ['A'..'Z']);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function htoin(value : PChar; len : Integer) : Integer;
var
    i : Integer;
begin
    Result := 0;
    i      := 0;
    while (i < len) and (Value[i] = ' ') do
        i := i + 1;
    while (i < len) and (isxDigit(Value[i])) do begin
        Result := Result * 16 + xdigit(Value[i]);
        i := i + 1;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function htoi2(value : PChar) : Integer;
begin
    Result := htoin(value, 2);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Retrieve a single value by name out of an URL encoded data stream         }
{ In the stream, every space is replaced by a '+'. The '%' character is     }
{ an escape character. The next two are 2 digits hexadecimal codes ascii    }
{ code value. The stream is constitued by name=value couples separated      }
{ by a single '&' character. The special characters are coded by the '%'    }
{ followed by hex-ascii character code.                                     }
function ExtractURLEncodedValue(
    Msg       : PChar;        { URL Encoded stream                     }
    Name      : String;       { Variable name to look for              }
    var Value : String)       { Where to put variable value            }
    : Boolean;                { Found or not found that's the question }
var
    NameLen  : Integer;
    FoundLen : Integer; {tps}
    Ch       : Char;
    P, Q     : PChar;
begin
    Result  := FALSE;
    Value   := '';
    if Msg = nil then         { Empty source }
        Exit;

    NameLen := Length(Name);

    P := Msg;
    while P^ <> #0 do begin
        Q := P;
        while (P^ <> #0) and (P^ <> '=') do
            Inc(P);
        FoundLen := P - Q; {tps}
        if P^ = '=' then
            Inc(P);
        if (StrLIComp(Q, @Name[1], NameLen) = 0) and
           (NameLen = FoundLen) then begin  {tps}
            while (P^ <> #0) and (P^ <> '&') do begin
                Ch := P^;
                if Ch = '%' then begin
                    Ch := chr(htoi2(P + 1));
                    Inc(P, 2);
                end
                else if Ch = '+' then
                    Ch := ' ';
                Value := Value + Ch;
                Inc(P);
            end;
            Result := TRUE;
            break;
         end;
         while (P^ <> #0) and (P^ <> '&') do
             Inc(P);
        if P^ = '&' then
            Inc(P);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function UrlDecode(const Url : String) : String;
var
    I, J, K, L : Integer;
begin
    Result := Url;
    L      := Length(Result);
    I      := 1;
    K      := 1;
    while TRUE do begin
        J := I;
        while (J <= Length(Result)) and (Result[J] <> '%') do begin
            if J <> K then
                Result[K] := Result[J];
            Inc(J);
            Inc(K);
        end;
        if J > Length(Result) then
            break;                   { End of string }
        if J > (Length(Result) - 2) then begin
            while J <= Length(Result) do begin
                Result[K] := Result[J];
                Inc(J);
                Inc(K);
            end;
            break;
        end;
        Result[K] := Char(htoi2(@Result[J + 1]));
        Inc(K);
        I := J + 3;
        Dec(L, 2);
    end;
    SetLength(Result, L);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

end.