Skip to content

E
emiMobile
Commit 575b7310 by Mac Stephens
Options

Merge Mike's version into Mac's - Testing

parents 8ffcf8f3 35701c57
Showing with 2323 additions and 546 deletions
emiMobile.groupproj 0 → 100644
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<ProjectGuid>{012E57DC-0378-4E45-B2F6-DFA72B2D10B1}</ProjectGuid>
</PropertyGroup>
<ItemGroup>
<Projects Include="emiMobileServer\emiMobileServer.dproj">
<Dependencies/>
</Projects>
<Projects Include="webEMIMobile\webEmiMobile.dproj">
<Dependencies/>
</Projects>
</ItemGroup>
<ProjectExtensions>
<Borland.Personality>Default.Personality.12</Borland.Personality>
<Borland.ProjectType/>
<BorlandProject>
<Default.Personality/>
</BorlandProject>
</ProjectExtensions>
<Target Name="emiMobileServer">
<MSBuild Projects="emiMobileServer\emiMobileServer.dproj"/>
</Target>
<Target Name="emiMobileServer:Clean">
<MSBuild Projects="emiMobileServer\emiMobileServer.dproj" Targets="Clean"/>
</Target>
<Target Name="emiMobileServer:Make">
<MSBuild Projects="emiMobileServer\emiMobileServer.dproj" Targets="Make"/>
</Target>
<Target Name="webEmiMobile">
<MSBuild Projects="webEMIMobile\webEmiMobile.dproj"/>
</Target>
<Target Name="webEmiMobile:Clean">
<MSBuild Projects="webEMIMobile\webEmiMobile.dproj" Targets="Clean"/>
</Target>
<Target Name="webEmiMobile:Make">
<MSBuild Projects="webEMIMobile\webEmiMobile.dproj" Targets="Make"/>
</Target>
<Target Name="Build">
<CallTarget Targets="emiMobileServer;webEmiMobile"/>
</Target>
<Target Name="Clean">
<CallTarget Targets="emiMobileServer:Clean;webEmiMobile:Clean"/>
</Target>
<Target Name="Make">
<CallTarget Targets="emiMobileServer:Make;webEmiMobile:Make"/>
</Target>
<Import Project="$(BDS)\Bin\CodeGear.Group.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Group.Targets')"/>
</Project>
emiMobileServer/Source/Auth.Server.Module.pas
...@@ -43,7 +43,9 @@ uses ...@@ -43,7 +43,9 @@ uses
Sparkle.Middleware.Compress, Sparkle.Middleware.Compress,
XData.OpenApi.Service, XData.OpenApi.Service,
Common.Logging, Common.Logging,
Common.Middleware.Logging; Common.Middleware.Logging,
System.Rtti,
Auth.Service;
{%CLASSGROUP 'Vcl.Controls.TControl'} {%CLASSGROUP 'Vcl.Controls.TControl'}
...@@ -55,7 +57,27 @@ procedure TAuthServerModule.StartAuthServer(ABaseUrl: string; ...@@ -55,7 +57,27 @@ procedure TAuthServerModule.StartAuthServer(ABaseUrl: string;
AModelName: string); AModelName: string);
var var
Url: string; Url: string;
ctx: TRttiContext;
t: TRttiType;
attr: TCustomAttribute;
s: string;
begin begin
ctx := TRttiContext.Create;
try
t := ctx.GetType(TypeInfo(IAuthService));
if t = nil then
Logger.Log(1, 'AUTH-DIAG: IAuthService RTTI=NIL')
else
begin
Logger.Log(1, 'AUTH-DIAG: IAuthService RTTI.Name=[' + t.Name + ']');
s := '';
for attr in t.GetAttributes do
s := s + attr.ClassName + ' ';
Logger.Log(1, 'AUTH-DIAG: IAuthService attrs=[' + s + ']');
end;
finally
ctx.Free;
end;
RegisterOpenApiService; RegisterOpenApiService;
Url := ABaseUrl; Url := ABaseUrl;
......
emiMobileServer/Source/Common.Middleware.Logging.pas
...@@ -15,11 +15,12 @@ type ...@@ -15,11 +15,12 @@ type
TLoggingMiddleware = class(THttpServerMiddleware, IHttpServerMiddleware) TLoggingMiddleware = class(THttpServerMiddleware, IHttpServerMiddleware)
private private
FLogger: ILogger; FLogger: ILogger;
FLogLevel: Integer;
function GetNewHttpRequestLog(Request: THttpServerRequest): ILog; function GetNewHttpRequestLog(Request: THttpServerRequest): ILog;
protected protected
procedure ProcessRequest(Context: THttpServerContext; Next: THttpServerProc); override; procedure ProcessRequest(Context: THttpServerContext; Next: THttpServerProc); override;
public public
constructor Create(ALogger: ILogger); constructor Create(ALogger: ILogger; ALogLevel: Integer = 5);
end; end;
THttpRequestLog = class( TInterfacedObject, ILog ) THttpRequestLog = class( TInterfacedObject, ILog )
...@@ -60,9 +61,10 @@ implementation ...@@ -60,9 +61,10 @@ implementation
{ TLoggingMiddleware } { TLoggingMiddleware }
constructor TLoggingMiddleware.Create(ALogger: ILogger); constructor TLoggingMiddleware.Create(ALogger: ILogger; ALogLevel: Integer = 5);
begin begin
FLogger := TLogger.Create(ALogger); FLogger := TLogger.Create(ALogger);
FLogLevel := ALogLevel;
end; end;
function TLoggingMiddleware.GetNewHttpRequestLog( function TLoggingMiddleware.GetNewHttpRequestLog(
...@@ -116,11 +118,11 @@ begin ...@@ -116,11 +118,11 @@ begin
procedure(Resp: THttpServerResponse) procedure(Resp: THttpServerResponse)
begin begin
if (Resp.StatusCode >= 400) and (Resp.StatusCode <= 499) then if (Resp.StatusCode >= 400) and (Resp.StatusCode <= 499) then
FLogger.Log(5, Format('%d %s on %s', [Resp.StatusCode, Resp.StatusReason, RequestLogMessage])); FLogger.Log(FLogLevel, Format('%d %s on %s', [Resp.StatusCode, Resp.StatusReason, RequestLogMessage]));
end end
); );
RequestLogMessage := GetNewHttpRequestLog(Context.Request).GetMessage; RequestLogMessage := GetNewHttpRequestLog(Context.Request).GetMessage;
FLogger.Log(5, RequestLogMessage); FLogger.Log(FLogLevel, RequestLogMessage);
Next(Context); Next(Context);
end; end;
......
emiMobileServer/Source/Main.dfm
...@@ -123,10 +123,11 @@ object FMain: TFMain ...@@ -123,10 +123,11 @@ object FMain: TFMain
OnClick = btnApiSwaggerUIClick OnClick = btnApiSwaggerUIClick
end end
object btnExit: TButton object btnExit: TButton
Left = 671 Left = 713
Top = 8 Top = 8
Width = 75 Width = 75
Height = 25 Height = 25
Anchors = [akTop, akRight]
Caption = 'Exit' Caption = 'Exit'
TabOrder = 1 TabOrder = 1
OnClick = btnExitClick OnClick = btnExitClick
...@@ -140,6 +141,47 @@ object FMain: TFMain ...@@ -140,6 +141,47 @@ object FMain: TFMain
TabOrder = 2 TabOrder = 2
OnClick = btnAuthSwaggerUIClick OnClick = btnAuthSwaggerUIClick
end 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 object initTimer: TTimer
OnTimer = initTimerTimer OnTimer = initTimerTimer
Left = 448 Left = 448
......
emiMobileServer/Source/Main.pas
...@@ -5,12 +5,13 @@ interface ...@@ -5,12 +5,13 @@ interface
uses uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, Winapi.ShellApi, Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, Winapi.ShellApi,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, 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, Auth.Service, Auth.Server.Module, Api.Server.Module, App.Server.Module,
ExeInfo, Api.Service, Vcl.ComCtrls, WebSocket.Manager, FireDAC.Stan.Intf, ExeInfo, Api.Service, Vcl.ComCtrls, WebSocket.Manager, FireDAC.Stan.Intf,
FireDAC.Stan.Option, FireDAC.Stan.Param, FireDAC.Stan.Error, FireDAC.DatS, FireDAC.Stan.Option, FireDAC.Stan.Param, FireDAC.Stan.Error, FireDAC.DatS,
FireDAC.Phys.Intf, FireDAC.DApt.Intf, Data.DB, Vcl.Grids, Vcl.DBGrids, FireDAC.Phys.Intf, FireDAC.DApt.Intf, Data.DB, Vcl.Grids, Vcl.DBGrids,
FireDAC.Comp.DataSet, FireDAC.Comp.Client; FireDAC.Comp.DataSet, FireDAC.Comp.Client, Ws.Server.Module;
type type
TFMain = class(TForm) TFMain = class(TForm)
...@@ -41,6 +42,7 @@ type ...@@ -41,6 +42,7 @@ type
strict private strict private
FWebSocketManager: TWebSocketManager; FWebSocketManager: TWebSocketManager;
procedure StartServers; procedure StartServers;
procedure RefreshClientList;
function LogValue(const LabelName: string; const Value: string; FromIni: Boolean): string; function LogValue(const LabelName: string; const Value: string; FromIni: Boolean): string;
procedure HandleConnectedClientsChanged; procedure HandleConnectedClientsChanged;
procedure RefreshConnectedClients; procedure RefreshConnectedClients;
...@@ -138,17 +140,43 @@ end; ...@@ -138,17 +140,43 @@ end;
procedure TFMain.FormClose(Sender: TObject; var Action: TCloseAction); procedure TFMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin begin
if Assigned(FWebSocketManager) then if Assigned(WsServerModule) then
begin WsServerModule.OnClientsChanged := nil;
FWebSocketManager.OnClientsChanged := nil;
FreeAndNil(FWebSocketManager);
end;
ServerConfig.Free; ServerConfig.Free;
IniEntries.Free; IniEntries.Free;
AuthServerModule.Free; AuthServerModule.Free;
ApiServerModule.Free; ApiServerModule.Free;
AppServerModule.Free; AppServerModule.Free;
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; end;
{ --- Helpers --- } { --- Helpers --- }
...@@ -172,12 +200,6 @@ begin ...@@ -172,12 +200,6 @@ begin
Logger.Log(1, LogValue('--Settings->LogFileNum', IniEntries.LogFileNum.ToString, IniEntries.LogFileNumFromIni)); Logger.Log(1, LogValue('--Settings->LogFileNum', IniEntries.LogFileNum.ToString, IniEntries.LogFileNumFromIni));
Logger.Log(1, LogValue('--Settings->webClientVersion', IniEntries.WebClientVersion, IniEntries.WebClientVersionFromIni)); 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, '');
Logger.Log(1, '--- URLs ---'); Logger.Log(1, '--- URLs ---');
try try
...@@ -190,14 +212,16 @@ begin ...@@ -190,14 +212,16 @@ begin
AppServerModule := TAppServerModule.Create(Self); AppServerModule := TAppServerModule.Create(Self);
AppServerModule.StartAppServer(ServerConfig.url); AppServerModule.StartAppServer(ServerConfig.url);
FWebSocketManager := TWebSocketManager.Create; WsServerModule := TWsServerModule.Create(Self);
FWebSocketManager.OnClientsChanged := HandleConnectedClientsChanged; FWsServerModule.OnClientsChanged := HandleConnectedClientsChanged;
FWebSocketManager.Start; FWsServerModule.StartWsServer(ServerConfig.Url, WS_MODEL);
Logger.Log(1, 'WebSocket server started on port 8091');
except except
on E: Exception do on E: Exception do
Logger.Log(2, 'Failed to start server modules: ' + E.Message); Logger.Log(2, 'Failed to start server modules: ' + E.Message);
end; end;
// Initialise the grid headers even before any client connects.
RefreshClientList;
end; end;
procedure TFMain.HandleConnectedClientsChanged; procedure TFMain.HandleConnectedClientsChanged;
...@@ -214,25 +238,3 @@ var ...@@ -214,25 +238,3 @@ var
clients: TArray<TConnectedClientSnapshot>; clients: TArray<TConnectedClientSnapshot>;
client: TConnectedClientSnapshot; client: TConnectedClientSnapshot;
begin begin
\ No newline at end of file
clients := FWebSocketManager.GetClientSnapshots;
tblConnectedClients.DisableControls;
try
tblConnectedClients.EmptyDataSet;
for client in clients do
begin
tblConnectedClients.Append;
tblConnectedClients.FieldByName('ConnectionId').AsString := client.ConnectionId;
tblConnectedClients.FieldByName('UserId').AsString := client.UserId;
tblConnectedClients.FieldByName('ConnectedAt').AsDateTime := client.ConnectedAt;
tblConnectedClients.Post;
end;
finally
tblConnectedClients.EnableControls;
end;
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;
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;
procedure DisconnectClient(const AConnectionId: string);
procedure SendMessageToClient(const AConnectionId, AText: string);
function GetClientSnapshots: TArray<TConnectedClientSnapshot>;
property OnClientsChanged: TClientsChangedEvent read FOnClientsChanged write FOnClientsChanged;
end;
implementation
uses
Common.Logging;
const
WEBSOCKET_PORT = 8091;
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.DisconnectClient(const AConnectionId: string);
var
client: TConnectedClient;
connection: TTMSFNCWebSocketServerConnection;
begin
connection := nil;
TMonitor.Enter(FClientsLock);
try
for client in FClients do
begin
if SameText(client.ConnectionId, AConnectionId) then
begin
connection := client.Connection;
Break;
end;
end;
finally
TMonitor.Exit(FClientsLock);
end;
if Assigned(connection) then
connection.SendClose;
end;
procedure TWebSocketManager.SendMessageToClient(const AConnectionId, AText: string);
var
client: TConnectedClient;
connection: TTMSFNCWebSocketServerConnection;
json: TJSONObject;
begin
connection := nil;
TMonitor.Enter(FClientsLock);
try
for client in FClients do
begin
if SameText(client.ConnectionId, AConnectionId) then
begin
connection := client.Connection;
Break;
end;
end;
finally
TMonitor.Exit(FClientsLock);
end;
if not Assigned(connection) then
Exit;
json := TJSONObject.Create;
try
json.AddPair('message', 'test_message');
json.AddPair('text', AText);
connection.Send(json.ToJSON);
finally
json.Free;
end;
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, 'WebSocket client connected: ' + client.ConnectionId);
NotifyClientsChanged;
end;
procedure TWebSocketManager.MessageReceived(Sender: TObject; AConnection: TTMSFNCWebSocketConnection; const AMessage: string);
var
json: TJSONValue;
messageType: string;
userId: string;
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;
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, 'WebSocket client identified: ' + connectionId + ' - ' + userId);
NotifyClientsChanged;
finally
json.Free;
end;
end;
procedure TWebSocketManager.ClientDisconnected(Sender: TObject; AConnection: TTMSFNCWebSocketConnection);
var
serverConnection: TTMSFNCWebSocketServerConnection;
client: TConnectedClient;
connectionId: string;
userId: string;
begin
serverConnection := TTMSFNCWebSocketServerConnection(AConnection);
client := TConnectedClient(serverConnection.UserData);
if not Assigned(client) then
Exit;
connectionId := client.ConnectionId;
userId := client.UserId;
serverConnection.UserData := nil;
TMonitor.Enter(FClientsLock);
try
FClients.Remove(client);
finally
TMonitor.Exit(FClientsLock);
end;
Logger.Log(1, 'WebSocket client disconnected: ' + connectionId + ' - ' + userId);
NotifyClientsChanged;
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/WebSocketServer.pas 0 → 100644
unit WebSocketServer;
interface
uses
System.SysUtils, System.Generics.Collections,
IdCustomTCPServer, IdTCPConnection, IdContext, IdIOHandler, IdGlobal, IdCoderMIME, IdHashSHA,
IdSSL, IdSSLOpenSSL;
type
TWebSocketServer = class(TIdCustomTCPServer)
private
IdServerIOHandlerSSLOpenSSL: TIdServerIOHandlerSSLOpenSSL;
HashSHA1: TIdHashSHA1;
protected
procedure DoConnect(AContext: TIdContext); override;
function DoExecute(AContext: TIdContext): Boolean; override;
public
procedure InitSSL(AIdServerIOHandlerSSLOpenSSL: TIdServerIOHandlerSSLOpenSSL);
property OnExecute;
constructor Create;
destructor Destroy; override;
end;
TWebSocketIOHandlerHelper = class(TIdIOHandler)
public
function ReadBytes: TArray<byte>;
function ReadString: string;
procedure WriteBytes(RawData: TArray<byte>);
procedure WriteString(const str: string);
end;
implementation
function HeadersParse(const msg: string): TDictionary<string, string>;
var
lines: TArray<string>;
line: string;
SplittedLine: TArray<string>;
begin
result := TDictionary<string, string>.Create;
lines := msg.Split([#13#10]);
for line in lines do
begin
SplittedLine := line.Split([': ']);
if Length(SplittedLine) > 1 then
result.AddOrSetValue(Trim(SplittedLine[0]), Trim(SplittedLine[1]));
end;
end;
{ TWebSocketServer }
constructor TWebSocketServer.Create;
begin
inherited Create;
HashSHA1 := TIdHashSHA1.Create;
IdServerIOHandlerSSLOpenSSL := nil;
end;
destructor TWebSocketServer.Destroy;
begin
HashSHA1.DisposeOf;
inherited;
end;
procedure TWebSocketServer.InitSSL(AIdServerIOHandlerSSLOpenSSL: TIdServerIOHandlerSSLOpenSSL);
var
CurrentActive: boolean;
begin
CurrentActive := Active;
if CurrentActive then
Active := false;
IdServerIOHandlerSSLOpenSSL := AIdServerIOHandlerSSLOpenSSL;
IOHandler := AIdServerIOHandlerSSLOpenSSL;
if CurrentActive then
Active := true;
end;
procedure TWebSocketServer.DoConnect(AContext: TIdContext);
begin
if AContext.Connection.IOHandler is TIdSSLIOHandlerSocketBase then
TIdSSLIOHandlerSocketBase(AContext.Connection.IOHandler).PassThrough := false;
// Mark connection as "not handshaked"
AContext.Connection.IOHandler.Tag := -1;
inherited;
end;
function TWebSocketServer.DoExecute(AContext: TIdContext): Boolean;
var
c: TIdIOHandler;
Bytes: TArray<byte>;
msg, SecWebSocketKey, Hash: string;
ParsedHeaders: TDictionary<string, string>;
begin
c := AContext.Connection.IOHandler;
// Handshake
if c.Tag = -1 then
begin
c.CheckForDataOnSource(10);
if not c.InputBufferIsEmpty then
begin
// Read string and parse HTTP headers
try
c.InputBuffer.ExtractToBytes(TIdBytes(Bytes));
msg := IndyTextEncoding_UTF8.GetString(TIdBytes(Bytes));
except
end;
ParsedHeaders := HeadersParse(msg);
if ParsedHeaders.ContainsKey('Upgrade') and (ParsedHeaders['Upgrade'] = 'websocket') and
ParsedHeaders.ContainsKey('Sec-WebSocket-Key') then
begin
// Handle handshake request
// https://developer.mozilla.org/en-US/docs/Web/API/WebSockets_API/Writing_WebSocket_servers
SecWebSocketKey := ParsedHeaders['Sec-WebSocket-Key'];
// Send handshake response
Hash := TIdEncoderMIME.EncodeBytes(
HashSHA1.HashString(SecWebSocketKey + '258EAFA5-E914-47DA-95CA-C5AB0DC85B11'));
try
c.Write('HTTP/1.1 101 Switching Protocols'#13#10
+ 'Upgrade: websocket'#13#10
+ 'Connection: Upgrade'#13#10
+ 'Sec-WebSocket-Accept: ' + Hash
+ #13#10#13#10, IndyTextEncoding_UTF8);
except
end;
// Mark IOHandler as handshaked
c.Tag := 1;
end;
ParsedHeaders.DisposeOf;
end;
end;
Result := inherited;
end;
{ TWebSocketIOHandlerHelper }
function TWebSocketIOHandlerHelper.ReadBytes: TArray<byte>;
var
l: byte;
b: array [0..7] of byte;
i, DecodedSize: int64;
Mask: array [0..3] of byte;
begin
// https://stackoverflow.com/questions/8125507/how-can-i-send-and-receive-websocket-messages-on-the-server-side
try
if ReadByte = $81 then
begin
l := ReadByte;
case l of
$FE:
begin
b[1] := ReadByte; b[0] := ReadByte;
b[2] := 0; b[3] := 0; b[4] := 0; b[5] := 0; b[6] := 0; b[7] := 0;
DecodedSize := Int64(b);
end;
$FF:
begin
b[7] := ReadByte; b[6] := ReadByte; b[5] := ReadByte; b[4] := ReadByte;
b[3] := ReadByte; b[2] := ReadByte; b[1] := ReadByte; b[0] := ReadByte;
DecodedSize := Int64(b);
end;
else
DecodedSize := l - 128;
end;
Mask[0] := ReadByte; Mask[1] := ReadByte; Mask[2] := ReadByte; Mask[3] := ReadByte;
if DecodedSize < 1 then
begin
result := [];
exit;
end;
SetLength(result, DecodedSize);
inherited ReadBytes(TIdBytes(result), DecodedSize, False);
for i := 0 to DecodedSize - 1 do
result[i] := result[i] xor Mask[i mod 4];
end;
except
end;
end;
procedure TWebSocketIOHandlerHelper.WriteBytes(RawData: TArray<byte>);
var
Msg: TArray<byte>;
begin
// https://stackoverflow.com/questions/8125507/how-can-i-send-and-receive-websocket-messages-on-the-server-side
Msg := [$81];
if Length(RawData) <= 125 then
Msg := Msg + [Length(RawData)]
else if (Length(RawData) >= 126) and (Length(RawData) <= 65535) then
Msg := Msg + [126, (Length(RawData) shr 8) and 255, Length(RawData) and 255]
else
Msg := Msg + [127, (int64(Length(RawData)) shr 56) and 255, (int64(Length(RawData)) shr 48) and 255,
(int64(Length(RawData)) shr 40) and 255, (int64(Length(RawData)) shr 32) and 255,
(Length(RawData) shr 24) and 255, (Length(RawData) shr 16) and 255, (Length(RawData) shr 8) and 255, Length(RawData) and 255];
Msg := Msg + RawData;
try
Write(TIdBytes(Msg), Length(Msg));
except
end;
end;
function TWebSocketIOHandlerHelper.ReadString: string;
begin
result := IndyTextEncoding_UTF8.GetString(TIdBytes(ReadBytes));
end;
procedure TWebSocketIOHandlerHelper.WriteString(const str: string);
begin
WriteBytes(TArray<byte>(IndyTextEncoding_UTF8.GetBytes(str)));
end;
end.
emiMobileServer/Source/Ws.DataModel.pas 0 → 100644
unit Ws.DataModel;
// Server-side WebSocket data model.
// Owns a VCL timer that fires every FIntervalMs milliseconds, queries the
// database for the five data sets used by the polling timers that existed in
// each connected browser client, and broadcasts the results to every
// handshaked WebSocket connection via the supplied broadcast callback.
//
// All five result shapes mirror what the XData API methods return so that the
// client-side parsing code can be shared between the initial HTTP load and the
// subsequent WebSocket pushes.
interface
uses
System.SysUtils, System.Classes, System.JSON,
System.Generics.Collections,
Data.DB,
Vcl.ExtCtrls,
Api.Database,
WsMessages,
Common.Logging;
type
TWsBroadcastProc = reference to procedure(const AMessage: string);
TWsDataModel = class
private
FDb: TApiDatabaseModule;
FTimer: TTimer;
FBroadcast: TWsBroadcastProc;
procedure TimerFire(Sender: TObject);
procedure BroadcastAll;
function BuildBadgeCountsJson: string;
function BuildUnitMapJson: string;
function BuildComplaintMapJson: string;
function BuildUnitListJson: string;
function BuildComplaintListJson: string;
public
constructor Create(ABroadcast: TWsBroadcastProc; AIntervalMs: Integer = 30000);
destructor Destroy; override;
end;
implementation
uses
System.StrUtils, System.DateUtils;
{ TWsDataModel }
constructor TWsDataModel.Create(ABroadcast: TWsBroadcastProc; AIntervalMs: Integer);
begin
inherited Create;
FBroadcast := ABroadcast;
FDb := TApiDatabaseModule.Create(nil);
FTimer := TTimer.Create(nil);
FTimer.Interval := AIntervalMs;
FTimer.OnTimer := TimerFire;
FTimer.Enabled := True;
end;
destructor TWsDataModel.Destroy;
begin
FTimer.Enabled := False;
FTimer.Free;
FDb.Free;
inherited;
end;
procedure TWsDataModel.TimerFire(Sender: TObject);
begin
BroadcastAll;
end;
procedure TWsDataModel.BroadcastAll;
begin
Logger.Log(3, 'WsDataModel: broadcasting all');
try FBroadcast(BuildBadgeCountsJson); except on E: Exception do Logger.Log(2, 'WsDataModel BADGE_COUNTS error: ' + E.Message); end;
try FBroadcast(BuildUnitMapJson); except on E: Exception do Logger.Log(2, 'WsDataModel UNIT_MAP error: ' + E.Message); end;
try FBroadcast(BuildComplaintMapJson); except on E: Exception do Logger.Log(2, 'WsDataModel COMPLAINT_MAP error: ' + E.Message); end;
try FBroadcast(BuildUnitListJson); except on E: Exception do Logger.Log(2, 'WsDataModel UNIT_LIST error: ' + E.Message); end;
try FBroadcast(BuildComplaintListJson); except on E: Exception do Logger.Log(2, 'WsDataModel COMPLAINT_LIST error: ' + E.Message); end;
end;
function TWsDataModel.BuildBadgeCountsJson: string;
var
msg: TWsBadgeCountsMessage;
begin
msg := TWsBadgeCountsMessage.Create;
try
with FDb.uqBadgeCounts do
begin
Open;
try
msg.BadgeComplaints := FieldByName('COMPLAINTS').AsInteger;
msg.BadgeUnits := FieldByName('UNITS').AsInteger;
finally
Close;
end;
end;
Result := msg.AsJson;
finally
msg.Free;
end;
end;
function TWsDataModel.BuildUnitMapJson: string;
var
obj: TJSONObject;
data: TJSONArray;
item: TJSONObject;
unitStatus, updateTimeText: string;
begin
obj := TJSONObject.Create;
data := TJSONArray.Create;
try
obj.AddPair('RequestId', WS_MSG_UNIT_MAP);
obj.AddPair('data', data);
with FDb.uqMapUnits do
begin
Close;
Open;
try
First;
while not Eof do
begin
if (not FDb.uqMapUnitsGPS_LATITUDE.IsNull) and (not FDb.uqMapUnitsGPS_LONGITUDE.IsNull) then
begin
item := TJSONObject.Create;
data.AddElement(item);
item.AddPair('UnitId', FDb.uqMapUnitsUNITID.AsString);
item.AddPair('UnitName', FDb.uqMapUnitsUNITNAME.AsString);
item.AddPair('UnitBadge', FDb.uqMapUnitsUNITNAME.AsString);
item.AddPair('Agency', FDb.uqMapUnitsAGENCY.AsString);
item.AddPair('AgencyName', FDb.uqMapUnitsAGENCY_NAME.AsString);
item.AddPair('AgencyType', FDb.uqMapUnitsAGENCYTYPE.AsString);
item.AddPair('Lat', TJSONNumber.Create(FDb.uqMapUnitsGPS_LATITUDE.AsFloat));
item.AddPair('Lng', TJSONNumber.Create(FDb.uqMapUnitsGPS_LONGITUDE.AsFloat));
item.AddPair('CallType', FDb.uqMapUnitsCALL_TYPE.AsString);
item.AddPair('Priority', FDb.uqMapUnitsPRIORITY.AsString);
unitStatus := FDb.uqMapUnitsUNIT_STATUS_DESC.AsString;
if Trim(unitStatus) = '' then unitStatus := 'Available';
item.AddPair('Status', unitStatus);
updateTimeText := '';
if not FDb.uqMapUnitsUPDATE_TIME.IsNull then
updateTimeText := FormatDateTime('yyyy-mm-dd hh:nn:ss', FDb.uqMapUnitsUPDATE_TIME.AsDateTime);
item.AddPair('UpdateTime', updateTimeText);
item.AddPair('Officer1Lname', FDb.uqMapUnitsOFFICER1_LNAME.AsString);
item.AddPair('Officer1Fname', FDb.uqMapUnitsOFFICER1_FNAME.AsString);
item.AddPair('Officer1Empnum', FDb.uqMapUnitsOFFICER1_EMPNUM.AsString);
item.AddPair('Officer2Lname', FDb.uqMapUnitsOFFICER2_LNAME.AsString);
item.AddPair('Officer2Fname', FDb.uqMapUnitsOFFICER2_FNAME.AsString);
item.AddPair('Officer2Empnum', FDb.uqMapUnitsOFFICER2_EMPNUM.AsString);
item.AddPair('CanShowDetails', TJSONBool.Create(not FDb.uqMapUnitsDIS_UNITID.IsNull));
end;
Next;
end;
finally
Close;
end;
end;
obj.AddPair('count', TJSONNumber.Create(data.Count));
obj.AddPair('returned', TJSONNumber.Create(data.Count));
Result := obj.ToJSON;
finally
obj.Free;
end;
end;
function TWsDataModel.BuildComplaintMapJson: string;
var
obj: TJSONObject;
data: TJSONArray;
item, unitObj: TJSONObject;
unitArray: TJSONArray;
UnitsByComplaintMap: TDictionary<string, TJSONArray>;
complaintId, unitStatus: string;
latestUpdate: TDateTime;
begin
obj := TJSONObject.Create;
data := TJSONArray.Create;
UnitsByComplaintMap := TDictionary<string, TJSONArray>.Create;
try
obj.AddPair('RequestId', WS_MSG_COMPLAINT_MAP);
obj.AddPair('data', data);
// Build unit→complaint map first
FDb.uqMapComplaintUnitsList.Close;
FDb.uqMapComplaintUnitsList.Open;
try
while not FDb.uqMapComplaintUnitsList.Eof do
begin
complaintId := FDb.uqMapComplaintUnitsListCOMPLAINTID.AsString;
if not UnitsByComplaintMap.TryGetValue(complaintId, unitArray) then
begin
unitArray := TJSONArray.Create;
UnitsByComplaintMap.Add(complaintId, unitArray);
end;
unitStatus := 'Dispatched';
if not FDb.uqMapComplaintUnitsListDATECLEARED.IsNull then unitStatus := 'Cleared'
else if not FDb.uqMapComplaintUnitsListDATEARRIVED.IsNull then unitStatus := 'On Scene'
else if not FDb.uqMapComplaintUnitsListDATERESPONDED.IsNull then unitStatus := 'Enroute';
latestUpdate := 0;
if not FDb.uqMapComplaintUnitsListDATEDISPATCHED.IsNull then
latestUpdate := FDb.uqMapComplaintUnitsListDATEDISPATCHED.AsDateTime;
if (not FDb.uqMapComplaintUnitsListDATERESPONDED.IsNull) and
(FDb.uqMapComplaintUnitsListDATERESPONDED.AsDateTime > latestUpdate) then
latestUpdate := FDb.uqMapComplaintUnitsListDATERESPONDED.AsDateTime;
if (not FDb.uqMapComplaintUnitsListDATEARRIVED.IsNull) and
(FDb.uqMapComplaintUnitsListDATEARRIVED.AsDateTime > latestUpdate) then
latestUpdate := FDb.uqMapComplaintUnitsListDATEARRIVED.AsDateTime;
if (not FDb.uqMapComplaintUnitsListDATECLEARED.IsNull) and
(FDb.uqMapComplaintUnitsListDATECLEARED.AsDateTime > latestUpdate) then
latestUpdate := FDb.uqMapComplaintUnitsListDATECLEARED.AsDateTime;
unitObj := TJSONObject.Create;
unitArray.AddElement(unitObj);
unitObj.AddPair('Unit', FDb.uqMapComplaintUnitsListUNITNAME.AsString);
unitObj.AddPair('Status', unitStatus);
unitObj.AddPair('Updated', IfThen(latestUpdate <> 0, FormatDateTime('yyyy-mm-dd hh:nn:ss', latestUpdate), ''));
FDb.uqMapComplaintUnitsList.Next;
end;
finally
FDb.uqMapComplaintUnitsList.Close;
end;
// Build complaint rows
FDb.uqMapComplaints.Close;
FDb.uqMapComplaints.Open;
try
while not FDb.uqMapComplaints.Eof do
begin
item := TJSONObject.Create;
data.AddElement(item);
complaintId := FDb.uqMapComplaintsCOMPLAINTID.AsString;
item.AddPair('ComplaintId', complaintId);
item.AddPair('DispatchDistrict', FDb.uqMapComplaintsDISPATCHDISTRICT.AsString);
item.AddPair('Agency', FDb.uqMapComplaintsAGENCY.AsString);
item.AddPair('AgencyName', FDb.uqMapComplaintsAGENCY_NAME.AsString);
item.AddPair('DispatchCodeDesc', FDb.uqMapComplaintsDISPATCH_CODE_DESC.AsString);
item.AddPair('DispatchCodeCategory', FDb.uqMapComplaintsDISPATCHCODECATEGORY.AsString);
item.AddPair('Priority', FDb.uqMapComplaintsPRIORITY.AsString);
item.AddPair('PriorityBadge', FDb.uqMapComplaintspriorityBadge.AsString);
item.AddPair('ComplaintStatusKey', FDb.uqMapComplaintscomplaintStatusKey.AsString);
item.AddPair('pngName', FDb.uqMapComplaintspngName.AsString);
item.AddPair('Address', FDb.uqMapComplaintsADDRESS.AsString);
item.AddPair('Business', FDb.uqMapComplaintsBUSINESS.AsString);
item.AddPair('Lat', TJSONNumber.Create(FDb.uqMapComplaintsLAT.AsFloat));
item.AddPair('Lng', TJSONNumber.Create(FDb.uqMapComplaintsLNG.AsFloat));
if UnitsByComplaintMap.TryGetValue(complaintId, unitArray) then
item.AddPair('Units', TJSONArray(unitArray.Clone))
else
item.AddPair('Units', TJSONArray.Create);
FDb.uqMapComplaints.Next;
end;
finally
FDb.uqMapComplaints.Close;
end;
obj.AddPair('count', TJSONNumber.Create(data.Count));
obj.AddPair('returned', TJSONNumber.Create(data.Count));
Result := obj.ToJSON;
finally
// Free the per-complaint unit arrays (not cloned copies — those are now owned by item)
for unitArray in UnitsByComplaintMap.Values do
unitArray.Free;
UnitsByComplaintMap.Free;
obj.Free;
end;
end;
function TWsDataModel.BuildUnitListJson: string;
var
obj: TJSONObject;
data: TJSONArray;
item: TJSONObject;
lastAgency, curAgency: string;
o1, f1, m1, o2, f2, m2: string;
statusDesc, complaintNumber: string;
mapLat, mapLng: Double;
canShowMap: Boolean;
begin
obj := TJSONObject.Create;
data := TJSONArray.Create;
lastAgency := '';
try
obj.AddPair('RequestId', WS_MSG_UNIT_LIST);
with FDb.uqUnitList do
begin
Open;
First;
while not Eof do
begin
item := TJSONObject.Create;
curAgency := Trim(FDb.uqUnitListAGENCY_NAME.AsString);
if curAgency = '' then curAgency := Trim(FDb.uqUnitListAGENCY.AsString);
if curAgency = '' then curAgency := 'Unknown Agency';
if not SameText(curAgency, lastAgency) then
begin
item.AddPair('AgencyHeader', curAgency);
lastAgency := curAgency;
end
else
item.AddPair('AgencyHeader', '');
item.AddPair('UnitId', FDb.uqUnitListUNITID.AsString);
item.AddPair('UnitName', FDb.uqUnitListUNITNAME.AsString);
item.AddPair('Agency', FDb.uqUnitListAGENCY.AsString);
item.AddPair('AgencyName', FDb.uqUnitListAGENCY_NAME.AsString);
item.AddPair('AgencyType', FDb.uqUnitListAGENCYTYPE.AsString);
item.AddPair('CarNumberDesc', FDb.uqUnitListCARNUMBER_DESC.AsString);
item.AddPair('District', FDb.uqUnitListDISTRICT_DESC.AsString);
item.AddPair('Sector', FDb.uqUnitListSECTOR_DESC.AsString);
item.AddPair('CallType', FDb.uqUnitListCALL_TYPE.AsString);
canShowMap := False;
if (not FDb.uqUnitListGPS_LATITUDE.IsNull) and (not FDb.uqUnitListGPS_LONGITUDE.IsNull) then
begin
mapLat := FDb.uqUnitListGPS_LATITUDE.AsFloat;
mapLng := FDb.uqUnitListGPS_LONGITUDE.AsFloat;
canShowMap :=
((mapLat <> 0) or (mapLng <> 0)) and
(Abs(mapLat) <= 90) and (Abs(mapLng) <= 180);
end;
item.AddPair('CanShowMap', IfThen(canShowMap, 'true', 'false'));
item.AddPair('MapButtonClass', IfThen(canShowMap, 'btn-primary', 'btn-secondary disabled'));
item.AddPair('MapButtonDisabled', IfThen(canShowMap, '', 'disabled="disabled" aria-disabled="true"'));
item.AddPair('MapButtonTitle', IfThen(canShowMap, 'Show on map', 'No map location available'));
complaintNumber := Trim(FDb.uqUnitListCOMPLAINT.AsString);
item.AddPair('Location', FDb.uqUnitListLOCATION.AsString);
item.AddPair('Complaint', complaintNumber);
item.AddPair('ComplaintHeader', IfThen(complaintNumber <> '', ' - ' + complaintNumber, ''));
statusDesc := FDb.uqUnitListUNIT_STATUS_DESC.AsString;
if statusDesc = '' then statusDesc := 'Available';
item.AddPair('Status', statusDesc);
o1 := Trim(FDb.uqUnitListOFFICER1_LAST_NAME.AsString);
f1 := Trim(FDb.uqUnitListOFFICER1_FIRST_NAME.AsString);
m1 := Trim(FDb.uqUnitListOFFICER1_MI.AsString);
if o1 <> '' then
begin
if f1 <> '' then o1 := o1 + ', ' + f1;
if m1 <> '' then o1 := o1 + ' ' + m1;
item.AddPair('Officer1', o1);
end;
o2 := Trim(FDb.uqUnitListOFFICER2_LAST_NAME.AsString);
f2 := Trim(FDb.uqUnitListOFFICER2_FIRST_NAME.AsString);
m2 := Trim(FDb.uqUnitListOFFICER2_MI.AsString);
if o2 <> '' then
begin
if f2 <> '' then o2 := o2 + ', ' + f2;
if m2 <> '' then o2 := o2 + ' ' + m2;
item.AddPair('Officer2', o2);
end;
data.AddElement(item);
Next;
end;
end;
obj.AddPair('count', TJSONNumber.Create(data.Count));
obj.AddPair('returned', TJSONNumber.Create(data.Count));
obj.AddPair('data', data);
Result := obj.ToJSON;
finally
FDb.uqUnitList.Close;
obj.Free;
end;
end;
function TWsDataModel.BuildComplaintListJson: string;
var
obj: TJSONObject;
data: TJSONArray;
item: TJSONObject;
lastDistrict, curAgency: string;
status, statusColor, statusTextColor: string;
colorVal: Integer;
complaintNumber: string;
begin
obj := TJSONObject.Create;
data := TJSONArray.Create;
lastDistrict := '';
try
obj.AddPair('RequestId', WS_MSG_COMPLAINT_LIST);
with FDb.uqComplaintList do
begin
Open;
(FieldByName('DATEREPORTED') as TDateTimeField).DisplayFormat := 'yyyy-mm-dd hh:nn:ss';
First;
while not Eof do
begin
if not FieldByName('DATEARRIVED').IsNull then
begin
status := 'On Scene'; statusColor := '#22C55E'; statusTextColor := '#000000';
end
else if not FieldByName('DATERESPONDED').IsNull then
begin
status := 'Enroute'; statusColor := '#FFFF00'; statusTextColor := '#000000';
end
else if not FieldByName('DATEDISPATCHED').IsNull then
begin
status := 'Dispatched'; statusColor := '#FFFF00'; statusTextColor := '#000000';
end
else
begin
status := 'Pending'; statusColor := '#FF8080'; statusTextColor := '#000000';
end;
item := TJSONObject.Create;
curAgency := Trim(FDb.uqComplaintListAGENCY.AsString);
if curAgency = '' then curAgency := 'Unknown Agency';
if not SameText(curAgency, lastDistrict) then
item.AddPair('DistrictHeader', curAgency);
lastDistrict := curAgency;
item.AddPair('AgencyLine', 'Agency: ' + curAgency);
colorVal := FDb.uqComplaintListPRIORITY_COLOR.AsInteger;
item.AddPair('PriorityColor', '#' + IntToHex(colorVal and $FFFFFF, 6));
item.AddPair('PriorityTextColor', '#000000');
complaintNumber := FDb.uqComplaintListcomplaintNumber.AsString;
item.AddPair('ComplaintId', FDb.uqComplaintListCOMPLAINTID.AsString);
item.AddPair('Complaint', complaintNumber);
item.AddPair('Agency', FDb.uqComplaintListAGENCY.AsString);
item.AddPair('Priority', FDb.uqComplaintListPRIORITY.AsString);
item.AddPair('DispatchCodeDesc', FDb.uqComplaintListDISPATCH_CODE_DESC.AsString);
item.AddPair('Address', FDb.uqComplaintListADDRESS.AsString);
item.AddPair('Business', FDb.uqComplaintListBUSINESS.AsString);
item.AddPair('CFSId', FDb.uqComplaintListCFSID.AsString);
item.AddPair('Status', status);
item.AddPair('StatusColor', statusColor);
item.AddPair('StatusTextColor', statusTextColor);
item.AddPair('DispatchDistrict', FDb.uqComplaintListDISPATCHDISTRICT.AsString);
item.AddPair('DateReported', FDb.uqComplaintListDATEREPORTED.AsString);
data.AddElement(item);
Next;
end;
end;
obj.AddPair('count', TJSONNumber.Create(data.Count));
obj.AddPair('returned', TJSONNumber.Create(data.Count));
obj.AddPair('data', data);
Result := obj.ToJSON;
finally
FDb.uqComplaintList.Close;
obj.Free;
end;
end;
end.
emiMobileServer/Source/Ws.Server.Module.dfm 0 → 100644
object WsServerModule: TWsServerModule
OldCreateOrder = False
OnCreate = DataModuleCreate
OnDestroy = DataModuleDestroy
Height = 150
Width = 150
end
emiMobileServer/Source/Ws.Server.Module.pas 0 → 100644
unit Ws.Server.Module;
interface
uses
System.SysUtils, System.Classes,
WebSocket.Manager,
Ws.DataModel;
type
TWsServerModule = class(TDataModule)
procedure DataModuleCreate(Sender: TObject);
procedure DataModuleDestroy(Sender: TObject);
private
FManager: TWebSocketManager;
FDataModel: TWsDataModel;
function GetOnClientsChanged: TClientsChangedEvent;
procedure SetOnClientsChanged(const AValue: TClientsChangedEvent);
public
procedure StartWsServer(ABaseUrl: string; AModelName: string);
procedure Broadcast(const AMessage: string);
function GetClientSnapshots: TArray<TConnectedClientSnapshot>;
property OnClientsChanged: TClientsChangedEvent
read GetOnClientsChanged write SetOnClientsChanged;
end;
var
WsServerModule: TWsServerModule;
implementation
uses
Common.Logging;
{$R *.dfm}
procedure TWsServerModule.DataModuleCreate(Sender: TObject);
begin
FManager := TWebSocketManager.Create;
end;
procedure TWsServerModule.DataModuleDestroy(Sender: TObject);
begin
FDataModel.Free;
FDataModel := nil;
FManager.Free;
FManager := nil;
end;
procedure TWsServerModule.StartWsServer(ABaseUrl: string; AModelName: string);
begin
FManager.Start;
Logger.Log(1, Format('WebSocket server listening on port %d', [WEBSOCKET_PORT]));
FDataModel := TWsDataModel.Create(
procedure(const AMessage: string)
begin
Broadcast(AMessage);
end,
30000 // broadcast interval in ms
);
Logger.Log(1, 'WsDataModel started (30 s broadcast interval)');
end;
procedure TWsServerModule.Broadcast(const AMessage: string);
begin
FManager.Broadcast(AMessage);
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.
emiMobileServer/Source/Ws.Service.pas 0 → 100644
unit Ws.Service;
interface
const
WS_MODEL = 'WsApi'; // retained for call-site compatibility in Main.pas
implementation
end.
emiMobileServer/Source/Ws.ServiceImpl.pas 0 → 100644
unit Ws.ServiceImpl;
// Stub retained for project compatibility. Implementation moved to Ws.Server.Module.
interface
implementation
end.
emiMobileServer/Source/shared/BaseRequest.pas 0 → 100644
unit BaseRequest;
interface
uses
Pkg.Json.DTO, System.Generics.Collections, REST.Json.Types;
{$M+}
type
TRequest = class(TJsonDTO)
private
[JSONName('device_id')]
FDeviceId: string;
FRequestId: string;
FSessionId: string;
published
property DeviceId: string read FDeviceId write FDeviceId;
property RequestId: string read FRequestId write FRequestId;
property SessionId: string read FSessionId write FSessionId;
procedure FromJson(aValue: string);
end;
TBaseRequest = class(TJsonDTO)
private
[JSONName('request'), JSONMarshalled(False)]
FRequestArray: TArray<TRequest>;
[GenericListReflect]
FRequest: TObjectList<TRequest>;
function GetRequest: TObjectList<TRequest>;
protected
function GetAsJson: string; override;
//procedure SetAsJson(aValue: string); virtual;
published
property Request: TObjectList<TRequest> read GetRequest;
procedure FromJson(aValue: string);
public
destructor Destroy; override;
end;
implementation
procedure TRequest.FromJson(aValue: string);
begin
TRequest(Self).SetAsJson(aValue);
end;
procedure TBaseRequest.FromJson(aValue: string);
begin
TBaseRequest(Self).SetAsJson(aValue);
end;
{ TBaseRequest }
destructor TBaseRequest.Destroy;
begin
GetRequest.Free;
inherited;
end;
function TBaseRequest.GetRequest: TObjectList<TRequest>;
begin
Result := ObjectList<TRequest>(FRequest, FRequestArray);
end;
function TBaseRequest.GetAsJson: string;
begin
RefreshArray<TRequest>(FRequest, FRequestArray);
Result := inherited;
end;
end.
emiMobileServer/Source/shared/LoginRequest.pas 0 → 100644
unit LoginRequest;
interface
uses
Pkg.Json.DTO,
System.Generics.Collections,
REST.Json.Types,
BaseRequest;
{$M+}
type
TLoginInfo = class
private
FCarNumber: string;
FDistrict: string;
FMileage: string;
FShift: string;
FShiftDate: string;
FUnitName: string;
FUnitType: string;
published
property CarNumber: string read FCarNumber write FCarNumber;
property District: string read FDistrict write FDistrict;
property Mileage: string read FMileage write FMileage;
property Shift: string read FShift write FShift;
property ShiftDate: string read FShiftDate write FShiftDate;
property UnitName: string read FUnitName write FUnitName;
property UnitType: string read FUnitType write FUnitType;
end;
TLoginRequest = class(TRequest)
private
[JSONName('device_id')]
FDeviceId: string;
FLoginInfo: TLoginInfo;
FPass: string;
FRelogin: Boolean;
FRequestId: string;
FSessionId: string;
FUnitnumber: string;
FUser: string;
FVersion: string;
published
property DeviceId: string read FDeviceId write FDeviceId;
property LoginInfo: TLoginInfo read FLoginInfo;
property Pass: string read FPass write FPass;
property Relogin: Boolean read FRelogin write FRelogin;
property RequestId: string read FRequestId write FRequestId;
property SessionId: string read FSessionId write FSessionId;
property Unitnumber: string read FUnitnumber write FUnitnumber;
property User: string read FUser write FUser;
property Version: string read FVersion write FVersion;
public
constructor Create; override;
destructor Destroy; override;
end;
implementation
{ TLoginRequest }
constructor TLoginRequest.Create;
begin
inherited;
FLoginInfo := TLoginInfo.Create;
end;
destructor TLoginRequest.Destroy;
begin
FLoginInfo.Free;
inherited;
end;
end.
emiMobileServer/Source/shared/Pkg.Json.DTO.pas 0 → 100644
unit Pkg.Json.DTO;
interface
uses System.Classes, System.Json, Rest.Json, System.Generics.Collections, Rest.JsonReflect;
type
TArrayMapper = class
protected
procedure RefreshArray<T>(aSource: TList<T>; var aDestination: TArray<T>);
function List<T>(var aList: TList<T>; aSource: TArray<T>): TList<T>;
function ObjectList<T: class>(var aList: TObjectList<T>; aSource: TArray<T>): TObjectList<T>;
public
constructor Create; virtual;
end;
TJsonDTO = class(TArrayMapper)
private
FOptions: TJsonOptions;
class procedure PrettyPrintPair(aJSONValue: TJSONPair; aOutputStrings: TStrings; Last: Boolean; Indent: Integer);
class procedure PrettyPrintJSON(aJSONValue: TJsonValue; aOutputStrings: TStrings; Indent: Integer = 0); overload;
class procedure PrettyPrintArray(aJSONValue: TJSONArray; aOutputStrings: TStrings; Last: Boolean; Indent: Integer);
protected
function GetAsJson: string; virtual;
procedure SetAsJson(aValue: string); virtual;
public
constructor Create; override;
class function PrettyPrintJSON(aJson: string): string; overload;
function ToString: string; override;
function Clone<T: TJsonDTO, constructor>: T;
property AsJson: string read GetAsJson write SetAsJson;
end;
GenericListReflectAttribute = class(JsonReflectAttribute)
public
constructor Create;
end;
SuppressZeroAttribute = class(JsonReflectAttribute)
public
constructor Create;
end;
implementation
uses System.Sysutils, System.JSONConsts, System.Rtti, System.DateUtils;
{ TJsonDTO }
function TJsonDTO.Clone<T>: T;
begin
Result := T.Create;
Result.AsJson := AsJson;
end;
constructor TJsonDTO.Create;
begin
inherited;
FOptions := [joDateIsUTC, joDateFormatISO8601];
end;
function TJsonDTO.GetAsJson: string;
begin
Result := TJson.ObjectToJsonString(Self, FOptions);
end;
const
INDENT_SIZE = 2;
class procedure TJsonDTO.PrettyPrintJSON(aJSONValue: TJsonValue; aOutputStrings: TStrings; Indent: Integer);
var
i: Integer;
Ident: Integer;
begin
Ident := Indent + INDENT_SIZE;
i := 0;
if aJSONValue is TJSONObject then
begin
aOutputStrings.Add(StringOfChar(' ', Ident) + '{');
for i := 0 to TJSONObject(aJSONValue).Count - 1 do
PrettyPrintPair(TJSONObject(aJSONValue).Pairs[i], aOutputStrings, i = TJSONObject(aJSONValue).Count - 1, Ident);
aOutputStrings.Add(StringOfChar(' ', Ident) + '}');
end
else if aJSONValue is TJSONArray then
PrettyPrintArray(TJSONArray(aJSONValue), aOutputStrings, i = TJSONObject(aJSONValue).Count - 1, Ident)
else
aOutputStrings.Add(StringOfChar(' ', Ident) + aJSONValue.ToString);
end;
class procedure TJsonDTO.PrettyPrintArray(aJSONValue: TJSONArray; aOutputStrings: TStrings; Last: Boolean; Indent: Integer);
var
i: Integer;
begin
aOutputStrings.Add(StringOfChar(' ', Indent + INDENT_SIZE) + '[');
for i := 0 to aJSONValue.Count - 1 do
begin
PrettyPrintJSON(aJSONValue.Items[i], aOutputStrings, Indent);
if i < aJSONValue.Count - 1 then
aOutputStrings[aOutputStrings.Count - 1] := aOutputStrings[aOutputStrings.Count - 1] + ',';
end;
aOutputStrings.Add(StringOfChar(' ', Indent + INDENT_SIZE - 2) + ']');
end;
class function TJsonDTO.PrettyPrintJSON(aJson: string): string;
var
StringList: TStringlist;
JSONValue: TJsonValue;
begin
StringList := TStringlist.Create;
try
JSONValue := TJSONObject.ParseJSONValue(aJson);
try
if JSONValue <> nil then
PrettyPrintJSON(JSONValue, StringList);
finally
JSONValue.Free;
end;
Result := StringList.Text;
finally
StringList.Free;
end;
end;
class procedure TJsonDTO.PrettyPrintPair(aJSONValue: TJSONPair; aOutputStrings: TStrings; Last: Boolean; Indent: Integer);
const
TEMPLATE = '%s:%s';
var
Line: string;
NewList: TStringlist;
begin
NewList := TStringlist.Create;
try
PrettyPrintJSON(aJSONValue.JSONValue, NewList, Indent);
Line := Format(TEMPLATE, [aJSONValue.JsonString.ToString, Trim(NewList.Text)]);
finally
NewList.Free;
end;
Line := StringOfChar(' ', Indent + INDENT_SIZE) + Line;
if not Last then
Line := Line + ',';
aOutputStrings.Add(Line);
end;
procedure TJsonDTO.SetAsJson(aValue: string);
var
JSONValue: TJsonValue;
JSONObject: TJSONObject;
begin
JSONValue := TJSONObject.ParseJSONValue(aValue);
try
if not Assigned(JSONValue) then
Exit;
if (JSONValue is TJSONArray) then
begin
with TJSONUnMarshal.Create do
try
SetFieldArray(Self, 'Items', (JSONValue as TJSONArray));
finally
Free;
end;
Exit;
end;
if (JSONValue is TJSONObject) then
JSONObject := JSONValue as TJSONObject
else
begin
aValue := aValue.Trim;
if (aValue = '') and not Assigned(JSONValue) or (aValue <> '') and Assigned(JSONValue) and JSONValue.Null then
Exit
else
raise EConversionError.Create(SCannotCreateObject);
end;
TJson.JsonToObject(Self, JSONObject, FOptions);
finally
JSONValue.Free;
end;
end;
function TJsonDTO.ToString: string;
begin
Result := AsJson;
end;
{ TArrayMapper }
constructor TArrayMapper.Create;
begin
inherited;
end;
function TArrayMapper.List<T>(var aList: TList<T>; aSource: TArray<T>): TList<T>;
begin
if aList = nil then
begin
aList := TList<T>.Create;
aList.AddRange(aSource);
end;
Exit(aList);
end;
function TArrayMapper.ObjectList<T>(var aList: TObjectList<T>; aSource: TArray<T>): TObjectList<T>;
var
Element: T;
begin
if aList = nil then
begin
aList := TObjectList<T>.Create;
for Element in aSource do
aList.Add(Element);
end;
Exit(aList);
end;
procedure TArrayMapper.RefreshArray<T>(aSource: TList<T>; var aDestination: TArray<T>);
begin
if aSource <> nil then
aDestination := aSource.ToArray;
end;
type
TGenericListFieldInterceptor = class(TJSONInterceptor)
public
function ObjectsConverter(Data: TObject; Field: string): TListOfObjects; override;
end;
{ TListFieldInterceptor }
function TGenericListFieldInterceptor.ObjectsConverter(Data: TObject; Field: string): TListOfObjects;
var
ctx: TRttiContext;
List: TList<TObject>;
RttiProperty: TRttiProperty;
begin
RttiProperty := ctx.GetType(Data.ClassInfo).GetProperty(Copy(Field, 2, MAXINT));
List := TList<TObject>(RttiProperty.GetValue(Data).AsObject);
Result := TListOfObjects(List.List);
SetLength(Result, List.Count);
end;
constructor GenericListReflectAttribute.Create;
begin
inherited Create(ctObjects, rtObjects, TGenericListFieldInterceptor, nil, false);
end;
type
TSuppressZeroDateInterceptor = class(TJSONInterceptor)
public
function StringConverter(Data: TObject; Field: string): string; override;
procedure StringReverter(Data: TObject; Field: string; Arg: string); override;
end;
function TSuppressZeroDateInterceptor.StringConverter(Data: TObject; Field: string): string;
var
RttiContext: TRttiContext;
Date: TDateTime;
begin
Date := RttiContext.GetType(Data.ClassType).GetField(Field).GetValue(Data).AsType<TDateTime>;
if Date = 0 then
Result := string.Empty
else
Result := DateToISO8601(Date, True);
end;
procedure TSuppressZeroDateInterceptor.StringReverter(Data: TObject; Field, Arg: string);
var
RttiContext: TRttiContext;
Date: TDateTime;
begin
if Arg.IsEmpty then
Date := 0
else
Date := ISO8601ToDate(Arg, True);
RttiContext.GetType(Data.ClassType).GetField(Field).SetValue(Data, Date);
end;
{ SuppressZeroAttribute }
constructor SuppressZeroAttribute.Create;
begin
inherited Create(ctString, rtString, TSuppressZeroDateInterceptor);
end;
end.
emiMobileServer/Source/shared/WsMessages.pas 0 → 100644
unit WsMessages;
// WebSocket push message types.
// Each constant is the value of RequestId that identifies the message kind.
// Server builds and broadcasts; client dispatches on RequestId.
interface
uses
BaseRequest, Pkg.Json.DTO, REST.Json.Types;
{$M+}
const
WS_MSG_BADGE_COUNTS = 'BADGE_COUNTS';
WS_MSG_UNIT_MAP = 'UNIT_MAP';
WS_MSG_COMPLAINT_MAP = 'COMPLAINT_MAP';
WS_MSG_UNIT_LIST = 'UNIT_LIST';
WS_MSG_COMPLAINT_LIST = 'COMPLAINT_LIST';
type
// Simple typed DTO — serialized directly via AsJson for broadcast.
TWsBadgeCountsMessage = class(TRequest)
private
FBadgeComplaints: Integer;
FBadgeUnits: Integer;
published
property BadgeComplaints: Integer read FBadgeComplaints write FBadgeComplaints;
property BadgeUnits: Integer read FBadgeUnits write FBadgeUnits;
public
constructor Create;
end;
// Array-payload messages: server adds RequestId to the existing TJSONObject
// produced by the DB query methods, then broadcasts as a plain JSON string.
// These classes exist for requestId-based type identification and future
// client→server use (cast a received TRequest to the appropriate type).
TWsUnitMapMessage = class(TRequest) public constructor Create; end;
TWsComplaintMapMessage = class(TRequest) public constructor Create; end;
TWsUnitListMessage = class(TRequest) public constructor Create; end;
TWsComplaintListMessage = class(TRequest) public constructor Create; end;
implementation
constructor TWsBadgeCountsMessage.Create;
begin
inherited;
RequestId := WS_MSG_BADGE_COUNTS;
end;
constructor TWsUnitMapMessage.Create;
begin
inherited;
RequestId := WS_MSG_UNIT_MAP;
end;
constructor TWsComplaintMapMessage.Create;
begin
inherited;
RequestId := WS_MSG_COMPLAINT_MAP;
end;
constructor TWsUnitListMessage.Create;
begin
inherited;
RequestId := WS_MSG_UNIT_LIST;
end;
constructor TWsComplaintListMessage.Create;
begin
inherited;
RequestId := WS_MSG_COMPLAINT_LIST;
end;
end.
emiMobileServer/Source/utils/DTOGeneratorUtils.pas 0 → 100644
unit DTOGeneratorUtils;
interface
uses
SysUtils, Classes, Uni, UniProvider, DB, System.JSON, Pkg.Json.DTO;
procedure GenerateDelphiJDOForTable(UniConnection: TUniConnection; const TableName: string; S: TStrings);
function GenerateJsonDTOFromJson(const JsonStr, ClassName: string): string;
function JsonTypeToDelphiType(const Value: TJSONValue): string;
function SqlTypeToDelphiType(const SqlType: string): string;
procedure GenerateJDOsForTables(UniConn: TUniConnection);
procedure JsonToDTO(JsonStr:string);
implementation
function JsonTypeToDelphiType(const Value: TJSONValue): string;
begin
if Value is TJSONNumber then
begin
if Pos('.', Value.Value) > 0 then
Result := 'Double'
else
Result := 'Integer'
end
else if Value is TJSONString then
Result := 'string'
else if Value is TJSONBool then
Result := 'Boolean'
else if Value is TJSONArray then
Result := 'TArray<string>' // Or further analysis could detect array of objects/numbers/etc
else if Value is TJSONObject then
Result := 'TObject' // Extend for nested DTOs if needed
else if Value is TJSONNull then
Result := 'Variant'
else
Result := 'string'
end;
function SqlTypeToDelphiType(const SqlType: string): string;
begin
if SqlType.Contains('int') then
Result := 'Integer'
else if SqlType.Contains('char') or SqlType.Contains('text') then
Result := 'string'
else if SqlType.Contains('bool') then
Result := 'Boolean'
else if SqlType.Contains('date') or SqlType.Contains('time') then
Result := 'TDateTime'
else if SqlType.Contains('double') or SqlType.Contains('numeric') or SqlType.Contains('real') then
Result := 'Double'
else
Result := 'string'; // fallback
end;
//utility
function PascalCase(const S: string): string;
var
i: Integer;
NextUpper: Boolean;
begin
Result := '';
NextUpper := True;
for i := 1 to Length(S) do
begin
if S[i] in ['a'..'z', 'A'..'Z', '0'..'9'] then
begin
if NextUpper then
Result := Result + UpCase(S[i])
else
Result := Result + LowerCase(S[i]);
NextUpper := False;
end
else
NextUpper := True;
end;
end;
procedure GenerateDelphiJDOForTable(UniConnection: TUniConnection; const TableName: string; S: TStrings);
var
Q: TUniQuery;
FieldName, FieldType, DelphiType: string;
begin
Q := TUniQuery.Create(nil);
try
Q.Connection := UniConnection;
Q.SQL.Text := Format(
'SELECT column_name, data_type ' +
'FROM information_schema.columns ' +
'WHERE table_name = %s ORDER BY ordinal_position', [QuotedStr(TableName)]);
Q.Open;
S.Add('type');
S.Add(' T' + TableName + 'JDO = class');
S.Add(' public');
while not Q.Eof do
begin
FieldName := Q.FieldByName('column_name').AsString;
FieldType := Q.FieldByName('data_type').AsString;
DelphiType := SqlTypeToDelphiType(FieldType);
// PascalCase the field
FieldName := StringReplace(FieldName, '_', '', [rfReplaceAll]);
FieldName[1] := UpCase(FieldName[1]);
S.Add(Format(' %s: %s;', [FieldName, DelphiType]));
Q.Next;
end;
S.Add(' end;');
S.Add('');
finally
Q.Free;
end;
end;
procedure GenerateJDOsForTables(UniConn: TUniConnection);
var
TableList: TArray<string>;
Table: string;
OutCode: TStringList;
begin
TableList := ['customer', 'orders', 'product']; // put your schema table names here
OutCode := TStringList.Create;
try
for Table in TableList do
begin
OutCode.Clear();
GenerateDelphiJDOForTable(UniConn, Table, OutCode);
// Output to console, file, or in-memory
OutCode.SaveToFile(Table+'JDOs.pas');
//Writeln(OutCode.Text);
end;
finally
OutCode.Free;
UniConn.Free;
end;
end;
function GenerateJsonDTOFromJson(const JsonStr, ClassName: string): string;
var
Json: TJSONObject;
JPair: TJSONPair;
FieldType, PubPropName, PriFieldName: string;
Code: TStringList;
begin
Code := TStringList.Create;
try
Json := TJSONObject.ParseJSONValue(JsonStr) as TJSONObject;
if not Assigned(Json) then
raise Exception.Create('Invalid/Unsupported JSON root object.');
Code.Add('type');
Code.Add(' T' + PascalCase(ClassName) + 'DTO = class(TJsonDTO)');
Code.Add(' private');
// Private fields
for JPair in Json do
begin
FieldType := JsonTypeToDelphiType(JPair.JsonValue);
PriFieldName := 'F' + PascalCase(JPair.JsonString.Value);
Code.Add(Format(' %s: %s;', [PriFieldName, FieldType]));
end;
Code.Add(' published');
// Published properties (JSON mapping)
for JPair in Json do
begin
FieldType := JsonTypeToDelphiType(JPair.JsonValue);
PubPropName := JPair.JsonString.Value; // Use original JSON key for property
PriFieldName := 'F' + PascalCase(PubPropName);
Code.Add(Format(' property %s: %s read %s write %s;', [
PubPropName, FieldType, PriFieldName, PriFieldName
]));
end;
Code.Add(' end;');
Result := Code.Text;
Json.Free;
finally
Code.Free;
end;
end;
procedure JsonToDTO(JsonStr:string);
var
ClassName: string;
ClassSource: string;
OutCode: TStringList;
begin
OutCode := TStringList.Create;
try
ClassName:='Customer';
JsonStr := '{ "id": 1, "name": "Alice", "isActive": true, "score": 42.1, "tags": ["one", "two"] }';
ClassSource := GenerateJsonDTOFromJson(JsonStr, ClassName);
Writeln(ClassSource);
OutCode.SaveToFile(ClassName+'JDOs.pas');
//Writeln(OutCode.Text);
finally
OutCode.Free
end;
end;
end.
emiMobileServer/emiMobileServer.dpr
...@@ -22,6 +22,15 @@ uses ...@@ -22,6 +22,15 @@ uses
Api.ServiceImpl in 'Source\Api.ServiceImpl.pas', Api.ServiceImpl in 'Source\Api.ServiceImpl.pas',
App.Server.Module in 'Source\App.Server.Module.pas' {AppServerModule: TDataModule}, App.Server.Module in 'Source\App.Server.Module.pas' {AppServerModule: TDataModule},
Common.Ini in 'Source\Common.Ini.pas', Common.Ini in 'Source\Common.Ini.pas',
BaseRequest in 'Source\shared\BaseRequest.pas',
LoginRequest in 'Source\shared\LoginRequest.pas',
Pkg.Json.DTO in 'Source\shared\Pkg.Json.DTO.pas',
DTOGeneratorUtils in 'Source\utils\DTOGeneratorUtils.pas',
Ws.Service in 'Source\Ws.Service.pas',
Ws.ServiceImpl in 'Source\Ws.ServiceImpl.pas',
Ws.Server.Module in 'Source\Ws.Server.Module.pas' {WsServerModule: TDataModule},
Ws.DataModel in 'Source\Ws.DataModel.pas',
WsMessages in 'Source\shared\WsMessages.pas',
WebSocket.Manager in 'Source\WebSocket.Manager.pas'; WebSocket.Manager in 'Source\WebSocket.Manager.pas';
type type
......
emiMobileServer/emiMobileServer.dproj
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup> <PropertyGroup>
<ProjectGuid>{2A3028D9-BC39-4625-9BA5-0338012E2824}</ProjectGuid> <ProjectGuid>{2A3028D9-BC39-4625-9BA5-0338012E2824}</ProjectGuid>
<ProjectVersion>20.4</ProjectVersion> <ProjectVersion>20.4</ProjectVersion>
...@@ -72,7 +72,7 @@ ...@@ -72,7 +72,7 @@
<SanitizedProjectName>emiMobileServer</SanitizedProjectName> <SanitizedProjectName>emiMobileServer</SanitizedProjectName>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Base_Win32)'!=''"> <PropertyGroup Condition="'$(Base_Win32)'!=''">
<DCC_UsePackage>gtFRExpD28;vclwinx;dacvcl280;FlexCel_Report;fmx;PKIEDB28;vclie;DbxCommonDriver;bindengine;IndyIPCommon;VCLRESTComponents;FireDACCommonODBC;aurelius;TMSCloudPkgDEDXE14;FireDACCommonDriver;sparkle;appanalytics;IndyProtocols;vclx;TatukGIS_DK11_RX11_VCL;FMXTMSFNCMapsPkgDXE14;IndyIPClient;dbxcds;vcledge;dac280;frxe28;bindcompvclwinx;gtScaleRichVwExpD28;VCLTMSFNCUIPackPkgDXE14;gtXPressExpD28;unidac280;gtPDFkitD11ProP;FlexCel_Pdf;bindcompfmx;AdvChartDEDXE14;madBasic_;VCLTMSFNCDashboardPackPkgDXE14;SKIA_FlexCel_Core;TMSVCLUIPackPkgDXE14;inetdb;TatukGIS_DK11_RX11_FMX;AcroPDF;TatukGIS_DK11_RX11;FireDACSqliteDriver;DbxClientDriver;soapmidas;vclCryptoPressStreamD28;vclactnband;gtRBExpD28;fmxFireDAC;dbexpress;DBXMySQLDriver;VclSmp;inet;unidacvcl280;dacfmx280;SigPlus;fcstudiowin;vcltouch;fmxase;VCLTMSFNCMapsPkgDXE14;ipstudiowin;TMSWEBCorePkgLibDXE14;frx28;dbrtl;QRWRunDXE11_w64;TMSWEBCorePkgDXE14;fmxdae;addict4_d28;FlexCel_XlsAdapter;gtAdvGridExpD28;FireDACMSAccDriver;VCL_FlexCel_Core;CustomIPTransport;tmsbcl;ipstudiowinwordxp;gtDocEngD28;gtRaveExpD28;FMXTMSFNCDashboardPackPkgDXE14;vcldsnap;madExcept_;DBXInterBaseDriver;frxDB28;IndySystem;ipstudiowinclient;VCLTMSFNCCorePkgDXE14;vcldb;CamRemoteD11;FMXTMSFNCUIPackPkgDXE14;TMSCloudPkgDXE14;gtQRExpD28;VirtualTreesR;WPViewPDF_RT;FlexCel_Core;vclFireDAC;vquery280;madDisAsm_;bindcomp;FireDACCommon;FlexCel_Render;unidacfmx280;FMXTMSFNCCorePkgDXE14;IndyCore;RESTBackendComponents;gtACEExpD28;bindcompdbx;rtl;FireDACMySQLDriver;FireDACADSDriver;VCL_FlexCel_Components;RESTComponents;DBXSqliteDriver;vcl;IndyIPServer;dsnapxml;dsnapcon;adortl;TMSVCLUIPackPkgExDXE14;WPViewPDF_DT;TMSVCLUIPackPkgWizDXE14;gtHtmVwExpD28;AdvChartDXE14;gtRichVwExpD28;vclimg;FireDACPgDriver;FireDAC;inetdbxpress;TMSVCLUIPackPkgXlsDXE14;xmlrtl;tethering;PKIECtrl28;crcontrols280;bindcompvcl;dsnap;xdata;CloudService;fmxobj;bindcompvclsmp;addict4db_d28;CEF4Delphi;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage)</DCC_UsePackage> <DCC_UsePackage>gtFRExpD28;vclwinx;dacvcl280;FlexCel_Report;fmx;PKIEDB28;vclie;DbxCommonDriver;bindengine;IndyIPCommon;VCLRESTComponents;FireDACCommonODBC;aurelius;TMSCloudPkgDEDXE14;FireDACCommonDriver;sparkle;appanalytics;IndyProtocols;vclx;TatukGIS_DK11_RX11_VCL;FMXTMSFNCMapsPkgDXE14;IndyIPClient;dbxcds;vcledge;dac280;frxe28;bindcompvclwinx;gtScaleRichVwExpD28;VCLTMSFNCUIPackPkgDXE14;gtXPressExpD28;unidac280;gtPDFkitD11ProP;FlexCel_Pdf;bindcompfmx;AdvChartDEDXE14;madBasic_;VCLTMSFNCDashboardPackPkgDXE14;SKIA_FlexCel_Core;VCLTMSFNCWebSocketPkg;FMXTMSFNCWebSocketPkg;TMSVCLUIPackPkgDXE14;inetdb;TatukGIS_DK11_RX11_FMX;AcroPDF;TatukGIS_DK11_RX11;FireDACSqliteDriver;DbxClientDriver;soapmidas;vclCryptoPressStreamD28;vclactnband;gtRBExpD28;fmxFireDAC;dbexpress;DBXMySQLDriver;VclSmp;inet;unidacvcl280;dacfmx280;SigPlus;fcstudiowin;vcltouch;fmxase;VCLTMSFNCMapsPkgDXE14;ipstudiowin;TMSWEBCorePkgLibDXE14;frx28;dbrtl;QRWRunDXE11_w64;TMSWEBCorePkgDXE14;fmxdae;addict4_d28;FlexCel_XlsAdapter;gtAdvGridExpD28;FireDACMSAccDriver;VCL_FlexCel_Core;CustomIPTransport;tmsbcl;ipstudiowinwordxp;gtDocEngD28;gtRaveExpD28;FMXTMSFNCDashboardPackPkgDXE14;vcldsnap;madExcept_;DBXInterBaseDriver;frxDB28;IndySystem;ipstudiowinclient;VCLTMSFNCCorePkgDXE14;vcldb;CamRemoteD11;FMXTMSFNCUIPackPkgDXE14;TMSCloudPkgDXE14;gtQRExpD28;VirtualTreesR;WPViewPDF_RT;FlexCel_Core;vclFireDAC;vquery280;madDisAsm_;bindcomp;FireDACCommon;FlexCel_Render;unidacfmx280;FMXTMSFNCCorePkgDXE14;IndyCore;RESTBackendComponents;gtACEExpD28;bindcompdbx;rtl;FireDACMySQLDriver;FireDACADSDriver;VCL_FlexCel_Components;RESTComponents;DBXSqliteDriver;vcl;IndyIPServer;dsnapxml;dsnapcon;adortl;TMSVCLUIPackPkgExDXE14;WPViewPDF_DT;TMSVCLUIPackPkgWizDXE14;gtHtmVwExpD28;AdvChartDXE14;gtRichVwExpD28;vclimg;FireDACPgDriver;FireDAC;inetdbxpress;TMSVCLUIPackPkgXlsDXE14;xmlrtl;tethering;PKIECtrl28;crcontrols280;bindcompvcl;dsnap;xdata;CloudService;fmxobj;bindcompvclsmp;addict4db_d28;CEF4Delphi;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage)</DCC_UsePackage>
<DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace>
<BT_BuildType>Debug</BT_BuildType> <BT_BuildType>Debug</BT_BuildType>
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
...@@ -81,7 +81,7 @@ ...@@ -81,7 +81,7 @@
<Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File> <Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Base_Win64)'!=''"> <PropertyGroup Condition="'$(Base_Win64)'!=''">
<DCC_UsePackage>vclwinx;FlexCel_Report;fmx;PKIEDB28;vclie;DbxCommonDriver;bindengine;IndyIPCommon;VCLRESTComponents;FireDACCommonODBC;FireDACCommonDriver;appanalytics;IndyProtocols;vclx;FMXTMSFNCMapsPkgDXE14;IndyIPClient;dbxcds;vcledge;bindcompvclwinx;VCLTMSFNCUIPackPkgDXE14;FlexCel_Pdf;bindcompfmx;VCLTMSFNCDashboardPackPkgDXE14;TMSVCLUIPackPkgDXE14;inetdb;FireDACSqliteDriver;DbxClientDriver;soapmidas;vclactnband;fmxFireDAC;dbexpress;DBXMySQLDriver;VclSmp;inet;fcstudiowin;vcltouch;fmxase;VCLTMSFNCMapsPkgDXE14;ipstudiowin;dbrtl;QRWRunDXE11_w64;fmxdae;FlexCel_XlsAdapter;FireDACMSAccDriver;VCL_FlexCel_Core;CustomIPTransport;vcldsnap;DBXInterBaseDriver;IndySystem;ipstudiowinclient;VCLTMSFNCCorePkgDXE14;vcldb;CamRemoteD11;FMXTMSFNCUIPackPkgDXE14;VirtualTreesR;WPViewPDF_RT;FlexCel_Core;vclFireDAC;bindcomp;FireDACCommon;FlexCel_Render;FMXTMSFNCCorePkgDXE14;IndyCore;RESTBackendComponents;bindcompdbx;rtl;FireDACMySQLDriver;FireDACADSDriver;VCL_FlexCel_Components;RESTComponents;DBXSqliteDriver;vcl;IndyIPServer;dsnapxml;dsnapcon;adortl;TMSVCLUIPackPkgExDXE14;AdvChartDXE14;vclimg;FireDACPgDriver;FireDAC;inetdbxpress;TMSVCLUIPackPkgXlsDXE14;xmlrtl;tethering;PKIECtrl28;bindcompvcl;dsnap;CloudService;fmxobj;bindcompvclsmp;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage)</DCC_UsePackage> <DCC_UsePackage>vclwinx;FlexCel_Report;fmx;PKIEDB28;vclie;DbxCommonDriver;bindengine;IndyIPCommon;VCLRESTComponents;FireDACCommonODBC;FireDACCommonDriver;appanalytics;IndyProtocols;vclx;FMXTMSFNCMapsPkgDXE14;IndyIPClient;dbxcds;vcledge;bindcompvclwinx;VCLTMSFNCUIPackPkgDXE14;FlexCel_Pdf;bindcompfmx;VCLTMSFNCDashboardPackPkgDXE14;TMSVCLUIPackPkgDXE14;inetdb;FireDACSqliteDriver;DbxClientDriver;soapmidas;vclactnband;fmxFireDAC;dbexpress;DBXMySQLDriver;VclSmp;inet;fcstudiowin;vcltouch;fmxase;VCLTMSFNCMapsPkgDXE14;ipstudiowin;dbrtl;QRWRunDXE11_w64;fmxdae;FlexCel_XlsAdapter;FMXTMSFNCWebSocketPkg;FireDACMSAccDriver;VCL_FlexCel_Core;CustomIPTransport;vcldsnap;DBXInterBaseDriver;IndySystem;ipstudiowinclient;VCLTMSFNCCorePkgDXE14;vcldb;CamRemoteD11;FMXTMSFNCUIPackPkgDXE14;VirtualTreesR;WPViewPDF_RT;FlexCel_Core;vclFireDAC;bindcomp;FireDACCommon;FlexCel_Render;FMXTMSFNCCorePkgDXE14;IndyCore;RESTBackendComponents;bindcompdbx;rtl;FireDACMySQLDriver;FireDACADSDriver;VCL_FlexCel_Components;RESTComponents;DBXSqliteDriver;vcl;IndyIPServer;dsnapxml;dsnapcon;adortl;TMSVCLUIPackPkgExDXE14;AdvChartDXE14;vclimg;FireDACPgDriver;FireDAC;inetdbxpress;TMSVCLUIPackPkgXlsDXE14;xmlrtl;tethering;PKIECtrl28;bindcompvcl;dsnap;CloudService;fmxobj;bindcompvclsmp;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage)</DCC_UsePackage>
<DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace>
<BT_BuildType>Debug</BT_BuildType> <BT_BuildType>Debug</BT_BuildType>
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
...@@ -165,6 +165,19 @@ ...@@ -165,6 +165,19 @@
<DesignClass>TDataModule</DesignClass> <DesignClass>TDataModule</DesignClass>
</DCCReference> </DCCReference>
<DCCReference Include="Source\Common.Ini.pas"/> <DCCReference Include="Source\Common.Ini.pas"/>
<DCCReference Include="Source\shared\BaseRequest.pas"/>
<DCCReference Include="Source\shared\LoginRequest.pas"/>
<DCCReference Include="Source\shared\Pkg.Json.DTO.pas"/>
<DCCReference Include="Source\utils\DTOGeneratorUtils.pas"/>
<DCCReference Include="Source\Ws.Service.pas"/>
<DCCReference Include="Source\Ws.ServiceImpl.pas"/>
<DCCReference Include="Source\Ws.Server.Module.pas">
<Form>WsServerModule</Form>
<FormType>dfm</FormType>
<DesignClass>TDataModule</DesignClass>
</DCCReference>
<DCCReference Include="Source\Ws.DataModel.pas"/>
<DCCReference Include="Source\shared\WsMessages.pas"/>
<DCCReference Include="Source\WebSocket.Manager.pas"/> <DCCReference Include="Source\WebSocket.Manager.pas"/>
<BuildConfiguration Include="Base"> <BuildConfiguration Include="Base">
<Key>Base</Key> <Key>Base</Key>
...@@ -858,9 +871,6 @@ ...@@ -858,9 +871,6 @@
<Platform Name="Win64x"> <Platform Name="Win64x">
<Operation>1</Operation> <Operation>1</Operation>
</Platform> </Platform>
<Platform Name="WinARM64EC">
<Operation>1</Operation>
</Platform>
</DeployClass> </DeployClass>
<DeployClass Name="ProjectiOSDeviceDebug"> <DeployClass Name="ProjectiOSDeviceDebug">
<Platform Name="iOSDevice32"> <Platform Name="iOSDevice32">
...@@ -931,10 +941,6 @@ ...@@ -931,10 +941,6 @@
<RemoteDir>Assets</RemoteDir> <RemoteDir>Assets</RemoteDir>
<Operation>1</Operation> <Operation>1</Operation>
</Platform> </Platform>
<Platform Name="WinARM64EC">
<RemoteDir>Assets</RemoteDir>
<Operation>1</Operation>
</Platform>
</DeployClass> </DeployClass>
<DeployClass Name="UWP_DelphiLogo44"> <DeployClass Name="UWP_DelphiLogo44">
<Platform Name="Win32"> <Platform Name="Win32">
...@@ -945,10 +951,6 @@ ...@@ -945,10 +951,6 @@
<RemoteDir>Assets</RemoteDir> <RemoteDir>Assets</RemoteDir>
<Operation>1</Operation> <Operation>1</Operation>
</Platform> </Platform>
<Platform Name="WinARM64EC">
<RemoteDir>Assets</RemoteDir>
<Operation>1</Operation>
</Platform>
</DeployClass> </DeployClass>
<DeployClass Name="iOS_AppStore1024"> <DeployClass Name="iOS_AppStore1024">
<Platform Name="iOSDevice64"> <Platform Name="iOSDevice64">
......
webEMIMobile/App.Config.pas
...@@ -14,11 +14,13 @@ type ...@@ -14,11 +14,13 @@ type
FAuthUrl: string; FAuthUrl: string;
FApiUrl: string; FApiUrl: string;
FAppUrl: string; FAppUrl: string;
FWsUrl: string;
public public
constructor Create; constructor Create;
property AuthUrl: string read FAuthUrl write FAuthUrl; property AuthUrl: string read FAuthUrl write FAuthUrl;
property ApiUrl: string read FApiUrl write FApiUrl; property ApiUrl: string read FApiUrl write FApiUrl;
property AppUrl: string read FAppUrl write FAppUrl; property AppUrl: string read FAppUrl write FAppUrl;
property WsUrl: string read FWsUrl write FWsUrl;
end; end;
TConfigLoadedProc = reference to procedure(Config: TAppConfig); TConfigLoadedProc = reference to procedure(Config: TAppConfig);
...@@ -49,6 +51,9 @@ procedure LoadConfig(LoadProc: TConfigLoadedProc); ...@@ -49,6 +51,9 @@ procedure LoadConfig(LoadProc: TConfigLoadedProc);
if JS.toString(Obj['AppUrl']) <> '' then if JS.toString(Obj['AppUrl']) <> '' then
Config.AppUrl := JS.toString(Obj['AppUrl']); Config.AppUrl := JS.toString(Obj['AppUrl']);
if JS.toString(Obj['WsUrl']) <> '' then
Config.WsUrl := JS.toString(Obj['WsUrl']);
end; end;
finally finally
LoadProc(Config); LoadProc(Config);
...@@ -86,6 +91,7 @@ begin ...@@ -86,6 +91,7 @@ begin
FAuthUrl := ''; FAuthUrl := '';
FApiUrl := ''; FApiUrl := '';
FAppUrl := ''; FAppUrl := '';
FWsUrl := '';
end; end;
end. end.
webEMIMobile/ConnectionModule.pas
...@@ -17,8 +17,10 @@ type ...@@ -17,8 +17,10 @@ type
procedure AuthConnectionError(Error: TXDataWebConnectionError); procedure AuthConnectionError(Error: TXDataWebConnectionError);
private private
FUnauthorizedAccessProc: TUnauthorizedAccessProc; FUnauthorizedAccessProc: TUnauthorizedAccessProc;
FWsUrl: string;
public public
const clientVersion = '9.4.0'; property WsUrl: string read FWsUrl;
const clientVersion = '0.1.0';
procedure InitApp(SuccessProc: TSuccessProc; procedure InitApp(SuccessProc: TSuccessProc;
UnauthorizedAccessProc: TUnauthorizedAccessProc); UnauthorizedAccessProc: TUnauthorizedAccessProc);
procedure SetClientConfig(Callback: TVersionCheckCallback); procedure SetClientConfig(Callback: TVersionCheckCallback);
...@@ -74,6 +76,9 @@ procedure TDMConnection.InitApp(SuccessProc: TSuccessProc; ...@@ -74,6 +76,9 @@ procedure TDMConnection.InitApp(SuccessProc: TSuccessProc;
if Config.ApiUrl <> '' then if Config.ApiUrl <> '' then
ApiConnection.URL := Config.ApiUrl; ApiConnection.URL := Config.ApiUrl;
if Config.WsUrl <> '' then
FWsUrl := Config.WsUrl;
AuthConnection.Open(SuccessProc); AuthConnection.Open(SuccessProc);
end; end;
......
webEMIMobile/Module.Websocket.dfm 0 → 100644
object dmWebsocket: TdmWebsocket
Height = 480
Width = 640
object EMiMobileWebSocketClient: TWebSocketClient
UseSSL = True
Port = 443
HostName = 'webapps.em-sys.net'
PathName = '/emiMobile/ws/emimobile'
Protocols.Strings = ()
OnConnect = EMiMobileWebSocketClientConnect
OnBinaryDataReceived = EMiMobileWebSocketClientBinaryDataReceived
OnDisconnect = EMiMobileWebSocketClientDisconnect
OnDataReceived = EMiMobileWebSocketClientDataReceived
OnMessageReceived = EMiMobileWebSocketClientMessageReceived
Left = 218
Top = 130
end
end
webEMIMobile/Module.Websocket.pas 0 → 100644
unit Module.Websocket;
interface
uses
System.SysUtils, System.Classes, WEBLib.WebSocketClient, Web, WEBLib.Controls, WEBLib.Modules,
Auth.Service, JS;
type
// Handler signature: receives the fully parsed JSON object for one push message.
TWsDataHandler = procedure(aData: TJSObject) of object;
TdmWebsocket = class(TWebDataModule)
private
procedure EMiMobileWebSocketClientConnect(Sender: TObject);
procedure EMiMobileWebSocketClientDataReceived(Sender: TObject;
Origin: string; SocketData: TJSObjectRecord);
procedure EMiMobileWebSocketClientDisconnect(Sender: TObject);
procedure EMiMobileWebSocketClientMessageReceived(Sender: TObject;
AMessage: string);
procedure EMiMobileWebSocketClientBinaryDataReceived(Sender: TObject;
AData: TBytes);
procedure DispatchMessage(const AMessage: string);
FOnBadgeCounts: TWsDataHandler;
FOnUnitMap: TWsDataHandler;
FOnComplaintMap: TWsDataHandler;
FOnUnitList: TWsDataHandler;
FOnComplaintList: TWsDataHandler;
public
EMiMobileWebSocketClient: TWebSocketClient;
procedure DataModuleCreate(Sender: TObject);
procedure Connect(const AWsUrl: string);
// Assign these before calling Connect so that pushes are routed immediately.
property OnBadgeCounts: TWsDataHandler read FOnBadgeCounts write FOnBadgeCounts;
property OnUnitMap: TWsDataHandler read FOnUnitMap write FOnUnitMap;
property OnComplaintMap: TWsDataHandler read FOnComplaintMap write FOnComplaintMap;
property OnUnitList: TWsDataHandler read FOnUnitList write FOnUnitList;
property OnComplaintList: TWsDataHandler read FOnComplaintList write FOnComplaintList;
end;
var
dmWebsocket: TdmWebsocket;
implementation
{%CLASSGROUP 'Vcl.Controls.TControl'}
{$R *.dfm}
procedure TdmWebsocket.DataModuleCreate(Sender: TObject);
begin
end;
procedure TdmWebsocket.Connect(const AWsUrl: string);
var
Rest, HostPort, Scheme, Path, Token: string;
ColonSlashSlash, SlashPos, ColonPos: Integer;
begin
if AWsUrl = '' then
Exit;
// Parse ws://host:port/path or wss://host:port/path
ColonSlashSlash := Pos('://', AWsUrl);
if ColonSlashSlash = 0 then
Exit;
Scheme := LowerCase(Copy(AWsUrl, 1, ColonSlashSlash - 1));
Rest := Copy(AWsUrl, ColonSlashSlash + 3, MaxInt);
SlashPos := Pos('/', Rest);
if SlashPos > 0 then
begin
HostPort := Copy(Rest, 1, SlashPos - 1);
Path := Copy(Rest, SlashPos, MaxInt);
end
else
begin
HostPort := Rest;
Path := '/';
end;
// Append JWT token as query param — browsers can't set Authorization headers on WebSocket.
Token := AuthService.GetToken;
if Token <> '' then
begin
if Pos('?', Path) > 0 then
Path := Path + '&token=' + Token
else
Path := Path + '?token=' + Token;
end;
EMiMobileWebSocketClient.PathName := Path;
ColonPos := Pos(':', HostPort);
if ColonPos > 0 then
begin
EMiMobileWebSocketClient.HostName := Copy(HostPort, 1, ColonPos - 1);
if Scheme = 'wss' then
EMiMobileWebSocketClient.Port := StrToIntDef(Copy(HostPort, ColonPos + 1, MaxInt), 443)
else
EMiMobileWebSocketClient.Port := StrToIntDef(Copy(HostPort, ColonPos + 1, MaxInt), 80);
end
else
begin
EMiMobileWebSocketClient.HostName := HostPort;
if Scheme = 'wss' then
EMiMobileWebSocketClient.Port := 443
else
EMiMobileWebSocketClient.Port := 80;
end;
EMiMobileWebSocketClient.UseSSL := (Scheme = 'wss');
EMiMobileWebSocketClient.Active := True;
end;
procedure TdmWebsocket.DispatchMessage(const AMessage: string);
var
obj: TJSObject;
requestId: string;
begin
if AMessage = '' then
Exit;
asm
try {
obj = JSON.parse(AMessage);
} catch(e) {
obj = null;
}
end;
if obj = nil then
begin
console.log('WS: could not parse message');
Exit;
end;
requestId := string(obj['RequestId']);
if SameText(requestId, 'BADGE_COUNTS') then
begin
if Assigned(FOnBadgeCounts) then FOnBadgeCounts(obj);
end
else if SameText(requestId, 'UNIT_MAP') then
begin
if Assigned(FOnUnitMap) then FOnUnitMap(obj);
end
else if SameText(requestId, 'COMPLAINT_MAP') then
begin
if Assigned(FOnComplaintMap) then FOnComplaintMap(obj);
end
else if SameText(requestId, 'UNIT_LIST') then
begin
if Assigned(FOnUnitList) then FOnUnitList(obj);
end
else if SameText(requestId, 'COMPLAINT_LIST') then
begin
if Assigned(FOnComplaintList) then FOnComplaintList(obj);
end
else
console.log('WS: unknown RequestId: ' + requestId);
end;
procedure TdmWebsocket.EMiMobileWebSocketClientBinaryDataReceived(
Sender: TObject; AData: TBytes);
begin
console.log('WS: binary data received (ignored)');
end;
procedure TdmWebsocket.EMiMobileWebSocketClientConnect(Sender: TObject);
begin
console.log('WS: connected');
end;
procedure TdmWebsocket.EMiMobileWebSocketClientDataReceived(Sender: TObject;
Origin: string; SocketData: TJSObjectRecord);
begin
// Text messages arrive via EMiMobileWebSocketClientMessageReceived.
end;
procedure TdmWebsocket.EMiMobileWebSocketClientDisconnect(Sender: TObject);
begin
console.log('WS: disconnected');
end;
procedure TdmWebsocket.EMiMobileWebSocketClientMessageReceived(Sender: TObject;
AMessage: string);
begin
DispatchMessage(AMessage);
end;
end.
webEMIMobile/View.Complaints.pas
...@@ -45,6 +45,7 @@ type ...@@ -45,6 +45,7 @@ type
public public
property OnShowDetails: TSelectProc read FSelectProc write FSelectProc; property OnShowDetails: TSelectProc read FSelectProc write FSelectProc;
procedure RefreshData; procedure RefreshData;
procedure ApplyWsData(aRespObj: TJSObject);
end; end;
var var
...@@ -186,5 +187,22 @@ begin ...@@ -186,5 +187,22 @@ begin
GetComplaints; GetComplaints;
end; end;
procedure TFViewComplaints.ApplyWsData(aRespObj: TJSObject);
var
complaintsCount: Integer;
begin
if FLoading then
Exit;
xdwdsComplaints.Close;
xdwdsComplaints.SetJsonData(aRespObj['data']);
xdwdsComplaints.Open;
ShowHideBusinessRows;
complaintsCount := Integer(aRespObj['count']);
lblEntries.Caption := Format('%d active complaints', [complaintsCount]);
end;
end. end.
webEMIMobile/View.Main.pas
...@@ -7,7 +7,7 @@ uses ...@@ -7,7 +7,7 @@ uses
WEBLib.Forms, WEBLib.Dialogs, WEBLib.ExtCtrls, Vcl.Controls, Vcl.StdCtrls, WEBLib.Forms, WEBLib.Dialogs, WEBLib.ExtCtrls, Vcl.Controls, Vcl.StdCtrls,
WEBLib.StdCtrls, Data.DB, XData.Web.JsonDataset, XData.Web.Dataset, WEBLib.StdCtrls, Data.DB, XData.Web.JsonDataset, XData.Web.Dataset,
App.Types, ConnectionModule, XData.Web.Client, View.Map, View.Units, View.Complaints, App.Types, ConnectionModule, XData.Web.Client, View.Map, View.Units, View.Complaints,
WEBLib.WebSocketClient; Module.Websocket;
type type
TFViewMain = class(TWebForm) TFViewMain = class(TWebForm)
...@@ -33,7 +33,6 @@ type ...@@ -33,7 +33,6 @@ type
pnlArchive: TWebPanel; pnlArchive: TWebPanel;
btnArchiveModalClose: TWebButton; btnArchiveModalClose: TWebButton;
btnLogout: TWebButton; btnLogout: TWebButton;
wsClient: TWebSocketClient;
procedure WebFormCreate(Sender: TObject); procedure WebFormCreate(Sender: TObject);
procedure mnuLogoutClick(Sender: TObject); procedure mnuLogoutClick(Sender: TObject);
procedure lblLogoutClick(Sender: TObject); procedure lblLogoutClick(Sender: TObject);
...@@ -45,10 +44,6 @@ type ...@@ -45,10 +44,6 @@ type
procedure btnDetailsModalCloseClick(Sender: TObject); procedure btnDetailsModalCloseClick(Sender: TObject);
procedure btnArchiveModalCloseClick(Sender: TObject); procedure btnArchiveModalCloseClick(Sender: TObject);
procedure btnLogoutClick(Sender: TObject); procedure btnLogoutClick(Sender: TObject);
procedure wsClientConnect(Sender: TObject);
procedure wsClientDisconnect(Sender: TObject);
procedure wsClientDataReceived(Sender: TObject; Origin: string;
SocketData: TJSObjectRecord);
private private
{ Private declarations } { Private declarations }
FUserInfo: string; FUserInfo: string;
...@@ -67,6 +62,13 @@ type ...@@ -67,6 +62,13 @@ type
procedure HideArchiveModal; procedure HideArchiveModal;
procedure ShowArchiveModal(const titleText: string); procedure ShowArchiveModal(const titleText: string);
// WebSocket push handlers — called by Module.Websocket when the server broadcasts
procedure HandleWsBadgeCounts(aData: TJSObject);
procedure HandleWsUnitMap(aData: TJSObject);
procedure HandleWsComplaintMap(aData: TJSObject);
procedure HandleWsUnitList(aData: TJSObject);
procedure HandleWsComplaintList(aData: TJSObject);
type TActivePanel = (apNone, apMap, apUnits, apComplaints); type TActivePanel = (apNone, apMap, apUnits, apComplaints);
var var
FActivePanel: TActivePanel; FActivePanel: TActivePanel;
...@@ -154,47 +156,20 @@ begin ...@@ -154,47 +156,20 @@ begin
SetActiveNavButton('view.main.btnmap'); SetActiveNavButton('view.main.btnmap');
SetActivePanel(apMap); SetActivePanel(apMap);
// Initial badge counts still loaded via HTTP so the UI is populated immediately.
RefreshBadgesAsync; RefreshBadgesAsync;
wsClient.Connect; // Polling timers are replaced by WebSocket server-push broadcasts.
end; tmrBadgeCounts.Enabled := False;
tmrGlobalRefresh.Enabled := False;
procedure TFViewMain.wsClientConnect(Sender: TObject);
var
msg: TJSObject;
begin
Console.Log('wsClientConnect fired');
msg := TJSObject.new;
msg['message'] := 'identify';
msg['userId'] := JS.toString(
AuthService.TokenPayload.Properties['user_name']
);
Console.Log('Sending WebSocket identify'); dmWebsocket := TdmWebsocket.Create(Self);
wsClient.Send(TJSJSON.stringify(msg)); dmWebsocket.OnBadgeCounts := HandleWsBadgeCounts;
end; dmWebsocket.OnUnitMap := HandleWsUnitMap;
dmWebsocket.OnComplaintMap := HandleWsComplaintMap;
procedure TFViewMain.wsClientDataReceived(Sender: TObject; Origin: string; SocketData: TJSObjectRecord); dmWebsocket.OnUnitList := HandleWsUnitList;
var dmWebsocket.OnComplaintList := HandleWsComplaintList;
messageObj: TJSObject; dmWebsocket.Connect(DMConnection.WsUrl);
messageType: string;
messageText: string;
begin
messageObj := TJSObject(TJSJSON.parse(SocketData.jsobject.toString));
messageType := string(messageObj['message']);
if messageType = 'test_message' then
begin
messageText := string(messageObj['text']);
window.alert(messageText);
end;
end;
procedure TFViewMain.wsClientDisconnect(Sender: TObject);
begin
console.log('WebSocket disconnected');
end; end;
procedure TFViewMain.SetActivePanel(panel: TActivePanel); procedure TFViewMain.SetActivePanel(panel: TActivePanel);
...@@ -483,6 +458,49 @@ begin ...@@ -483,6 +458,49 @@ begin
end; end;
// ---------------------------------------------------------------------------
// WebSocket push handlers
// ---------------------------------------------------------------------------
procedure TFViewMain.HandleWsBadgeCounts(aData: TJSObject);
var
el: TJSElement;
begin
el := Document.getElementById('view.main.badgecomplaints');
if Assigned(el) then
TJSHtmlElement(el).innerText := string(aData['BadgeComplaints']);
el := Document.getElementById('view.main.badgeunits');
if Assigned(el) then
TJSHtmlElement(el).innerText := string(aData['BadgeUnits']);
end;
procedure TFViewMain.HandleWsUnitMap(aData: TJSObject);
begin
if Assigned(FMapForm) then
FMapForm.ApplyWsUnitMapData(TJSArray(aData['data']));
end;
procedure TFViewMain.HandleWsComplaintMap(aData: TJSObject);
begin
if Assigned(FMapForm) then
FMapForm.ApplyWsComplaintMapData(TJSArray(aData['data']));
end;
procedure TFViewMain.HandleWsUnitList(aData: TJSObject);
begin
if Assigned(FUnitsForm) then
FUnitsForm.ApplyWsData(aData);
end;
procedure TFViewMain.HandleWsComplaintList(aData: TJSObject);
begin
if Assigned(FComplaintsForm) then
FComplaintsForm.ApplyWsData(aData);
end;
// ---------------------------------------------------------------------------
procedure TFViewMain.tmrBadgeCountsTimer(Sender: TObject); procedure TFViewMain.tmrBadgeCountsTimer(Sender: TObject);
begin begin
console.log('Badges Refreshed'); console.log('Badges Refreshed');
...@@ -490,6 +508,7 @@ begin ...@@ -490,6 +508,7 @@ begin
end; end;
procedure TFViewMain.tmrGlobalRefreshTimer(Sender: TObject); procedure TFViewMain.tmrGlobalRefreshTimer(Sender: TObject);
begin begin
Inc(FGlobalRefreshTick); Inc(FGlobalRefreshTick);
...@@ -518,9 +537,9 @@ begin ...@@ -518,9 +537,9 @@ begin
on E: Exception do on E: Exception do
begin begin
el := Document.getElementById('view.main.badgecomplaints'); el := Document.getElementById('view.main.badgecomplaints');
if Assigned(el) then TJSHtmlElement(el).innerText := ''; if Assigned(el) then TJSHtmlElement(el).innerText := '�';
el := Document.getElementById('view.main.badgeunits'); el := Document.getElementById('view.main.badgeunits');
if Assigned(el) then TJSHtmlElement(el).innerText := ''; if Assigned(el) then TJSHtmlElement(el).innerText := '�';
Console.Log('Badge refresh error: ' + E.Message); Console.Log('Badge refresh error: ' + E.Message);
end; end;
end; end;
......
webEMIMobile/View.Map.pas
...@@ -40,6 +40,8 @@ type ...@@ -40,6 +40,8 @@ type
FGeoJsonLoadStep: Integer; FGeoJsonLoadStep: Integer;
[async] procedure LoadPointsAsync(showBusy: Boolean); [async] procedure LoadPointsAsync(showBusy: Boolean);
procedure PlaceUnitMarkers(aData: TJSArray);
procedure PlaceComplaintMarkers(aData: TJSArray);
procedure UpdateDeviceLocation(lat, lng: Double); procedure UpdateDeviceLocation(lat, lng: Double);
procedure StartDeviceLocation; procedure StartDeviceLocation;
procedure ApplyPendingUnitFocus; procedure ApplyPendingUnitFocus;
...@@ -52,6 +54,9 @@ type ...@@ -52,6 +54,9 @@ type
procedure FocusUnit(const unitId: string); procedure FocusUnit(const unitId: string);
procedure FocusComplaint(const complaintId: string); procedure FocusComplaint(const complaintId: string);
procedure RefreshData; procedure RefreshData;
// Called by View.Main when the server broadcasts a WebSocket push.
procedure ApplyWsUnitMapData(aData: TJSArray);
procedure ApplyWsComplaintMapData(aData: TJSArray);
end; end;
var var
...@@ -262,22 +267,7 @@ end; ...@@ -262,22 +267,7 @@ end;
[async] procedure TFViewMap.LoadPointsAsync(showBusy: Boolean); [async] procedure TFViewMap.LoadPointsAsync(showBusy: Boolean);
var var
resp: TXDataClientResponse; resp: TXDataClientResponse;
root, item, uo: TJSObject; root: TJSObject;
units: TJSArray;
i, ui: Integer;
m: TTMSFNCMapsMarker;
lat, lng: Double;
uName, unitBadge, agencyType, agencyId, agencyName, agency: string;
unitId, callType, priorityText, statusText: string;
complaintId, complaintNumber, codeDesc, priority, priorityBadge, complaintStatusKey, business, address: string;
pngName, iconUrl, rowsHtml: string;
officer1Lname, officer1Fname, officer1Empnum: string;
officer2Lname, officer2Fname, officer2Empnum: string;
officer1Display, officer2Display: string;
updateTimeText: string;
canShowDetails: Boolean;
canShowDetailsText: string;
detailsBtnHtml: string;
unitsData: TJSArray; unitsData: TJSArray;
complaintsData: TJSArray; complaintsData: TJSArray;
begin begin
...@@ -317,23 +307,52 @@ begin ...@@ -317,23 +307,52 @@ begin
Console.Log('Complaints XData error: ' + E.ErrorResult.ErrorMessage); Console.Log('Complaints XData error: ' + E.ErrorResult.ErrorMessage);
end; end;
// --- Swap Markers (no blank map while loading) --------------------------- // --- Place markers (BeginUpdate wraps both so the map redraws once) ------
lfMap.BeginUpdate; lfMap.BeginUpdate;
try try
for i := lfMap.Markers.Count - 1 downto 0 do PlaceUnitMarkers(unitsData);
begin PlaceComplaintMarkers(complaintsData);
m := lfMap.Markers[i]; finally
lfMap.EndUpdate;
end;
if StartsText('unit|', m.DataString) or StartsText('complaint|', m.DataString) then if mapFilters <> nil then
lfMap.Markers.Delete(i); mapFilters.Apply;
ApplyPendingUnitFocus;
ApplyPendingComplaintFocus;
finally
if showBusy then
HideSpinner('spinner');
FLoadingPoints := False;
end; end;
end;
// Unit markers procedure TFViewMap.PlaceUnitMarkers(aData: TJSArray);
if unitsData <> nil then var
begin item: TJSObject;
for i := 0 to unitsData.Length - 1 do i: Integer;
m: TTMSFNCMapsMarker;
lat, lng: Double;
uName, unitBadge, agencyType, agencyId, agencyName, agency: string;
unitId, callType, priorityText, statusText, updateTimeText: string;
officer1Lname, officer1Fname, officer1Empnum: string;
officer2Lname, officer2Fname, officer2Empnum: string;
officer1Display, officer2Display: string;
iconUrl, canShowDetailsText, detailsBtnHtml: string;
canShowDetails: Boolean;
begin
// Remove stale unit markers
for i := lfMap.Markers.Count - 1 downto 0 do
if StartsText('unit|', lfMap.Markers[i].DataString) then
lfMap.Markers.Delete(i);
if aData = nil then
Exit;
for i := 0 to aData.Length - 1 do
begin begin
item := TJSObject(unitsData[i]); item := TJSObject(aData[i]);
lat := Double(item['Lat']); lat := Double(item['Lat']);
lng := Double(item['Lng']); lng := Double(item['Lng']);
...@@ -341,27 +360,18 @@ begin ...@@ -341,27 +360,18 @@ begin
unitId := GetJsonString(item, 'UnitId'); unitId := GetJsonString(item, 'UnitId');
unitBadge := GetJsonString(item, 'UnitBadge'); unitBadge := GetJsonString(item, 'UnitBadge');
if Trim(unitBadge) = '' then if Trim(unitBadge) = '' then unitBadge := uName;
unitBadge := uName; if Trim(unitBadge) = '' then unitBadge := unitId;
if Trim(unitBadge) = '' then
unitBadge := unitId;
agencyId := GetJsonString(item, 'Agency'); agencyId := GetJsonString(item, 'Agency');
agencyName := GetJsonString(item, 'AgencyName'); agencyName := GetJsonString(item, 'AgencyName');
agency := agencyName; agency := agencyName;
if Trim(agency) = '' then if Trim(agency) = '' then agency := agencyId;
agency := agencyId;
agencyType := UpperCase(Trim(GetJsonString(item, 'AgencyType'))); agencyType := UpperCase(Trim(GetJsonString(item, 'AgencyType')));
if agencyType = 'FIR' then iconUrl := 'assets/markers/car_fire.png'
if agencyType = 'FIR' then else if agencyType = 'EMS' then iconUrl := 'assets/markers/car_ems.png'
iconUrl := 'assets/markers/car_fire.png' else iconUrl := 'assets/markers/car_police.png';
else if agencyType = 'EMS' then
iconUrl := 'assets/markers/car_ems.png'
else if agencyType = 'POL' then
iconUrl := 'assets/markers/car_police.png'
else
iconUrl := 'assets/markers/car_police.png';
callType := GetJsonString(item, 'CallType'); callType := GetJsonString(item, 'CallType');
priorityText := GetJsonString(item, 'Priority'); priorityText := GetJsonString(item, 'Priority');
...@@ -371,7 +381,6 @@ begin ...@@ -371,7 +381,6 @@ begin
officer1Lname := GetJsonString(item, 'Officer1Lname'); officer1Lname := GetJsonString(item, 'Officer1Lname');
officer1Fname := GetJsonString(item, 'Officer1Fname'); officer1Fname := GetJsonString(item, 'Officer1Fname');
officer1Empnum := GetJsonString(item, 'Officer1Empnum'); officer1Empnum := GetJsonString(item, 'Officer1Empnum');
officer2Lname := GetJsonString(item, 'Officer2Lname'); officer2Lname := GetJsonString(item, 'Officer2Lname');
officer2Fname := GetJsonString(item, 'Officer2Fname'); officer2Fname := GetJsonString(item, 'Officer2Fname');
officer2Empnum := GetJsonString(item, 'Officer2Empnum'); officer2Empnum := GetJsonString(item, 'Officer2Empnum');
...@@ -382,13 +391,11 @@ begin ...@@ -382,13 +391,11 @@ begin
canShowDetails := SameText(Trim(canShowDetailsText), 'true'); canShowDetails := SameText(Trim(canShowDetailsText), 'true');
if canShowDetails then if canShowDetails then
begin
detailsBtnHtml := detailsBtnHtml :=
'<button type="button" class="btn btn-primary btn-sm px-2 py-1" ' + '<button type="button" class="btn btn-primary btn-sm px-2 py-1" ' +
'onclick="window.showUnitDetails(''' + unitId + ''')">' + 'onclick="window.showUnitDetails(''' + unitId + ''')">' +
'Details' + 'Details' +
'</button>'; '</button>'
end
else else
detailsBtnHtml := ''; detailsBtnHtml := '';
...@@ -396,25 +403,23 @@ begin ...@@ -396,25 +403,23 @@ begin
if Trim(officer1Lname + officer1Fname + officer1Empnum) <> '' then if Trim(officer1Lname + officer1Fname + officer1Empnum) <> '' then
begin begin
officer1Display := Trim(officer1Lname); officer1Display := Trim(officer1Lname);
if Trim(officer1Fname) <> '' then if Trim(officer1Fname) <> '' then officer1Display := officer1Display + ', ' + Trim(officer1Fname);
officer1Display := officer1Display + ', ' + Trim(officer1Fname); if Trim(officer1Empnum) <> '' then officer1Display := officer1Display + ' (' + Trim(officer1Empnum) + ')';
if Trim(officer1Empnum) <> '' then
officer1Display := officer1Display + ' (' + Trim(officer1Empnum) + ')';
end; end;
officer2Display := ''; officer2Display := '';
if Trim(officer2Lname + officer2Fname + officer2Empnum) <> '' then if Trim(officer2Lname + officer2Fname + officer2Empnum) <> '' then
begin begin
officer2Display := Trim(officer2Lname); officer2Display := Trim(officer2Lname);
if Trim(officer2Fname) <> '' then if Trim(officer2Fname) <> '' then officer2Display := officer2Display + ', ' + Trim(officer2Fname);
officer2Display := officer2Display + ', ' + Trim(officer2Fname); if Trim(officer2Empnum) <> '' then officer2Display := officer2Display + ' (' + Trim(officer2Empnum) + ')';
if Trim(officer2Empnum) <> '' then
officer2Display := officer2Display + ' (' + Trim(officer2Empnum) + ')';
end; end;
m := lfMap.Markers.Add; m := lfMap.Markers.Add;
m.Latitude := lat; m.Latitude := lat;
m.Longitude := lng; m.Longitude := lng;
m.DataString := 'unit|' + unitId + '|' + StringReplace(unitBadge, '|', '/', [rfReplaceAll]);
m.IconURL := iconUrl;
m.Title := m.Title :=
'<span class="emi-marker-meta" data-marker-type="unit" data-unit-badge="' + '<span class="emi-marker-meta" data-marker-type="unit" data-unit-badge="' +
...@@ -423,82 +428,59 @@ begin ...@@ -423,82 +428,59 @@ begin
HtmlAttrEncode('Unit ' + unitBadge) + HtmlAttrEncode('Unit ' + unitBadge) +
'" style="display:none"></span>' + '" style="display:none"></span>' +
'<div class="d-flex flex-column gap-1 px-1 py-1" style="width:260px;">' + '<div class="d-flex flex-column gap-1 px-1 py-1" style="width:260px;">' +
'<div class="fw-semibold small">' + '<div class="fw-semibold small"><span class="fw-bold">Unit:</span> ' + uName + '</div>' +
'<span class="fw-bold">Unit:</span> ' + uName + IfThen(agency <> '', '<div class="small"><span class="fw-bold">Agency:</span> ' + agency + '</div>', '') +
'</div>' + IfThen(Trim(callType) <> '', '<div class="small"><span class="fw-bold">Call Type:</span> ' + callType + '</div>', '') +
IfThen(agency <> '', IfThen(Trim(priorityText) <> '', '<div class="small"><span class="fw-bold">Priority:</span> ' + priorityText + '</div>', '') +
'<div class="small"><span class="fw-bold">Agency:</span> ' + agency + '</div>', IfThen(Trim(statusText) <> '', '<div class="small"><span class="fw-bold">Status:</span> ' + statusText + '</div>', '') +
'' IfThen(Trim(officer1Display) <> '', '<div class="small"><span class="fw-bold">Officer 1:</span> ' + officer1Display + '</div>', '') +
) + IfThen(Trim(officer2Display) <> '', '<div class="small"><span class="fw-bold">Officer 2:</span> ' + officer2Display + '</div>', '') +
IfThen(Trim(callType) <> '',
'<div class="small"><span class="fw-bold">Call Type:</span> ' + callType + '</div>',
''
) +
IfThen(Trim(priorityText) <> '',
'<div class="small"><span class="fw-bold">Priority:</span> ' + priorityText + '</div>',
''
) +
IfThen(Trim(statusText) <> '',
'<div class="small"><span class="fw-bold">Status:</span> ' + statusText + '</div>',
''
) +
IfThen(Trim(officer1Display) <> '',
'<div class="small"><span class="fw-bold">Officer 1:</span> ' + officer1Display + '</div>',
''
) +
IfThen(Trim(officer2Display) <> '',
'<div class="small"><span class="fw-bold">Officer 2:</span> ' + officer2Display + '</div>',
''
) +
IfThen(Trim(updateTimeText) <> '', IfThen(Trim(updateTimeText) <> '',
'<div class="small mb-1"><span class="fw-bold">Updated:</span> ' + updateTimeText + '</div>', '<div class="small mb-1"><span class="fw-bold">Updated:</span> ' + updateTimeText + '</div>',
'<div class="small mb-1"></div>' '<div class="small mb-1"></div>') +
) + IfThen(detailsBtnHtml <> '', '<div class="d-flex justify-content-end mt-0">' + detailsBtnHtml + '</div>', '') +
IfThen(detailsBtnHtml <> '',
'<div class="d-flex justify-content-end mt-0">' + detailsBtnHtml + '</div>',
''
) +
'</div>'; '</div>';
end;
end;
m.DataString := 'unit|' + unitId + '|' + StringReplace(unitBadge, '|', '/', [rfReplaceAll]); procedure TFViewMap.PlaceComplaintMarkers(aData: TJSArray);
m.IconURL := iconUrl; var
item, uo: TJSObject;
units: TJSArray;
i, ui: Integer;
m: TTMSFNCMapsMarker;
lat, lng: Double;
complaintId, complaintNumber, codeDesc, priority, priorityBadge, complaintStatusKey: string;
agencyId, agencyName, agency, business, address: string;
pngName, iconUrl, rowsHtml: string;
begin
// Remove stale complaint markers
for i := lfMap.Markers.Count - 1 downto 0 do
if StartsText('complaint|', lfMap.Markers[i].DataString) then
lfMap.Markers.Delete(i);
end; if aData = nil then
end; Exit;
// Complaint markers for i := 0 to aData.Length - 1 do
if complaintsData <> nil then
begin
for i := 0 to complaintsData.Length - 1 do
begin begin
item := TJSObject(complaintsData[i]); item := TJSObject(aData[i]);
complaintId := GetJsonString(item, 'ComplaintId'); complaintId := GetJsonString(item, 'ComplaintId');
complaintNumber := GetJsonString(item, 'Complaint'); complaintNumber := GetJsonString(item, 'Complaint');
if Trim(complaintNumber) = '' then complaintNumber := complaintId;
if Trim(complaintNumber) = '' then
complaintNumber := complaintId;
codeDesc := GetJsonString(item, 'DispatchCodeDesc'); codeDesc := GetJsonString(item, 'DispatchCodeDesc');
agencyId := GetJsonString(item, 'Agency'); agencyId := GetJsonString(item, 'Agency');
agencyName := GetJsonString(item, 'AgencyName'); agencyName := GetJsonString(item, 'AgencyName');
agency := agencyName; agency := agencyName;
if Trim(agency) = '' then if Trim(agency) = '' then agency := agencyId;
agency := agencyId;
priority := GetJsonString(item, 'Priority'); priority := GetJsonString(item, 'Priority');
priorityBadge := GetJsonString(item, 'PriorityBadge'); priorityBadge := GetJsonString(item, 'PriorityBadge');
if Trim(priorityBadge) = '' then if Trim(priorityBadge) = '' then priorityBadge := '?';
priorityBadge := '?';
complaintStatusKey := LowerCase(Trim(GetJsonString(item, 'ComplaintStatusKey'))); complaintStatusKey := LowerCase(Trim(GetJsonString(item, 'ComplaintStatusKey')));
if complaintStatusKey = '' then if complaintStatusKey = '' then complaintStatusKey := 'notattached';
complaintStatusKey := 'notattached';
business := GetJsonString(item, 'Business'); business := GetJsonString(item, 'Business');
address := GetJsonString(item, 'Address'); address := GetJsonString(item, 'Address');
lat := Double(item['Lat']); lat := Double(item['Lat']);
lng := Double(item['Lng']); lng := Double(item['Lng']);
...@@ -513,13 +495,11 @@ begin ...@@ -513,13 +495,11 @@ begin
rowsHtml := ''; rowsHtml := '';
units := TJSArray(item['Units']); units := TJSArray(item['Units']);
if Assigned(units) and (units.Length > 0) then if Assigned(units) and (units.Length > 0) then
begin begin
for ui := 0 to units.Length - 1 do for ui := 0 to units.Length - 1 do
begin begin
uo := TJSObject(units[ui]); uo := TJSObject(units[ui]);
rowsHtml := rowsHtml + rowsHtml := rowsHtml +
'<tr>' + '<tr>' +
'<td>' + GetJsonString(uo, 'Unit') + '</td>' + '<td>' + GetJsonString(uo, 'Unit') + '</td>' +
...@@ -534,7 +514,6 @@ begin ...@@ -534,7 +514,6 @@ begin
m := lfMap.Markers.Add; m := lfMap.Markers.Add;
m.Latitude := lat; m.Latitude := lat;
m.Longitude := lng; m.Longitude := lng;
m.DataString := 'complaint|' + complaintId; m.DataString := 'complaint|' + complaintId;
m.IconURL := iconUrl; m.IconURL := iconUrl;
...@@ -547,40 +526,17 @@ begin ...@@ -547,40 +526,17 @@ begin
HtmlAttrEncode('Complaint ' + complaintNumber + IfThen(Trim(codeDesc) <> '', ' - ' + codeDesc, '')) + HtmlAttrEncode('Complaint ' + complaintNumber + IfThen(Trim(codeDesc) <> '', ' - ' + codeDesc, '')) +
'" style="display:none"></span>' + '" style="display:none"></span>' +
'<div class="d-flex flex-column gap-1 px-1 py-1" style="width:260px;">' + '<div class="d-flex flex-column gap-1 px-1 py-1" style="width:260px;">' +
'<div class="fw-semibold small">' + '<div class="fw-semibold small"><span class="fw-bold">Complaint:</span> ' + complaintNumber + '</div>' +
'<span class="fw-bold">Complaint:</span> ' + complaintNumber + '<div class="small"><span class="fw-bold">Priority:</span> ' + priority + '</div>' +
'</div>' + '<div class="small"><span class="fw-bold">Dispatch Code:</span> ' + codeDesc + '</div>' +
'<div class="small">' + '<div class="small"><span class="fw-bold">Agency:</span> ' + agency + '</div>' +
'<span class="fw-bold">Priority:</span> ' + priority + IfThen(Trim(business) <> '', '<div class="small"><span class="fw-bold">Business:</span> ' + business + '</div>', '') +
'</div>' + '<div class="small mb-1"><span class="fw-bold">Address:</span> ' + address + '</div>' +
'<div class="small">' +
'<span class="fw-bold">Dispatch Code:</span> ' + codeDesc +
'</div>' +
'<div class="small">' +
'<span class="fw-bold">Agency:</span> ' + agency +
'</div>' +
IfThen(Trim(business) <> '',
'<div class="small">' +
'<span class="fw-bold">Business:</span> ' + business +
'</div>',
''
) +
'<div class="small mb-1">' +
'<span class="fw-bold">Address:</span> ' + address +
'</div>' +
'<table class="table table-sm table-bordered mb-1 emi-tip-table">' + '<table class="table table-sm table-bordered mb-1 emi-tip-table">' +
'<colgroup>' + '<colgroup>' +
'<col style="width:34%">' + '<col style="width:34%"><col style="width:33%"><col style="width:33%">' +
'<col style="width:33%">' +
'<col style="width:33%">' +
'</colgroup>' + '</colgroup>' +
'<thead class="table-light">' + '<thead class="table-light"><tr><th>Unit</th><th>Status</th><th>Updated</th></tr></thead>' +
'<tr>' +
'<th>Unit</th>' +
'<th>Status</th>' +
'<th>Updated</th>' +
'</tr>' +
'</thead>' +
'<tbody>' + rowsHtml + '</tbody>' + '<tbody>' + rowsHtml + '</tbody>' +
'</table>' + '</table>' +
'<div class="d-flex justify-content-end mt-0">' + '<div class="d-flex justify-content-end mt-0">' +
...@@ -591,21 +547,41 @@ begin ...@@ -591,21 +547,41 @@ begin
'</div>' + '</div>' +
'</div>'; '</div>';
end; end;
end; end;
// --- WebSocket push entry points -------------------------------------------
procedure TFViewMap.ApplyWsUnitMapData(aData: TJSArray);
begin
// Skip if the map is still initialising or an HTTP load is in flight.
if (not Assigned(mapFilters)) or FLoadingPoints then
Exit;
lfMap.BeginUpdate;
try
PlaceUnitMarkers(aData);
finally finally
lfMap.EndUpdate; lfMap.EndUpdate;
end; end;
if mapFilters <> nil then
mapFilters.Apply; mapFilters.Apply;
ApplyPendingUnitFocus; ApplyPendingUnitFocus;
ApplyPendingComplaintFocus; end;
procedure TFViewMap.ApplyWsComplaintMapData(aData: TJSArray);
begin
if (not Assigned(mapFilters)) or FLoadingPoints then
Exit;
lfMap.BeginUpdate;
try
PlaceComplaintMarkers(aData);
finally finally
if showBusy then lfMap.EndUpdate;
HideSpinner('spinner');
FLoadingPoints := False;
end; end;
mapFilters.Apply;
ApplyPendingComplaintFocus;
end; end;
......
webEMIMobile/View.Units.pas
...@@ -41,6 +41,7 @@ type ...@@ -41,6 +41,7 @@ type
procedure HandleListClick(e: TJSMouseEvent); procedure HandleListClick(e: TJSMouseEvent);
public public
procedure RefreshData; procedure RefreshData;
procedure ApplyWsData(aRespObj: TJSObject);
end; end;
var var
...@@ -166,5 +167,19 @@ begin ...@@ -166,5 +167,19 @@ begin
GetUnits; GetUnits;
end; end;
procedure TFViewUnits.ApplyWsData(aRespObj: TJSObject);
var
unitCount: Integer;
begin
if FLoading then
Exit;
xdwdsUnits.Close;
xdwdsUnits.SetJsonData(aRespObj['data']);
xdwdsUnits.Open;
unitCount := Integer(aRespObj['count']);
lblEntries.Caption := Format('%d units', [unitCount]);
end;
end. end.
webEMIMobile/config/config.json
{ {
"AuthUrl" : "http://localhost:2009/emimobile/auth/", "AuthUrl" : "http://localhost:2009/emimobile/auth/",
"ApiUrl" : "http://localhost:2009/emimobile/api/", "ApiUrl" : "http://localhost:2009/emimobile/api/",
"AppUrl" : "http://localhost:2009/emimobile/app/" "AppUrl" : "http://localhost:2009/emimobile/app/",
"WsUrl" : "ws://localhost:2009/emiMobile/ws/emimobile"
} }
webEMIMobile/emiMobile.groupproj 0 → 100644
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<ProjectGuid>{27B04508-3F72-45A2-83EF-A007750D2923}</ProjectGuid>
</PropertyGroup>
<ItemGroup>
<Projects Include="webEmiMobile.dproj">
<Dependencies/>
</Projects>
<Projects Include="..\emiMobileServer\emiMobileServer.dproj">
<Dependencies/>
</Projects>
</ItemGroup>
<ProjectExtensions>
<Borland.Personality>Default.Personality.12</Borland.Personality>
<Borland.ProjectType/>
<BorlandProject>
<Default.Personality/>
</BorlandProject>
</ProjectExtensions>
<Target Name="webEmiMobile">
<MSBuild Projects="webEmiMobile.dproj"/>
</Target>
<Target Name="webEmiMobile:Clean">
<MSBuild Projects="webEmiMobile.dproj" Targets="Clean"/>
</Target>
<Target Name="webEmiMobile:Make">
<MSBuild Projects="webEmiMobile.dproj" Targets="Make"/>
</Target>
<Target Name="emiMobileServer">
<MSBuild Projects="..\emiMobileServer\emiMobileServer.dproj"/>
</Target>
<Target Name="emiMobileServer:Clean">
<MSBuild Projects="..\emiMobileServer\emiMobileServer.dproj" Targets="Clean"/>
</Target>
<Target Name="emiMobileServer:Make">
<MSBuild Projects="..\emiMobileServer\emiMobileServer.dproj" Targets="Make"/>
</Target>
<Target Name="Build">
<CallTarget Targets="webEmiMobile;emiMobileServer"/>
</Target>
<Target Name="Clean">
<CallTarget Targets="webEmiMobile:Clean;emiMobileServer:Clean"/>
</Target>
<Target Name="Make">
<CallTarget Targets="webEmiMobile:Make;emiMobileServer:Make"/>
</Target>
<Import Project="$(BDS)\Bin\CodeGear.Group.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Group.Targets')"/>
</Project>
webEMIMobile/webEmiMobile.dpr
...@@ -27,7 +27,8 @@ uses ...@@ -27,7 +27,8 @@ uses
View.UnitDetails in 'View.UnitDetails.pas' {FViewUnitDetails: TWebForm} {*.html}, View.UnitDetails in 'View.UnitDetails.pas' {FViewUnitDetails: TWebForm} {*.html},
uMapFilters in 'uMapFilters.pas', uMapFilters in 'uMapFilters.pas',
View.ComplaintArchive in 'View.ComplaintArchive.pas' {FViewComplaintArchive: TWebForm} {*.html}, View.ComplaintArchive in 'View.ComplaintArchive.pas' {FViewComplaintArchive: TWebForm} {*.html},
uMapMarkerJs in 'uMapMarkerJs.pas'; uMapMarkerJs in 'uMapMarkerJs.pas',
Module.Websocket in 'Module.Websocket.pas' {dmWebsocket: TDataModule};
{$R *.res} {$R *.res}
......
webEMIMobile/webEmiMobile.dproj
...@@ -62,6 +62,7 @@ ...@@ -62,6 +62,7 @@
<VerInfo_Locale>1046</VerInfo_Locale> <VerInfo_Locale>1046</VerInfo_Locale>
<TMSWebProject>2</TMSWebProject> <TMSWebProject>2</TMSWebProject>
<VerInfo_Keys>CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.802;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;LastCompiledTime=2018/07/25 12:57:53</VerInfo_Keys> <VerInfo_Keys>CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.802;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;LastCompiledTime=2018/07/25 12:57:53</VerInfo_Keys>
<DCC_Define>SKIA;$(DCC_Define)</DCC_Define>
<TMSWebHTMLFile>index.html</TMSWebHTMLFile> <TMSWebHTMLFile>index.html</TMSWebHTMLFile>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Base_Win32)'!=''"> <PropertyGroup Condition="'$(Base_Win32)'!=''">
...@@ -194,6 +195,11 @@ ...@@ -194,6 +195,11 @@
<DesignClass>TWebForm</DesignClass> <DesignClass>TWebForm</DesignClass>
</DCCReference> </DCCReference>
<DCCReference Include="uMapMarkerJs.pas"/> <DCCReference Include="uMapMarkerJs.pas"/>
<DCCReference Include="Module.Websocket.pas">
<Form>dmWebsocket</Form>
<FormType>dfm</FormType>
<DesignClass>TDataModule</DesignClass>
</DCCReference>
<None Include="index.html"/> <None Include="index.html"/>
<None Include="css\app.css"/> <None Include="css\app.css"/>
<None Include="css\spinner.css"/> <None Include="css\spinner.css"/>
...@@ -886,6 +892,70 @@ ...@@ -886,6 +892,70 @@
</Excluded_Packages> </Excluded_Packages>
</Delphi.Personality> </Delphi.Personality>
<Deployment Version="5"> <Deployment Version="5">
<DeployFile Condition="'$(SKIADIR)'==''" Required="true" LocalName="$(BDS)\bin64\sk4d.dll" Configuration="Debug" Class="Skia">
<Platform Name="Win64">
<RemoteDir>.\</RemoteDir>
<Operation>0</Operation>
<RemoteName>sk4d.dll</RemoteName>
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile Condition="'$(SKIADIR)'==''" Required="true" LocalName="$(BDS)\bin64\sk4d.dll" Configuration="Release" Class="Skia">
<Platform Name="Win64">
<RemoteDir>.\</RemoteDir>
<Operation>0</Operation>
<RemoteName>sk4d.dll</RemoteName>
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile Condition="'$(SKIADIR)'==''" Required="true" LocalName="$(BDS)\bin\sk4d.dll" Configuration="Debug" Class="Skia">
<Platform Name="Win32">
<RemoteDir>.\</RemoteDir>
<Operation>0</Operation>
<RemoteName>sk4d.dll</RemoteName>
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile Condition="'$(SKIADIR)'==''" Required="true" LocalName="$(BDS)\bin\sk4d.dll" Configuration="Release" Class="Skia">
<Platform Name="Win32">
<RemoteDir>.\</RemoteDir>
<Operation>0</Operation>
<RemoteName>sk4d.dll</RemoteName>
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile Condition="'$(SKIADIR)'!=''" Required="true" LocalName="$(SKIADIR)\Binary\Shared\Win32\sk4d.dll" Configuration="Debug" Class="Skia">
<Platform Name="Win32">
<RemoteDir>.\</RemoteDir>
<Operation>0</Operation>
<RemoteName>sk4d.dll</RemoteName>
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile Condition="'$(SKIADIR)'!=''" Required="true" LocalName="$(SKIADIR)\Binary\Shared\Win32\sk4d.dll" Configuration="Release" Class="Skia">
<Platform Name="Win32">
<RemoteDir>.\</RemoteDir>
<Operation>0</Operation>
<RemoteName>sk4d.dll</RemoteName>
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile Condition="'$(SKIADIR)'!=''" Required="true" LocalName="$(SKIADIR)\Binary\Shared\Win64\sk4d.dll" Configuration="Debug" Class="Skia">
<Platform Name="Win64">
<RemoteDir>.\</RemoteDir>
<Operation>0</Operation>
<RemoteName>sk4d.dll</RemoteName>
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile Condition="'$(SKIADIR)'!=''" Required="true" LocalName="$(SKIADIR)\Binary\Shared\Win64\sk4d.dll" Configuration="Release" Class="Skia">
<Platform Name="Win64">
<RemoteDir>.\</RemoteDir>
<Operation>0</Operation>
<RemoteName>sk4d.dll</RemoteName>
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile LocalName="Win32\Debug\webCharms.exe" Configuration="Debug" Class="ProjectOutput"/> <DeployFile LocalName="Win32\Debug\webCharms.exe" Configuration="Debug" Class="ProjectOutput"/>
<DeployFile LocalName="Win32\Debug\webEmiMobile.exe" Configuration="Debug" Class="ProjectOutput"> <DeployFile LocalName="Win32\Debug\webEmiMobile.exe" Configuration="Debug" Class="ProjectOutput">
<Platform Name="Win32"> <Platform Name="Win32">
......
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