rtcwsocksrvprov.pas

Delphi快速开发Web Server

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

  Server Connection Provider implementation using a modified version
  of TWSocket, TWSocketServer & TWSocketClient
  from F.Piette's Internet Component Suite (ICS).

  To implement a connection provider, we only need to extend the TRtcConnectionProvider class.

  Files used from F.Piette's Internet Component Suite (ICS) library:
    WSockBuf.pas
    WSocket.pas

  @exclude
}

unit rtcWSockSrvProv;

{$INCLUDE rtcDefs.inc}

interface

uses
  rtcTrashcan,

  Classes,
  SysUtils,

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

{$IFDEF CLR}
  DTkalcec.Ics.WSocket,
  DTkalcec.Ics.WSocketServer,
{$ELSE}
  WSocket_rtc, // WinSock classes
{$ENDIF}

  memBinList,
  memBinTree,

  rtcSyncObjs,
  rtcLog,
  rtcThrPool,

  rtcPlugins,
  rtcThrConnProv, // Threaded connection provider wrapper

  rtcConnProv, // Basic connection provider wrapper
  rtcConnLimit;

const
  LOG_REFUSED_CONNECTIONS:boolean=False;

type
  TRtcWSockServerProvider = class;

  TRtcWSockServerProtocol = (proTCP, proUDP);

  TRtcWSockClientThread = class(TRtcThread)
  public
    H_Sock: TSocket;
    Par: TRtcWSockServerProvider;
    _Silent: boolean;

    RtcConn: TRtcWSockServerProvider;

  public
    constructor Create; override;
    destructor Destroy; override;

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

  TRtcWSocketClient = class(TWSocketClient)
  public
    Thr: TRtcWSockClientThread;

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

  TRtcWSockServerThread = class(TRtcThread)
  public
    RtcConn: TRtcWSockServerProvider;
    Releasing: boolean;

  public
    constructor Create; override;
    destructor Destroy; override;

    procedure StartListen;
    procedure StopListen;

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

  TRtcWSocketServer = class(TWSocketServer)
  public
    Thr: TRtcWSockServerThread;

    procedure Call_FD_READ; override;
    procedure Call_FD_WRITE; override;
    procedure Call_FD_ACCEPT; override;
    end;

  TRtcWSockServerProvider = class(TRtcThrServerProvider)
  private
    FConnID:longint;

    Conn:TWSocket;

    FRawOut,
    FPlainOut:int64;

    FCryptPlugin: TRtcCryptPlugin;

    FProtocol: TRtcWSockServerProtocol;

    FReadBuff:string;

    FCS:TRtcCritSec;

    FClientList:tBinList;
    FThrList:tBinList;

    FMultiCast          : Boolean;
    FMultiCastAddrStr   : String;
    FReuseAddr          : Boolean;

    FListenerUp:boolean;

    Client_Thread: TRtcWSockClientThread;
    Server_Thread: TRtcWSockServerThread;

    FParent:TRtcWSockServerProvider;

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

    procedure wsOnSessionAvailable(Sender: TObject; ErrCode: Word);
    procedure wsOnSessionClosed(Sender: TObject; ErrCode: 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);

  protected

    procedure Enter; override;
    procedure Leave; override;

    function GetClientThread:TRtcThread; override;
    function GetServerThread:TRtcThread; override;

    procedure AddClient(Client:TRtcWSockServerProvider);
    procedure RemoveClient(Client:TRtcWSockServerProvider);
    procedure KillClients;

    function ClientCount:integer;

    procedure AddThread(Thr:TRtcThread);
    procedure RemoveThread(Thr:TRtcThread);
    procedure KillThreads;

    function _Active:boolean;
    function _Visible:boolean;

    procedure CopyFrom(Dup:TRtcConnectionProvider);

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

    procedure StartListener;

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

  public
    constructor Create; override;
    destructor Destroy; override;

    procedure Release; override;

    function GetParent:TRtcConnectionProvider; override;

    procedure Check; override;
    procedure InternalDisconnect; override;

    procedure Listen; override;
    procedure Disconnect; override;

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

    property Proto:TRtcWSockServerProtocol read FProtocol write FProtocol;

    property UdpMultiCast       : Boolean           read  FMultiCast
                                                    write FMultiCast;
    property UdpMultiCastAddr   : String            read  FMultiCastAddrStr
                                                    write FMultiCastAddrStr;
    property UdpReuseAddr       : Boolean           read  FReuseAddr
                                                    write FReuseAddr;

    property CryptPlugin        : TRtcCryptPlugin   read FCryptPlugin
                                                    write FCryptPlugin;
    end;

