Skip to content

E
emiMobile
Commit 68de9931 by Michael Brachmann
Options

swap indy ws implimentation for tmsfncwebsocketserver

parent 6c3ea014
Showing with 379 additions and 110 deletions
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 0 → 100644
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.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment