Componentes.Terceros.RemObjects/official/5.0.35.741/RemObjects SDK for Delphi/Source/uROSynapseServerSocket.pas

unit uROSynapseServerSocket;

{$I RemObjects.inc}

interface
uses
  SysUtils, Classes, blcksock, synsock, uROThreadPool;

type
  TRONewSocketEvent = function (Sender: TObject; aSock: TSocket): TTCPBlockSocket of object;
  TRONewConnection = procedure (Sender: TObject; aSocket: TTCPBlockSocket) of object;
  TROSynapseServerSocket = class
  private
    fSock: TTCPBlockSocket;
    fActive: Boolean;
    fMaxThreads: Integer;
    fThreads: TThreadList;
    fListenThread: TThread;
    fBindList: TStrings;
    fOnNewSocket: TRONewSocketEvent;
    fOnNewConnection: TRONewConnection;
    fPort: Integer;
    procedure SetActive(aValue: Boolean);
  protected

  public
    constructor Create;
    destructor Destroy; override;

    property OnNewSocket: TRONewSocketEvent read fOnNewSocket write fOnNewSocket; // to be used to say setup ssl
    property OnNewConnection: TRONewConnection read fOnNewConnection write fOnNewConnection;

    property Active: Boolean read fActive write SetActive;
    property Sock: TTCPBlockSocket read fSock;
    property MaxThreads: Integer read fMaxThreads write fMaxThreads;
    property BindList: TStrings read fBindList;
    property Port: Integer read fPort write fPort; // for when the bindlist is empty
  end;

implementation
uses
  uROClasses;

type
  TSynapseListenThread = class(TROInitializedThread)
  private
    fOwner: TROSynapseServerSocket;
  public
    constructor Create(aOwner: TROSynapseServerSocket);
    procedure Execute; override;
  end;
  TSynapseClientThread = class(TROInitializedThread)
  private
    fOwner: TROSynapseServerSocket;
    fSock: TTCPBlockSocket;
  protected
    procedure Execute; override;
  public
    constructor Create(aOwner: TROSynapseServerSocket; aSock: TTCPBlockSocket);
    procedure Close;
    destructor Destroy; override;
  end;

{ TROSynapseServerSocket }

constructor TROSynapseServerSocket.Create;
begin
  fSock := TTCPBlockSocket.Create;
  fThreads := TThreadList.Create;
  fMaxThreads := 100;
  fBindList := TStringList.Create;
end;

destructor TROSynapseServerSocket.Destroy;
var
  i: Integer;
  lList: TList;
begin
  lList := fThreads.LockList;
  try
    for i := 0 to lList.Count -1 do begin
      TSynapseClientThread(lList[i]).Close;
    end;
  finally
    fThreads.UnlockList;
  end;
  Sleep(10);
  while true do begin
    if fThreads.LockList.Count = 0 then begin
      fThreads.UnlockList;
      break;
    end;
    fThreads.UnlockList;
    Sleep(10);
  end;

  Active := false;
  fThreads.Free;
  fBindList.Free;
  fSock.Free;

  inherited Destroy;
end;

procedure TROSynapseServerSocket.SetActive(aValue: Boolean);
var
  i: Integer;
  s1,s2: string;
begin
  if fActive = aValue then exit;
  if aValue then begin
    fSock.CreateSocket;
    if fBindList.Count = 0 then
      fSock.Bind('0.0.0.0', IntTostr(fPort))
    else begin
      for i := 0 to fBindList.Count -1 do begin
        s2 := fBindList[i];
        s1 := copy(s2, 1, pos(':', s2) -1);
        Delete(s2, 1, pos(':', s2));
      end;
      fSock.Bind(s1,s2);
    end;
    fSock.Listen;
    fListenThread := TSynapseListenThread.Create(self);
  end else begin
    fSock.CloseSocket;
    fListenThread.Free;
    fListenThread := nil;
  end;
  fActive := aValue;
end;

{ TSynapseListenThread }

constructor TSynapseListenThread.Create(aOwner: TROSynapseServerSocket);
begin
  inherited Create(True);
  fOwner := aOwner;
  FreeOnTerminate := false;
  resume;
end;


procedure TSynapseListenThread.Execute;
var
  lSock: TSocket;
  lList: TList;
  lRealSock: TTCPBlockSocket;
begin
  while not Terminated do begin
    lSock := fOwner.fSock.Accept;
    if (lSock = 0) or (lSock = INVALID_SOCKET) then break;
    lList := fOwner.fThreads.LockList;
    try
      if lList.Count >= fOwner.fMaxThreads then begin
        CloseSocket(lSock);
      end else begin
        if @fOwner.fOnNewSocket <> nil then
          lRealSock := fOwner.fOnNewSocket(fOwner, lSock)
        else begin
          lRealSock := TTCPBlockSocket.Create;
          lRealSock.Socket := lSock;
        end;
        if lRealSock = nil then begin
          CloseSocket(lSock);
        end else begin
          lList.Add(TSynapseClientThread.Create(fOwner, lRealSock));
        end;
      end;
    finally
      fOwner.fThreads.UnlockList;
    end;
  end;
end;

{ TSynapseClientThread }

procedure TSynapseClientThread.Close;
begin
  fSock.AbortSocket;
  terminate;
end;

constructor TSynapseClientThread.Create(aOwner: TROSynapseServerSocket;
  aSock: TTCPBlockSocket);
begin
  inherited Create(True);
  fOwner := aOwner;
  fSock := aSock;
//  fOwner.fThreads.Add(Self);
  FreeOnTerminate := true;
  Resume;
end;

destructor TSynapseClientThread.Destroy;
begin
  fOwner.fThreads.Remove(Self);
  fSock.Free;
  inherited;
end;

procedure TSynapseClientThread.Execute;
begin
  if @fOwner.fOnNewConnection <> nil then
    fOwner.fOnNewConnection(fOwner, fSock);
end;

end.