rtcwsockhttpcliprov.pas

Delphi快速开发Web Server

{
  "HTTP Client Provider (WinSock)" - Copyright (c) Danijel Tkalcec
  @html(<br>)

  Using TRtcWSockClientProvider to implement a HTTP Client provider

  @exclude
}
unit rtcWSockHttpCliProv;

{$INCLUDE rtcDefs.inc}

interface

uses
  Classes,
  SysUtils,

  rtcLog,
  rtcConn,
  rtcConnProv,

  rtcFastStrings,
  rtcWSockCliProv;

type
  TRtcWSockHttpClientProvider = class(TRtcWSockClientProvider)
  private
    FOnInvalidResponse:TRtcEvent;

    FMaxHeaderSize:integer;
    FMaxResponseSize:integer;

    FRequest:TRtcClientRequest;
    FResponse:TRtcClientResponse;

    FResponseBuffer:TRtcHugeString;

    FResponseWaiting:boolean;

    ReqComplete:boolean; // internal Request.Complete indicator (to avoid problems with changing Request objects)

    FChunked:boolean;
    FChunkState:byte;

    FResponseLine:boolean; // response line received
    InBuffer:string; // data received, including HTTP header (header will be stripped when read)
    FHaveResponse:boolean; // response header accepted, receiving request data.
    LenToRead:int64; // number of bytes left to read from last Request

    LenToWrite:int64; // number of bytes to write out using inherited Write()
    LenToSend:int64; // number of bytes left to send out (DataOut event)
    FHeaderOut:boolean;

  protected
    procedure ClearResponse;

    procedure TriggerConnect; override;
    procedure TriggerConnectLost; override;
    procedure TriggerDataReceived; override;
    procedure TriggerDataSent; override;
    procedure TriggerDataOut; override;

    procedure TriggerInvalidResponse; virtual;

  public
    constructor Create; override;
    destructor Destroy; override;

    procedure SetTriggerInvalidResponse(Event:TRtcEvent);

    procedure WriteHeader(SendNow:boolean=True); overload;
    procedure WriteHeader(const Header_Text:string; SendNow:boolean=True); overload;

    procedure Write(const ResultData:string; SendNow:boolean=True); override;

    // On DataReceived, read server response body using this:
    function Read:string; override;

    property Request:TRtcClientRequest read FRequest write FRequest;
    property Response:TRtcClientResponse read FResponse write FResponse;

    // Max. allowed size of the first (status) line in response header
    property MaxResponseSize:integer read FMaxResponseSize write FMaxResponseSize;
    // Max. allowed size of the complete response Header
    property MaxHeaderSize:integer read FMaxHeaderSize write FMaxHeaderSize;
    end;

implementation

const
  CRLF = #13#10;
  END_MARK = CRLF+CRLF;

{ TRtcWSockHttpClientProvider }

procedure TRtcWSockHttpClientProvider.SetTriggerInvalidResponse(Event: TRtcEvent);
  begin
  FOnInvalidResponse:=Event;
  end;

procedure TRtcWSockHttpClientProvider.TriggerInvalidResponse;
  begin
  if assigned(FOnInvalidResponse) then
    FOnInvalidResponse;
  end;

constructor TRtcWSockHttpClientProvider.Create;
  begin
  inherited;
  FResponseBuffer:=TRtcHugeString.Create;

  InBuffer:='';
  LenToWrite:=0;
  LenToSend:=0;
  FHeaderOut:=False;
  FResponseLine:=False;
  ReqComplete:=False;
  end;

destructor TRtcWSockHttpClientProvider.Destroy;
  begin
  Enter;
  try
    FResponseBuffer.Free;

    InBuffer:='';
    LenToWrite:=0;
    LenToSend:=0;
    FResponseLine:=False;
    FHeaderOut:=False;
    FResponseWaiting:=False;
  finally
    Leave;
    end;
  inherited;
  end;

procedure TRtcWSockHttpClientProvider.ClearResponse;
  begin
  FResponseBuffer.Clear;

  FResponseLine:=False;
  FResponse.Clear;
  LenToRead:=-1;
  end;

procedure TRtcWSockHttpClientProvider.TriggerConnect;
  begin
  Enter;
  try
    Request.Init;

    FResponseBuffer.Clear;

    InBuffer:='';
    LenToWrite:=0;
    LenToSend:=0;
    FHeaderOut:=False;
    FResponseLine:=False;
    FResponseWaiting:=False;
    FHaveResponse:=False;
    FChunked:=False;
    FChunkState:=0;

    ClearResponse;
  finally
    Leave;
    end;
  inherited;
  end;

