////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2026 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// DIM Server class library. See http://dim.web.cern.ch on DIM.               //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 2019???? - Created by A.K.                                                 //
// 20230607 - Modified for FPC (A.K.)                                         //
////////////////////////////////////////////////////////////////////////////////

unit _crw_dims; // DIM Server

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

{$WARN 5023 off : Unit "$1" not used in $2}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 sysutils, classes, math,
 _crw_alloc, _crw_dim, _crw_dimq, _crw_dimc;

{$IFDEF SKIP_DRAFT}
TODO: The unit should be updated to use DimDataQueue.
      Data processing should be moved to main thread.
{$ENDIF SKIP_DRAFT}

 ///////////////////////////////////////////////////////////////////////////////
 // TDisBaseService - base class for server INFO/CMND services.
 // For internal use only.
 ///////////////////////////////////////////////////////////////////////////////
type
 TDisBaseService = class(TDimService)
 protected
  function  GetClientServices:LongString;
  function  GetClientName:LongString;
  function  GetConnId:Integer;
 public // To be called inside user callback procedures only.
  property  ClientServices : LongString read GetClientServices; // List of client services
  property  ClientName     : LongString read GetClientName;     // Client name as PID@node
  property  ConnId         : Integer    read GetConnId;         // Connection ID
 end;

 ///////////////////////////////////////////////////////////////////////////////
 // TDisInfoService - DIM server INFO service.
 // Uses to provide published data to DIM clients.
 ///////////////////////////////////////////////////////////////////////////////
type
 TDisInfoService = class;
 TOnDisInfoSend = procedure(Service:TDisInfoService; var Buffer:Pointer; var Size:Integer; First:Integer);
 TDisInfoService = class(TDisBaseService)
 protected
  FOnInfoSend : TOnDisInfoSend;
  function  GetOnInfoSend:TOnDisInfoSend;
  procedure SetOnInfoSend(Value:TOnDisInfoSend);
 protected
  procedure OnStop; override;
  procedure OnStart; override;
  procedure OnUpdate; override;
 public
  property  OnInfoSend : TOnDisInfoSend read GetOnInfoSend write SetOnInfoSend;
 public
  constructor Create(ServiceName:LongString; ServiceType:LongString=''; BufferSize:Integer=0);
  procedure   AfterConstruction; override;
  procedure   BeforeDestruction; override;
  destructor  Destroy; override;
 end;

 ///////////////////////////////////////////////////////////////////////////////
 // TDisCmndService - DIM server CMND service.
 // Uses to receive commands from DIM clients.
 ///////////////////////////////////////////////////////////////////////////////
type
 TDisCmndService = class;
 TOnDisCmndGot = procedure(Service:TDisCmndService);
 TOnDisCmndTake = procedure(Service:TDisCmndService; Buffer:Pointer; Size:Integer);
 TDisCmndService = class(TDisBaseService)
 protected
  FCmndGot    : Cardinal;
  FOnCmndGot  : TOnDisCmndGot;
  FOnCmndTake : TOnDisCmndTake;
  function  GetCmndGot:Cardinal;
  procedure SetCmndGot(Value:Cardinal);
  function  GetOnCmndGot:TOnDisCmndGot;
  procedure SetOnCmndGot(Value:TOnDisCmndGot);
  function  GetOnCmndTake:TOnDisCmndTake;
  procedure SetOnCmndTake(Value:TOnDisCmndTake);
 protected
  procedure OnStop; override;
  procedure OnStart; override;
 public
  property  CmndGot    : Cardinal       read GetCmndGot    write SetCmndGot;
  property  OnCmndGot  : TOnDisCmndGot  read GetOnCmndGot  write SetOnCmndGot;
  property  OnCmndTake : TOnDisCmndTake read GetOnCmndTake write SetOnCmndTake;
 public
  constructor Create(ServiceName:LongString; ServiceType:LongString=''; BufferSize:Integer=0);
  procedure   AfterConstruction; override;
  procedure   BeforeDestruction; override;
  destructor  Destroy; override;
 end;

 ///////////////////////////////////////////////////////////////////////////////
 // TDimServer - general DIM Server. Contains all INFO/CMND server services.
 ///////////////////////////////////////////////////////////////////////////////
