swap indy ws implimentation for tmsfncwebsocketserver

emiMobileServer/Source/Main.dfm

@@ -2,8 +2,8 @@ object FMain: TFMain
   Left = 0
   Top = 0
   Caption = 'emiMobileServer'
-  ClientHeight = 583
-  ClientWidth = 761
+  ClientHeight = 620
+  ClientWidth = 800
   Color = clBtnFace
   Font.Charset = DEFAULT_CHARSET
   Font.Color = clWindowText
@@ -12,34 +12,26 @@ object FMain: TFMain
   Font.Style = []
   OnClose = FormClose
   DesignSize = (
-    761
-    583)
+    800
+    620)
   TextHeight = 13
-  object memoInfo: TMemo
-    Left = 8
-    Top = 39
-    Width = 741
-    Height = 535
-    Anchors = [akLeft, akTop, akRight, akBottom]
-    ReadOnly = True
-    TabOrder = 0
-  end
   object btnApiSwaggerUI: TButton
     Left = 141
     Top = 8
     Width = 100
     Height = 25
     Caption = 'Api SwaggerUI'
-    TabOrder = 1
+    TabOrder = 0
     OnClick = btnApiSwaggerUIClick
   end
   object btnExit: TButton
-    Left = 671
+    Left = 713
     Top = 8
     Width = 75
     Height = 25
+    Anchors = [akTop, akRight]
     Caption = 'Exit'
-    TabOrder = 2
+    TabOrder = 1
     OnClick = btnExitClick
   end
   object btnAuthSwaggerUI: TButton
@@ -48,9 +40,50 @@ object FMain: TFMain
     Width = 100
     Height = 25
     Caption = 'Auth SwaggerUI'
-    TabOrder = 3
+    TabOrder = 2
     OnClick = btnAuthSwaggerUIClick
   end
+  object pgcMain: TPageControl
+    Left = 8
+    Top = 39
+    Width = 784
+    Height = 573
+    Anchors = [akLeft, akTop, akRight, akBottom]
+    TabOrder = 3
+    object tabLog: TTabSheet
+      Caption = 'Log'
+      object memoInfo: TMemo
+        Left = 0
+        Top = 0
+        Width = 776
+        Height = 545
+        Align = alClient
+        ReadOnly = True
+        TabOrder = 0
+      end
+    end
+    object tabClients: TTabSheet
+      Caption = 'Connected Clients'
+      object sgClients: TStringGrid
+        Left = 0
+        Top = 0
+        Width = 776
+        Height = 545
+        Align = alClient
+        ColCount = 3
+        DefaultColWidth = 220
+        DefaultRowHeight = 20
+        FixedCols = 0
+        RowCount = 2
+        Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goColSizing]
+        TabOrder = 0
+        ColWidths = (
+          200
+          200
+          176)
+      end
+    end
+  end
   object initTimer: TTimer
     OnTimer = initTimerTimer
     Left = 58

emiMobileServer/Source/Main.pas

@@ -5,18 +5,23 @@ interface
 uses
   Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, Winapi.ShellApi,
   System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
-  Vcl.StdCtrls, Vcl.ExtCtrls, System.Generics.Collections, System.IniFiles,
+  Vcl.StdCtrls, Vcl.ExtCtrls, Vcl.ComCtrls, Vcl.Grids,
+  System.Generics.Collections, System.IniFiles,
   Auth.Service, Auth.Server.Module, Api.Server.Module, App.Server.Module,
   ExeInfo, Api.Service, Ws.Server.Module, Ws.Service;
 
 type
   TFMain = class(TForm)
-    memoInfo: TMemo;
     btnApiSwaggerUI: TButton;
     btnExit: TButton;
     initTimer: TTimer;
     btnAuthSwaggerUI: TButton;
     ExeInfo1: TExeInfo;
+    pgcMain: TPageControl;
+    tabLog: TTabSheet;
+    tabClients: TTabSheet;
+    memoInfo: TMemo;
+    sgClients: TStringGrid;
     procedure btnApiSwaggerUIClick(Sender: TObject);
     procedure btnExitClick(Sender: TObject);
     procedure ContactFormData(AText: String);
@@ -25,6 +30,7 @@ type
     procedure btnAuthSwaggerUIClick(Sender: TObject);
   strict private
     procedure StartServers;
+    procedure RefreshClientList;
     function LogValue(const LabelName: string; const Value: string; FromIni: Boolean): string;
   private
     function LocalBrowserUrl(const Url: string): string;
@@ -93,6 +99,8 @@ end;
 
 procedure TFMain.FormClose(Sender: TObject; var Action: TCloseAction);
 begin
