unaconfserver.pas

Voice Commnucation Components for Delphi

(*
	----------------------------------------------

	  unaConfServer.pas - ConfServer class
	  Voice Communicator components version 2.5

	----------------------------------------------
	  This source code cannot be used without
	  proper license granted to you as a private
	  person or an entity by the Lake of Soft, Ltd

	  Visit http://lakeofsoft.com/ for more information.

	  Copyright (c) 2001, 2007 Lake of Soft, Ltd
		     All rights reserved
	----------------------------------------------

	  created by:
		Lake, 08 Jul 2003

	  modified by:
		Lake, Jul, Dec 2003
		Lake, Jan, Feb 2004
		Lake, May-Oct 2005
		Lake, Mar-Jun 2006
		Lake, Apr 2007

	----------------------------------------------

*)

{$I unaDef.inc }

{*** $DEFINE USE_INSTALLABLE_DRIVERS }	// define to force codecs to use installable drivers rather than default ACM drivers

{$IFDEF DEBUG }
  {xx $DEFINE CS_LOG_MAX }		// enable extensive logging
  {xx $DEFINE DEBUG_NASTY_EXCEPTION }	// enable exceptions additional info log
  {xx $DEFINE DEBUG_EXTRA_DELAY } 	// include additional random delay in send thread for debugging
  {xx $DEFINE DEBUG_DUMMY_CODEC }	// use dummy installable driver for debugging
{$ENDIF }

unit
  unaConfServer;

interface

uses
  Windows, unaTypes, unaUtils, unaClasses, unaMsAcmClasses, unaVcIDE;

var
  c_maxClients: uint = 15;

const
  c_maxClientsLimit	= 100;

  c_defSamplingRate	= 8000;
  c_defBitsPerSample	= 16;
  c_defNumChannels	= 1;


  c_ticksPerSecond	= 10;


  c_outFormatTag	= 49;	// GSM - this codec will be used by default to compress
				// audio sent back to clients

  // -- error codec --
  c_unaconfserr_unknownDriver	= 1;
  c_unaconfserr_driverNotFound	= 2;
  c_unaconfserr_driverFound	= 3;

