rtcwsockcliprov.pas

Delphi快速开发Web Server

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

  Client connection provider implementation using a modified
  TWSocket class from F.Piette's Internet Component Suite (ICS).

  @exclude
}
unit rtcWSockCliProv;

{$INCLUDE rtcDefs.inc}

interface

uses
  rtcTrashcan,
  
  Classes,
  SysUtils,

  // Windows, Messages, // Windows and Messages units are used only in Multithreading, to send messages

  rtcSyncObjs,
{$IFDEF CLR}
  DTkalcec.Ics.WSocket,
{$ELSE}
  WSocket_rtc, // Client Socket
{$ENDIF}

  rtcLog,
  rtcConnProv, // Basic connection provider wrapper
  rtcConnLimit,

  rtcPlugins,
  rtcThrPool,
  rtcThrConnProv; // Threaded connection provider wrapper

type
  TRtcWSockClientProvider = class;

  TRtcWSockClientProtocol = (proTCP, proUDP);

  TRtcWSockClientThread = class(TRtcThread)
  public
    RtcConn: TRtcWSockClientProvider;
    Releasing: boolean;

  public
    constructor Create; override;
    destructor Destroy; override;

    procedure OpenConn;
    procedure CloseConn(_lost:boolean);

    function Work(Job:TObject):boolean; override;
    procedure Kill(Job:TObject); override;
    end;

  TRtcWSocketClient = class(TWSocketClient)
  public
    Thr: TRtcWSockClientThread;

    procedure Call_FD_CONNECT(Err:word); override;
    procedure Call_FD_CLOSE(Err:word); override;
    procedure Call_FD_READ; override;
    procedure Call_FD_WRITE; override;
    end;

  TRtcWSockClientProvider = class(TRtcThrClientProvider)
  private
    FConnID:longint;

    Conn:TWSocket;

    FProtocol: TRtcWSockClientProtocol;

    FRawOut,
    FPlainOut:int64;

    FCryptPlugin: TRtcCryptPlugin;

    FReadBuff:string;

    FCS:TRtcCritSec;

    Client_Thread : TRtcWSockClientThread;

    FMultiCast          : Boolean;
    FMultiCastIpTTL     : Integer;
    FReuseAddr          : Boolean;

    procedure wsOnBgException(Sender: TObject; E: Exception; var CanClose: Boolean);
    procedure wsOnChangeState(Sender: TObject; OldState,NewState: TSocketState);

    procedure wsOnSessionClosed(Sender: TObject; ErrorCode: Word);

    procedure wsOnDataReceived(Sender: TObject; ErrCode: Word);
    procedure wsOnDataSent(Sender: TObject; ErrCode: Word);
    procedure wsOnDataOut(Sender: TObject; Len: cardinal);
    procedure wsOnDataIn(Sender: TObject; Len: cardinal);

    procedure OpenConnection(Force:boolean);

  protected

    procedure Enter; override;
    procedure Leave; override;

    function _Active:boolean;
    function _Visible:boolean;

    function PostWrite(HighPriority:boolean=False):boolean;
    function PostRead(HighPriority:boolean=False):boolean;

    function GetClientThread:TRtcThread; override;

    procedure DirectWrite(const s:string);
    procedure BufferWrite(const s:string);

  public
    constructor Create; override;
    destructor Destroy; override;

    procedure Release; override;

    procedure Connect(Force:boolean=False); override;

    procedure InternalDisconnect; override;
    procedure Disconnect; override;

    procedure Check; override;

    function Read: string; override;
    procedure Write(const s: string; sendNow:boolean=True); override;

    property Proto:TRtcWSockClientProtocol read FProtocol write FProtocol;

    property UdpMultiCast       : Boolean           read  FMultiCast
                                                    write FMultiCast;
    property UdpMultiCastMaxHops: Integer           read  FMultiCastIpTTL
                                                    write FMultiCastIpTTL;
    property UdpReuseAddr       : Boolean           read  FReuseAddr
                                                    write FReuseAddr;
    property CryptPlugin        : TRtcCryptPlugin   read FCryptPlugin
                                                    write FCryptPlugin;
    end;

