rtcmsgcli.pas

Delphi快速开发Web Server

{
  @html(<b>)
  Plugable Message Client component
  @html(</b>)
  - Copyright (c) Danijel Tkalcec
  @html(<br><br>)

  Introducing the @html(<b>) @Link(TRtcMessageClient) @html(</b>) component:
  @html(<br>)
  Plugable Client component can be used for direct client-server in-memory connections, or
  for "plugging" RTC Clients into third-party connection components (like NexusDB).
}
unit rtcMsgCli;

{$INCLUDE rtcDefs.inc}

interface

uses
  Classes,

  rtcInfo,
  rtcConn,

  rtcFastStrings,
  rtcTransports,
  rtcDataCli;

type
  // @exclude
  TRtcMessageClient=class;

  { @Abstract(Plugable Message Client Connection component)

    Received data will be processed by TRtcMessageClient to gather Request
    information and make it easily accessible through the
    @Link(TRtcDataClient.Request) property.
    The same way, your response will be packed into a HTTP result header
    and sent out as a valid HTTP result, readable by any Web Browser.
    @html(<br>)
    @Link(TRtcMessageClient) also makes sure that you receive requests one by one
    and get the chance to answer them one-by-one, even if the client side
    sends all the requests at once (as one big request list), so
    you can relax and process all incomming requests, without worrying
    about overlapping your responses for different requests.
    @html(<br><br>)

    Properties to check first:
    @html(<br>)
    @Link(TRtcMessageClient.Server) - Server connection component (where our requests are sent for processing)
    @html(<br><br>)

    Methods to check first:
    @html(<br>)
    @Link(TRtcDataClient.Request), @Link(TRtcMessageClient.WriteHeader), @Link(TRtcMessageClient.Write) - Write (send) Request to Server
    @html(<br>)
    @Link(TRtcDataClient.Response), @Link(TRtcConnection.Read) - Read Server's Response
    @html(<br><br>)

    Events to check first:
    @html(<br>)
    @Link(TRtcConnection.OnDataSent) - Data sent to server (buffer now empty)
    @html(<br>)
    @Link(TRtcConnection.OnDataReceived) - Data available from server (check @Link(TRtcDataClient.Response))
    @html(<br>)
    @Link(TRtcMessageClient.OnInvalidResponse) - Received invalid response from Server
    @html(<br><br>)

    Check @Link(TRtcClient) and @Link(TRtcConnection) for more info.
    }
  TRtcMessageClient = class(TRtcDataClient)
  private
    FServer:TComponent;

    // User Parameters
    FMaxResponseSize:cardinal;
    FMaxHeaderSize:cardinal;
    FOnInvalidResponse:TRtcNotifyEvent;

    // Internal variables
    FWritten:boolean;
    FWriteBuffer:TRtcHugeString;

    procedure SetServer(const Value: TComponent);

  protected
    // @exclude
    procedure SetTriggers; override;
    // @exclude
    procedure ClearTriggers; override;
    // @exclude
    procedure SetParams; override;

    // @exclude
    function CreateProvider:TObject; override;


    // @exclude
    procedure TriggerDataSent; override;
    // @exclude
    procedure TriggerDataReceived; override;
    // @exclude
    procedure TriggerDataOut; override;

    // @exclude
    procedure TriggerInvalidResponse; virtual;
    // @exclude
    procedure CallInvalidResponse; virtual;

    // @exclude
    procedure SetRequest(const Value: TRtcClientRequest); override;
    // @exclude
    procedure SetResponse(const Value: TRtcClientResponse); override;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    class function New:TRtcMessageClient;

    // @exclude
    procedure LeaveEvent; override;

    { Flush all buffered data.
      @html(<br>)
      When using 'Write' without calling 'WriteHeader' before, all data
      prepared by calling 'Write' will be buffered until your event
      returns to its caller (automatically upon your event completion) or
      when you first call 'Flush'. Flush will check if Request.ContentLength is set
      and if not, will set the content length to the number of bytes buffered.
      @html(<br>)
      Flush does nothing if WriteHeader was called for this response.

      @exclude}
    procedure Flush; override;

    // You can call WriteHeader to send the Request header out.
    procedure WriteHeader(SendNow:boolean=True); overload; override;
    { You can call WriteHeader with empty 'HeaderText' parameter to
      tell the component that you do not want any HTTP header to be sent. }
    procedure WriteHeader(const HeaderText: string; SendNow:boolean=True); overload; override;

    // Use Write to send any Content (document body) out.
    procedure Write(const s:string=''); override;

  published
    { Maximum allowed size of the first response line, without header (0 = no limit).
      This is the first line in a HTTP response and includes Response.StatusCode and Response.StatusText }
    property MaxResponseSize:cardinal read FMaxResponseSize write FMaxResponseSize default 0;
    { Maximum allowed size of each response's header size (0 = no limit).
      This are all the remaining header lines in a HTTP response,
      which come after the first line and end with an empty line,
      after which usually comes the content (document body). }
    property MaxHeaderSize:cardinal read FMaxHeaderSize write FMaxHeaderSize default 0;

    { This event will be called if the received response exceeds your defined
      maximum response or header size. If both values are 0, this event will never be called. }
    property OnInvalidResponse:TRtcNotifyEvent read FOnInvalidResponse write FOnInvalidResponse;

    { TRtcMsgServer or any other component implementing the IRTCMessageReceiver interface. }
    property Server:TComponent read FServer write SetServer;
    end;