implementation

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

{ TRtcWSockClientThread }

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

var
  Message_WSAccept,
  Message_WSInit,
  Message_WSStop,
  Message_WSRelease_Silent,
  Message_WSRelease_Normal,
  Message_WSCloseConn,
  Message_WSRelease,
  Message_WSRead,
  Message_WSWrite,
  Message_WSClose:TRtcBaseMessage;


{ TRtcWSockServerProvider }

constructor TRtcWSockServerProvider.Create;
  begin
  inherited;

  FRawOut:=0;
  FPlainOut:=0;
  FConnID:=GetNextConnID;

  FCS:=TRtcCritSec.Create;

  FClientList:=TBinList.Create(128);
  FThrList:=TBinList.Create(128);

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

  FProtocol:=proTCP;
  FMultiCastAddrStr:='';

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

  FParent:=nil;

  FListenerUp:=False;

  Conn:=nil;
  end;

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

  Closing:=True;
  Silent:=True;

  try
    if assigned(Conn) then
      InternalDisconnect;

    if assigned(FParent) and not FParent.Silent then
      TriggerConnectionLost;

  finally
    SetLength(FReadBuff,0);

    FParent:=nil;
    FClientList.Free;
    FThrList.Free;
    FCS.Free;

    FPeerPort:='';
    FPeerAddr:='';
    FLocalPort:='';
    FLocalAddr:='';
    FMultiCastAddrStr:='';
    end;

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

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

  inherited;
  end;

procedure TRtcWSockServerProvider.CopyFrom(Dup: TRtcConnectionProvider);
  begin
  Proto:=TRtcWSockServerProvider(Dup).Proto;
  FCryptPlugin:=TRtcWSockServerProvider(Dup).FCryptPlugin;

  {$IFDEF FPC}
  Conn.OnBgException:=@wsOnBgException;
  {$ELSE}
  Conn.OnBgException:=wsOnBgException;
  {$ENDIF}

  if Conn is TWSocketServer then
    begin
    with Conn as TWSocketServer do
      begin
      case Proto of
        proTCP:Protocol:=spTcp;
        proUDP:Protocol:=spUdp;
        end;

      {$IFDEF FPC}
      OnSessionAvailable:=@wsOnSessionAvailable;
      OnChangeState:=@wsOnChangeState;
      {$ELSE}
      OnSessionAvailable:=wsOnSessionAvailable;
      OnChangeState:=wsOnChangeState;
      {$ENDIF}
      end;
    end
  else if Conn is TWSocketClient then
    begin
    with Conn as TWSocketClient do
      begin
      case Proto of
        proTCP:Protocol:=spTcp;
        proUDP:Protocol:=spUdp;
        end;

      {$IFDEF FPC}
      OnDataReceived:=@wsOnDataReceived;
      OnDataSent:=@wsOnDataSent;
      OnDataOut:=@wsOnDataOut;
      OnDataIn:=@wsOnDataIn;
      OnChangeState:=@wsOnChangeState;
      {$ELSE}
      OnDataReceived:=wsOnDataReceived;
      OnDataSent:=wsOnDataSent;
      OnDataOut:=wsOnDataOut;
      OnDataIn:=wsOnDataIn;
      OnChangeState:=wsOnChangeState;
      {$ENDIF}
      end;
    end;
  end;

procedure TRtcWSockServerProvider.Enter;
  begin
  FCS.Enter;
  end;

procedure TRtcWSockServerProvider.Leave;
  begin
  FCS.Leave;
  end;

procedure TRtcWSockServerProvider.Listen;
  begin
  if assigned(Server_Thread) then
    TRtcThread.PostJob(Server_Thread, Message_WSInit)
  else if GetMultiThreaded then
    begin
    Server_Thread := TRtcWSockServerThread.Create;
    Server_Thread.RtcConn:= self;
    TRtcThread.PostJob(Server_Thread,Message_WSInit);
    end
  else
    StartListener;
  end;