type
  // ahead declaration
  unaConfServerClass = class;

  //
  // -- some overrides --
  //
  unaConfIPServer = class(TunavclIPInStream)
  private
    f_master: unaConfServerClass;
  protected
    function onNewPacket(const packet: unavclInOutIPPacket; connId: unsigned): bool; override;
    procedure doAcceptClient(connId: unsigned; var accept: bool); override;
    procedure doServerClientConnection(connId: unsigned; isConnected: bool); override;
  public
    constructor createServer(master: unaConfServerClass);
  end;


  //
  // -- unaConfServerClient --
  //
  unaConfServerClient = record
    //
    r_connId: unsigned;
    r_codecIn: TunavclWaveCodecDevice;
    r_codecOut: TunavclWaveCodecDevice;
    r_mixerStream: unaAbstractStream;
  end;

  //
  //
  tunaConfError = procedure(sender: tObject; errorCode, errorInfo: int) of object;


  //
  // -- unaCSSendThreadRecord --
  //
  punaCSSendThreadRecord = ^unaCSSendThreadRecord;
  unaCSSendThreadRecord = packed record
    //
    r_connId: uint;
    r_cmdu: uint;
    r_data: pointer;
    r_lenu: uint;
  end;


  //
  // -- unaCSSendThread --
  //
  unaCSSendThread = class(unaThread)
  private
    f_sentOK: array[0..c_maxClientsLimit - 1] of int64;
    f_records: unaRecordList;
    f_master: unaConfServerClass;
    f_sentFail: array[0..c_maxClientsLimit - 1] of int64;
  protected
    function execute(threadId: uint): int; override;
  public
    constructor create(master: unaConfServerClass);
    procedure AfterConstruction(); override;
    procedure BeforeDestruction(); override;
    //
    function addSendRecord(connId: uint; cmd: uint; data: pointer; len: uint): bool;
  end;


  //
  // -- unaConfServerClass --
  //
  unaConfServerClass = class(unaMMTimer)
  private
    f_mixBuf: pArray;
    f_mixBufSize: unsigned;
    f_bcMixed: int64;
    //
    f_bytesSent: int64;
    f_bytesReceived: int64;
    //
    f_samplingRate: int;
    f_bitsPerSample: int;
    f_numChannels: int;
    f_outFormatTag: int;
    //
    f_ipServer: unaConfIPServer;
    f_mixer: unaWaveMultiStreamDevice;
    f_senderThread: unaCSSendThread;
    //
    f_clients: array[0..c_maxClientsLimit - 1] of unaConfServerClient;
    f_clientLock: unaInProcessGate;
    f_clientCount: unsigned;
    //
    f_onAC: tunavclAcceptClient;
    f_onCE: tunavclConnectEvent;
    f_onError: tunaConfError;
    //
    f_lastTimerTick: int64;
    //
    function getClientIndex(connId: unsigned): int; overload;
    function getClientIndex(codecOut: tObject): int; overload;
    function getSrvIsActive(): bool;
    //
    procedure checkDriver(codec: TunavclWaveCodecDevice);
    procedure error(code, info: int);
    //
    function getClientOptions(clientIndex: unsigned): unsigned;
    procedure setClientOptions(clientIndex: unsigned; value: unsigned);
    //
    procedure onCodecOutDA(sender: unavclInOutPipe; data: pointer; len: unsigned);
    //
    procedure onAC2(connectionId: unsigned; var accept: bool);
    procedure onCE2(connectionId: unsigned; connected: bool);
    procedure onPacketEvent2(connectionId: unsigned; const packet: unavclInOutIPPacket);
  protected
    procedure timer(); override;
  public
    procedure afterConstruction(); override;
    procedure beforeDestruction(); override;
    //
    {DP:METHOD
      outFormatTag = -1 means outgoing codec will be same as incoming (per client);
    }
    function setAudioFormat(samplingRate: int = c_defSamplingRate; bitsPerSample: int = c_defBitsPerSample; numChannels: int = c_defNumChannels; outFormatTag: int = c_outFormatTag): HRESULT;
    function getAudioFormat(out format: unavclWavePipeFormatExchange): bool; overload;
    //
    function start(const port: string; connType: tunavclProtoType = unapt_UDP): HRESULT;
    procedure stop();
    function disconnectClient(connId: unsigned): bool;
    //
{$IFDEF DEBUG }
    function selfTest(): string;
{$ENDIF }
    //
    property clientCount: unsigned read f_clientCount;
    property clientOptions[clientIndex: unsigned]: unsigned read getClientOptions write setClientOptions;
    //
    property server: unaConfIPServer read f_ipServer;
    //
    property isActive: bool read getSrvIsActive;
    property mixedBytes: int64 read f_bcMixed;
    //
    property bytesSent: int64 read f_bytesSent;
    property bytesReceived: int64 read f_bytesReceived;
    //
    property onAcceptClient: tunavclAcceptClient read f_onAC write f_onAC;
    property onClientEvent: tunavclConnectEvent read f_onCE write f_onCE;
    property onError: tunaConfError read f_onError write f_onError;
  end;


implementation


uses
  unaWave, unaMsAcmApi, unaSockets
{$IFDEF DEBUG }
  , SysUtils	// for Exceptions
{$ENDIF }
  ;


{ unaConfIPServer }

// --  --
constructor unaConfIPServer.createServer(master: unaConfServerClass);
begin
  f_master := master;
  //
{$IFDEF CS_LOG_MAX }
  logMessage(className + '.createServer() - server about to be created..');
{$ENDIF }
  //
  inherited create(nil);
end;

// --  --
procedure unaConfIPServer.doAcceptClient(connId: unsigned; var accept: bool);
begin
{$IFDEF CS_LOG_MAX }
  logMessage(className + '.doAcceptClient() - about to accept new client, connId=' + int2str(connId));
{$ENDIF }
  //
  f_master.onAC2(connId, accept);
  //
  inherited;