implementation

uses
  SysUtils,
  rtcConnProv,

  rtcMsgCliProv; // Message Client Provider

type
  TMyProvider = TRtcMsgClientProvider; // Message Client Provider

{ TRtcMessageClient }

constructor TRtcMessageClient.Create(AOwner: TComponent);
  begin
  inherited Create(AOwner);

  FWriteBuffer:=TRtcHugeString.Create;
  FWritten:=False;
  end;

destructor TRtcMessageClient.Destroy;
  begin
  FWriteBuffer.Free;
  inherited;
  end;

class function TRtcMessageClient.New: TRtcMessageClient;
  begin
  Result:=Create(nil);
  end;

function TRtcMessageClient.CreateProvider:TObject;
  begin
  if not assigned(Con) then
    begin
    Con:=TMyProvider.Create;
    SetTriggers;
    end;
  Result:=Con;
  end;

procedure TRtcMessageClient.SetParams;
  begin
  inherited;
  if assigned(Con) then
    begin
    TMyProvider(Con).Request:=Request;
    TMyProvider(Con).Response:=Response;
    TMyProvider(Con).MaxResponseSize:=MaxResponseSize;
    TMyProvider(Con).MaxHeaderSize:=MaxHeaderSize;
    end;
  end;

procedure TRtcMessageClient.SetTriggers;
  var
    MR:IRTCMessageReceiver;
  begin
  inherited;
  if assigned(Con) then
    begin
    if Server.GetInterface(IRTCMessageReceiverGUID, MR) then
      TMyProvider(Con).Server:=MR
    else
      raise Exception.Create('Server does NOT support the IRTCMessageReceiver interface!');

    {$IFDEF FPC}
      TMyProvider(Con).SetTriggerInvalidResponse(@TriggerInvalidResponse);
    {$ELSE}
      TMyProvider(Con).SetTriggerInvalidResponse(TriggerInvalidResponse);
    {$ENDIF}
    end;
  end;

procedure TRtcMessageClient.ClearTriggers;
  begin
  inherited;
  if assigned(Con) then
    begin
    TMyProvider(Con).Server:=nil;
    TMyProvider(Con).SetTriggerInvalidResponse(nil);
    end;
  end;

procedure TRtcMessageClient.WriteHeader(SendNow:boolean=True);
  begin
  if assigned(Con) and (State<>conInactive) then
    begin
    if Request.Active then
      raise Exception.Create('Error! Sending multiple headers for one request.');

    Timeout.DataSending;
    TMyProvider(Con).WriteHeader;
    end;
  end;

procedure TRtcMessageClient.WriteHeader(const HeaderText: string; SendNow:boolean=True);
  begin
  if assigned(Con) and (State<>conInactive) then
    begin
    if Request.Active then
      raise Exception.Create('Error! Sending multiple headers for one request.');

    Timeout.DataSending;
    TMyProvider(Con).WriteHeader(HeaderText);
    end;
  end;