procedure TRtcWSockServerProvider.Disconnect;
  begin
  if assigned(Client_Thread) then
    TRtcThread.PostJob(Client_Thread, Message_WSRelease)
  else if assigned(Server_Thread) then
    TRtcThread.PostJob(Server_Thread, Message_WSCloseConn)
  else
    begin
    Lost:=False;
    InternalDisconnect;
    end;
  end;

procedure TRtcWSockServerProvider.InternalDisconnect;
  var
    myCon2:TWSocket;
    s_out:string;
  begin
  if Conn=nil then
    begin
    Closing:=True;
    Exit;
    end;

  if Conn is TWSocketServer then
    begin
    with Conn as TWSocketServer do
      begin
      OnBgException:=nil;
      OnChangeState:=nil;

      OnSessionAvailable:=nil;
      end;

    Closing:=True;
    State:=conInactive;

    if FListenerUp then
      begin
      FListenerUp:=False;
      if not Silent then
        TriggerListenStop;
      end;

    myCon2:=Conn;
    Conn:=nil;  // hide connections from component

    if GetMultiThreaded then
      KillThreads
    else
      KillClients;

    try
      myCon2.Close;
    except
      on E:Exception do
        if LOG_SOCKET_ERRORS then
          Log('WSockServerProvider.InternalDisconnect: MyCon2.Close',E);
      end;
    try
      myCon2.Release;
    except
      on E:Exception do
        if LOG_AV_ERRORS then
          Log('WSockServerProvider.InternalDisconnect: MyCon2.Release',E);
      end;

    if Lost then
      TriggerListenLost;

    {if assigned(Server_Thread) then
      begin
      Server_Thread.RtcConn:=nil;
      Server_Thread.Stop;
      Server_Thread:=nil;
      end;}
    TriggerReadyToRelease;
    end
  else if State in [conActive,conActivating] then
    begin
    if State=conActive then
      State:=conClosing
    else
      State:=conInactive;

    with Conn do // deactivate all events for this client connection
      begin
      OnBgException:=nil;

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

    if not Closing then
      begin
      if assigned(FCryptPlugin) then
        begin
        s_out:='';
        FCryptPlugin.BeforeDisconnect(FConnID,s_out);
        if s_out<>'' then
          begin
          DirectWrite(s_out);
          s_out:='';
          end;
        end;
      wsOnSessionClosed(self,0);
      end
    else
      begin
      myCon2:=Conn;
      Conn:=nil;

      try
        MyCon2.Close;
      except
        on E:Exception do
          if LOG_SOCKET_ERRORS then
            Log('WSockServerProvider.InternalDisconnect: MyCon.Close',E);
        end;
      try
        MyCon2.Release;
      except
        on E:Exception do
          if LOG_AV_ERRORS then
            Log('WSockServerProvider.InternalDisconnect: MyCon.Release',E);
        end;
      end;
    end;
  end;

procedure TRtcWSockServerProvider.wsOnDataOut(Sender: TObject; Len: Cardinal);
  begin
  if _Visible then
    begin
    if (State=conListening) and (Proto=proUDP) then
      begin
      FDataOut:=Len;
      TriggerDataOut;
      TriggerReadyToRelease;
      end
    else 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;
      end;
    end;
  end;

procedure TRtcWSockServerProvider.wsOnDataIn(Sender: TObject; Len: Cardinal);
  begin
  if _Visible then
    begin
    if (State=conListening) and (Proto=proUDP) then
      begin
      FDataIn:=Len;
      TriggerDataIn;
      TriggerReadyToRelease;
      end
    else if State=conActive then
      begin
      if not assigned(FCryptPlugin) then
        begin
        FDataIn:=Len;
        TriggerDataIn;
        TriggerReadyToRelease;
        end;
      end;
    end;
  end;

function TRtcWSockServerProvider.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 TRtcWSockServerProvider.Write(const s: string; SendNow:boolean=True);
  var
    s_out:string;
  begin
  if Closing then
    Exit;

  if Conn=nil then