rtcmsgsrvprov.pas

Delphi快速开发Web Server

{
  "Message Server Connection Provider" - Copyright (c) Danijel Tkalcec
  @html(<br>)

  @exclude
}
unit rtcMsgSrvProv;

{$INCLUDE rtcDefs.inc}

interface

uses
  Windows, Classes, SysUtils,

  rtcFastStrings,
  rtcLog, rtcSyncObjs, rtcConn,
  rtcConnProv, rtcThrConnProv;

type
  TRtcMessageServerProvider = class(TRtcNoThrServerProvider)
  private
    FRequestLine,
    FHaveRequest:boolean;
    InBuffer:string;
    LenToRead:integer;

    OutStream:TStream;

    FCS:TRtcCritSec;
    FRequest:TRtcServerRequest;
    FResponse:TRtcServerResponse;

    FRequestBuffer:TRtcHugeString;

    LenToWrite:int64; // number of bytes to write out using inherited Write()
    LenToSend:int64;

    FHeaderOut:boolean;

  protected
    procedure Enter; override;
    procedure Leave; override;

    procedure CopyFrom(Dup:TRtcConnectionProvider);

  public
    constructor Create; override;
    destructor Destroy; override;

    function GetParent:TRtcConnectionProvider; override;

    procedure Connect;
    procedure ExecuteRequest(InStream, _OutStream:TStream);

    procedure Listen; override;
    procedure Disconnect; override;
    procedure InternalDisconnect; override;

    procedure TriggerDataSent; override;
    procedure TriggerDataOut; override;

    procedure WriteHeader; overload;
    procedure WriteHeader(const Header_Text:string); overload;

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

    property Request:TRtcServerRequest read FRequest write FRequest;
    property Response:TRtcServerResponse read FResponse write FResponse;
    end;

implementation

{ TRtcMessageServerProvider }

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

constructor TRtcMessageServerProvider.Create;
  begin
  inherited;
  FCS:=TRtcCritSec.Create;

  FRequestLine:=False;
  FHaveRequest:=False;
  InBuffer:='';
  LenToRead:=0;

  FRequestBuffer:=TRtcHugeString.Create;

  LenToWrite:=0;
  LenToSend:=0;
  FHeaderOut:=False;

  FRequest:=nil;
  FResponse:=nil;
  end;

destructor TRtcMessageServerProvider.Destroy;
  begin
  Enter;
  try
    FRequestBuffer.Free;

    LenToWrite:=0;
    LenToSend:=0;
    FHeaderOut:=False;
  finally
    Leave;
    FCS.Free;
    FCS:=nil;
    end;
  inherited;
  end;

procedure TRtcMessageServerProvider.WriteHeader;
  var
    s:string;
  begin
  if FHeaderOut then
    raise Exception.Create('Last header intercepted with new header, before data sent out.');

  s:='HTTP/1.1 '+IntToStr(Response.StatusCode)+' '+Response.StatusText+CRLF+
     Response.HeaderText;

  if Request.Close then s:=s+'Connection: close'+CRLF;

  s:=s+CRLF;

  Response.Sending:=True;
  Response.Started:=True;

  if Response.SendContent and
    (Response['CONTENT-LENGTH']='')  then // streaming data
    begin
    raise Exception.Create('Streaming content not supported by a Message Server.');
    LenToWrite:=-1;
    LenToSend:=-1;
    end
  else
    begin
    if not Response.SendContent then
      Response['CONTENT-LENGTH']:='';

    LenToWrite:=Response.ContentLength;
    LenToSend:=LenToWrite;
    end;

  Response.Sent:=LenToWrite=0;
  if Response.Sent then
    TriggerLastWrite;

  FHeaderOut:=True;

  OutStream.Write(s[1], length(s));

  FDataOut:=0;
  if Response.Sent then
    try
      TriggerDataOut;
    finally
      TriggerDataSent;
    end;
  end;

procedure TRtcMessageServerProvider.WriteHeader(const Header_Text:string);
  var
    s:string;
  begin
  if FHeaderOut then
    raise Exception.Create('Last header intercepted with new header, before data sent out.');

  if Header_Text<>'' then
    begin
    Response.HeaderText:=Header_Text;

    s:='HTTP/1.1 '+IntToStr(Response.StatusCode)+' '+Response.StatusText+CRLF+
       Response.HeaderText;
    if Request.Close then s:=s+'Connection: close'+CRLF;
    s:=s+CRLF;
    end
  else
    begin
    raise Exception.Create('Streaming content not supported by a Message Server.');
    s:='';
    Request.Close:=True;
    end;

  Response.Sending:=True;
  Response.Started:=True;

  if Response.SendContent and
    (Response['CONTENT-LENGTH']='')  then // streaming data
    begin
    raise Exception.Create('Streaming content not supported by ISAPI.');
    LenToWrite:=-1;
    LenToSend:=-1;
    end
  else
    begin
    if not Response.SendContent then
      Response['CONTENT-LENGTH']:='';

    LenToWrite:=Response.ContentLength;
    LenToSend:=LenToWrite;
    end;

  Response.Sent:=LenToWrite=0;
  if Response.Sent then
    TriggerLastWrite;

  FHeaderOut:=True;

  OutStream.Write(s[1], length(s));

  if Response.Sent then
    begin
    FDataOut:=0;
    try
      TriggerDataOut;
    finally
      TriggerDataSent;
      end;
    end;
  end;

procedure TRtcMessageServerProvider.Write(const ResultData: string; SendNow:boolean=True);
  var
    len:cardinal;
  begin
  if length(ResultData)=0 then Exit;

  if not FHeaderOut then
    raise Exception.Create('Trying to send Data without Header. Call WriteHeader before Write.');

  if LenToWrite>=0 then
    begin
    if length(ResultData)>LenToWrite then
      raise Exception.Create('Trying to send more Data out than specified in Header.');

    Dec(LenToWrite, length(ResultData));
    end;

  Response.Sent:=LenToWrite=0;
  Response.ContentOut:=Response.ContentOut + length(ResultData);

  if Response.Sent then
    TriggerLastWrite;

  len:=length(ResultData);
  OutStream.Write(ResultData[1],length(ResultData));

  FDataOut:=len;
  try
    TriggerDataOut;
  finally
    FDataOut:=0;
    TriggerDataSent;
    end;
  end;

function TRtcMessageServerProvider.Read: string;
  begin
  if FRequestBuffer.Size>0 then
    begin
    Result:=FRequestBuffer.Get;
    FRequestBuffer.Clear;
    end
  else
    Result:='';
  end;

procedure TRtcMessageServerProvider.TriggerDataSent;
  begin
  if Response.Sending then
    Response.Started:=False;

  inherited TriggerDataSent;
  end;

procedure TRtcMessageServerProvider.TriggerDataOut;
  begin
  if Response.Sending then
    begin
    if LenToSend>=0 then
      begin
      Dec(LenToSend, DataOut);
      Response.Done := LenToSend=0;
      end;

    if Response.Done then
      begin
      Request.Started:=False;
      Request.Active:=False;
      Response.Started:=False;
      Response.Sending:=False;
      FHeaderOut:=False;
      end;
    end;

  inherited TriggerDataOut;
  end;

function TRtcMessageServerProvider.GetParent: TRtcConnectionProvider;
  begin
  Result:=nil;