end;

// --  --
procedure unaConfIPServer.doServerClientConnection(connId: unsigned; isConnected: bool);
begin
{$IFDEF CS_LOG_MAX }
  logMessage(className + '.doServerClientConnection() - client connection, connId=' + int2str(connId) + '; isConnected = ' + bool2strStr(isConnected));
{$ENDIF }
  //
  f_master.onCE2(connId, isConnected);
  //
  inherited;
end;

// --  --
function unaConfIPServer.onNewPacket(const packet: unavclInOutIPPacket; connId: unsigned): bool;
begin
  f_master.onPacketEvent2(connId, packet);
  //
  result := inherited onNewPacket(packet, connId);
end;


{ unaCSSendThread }

// --  --
function unaCSSendThread.addSendRecord(connId: uint; cmd: uint; data: pointer; len: uint): bool;
var
  rx: punaCSSendThreadRecord;
begin
  if (100 > f_records.count) then begin	// sanity check
    //
    rx := malloc(sizeOf(rx^));
    //
    rx.r_connId := connId;
    rx.r_cmdu := cmd;
    rx.r_data := malloc(len, data);	// make local copy
    rx.r_lenu := len;
    //
    f_records.add(rx);
    //
    {$IFDEF DEBUG_EXTRA_DELAY }
    if (100 = random(10000)) then begin
      //
      if (f_records.lock(1000)) then try
	sleep(20);
      finally
	f_records.unlock();
      end;
    end;
    {$ENDIF }
    //
    start();	// just in case
    //
    result := true;
  end
  else
    result := false;
end;

// --  --
procedure unaCSSendThread.AfterConstruction();
begin
  f_records := unaRecordList.create();
  //
  inherited;
end;

// --  --
procedure unaCSSendThread.BeforeDestruction();
var
  i: int;
begin
  inherited;
  //
  if (0 < f_records.count) then begin
    //
    for i := 0 to f_records.count - 1 do
      mrealloc(punaCSSendThreadRecord(f_records.get(i)).r_data);
    //
  end;
  //
  freeAndNil(f_records);
end;

// --  --
constructor unaCSSendThread.create(master: unaConfServerClass);
begin
  f_master := master;
  //
  inherited create();
end;

{$IFDEF DEBUG_NASTY_EXCEPTION }

// --  --
function getEEInfo(E:PExceptionRecord): string;
begin
  if (nil <> E) then begin
    //
    result := 'Code: $' + int2str(E.ExceptionCode, 16) + '; ' +
	      'Flags: ' + int2str(E.ExceptionFlags) + '; ' +
	      'Record: [' + getEEInfo(E.ExceptionRecord) + ']; ' +
	      'Address: $' + int2str(uint(E.ExceptionAddress), 16) + '; ' +
	      'NumParams: ' + int2str(E.NumberParameters) + '; ' +
	      'Info: ' + base64encode(@E.ExceptionInformation, sizeOf(E.ExceptionInformation))
  end
  else
    result := '<NULL>';
end;

{$ENDIF }

// --  --
function unaCSSendThread.execute(threadId: uint): int;
var
  rx: punaCSSendThreadRecord;
  i: int;
  idx: int;
  res: tsendResult;
begin
  while (not shouldStop) do begin
    //
    try
      if (lockNonEmptyList(f_records, 10)) then begin
	//
	try
	  //
  {$IFDEF CS_LOG_MAX }
	  logMessage(className + '.execute() - about to send ' + int2str(f_records.count) + ' packets to cleint(s)..');
  {$ENDIF }
	  for i := 0 to f_records.count - 1 do begin
	    //
	    rx := punaCSSendThreadRecord(f_records.get(i));
	    //
	    res := f_master.f_ipServer.doSendPacket(rx.r_connId, rx.r_cmdu, rx.r_data, rx.r_lenu);
  {$IFDEF CS_LOG_MAX }