Skip to content

E
emiMobile
Commit 448ace4a by Elias Sarraf
Options

Merge remote-tracking branch 'origin/tmsWebSockets'

parents d3faa7cf 69fafe4a
Showing with 2855 additions and 230 deletions
emiMobileServer/Source/Api.Database.dfm
......@@ -1359,4 +1359,11 @@ object ApiDatabaseModule: TApiDatabaseModule
Left = 162
Top = 42
end
object UniAlerter1: TUniAlerter
Connection = ucENTCAD
Events = 'disupdate'
OnEvent = UniAlerter1Event
Left = 324
Top = 382
end
end
emiMobileServer/Source/Api.Database.pas
......@@ -5,7 +5,8 @@ interface
uses
System.SysUtils, System.Classes, Data.DB, MemDS, DBAccess, Uni, UniProvider,
PostgreSQLUniProvider, System.Variants, System.Generics.Collections, System.IniFiles,
Common.Logging, Vcl.Forms, System.Character, Common.Ini;
Common.Logging, Vcl.Forms, System.Character, Common.Ini, DAAlerter,
UniAlerter;
type
TApiDatabaseModule = class(TDataModule)
......@@ -203,12 +204,16 @@ type
uqMapUnitsagencytype: TStringField;
uqUnitListagencytype: TStringField;
uqMapComplaintscomplaint: TStringField;
UniAlerter1: TUniAlerter;
procedure uqComplaintListCalcFields(DataSet: TDataSet);
procedure uqMapComplaintsCalcFields(DataSet: TDataSet);
procedure DataModuleCreate(Sender: TObject);
procedure UniAlerter1Event(Sender: TDAAlerter; const EventName,
Message: string);
private
{ Private declarations }
public
CADUpdate: Boolean;
function HandleUniqueFilenames(const category: string): string;
function BadgeCounts(const BaseQuery: TUniQuery): Integer;
end;
......@@ -225,6 +230,8 @@ implementation
procedure TApiDatabaseModule.DataModuleCreate(Sender: TObject);
begin
CADUpdate := False;
ucENTCAD.ProviderName := 'PostgreSQL';
ucENTCAD.Server := IniEntries.DatabaseServer;
ucENTCAD.Port := IniEntries.DatabasePort;
......@@ -238,6 +245,10 @@ begin
ucENTCAD.ExecSQL('set search_path to lems, avl, entcad, public');
Logger.Log(2, 'PostgreSQL API search_path set to lems, avl, entcad, public');
Logger.Log(1, 'Starting PostgreSQL disupdate listener');
UniAlerter1.Start;
Logger.Log(1, 'PostgreSQL disupdate listener started');
end;
procedure TApiDatabaseModule.uqComplaintListCalcFields(DataSet: TDataSet);
......@@ -307,6 +318,12 @@ begin
end;
procedure TApiDatabaseModule.UniAlerter1Event(Sender: TDAAlerter; const EventName, Message: string);
begin
if SameText(EventName, 'disupdate') then
CADUpdate := True;
end;
function TApiDatabaseModule.BadgeCounts(const BaseQuery: TUniQuery): Integer;
var
Q: TUniQuery;
......
emiMobileServer/Source/Auth.Server.Module.pas
......@@ -43,7 +43,9 @@ uses
Sparkle.Middleware.Compress,
XData.OpenApi.Service,
Common.Logging,
Common.Middleware.Logging;
Common.Middleware.Logging,
System.Rtti,
Auth.Service;
{%CLASSGROUP 'Vcl.Controls.TControl'}
......@@ -55,7 +57,27 @@ procedure TAuthServerModule.StartAuthServer(ABaseUrl: string;
AModelName: string);
var
Url: string;
ctx: TRttiContext;
t: TRttiType;
attr: TCustomAttribute;
s: string;
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;
Url := ABaseUrl;
......
emiMobileServer/Source/Common.Middleware.Logging.pas
......@@ -15,11 +15,12 @@ type
TLoggingMiddleware = class(THttpServerMiddleware, IHttpServerMiddleware)
private
FLogger: ILogger;
FLogLevel: Integer;
function GetNewHttpRequestLog(Request: THttpServerRequest): ILog;
protected
procedure ProcessRequest(Context: THttpServerContext; Next: THttpServerProc); override;
public
constructor Create(ALogger: ILogger);
constructor Create(ALogger: ILogger; ALogLevel: Integer = 5);
end;
THttpRequestLog = class( TInterfacedObject, ILog )
......@@ -60,9 +61,10 @@ implementation
{ TLoggingMiddleware }
constructor TLoggingMiddleware.Create(ALogger: ILogger);
constructor TLoggingMiddleware.Create(ALogger: ILogger; ALogLevel: Integer = 5);
begin
FLogger := TLogger.Create(ALogger);
FLogLevel := ALogLevel;
end;
function TLoggingMiddleware.GetNewHttpRequestLog(
......@@ -116,11 +118,11 @@ begin
procedure(Resp: THttpServerResponse)
begin
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
);
RequestLogMessage := GetNewHttpRequestLog(Context.Request).GetMessage;
FLogger.Log(5, RequestLogMessage);
FLogger.Log(FLogLevel, RequestLogMessage);
Next(Context);
end;
......
emiMobileServer/Source/Main.dfm
......@@ -2,8 +2,8 @@ object FMain: TFMain
Left = 0
Top = 0
Caption = 'emiMobileServer'
ClientHeight = 583
ClientWidth = 761
ClientHeight = 616
ClientWidth = 772
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
......@@ -12,17 +12,103 @@ object FMain: TFMain
Font.Style = []
OnClose = FormClose
DesignSize = (
761
583)
772
616)
TextHeight = 13
object memoInfo: TMemo
object pgcMain: TPageControl
Left = 8
Top = 39
Width = 741
Height = 535
Width = 756
Height = 575
ActivePage = tabConnectedClients
Anchors = [akLeft, akTop, akRight, akBottom]
TabOrder = 3
object tabServerLog: TTabSheet
Caption = 'Server Log'
object memoInfo: TMemo
Left = 0
Top = 0
Width = 748
Height = 547
Align = alClient
ReadOnly = True
ScrollBars = ssVertical
TabOrder = 0
WordWrap = False
end
end
object tabConnectedClients: TTabSheet
Caption = 'Connected Clients'
ImageIndex = 1
object grdConnectedClients: TDBGrid
Left = 0
Top = 0
Width = 748
Height = 487
Align = alClient
DataSource = dsConnectedClients
Options = [dgTitles, dgIndicator, dgColumnResize, dgColLines, dgRowLines, dgTabs, dgRowSelect, dgConfirmDelete, dgCancelOnExit, dgTitleClick, dgTitleHotTrack]
ReadOnly = True
TabOrder = 0
TitleFont.Charset = DEFAULT_CHARSET
TitleFont.Color = clWindowText
TitleFont.Height = -11
TitleFont.Name = 'Tahoma'
TitleFont.Style = []
Columns = <
item
Expanded = False
FieldName = 'ConnectionId'
Visible = True
end
item
Expanded = False
FieldName = 'UserId'
Visible = True
end
item
Expanded = False
FieldName = 'ConnectedAt'
Width = 150
Visible = True
end>
end
object pnlConnectedClientsActions: TPanel
Left = 0
Top = 487
Width = 748
Height = 60
Align = alBottom
Caption = 'pnlConnectedClientsActions'
ShowCaption = False
TabOrder = 1
object btnDisconnectClient: TButton
Left = 5
Top = 18
Width = 141
Height = 25
Caption = 'Disconnect Selected Client'
TabOrder = 0
OnClick = btnDisconnectClientClick
end
object edtClientMessage: TEdit
Left = 294
Top = 12
Width = 317
Height = 21
TabOrder = 1
end
object btnSendClientMessage: TButton
Left = 617
Top = 18
Width = 123
Height = 25
Caption = 'Send Client Message'
TabOrder = 2
OnClick = btnSendClientMessageClick
end
end
end
end
object btnApiSwaggerUI: TButton
Left = 141
......@@ -30,16 +116,17 @@ object FMain: TFMain
Width = 100
Height = 25
Caption = 'Api SwaggerUI'
TabOrder = 1
TabOrder = 0
OnClick = btnApiSwaggerUIClick
end
object btnExit: TButton
Left = 671
Left = 713
Top = 8
Width = 75
Height = 25
Anchors = [akTop, akRight]
Caption = 'Exit'
TabOrder = 2
TabOrder = 1
OnClick = btnExitClick
end
object btnAuthSwaggerUI: TButton
......@@ -48,17 +135,51 @@ object FMain: TFMain
Width = 100
Height = 25
Caption = 'Auth SwaggerUI'
TabOrder = 3
TabOrder = 2
OnClick = btnAuthSwaggerUIClick
end
object initTimer: TTimer
OnTimer = initTimerTimer
Left = 58
Top = 398
Left = 422
Top = 4
end
object ExeInfo1: TExeInfo
Version = '1.6.1.1'
Left = 256
Top = 402
Left = 572
Top = 4
end
object tblConnectedClients: TFDMemTable
Active = True
FieldDefs = <
item
Name = 'ConnectionId'
DataType = ftString
Size = 50
end
item
Name = 'UserId'
DataType = ftString
Size = 30
end
item
Name = 'ConnectedAt'
DataType = ftDateTime
end>
IndexDefs = <>
FetchOptions.AssignedValues = [evMode]
FetchOptions.Mode = fmAll
ResourceOptions.AssignedValues = [rvSilentMode]
ResourceOptions.SilentMode = True
UpdateOptions.AssignedValues = [uvCheckRequired, uvAutoCommitUpdates]
UpdateOptions.CheckRequired = False
UpdateOptions.AutoCommitUpdates = True
StoreDefs = True
Left = 490
Top = 5
end
object dsConnectedClients: TDataSource
DataSet = tblConnectedClients
Left = 352
Top = 7
end
end
emiMobileServer/Source/Main.pas
......@@ -3,31 +3,51 @@ unit Main;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, Winapi.ShellApi,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Vcl.StdCtrls, Vcl.ExtCtrls, System.Generics.Collections, System.IniFiles,
Winapi.Windows, Winapi.Messages, Winapi.ShellApi,
System.SysUtils, System.Variants, System.Classes, System.Generics.Collections,
System.IniFiles,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,
Vcl.ExtCtrls, Vcl.ComCtrls, Vcl.Grids, Vcl.DBGrids,
Data.DB,
FireDAC.Stan.Intf, FireDAC.Stan.Option, FireDAC.Stan.Param,
FireDAC.Stan.Error, FireDAC.DatS, FireDAC.Phys.Intf, FireDAC.DApt.Intf,
FireDAC.Comp.DataSet, FireDAC.Comp.Client,
Auth.Service, Auth.Server.Module, Api.Server.Module, App.Server.Module,
ExeInfo, Api.Service;
ExeInfo, Api.Service, WebSocket.Manager, Ws.Server.Module;
type
TFMain = class(TForm)
memoInfo: TMemo;
btnApiSwaggerUI: TButton;
btnExit: TButton;
initTimer: TTimer;
btnAuthSwaggerUI: TButton;
ExeInfo1: TExeInfo;
pgcMain: TPageControl;
tabServerLog: TTabSheet;
tabConnectedClients: TTabSheet;
memoInfo: TMemo;
tblConnectedClients: TFDMemTable;
dsConnectedClients: TDataSource;
grdConnectedClients: TDBGrid;
pnlConnectedClientsActions: TPanel;
btnDisconnectClient: TButton;
edtClientMessage: TEdit;
btnSendClientMessage: TButton;
procedure btnApiSwaggerUIClick(Sender: TObject);
procedure btnExitClick(Sender: TObject);
procedure ContactFormData(AText: String);
procedure ContactFormData(AText: string);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure initTimerTimer(Sender: TObject);
procedure btnAuthSwaggerUIClick(Sender: TObject);
procedure btnDisconnectClientClick(Sender: TObject);
procedure btnSendClientMessageClick(Sender: TObject);
strict private
procedure StartServers;
function LogValue(const LabelName: string; const Value: string; FromIni: Boolean): string;
procedure HandleConnectedClientsChanged;
procedure RefreshConnectedClients;
function LogValue(LabelName: string; Value: string; FromIni: Boolean): string;
private
function LocalBrowserUrl(const Url: string): string;
function LocalBrowserUrl(Url: string): string;
end;
var
......@@ -45,14 +65,43 @@ uses
{$R *.dfm}
{ --- Event Handlers --- }
procedure TFMain.btnExitClick(Sender: TObject);
begin
Close;
end;
function TFMain.LocalBrowserUrl(const Url: string): string;
procedure TFMain.btnSendClientMessageClick(Sender: TObject);
var
connectionId: string;
begin
if not Assigned(WsServerModule) then
Exit;
if tblConnectedClients.IsEmpty then
Exit;
if Trim(edtClientMessage.Text) = '' then
Exit;
connectionId := tblConnectedClients.FieldByName('ConnectionId').AsString;
WsServerModule.SendMessageToClient(connectionId, edtClientMessage.Text);
end;
procedure TFMain.btnDisconnectClientClick(Sender: TObject);
var
connectionId: string;
begin
if not Assigned(WsServerModule) then
Exit;
if tblConnectedClients.IsEmpty then
Exit;
connectionId := tblConnectedClients.FieldByName('ConnectionId').AsString;
WsServerModule.DisconnectClient(connectionId);
end;
function TFMain.LocalBrowserUrl(Url: string): string;
begin
Result := StringReplace(Url, '://0.0.0.0:', '://localhost:', [rfIgnoreCase]);
end;
......@@ -73,18 +122,27 @@ begin
ShellExecute(Handle, 'open', PChar(LocalBrowserUrl(url)), nil, nil, SW_SHOWNORMAL);
end;
procedure TFMain.ContactFormData(AText: String);
procedure TFMain.ContactFormData(AText: string);
begin
if memoInfo.CanFocus then
TThread.Queue(nil, procedure begin memoInfo.Lines.Add(AText); end)
TThread.Queue(nil,
procedure
begin
memoInfo.Lines.Add(AText);
end)
else
TThread.Synchronize(nil, procedure begin memoInfo.Lines.Add(AText); end);
TThread.Synchronize(nil,
procedure
begin
memoInfo.Lines.Add(AText);
end);
end;
procedure TFMain.initTimerTimer(Sender: TObject);
begin
initTimer.Enabled := False;
Caption := Caption + ' ver ' + ExeInfo1.FileVersion;
ServerConfig := TServerConfig.Create;
LoadIniEntries;
LoadServerConfig;
......@@ -93,16 +151,18 @@ end;
procedure TFMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
ServerConfig.Free;
IniEntries.Free;
AuthServerModule.Free;
ApiServerModule.Free;
AppServerModule.Free;
if Assigned(WsServerModule) then
WsServerModule.OnClientsChanged := nil;
FreeAndNil(WsServerModule);
FreeAndNil(AppServerModule);
FreeAndNil(ApiServerModule);
FreeAndNil(AuthServerModule);
FreeAndNil(IniEntries);
FreeAndNil(ServerConfig);
end;
{ --- Helpers --- }
function TFMain.LogValue(const LabelName: string; const Value: string; FromIni: Boolean): string;
function TFMain.LogValue(LabelName: string; Value: string; FromIni: Boolean): string;
begin
Result := LabelName + ': ' + Value + IfThen(FromIni, ' [from ini]', ' [default]');
end;
......@@ -121,29 +181,66 @@ begin
Logger.Log(1, LogValue('--Settings->LogFileNum', IniEntries.LogFileNum.ToString, IniEntries.LogFileNumFromIni));
Logger.Log(1, LogValue('--Settings->webClientVersion', IniEntries.WebClientVersion, IniEntries.WebClientVersionFromIni));
// Logger.Log(1, '--- Database ---');
// Logger.Log(1, LogValue('--Database->Server', IniEntries.DatabaseServer, IniEntries.DatabaseServerFromIni));
// Logger.Log(1, LogValue('--Database->Database', IniEntries.DatabaseName, IniEntries.DatabaseNameFromIni));
// Logger.Log(1, LogValue('--Database->Username', IniEntries.DatabaseUsername, IniEntries.DatabaseUsernameFromIni));
// Logger.Log(1, LogValue('--Database->Password', IniEntries.DatabasePassword, IniEntries.DatabasePasswordFromIni));
Logger.Log(1, '');
Logger.Log(1, '--- URLs ---');
try
AuthServerModule := TAuthServerModule.Create(Self);
AuthServerModule.StartAuthServer(ServerConfig.url, AUTH_MODEL);
AuthServerModule.StartAuthServer(ServerConfig.Url, AUTH_MODEL);
ApiServerModule := TApiServerModule.Create(Self);
ApiServerModule.StartApiServer(ServerConfig.url, API_MODEL);
ApiServerModule.StartApiServer(ServerConfig.Url, API_MODEL);
AppServerModule := TAppServerModule.Create(Self);
AppServerModule.StartAppServer(ServerConfig.url);
AppServerModule.StartAppServer(ServerConfig.Url);
WsServerModule := TWsServerModule.Create(Self);
WsServerModule.OnClientsChanged := HandleConnectedClientsChanged;
WsServerModule.StartWsServer;
except
on E: Exception do
Logger.Log(2, 'Failed to start server modules: ' + E.Message);
end;
RefreshConnectedClients;
end;
procedure TFMain.HandleConnectedClientsChanged;
begin
TThread.Queue(nil,
procedure
begin
RefreshConnectedClients;
end);
end;
end.
procedure TFMain.RefreshConnectedClients;
var
clients: TArray<TConnectedClientSnapshot>;
client: TConnectedClientSnapshot;
begin
if not Assigned(WsServerModule) then
Exit;
clients := WsServerModule.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;
tabConnectedClients.Caption := Format('Connected Clients (%d)', [Length(clients)]);
end;
end.
emiMobileServer/Source/WebSocket.Manager.pas 0 → 100644
unit WebSocket.Manager;
interface
uses
System.Classes,
System.SysUtils,
System.JSON,
System.Generics.Collections,
VCL.TMSFNCWebSocketServer,
VCL.TMSFNCWebSocketCommon;
const
WEBSOCKET_PORT = 8091;
type
TConnectedClientSnapshot = record
ConnectionId: string;
UserId: string;
ConnectedAt: TDateTime;
end;
TConnectedClient = class
private
FConnectionId: string;
FUserId: string;
FConnectedAt: TDateTime;
FConnection: TTMSFNCWebSocketServerConnection;
public
property ConnectionId: string read FConnectionId write FConnectionId;
property UserId: string read FUserId write FUserId;
property ConnectedAt: TDateTime read FConnectedAt write FConnectedAt;
property Connection: TTMSFNCWebSocketServerConnection read FConnection write FConnection;
end;
TClientsChangedEvent = procedure of object;
TWebSocketManager = class
private
FServer: TTMSFNCWebSocketServer;
FClients: TObjectList<TConnectedClient>;
FClientsLock: TObject;
FOnClientsChanged: TClientsChangedEvent;
procedure NotifyClientsChanged;
procedure HandshakeResponseSent(Sender: TObject; AConnection: TTMSFNCWebSocketServerConnection);
procedure MessageReceived(Sender: TObject; AConnection: TTMSFNCWebSocketConnection; const AMessage: string);
procedure ClientDisconnected(Sender: TObject; AConnection: TTMSFNCWebSocketConnection);
public
constructor Create;
destructor Destroy; override;
procedure Start;
procedure Stop;
procedure Broadcast(AMessage: string);
procedure DisconnectClient(AConnectionId: string);
procedure SendMessageToClient(AConnectionId, AText: string);
function GetClientSnapshots: TArray<TConnectedClientSnapshot>;
property OnClientsChanged: TClientsChangedEvent read FOnClientsChanged write FOnClientsChanged;
end;
implementation
uses
Common.Logging;
constructor TWebSocketManager.Create;
begin
inherited Create;
FClientsLock := TObject.Create;
FClients := TObjectList<TConnectedClient>.Create(True);
FServer := TTMSFNCWebSocketServer.Create;
FServer.Port := WEBSOCKET_PORT;
FServer.UseSSL := False;
FServer.OnHandshakeResponseSent := HandshakeResponseSent;
FServer.OnMessageReceived := MessageReceived;
FServer.OnDisconnect := ClientDisconnected;
end;
destructor TWebSocketManager.Destroy;
begin
Stop;
FServer.Free;
FClients.Free;
FClientsLock.Free;
inherited;
end;
procedure TWebSocketManager.Start;
begin
FServer.Active := True;
end;
procedure TWebSocketManager.Stop;
begin
FServer.Active := False;
end;
procedure TWebSocketManager.Broadcast(AMessage: string);
var
connections: TArray<TTMSFNCWebSocketServerConnection>;
i: Integer;
begin
TMonitor.Enter(FClientsLock);
try
SetLength(connections, FClients.Count);
for i := 0 to FClients.Count - 1 do
connections[i] := FClients[i].Connection;
finally
TMonitor.Exit(FClientsLock);
end;
for i := 0 to Length(connections) - 1 do
begin
try
connections[i].Send(AMessage);
except
on E: Exception do
Logger.Log(2, 'WebSocket broadcast failed: ' + E.Message);
end;
end;
end;
procedure TWebSocketManager.DisconnectClient(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(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.
\ No newline at end of file
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 = 5000);
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
if not FDb.CADUpdate then
Exit;
FDb.CADUpdate := False;
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('Complaint', FDb.uqMapComplaintsCOMPLAINT.AsString);
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
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;
procedure Broadcast(const AMessage: string);
function GetClientSnapshots: TArray<TConnectedClientSnapshot>;
property OnClientsChanged: TClientsChangedEvent read GetOnClientsChanged write SetOnClientsChanged;
procedure DisconnectClient(AConnectionId: string);
procedure SendMessageToClient(AConnectionId, AText: string);
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;
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,
5000 // notification check interval in ms
);
Logger.Log(1, 'WsDataModel started (5 s notification check interval)');
end;
procedure TWsServerModule.Broadcast(const AMessage: string);
begin
FManager.Broadcast(AMessage);
end;
procedure TWsServerModule.DisconnectClient(AConnectionId: string);
begin
FManager.DisconnectClient(AConnectionId);
end;
procedure TWsServerModule.SendMessageToClient(AConnectionId, AText: string);
begin
FManager.SendMessageToClient(AConnectionId, AText);
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/bin/emiMobileServer.ini
[Settings]
LogFileNum=729
LogFileNum=746
webClientVersion=9.4.0
[Database]
......
emiMobileServer/emiMobileServer.dpr
......@@ -21,7 +21,17 @@ uses
Auth.ServiceImpl in 'Source\Auth.ServiceImpl.pas',
Api.ServiceImpl in 'Source\Api.ServiceImpl.pas',
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';
type
TMemoLogAppender = class( TInterfacedObject, ILogAppender )
......
emiMobileServer/emiMobileServer.dproj
......@@ -72,7 +72,7 @@
<SanitizedProjectName>emiMobileServer</SanitizedProjectName>
</PropertyGroup>
<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>
<BT_BuildType>Debug</BT_BuildType>
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
......@@ -81,7 +81,7 @@
<Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File>
</PropertyGroup>
<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>
<BT_BuildType>Debug</BT_BuildType>
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
......@@ -165,6 +165,20 @@
<DesignClass>TDataModule</DesignClass>
</DCCReference>
<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"/>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>
......@@ -193,7 +207,7 @@
</Excluded_Packages>
</Delphi.Personality>
<Deployment Version="5">
<DeployFile LocalName="emiMobileServer.exe" Configuration="Debug" Class="ProjectOutput">
<DeployFile LocalName="bin\emiMobileServer.exe" Configuration="Debug" Class="ProjectOutput">
<Platform Name="Win32">
<RemoteName>emiMobileServer.exe</RemoteName>
<Overwrite>true</Overwrite>
......
webEMIMobile/App.Config.pas
......@@ -14,11 +14,13 @@ type
FAuthUrl: string;
FApiUrl: string;
FAppUrl: string;
FWsUrl: string;
public
constructor Create;
property AuthUrl: string read FAuthUrl write FAuthUrl;
property ApiUrl: string read FApiUrl write FApiUrl;
property AppUrl: string read FAppUrl write FAppUrl;
property WsUrl: string read FWsUrl write FWsUrl;
end;
TConfigLoadedProc = reference to procedure(Config: TAppConfig);
......@@ -49,6 +51,9 @@ procedure LoadConfig(LoadProc: TConfigLoadedProc);
if JS.toString(Obj['AppUrl']) <> '' then
Config.AppUrl := JS.toString(Obj['AppUrl']);
if JS.toString(Obj['WsUrl']) <> '' then
Config.WsUrl := JS.toString(Obj['WsUrl']);
end;
finally
LoadProc(Config);
......@@ -86,6 +91,7 @@ begin
FAuthUrl := '';
FApiUrl := '';
FAppUrl := '';
FWsUrl := '';
end;
end.
webEMIMobile/ConnectionModule.pas
......@@ -17,7 +17,9 @@ type
procedure AuthConnectionError(Error: TXDataWebConnectionError);
private
FUnauthorizedAccessProc: TUnauthorizedAccessProc;
FWsUrl: string;
public
property WsUrl: string read FWsUrl;
const clientVersion = '9.4.0';
procedure InitApp(SuccessProc: TSuccessProc;
UnauthorizedAccessProc: TUnauthorizedAccessProc);
......@@ -74,6 +76,9 @@ procedure TDMConnection.InitApp(SuccessProc: TSuccessProc;
if Config.ApiUrl <> '' then
ApiConnection.URL := Config.ApiUrl;
if Config.WsUrl <> '' then
FWsUrl := Config.WsUrl;
AuthConnection.Open(SuccessProc);
end;
......
webEMIMobile/Module.Websocket.dfm 0 → 100644
object dmWebsocket: TdmWebsocket
OnCreate = WebDataModuleCreate
OnDestroy = WebDataModuleDestroy
Height = 480
Width = 640
object EMiMobileWebSocketClient: TWebSocketClient
UseSSL = True
Port = 443
HostName = 'webapps.em-sys.net'
PathName = '/emiMobile/ws/emimobile'
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)
procedure WebDataModuleCreate(Sender: TObject);
procedure WebDataModuleDestroy(Sender: TObject);
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 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.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;
console.log('WS: connecting to ' + AWsUrl);
EMiMobileWebSocketClient.UseSSL := (Scheme = 'wss');
EMiMobileWebSocketClient.Active := True;
console.log('WS: Active set to true');
end;
procedure TdmWebsocket.DispatchMessage(const AMessage: string);
var
obj: TJSObject;
requestId: string;
messageType: string;
messageText: 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;
messageType := string(obj['message']);
if SameText(messageType, 'test_message') then
begin
messageText := string(obj['text']);
window.alert(messageText);
Exit;
end;
requestId := string(obj['RequestId']);
if requestId <> '' then
console.log('WS: received ' + 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);
var
msg: TJSObject;
begin
console.log('WS: connected');
msg := TJSObject.new;
msg['message'] := 'identify';
msg['userId'] := JS.toString(AuthService.TokenPayload.Properties['user_name']);
EMiMobileWebSocketClient.Send(TJSJSON.stringify(msg));
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;
procedure TdmWebsocket.WebDataModuleCreate(Sender: TObject);
begin
console.log('WS: datamodule created');
EMiMobileWebSocketClient.OnConnect := EMiMobileWebSocketClientConnect;
EMiMobileWebSocketClient.OnDisconnect := EMiMobileWebSocketClientDisconnect;
EMiMobileWebSocketClient.OnMessageReceived := EMiMobileWebSocketClientMessageReceived;
end;
procedure TdmWebsocket.WebDataModuleDestroy(Sender: TObject);
begin
end;
end.
webEMIMobile/View.Complaints.pas
......@@ -45,6 +45,7 @@ type
public
property OnShowDetails: TSelectProc read FSelectProc write FSelectProc;
procedure RefreshData;
procedure ApplyWsData(aRespObj: TJSObject);
end;
var
......@@ -186,5 +187,22 @@ begin
GetComplaints;
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.
webEMIMobile/View.Main.dfm
......@@ -70,18 +70,6 @@ object FViewMain: TFViewMain
ElementID = 'pnl_main'
ChildOrder = 3
TabOrder = 0
object WebButton1: TWebButton
Left = 456
Top = 20
Width = 96
Height = 25
Caption = 'WebButton1'
ElementClassName = 'btn btn-light'
ElementFont = efCSS
HeightStyle = ssAuto
HeightPercent = 100.000000000000000000
WidthPercent = 100.000000000000000000
end
end
object WebMessageDlg1: TWebMessageDlg
Left = 47
......
webEMIMobile/View.Main.pas
unit View.Main;
unit View.Main;
interface
......@@ -6,7 +6,8 @@ uses
System.SysUtils, System.Classes, JS, Web, WEBLib.Graphics, WEBLib.Controls,
WEBLib.Forms, WEBLib.Dialogs, WEBLib.ExtCtrls, Vcl.Controls, Vcl.StdCtrls,
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,
Module.Websocket;
type
TFViewMain = class(TWebForm)
......@@ -31,7 +32,6 @@ type
btnDetailsModalClose: TWebButton;
pnlArchive: TWebPanel;
btnArchiveModalClose: TWebButton;
WebButton1: TWebButton;
btnLogout: TWebButton;
procedure WebFormCreate(Sender: TObject);
procedure mnuLogoutClick(Sender: TObject);
......@@ -62,6 +62,13 @@ type
procedure HideArchiveModal;
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);
var
FActivePanel: TActivePanel;
......@@ -149,9 +156,21 @@ begin
SetActiveNavButton('view.main.btnmap');
SetActivePanel(apMap);
// Initial badge counts still loaded via HTTP so the UI is populated immediately.
RefreshBadgesAsync;
end;
// Polling timers are replaced by WebSocket server-push broadcasts.
tmrBadgeCounts.Enabled := False;
tmrGlobalRefresh.Enabled := False;
dmWebsocket := TdmWebsocket.Create(Self);
dmWebsocket.OnBadgeCounts := HandleWsBadgeCounts;
dmWebsocket.OnUnitMap := HandleWsUnitMap;
dmWebsocket.OnComplaintMap := HandleWsComplaintMap;
dmWebsocket.OnUnitList := HandleWsUnitList;
dmWebsocket.OnComplaintList := HandleWsComplaintList;
dmWebsocket.Connect(DMConnection.WsUrl);
end;
procedure TFViewMain.SetActivePanel(panel: TActivePanel);
begin
......@@ -439,6 +458,49 @@ begin
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);
begin
console.log('Badges Refreshed');
......@@ -446,6 +508,7 @@ begin
end;
procedure TFViewMain.tmrGlobalRefreshTimer(Sender: TObject);
begin
Inc(FGlobalRefreshTick);
......@@ -474,9 +537,9 @@ begin
on E: Exception do
begin
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');
if Assigned(el) then TJSHtmlElement(el).innerText := '';
if Assigned(el) then TJSHtmlElement(el).innerText := '�';
Console.Log('Badge refresh error: ' + E.Message);
end;
end;
......
webEMIMobile/View.Map.pas
......@@ -40,6 +40,8 @@ type
FGeoJsonLoadStep: Integer;
[async] procedure LoadPointsAsync(showBusy: Boolean);
procedure PlaceUnitMarkers(aData: TJSArray);
procedure PlaceComplaintMarkers(aData: TJSArray);
procedure UpdateDeviceLocation(lat, lng: Double);
procedure StartDeviceLocation;
procedure ApplyPendingUnitFocus;
......@@ -52,6 +54,9 @@ type
procedure FocusUnit(const unitId: string);
procedure FocusComplaint(const complaintId: string);
procedure RefreshData;
// Called by View.Main when the server broadcasts a WebSocket push.
procedure ApplyWsUnitMapData(aData: TJSArray);
procedure ApplyWsComplaintMapData(aData: TJSArray);
end;
var
......@@ -262,22 +267,7 @@ end;
[async] procedure TFViewMap.LoadPointsAsync(showBusy: Boolean);
var
resp: TXDataClientResponse;
root, item, uo: 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;
root: TJSObject;
unitsData: TJSArray;
complaintsData: TJSArray;
begin
......@@ -317,23 +307,52 @@ begin
Console.Log('Complaints XData error: ' + E.ErrorResult.ErrorMessage);
end;
// --- Swap Markers (no blank map while loading) ---------------------------
// --- Place markers (BeginUpdate wraps both so the map redraws once) ------
lfMap.BeginUpdate;
try
for i := lfMap.Markers.Count - 1 downto 0 do
begin
m := lfMap.Markers[i];
PlaceUnitMarkers(unitsData);
PlaceComplaintMarkers(complaintsData);
finally
lfMap.EndUpdate;
end;
if StartsText('unit|', m.DataString) or StartsText('complaint|', m.DataString) then
lfMap.Markers.Delete(i);
if mapFilters <> nil then
mapFilters.Apply;
ApplyPendingUnitFocus;
ApplyPendingComplaintFocus;
finally
if showBusy then
HideSpinner('spinner');
FLoadingPoints := False;
end;
end;
// Unit markers
if unitsData <> nil then
begin
for i := 0 to unitsData.Length - 1 do
procedure TFViewMap.PlaceUnitMarkers(aData: TJSArray);
var
item: TJSObject;
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
item := TJSObject(unitsData[i]);
item := TJSObject(aData[i]);
lat := Double(item['Lat']);
lng := Double(item['Lng']);
......@@ -341,27 +360,18 @@ begin
unitId := GetJsonString(item, 'UnitId');
unitBadge := GetJsonString(item, 'UnitBadge');
if Trim(unitBadge) = '' then
unitBadge := uName;
if Trim(unitBadge) = '' then
unitBadge := unitId;
if Trim(unitBadge) = '' then unitBadge := uName;
if Trim(unitBadge) = '' then unitBadge := unitId;
agencyId := GetJsonString(item, 'Agency');
agencyName := GetJsonString(item, 'AgencyName');
agency := agencyName;
if Trim(agency) = '' then
agency := agencyId;
if Trim(agency) = '' then agency := agencyId;
agencyType := UpperCase(Trim(GetJsonString(item, 'AgencyType')));
if agencyType = 'FIR' then
iconUrl := 'assets/markers/car_fire.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';
if agencyType = 'FIR' then iconUrl := 'assets/markers/car_fire.png'
else if agencyType = 'EMS' then iconUrl := 'assets/markers/car_ems.png'
else iconUrl := 'assets/markers/car_police.png';
callType := GetJsonString(item, 'CallType');
priorityText := GetJsonString(item, 'Priority');
......@@ -371,7 +381,6 @@ begin
officer1Lname := GetJsonString(item, 'Officer1Lname');
officer1Fname := GetJsonString(item, 'Officer1Fname');
officer1Empnum := GetJsonString(item, 'Officer1Empnum');
officer2Lname := GetJsonString(item, 'Officer2Lname');
officer2Fname := GetJsonString(item, 'Officer2Fname');
officer2Empnum := GetJsonString(item, 'Officer2Empnum');
......@@ -382,13 +391,11 @@ begin
canShowDetails := SameText(Trim(canShowDetailsText), 'true');
if canShowDetails then
begin
detailsBtnHtml :=
'<button type="button" class="btn btn-primary btn-sm px-2 py-1" ' +
'onclick="window.showUnitDetails(''' + unitId + ''')">' +
'Details' +
'</button>';
end
'</button>'
else
detailsBtnHtml := '';
......@@ -396,25 +403,23 @@ begin
if Trim(officer1Lname + officer1Fname + officer1Empnum) <> '' then
begin
officer1Display := Trim(officer1Lname);
if Trim(officer1Fname) <> '' then
officer1Display := officer1Display + ', ' + Trim(officer1Fname);
if Trim(officer1Empnum) <> '' then
officer1Display := officer1Display + ' (' + Trim(officer1Empnum) + ')';
if Trim(officer1Fname) <> '' then officer1Display := officer1Display + ', ' + Trim(officer1Fname);
if Trim(officer1Empnum) <> '' then officer1Display := officer1Display + ' (' + Trim(officer1Empnum) + ')';
end;
officer2Display := '';
if Trim(officer2Lname + officer2Fname + officer2Empnum) <> '' then
begin
officer2Display := Trim(officer2Lname);
if Trim(officer2Fname) <> '' then
officer2Display := officer2Display + ', ' + Trim(officer2Fname);
if Trim(officer2Empnum) <> '' then
officer2Display := officer2Display + ' (' + Trim(officer2Empnum) + ')';
if Trim(officer2Fname) <> '' then officer2Display := officer2Display + ', ' + Trim(officer2Fname);
if Trim(officer2Empnum) <> '' then officer2Display := officer2Display + ' (' + Trim(officer2Empnum) + ')';
end;
m := lfMap.Markers.Add;
m.Latitude := lat;
m.Longitude := lng;
m.DataString := 'unit|' + unitId + '|' + StringReplace(unitBadge, '|', '/', [rfReplaceAll]);
m.IconURL := iconUrl;
m.Title :=
'<span class="emi-marker-meta" data-marker-type="unit" data-unit-badge="' +
......@@ -423,82 +428,59 @@ begin
HtmlAttrEncode('Unit ' + unitBadge) +
'" style="display:none"></span>' +
'<div class="d-flex flex-column gap-1 px-1 py-1" style="width:260px;">' +
'<div class="fw-semibold small">' +
'<span class="fw-bold">Unit:</span> ' + uName +
'</div>' +
IfThen(agency <> '',
'<div class="small"><span class="fw-bold">Agency:</span> ' + agency + '</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>',
''
) +
'<div class="fw-semibold small"><span class="fw-bold">Unit:</span> ' + uName + '</div>' +
IfThen(agency <> '', '<div class="small"><span class="fw-bold">Agency:</span> ' + agency + '</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) <> '',
'<div class="small mb-1"><span class="fw-bold">Updated:</span> ' + updateTimeText + '</div>',
'<div class="small mb-1"></div>'
) +
IfThen(detailsBtnHtml <> '',
'<div class="d-flex justify-content-end mt-0">' + detailsBtnHtml + '</div>',
''
) +
'<div class="small mb-1"></div>') +
IfThen(detailsBtnHtml <> '', '<div class="d-flex justify-content-end mt-0">' + detailsBtnHtml + '</div>', '') +
'</div>';
end;
end;
m.DataString := 'unit|' + unitId + '|' + StringReplace(unitBadge, '|', '/', [rfReplaceAll]);
m.IconURL := iconUrl;
procedure TFViewMap.PlaceComplaintMarkers(aData: TJSArray);
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;
end;
if aData = nil then
Exit;
// Complaint markers
if complaintsData <> nil then
begin
for i := 0 to complaintsData.Length - 1 do
for i := 0 to aData.Length - 1 do
begin
item := TJSObject(complaintsData[i]);
item := TJSObject(aData[i]);
complaintId := GetJsonString(item, 'ComplaintId');
complaintNumber := GetJsonString(item, 'Complaint');
if Trim(complaintNumber) = '' then
complaintNumber := complaintId;
if Trim(complaintNumber) = '' then complaintNumber := complaintId;
codeDesc := GetJsonString(item, 'DispatchCodeDesc');
agencyId := GetJsonString(item, 'Agency');
agencyName := GetJsonString(item, 'AgencyName');
agency := agencyName;
if Trim(agency) = '' then
agency := agencyId;
if Trim(agency) = '' then agency := agencyId;
priority := GetJsonString(item, 'Priority');
priorityBadge := GetJsonString(item, 'PriorityBadge');
if Trim(priorityBadge) = '' then
priorityBadge := '?';
if Trim(priorityBadge) = '' then priorityBadge := '?';
complaintStatusKey := LowerCase(Trim(GetJsonString(item, 'ComplaintStatusKey')));
if complaintStatusKey = '' then
complaintStatusKey := 'notattached';
if complaintStatusKey = '' then complaintStatusKey := 'notattached';
business := GetJsonString(item, 'Business');
address := GetJsonString(item, 'Address');
lat := Double(item['Lat']);
lng := Double(item['Lng']);
......@@ -513,13 +495,11 @@ begin
rowsHtml := '';
units := TJSArray(item['Units']);
if Assigned(units) and (units.Length > 0) then
begin
for ui := 0 to units.Length - 1 do
begin
uo := TJSObject(units[ui]);
rowsHtml := rowsHtml +
'<tr>' +
'<td>' + GetJsonString(uo, 'Unit') + '</td>' +
......@@ -534,7 +514,6 @@ begin
m := lfMap.Markers.Add;
m.Latitude := lat;
m.Longitude := lng;
m.DataString := 'complaint|' + complaintId;
m.IconURL := iconUrl;
......@@ -547,40 +526,17 @@ begin
HtmlAttrEncode('Complaint ' + complaintNumber + IfThen(Trim(codeDesc) <> '', ' - ' + codeDesc, '')) +
'" style="display:none"></span>' +
'<div class="d-flex flex-column gap-1 px-1 py-1" style="width:260px;">' +
'<div class="fw-semibold small">' +
'<span class="fw-bold">Complaint:</span> ' + complaintNumber +
'</div>' +
'<div class="small">' +
'<span class="fw-bold">Priority:</span> ' + priority +
'</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>' +
'<div class="fw-semibold small"><span class="fw-bold">Complaint:</span> ' + complaintNumber + '</div>' +
'<div class="small"><span class="fw-bold">Priority:</span> ' + priority + '</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">' +
'<colgroup>' +
'<col style="width:34%">' +
'<col style="width:33%">' +
'<col style="width:33%">' +
'<col style="width:34%"><col style="width:33%"><col style="width:33%">' +
'</colgroup>' +
'<thead class="table-light">' +
'<tr>' +
'<th>Unit</th>' +
'<th>Status</th>' +
'<th>Updated</th>' +
'</tr>' +
'</thead>' +
'<thead class="table-light"><tr><th>Unit</th><th>Status</th><th>Updated</th></tr></thead>' +
'<tbody>' + rowsHtml + '</tbody>' +
'</table>' +
'<div class="d-flex justify-content-end mt-0">' +
......@@ -591,21 +547,41 @@ begin
'</div>' +
'</div>';
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
lfMap.EndUpdate;
end;
if mapFilters <> nil then
mapFilters.Apply;
ApplyPendingUnitFocus;
ApplyPendingComplaintFocus;
end;
procedure TFViewMap.ApplyWsComplaintMapData(aData: TJSArray);
begin
if (not Assigned(mapFilters)) or FLoadingPoints then
Exit;
lfMap.BeginUpdate;
try
PlaceComplaintMarkers(aData);
finally
if showBusy then
HideSpinner('spinner');
FLoadingPoints := False;
lfMap.EndUpdate;
end;
mapFilters.Apply;
ApplyPendingComplaintFocus;
end;
......
webEMIMobile/View.Units.pas
......@@ -41,6 +41,7 @@ type
procedure HandleListClick(e: TJSMouseEvent);
public
procedure RefreshData;
procedure ApplyWsData(aRespObj: TJSObject);
end;
var
......@@ -166,5 +167,19 @@ begin
GetUnits;
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.
webEMIMobile/config/config.json
{
"AuthUrl" : "http://localhost:2009/emimobile/auth/",
"ApiUrl" : "http://localhost:2009/emimobile/api/",
"AppUrl" : "http://localhost:2009/emimobile/app/"
"AppUrl" : "http://localhost:2009/emimobile/app/",
"WsUrl": "ws://localhost:8091/"
}
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
View.UnitDetails in 'View.UnitDetails.pas' {FViewUnitDetails: TWebForm} {*.html},
uMapFilters in 'uMapFilters.pas',
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}
......
webEMIMobile/webEmiMobile.dproj
......@@ -62,6 +62,7 @@
<VerInfo_Locale>1046</VerInfo_Locale>
<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>
<DCC_Define>SKIA;$(DCC_Define)</DCC_Define>
<TMSWebHTMLFile>index.html</TMSWebHTMLFile>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_Win32)'!=''">
......@@ -194,6 +195,11 @@
<DesignClass>TWebForm</DesignClass>
</DCCReference>
<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="css\app.css"/>
<None Include="css\spinner.css"/>
......@@ -886,6 +892,70 @@
</Excluded_Packages>
</Delphi.Personality>
<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\webEmiMobile.exe" Configuration="Debug" Class="ProjectOutput">
<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