procedure TRtcMessageClient.Write(const s: string='');
  begin
  if assigned(Con) and (State<>conInactive) then
    begin
    if Request.Complete then
      raise Exception.Create('Error! Answer allready sent for this request.');

    if Request.Active then
      begin
      { Header is out }

      if Request['Content-Length']<>'' then
        if Request.ContentLength - Request.ContentOut < length(s) then
          raise Exception.Create('Error! Sending more data out than specified in header.');

      { Data size is known or unimportant.
        We can just write the string out, without buffering }

      Con.Write(s);
      end
    else
      begin
      if (Request['CONTENT-LENGTH']<>'') and not FWritten then
        begin
        { Content length defined and no data buffered,
          send out header prior to sending first content bytes }
        WriteHeader(length(s)=0);
        if Request.ContentLength - Request.ContentOut < length(s) then
          raise Exception.Create('Error! Sending more data out than specified in header.');
        Con.Write(s);
        end
      else
        begin
        { Header is not out.
          Buffer all Write() operations,
          so we can determine content size and write it all out in a flush. }
        FWritten:=True;
        FWriteBuffer.Add(s);
        end;
      end;
    end;
  end;

procedure TRtcMessageClient.Flush;
  var
    Temp:string;
  begin
  if not FWritten then
    Exit
  else
    FWritten:=False; // so we don't re-enter this method.

  if assigned(Con) and (State<>conInactive) then
    begin
    Timeout.DataSending;

    if Request.Complete then
      raise Exception.Create('Error! Answer allready sent for this request.');

    if not Request.Active then
      begin
      if Request['CONTENT-LENGTH']='' then // length not specified
        begin
        Request.AutoLength:=True;
        Request.ContentLength:=FWriteBuffer.Size;
        end;

      TMyProvider(Con).WriteHeader;
      end;

    if FWriteBuffer.Size>0 then
      begin
      Temp:= FWriteBuffer.Get;
      FWriteBuffer.Clear;

      Con.Write(Temp);
      Temp:='';
      end;
    end;
  end;

procedure TRtcMessageClient.CallInvalidResponse;
  begin
  if assigned(OnInvalidResponse) then
    OnInvalidResponse(self);
  end;

procedure TRtcMessageClient.TriggerDataReceived;
  begin
  inherited;
  Flush;
  end;

procedure TRtcMessageClient.TriggerDataSent;
  begin
  if FWriteCount>0 then
    Timeout.DataSent;
  EnterEvent;
  try
    if FWriteCount>0 then
      begin
      CallDataSent;
      Flush;
      end;

    if not isClosing then
      begin
      CallReadyToSend;
      Flush;
      end;
  finally
    LeaveEvent;
    end;
  end;

procedure TRtcMessageClient.TriggerDataOut;
  begin
  inherited;
  Flush;
  end;

procedure TRtcMessageClient.TriggerInvalidResponse;
  begin
  EnterEvent;
  try
    CallInvalidResponse;
    Flush;

    Disconnect;
  finally
    LeaveEvent;
    end;
  end;

procedure TRtcMessageClient.SetRequest(const Value: TRtcClientRequest);
  begin
  inherited SetRequest(Value);
  if assigned(Con) then
    TMyProvider(Con).Request:=Request;
  end;

procedure TRtcMessageClient.SetResponse(const Value: TRtcClientResponse);
  begin
  inherited SetResponse(Value);
  if assigned(Con) then
    TMyProvider(Con).Response:=Response;
  end;

procedure TRtcMessageClient.LeaveEvent;
  begin
  inherited;
    if not InsideEvent then
      if assigned(Con) then
        TMyProvider(Con).LeavingEvent;
  end;

procedure TRtcMessageClient.SetServer(const Value: TComponent);
  var
    MR:IRTCMessageReceiver;
  begin
  if Value<>FServer then
    begin
    if not assigned(Value) then
      FServer:=nil
    else if assigned(Value) then
      if Value.GetInterface(IRTCMessageReceiverGUID, MR) then
        FServer:=Value
      else
        raise Exception.Create('Component does NOT support the IRTCMessageReceived interface!');
    end;
  end;

end.