implementation

{$IFDEF CLR}
uses
  System.Security;
{$ENDIF}

{ TRtcWSockClientThread }

type
  TRtcBaseMessage=class
    end;
  TRtcInfoMessage=class(TRtcBaseMessage)
  public
    Error:word;
    constructor Create(Value:word);
    end;
  TRtcCloseMessage=class(TRtcInfoMessage)
    end;
  TRtcConnectMessage=class(TRtcInfoMessage)
    end;

var
  Message_WSStop,
  Message_WSRelease,
  Message_WSOpenConn,
  Message_WSCloseConn,
  Message_WSConnect,
  Message_WSClose,
  Message_WSRead,
  Message_WSWrite:TRtcBaseMessage;

{ TRtcWSockClientProvider }

constructor TRtcWSockClientProvider.Create;
  begin
  inherited;

  FRawOut:=0;
  FPlainOut:=0;

  FConnID:=GetNextConnID;

  FCS:=TRtcCritSec.Create;

  Closing:=False;

  FPeerPort:='';
  FPeerAddr:='0.0.0.0';
  FLocalPort:='';
  FLocalAddr:='0.0.0.0';

  FProtocol:=proTCP;
  UdpMultiCastMaxHops:=1;

  FReadBuff:='';
  SetLength(FReadBuff, WSOCK_READ_BUFFER_SIZE);

  Conn:=nil;
  end;

destructor TRtcWSockClientProvider.Destroy;
  begin
  { Before destroying this connection object,
    we will disconnect this and all related open connections. }

  Closing:=True;
  Silent:=True;

  if assigned(Conn) then
    InternalDisconnect;

  TriggerConnectionClosing;

  if assigned(Client_Thread) then
    TRtcThread.PostJob(Client_Thread, Message_WSStop, True);

  SetLength(FReadBuff,0);
  FCS.Free;

  inherited;
  end;

procedure TRtcWSockClientProvider.Enter;
  begin
  FCS.Enter;
  end;

procedure TRtcWSockClientProvider.Leave;
  begin
  FCS.Leave;
  end;

function TRtcWSockClientProvider.Read: string;
  var
    len:longint;
    s_in, s_out:string;
  begin
  if Proto=proTCP then
    begin
    len:=Conn.Receive(FReadBuff[1], length(FReadBuff));
    if len<=0 then
      Result:=''
    else if assigned(FCryptPlugin) then
      begin
      // Decrypt input data ...
      SetLength(s_in,len);
      Move(FReadBuff[1],s_in[1],len);
      s_out:=''; Result:='';
      FCryptPlugin.DataReceived(FConnID, s_in, s_out, Result);
      if length(Result)>0 then
        begin
        // Trigger the "OnDataIn" event ...
        FDataIn:=length(Result);
        TriggerDataIn;
        end;
      if s_out<>'' then
        DirectWrite(s_out);
      end
    else
      begin
      SetLength(Result,len);
      Move(FReadBuff[1],Result[1],len);
      end;
    end
  else
    begin
    Result:=FReadBuff;
    FReadBuff:='';
    end;
  end;

procedure TRtcWSockClientProvider.Write(const s: string; SendNow:boolean=True);
  var
    s_out:string;
  begin
  if Closing then
    Exit;

  if Conn=nil then
    Error('Not connected.');

  if assigned(FCryptPlugin) then
    begin
    FCryptPlugin.DataToSend(FConnID,s,s_out);
    Inc(FPlainOut, length(s));
    if s_out<>'' then
      DirectWrite(s_out);
    end
  else if SendNow then
    DirectWrite(s)
  else
    BufferWrite(s);
  end;