+  WsServerModule.OnClientsChanged := nil;
+
   ServerConfig.Free;
   IniEntries.Free;
   AuthServerModule.Free;
@@ -101,6 +109,34 @@ begin
   WsServerModule.Free;
 end;
 
+{ --- Connected Client List --- }
+
+procedure TFMain.RefreshClientList;
+var
+  snapshots: TArray<TConnectedClientSnapshot>;
+  i: Integer;
+begin
+  snapshots := WsServerModule.GetClientSnapshots;
+
+  sgClients.RowCount := Length(snapshots) + 1;  // +1 for header row
+
+  // Header
+  sgClients.Cells[0, 0] := 'Connection ID';
+  sgClients.Cells[1, 0] := 'User ID';
+  sgClients.Cells[2, 0] := 'Connected At';
+
+  for i := 0 to Length(snapshots) - 1 do
+  begin
+    sgClients.Cells[0, i + 1] := snapshots[i].ConnectionId;
+    sgClients.Cells[1, i + 1] := snapshots[i].UserId;
+    sgClients.Cells[2, i + 1] :=
+      FormatDateTime('yyyy-mm-dd hh:nn:ss', snapshots[i].ConnectedAt);
+  end;
+
+  tabClients.Caption :=
+    Format('Connected Clients (%d)', [Length(snapshots)]);
+end;
+
 { --- Helpers --- }
 
 function TFMain.LogValue(const LabelName: string; const Value: string; FromIni: Boolean): string;
@@ -122,12 +158,6 @@ begin
   Logger.Log(1, LogValue('--Settings->LogFileNum', IniEntries.LogFileNum.ToString, IniEntries.LogFileNumFromIni));
   Logger.Log(1, LogValue('--Settings->webClientVersion', IniEntries.WebClientVersion, IniEntries.WebClientVersionFromIni));
 
-//  Logger.Log(1, '--- Database ---');
-//  Logger.Log(1, LogValue('--Database->Server', IniEntries.DatabaseServer, IniEntries.DatabaseServerFromIni));
-//  Logger.Log(1, LogValue('--Database->Database', IniEntries.DatabaseName, IniEntries.DatabaseNameFromIni));
-//  Logger.Log(1, LogValue('--Database->Username', IniEntries.DatabaseUsername, IniEntries.DatabaseUsernameFromIni));
-//  Logger.Log(1, LogValue('--Database->Password', IniEntries.DatabasePassword, IniEntries.DatabasePasswordFromIni));
-
   Logger.Log(1, '');
   Logger.Log(1, '--- URLs ---');
   try
@@ -141,13 +171,15 @@ begin
     AppServerModule.StartAppServer(ServerConfig.url);
 
     WsServerModule := TWsServerModule.Create(Self);
+    WsServerModule.OnClientsChanged := RefreshClientList;
     WsServerModule.StartWsServer(ServerConfig.url, WS_MODEL);
   except
     on E: Exception do
       Logger.Log(2, 'Failed to start server modules: ' + E.Message);
   end;
-end;
 
+  // Initialise the grid headers even before any client connects.
+  RefreshClientList;
+end;
 
 end.
-

emiMobileServer/Source/WebSocket.Manager.pas

