httpprot.pas

互联网套件

end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpCli.TriggerHeaderBegin;
begin
    if Assigned(FOnHeaderBegin) then
        FOnHeaderBegin(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpCli.TriggerHeaderEnd;
begin
    if Assigned(FOnHeaderEnd) then
        FOnHeaderEnd(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpCli.TriggerRequestHeaderBegin;
begin
    if Assigned(FOnRequestHeaderBegin) then
        FOnRequestHeaderBegin(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpCli.TriggerRequestHeaderEnd;
begin
    if Assigned(FOnRequestHeaderEnd) then
        FOnRequestHeaderEnd(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpCli.TriggerRequestDone;
begin
    PostMessage(Handle, WM_HTTP_REQUEST_DONE, 0, 0);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpCli.WMHttpRequestDone(var msg: TMessage);
begin
    if Assigned(FOnRequestDone) then
        FOnRequestDone(Self, FRequestType, FRequestDoneError);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpCli.WMHttpSetReady(var msg: TMessage);
begin
    StateChange(httpReady);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure ReplaceExt(var FName : String; const newExt : String);
var
    I : Integer;
begin
    I := Posn('.', FName, -1);
    if I <= 0 then
        FName := FName + '.' + newExt
    else
        FName := Copy(FName, 1, I) + newExt;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpCli.Abort;
var
    bFlag : Boolean;
begin
    if FState = httpReady then begin
        if FWSocket.State <> wsClosed then
            FWSocket.Close; { This should never occurs ! }
        Exit;
    end;

    bFlag := (FState = httpDnsLookup);
    StateChange(httpAborting);

    if bFlag then begin
        try
            FWSocket.CancelDnsLookup;
        except
            { Ignore any exception }
        end;
    end;

    FStatusCode       := 404;
    FReasonPhrase     := 'Connection aborted on request';
    FRequestDoneError := httperrAborted;

    if bFlag then
        SocketSessionClosed(Self, 0)
    else
        FWSocket.Close;
    StateChange(httpReady);  { 13/02/99 }
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpCli.Login;
begin
    FDnsResult := '';
    StateChange(httpDnsLookup);
    FWSocket.DnsLookup(FHostName);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpCli.SocketDNSLookupDone(Sender: TObject; Error: Word);
begin
    if Error <> 0 then begin
        if FState = httpAborting then
            Exit;
        FRequestDoneError := Error;
        FStatusCode       := 404;
        FReasonPhrase     := 'can''t resolve hostname to IP address';
        SocketSessionClosed(Sender, Error);
    end
    else begin
        FDnsResult     := FWSocket.DnsResult;
        StateChange(httpDnsLookupDone);  { 19/09/98 }
        FWSocket.Addr  := FDnsResult;
        FWSocket.Port  := FPort;
        FWSocket.Proto := 'tcp';
        try
            FWSocket.Connect;
        except
            FRequestDoneError := FWSocket.LastError;
            FStatusCode       := 404;
            FReasonPhrase     := 'can''t connect: ' +
                                 WSocketErrorDesc(FWSocket.LastError) +
                                 ' (Error #' + IntToStr(FWSocket.LastError) + ')';
            FWSocket.Close;
            SocketSessionClosed(Sender, FWSocket.LastError);
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpCli.SocketSessionConnected(Sender : TObject; Error : Word);
begin
    if Error <> 0 then begin
        FRequestDoneError := Error;
        FStatusCode       := 404;
        FReasonPhrase     := WSocketErrorDesc(Error) +
                             ' (Error #' + IntToStr(Error) + ')';
        SocketSessionClosed(Sender, Error);
        Exit;
    end;

    FConnected := TRUE;
    StateChange(httpConnected);
    TriggerSessionConnected;

    FNext := GetHeaderLineNext;
    StateChange(httpWaitingHeader);

    try
        case FRequestType of
        httpPOST:
            begin
                SendRequest('POST', '1.0');
                TriggerSendBegin;
                FAllowedToSend := TRUE;
                SocketDataSent(FWSocket, 0);
            end;
        httpHEAD:
            begin
                SendRequest('HEAD', '1.0');
            end;
        httpGET:
            begin
                SendRequest('GET', '1.0');
            end;
        end;
    except
        Logout;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpCli.Logout;
begin
    FWSocket.Close;
    FConnected := FALSE;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpCli.SendCommand(const Cmd : String);
const
    CRLF : String[2] = #13#10;
begin
    if Assigned(FOnCommand) then
        FOnCommand(Self, Cmd);
    if Length(Cmd) > 0 then
        FReqStream.Write(Cmd[1], Length(Cmd));
    FReqStream.Write(CRLF[1], 2);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpCli.SendRequest(const Method, Version: String);
begin
    FReqStream.Clear;
    TriggerRequestHeaderBegin;
    SendCommand(method + ' ' + FPath + ' HTTP/' + Version);
    if FSender <> '' then
        SendCommand('From: ' + FSender);
{SendCommand('Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, */*'); }
    if FAccept <> '' then
        SendCommand('Accept: ' + FAccept);
    if FReference <> '' then
        SendCommand('Referer: ' + FReference);
{SendCommand('Accept-Language: fr, en'); }
    if (method = 'POST') and (FContentPost <> '') then
        SendCommand('Content-Type: ' + FContentPost);
{SendCommand('UA-pixels: 1024x768'); }
{SendCommand('UA-color: color8'); }
{SendCommand('UA-OS: Windows 95'); }
{SendCommand('UA-CPU: x86'); }
{SendCommand('User-Agent: Mozilla/3.0 (compatible)');} {; MSIE 3.01; Update a; Windows 95)');}
    if FAgent <> '' then
        SendCommand('User-Agent: ' + FAgent);
    SendCommand('Host: ' + FTargetHost);
    if FNoCache then
        SendCommand('Pragma: no-cache');
    if method = 'POST' then
        SendCommand('Content-Length: ' + IntToStr(SendStream.Size));
    if FModifiedSince <> 0 then
        SendCommand('If-Modified-Since: ' +
                    RFC1123_Date(FModifiedSince) + ' GMT');
    if FUsername <> '' then
        SendCommand('Authorization: Basic ' +
                    EncodeStr(encBase64, FUsername + ':' + FPassword));
    if (FProxy <> '') and (FProxyUsername <> '') then
        SendCommand('Proxy-Authorization: Basic ' +
                    EncodeStr(encBase64, FProxyUsername + ':' + FProxyPassword));
{SendCommand('Proxy-Connection: Keep-Alive'); }
    if FCookie <> '' then
        SendCommand('Cookie: ' + FCookie);
    if (FContentRangeBegin <> '') or (FContentRangeEnd <> '') then begin            {JMR!! Added this line!!!}
        SendCommand('Range: bytes=' + FContentRangeBegin + '-' + FContentRangeEnd); {JMR!! Added this line!!!}
      FContentRangeBegin := '';                                                     {JMR!! Added this line!!!}
      FContentRangeEnd   := '';                                                     {JMR!! Added this line!!!}
    end;                                                                            {JMR!! Added this line!!!}
    FAcceptRanges := '';

    TriggerRequestHeaderEnd;
    SendCommand('');
    FWSocket.Send(FReqStream.Memory, FReqStream.Size);
    FReqStream.Clear;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpCli.GetBodyLineNext;
var
    Len  : Integer;
    Data : Pointer;
const
    CRLF : String[2] = #13#10;
begin
    if FBodyLineCount = 0 then
        TriggerDocBegin;
    Inc(FBodyLineCount);

    Len := Length(FLastResponse);
    if Len > 0 then
        Data := @FLastResponse[1]
    else
        Data := @Len;
    FRcvdCount := FRcvdCount + Len;

    if Assigned(FRcvdStream) then
        FRcvdStream.WriteBuffer(Data^, Len);
    TriggerDocData(Data, Len);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpCli.GetHeaderLineNext;
var
    proto   : String;
    user    : String;
    pass    : String;
    port    : String;
    Host    : String;
    Path    : String;
    Field   : String;
    Data    : String;
    nSep    : Integer;
    tmpInt  : LongInt;
    bAccept : Boolean;
begin
    if FHeaderLineCount = 0 then
        TriggerHeaderBegin;
    Inc(FHeaderLineCount);

    { Some server send HTML document without header ! I don't know if it is  }
    { legal, but it exists (AltaVista Discovery does that).                  }
    if UpperCase(Copy(FLastResponse, 1, 6)) = '<HTML>' then begin { 15/09/98 }
        if FContentType = '' then
            FContentType := 'text/html';
        StateChange(httpWaitingBody);
        FNext := GetBodyLineNext;
        TriggerHeaderEnd;
        GetBodyLineNext;
        Exit;
    end;

    if FLastResponse = '' then begin
        if FLocationFlag then begin
            TriggerHeaderEnd;
            FReceiveLen       := 0;
            FHeaderLineCount  := 0;
            FBodyLineCount    := 0;
            FWSocket.OnSessionClosed := LocationSessionClosed;
            FWSocket.Close;
            Exit;
        end;
        if lowercase(ExtractFileExt(FDocName)) = '.exe' then begin
            if FContentType = 'text/html' then
                ReplaceExt(FDocName, 'htm');