procedure TRtcWSockClientProvider.DirectWrite(const s: string);
  var
    len:integer;
  begin
  if RTC_LIMIT_CONN and assigned(Client_Thread) then
    if not rtcStartAction(Client_Thread, RTC_ACTION_WRITE) then
      begin
      if assigned(FCryptPlugin) then
        Inc(FRawOut, length(s));
      len:=Conn.BuffStr(s);
      if len<0 then
        Error('Error #'+IntToStr(Conn.LastError)+': '+WSocketErrorDesc(Conn.LastError))
      else if len<length(s) then
        Error('Wanted to write '+IntToStr(length(s))+' bytes, written only '+IntToStr(len)+' bytes.');

      PostWrite(True);
      Exit;
      end;

  if assigned(FCryptPlugin) then
    Inc(FRawOut, length(s));
  len:=Conn.SendStr(s);
  if len<0 then
    Error('Error #'+IntToStr(Conn.LastError)+': '+WSocketErrorDesc(Conn.LastError))
  else if len<length(s) then
    Error('Wanted to write '+IntToStr(length(s))+' bytes, written only '+IntToStr(len)+' bytes.');
  end;

procedure TRtcWSockClientProvider.BufferWrite(const s: string);
  var
    len:integer;
  begin
  if assigned(FCryptPlugin) then
    Inc(FRawOut, length(s));
  len:=Conn.BuffStr(s);
  if len<0 then
    Error('Error #'+IntToStr(Conn.LastError)+': '+WSocketErrorDesc(Conn.LastError))
  else if len<length(s) then
    Error('Wanted to write '+IntToStr(length(s))+' bytes, written only '+IntToStr(len)+' bytes.');
  end;

procedure TRtcWSockClientProvider.wsOnChangeState(Sender: TObject; OldState, NewState: TSocketState);
  var
    s_out:string;
  begin
  if Closing then Exit;

  if assigned(Conn) then
    if NewState=wsConnected then
      begin
      if Proto=proTCP then
        begin
        FLocalAddr:=Conn.GetXAddr;
        if FLocalAddr<>'0.0.0.0' then
          begin
          FLocalPort:=Conn.GetXPort;
          FPeerAddr:=Conn.GetPeerAddr;
          FPeerPort:=Conn.GetPeerPort;
          TriggerConnecting;
          end;
        end
      else
        begin
        FLocalAddr:='127.0.0.1';
        FLocalPort:=Conn.GetXPort;
        FPeerAddr:=Conn.GetPeerAddr;
        FPeerPort:=Conn.GetPeerPort;
        TriggerConnecting;

        State:=conActive;

        if assigned(FCryptPlugin) then
          begin
          s_out:='';
          FCryptPlugin.AfterConnect(FConnID,s_out);
          if s_out<>'' then
            begin
            DirectWrite(s_out);
            s_out:='';
            end;
          end;
        TriggerConnect;
        end;
      end
    else if NewState=wsClosed then
      wsOnSessionClosed(Sender, 0);
  end;

procedure TRtcWSockClientProvider.wsOnSessionClosed(Sender: TObject; ErrorCode:Word);
  begin
  { Client connection closed.

    This method is called when one of the active connections get closed.
    It handles connections closing for all active connection types
    (incomming and outgoing connections). }

  TriggerDisconnecting;

  if assigned(Conn) and not Closing then // Connection object still here ?
    begin
    Closing:=True; // Let everyone know we are closing now ...

    try
      TriggerConnectionClosing;

      if State in [conInactive,conActivating] then // Connection still not activated,
        TriggerConnectFail // we have a "Failed connection" here, rather then a Disconnect.
      else
        begin
        if assigned(FCryptPlugin) then
          FCryptPlugin.AfterDisconnect(FConnID);

        TriggerDisconnect;
        if Lost then
          TriggerConnectLost;
        end;
    finally

      State:=conInactive;

      { We need to remove all events from this connection
        before we can actually destroy our own connection object. }
      with Conn do
        begin
        OnBgException:=nil;

        OnChangeState:=nil;

        OnDataReceived:=nil;
        OnDataSent:=nil;
        OnDataOut:=nil;
        OnDataIn:=nil;
        end;

      try
        Conn.Close;
      except
        on E:Exception do
          if LOG_SOCKET_ERRORS then
            Log('WSockClientProvider.OnSessionClosed: Conn.Close',E); // ignore all errors here
        end;
      try
        Conn.Release;
      except
        on E:Exception do
          if LOG_AV_ERRORS then
            Log('WSockClientProvider.OnSessionClosed: Conn.Release',E); // ignore all errors here
        end;
      Conn:=nil;

      TriggerReadyToRelease;
      end;
    end;
  end;