type
 TDimServer = class(TMasterObject)
 protected
  FTaskName     : LongString;
  FInfoServices : TDimThreadList;
  FCmndServices : TDimThreadList;
  function  GetServing:Boolean;
  function  GetDnsNode:LongString;
  procedure SetDnsNode(Node:LongString);
  function  GetTaskName:LongString;
  function  GetTaskNode:LongString;
 public
  property  Serving      : Boolean        read GetServing;                  // DIM Server working?
  property  DnsNode      : LongString     read GetDnsNode write SetDnsNode; // DNS uses by Server
  property  TaskName     : LongString     read GetTaskName;                 // Task Name or empty if not serving
  property  TaskNode     : LongString     read GetTaskNode;                 // Task@node or empty if not serving
  property  InfoServices : TDimThreadList read FInfoServices;               // List of all INFO Servers
  property  CmndServices : TDimThreadList read FCmndServices;               // List of all CMND Servers
 public
  procedure StopServing;
  procedure FreeServices;
  procedure StopServices;
  procedure StartServices;
  procedure UpdateServices;
  function  StartServing(TaskName:LongString; DNS:LongString=''):Boolean;
  function  InfoServingCount:Integer;
  function  CmndServingCount:Integer;
 public
  constructor Create;
  procedure   AfterConstruction; override;
  procedure   BeforeDestruction; override;
  destructor  Destroy; override;
 end;

function DimServer:TDimServer;  // The only one DIM server instance allowed.

implementation

 ////////////////////////////////////
 // user callback routines interfaces
 ////////////////////////////////////

 // See _dim.TDis_User_Routine
procedure DisInfoUserRoutine(var tag:TDimLong; var buff:Pointer; var size:Integer; var first:Integer); cdecl;
var Service:TDisInfoService;
begin
 Service:=PtrIntToPointer(tag);
 if (Service=nil) then Exit;
 try
  Service.FCallBackNow:=true;
  try
   buff:=Service.Buffer.Addr;                        // Default buffer
   size:=Service.Buffer.Size;                        // Default buffer size
   if Assigned(Service.FOnInfoSend)                  // User callback routine
   then Service.OnInfoSend(Service,buff,size,first); // may change buffer size
   Service.FMessageLeng:=size;                       // Set actual leng
   Service.FMessageSize:=size;                       // Set actual size
   inc(DimTrafficCounts.DisInfoItems);               // Count items
   inc(DimTrafficCounts.DisInfoBytes,size);          // Count bytes
  finally
   Service.FCallBackNow:=false;
  end;
 except
  on E:Exception do DimBugReport(E,Service,'DisInfoUserRoutine');
 end;
end;

 // See _dim.TDis_Cmnd_Routine
procedure DisCmndUserRoutine(var tag:TDimLong; buff:Pointer; var size:Integer); cdecl;
var Service:TDisCmndService; lost:Integer;
begin
 Service:=PtrIntToPointer(tag);
 if (Service=nil) then Exit;
 try
  Service.FCallBackNow:=true;
  try
   Inc(Service.FCmndGot);
   Service.FTimeStamp:=Now;
   Service.FMessageLeng:=size;
   inc(DimTrafficCounts.DisCmndItems);
   inc(DimTrafficCounts.DisCmndBytes,size);
   if Assigned(Service.FOnCmndTake) then begin
    Service.FMessageSize:=size;
    Service.FOnCmndTake(Service,buff,size)
   end else begin
    Service.FMessageSize:=Min(Service.Buffer.Size,size);
    if (Service.Buffer.SetData(buff,Service.FMessageSize)>0) then begin
     lost:=size-Service.FMessageSize;
     if (lost>0) then inc(DimTrafficCounts.DisCmndBytesLost,lost);
    end else begin
     if (size>0) then begin
      inc(DimTrafficCounts.DisCmndBytesLost,size);
      inc(DimTrafficCounts.DisCmndItemsLost);
     end;
    end;
   end;
   if Assigned(Service.FOnCmndGot) then Service.FOnCmndGot(Service);
  finally
   Service.FCallBackNow:=false;
  end;
 except
  on E:Exception do DimBugReport(E,Service,'DisCmndUserRoutine');
 end;
end;

 //////////////////
 // TDisBaseService
 //////////////////

function TDisBaseService.GetClientServices:LongString;
var P:PChar;
begin
 Result:='';
 if (Self=nil) then Exit;
 if not FCallBackNow then Exit;
 P:=dis_get_client_services(dis_get_conn_id);
 if (P<>nil) then Result:=P;
