unit Ws.Server.Module;

interface

uses
  System.SysUtils, System.Classes,
  IdContext,
  WebSocketServer;

type
  TWsServerModule = class(TDataModule)
    procedure DataModuleCreate(Sender: TObject);
    procedure DataModuleDestroy(Sender: TObject);
  private
    FServer: TWebSocketServer;
    procedure DoConnect(AContext: TIdContext);
    procedure DoDisconnect(AContext: TIdContext);
    procedure DoExecute(AContext: TIdContext);
    function PeerId(AContext: TIdContext): string;
  public
    procedure StartWsServer(ABaseUrl: string; AModelName: string);
    procedure Broadcast(const AMessage: string);
    property Server: TWebSocketServer read FServer;
  end;

const
  WS_PORT = 2008;

var
  WsServerModule: TWsServerModule;

implementation

uses
  Common.Logging;

{$R *.dfm}

function TWsServerModule.PeerId(AContext: TIdContext): string;
begin
  try
    Result := AContext.Binding.PeerIP + ':' + IntToStr(AContext.Binding.PeerPort);
  except
    Result := 'unknown';
  end;
end;

procedure TWsServerModule.DataModuleCreate(Sender: TObject);
begin
  FServer := TWebSocketServer.Create;
  FServer.OnConnect    := DoConnect;
  FServer.OnDisconnect := DoDisconnect;
  FServer.OnExecute    := DoExecute;
end;

procedure TWsServerModule.DataModuleDestroy(Sender: TObject);
begin
  if Assigned(FServer) then
  begin
    FServer.Active := False;
    FServer.Free;
    FServer := nil;
  end;
end;

procedure TWsServerModule.DoConnect(AContext: TIdContext);
begin
  Logger.Log(1, 'WS: Client connected [' + PeerId(AContext) + ']');
end;

procedure TWsServerModule.DoDisconnect(AContext: TIdContext);
begin
  Logger.Log(1, 'WS: Client disconnected [' + PeerId(AContext) + ']');
end;

procedure TWsServerModule.DoExecute(AContext: TIdContext);
var
  io: TWebSocketIOHandlerHelper;
  msg: string;
begin
  // Tag = 1 means the WebSocket handshake has completed; skip until then
  if AContext.Connection.IOHandler.Tag <> 1 then
    Exit;

  io := TWebSocketIOHandlerHelper(AContext.Connection.IOHandler);
  io.CheckForDataOnSource(10);
  msg := io.ReadString;
  if msg = '' then
    Exit;

  Logger.Log(1, 'WS: Message from [' + PeerId(AContext) + ']: ' + msg);
  // Dispatch or handle incoming message here
end;

procedure TWsServerModule.StartWsServer(ABaseUrl: string; AModelName: string);
begin
  FServer.DefaultPort := WS_PORT;
  FServer.Active := True;
  Logger.Log(1, Format('WebSocket server listening on ws://0.0.0.0:%d/', [WS_PORT]));
end;

procedure TWsServerModule.Broadcast(const AMessage: string);
var
  List: TList;
  i: Integer;
  ctx: TIdContext;
begin
  if not (Assigned(FServer) and FServer.Active) then
    Exit;

  List := FServer.Contexts.LockList;
  try
    for i := 0 to List.Count - 1 do
    begin
      ctx := TIdContext(List[i]);
      if ctx.Connection.Connected and (ctx.Connection.IOHandler.Tag = 1) then
      try
        TWebSocketIOHandlerHelper(ctx.Connection.IOHandler).WriteString(AMessage);
      except
        // ignore dead connections
      end;
    end;
  finally
    FServer.Contexts.UnlockList;
  end;
end;

end.