procedure TRtcWSockHttpClientProvider.TriggerConnectLost;
  begin
  Enter;
  try
    if FHaveResponse then // Processing a response ...
      begin
      if not FChunked and (LenToRead=-1) then // No content-length and not chunked
        begin
        LenToRead:=0;
        Response.Done:=True;
        Request.Active:=False;
        FHaveResponse:=False; // get ready for next request
        FResponseLine:=False;
        FHeaderOut:=False;
        FChunked:=False;
        FChunkState:=0;

        ReqComplete:=False; // DataReceived events have to wait until a new request has been sent out

        Leave;
        try
          inherited TriggerDataReceived;
        finally
          Enter;
          end;
        end;
      end;
  finally
    Leave;
    end;
  inherited;
  end;

procedure TRtcWSockHttpClientProvider.TriggerDataReceived;
  var
    s,
    StatusLine,
    HeadStr:string;
    HeadLen,
    MyPos:integer;

  function HexToInt(s:string):integer;
    var
      i,len:integer;
      c:char;
    begin
    Result:=0;
    len:=length(s);
    i:=1;
    while len>0 do
      begin
      c:=s[len];
      if c in ['1'..'9'] then
        Result:=Result+i*(Ord(c)-Ord('0'))
      else if s[len] in ['A'..'F'] then
        Result:=Result+i*(Ord(c)-Ord('A')+10)
      else if s[len] in ['a'..'f'] then
        Result:=Result+i*(Ord(c)-Ord('a')+10);
      i:=i*16;Dec(len);
      end;
    end;

  procedure ResponseError;
    begin
    ReqComplete:=False; // no more reading, please!
    FResponseLine:=False;
    Leave;
    try
      TriggerInvalidResponse;
    finally
      Enter;
      end;
    end;

  begin
  if not ReqComplete then
    begin
    if assigned(CryptPlugin) then
      begin
      Enter;
      try
        // Read string from buffer
        InBuffer:=InBuffer + inherited Read;

        if InBuffer='' then
          begin
          FResponseWaiting:=True;
          Exit;
          end
        else
          FResponseWaiting:=False;
      finally
        Leave;
        end;
      end
    else
      begin
      FResponseWaiting:=True;
      Exit;
      end;
    end
  else
    FResponseWaiting:=False;

  Enter;
  try
    // Read string from buffer
    InBuffer:=InBuffer + inherited Read;

    repeat
      if not FHaveResponse then // Don't have the header yet ...
        begin
        if not FResponseLine then
          begin
          // Accept streaming data as response
          if ((length(InBuffer)>=5) and (CompareText(Copy(InBuffer,1,5),'HTTP/')<>0)) or
             ((length(InBuffer)=1) and (CompareText(InBuffer,'H')<>0)) or
             ((length(InBuffer)=2) and (CompareText(InBuffer,'HT')<>0)) or
             ((length(InBuffer)=3) and (CompareText(InBuffer,'HTT')<>0)) or
             ((length(InBuffer)=4) and (CompareText(InBuffer,'HTTP')<>0)) then
            begin
            ClearResponse;

            Response.Receiving:=True;
            Response.Started:=True;

            FHaveResponse:=True;
            FResponseLine:=True;
            LenToRead:=-1; // Unlimited length (streaming data until disconnected)

            Continue;
            end;

          MyPos:=Pos(CRLF,InBuffer);
          if (MaxResponseSize>0) and
             ( (MyPos>MaxResponseSize+1) or
               ((MyPos<=0) and (length(InBuffer)>MaxResponseSize+length(CRLF))) ) then
            begin
            ClearResponse;

            ResponseError;
            Exit;
            end
          else if (MyPos>0) then
            begin
            ClearResponse;

            StatusLine:=Copy(InBuffer,1,MyPos-1);
            Delete(InBuffer,1,MyPos+length(CRLF)-1);

            if CompareText(Copy(StatusLine,1,5),'HTTP/')<>0 then
              begin
              ResponseError;
              Exit;
              end;

            Response.Receiving:=True;
            Response.Started:=True;

            { Our line probably looks like this:
              HTTP/1.1 200 OK }
            MyPos:=Pos(' ',StatusLine); // first space before StatusCode
            if MyPos<=0 then
              begin
              ResponseError;
              Exit;
              end;
            Delete(StatusLine,1,MyPos); // remove 'HTTP/1.1 '

            MyPos:=Pos(' ',StatusLine); // space after StatusCode
            if MyPos<=0 then
              begin
              ResponseError;
              Exit;
              end;

            s:=Copy(StatusLine,1,MyPos-1); // StatusCode
            Delete(StatusLine,1,MyPos); // StatusText

            if (s<>'') and (StatusLine<>'') then
              begin
              try
                Response.StatusCode:=StrToInt(s);
                Response.StatusText:=StatusLine;
              except
                // if there is something wrong with this, just ignore the exception
                end;
              end;

            FResponseLine:=True;
            end;
          end;