+unit WebSocket.Manager;
+
+interface
+
+uses
+  System.Classes,
+  System.SysUtils,
+  System.JSON,
+  System.Generics.Collections,
+  VCL.TMSFNCWebSocketServer,
+  VCL.TMSFNCWebSocketCommon;
+
+const
+  WEBSOCKET_PORT = 8091;
+
+type
+  TConnectedClientSnapshot = record
+    ConnectionId: string;
+    UserId: string;
+    ConnectedAt: TDateTime;
+  end;
+
+  TConnectedClient = class
+  private
+    FConnectionId: string;
+    FUserId: string;
+    FConnectedAt: TDateTime;
+    FConnection: TTMSFNCWebSocketServerConnection;
+  public
+    property ConnectionId: string read FConnectionId write FConnectionId;
+    property UserId: string read FUserId write FUserId;
+    property ConnectedAt: TDateTime read FConnectedAt write FConnectedAt;
+    property Connection: TTMSFNCWebSocketServerConnection
+      read FConnection write FConnection;
+  end;
+
+  TClientsChangedEvent = procedure of object;
+
+  TWebSocketManager = class
+  private
+    FServer: TTMSFNCWebSocketServer;
+    FClients: TObjectList<TConnectedClient>;
+    FClientsLock: TObject;
+    FOnClientsChanged: TClientsChangedEvent;
+
+    procedure NotifyClientsChanged;
+    procedure HandshakeResponseSent(Sender: TObject;
+      AConnection: TTMSFNCWebSocketServerConnection);
+    procedure MessageReceived(Sender: TObject;
+      AConnection: TTMSFNCWebSocketConnection; const AMessage: string);
+    procedure ClientDisconnected(Sender: TObject;
+      AConnection: TTMSFNCWebSocketConnection);
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    procedure Start;
+    procedure Stop;
+
+    // Send AMessage to every currently connected and handshaked client.
+    // Snapshots the connection list under lock before sending so that the lock
+    // is never held while performing I/O.
+    procedure Broadcast(const AMessage: string);
+
+    function GetClientSnapshots: TArray<TConnectedClientSnapshot>;
+
+    property OnClientsChanged: TClientsChangedEvent
+      read FOnClientsChanged write FOnClientsChanged;
+  end;
+
+implementation
+
+uses
+  Common.Logging;
+
+constructor TWebSocketManager.Create;
+begin
+  inherited Create;
+
+  FClientsLock := TObject.Create;
+  FClients := TObjectList<TConnectedClient>.Create(True);
+
+  FServer := TTMSFNCWebSocketServer.Create;
+  FServer.Port := WEBSOCKET_PORT;
+  FServer.UseSSL := False;
+  FServer.OnHandshakeResponseSent := HandshakeResponseSent;
+  FServer.OnMessageReceived := MessageReceived;
+  FServer.OnDisconnect := ClientDisconnected;
+end;
+
+destructor TWebSocketManager.Destroy;
+begin
+  Stop;
+  FServer.Free;
+  FClients.Free;
+  FClientsLock.Free;
+
+  inherited;
+end;
+
+procedure TWebSocketManager.Start;
+begin
+  FServer.Active := True;
+end;
+
+procedure TWebSocketManager.Stop;
+begin
+  FServer.Active := False;
+end;
+
+procedure TWebSocketManager.NotifyClientsChanged;
+begin
+  if Assigned(FOnClientsChanged) then
+    FOnClientsChanged;
+end;
+
+procedure TWebSocketManager.HandshakeResponseSent(Sender: TObject;
+  AConnection: TTMSFNCWebSocketServerConnection);
+var
+  client: TConnectedClient;
+  guid: TGUID;
+begin
+  CreateGUID(guid);
+
+  client := TConnectedClient.Create;
+  client.ConnectionId := GUIDToString(guid);
+  client.ConnectedAt := Now;
+  client.Connection := AConnection;
+
+  TMonitor.Enter(FClientsLock);
+  try
+    FClients.Add(client);
+  finally
+    TMonitor.Exit(FClientsLock);
+  end;
+
+  AConnection.OwnsUserData := False;
+  AConnection.UserData := client;
+
+  Logger.Log(1, 'WS: client connected [' + client.ConnectionId + ']');
+  NotifyClientsChanged;
+end;
+
+procedure TWebSocketManager.MessageReceived(Sender: TObject;
+  AConnection: TTMSFNCWebSocketConnection; const AMessage: string);
+var
+  json: TJSONValue;
+  messageType, userId, connectionId: string;
+  client: TConnectedClient;
+begin
+  json := TJSONObject.ParseJSONValue(AMessage);
+  try
+    if not Assigned(json) then
+      Exit;
+
+    if not json.TryGetValue<string>('message', messageType) then
+      Exit;
+
+    // "identify" lets the client register a human-readable userId for the log.
+    if messageType <> 'identify' then
+      Exit;
+
+    if not json.TryGetValue<string>('userId', userId) then
+      Exit;
+
+    client := TConnectedClient(
+      TTMSFNCWebSocketServerConnection(AConnection).UserData);
+
+    if not Assigned(client) then
+      Exit;
+
+    TMonitor.Enter(FClientsLock);
+    try
+      if FClients.IndexOf(client) < 0 then
+        Exit;
+
+      client.UserId := userId;
+      connectionId := client.ConnectionId;
+    finally
+      TMonitor.Exit(FClientsLock);
+    end;
+
+    Logger.Log(1, 'WS: client identified [' + connectionId + '] userId=' + userId);
+    NotifyClientsChanged;
+  finally
+    json.Free;
+  end;
+end;
+
+procedure TWebSocketManager.ClientDisconnected(Sender: TObject;
+  AConnection: TTMSFNCWebSocketConnection);
+var
+  serverConn: TTMSFNCWebSocketServerConnection;
+  client: TConnectedClient;
+  connectionId, userId: string;
+begin
+  serverConn := TTMSFNCWebSocketServerConnection(AConnection);
+  client := TConnectedClient(serverConn.UserData);
+
+  if not Assigned(client) then
+    Exit;
+
+  connectionId := client.ConnectionId;
+  userId := client.UserId;
+  serverConn.UserData := nil;
+
+  TMonitor.Enter(FClientsLock);
+  try
+    FClients.Remove(client);
+  finally
+    TMonitor.Exit(FClientsLock);
+  end;
+
+  Logger.Log(1, 'WS: client disconnected [' + connectionId + '] userId=' + userId);
+  NotifyClientsChanged;
+end;
+
+procedure TWebSocketManager.Broadcast(const AMessage: string);
+var
+  snapshot: TArray<TTMSFNCWebSocketServerConnection>;
+  i: Integer;
+begin
+  // Snapshot connections under lock so we never hold the lock during I/O.
+  TMonitor.Enter(FClientsLock);
+  try
+    SetLength(snapshot, FClients.Count);
+    for i := 0 to FClients.Count - 1 do
+      snapshot[i] := FClients[i].Connection;
+  finally
+    TMonitor.Exit(FClientsLock);
+  end;
+
+  for i := 0 to Length(snapshot) - 1 do
+  try
+    snapshot[i].WriteString(AMessage);
+  except
+    // Ignore disconnected or errored connections; they will be cleaned up
+    // via the OnDisconnect event.
+  end;
+end;
+
+function TWebSocketManager.GetClientSnapshots: TArray<TConnectedClientSnapshot>;
+var
+  i: Integer;
+begin
+  TMonitor.Enter(FClientsLock);
+  try
+    SetLength(Result, FClients.Count);
+    for i := 0 to FClients.Count - 1 do
+    begin
+      Result[i].ConnectionId := FClients[i].ConnectionId;
+      Result[i].UserId := FClients[i].UserId;
+      Result[i].ConnectedAt := FClients[i].ConnectedAt;
+    end;
+  finally
+    TMonitor.Exit(FClientsLock);
+  end;
+end;
+
+end.