end;

function TDisBaseService.GetClientName:LongString;
var s:LongString;
begin
 Result:='';
 if (Self=nil) then Exit;
 if not FCallBackNow then Exit;
 s:=StringOfChar(#0,MAX_PATH);
 if dis_get_client(PChar(s))>0
 then Result:=PChar(s);
end;

function TDisBaseService.GetConnId:Integer;
begin
 Result:=0;
 if (Self=nil) then Exit;
 if not FCallBackNow then Exit;
 Result:=dis_get_conn_id;
end;

 //////////////////
 // TDisInfoService
 //////////////////

constructor TDisInfoService.Create(ServiceName,ServiceType:LongString; BufferSize:Integer);
begin
 inherited Create(ServiceName,BufferSize);
 FServiceType:=ServiceType;
 Buffer.Auto:=true;
end;

procedure TDisInfoService.AfterConstruction;
begin
 inherited;
 DimServer.InfoServices.AddService(Self);
end;

procedure TDisInfoService.BeforeDestruction;
begin
 Stop;
 DimServer.InfoServices.DeleteService(Self);
 inherited;
end;

destructor TDisInfoService.Destroy;
begin
 inherited;
end;

function TDisInfoService.GetOnInfoSend:TOnDisInfoSend;
begin
 if (Self<>nil)
 then Result:=FOnInfoSend
 else Result:=nil;
end;

procedure TDisInfoService.SetOnInfoSend(Value:TOnDisInfoSend);
begin
 if (Self=nil) then Exit;
 FOnInfoSend:=Value;
end;

procedure TDisInfoService.OnStart;
var Buffer_Addr:Pointer; Buffer_Size:Integer; const UsesBuffer:Boolean=false;
begin
 if UsesBuffer then Buffer_Size:=Buffer.Size else Buffer_Size:=0;
 if UsesBuffer then Buffer_Addr:=Buffer.Addr else Buffer_Addr:=nil;
 // Always use callback routine as most flexible solution
 FID:=dis_add_service(PChar(FServiceName),PChar(FServiceType),
      Buffer_Addr,Buffer_Size,DisInfoUserRoutine,PointerToPtrInt(Self));
 if (FID=0) then FStarted:=false;
end;

procedure TDisInfoService.OnStop;
begin
 if (FID<>0) then begin
  dis_remove_service(FID);
  FID:=0;
 end;
end;

procedure TDisInfoService.OnUpdate;
begin
 if (FID<>0) then dis_update_service(FID);
end;

 //////////////////
 // TDisCmndService
 //////////////////

constructor TDisCmndService.Create(ServiceName,ServiceType:LongString; BufferSize:Integer);
begin
 inherited Create(ServiceName,BufferSize);
 FServiceType:=ServiceType;
end;

procedure TDisCmndService.AfterConstruction;
begin
 inherited;
 DimServer.CmndServices.AddService(Self);
end;

procedure TDisCmndService.BeforeDestruction;
begin
 Stop;
 DimServer.CmndServices.DeleteService(Self);
 inherited;
end;

destructor TDisCmndService.Destroy;
begin
 inherited;
end;

function TDisCmndService.GetCmndGot:Cardinal;
begin
 if (Self<>nil)
 then Result:=FCmndGot
 else Result:=0;
end;

procedure TDisCmndService.SetCmndGot(Value:Cardinal);
begin
 if (Self=nil) then Exit;
 FCmndGot:=Value;
end;

function TDisCmndService.GetOnCmndGot:TOnDisCmndGot;
begin
 if (Self<>nil)
 then Result:=FOnCmndGot
 else Result:=nil;
end;

procedure TDisCmndService.SetOnCmndGot(Value:TOnDisCmndGot);
begin
 if (Self=nil) then Exit;
 FOnCmndGot:=Value;
end;

function TDisCmndService.GetOnCmndTake:TOnDisCmndTake;
begin
 if (Self<>nil)
 then Result:=FOnCmndTake
 else Result:=nil;
end;

procedure TDisCmndService.SetOnCmndTake(Value:TOnDisCmndTake);
begin
 if (Self=nil) then Exit;
 FOnCmndTake:=Value;
end;

procedure TDisCmndService.OnStart;
begin
 // Always use callback routine as most flexible solution
 FID:=dis_add_cmnd(PChar(FServiceName),PChar(FServiceType),
                   DisCmndUserRoutine,PointerToPtrInt(Self));
 if (FID=0) then FStarted:=false;
end;

procedure TDisCmndService.OnStop;
begin
 if (FID<>0) then begin
  dis_remove_service(FID);
  FID:=0;
 end;
end;

 /////////////
 // TDimServer
 /////////////

const
 TheDimServer : TDimServer = nil;

function DimServer:TDimServer;
begin
 if TheDimServer=nil then begin
  TheDimServer:=TDimServer.Create;
  TheDimServer.Master:=@TheDimServer;
 end;
 Result:=TheDimServer;
end;

constructor TDimServer.Create;
begin
 inherited;
 FInfoServices:=TDimThreadList.Create;
 FCmndServices:=TDimThreadList.Create;
end;

procedure TDimServer.AfterConstruction;
begin
 inherited;
 if (TheDimServer=nil)
 then TheDimServer:=Self;
end;

procedure TDimServer.BeforeDestruction;
begin
 StopServing;
 FreeServices;
 if (TheDimServer=Self)
 then TheDimServer:=nil;
 inherited;
end;

destructor TDimServer.Destroy;
begin
 FInfoServices.Free;
 FCmndServices.Free;
 FTaskName:='';
 inherited;
end;

procedure TDimServer.FreeServices;
begin
 if (Self=nil) then Exit;
 StopServing;
 FInfoServices.FreeServices;
 FCmndServices.FreeServices;
end;

procedure TDimServer.StopServices;
begin
 if (Self=nil) then Exit;
 FInfoServices.StopServices;
 FCmndServices.StopServices;
end;

procedure TDimServer.StartServices;
begin
 if (Self=nil) then Exit;
 FInfoServices.StartServices;
 FCmndServices.StartServices;
end;

procedure TDimServer.UpdateServices;
begin
 if (Self=nil) then Exit;
 if not Serving then Exit;
 FInfoServices.UpdateServices;
 FCmndServices.UpdateServices;
end;

function TDimServer.InfoServingCount:Integer;
begin
 Result:=0;
 if (Self=nil) then Exit;
 if not Serving then Exit;
 Result:=FInfoServices.CountStartedServices;
end;

function TDimServer.CmndServingCount:Integer;
begin
 Result:=0;
 if (Self=nil) then Exit;
 if not Serving then Exit;
 Result:=FCmndServices.CountStartedServices;
end;

procedure TDimServer.StopServing;
begin
 StopServices;
 if Serving then begin
  dis_stop_serving;
  FTaskName:='';
 end;
end;

function TDimServer.GetServing:Boolean;
begin
 if (Self<>nil)
 then Result:=(Length(FTaskName)>0)
 else Result:=false;
end;

function TDimServer.GetTaskName:LongString;
begin
 if (Self<>nil)
 then Result:=FTaskName
 else Result:='';
end;

function TDimServer.GetTaskNode:LongString;
begin
 if Serving
 then Result:=TaskName+'@'+GetLocalHostNode
 else Result:='';
end;

function TDimServer.StartServing(TaskName:LongString; DNS:LongString=''):Boolean;
begin
 Result:=false;
 if (Self=nil) then Exit;
 if Serving then StopServing;
 if (DNS<>'') then DnsNode:=DNS;
 if (DnsNode='') then Exit;
 if (InfoServices.CountServices>0)
 or (CmndServices.CountServices>0)
 then StartServices else Exit;
 if (dis_start_serving(PChar(TaskName))<>0)
 then FTaskName:=TaskName
 else StopServing;                            
 Result:=Serving;
end;

function TDimServer.GetDnsNode:LongString;
var Node:TMaxPathBuffer;
begin
 if dis_get_dns_node(Node)>0
 then Result:=Node
 else Result:='';
end;

procedure TDimServer.SetDnsNode(Node:LongString);
begin
 dis_set_dns_node(PChar(Node));
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_dims;
begin
 DimServer;
end;

procedure Free_crw_dims;
begin
 FreeAndNil(TheDimServer);
end;

initialization

 Init_crw_dims;

finalization

 Free_crw_dims;

end.

//////////////
// END OF FILE
//////////////