procedure TRtcWSockClientProvider.wsOnDataReceived(Sender: TObject; ErrCode: Word);
  var
    len:integer;
    s_out:string;
  begin
  if _Visible then
    begin
    if (State=conActivating) then // call "Connected" only after we know that we can relly send data.
      begin
      if FLocalAddr<>'0.0.0.0' then
        begin
        State:=conActive;

        if assigned(FCryptPlugin) then
          begin
          s_out:='';
          FCryptPlugin.AfterConnect(FConnID,s_out);
          if s_out<>'' then
            begin
            DirectWrite(s_out);
            s_out:='';
            end;
          end;

        TriggerConnect;
        end;
      end;

    if State=conActive then
      begin
      if Proto=proUDP then
        begin
        len:=Conn.GetRcvdCount;
        if len>=0 then
          begin
          SetLength(FReadBuff,len);
          len:=Conn.Receive(FReadBuff[1], length(FReadBuff));

          FPeerPort:=Conn.GetSrcPort;
          FPeerAddr:=Conn.GetSrcAddr;

          if len<0 then
            begin
            FReadBuff:='';
            TriggerDataLost;
            TriggerReadyToRelease;
            end
          else
            begin
            if len<>length(FReadBuff) then
              SetLength(FReadBuff,len);
            TriggerDataReceived;
            TriggerReadyToRelease;
            end;
          end
        else
          begin
          FReadBuff:='';
          TriggerDataLost;
          TriggerReadyToRelease;
          end;
        end
      else
        begin
        TriggerDataReceived;
        TriggerReadyToRelease;
        end;
      end;
    end;
  end;

procedure TRtcWSockClientProvider.wsOnDataSent(Sender: TObject; ErrCode: Word);
  var
    s_out:string;
  begin
  if _Visible then
    begin
    if (State=conActivating) then // call "Connected" only after we know that we can relly send data.
      begin
      if FLocalAddr<>'0.0.0.0' then
        begin
        State:=conActive;

        if assigned(FCryptPlugin) then
          begin
          s_out:='';
          FCryptPlugin.AfterConnect(FConnID,s_out);
          if s_out<>'' then
            begin
            DirectWrite(s_out);
            s_out:='';
            end;
          end;

        TriggerConnect;
        end;
      end;

    if State=conActive then // do not call this when it comes for the first time, if we haven't been sending anything out yet.
      begin
      TriggerDataSent;
      TriggerReadyToRelease;
      end;
    end;
  end;

procedure TRtcWSockClientProvider.wsOnDataOut(Sender: TObject; Len: cardinal);
  begin
  if _Visible then
    begin
    if State=conActive then
      begin
      if assigned(FCryptPlugin) then
        begin
        Dec(FRawOut,Len);
        if (FRawOut=0) and (FPlainOut>0) then
          begin
          FDataOut:=FPlainOut;
          FPlainOut:=0;
          TriggerDataOut;
          TriggerReadyToRelease;
          end;
        end
      else
        begin
        FDataOut:=Len;
        TriggerDataOut;
        TriggerReadyToRelease;
        end;