emiMobileServer/Source/Ws.Server.Module.pas

@@ -4,8 +4,7 @@ interface
 
 uses
   System.SysUtils, System.Classes,
-  IdContext,
-  WebSocketServer,
+  WebSocket.Manager,
   Ws.DataModel;
 
 type
@@ -13,21 +12,18 @@ type
     procedure DataModuleCreate(Sender: TObject);
     procedure DataModuleDestroy(Sender: TObject);
   private
-    FServer: TWebSocketServer;
+    FManager: TWebSocketManager;
     FDataModel: TWsDataModel;
-    procedure DoConnect(AContext: TIdContext);
-    procedure DoDisconnect(AContext: TIdContext);
-    procedure DoExecute(AContext: TIdContext);
-    function PeerId(AContext: TIdContext): string;
+    function GetOnClientsChanged: TClientsChangedEvent;
+    procedure SetOnClientsChanged(const AValue: TClientsChangedEvent);
   public
     procedure StartWsServer(ABaseUrl: string; AModelName: string);
     procedure Broadcast(const AMessage: string);
-    property Server: TWebSocketServer read FServer;
+    function GetClientSnapshots: TArray<TConnectedClientSnapshot>;
+    property OnClientsChanged: TClientsChangedEvent
+      read GetOnClientsChanged write SetOnClientsChanged;
   end;
 
-const
-  WS_PORT = 2008;
-
 var
   WsServerModule: TWsServerModule;
 
@@ -38,21 +34,9 @@ uses
 
 {$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;
+  FManager := TWebSocketManager.Create;
 end;
 
 procedure TWsServerModule.DataModuleDestroy(Sender: TObject);
@@ -60,48 +44,14 @@ begin
   FDataModel.Free;
   FDataModel := nil;
 
-  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
+  FManager.Free;
+  FManager := nil;
 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]));
+  FManager.Start;
+  Logger.Log(1, Format('WebSocket server listening on port %d', [WEBSOCKET_PORT]));
 
   FDataModel := TWsDataModel.Create(
     procedure(const AMessage: string)
@@ -114,29 +64,23 @@ begin
 end;
 
 procedure TWsServerModule.Broadcast(const AMessage: string);
-var
-  List: TList;
-  i: Integer;
-  ctx: TIdContext;
 begin
-  if not (Assigned(FServer) and FServer.Active) then
-    Exit;
+  FManager.Broadcast(AMessage);
+end;
 
-  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;
+function TWsServerModule.GetClientSnapshots: TArray<TConnectedClientSnapshot>;
+begin
+  Result := FManager.GetClientSnapshots;
+end;
+
+function TWsServerModule.GetOnClientsChanged: TClientsChangedEvent;
+begin
+  Result := FManager.OnClientsChanged;
+end;
+
+procedure TWsServerModule.SetOnClientsChanged(const AValue: TClientsChangedEvent);
+begin
+  FManager.OnClientsChanged := AValue;
 end;
 
 end.