Skip to content

E
emiMobile
Commit 80d51ec3 by Mac Stephens
Options

Complete BFD shared-server integration and simplify common code structure

parent ab1d1cac
Showing with 10784 additions and 2055 deletions
.gitignore
......@@ -33,3 +33,5 @@ emiMobileServer/Clients/*/Web/**/__history/
emiMobileServer/Clients/*/Web/**/__recovery/
emiMobileServer/Clients/*/Web/TMSWeb/
emiMobileServer/Clients/*/Web/Win32/
emiMobileServer/Shared/Server/__history/
core-plan.md
......@@ -8,6 +8,47 @@ Client relocation and separate static outputs are complete; the user confirmed b
## Latest implementation checkpoint
- User-requested cleanup complete: Common.Ini loads WC [Database] or BFD [Oracle] into the same connection properties and applies them through ConfigureConnection. Startup validates client and Oracle settings once; removed Oracle.Connection and throwaway connection validation. All active CAD/auth/device connections use the common method; no designer fallback.
- Standalone BFD server retired as a supported build/fallback; source and nested history retained with RETIRED.md. Its historical project is no longer expected to build against current shared modules. Only emiMobileServer/emiMobileServer.dproj is supported for both clients.
- Removed shared Ws.Service/Ws.ServiceImpl stubs, unused WebSocketServer, unused LoginRequest and project references, ClearVerificationCode contract/implementations/designer queries, both uqUserPref components, commented old login code and unused WC import in Main. DTOGeneratorUtils retained in tools outside runtime project. No web changes or database modifications.
- Shared server build passed. Offline compiled test passed for WC settings, Oracle TNS settings, and missing Oracle password rejection without database connections. DFM checks confirm only specified unused queries removed; all active project references resolve. Runtime regression check still required.
- At user request, merged WC.Api.Data and BFD.Api.Data response builders into their respective Api.Database modules and removed the wrapper units. TClientData now derives from TDataModule; existing modules implement its methods directly. Client.Selection and standalone BFD API/WS construct modules with owner nil. Per-request/worker/listener lifetimes preserved. No folder renames in this step.
- Both server builds passed. Static comparisons verify all moved response/timeout method bodies (apart from class names and removed ApiDB qualifier), pre-existing database implementations, and designer DFM files are unchanged. Runtime CAD/live-update regression remains pending.
- User confirmed BFD browser registration, real-number verification, and login work on the shared Oracle server. Broader CAD/live-update/revoke/restore and WC regression tests remain pending.
- At user request, consolidated common server code into Shared: Source root -> Shared/Server; Source/shared -> Shared/Models; Source/utils -> Shared/Utils; Core/Server -> Shared/Clients; Database -> Shared/Database. Updated both server DPR/DPROJ references. Unit names and source contents unchanged by relocation. Both builds passed; every DCCReference resolves. Standalone BFD Source tree preserved. See folder-layout.md for authoritative current paths; earlier checkpoints retain historical names.
- User manually created DEVICE_REGISTRATIONS and REDEEM_CODES in Oracle/dbForge successfully. Live application query/binding tests remain pending.
- Shared server now recognizes BFD and requires explicit [Oracle] Server (TNS alias), Username, Password. BFD CAD/auth require this section when Client=BFD; standalone fallback remains only without that client setting/section. Runtime INI not switched; awaiting local credentials. User asked whether TNS is still used: confirmed Server=BFD still resolves through tnsnames.ora; credentials are separate.
- BFD web now targets shared localhost:2001/emsys/emimobile and uses WC WebSocket reconnect/session-expiry handling and Main integration, preserving incident terminology and CAD/map views. Added connection-status CSS. BFD browser storage uses BFDEMIMOBILE_ to avoid WC identity reuse during localhost testing.
- Shared server and BFD JavaScript builds passed in temporary folders. Ws.DataModel destructor handles early construction failure; startup logging identifies Oracle and masks PostgreSQL password. No database changes executed. Oracle connection/listener/device-flow testing pending.
- BFD test configuration requires Client=BFD, webClientVersion=9.4.0 and actual Oracle settings in common server bin INI. Restore Client=WC and webClientVersion=0.9.4.9 for WC. Audit sequence helper remains PostgreSQL-specific; Oracle audit-enabled flow is not verified and requires adaptation before use.
- BFD web authentication port completed: WC Auth.Service, login forms, device registration/verification forms, and device manager forms copied into BFD; startup now gates normal use on device registration and supports device-management mode. ConnectionModule uses WC startup/version flow while retaining BFD clientVersion 9.4.0. Main gains an admin Devices button; Utils gains the information modal and WC confirmation semantics required by Delete. No prior BFD confirmation callers existed. Map/incident/unit/detail/archive/marker/filter and WebSocket sources remain unchanged.
- TMSWebCompiler produced a successful BFD JavaScript build and form resources under TEMP/emiMobile-bfd-web-auth-build. CAD preservation, form-resource/project XML, and common-server operation-name checks passed. No live device/auth test: updated BFD web requires the common-server endpoints and Oracle tables, which are still deferred/blocked. It no longer supports the standalone BFD password-only login contract. Existing deployed static output was not the compiler target. Next steps remain Oracle configuration/tables and common-server integration (including WebSocket upgrades); do not present this client as usable against the standalone server.
- October 20: user confirmed both servers build and function with Client.Auth. Prepared BFD/Oracle branches in Client.Selection and added the BFD CAD/auth plus Oracle device modules to the common project. ValidateClient still blocks BFD before construction; no runtime activation or bypass.
- Added Oracle.Connection, reading explicit [Oracle] Server (TNS alias), Username, Password. BFD CAD/auth modules apply it before connecting, retaining designer settings only if the section is absent for standalone compatibility. Standalone device-store connections require this section. Existing BFD [Database] contains stale PostgreSQL settings and is intentionally not used for Oracle. Running INIs unchanged; both server builds passed. Live Oracle INI testing pending. Require the Oracle section for common-server CAD/auth when activating BFD; finish remaining web/auth, tables, and listener validation first.
- October 20: user confirmed both clients work after the authentication-query extraction. Missing WC map GeoJSON files were copied from source assets into bin/static/WC/assets.
- Added Core/Server/Client.Auth.pas: TClientAuth exposes module-owned connection/datasets plus existing open-query and audit operations. WC.Auth.Database and BFD.Auth.Database implement it without DFM changes. Client.Selection.CreateClientAuth selects WC; Auth.ServiceImpl now uses TClientAuth and no longer references WC components directly. Borrowed device-store connection and destruction order are preserved. Both Win32 Debug builds passed; service equivalence and unchanged DFM checks passed. Runtime verification of this interface step is pending. BFD selection remains disabled; standalone BFD still constructs its own auth module.
- User/agency SQL extraction completed for both clients: uqAuth holds the user lookup; uqAgencies and uqAgencyConfig hold the two agency queries in each Auth.Database DFM. OpenUser/OpenAgencies/OpenAgencyConfig bind/open them; services retain checks, result mapping, passwords/JWTs, and auditing. Both server builds passed; static comparisons confirm SQL and remaining service logic are preserved. Runtime login/agency checks pending. The next code step is a shared client-auth contract and central selection, before BFD common-server integration.
- October 17 follow-up: the user resolved the WC WebSocket rejection by logging out and back in. Full registration/verification/device-management testing is still pending.
- Moved each CAD authentication module into Clients/WC/Server/WC.Auth.Database and Clients/BFD/Server/BFD.Auth.Database (PAS/DFM), updating service and project references. Only unit/class/object names and paths changed; connection properties, queries, and audit behavior are preserved. Both Win32 Debug server builds passed. Client-specific user/agency SQL still remains in the respective Auth.ServiceImpl units; extracting those operations is the next code step.
- The user explicitly chose separate device-storage data modules behind a shared operation interface. CAD queries remain per client; device SQL/parameters/transactions belong to database-platform implementations; service workflows remain shared.
- Added Core/Server/Device.Store.pas and Database/PostgreSQL/PostgreSQL.Device.Database.pas/.dfm. Oracle.Device.Database now implements the same TDeviceStore contract. Read results are store-owned TDataSets; writes return affected-row counts; redemption allocation is a transaction-owning operation.
- WC Auth.ServiceImpl, Api.ServiceImpl, and WebSocket.Manager now call the store instead of building device-storage SQL. Auth borrows its existing connection; API operations and WebSocket checks use separate store-owned connections. Client.Selection creates the WC/PostgreSQL implementation only and still rejects BFD.
- PostgreSQL's 26 query texts were copied exactly from the existing WC service SQL. Oracle's 25 designer queries are unchanged, with operation wrappers added. Services retain validation, crypto/JWT handling, SMS, response generation, and access/affected-row checks. CAD user/agency authentication SQL is not extracted yet.
- Both WC and standalone BFD Win32 Debug builds passed. Offline DFM/ownership test passed for both stores without a database connection. Static comparisons checked SQL, call arguments/bindings, response assignments, guards, and exception messages. Live WC device-flow verification is pending.
- Oracle 19c tables are not yet created, per user instruction. Assume uppercase DEVICE_REGISTRATIONS and REDEEM_CODES in the CAD schema; final schema ownership undecided. Oracle execution/binding/transaction tests and runtime selection remain pending. No auth bypass added.
- BFD's data-contract/lifecycle changes were runtime-verified before this step. BFD still uses its existing standalone auth implementation. No commits were made for these subsequent changes.
## Previous WC checkpoint
- The user verified the previous WC response-builder extraction at runtime.
- Core/Server/Client.Data.pas now defines TClientData, the abstract CAD operations used by the API and WebSocket data model. It also covers connection checks, worker query timeouts, and update-listener operations.
- Core/Server/Client.Selection.pas centralizes ValidateClient and CreateClientData. Startup and creation use the same validation: only WC is supported; missing/unknown clients and BFD retain their existing error messages. No default fallback.
......@@ -75,3 +116,7 @@ Client relocation and separate static outputs are complete; the user confirmed b
## Scope preferences
Keep changes minimal and consistent with existing Delphi/TMS conventions. Explain existing flow and the intended change before editing application code. Avoid broad abstractions, scattered client conditionals, unrelated cleanup, and premature restructuring. The user is still choosing the plan.
## Registration SMS failure fix
Changed shared BeginRegistration to save verification codes only after Twilio accepts the HTTP send request. HTTP rejection logs details and returns a friendly error without raising an intentional debugger exception. Transport/configuration exceptions retain the existing error response. Both WC and BFD use this code; no schema changes. Shared server build passed; live failure/success tests pending. Twilio acceptance is not proof of delivery; no delivery callback added. Existing codes are not migrated or cleared by this edit and retain their five-minute expiry.
current-progress.md
......@@ -6,7 +6,7 @@ October 17, 2026
We're moving toward one emiMobile server project with shared code and separate pieces for each client. Each client will still run on its own server machine. The INI will tell the server which client it is running and which web folder to use.
WC will stay on PostgreSQL and BFD will stay on Oracle. Device registrations and verification data will go in each client's existing database. The queries will stay in the UniQueries in each client's database module.
WC will stay on PostgreSQL and BFD will stay on Oracle. Device registrations and verification data will go in each client's existing database. CAD queries stay in each client's database module. Device-storage queries are shared by database type, using separate PostgreSQL and Oracle modules.
## What we've done
......@@ -22,12 +22,28 @@ WC will stay on PostgreSQL and BFD will stay on Oracle. Device registrations and
WC is working after the database, response-building, and shared client-selection changes. The server compiled successfully, and I tested the latest changes and confirmed they work.
BFD still uses its existing Oracle server. We haven't connected it to the common server yet.
BFD's database, response builders, and shared data contract are in place and tested. Device storage now has a shared interface with PostgreSQL and Oracle implementations. WC's authentication, device management, and WebSocket device checks use that interface. Both server projects build, and offline checks passed. The WC WebSocket login issue was resolved by logging out and back in; registration and device-management testing is still pending. The Oracle queries are prepared, but no tables have been created and BFD isn't using the new authentication yet.
Each client's existing authentication database module now lives alongside its CAD module in its own Server folder. Both servers compile after this move; login behavior and queries are unchanged. User and agency SQL now lives in those modules' designer queries, while the services keep the login checks and responses. Both servers build; this step still needs a login and agency-list check.
## What's next
Next we'll start bringing BFD into the same structure. That includes its Oracle queries and the Oracle tables/storage needed for the newer device registration and authentication features.
Next we'll test WC's device flows after this extraction, then continue BFD's remaining authentication and common-server integration. That includes its Oracle queries and the Oracle tables/storage needed for the newer device registration and authentication features.
After that, we can connect BFD to the shared server functionality and bring its web client up to date, while keeping the things that are different for BFD, especially the maps, markers, and fire-specific information.
We're doing this in pieces so we can keep building and testing as we go. The basic structure is in place now, but the BFD integration and the rest of the shared web/authentication work are still ahead.
The user confirmed both clients work after the authentication-query move. We have now added a common authentication-data interface and connected WC through client selection. Both server projects compile; the latest interface change still needs a runtime login check. BFD remains on its standalone server, and Oracle device tables are still deferred.
Both clients were confirmed working with the shared authentication interface. BFD selection code is now prepared in the common server, with an explicit Oracle INI section available for its connections. Both projects compile. BFD activation remains blocked while its device tables and remaining integration are unfinished; its standalone server retains the current connection settings unless the Oracle section is added.
BFD now has WC's web login, registration/verification, and device-management screens. The TMS web build passed, and BFD's fire-specific screens and maps were preserved. This updated client requires the newer shared-server endpoints, so full testing waits on BFD server integration and Oracle device tables.
The Oracle tables were created manually in dbForge. The shared server now accepts BFD with explicit Oracle settings, and BFD has the newer WebSocket reconnect/session handling. Both builds passed. Local Oracle credentials and runtime checks are still needed. The connection continues to use the BFD TNS alias.
BFD browser registration, verification, and login were tested successfully on the shared server with Oracle. We then simplified the folder layout into Shared and Clients. Both server projects compile after the move; project locations and application behavior stay the same.
Simplified the client server units by moving response-building code directly into WC.Api.Database and BFD.Api.Database. Removed both Api.Data wrapper units. API and WebSockets still reuse the same methods, with separate database instances. Both server builds passed.
Cleaned up unused server units, queries, and old commented login code. Both database types now use Common.Ini for connection setup. The standalone BFD server is retired; its files remain as reference. The shared server builds, and offline WC/Oracle configuration checks passed.
emiMobileServer/Clients/BFD/Server/BFD.Api.Database.dfm 0 → 100644
object BFDAPIDataModule: TBFDAPIDataModule
OnCreate = DataModuleCreate
Height = 491
Width = 640
object uqMapUnits: TUniQuery
Connection = ucENTCAD
SQL.Strings = (
'SELECT'
' uc.ENTRYID,'
' uc.UNITID,'
' TO_CLOB(NVL(dua.UNITNAME, NVL(uc.UNITNAME, uc.CAR_NUMBER))) AS' +
' UNITNAME,'
' ag.AGENCYID AS AGENCY,'
' ag.AGENCYNAME AS AGENCY_NAME,'
' ag.AGENCYTYPE AS AGENCYTYPE,'
' uc.GPS_LATITUDE,'
' uc.GPS_LONGITUDE,'
' cdc.CODE_DESC AS CALL_TYPE,'
' cap.PRIORITY AS PRIORITY,'
' CASE'
' WHEN dua.STATUS = 20 AND mts.STATION_NAME IS NOT NULL THEN N' +
'VL(cus.CODE_DESC, TO_CHAR(dua.STATUS)) || '#39' to '#39' || mts.STATION_' +
'NAME'
' WHEN dua.STATUS = 70 AND dua.UNAVAILABLE_REASON IS NOT NULL ' +
'THEN NVL(cus.CODE_DESC, TO_CHAR(dua.STATUS)) || '#39' - '#39' || dua.UNA' +
'VAILABLE_REASON'
' WHEN dua.STATUS = 0 AND NVL(dua.MANPOWER, 0) = 1 THEN NVL(cu' +
's.CODE_DESC, '#39'Available'#39') || '#39' - Undermanned'#39
' ELSE NVL(cus.CODE_DESC, TO_CHAR(dua.STATUS))'
' END AS UNIT_STATUS_DESC,'
' uc.UPDATETIME AS UPDATE_TIME,'
' dua.UNITID AS DIS_UNITID,'
' p1.PF_LNAME AS OFFICER1_LNAME,'
' p1.PF_FNAME AS OFFICER1_FNAME,'
' p1.PF_EMPNUM AS OFFICER1_EMPNUM,'
' p2.PF_LNAME AS OFFICER2_LNAME,'
' p2.PF_FNAME AS OFFICER2_FNAME,'
' p2.PF_EMPNUM AS OFFICER2_EMPNUM,'
' dua.CARNUMBER AS CARNUMBER,'
' cs.STATION_NAME AS CURRENT_STATION,'
' ms.STATION_NAME AS MAIN_STATION,'
' mts.STATION_NAME AS MOVING_TO_STATION,'
' dua.MANPOWER,'
' dua.UNIT_DESC,'
' dua.UNIT_TYPE,'
' dua.STATUS AS CURRENT_STATUS,'
' CASE'
' WHEN dua.STATUS = 70 THEN dua.UNAVAILABLE_REASON'
' ELSE NULL'
' END AS UNAVAILABLE_REASON,'
' dua.LASTSTATUSCHANGE'
'FROM UNITS_CURRENT uc'
'JOIN DIS_UNIT_ACTIVE dua ON dua.UNITID = uc.UNITID'
'JOIN AGENCY ag ON ag.AGENCYID = dua.AGENCY'
'LEFT JOIN CFS_ACTIVE cfs ON cfs.UNITID = dua.UNITID'
'LEFT JOIN COMPLAINT_ACTIVE cap ON cap.COMPLAINTID = cfs.COMPLAIN' +
'TID AND cap.AGENCY = '#39'BFD'#39
'LEFT JOIN CD_DISPATCHCODES cdc ON cdc.CODE = cap.DISPATCHCODE'
'LEFT JOIN CD_UNITSTATUS cus ON cus.CODE = dua.STATUS'
'LEFT JOIN PERSONNEL p1 ON p1.PF_NAMEID = dua.OFFICER1ID'
'LEFT JOIN PERSONNEL p2 ON p2.PF_NAMEID = dua.OFFICER2ID'
'LEFT JOIN STATIONS cs ON cs.STATION_ID = dua.CURRENT_STATION_ID'
'LEFT JOIN STATIONS ms ON ms.STATION_ID = dua.MAIN_STATION_ID'
'LEFT JOIN STATIONS mts ON mts.STATION_ID = dua.MOVING_TO_STATION' +
'_ID'
'WHERE uc.AGENCY = '#39'BFD'#39
' AND dua.AGENCY = '#39'BFD'#39
' AND dua.STATUS < 101'
' AND uc.GPS_LATITUDE IS NOT NULL'
' AND uc.GPS_LONGITUDE IS NOT NULL'
' AND NOT (uc.GPS_LATITUDE = 0 AND uc.GPS_LONGITUDE = 0)'
'ORDER BY dua.UNITNAME')
ReadOnly = True
Left = 467
Top = 391
object uqMapUnitsentryid: TFloatField
FieldName = 'entryid'
Required = True
end
object uqMapUnitsunitid: TFloatField
FieldName = 'unitid'
end
object uqMapUnitsunitname: TMemoField
FieldName = 'unitname'
ReadOnly = True
BlobType = ftMemo
end
object uqMapUnitsagency: TStringField
FieldName = 'agency'
ReadOnly = True
Size = 6
end
object uqMapUnitsagency_name: TStringField
FieldName = 'agency_name'
ReadOnly = True
Size = 40
end
object uqMapUnitsgps_latitude: TFloatField
FieldName = 'gps_latitude'
end
object uqMapUnitsgps_longitude: TFloatField
FieldName = 'gps_longitude'
end
object uqMapUnitscall_type: TStringField
FieldName = 'call_type'
ReadOnly = True
Size = 60
end
object uqMapUnitspriority: TStringField
FieldName = 'priority'
ReadOnly = True
Size = 6
end
object uqMapUnitsunit_status_desc: TStringField
FieldName = 'unit_status_desc'
ReadOnly = True
Size = 100
end
object uqMapUnitsupdate_time: TDateTimeField
FieldName = 'update_time'
end
object uqMapUnitsdis_unitid: TFloatField
FieldName = 'dis_unitid'
ReadOnly = True
end
object uqMapUnitsofficer1_lname: TStringField
FieldName = 'officer1_lname'
ReadOnly = True
Size = 15
end
object uqMapUnitsofficer1_fname: TStringField
FieldName = 'officer1_fname'
ReadOnly = True
Size = 12
end
object uqMapUnitsofficer1_empnum: TStringField
FieldName = 'officer1_empnum'
ReadOnly = True
Size = 10
end
object uqMapUnitsofficer2_lname: TStringField
FieldName = 'officer2_lname'
ReadOnly = True
Size = 15
end
object uqMapUnitsofficer2_fname: TStringField
FieldName = 'officer2_fname'
ReadOnly = True
Size = 12
end
object uqMapUnitsofficer2_empnum: TStringField
FieldName = 'officer2_empnum'
ReadOnly = True
Size = 10
end
object uqMapUnitsagencytype: TStringField
FieldName = 'agencytype'
ReadOnly = True
Size = 10
end
object uqMapUnitscarnumber: TStringField
FieldName = 'carnumber'
ReadOnly = True
end
object uqMapUnitscurrent_station: TStringField
FieldName = 'current_station'
ReadOnly = True
Size = 50
end
object uqMapUnitsmain_station: TStringField
FieldName = 'main_station'
ReadOnly = True
Size = 50
end
object uqMapUnitsmoving_to_station: TStringField
FieldName = 'moving_to_station'
ReadOnly = True
Size = 50
end
object uqMapUnitsmanpower: TFloatField
FieldName = 'manpower'
ReadOnly = True
end
object uqMapUnitsunit_desc: TStringField
FieldName = 'unit_desc'
ReadOnly = True
Size = 30
end
object uqMapUnitsunit_type: TFloatField
FieldName = 'unit_type'
ReadOnly = True
end
object uqMapUnitscurrent_status: TFloatField
FieldName = 'current_status'
ReadOnly = True
end
object uqMapUnitsunavailable_reason: TStringField
FieldName = 'unavailable_reason'
ReadOnly = True
Size = 50
end
object uqMapUnitslaststatuschange: TDateTimeField
FieldName = 'laststatuschange'
ReadOnly = True
end
end
object uqUnitList: TUniQuery
Connection = ucENTCAD
SQL.Strings = (
'SELECT'
' ag.AGENCYID AS AGENCY,'
' ag.AGENCYNAME AS AGENCY_NAME,'
' ag.AGENCYTYPE AS AGENCYTYPE,'
' dua.UNITID,'
' dua.UNITNAME,'
' dua.CARNUMBER AS CARNUMBER_DESC,'
' cd.CODE_DESC AS DISTRICT_DESC,'
' sec.CODE_DESC AS SECTOR_DESC,'
' p1.PF_EMPNUM AS OFFICER1_EMPNUM,'
' p1.PF_LNAME AS OFFICER1_LAST_NAME,'
' p1.PF_FNAME AS OFFICER1_FIRST_NAME,'
' p1.PF_MI AS OFFICER1_MI,'
' p2.PF_EMPNUM AS OFFICER2_EMPNUM,'
' p2.PF_LNAME AS OFFICER2_LAST_NAME,'
' p2.PF_FNAME AS OFFICER2_FIRST_NAME,'
' p2.PF_MI AS OFFICER2_MI,'
' NVL(cfs.LOCATION, dua.LOCATION) AS LOCATION,'
' cfs.COMPLAINT,'
' dua.STATUS AS UNITSTATUS,'
' CASE'
' WHEN dua.STATUS = 20 AND mts.STATION_NAME IS NOT NULL THEN N' +
'VL(cus.CODE_DESC, TO_CHAR(dua.STATUS)) || '#39' to '#39' || mts.STATION_' +
'NAME'
' WHEN dua.STATUS = 70 AND dua.UNAVAILABLE_REASON IS NOT NULL ' +
'THEN NVL(cus.CODE_DESC, TO_CHAR(dua.STATUS)) || '#39' - '#39' || dua.UNA' +
'VAILABLE_REASON'
' WHEN dua.STATUS = 0 AND NVL(dua.MANPOWER, 0) = 1 THEN NVL(cu' +
's.CODE_DESC, '#39'Available'#39') || '#39' - Undermanned'#39
' ELSE NVL(cus.CODE_DESC, TO_CHAR(dua.STATUS))'
' END AS UNIT_STATUS_DESC,'
' cdc.CODE_DESC AS CALL_TYPE,'
' uc.ENTRYID,'
' uc.GPS_LATITUDE,'
' uc.GPS_LONGITUDE,'
' cs.STATION_NAME AS CURRENT_STATION,'
' ms.STATION_NAME AS MAIN_STATION,'
' mts.STATION_NAME AS MOVING_TO_STATION,'
' dua.MANPOWER,'
' dua.UNIT_DESC,'
' dua.UNIT_TYPE,'
' dua.DISPATCHABLE,'
' CASE'
' WHEN dua.STATUS = 70 THEN dua.UNAVAILABLE_REASON'
' ELSE NULL'
' END AS UNAVAILABLE_REASON,'
' dua.LASTSTATUSCHANGE'
'FROM DIS_UNIT_ACTIVE dua'
'JOIN AGENCY ag ON ag.AGENCYID = dua.AGENCY'
'JOIN STATIONS cs ON cs.STATION_ID = dua.CURRENT_STATION_ID'
'LEFT JOIN STATIONS ms ON ms.STATION_ID = dua.MAIN_STATION_ID'
'LEFT JOIN STATIONS mts ON mts.STATION_ID = dua.MOVING_TO_STATION' +
'_ID'
'LEFT JOIN CD_DISTRICT cd ON cd.AGENCYCODE = dua.DISTRICT'
'LEFT JOIN CD_SECTOR sec ON sec.AGENCYCODE = dua.SECTOR AND sec.C' +
'ODE_TYPE = cd.AGENCYCODE'
'LEFT JOIN PERSONNEL p1 ON dua.OFFICER1ID = p1.PF_NAMEID'
'LEFT JOIN PERSONNEL p2 ON dua.OFFICER2ID = p2.PF_NAMEID'
'LEFT JOIN CFS_ACTIVE cfs ON dua.UNITID = cfs.UNITID'
'LEFT JOIN COMPLAINT_ACTIVE cap ON cap.COMPLAINTID = cfs.COMPLAIN' +
'TID AND cap.AGENCY = '#39'BFD'#39
'LEFT JOIN CD_DISPATCHCODES cdc ON cdc.CODE = cap.DISPATCHCODE'
'LEFT JOIN CD_UNITSTATUS cus ON cus.CODE = dua.STATUS'
'LEFT JOIN UNITS_CURRENT uc ON uc.UNITID = dua.UNITID AND uc.AGEN' +
'CY = '#39'BFD'#39
'WHERE dua.AGENCY = '#39'BFD'#39
' AND dua.STATUS < 101'
' AND dua.DISPATCHABLE <> '#39'F'#39
'ORDER BY cs.STATION_NAME, dua.UNITNAME')
ReadOnly = True
Left = 79
Top = 191
object uqUnitListagency: TStringField
FieldName = 'agency'
ReadOnly = True
Size = 6
end
object uqUnitListagency_name: TStringField
FieldName = 'agency_name'
ReadOnly = True
Size = 40
end
object uqUnitListunitid: TFloatField
FieldName = 'unitid'
end
object uqUnitListunitname: TStringField
FieldName = 'unitname'
Size = 10
end
object uqUnitListcarnumber_desc: TStringField
FieldName = 'carnumber_desc'
ReadOnly = True
Size = 120
end
object uqUnitListdistrict_desc: TStringField
FieldName = 'district_desc'
ReadOnly = True
Size = 120
end
object uqUnitListsector_desc: TStringField
FieldName = 'sector_desc'
ReadOnly = True
Size = 120
end
object uqUnitListofficer1_empnum: TStringField
FieldName = 'officer1_empnum'
ReadOnly = True
Size = 10
end
object uqUnitListofficer1_last_name: TStringField
FieldName = 'officer1_last_name'
ReadOnly = True
Size = 15
end
object uqUnitListofficer1_first_name: TStringField
FieldName = 'officer1_first_name'
ReadOnly = True
Size = 12
end
object uqUnitListofficer1_mi: TStringField
FieldName = 'officer1_mi'
ReadOnly = True
Size = 1
end
object uqUnitListofficer2_empnum: TStringField
FieldName = 'officer2_empnum'
ReadOnly = True
Size = 10
end
object uqUnitListofficer2_last_name: TStringField
FieldName = 'officer2_last_name'
ReadOnly = True
Size = 15
end
object uqUnitListofficer2_first_name: TStringField
FieldName = 'officer2_first_name'
ReadOnly = True
Size = 12
end
object uqUnitListofficer2_mi: TStringField
FieldName = 'officer2_mi'
ReadOnly = True
Size = 1
end
object uqUnitListlocation: TStringField
FieldName = 'location'
ReadOnly = True
Size = 100
end
object uqUnitListcomplaint: TStringField
FieldName = 'complaint'
ReadOnly = True
Size = 10
end
object uqUnitListunitstatus: TFloatField
FieldName = 'unitstatus'
ReadOnly = True
end
object uqUnitListunit_status_desc: TStringField
FieldName = 'unit_status_desc'
ReadOnly = True
Size = 100
end
object uqUnitListcall_type: TStringField
FieldName = 'call_type'
ReadOnly = True
Size = 60
end
object uqUnitListentryid: TFloatField
FieldName = 'entryid'
ReadOnly = True
Required = True
end
object uqUnitListgps_latitude: TFloatField
FieldName = 'gps_latitude'
ReadOnly = True
end
object uqUnitListgps_longitude: TFloatField
FieldName = 'gps_longitude'
ReadOnly = True
end
object uqUnitListagencytype: TStringField
FieldName = 'agencytype'
ReadOnly = True
Size = 10
end
object uqUnitListcurrent_station: TStringField
FieldName = 'current_station'
ReadOnly = True
Size = 50
end
object uqUnitListmain_station: TStringField
FieldName = 'main_station'
ReadOnly = True
Size = 50
end
object uqUnitListmoving_to_station: TStringField
FieldName = 'moving_to_station'
ReadOnly = True
Size = 50
end
object uqUnitListmanpower: TFloatField
FieldName = 'manpower'
ReadOnly = True
end
object uqUnitListunit_desc: TStringField
FieldName = 'unit_desc'
ReadOnly = True
Size = 30
end
object uqUnitListunit_type: TFloatField
FieldName = 'unit_type'
ReadOnly = True
end
object uqUnitListdispatchable: TStringField
FieldName = 'dispatchable'
ReadOnly = True
Size = 1
end
object uqUnitListunavailable_reason: TStringField
FieldName = 'unavailable_reason'
ReadOnly = True
Size = 50
end
object uqUnitListlaststatuschange: TDateTimeField
FieldName = 'laststatuschange'
ReadOnly = True
end
end
object uqComplaintUnits: TUniQuery
Connection = ucENTCAD
SQL.Strings = (
'SELECT'
' cft.COMPLAINTID,'
' cft.UNITID,'
' NVL(dua.UNITNAME, cfs.UNITNAME) AS UNITNAME,'
' cft.DISPATCHED AS DATEDISPATCHED,'
' cft.ENROUTE AS DATERESPONDED,'
' cft.ONSCENE AS DATEARRIVED,'
' cft.CLEARED AS DATECLEARED,'
' cfs.LOCATION,'
' cft.REPORTING_UNIT'
'FROM COMPLAINT_FIREUNIT_TIMES cft'
'LEFT JOIN DIS_UNIT_ACTIVE dua ON dua.UNITID = cft.UNITID'
'LEFT JOIN CFS_ACTIVE cfs ON cfs.COMPLAINTID = cft.COMPLAINTID AN' +
'D cfs.UNITID = cft.UNITID'
'WHERE cft.COMPLAINTID = :COMPLAINTID'
' AND cft.AGENCY = '#39'BFD'#39
'ORDER BY cft.DISPATCHED')
ReadOnly = True
Left = 467
Top = 327
ParamData = <
item
DataType = ftUnknown
Name = 'COMPLAINTID'
Value = nil
end>
object uqComplaintUnitscomplaintid: TFloatField
FieldName = 'complaintid'
Required = True
end
object uqComplaintUnitsunitid: TFloatField
FieldName = 'unitid'
Required = True
end
object uqComplaintUnitsunitname: TStringField
FieldName = 'unitname'
Size = 10
end
object uqComplaintUnitsdatedispatched: TDateTimeField
FieldName = 'datedispatched'
end
object uqComplaintUnitsdateresponded: TDateTimeField
FieldName = 'dateresponded'
end
object uqComplaintUnitsdatearrived: TDateTimeField
FieldName = 'datearrived'
end
object uqComplaintUnitsdatecleared: TDateTimeField
FieldName = 'datecleared'
end
object uqComplaintUnitslocation: TStringField
FieldName = 'location'
Size = 100
end
object uqComplaintUnitsreporting_unit: TStringField
FieldName = 'reporting_unit'
ReadOnly = True
Size = 1
end
end
object uqCFSMemos: TUniQuery
Connection = ucENTCAD
SQL.Strings = (
'SELECT'
' cm.MEMO_ID,'
' cm.CFSID,'
' cm.MEMO_TYPE,'
' cm.TIMESTAMP,'
' cm.BADGE_NUMBER,'
' cm.REMARKS'
'FROM CFS_MEMOS cm'
'WHERE cm.CFSID = :CFSID'
'ORDER BY cm.TIMESTAMP DESC')
ReadOnly = True
Left = 199
Top = 248
ParamData = <
item
DataType = ftUnknown
Name = 'CFSID'
Value = nil
end>
object uqCFSMemosmemo_id: TFloatField
FieldName = 'memo_id'
end
object uqCFSMemoscfsid: TFloatField
FieldName = 'cfsid'
end
object uqCFSMemosmemo_type: TFloatField
FieldName = 'memo_type'
end
object uqCFSMemostimestamp: TDateTimeField
FieldName = 'timestamp'
end
object uqCFSMemosbadge_number: TStringField
FieldName = 'badge_number'
Size = 6
end
object uqCFSMemosremarks: TStringField
FieldName = 'remarks'
Size = 4000
end
end
object uqComplaintList: TUniQuery
Connection = ucENTCAD
SQL.Strings = (
'SELECT'
' ca.COMPLAINTID,'
' ca.CFSID,'
' ca.COMPLAINT,'
' ca.AGENCY,'
' cdc.CODE_DESC AS DISPATCH_CODE_DESC,'
' ca.SOURCE,'
' ccs.CODE_DESC AS SOURCE_DESC,'
' ca.PRIORITY,'
' ca.ADDRESSID,'
' ca.ADDRESS,'
' ca.APARTMENT,'
' ca.CITY,'
' ca.BUSINESS,'
' cd.CODE_DESC AS DISPATCHDISTRICT,'
' ca.DISPATCHSECTOR,'
' ca.ADDRESSDISTRICT,'
' ca.ADDRESSSECTOR,'
' ca.XCOORD,'
' ca.YCOORD,'
' ca.WARNINGS,'
' ca.CONTACTS,'
' ca.HISTORY,'
' ct.DATEREPORTED,'
' ct.DATERECEIVED,'
' ct.DATEDISPATCHED,'
' ct.DATERESPONDED,'
' ct.DATEARRIVED,'
' ct.DATECLEARED,'
' cp.COLOR AS PRIORITY_COLOR,'
' cd.CODE_DESC AS DISTRICT_DESC,'
' sec.CODE_DESC AS SECTOR_DESC,'
' ca.STATUS,'
' cst.CODE_DESC AS STATUS_DESC,'
' cst.COLOR AS STATUS_COLOR,'
' ca.HOLDUNITNAME,'
' ca.FIRERESONDER AS FIRERESPONDER,'
' ca.EMSRESONDER AS EMSRESPONDER,'
' ca.ALARMLEVEL,'
' ca.RESPONSE_ZONE,'
' ca.EMS_RESPONSE_TYPE'
'FROM COMPLAINT_ACTIVE ca'
'JOIN COMPLAINT_TIMES ct ON ct.COMPLAINTID = ca.COMPLAINTID'
'LEFT JOIN CD_DISPATCHCODES cdc ON cdc.CODE = ca.DISPATCHCODE'
'LEFT JOIN CD_CALLSOURCES ccs ON ccs.CODE = ca.SOURCE'
'LEFT JOIN CD_CALLPRIORITIES cp ON cp.CODE = ca.PRIORITY'
'LEFT JOIN CD_DISTRICT cd ON cd.AGENCYCODE = ca.DISPATCHDISTRICT'
'LEFT JOIN CD_SECTOR sec ON sec.AGENCYCODE = ca.DISPATCHSECTOR AN' +
'D sec.CODE_TYPE = cd.AGENCYCODE'
'LEFT JOIN CD_COMPLAINTSTATUS cst ON cst.CODE = ca.STATUS'
'WHERE ca.AGENCY = '#39'BFD'#39
' AND ca.COMPLAINT IS NOT NULL'
'ORDER BY ct.DATEREPORTED DESC, ca.PRIORITY')
ReadOnly = True
OnCalcFields = uqComplaintListCalcFields
Left = 80
Top = 248
object uqComplaintListcomplaintid: TFloatField
FieldName = 'complaintid'
Required = True
end
object uqComplaintListcfsid: TFloatField
FieldName = 'cfsid'
end
object uqComplaintListcomplaint: TStringField
FieldName = 'complaint'
Size = 10
end
object uqComplaintListagency: TStringField
FieldName = 'agency'
Size = 6
end
object uqComplaintListdispatch_code_desc: TStringField
FieldName = 'dispatch_code_desc'
ReadOnly = True
Size = 60
end
object uqComplaintListsource: TStringField
FieldName = 'source'
Size = 6
end
object uqComplaintListsource_desc: TStringField
FieldName = 'source_desc'
ReadOnly = True
Size = 120
end
object uqComplaintListpriority: TStringField
FieldName = 'priority'
Size = 6
end
object uqComplaintListaddressid: TFloatField
FieldName = 'addressid'
end
object uqComplaintListaddress: TStringField
FieldName = 'address'
Size = 64
end
object uqComplaintListapartment: TStringField
FieldName = 'apartment'
Size = 6
end
object uqComplaintListcity: TStringField
FieldName = 'city'
end
object uqComplaintListbusiness: TStringField
FieldName = 'business'
Size = 35
end
object uqComplaintListdispatchdistrict: TStringField
FieldName = 'dispatchdistrict'
ReadOnly = True
Size = 120
end
object uqComplaintListdispatchsector: TStringField
FieldName = 'dispatchsector'
Size = 6
end
object uqComplaintListaddressdistrict: TStringField
FieldName = 'addressdistrict'
Size = 5
end
object uqComplaintListaddresssector: TStringField
FieldName = 'addresssector'
Size = 5
end
object uqComplaintListxcoord: TFloatField
FieldName = 'xcoord'
end
object uqComplaintListycoord: TFloatField
FieldName = 'ycoord'
end
object uqComplaintListwarnings: TFloatField
FieldName = 'warnings'
end
object uqComplaintListcontacts: TFloatField
FieldName = 'contacts'
end
object uqComplaintListhistory: TFloatField
FieldName = 'history'
end
object uqComplaintListdatereported: TDateTimeField
FieldName = 'datereported'
ReadOnly = True
end
object uqComplaintListdatereceived: TDateTimeField
FieldName = 'datereceived'
ReadOnly = True
end
object uqComplaintListdatedispatched: TDateTimeField
FieldName = 'datedispatched'
ReadOnly = True
end
object uqComplaintListdateresponded: TDateTimeField
FieldName = 'dateresponded'
ReadOnly = True
end
object uqComplaintListdatearrived: TDateTimeField
FieldName = 'datearrived'
ReadOnly = True
end
object uqComplaintListdatecleared: TDateTimeField
FieldName = 'datecleared'
ReadOnly = True
end
object uqComplaintListpriority_color: TFloatField
FieldName = 'priority_color'
ReadOnly = True
end
object uqComplaintListdistrict_desc: TStringField
FieldName = 'district_desc'
ReadOnly = True
Size = 120
end
object uqComplaintListsector_desc: TStringField
FieldName = 'sector_desc'
ReadOnly = True
Size = 120
end
object uqComplaintListcomplaintNumber: TStringField
FieldKind = fkCalculated
FieldName = 'complaintNumber'
Calculated = True
end
object uqComplaintListstatus: TStringField
FieldName = 'status'
Size = 3
end
object uqComplaintListstatus_desc: TStringField
FieldName = 'status_desc'
ReadOnly = True
Size = 30
end
object uqComplaintListstatus_color: TFloatField
FieldName = 'status_color'
ReadOnly = True
end
object uqComplaintListholdunitname: TStringField
FieldName = 'holdunitname'
Size = 10
end
object uqComplaintListfireresponder: TStringField
FieldName = 'fireresponder'
Size = 6
end
object uqComplaintListemsresponder: TStringField
FieldName = 'emsresponder'
Size = 6
end
object uqComplaintListalarmlevel: TStringField
FieldName = 'alarmlevel'
Size = 4
end
object uqComplaintListresponse_zone: TStringField
FieldName = 'response_zone'
Size = 6
end
object uqComplaintListems_response_type: TStringField
FieldName = 'ems_response_type'
Size = 10
end
end
object uqComplaintDetails: TUniQuery
Connection = ucENTCAD
SQL.Strings = (
'SELECT'
' ca.COMPLAINTID,'
' ca.CFSID,'
' ca.COMPLAINT,'
' ca.PRIORITY,'
' ca.DISPATCHCODE,'
' cdc.CODE_DESC AS DISPATCH_CODE_DESC,'
' cd.CODE_DESC AS DISPATCHDISTRICT,'
' ca.ADDRESS,'
' ca.BUSINESS,'
' ct.DATEREPORTED,'
' ct.DATERECEIVED,'
' ct.DATEDISPATCHED,'
' ct.DATERESPONDED,'
' ct.DATEARRIVED,'
' ct.DATECLEARED,'
' ca.HISTORY,'
' ca.CONTACTS,'
' ca.WARNINGS,'
' ca.ADDRESSID,'
' ca.AGENCY,'
' a.STRNUMBER,'
' a.STRHNUMBER,'
' a.STRPREFIX,'
' a.STRNAME,'
' a.STRSUFFIX,'
' a.CITY,'
' 0 AS STATUS,'
' ca.STATUS AS COMPLAINT_STATUS,'
' cst.CODE_DESC AS COMPLAINT_STATUS_DESC,'
' cst.COLOR AS COMPLAINT_STATUS_COLOR,'
' ca.HOLDUNITNAME,'
' ca.FIRERESONDER AS FIRERESPONDER,'
' ca.EMSRESONDER AS EMSRESPONDER,'
' ca.ALARMLEVEL,'
' ca.RESPONSE_ZONE,'
' ca.EMS_RESPONSE_TYPE'
'FROM COMPLAINT_ACTIVE ca'
'JOIN COMPLAINT_TIMES ct ON ct.COMPLAINTID = ca.COMPLAINTID'
'LEFT JOIN CD_DISPATCHCODES cdc ON cdc.CODE = ca.DISPATCHCODE'
'LEFT JOIN CD_DISTRICT cd ON cd.AGENCYCODE = ca.DISPATCHDISTRICT'
'LEFT JOIN ADDRESS a ON a.ADDRESSID = ca.ADDRESSID'
'LEFT JOIN CD_COMPLAINTSTATUS cst ON cst.CODE = ca.STATUS'
'WHERE ca.COMPLAINTID = :COMPLAINTID'
' AND ca.AGENCY = '#39'BFD'#39
'UNION ALL'
'SELECT'
' ca.COMPLAINTID,'
' ca.CFSID,'
' ca.COMPLAINT,'
' ca.PRIORITY,'
' ca.DISPATCHCODE,'
' cdc.CODE_DESC AS DISPATCH_CODE_DESC,'
' cd.CODE_DESC AS DISPATCHDISTRICT,'
' ca.ADDRESS,'
' ca.BUSINESS,'
' ct.DATEREPORTED,'
' ct.DATERECEIVED,'
' ct.DATEDISPATCHED,'
' ct.DATERESPONDED,'
' ct.DATEARRIVED,'
' ct.DATECLEARED,'
' ca.HISTORY,'
' ca.CONTACTS,'
' ca.WARNINGS,'
' ca.ADDRESSID,'
' ca.AGENCY,'
' a.STRNUMBER,'
' a.STRHNUMBER,'
' a.STRPREFIX,'
' a.STRNAME,'
' a.STRSUFFIX,'
' a.CITY,'
' 1 AS STATUS,'
' ca.STATUS AS COMPLAINT_STATUS,'
' cst.CODE_DESC AS COMPLAINT_STATUS_DESC,'
' cst.COLOR AS COMPLAINT_STATUS_COLOR,'
' CAST(NULL AS VARCHAR2(10)) AS HOLDUNITNAME,'
' ca.FIRERESONDER,'
' ca.EMSRESONDER,'
' ca.ALARMLEVEL,'
' ca.RESPONSE_ZONE,'
' ca.EMS_RESPONSE_TYPE'
'FROM COMPLAINT_ARCHIVE ca'
'JOIN COMPLAINT_TIMES ct ON ct.COMPLAINTID = ca.COMPLAINTID'
'LEFT JOIN CD_DISPATCHCODES cdc ON cdc.CODE = ca.DISPATCHCODE'
'LEFT JOIN CD_DISTRICT cd ON cd.AGENCYCODE = ca.DISPATCHDISTRICT'
'LEFT JOIN ADDRESS a ON a.ADDRESSID = ca.ADDRESSID'
'LEFT JOIN CD_COMPLAINTSTATUS cst ON cst.CODE = ca.STATUS'
'WHERE ca.COMPLAINTID = :COMPLAINTID'
' AND ca.AGENCY = '#39'BFD'#39)
ReadOnly = True
Left = 83
Top = 303
ParamData = <
item
DataType = ftUnknown
Name = 'COMPLAINTID'
Value = nil
end>
object uqComplaintDetailscomplaintid: TFloatField
FieldName = 'complaintid'
ReadOnly = True
end
object uqComplaintDetailscfsid: TFloatField
FieldName = 'cfsid'
ReadOnly = True
end
object uqComplaintDetailscomplaint: TStringField
FieldName = 'complaint'
ReadOnly = True
Size = 10
end
object uqComplaintDetailspriority: TStringField
FieldName = 'priority'
ReadOnly = True
Size = 6
end
object uqComplaintDetailsdispatchcode: TStringField
FieldName = 'dispatchcode'
ReadOnly = True
Size = 6
end
object uqComplaintDetailsdispatch_code_desc: TStringField
FieldName = 'dispatch_code_desc'
ReadOnly = True
Size = 60
end
object uqComplaintDetailsdispatchdistrict: TStringField
FieldName = 'dispatchdistrict'
ReadOnly = True
Size = 120
end
object uqComplaintDetailsaddress: TStringField
FieldName = 'address'
ReadOnly = True
Size = 64
end
object uqComplaintDetailsbusiness: TStringField
FieldName = 'business'
ReadOnly = True
Size = 35
end
object uqComplaintDetailsdatereported: TDateTimeField
FieldName = 'datereported'
ReadOnly = True
end
object uqComplaintDetailsdatereceived: TDateTimeField
FieldName = 'datereceived'
ReadOnly = True
end
object uqComplaintDetailsdatedispatched: TDateTimeField
FieldName = 'datedispatched'
ReadOnly = True
end
object uqComplaintDetailsdateresponded: TDateTimeField
FieldName = 'dateresponded'
ReadOnly = True
end
object uqComplaintDetailsdatearrived: TDateTimeField
FieldName = 'datearrived'
ReadOnly = True
end
object uqComplaintDetailsdatecleared: TDateTimeField
FieldName = 'datecleared'
ReadOnly = True
end
object uqComplaintDetailshistory: TFloatField
FieldName = 'history'
ReadOnly = True
end
object uqComplaintDetailscontacts: TFloatField
FieldName = 'contacts'
ReadOnly = True
end
object uqComplaintDetailswarnings: TFloatField
FieldName = 'warnings'
ReadOnly = True
end
object uqComplaintDetailsaddressid: TFloatField
FieldName = 'addressid'
ReadOnly = True
end
object uqComplaintDetailsagency: TStringField
FieldName = 'agency'
ReadOnly = True
Size = 6
end
object uqComplaintDetailsstrnumber: TFloatField
FieldName = 'strnumber'
ReadOnly = True
end
object uqComplaintDetailsstrhnumber: TStringField
FieldName = 'strhnumber'
ReadOnly = True
Size = 1
end
object uqComplaintDetailsstrprefix: TStringField
FieldName = 'strprefix'
ReadOnly = True
Size = 1
end
object uqComplaintDetailsstrname: TStringField
FieldName = 'strname'
ReadOnly = True
end
object uqComplaintDetailsstrsuffix: TStringField
FieldName = 'strsuffix'
ReadOnly = True
Size = 2
end
object uqComplaintDetailscity: TStringField
FieldName = 'city'
ReadOnly = True
end
object uqComplaintDetailscomplaint_status: TStringField
FieldName = 'complaint_status'
ReadOnly = True
Size = 3
end
object uqComplaintDetailscomplaint_status_desc: TStringField
FieldName = 'complaint_status_desc'
ReadOnly = True
Size = 30
end
object uqComplaintDetailscomplaint_status_color: TFloatField
FieldName = 'complaint_status_color'
ReadOnly = True
end
object uqComplaintDetailsholdunitname: TStringField
FieldName = 'holdunitname'
ReadOnly = True
Size = 10
end
object uqComplaintDetailsfireresponder: TStringField
FieldName = 'fireresponder'
ReadOnly = True
Size = 6
end
object uqComplaintDetailsemsresponder: TStringField
FieldName = 'emsresponder'
ReadOnly = True
Size = 6
end
object uqComplaintDetailsalarmlevel: TStringField
FieldName = 'alarmlevel'
ReadOnly = True
Size = 4
end
object uqComplaintDetailsresponse_zone: TStringField
FieldName = 'response_zone'
ReadOnly = True
Size = 6
end
object uqComplaintDetailsems_response_type: TStringField
FieldName = 'ems_response_type'
ReadOnly = True
Size = 10
end
object uqComplaintDetailsSTATUS: TFloatField
FieldName = 'status'
ReadOnly = True
end
end
object uqMapComplaints: TUniQuery
Connection = ucENTCAD
SQL.Strings = (
'SELECT'
' q.COMPLAINTID,'
' q.COMPLAINT,'
' q.DISPATCHDISTRICT,'
' q.AGENCY,'
' q.AGENCY_NAME,'
' q.PRIORITY,'
' q.DATEDISPATCHED,'
' q.DATEARRIVED,'
' q.BUSINESS,'
' q.DISPATCHCODECATEGORY,'
' q.GEOM.SDO_POINT.X AS LNG,'
' q.GEOM.SDO_POINT.Y AS LAT,'
' q.DISPATCH_CODE_DESC,'
' q.ADDRESS,'
' q.COMPLAINT_STATUS,'
' q.COMPLAINT_STATUS_DESC,'
' q.STATUS_COLOR'
'FROM ('
' SELECT'
' ca.COMPLAINTID,'
' ca.COMPLAINT,'
' cd.CODE_DESC AS DISPATCHDISTRICT,'
' ca.AGENCY,'
' ag.AGENCYNAME AS AGENCY_NAME,'
' ca.PRIORITY,'
' ct.DATEDISPATCHED,'
' ct.DATEARRIVED,'
' ca.BUSINESS,'
' cdc.CATEGORY AS DISPATCHCODECATEGORY,'
' cdc.CODE_DESC AS DISPATCH_CODE_DESC,'
' ca.ADDRESS,'
' ca.STATUS AS COMPLAINT_STATUS,'
' cst.CODE_DESC AS COMPLAINT_STATUS_DESC,'
' cst.COLOR AS STATUS_COLOR,'
' MDSYS.SDO_CS.TRANSFORM('
' MDSYS.SDO_GEOMETRY('
' 2001,'
' 2262,'
' MDSYS.SDO_POINT_TYPE(ca.XCOORD, ca.YCOORD, NULL),'
' NULL,'
' NULL'
' ),'
' 4326'
' ) AS GEOM'
' FROM COMPLAINT_ACTIVE ca'
' JOIN COMPLAINT_TIMES ct'
' ON ct.COMPLAINTID = ca.COMPLAINTID'
' LEFT JOIN CD_DISPATCHCODES cdc'
' ON cdc.CODE = ca.DISPATCHCODE'
' LEFT JOIN CD_DISTRICT cd'
' ON cd.AGENCYCODE = ca.DISPATCHDISTRICT'
' LEFT JOIN AGENCY ag'
' ON ag.AGENCYID = ca.AGENCY'
' LEFT JOIN CD_COMPLAINTSTATUS cst'
' ON cst.CODE = ca.STATUS'
' WHERE ca.AGENCY = '#39'BFD'#39
' AND ca.COMPLAINT IS NOT NULL'
' AND ca.XCOORD IS NOT NULL'
' AND ca.YCOORD IS NOT NULL'
') q')
ReadOnly = True
OnCalcFields = uqMapComplaintsCalcFields
Left = 468
Top = 264
object uqMapComplaintscomplaintid: TFloatField
FieldName = 'complaintid'
Required = True
end
object uqMapComplaintsdispatchdistrict: TStringField
FieldName = 'dispatchdistrict'
ReadOnly = True
Size = 120
end
object uqMapComplaintspriority: TStringField
FieldName = 'priority'
Size = 6
end
object uqMapComplaintsbusiness: TStringField
FieldName = 'business'
Size = 35
end
object uqMapComplaintsdispatchcodecategory: TStringField
FieldName = 'dispatchcodecategory'
ReadOnly = True
Size = 30
end
object uqMapComplaintslng: TFloatField
FieldName = 'lng'
ReadOnly = True
end
object uqMapComplaintslat: TFloatField
FieldName = 'lat'
ReadOnly = True
end
object uqMapComplaintsdispatch_code_desc: TStringField
FieldName = 'dispatch_code_desc'
ReadOnly = True
Size = 60
end
object uqMapComplaintsaddress: TStringField
FieldName = 'address'
Size = 64
end
object uqMapComplaintsagency: TStringField
FieldName = 'agency'
Size = 6
end
object uqMapComplaintsagency_name: TStringField
FieldName = 'agency_name'
ReadOnly = True
Size = 40
end
object uqMapComplaintsdatedispatched: TDateTimeField
FieldName = 'datedispatched'
ReadOnly = True
end
object uqMapComplaintsdatearrived: TDateTimeField
FieldName = 'datearrived'
ReadOnly = True
end
object uqMapComplaintspriorityBadge: TStringField
FieldKind = fkCalculated
FieldName = 'priorityBadge'
Size = 80
Calculated = True
end
object uqMapComplaintscomplaintStatusKey: TStringField
FieldKind = fkCalculated
FieldName = 'complaintStatusKey'
Size = 80
Calculated = True
end
object uqMapComplaintspngName: TStringField
FieldKind = fkCalculated
FieldName = 'pngName'
Size = 80
Calculated = True
end
object uqMapComplaintscomplaint: TStringField
FieldName = 'complaint'
Size = 10
end
object uqMapComplaintscomplaint_status: TStringField
FieldName = 'complaint_status'
ReadOnly = True
Size = 3
end
object uqMapComplaintscomplaint_status_desc: TStringField
FieldName = 'complaint_status_desc'
ReadOnly = True
Size = 30
end
object uqMapComplaintsstatus_color: TFloatField
FieldName = 'status_color'
ReadOnly = True
end
end
object uqBadgeCounts: TUniQuery
Connection = ucENTCAD
SQL.Strings = (
'SELECT'
' CAST(('
' SELECT COUNT(*)'
' FROM COMPLAINT_ACTIVE ca'
' WHERE ca.AGENCY = '#39'BFD'#39
' AND ca.COMPLAINT IS NOT NULL'
' ) AS NUMBER(18,0)) AS COMPLAINTS,'
' CAST(('
' SELECT COUNT(*)'
' FROM DIS_UNIT_ACTIVE dua'
' WHERE dua.AGENCY = '#39'BFD'#39
' AND dua.STATUS < 101'
' AND dua.DISPATCHABLE <> '#39'F'#39
' ) AS NUMBER(18,0)) AS UNITS'
'FROM DUAL')
ReadOnly = True
Left = 200
Top = 192
object uqBadgeCountscomplaints: TLargeintField
FieldName = 'complaints'
ReadOnly = True
end
object uqBadgeCountsunits: TLargeintField
FieldName = 'units'
ReadOnly = True
end
end
object uqMapComplaintUnitsList: TUniQuery
Connection = ucENTCAD
SQL.Strings = (
'SELECT'
' cfs.COMPLAINTID,'
' cfs.UNITID,'
' cfs.UNITNAME,'
' cfs.DATEDISPATCHED,'
' cfs.DATERESPONDED,'
' cfs.DATEARRIVED,'
' cfs.DATECLEARED,'
' cfs.LOCATION'
'FROM CFS_ACTIVE cfs'
'JOIN COMPLAINT_ACTIVE ca ON ca.COMPLAINTID = cfs.COMPLAINTID'
'JOIN DIS_UNIT_ACTIVE dua ON dua.UNITID = cfs.UNITID AND dua.AGEN' +
'CY = '#39'BFD'#39
'WHERE ca.AGENCY = '#39'BFD'#39
' AND ca.XCOORD IS NOT NULL'
' AND ca.YCOORD IS NOT NULL'
'ORDER BY cfs.COMPLAINTID, cfs.DATEDISPATCHED')
ReadOnly = True
Left = 464
Top = 203
object uqMapComplaintUnitsListcomplaintid: TFloatField
FieldName = 'complaintid'
Required = True
end
object uqMapComplaintUnitsListunitid: TFloatField
FieldName = 'unitid'
Required = True
end
object uqMapComplaintUnitsListunitname: TStringField
FieldName = 'unitname'
Size = 10
end
object uqMapComplaintUnitsListdatedispatched: TDateTimeField
FieldName = 'datedispatched'
end
object uqMapComplaintUnitsListdateresponded: TDateTimeField
FieldName = 'dateresponded'
end
object uqMapComplaintUnitsListdatearrived: TDateTimeField
FieldName = 'datearrived'
end
object uqMapComplaintUnitsListdatecleared: TDateTimeField
FieldName = 'datecleared'
end
object uqMapComplaintUnitsListlocation: TStringField
FieldName = 'location'
Size = 100
end
end
object uqComplaintHistory: TUniQuery
Connection = ucENTCAD
SQL.Strings = (
'WITH ctx AS ('
' SELECT'
' ca.AGENCY,'
' a.STRNUMBER,'
' a.STRHNUMBER,'
' a.STRPREFIX,'
' a.STRNAME,'
' a.STRSUFFIX,'
' a.CITY'
' FROM COMPLAINT_ACTIVE ca'
' LEFT JOIN ADDRESS a ON a.ADDRESSID = ca.ADDRESSID'
' WHERE ca.COMPLAINTID = :COMPLAINTID'
' AND ca.AGENCY = '#39'BFD'#39
' UNION ALL'
' SELECT'
' ca.AGENCY,'
' a.STRNUMBER,'
' a.STRHNUMBER,'
' a.STRPREFIX,'
' a.STRNAME,'
' a.STRSUFFIX,'
' a.CITY'
' FROM COMPLAINT_ARCHIVE ca'
' LEFT JOIN ADDRESS a ON a.ADDRESSID = ca.ADDRESSID'
' WHERE ca.COMPLAINTID = :COMPLAINTID'
' AND ca.AGENCY = '#39'BFD'#39
' AND NOT EXISTS ('
' SELECT 1 FROM COMPLAINT_ACTIVE x WHERE x.COMPLAINTID = :CO' +
'MPLAINTID'
' )'
')'
'SELECT'
' c.COMPLAINTID,'
' c.COMPLAINT,'
' c.APARTMENT,'
' c.DATEREPORTED,'
' cp.CODE_DESC AS DPRIORITY,'
' cdc.CODE_DESC AS DCALLTYPE'
'FROM COMPLAINT_ARCHIVE c'
'JOIN ctx ON 1 = 1'
'LEFT JOIN CD_CALLPRIORITIES cp ON cp.CODE = c.PRIORITY'
'LEFT JOIN CD_DISPATCHCODES cdc ON cdc.CODE = c.DISPATCHCODE'
'WHERE c.AGENCY = ctx.AGENCY'
' AND c.COMPLAINTID <> :COMPLAINTID'
' AND ((ctx.STRNUMBER IS NULL AND c.STRNUMBER IS NULL) OR (ctx.S' +
'TRNUMBER IS NOT NULL AND c.STRNUMBER = ctx.STRNUMBER))'
' AND (ctx.STRHNUMBER IS NULL OR c.STRHNUMBER = ctx.STRHNUMBER)'
' AND (ctx.STRPREFIX IS NULL OR c.STRPREFIX = ctx.STRPREFIX)'
' AND (ctx.STRNAME IS NULL OR c.STRNAME = ctx.STRNAME)'
' AND (ctx.STRSUFFIX IS NULL OR c.STRSUFFIX = ctx.STRSUFFIX)'
' AND (ctx.CITY IS NULL OR c.CITY = ctx.CITY)'
'ORDER BY c.DATEREPORTED DESC')
ReadOnly = True
Left = 331
Top = 72
ParamData = <
item
DataType = ftUnknown
Name = 'COMPLAINTID'
Value = Null
end>
object uqComplaintHistorycomplaintid: TFloatField
FieldName = 'complaintid'
Required = True
end
object uqComplaintHistorycomplaint: TStringField
FieldName = 'complaint'
Size = 10
end
object uqComplaintHistoryapartment: TStringField
FieldName = 'apartment'
Size = 6
end
object uqComplaintHistorydatereported: TDateTimeField
FieldName = 'datereported'
Required = True
end
object uqComplaintHistorydpriority: TStringField
FieldName = 'dpriority'
ReadOnly = True
Size = 120
end
object uqComplaintHistorydcalltype: TStringField
FieldName = 'dcalltype'
ReadOnly = True
Size = 60
end
end
object uqComplaintContacts: TUniQuery
Connection = ucENTCAD
SQL.Strings = (
'WITH ctx AS ('
' SELECT ca.ADDRESSID'
' FROM COMPLAINT_ACTIVE ca'
' WHERE ca.COMPLAINTID = :COMPLAINTID'
' AND ca.AGENCY = '#39'BFD'#39
' UNION ALL'
' SELECT ca.ADDRESSID'
' FROM COMPLAINT_ARCHIVE ca'
' WHERE ca.COMPLAINTID = :COMPLAINTID'
' AND ca.AGENCY = '#39'BFD'#39
' AND NOT EXISTS ('
' SELECT 1 FROM COMPLAINT_ACTIVE x WHERE x.COMPLAINTID = :CO' +
'MPLAINTID'
' )'
')'
'SELECT'
' c.NAME,'
' c.PHONE,'
' ct.CODE_DESC AS DCONTACTTYPE,'
' c.REMARKS'
'FROM DIS_CONTACT c'
'JOIN ctx ON ctx.ADDRESSID = c.ADDRESSID'
'LEFT JOIN CD_CONTACTTYPE ct ON ct.CODE = c.CONTACTTYPE'
'ORDER BY c.NOTIFYORDER, c.NAME')
ReadOnly = True
Left = 331
Top = 131
ParamData = <
item
DataType = ftUnknown
Name = 'COMPLAINTID'
Value = nil
end>
object uqComplaintContactsname: TStringField
FieldName = 'name'
Size = 30
end
object uqComplaintContactsphone: TStringField
FieldName = 'phone'
Size = 15
end
object uqComplaintContactsdcontacttype: TStringField
FieldName = 'dcontacttype'
ReadOnly = True
Size = 120
end
object uqComplaintContactsremarks: TStringField
FieldName = 'remarks'
Size = 200
end
end
object uqComplaintWarnings: TUniQuery
Connection = ucENTCAD
SQL.Strings = (
'WITH ctx AS ('
' SELECT ca.ADDRESSID'
' FROM COMPLAINT_ACTIVE ca'
' WHERE ca.COMPLAINTID = :COMPLAINTID'
' AND ca.AGENCY = '#39'BFD'#39
' UNION ALL'
' SELECT ca.ADDRESSID'
' FROM COMPLAINT_ARCHIVE ca'
' WHERE ca.COMPLAINTID = :COMPLAINTID'
' AND ca.AGENCY = '#39'BFD'#39
' AND NOT EXISTS ('
' SELECT 1 FROM COMPLAINT_ACTIVE x WHERE x.COMPLAINTID = :CO' +
'MPLAINTID'
' )'
')'
'SELECT'
' wt.CODE_DESC,'
' a.STRNUMBER,'
' a.STRHNUMBER,'
' a.STRPREFIX,'
' a.STRNAME,'
' a.STRSUFFIX,'
' a.APARTMENT,'
' a.CITY,'
' w.NOTES'
'FROM ctx'
'JOIN DIS_WARNING w ON w.ADDRESSID = ctx.ADDRESSID'
'JOIN CD_WARNINGTYPE wt ON wt.CODE = w.CODE'
'JOIN ADDRESS a ON a.ADDRESSID = w.ADDRESSID'
'WHERE w.STATUS = '#39'1'#39
'ORDER BY wt.CODE_DESC')
ReadOnly = True
Left = 488
Top = 76
ParamData = <
item
DataType = ftUnknown
Name = 'COMPLAINTID'
Value = nil
end>
object uqComplaintWarningscode_desc: TStringField
FieldName = 'code_desc'
ReadOnly = True
Size = 120
end
object uqComplaintWarningsstrnumber: TFloatField
FieldName = 'strnumber'
ReadOnly = True
end
object uqComplaintWarningsstrhnumber: TStringField
FieldName = 'strhnumber'
ReadOnly = True
Size = 1
end
object uqComplaintWarningsstrprefix: TStringField
FieldName = 'strprefix'
ReadOnly = True
Size = 1
end
object uqComplaintWarningsstrname: TStringField
FieldName = 'strname'
ReadOnly = True
end
object uqComplaintWarningsstrsuffix: TStringField
FieldName = 'strsuffix'
ReadOnly = True
Size = 2
end
object uqComplaintWarningsapartment: TStringField
FieldName = 'apartment'
ReadOnly = True
Size = 6
end
object uqComplaintWarningscity: TStringField
FieldName = 'city'
ReadOnly = True
end
object uqComplaintWarningsnotes: TStringField
FieldName = 'notes'
ReadOnly = True
Size = 1000
end
end
object uqUnitDetails: TUniQuery
Connection = ucENTCAD
SQL.Strings = (
'SELECT'
' dua.UNITID,'
' dua.UNITNAME,'
' dua.CARNUMBER AS CARNUMBER_DESC,'
' cd.CODE_DESC AS DISTRICT_DESC,'
' NVL(cfs.LOCATION, dua.LOCATION) AS LOCATION,'
' CASE'
' WHEN dua.STATUS = 20 AND mts.STATION_NAME IS NOT NULL THEN N' +
'VL(cus.CODE_DESC, TO_CHAR(dua.STATUS)) || '#39' to '#39' || mts.STATION_' +
'NAME'
' WHEN dua.STATUS = 70 AND dua.UNAVAILABLE_REASON IS NOT NULL ' +
'THEN NVL(cus.CODE_DESC, TO_CHAR(dua.STATUS)) || '#39' - '#39' || dua.UNA' +
'VAILABLE_REASON'
' WHEN dua.STATUS = 0 AND NVL(dua.MANPOWER, 0) = 1 THEN NVL(cu' +
's.CODE_DESC, '#39'Available'#39') || '#39' - Undermanned'#39
' ELSE NVL(cus.CODE_DESC, TO_CHAR(dua.STATUS))'
' END AS UNIT_STATUS_DESC,'
' p1.PF_LNAME AS OFFICER1_LNAME,'
' p1.PF_FNAME AS OFFICER1_FNAME,'
' p1.PF_EMPNUM AS OFFICER1_EMPNUM,'
' p2.PF_LNAME AS OFFICER2_LNAME,'
' p2.PF_FNAME AS OFFICER2_FNAME,'
' p2.PF_EMPNUM AS OFFICER2_EMPNUM,'
' uc.UPDATETIME AS UPDATE_TIME,'
' cs.STATION_NAME AS CURRENT_STATION,'
' ms.STATION_NAME AS MAIN_STATION,'
' mts.STATION_NAME AS MOVING_TO_STATION,'
' dua.MANPOWER,'
' dua.UNIT_DESC,'
' dua.UNIT_TYPE,'
' dua.STATUS AS CURRENT_STATUS,'
' dua.DISPATCHABLE,'
' CASE'
' WHEN dua.STATUS = 70 THEN dua.UNAVAILABLE_REASON'
' ELSE NULL'
' END AS UNAVAILABLE_REASON,'
' dua.LASTSTATUSCHANGE,'
' cfs.COMPLAINT,'
' cdc.CODE_DESC AS CALL_TYPE'
'FROM DIS_UNIT_ACTIVE dua'
'LEFT JOIN CD_DISTRICT cd ON cd.AGENCYCODE = dua.DISTRICT'
'LEFT JOIN CFS_ACTIVE cfs ON cfs.UNITID = dua.UNITID'
'LEFT JOIN COMPLAINT_ACTIVE ca ON ca.COMPLAINTID = cfs.COMPLAINTI' +
'D AND ca.AGENCY = '#39'BFD'#39
'LEFT JOIN CD_DISPATCHCODES cdc ON cdc.CODE = ca.DISPATCHCODE'
'LEFT JOIN CD_UNITSTATUS cus ON cus.CODE = dua.STATUS'
'LEFT JOIN PERSONNEL p1 ON dua.OFFICER1ID = p1.PF_NAMEID'
'LEFT JOIN PERSONNEL p2 ON dua.OFFICER2ID = p2.PF_NAMEID'
'LEFT JOIN UNITS_CURRENT uc ON uc.UNITID = dua.UNITID AND uc.AGEN' +
'CY = '#39'BFD'#39
'LEFT JOIN STATIONS cs ON cs.STATION_ID = dua.CURRENT_STATION_ID'
'LEFT JOIN STATIONS ms ON ms.STATION_ID = dua.MAIN_STATION_ID'
'LEFT JOIN STATIONS mts ON mts.STATION_ID = dua.MOVING_TO_STATION' +
'_ID'
'WHERE dua.UNITID = :UNITID'
' AND dua.AGENCY = '#39'BFD'#39)
ReadOnly = True
Left = 199
Top = 304
ParamData = <
item
DataType = ftUnknown
Name = 'UNITID'
Value = nil
end>
object uqUnitDetailsunitid: TFloatField
FieldName = 'unitid'
end
object uqUnitDetailsunitname: TStringField
FieldName = 'unitname'
Size = 10
end
object uqUnitDetailscarnumber_desc: TStringField
FieldName = 'carnumber_desc'
ReadOnly = True
Size = 120
end
object uqUnitDetailsdistrict_desc: TStringField
FieldName = 'district_desc'
ReadOnly = True
Size = 120
end
object uqUnitDetailslocation: TStringField
FieldName = 'location'
ReadOnly = True
Size = 100
end
object uqUnitDetailsunit_status_desc: TStringField
FieldName = 'unit_status_desc'
ReadOnly = True
Size = 100
end
object uqUnitDetailsofficer1_lname: TStringField
FieldName = 'officer1_lname'
ReadOnly = True
Size = 15
end
object uqUnitDetailsofficer1_fname: TStringField
FieldName = 'officer1_fname'
ReadOnly = True
Size = 12
end
object uqUnitDetailsofficer1_empnum: TStringField
FieldName = 'officer1_empnum'
ReadOnly = True
Size = 10
end
object uqUnitDetailsofficer2_lname: TStringField
FieldName = 'officer2_lname'
ReadOnly = True
Size = 15
end
object uqUnitDetailsofficer2_fname: TStringField
FieldName = 'officer2_fname'
ReadOnly = True
Size = 12
end
object uqUnitDetailsofficer2_empnum: TStringField
FieldName = 'officer2_empnum'
ReadOnly = True
Size = 10
end
object uqUnitDetailsupdate_time: TDateTimeField
FieldName = 'update_time'
ReadOnly = True
end
object uqUnitDetailscurrent_station: TStringField
FieldName = 'current_station'
ReadOnly = True
Size = 50
end
object uqUnitDetailsmain_station: TStringField
FieldName = 'main_station'
ReadOnly = True
Size = 50
end
object uqUnitDetailsmoving_to_station: TStringField
FieldName = 'moving_to_station'
ReadOnly = True
Size = 50
end
object uqUnitDetailsmanpower: TFloatField
FieldName = 'manpower'
ReadOnly = True
end
object uqUnitDetailsunit_desc: TStringField
FieldName = 'unit_desc'
ReadOnly = True
Size = 30
end
object uqUnitDetailsunit_type: TFloatField
FieldName = 'unit_type'
ReadOnly = True
end
object uqUnitDetailscurrent_status: TFloatField
FieldName = 'current_status'
ReadOnly = True
end
object uqUnitDetailsdispatchable: TStringField
FieldName = 'dispatchable'
ReadOnly = True
Size = 1
end
object uqUnitDetailsunavailable_reason: TStringField
FieldName = 'unavailable_reason'
ReadOnly = True
Size = 50
end
object uqUnitDetailslaststatuschange: TDateTimeField
FieldName = 'laststatuschange'
ReadOnly = True
end
object uqUnitDetailscomplaint: TStringField
FieldName = 'complaint'
ReadOnly = True
Size = 10
end
object uqUnitDetailscall_type: TStringField
FieldName = 'call_type'
ReadOnly = True
Size = 60
end
end
object uqUnitLogs: TUniQuery
Connection = ucENTCAD
SQL.Strings = (
'SELECT'
' dul.TIMESTAMP AS LOG_TIME,'
' dul.COMPLAINT AS COMPLAINT_NUM,'
' dul.LOG AS LOG_TEXT'
'FROM DIS_UNIT_LOG dul'
'WHERE dul.UNITID = :UNITID'
'ORDER BY dul.TIMESTAMP DESC')
ReadOnly = True
Left = 199
Top = 359
ParamData = <
item
DataType = ftUnknown
Name = 'UNITID'
Value = nil
end>
object uqUnitLogslog_time: TDateTimeField
FieldName = 'log_time'
end
object uqUnitLogscomplaint_num: TStringField
FieldName = 'complaint_num'
Size = 10
end
object uqUnitLogslog_text: TStringField
FieldName = 'log_text'
Size = 2000
end
end
object UniAlerter1: TUniAlerter
Connection = ucENTCAD
Events = 'disupdate'
OnEvent = UniAlerter1Event
Left = 324
Top = 383
end
object OracleUniProvider1: TOracleUniProvider
Left = 167
Top = 47
end
object ucENTCAD: TUniConnection
ProviderName = 'Oracle'
Username = 'EMFIRECAD'
Server = 'BFD'
Connected = False
LoginPrompt = False
Left = 57
Top = 45
EncryptedPassword = 'BAFFB2FFB9FFB6FFADFFBAFFBCFFBEFFBBFF'
end
end
emiMobileServer/Clients/WC/Server/WC.Api.Data.pas → emiMobileServer/Clients/BFD/Server/BFD.Api.Database.pas
unit WC.Api.Data;
unit BFD.Api.Database;
interface
uses
System.JSON, Client.Data, WC.Api.Database;
Client.Data, System.JSON, System.StrUtils, XData.Sys.Exceptions,
System.SysUtils, System.Classes, System.SyncObjs, Data.DB, MemDS, DBAccess, Uni, UniProvider,
OracleUniProvider, System.Variants, System.Generics.Collections, System.IniFiles,
Common.Logging, Vcl.Forms, System.Character, Common.Ini, DAAlerter,
UniAlerter;
type
// Note: Owns the WC database module; each returned JSON object belongs to the caller.
TWCAPIData = class(TClientData)
TBFDAPIDataModule = class(TClientData)
uqMapUnits: TUniQuery;
uqUnitList: TUniQuery;
uqComplaintUnits: TUniQuery;
uqCFSMemos: TUniQuery;
uqComplaintList: TUniQuery;
uqComplaintDetails: TUniQuery;
ucENTCAD: TUniConnection;
uqMapComplaints: TUniQuery;
uqBadgeCounts: TUniQuery;
uqMapComplaintUnitsList: TUniQuery;
uqComplaintHistory: TUniQuery;
uqComplaintContacts: TUniQuery;
uqComplaintWarnings: TUniQuery;
uqUnitDetails: TUniQuery;
uqUnitLogs: TUniQuery;
OracleUniProvider1: TOracleUniProvider;
uqComplaintListcomplaintid: TFloatField;
uqComplaintListcfsid: TFloatField;
uqComplaintListcomplaint: TStringField;
uqComplaintListagency: TStringField;
uqComplaintListdispatch_code_desc: TStringField;
uqComplaintListsource: TStringField;
uqComplaintListsource_desc: TStringField;
uqComplaintListpriority: TStringField;
uqComplaintListaddressid: TFloatField;
uqComplaintListaddress: TStringField;
uqComplaintListapartment: TStringField;
uqComplaintListcity: TStringField;
uqComplaintListbusiness: TStringField;
uqComplaintListdispatchdistrict: TStringField;
uqComplaintListdispatchsector: TStringField;
uqComplaintListaddressdistrict: TStringField;
uqComplaintListaddresssector: TStringField;
uqComplaintListxcoord: TFloatField;
uqComplaintListycoord: TFloatField;
uqComplaintListwarnings: TFloatField;
uqComplaintListcontacts: TFloatField;
uqComplaintListhistory: TFloatField;
uqComplaintListdatereported: TDateTimeField;
uqComplaintListdatereceived: TDateTimeField;
uqComplaintListdatedispatched: TDateTimeField;
uqComplaintListdateresponded: TDateTimeField;
uqComplaintListdatearrived: TDateTimeField;
uqComplaintListdatecleared: TDateTimeField;
uqComplaintListpriority_color: TFloatField;
uqComplaintListdistrict_desc: TStringField;
uqComplaintListsector_desc: TStringField;
uqComplaintListcomplaintNumber: TStringField;
uqComplaintDetailscomplaintid: TFloatField;
uqComplaintDetailscfsid: TFloatField;
uqComplaintDetailscomplaint: TStringField;
uqComplaintDetailspriority: TStringField;
uqComplaintDetailsdispatchcode: TStringField;
uqComplaintDetailsdispatch_code_desc: TStringField;
uqComplaintDetailsdispatchdistrict: TStringField;
uqComplaintDetailsaddress: TStringField;
uqComplaintDetailsbusiness: TStringField;
uqComplaintDetailsdatereported: TDateTimeField;
uqComplaintDetailsdatereceived: TDateTimeField;
uqComplaintDetailsdatedispatched: TDateTimeField;
uqComplaintDetailsdateresponded: TDateTimeField;
uqComplaintDetailsdatearrived: TDateTimeField;
uqComplaintDetailsdatecleared: TDateTimeField;
uqComplaintDetailshistory: TFloatField;
uqComplaintDetailscontacts: TFloatField;
uqComplaintDetailswarnings: TFloatField;
uqComplaintDetailsaddressid: TFloatField;
uqComplaintDetailsagency: TStringField;
uqComplaintDetailsstrnumber: TFloatField;
uqComplaintDetailsstrhnumber: TStringField;
uqComplaintDetailsstrprefix: TStringField;
uqComplaintDetailsstrname: TStringField;
uqComplaintDetailsstrsuffix: TStringField;
uqComplaintDetailscity: TStringField;
uqCFSMemosmemo_id: TFloatField;
uqCFSMemoscfsid: TFloatField;
uqCFSMemosmemo_type: TFloatField;
uqCFSMemostimestamp: TDateTimeField;
uqCFSMemosbadge_number: TStringField;
uqCFSMemosremarks: TStringField;
uqUnitDetailsunitid: TFloatField;
uqUnitDetailsunitname: TStringField;
uqUnitDetailscarnumber_desc: TStringField;
uqUnitDetailsdistrict_desc: TStringField;
uqUnitDetailslocation: TStringField;
uqUnitDetailsunit_status_desc: TStringField;
uqUnitDetailsofficer1_lname: TStringField;
uqUnitDetailsofficer1_fname: TStringField;
uqUnitDetailsofficer1_empnum: TStringField;
uqUnitDetailsofficer2_lname: TStringField;
uqUnitDetailsofficer2_fname: TStringField;
uqUnitDetailsofficer2_empnum: TStringField;
uqUnitDetailsupdate_time: TDateTimeField;
uqUnitLogslog_time: TDateTimeField;
uqUnitLogscomplaint_num: TStringField;
uqUnitLogslog_text: TStringField;
uqComplaintHistorycomplaintid: TFloatField;
uqComplaintHistorycomplaint: TStringField;
uqComplaintHistoryapartment: TStringField;
uqComplaintHistorydatereported: TDateTimeField;
uqComplaintHistorydpriority: TStringField;
uqComplaintHistorydcalltype: TStringField;
uqComplaintContactsname: TStringField;
uqComplaintContactsphone: TStringField;
uqComplaintContactsdcontacttype: TStringField;
uqComplaintContactsremarks: TStringField;
uqComplaintWarningscode_desc: TStringField;
uqComplaintWarningsstrnumber: TFloatField;
uqComplaintWarningsstrhnumber: TStringField;
uqComplaintWarningsstrprefix: TStringField;
uqComplaintWarningsstrname: TStringField;
uqComplaintWarningsstrsuffix: TStringField;
uqComplaintWarningsapartment: TStringField;
uqComplaintWarningscity: TStringField;
uqComplaintWarningsnotes: TStringField;
uqMapComplaintUnitsListcomplaintid: TFloatField;
uqMapComplaintUnitsListunitid: TFloatField;
uqMapComplaintUnitsListunitname: TStringField;
uqMapComplaintUnitsListdatedispatched: TDateTimeField;
uqMapComplaintUnitsListdateresponded: TDateTimeField;
uqMapComplaintUnitsListdatearrived: TDateTimeField;
uqMapComplaintUnitsListdatecleared: TDateTimeField;
uqMapComplaintUnitsListlocation: TStringField;
uqMapComplaintscomplaintid: TFloatField;
uqMapComplaintsdispatchdistrict: TStringField;
uqMapComplaintspriority: TStringField;
uqMapComplaintsbusiness: TStringField;
uqMapComplaintsdispatchcodecategory: TStringField;
uqMapComplaintslng: TFloatField;
uqMapComplaintslat: TFloatField;
uqMapComplaintsdispatch_code_desc: TStringField;
uqMapComplaintsaddress: TStringField;
uqComplaintUnitscomplaintid: TFloatField;
uqComplaintUnitsunitid: TFloatField;
uqComplaintUnitsunitname: TStringField;
uqComplaintUnitsdatedispatched: TDateTimeField;
uqComplaintUnitsdateresponded: TDateTimeField;
uqComplaintUnitsdatearrived: TDateTimeField;
uqComplaintUnitsdatecleared: TDateTimeField;
uqComplaintUnitslocation: TStringField;
uqUnitListagency: TStringField;
uqUnitListagency_name: TStringField;
uqUnitListunitid: TFloatField;
uqUnitListunitname: TStringField;
uqUnitListcarnumber_desc: TStringField;
uqUnitListdistrict_desc: TStringField;
uqUnitListsector_desc: TStringField;
uqUnitListofficer1_empnum: TStringField;
uqUnitListofficer1_last_name: TStringField;
uqUnitListofficer1_first_name: TStringField;
uqUnitListofficer1_mi: TStringField;
uqUnitListofficer2_empnum: TStringField;
uqUnitListofficer2_last_name: TStringField;
uqUnitListofficer2_first_name: TStringField;
uqUnitListofficer2_mi: TStringField;
uqUnitListlocation: TStringField;
uqUnitListcomplaint: TStringField;
uqUnitListunitstatus: TFloatField;
uqUnitListunit_status_desc: TStringField;
uqUnitListcall_type: TStringField;
uqUnitListentryid: TFloatField;
uqUnitListgps_latitude: TFloatField;
uqUnitListgps_longitude: TFloatField;
uqBadgeCountscomplaints: TLargeintField;
uqBadgeCountsunits: TLargeintField;
uqMapUnitsentryid: TFloatField;
uqMapUnitsunitid: TFloatField;
uqMapUnitsunitname: TMemoField;
uqMapUnitsagency: TStringField;
uqMapUnitsagency_name: TStringField;
uqMapUnitsgps_latitude: TFloatField;
uqMapUnitsgps_longitude: TFloatField;
uqMapUnitscall_type: TStringField;
uqMapUnitspriority: TStringField;
uqMapUnitsunit_status_desc: TStringField;
uqMapUnitsupdate_time: TDateTimeField;
uqMapUnitsdis_unitid: TFloatField;
uqMapUnitsofficer1_lname: TStringField;
uqMapUnitsofficer1_fname: TStringField;
uqMapUnitsofficer1_empnum: TStringField;
uqMapUnitsofficer2_lname: TStringField;
uqMapUnitsofficer2_fname: TStringField;
uqMapUnitsofficer2_empnum: TStringField;
uqMapComplaintsagency: TStringField;
uqMapComplaintsagency_name: TStringField;
uqMapComplaintsdatedispatched: TDateTimeField;
uqMapComplaintsdatearrived: TDateTimeField;
uqMapComplaintspriorityBadge: TStringField;
uqMapComplaintscomplaintStatusKey: TStringField;
uqMapComplaintspngName: TStringField;
uqMapUnitsagencytype: TStringField;
uqUnitListagencytype: TStringField;
uqMapComplaintscomplaint: TStringField;
uqMapUnitscarnumber: TStringField;
uqMapUnitscurrent_station: TStringField;
uqMapUnitsmain_station: TStringField;
uqMapUnitsmoving_to_station: TStringField;
uqMapUnitsmanpower: TFloatField;
uqMapUnitsunit_desc: TStringField;
uqMapUnitsunit_type: TFloatField;
uqMapUnitscurrent_status: TFloatField;
uqMapUnitsunavailable_reason: TStringField;
uqMapUnitslaststatuschange: TDateTimeField;
uqUnitListcurrent_station: TStringField;
uqUnitListmain_station: TStringField;
uqUnitListmoving_to_station: TStringField;
uqUnitListmanpower: TFloatField;
uqUnitListunit_desc: TStringField;
uqUnitListunit_type: TFloatField;
uqUnitListdispatchable: TStringField;
uqUnitListunavailable_reason: TStringField;
uqUnitListlaststatuschange: TDateTimeField;
uqComplaintUnitsreporting_unit: TStringField;
uqComplaintListstatus: TStringField;
uqComplaintListstatus_desc: TStringField;
uqComplaintListstatus_color: TFloatField;
uqComplaintListholdunitname: TStringField;
uqComplaintListfireresponder: TStringField;
uqComplaintListemsresponder: TStringField;
uqComplaintListalarmlevel: TStringField;
uqComplaintListresponse_zone: TStringField;
uqComplaintListems_response_type: TStringField;
uqComplaintDetailscomplaint_status: TStringField;
uqComplaintDetailscomplaint_status_desc: TStringField;
uqComplaintDetailscomplaint_status_color: TFloatField;
uqComplaintDetailsholdunitname: TStringField;
uqComplaintDetailsfireresponder: TStringField;
uqComplaintDetailsemsresponder: TStringField;
uqComplaintDetailsalarmlevel: TStringField;
uqComplaintDetailsresponse_zone: TStringField;
uqComplaintDetailsems_response_type: TStringField;
uqMapComplaintscomplaint_status: TStringField;
uqMapComplaintscomplaint_status_desc: TStringField;
uqMapComplaintsstatus_color: TFloatField;
uqUnitDetailscurrent_station: TStringField;
uqUnitDetailsmain_station: TStringField;
uqUnitDetailsmoving_to_station: TStringField;
uqUnitDetailsmanpower: TFloatField;
uqUnitDetailsunit_desc: TStringField;
uqUnitDetailsunit_type: TFloatField;
uqUnitDetailscurrent_status: TFloatField;
uqUnitDetailsdispatchable: TStringField;
uqUnitDetailsunavailable_reason: TStringField;
uqUnitDetailslaststatuschange: TDateTimeField;
uqUnitDetailscomplaint: TStringField;
uqUnitDetailscall_type: TStringField;
UniAlerter1: TUniAlerter;
uqComplaintDetailsSTATUS: TFloatField;
procedure uqComplaintListCalcFields(DataSet: TDataSet);
procedure uqMapComplaintsCalcFields(DataSet: TDataSet);
procedure DataModuleCreate(Sender: TObject);
procedure UniAlerter1Event(Sender: TDAAlerter; const EventName,
Message: string);
private
ApiDB: TWCAPIDataModule;
FCADUpdate: Integer;
public
constructor Create;
destructor Destroy; override;
function EnsureConnected: Boolean; override;
procedure ConfigureQueryTimeouts; override;
function StartUpdateListener: Boolean; override;
function ConsumeCADUpdate: Boolean; override;
function GetBadgeCounts: TJSONObject; override;
function GetComplaintMap(FormatComplaintNumber: Boolean = True): TJSONObject; override;
function GetUnitMap: TJSONObject; override;
......@@ -30,66 +281,213 @@ type
function GetComplaintWarnings(ComplaintId: string): TJSONObject; override;
function GetUnitLogs(UnitId: string): TJSONObject; override;
function GetUnitDetails(UnitId: string): TJSONObject; override;
function EnsureConnected: Boolean; override;
function StartUpdateListener: Boolean; override;
function ConsumeCADUpdate: Boolean; override;
function HandleUniqueFilenames(const category: string): string;
function BadgeCounts(const BaseQuery: TUniQuery): Integer;
end;
var
BFDAPIDataModule: TBFDAPIDataModule;
implementation
uses
System.SysUtils, System.StrUtils, System.Generics.Collections, Data.DB,
XData.Sys.Exceptions, Common.Logging;
{%CLASSGROUP 'Vcl.Controls.TControl'}
{$R *.dfm}
constructor TWCAPIData.Create;
procedure TBFDAPIDataModule.DataModuleCreate(Sender: TObject);
begin
inherited Create;
ApiDB := TWCAPIDataModule.Create(nil);
IniEntries.ConfigureConnection(ucENTCAD);
FCADUpdate := 0;
end;
destructor TWCAPIData.Destroy;
function TBFDAPIDataModule.EnsureConnected: Boolean;
begin
ApiDB.Free;
inherited Destroy;
Result := False;
try
if not ucENTCAD.Connected then
ucENTCAD.Connect;
Result := True;
except
on E: Exception do
Logger.Log(1, 'Oracle API database unavailable: ' + E.Message);
end;
end;
function TWCAPIData.EnsureConnected: Boolean;
function TBFDAPIDataModule.StartUpdateListener: Boolean;
begin
Result := ApiDB.EnsureConnected;
Result := False;
if not EnsureConnected then
Exit;
try
if not UniAlerter1.Active then
begin
Logger.Log(1, 'Starting Oracle disupdate listener');
UniAlerter1.Start;
Logger.Log(1, 'Oracle disupdate listener started');
end;
Result := True;
except
on E: Exception do
Logger.Log(1, 'Oracle disupdate listener unavailable: ' + E.Message);
end;
end;
function TWCAPIData.StartUpdateListener: Boolean;
function TBFDAPIDataModule.ConsumeCADUpdate: Boolean;
begin
Result := ApiDB.StartUpdateListener;
Result := TInterlocked.Exchange(FCADUpdate, 0) <> 0;
end;
function TWCAPIData.ConsumeCADUpdate: Boolean;
procedure TBFDAPIDataModule.uqComplaintListCalcFields(DataSet: TDataSet);
var
raw: string;
begin
Result := ApiDB.ConsumeCADUpdate;
raw := uqComplaintListCOMPLAINT.AsString.Trim;
if raw.Length >= 3 then
uqComplaintListcomplaintNumber.AsString := Copy(raw, 1, 2) + '-' + Copy(raw, 3, MaxInt)
else if raw.Length = 2 then
uqComplaintListcomplaintNumber.AsString := raw + '-'
else
uqComplaintListcomplaintNumber.AsString := raw;
end;
procedure TWCAPIData.ConfigureQueryTimeouts;
const
COMMAND_TIMEOUT_SECONDS = 15;
procedure TBFDAPIDataModule.uqMapComplaintsCalcFields(DataSet: TDataSet);
var
rawCategory: string;
rawPriority: string;
complaintStatus: string;
statusKey: string;
begin
ApiDB.uqBadgeCounts.SpecificOptions.Values['CommandTimeout'] := IntToStr(COMMAND_TIMEOUT_SECONDS);
ApiDB.uqMapUnits.SpecificOptions.Values['CommandTimeout'] := IntToStr(COMMAND_TIMEOUT_SECONDS);
ApiDB.uqMapComplaintUnitsList.SpecificOptions.Values['CommandTimeout'] := IntToStr(COMMAND_TIMEOUT_SECONDS);
ApiDB.uqMapComplaints.SpecificOptions.Values['CommandTimeout'] := IntToStr(COMMAND_TIMEOUT_SECONDS);
ApiDB.uqUnitList.SpecificOptions.Values['CommandTimeout'] := IntToStr(COMMAND_TIMEOUT_SECONDS);
ApiDB.uqComplaintList.SpecificOptions.Values['CommandTimeout'] := IntToStr(COMMAND_TIMEOUT_SECONDS);
rawCategory := DataSet.FieldByName('DISPATCHCODECATEGORY').AsString;
rawPriority := Trim(DataSet.FieldByName('PRIORITY').AsString);
complaintStatus := Trim(DataSet.FieldByName('COMPLAINT_STATUS').AsString);
case StrToIntDef(complaintStatus, 1) of
2: statusKey := 'active';
4: statusKey := 'hold';
5: statusKey := 'holdu';
6: statusKey := 'suspend';
else
statusKey := 'pending';
end;
if rawPriority = '' then
DataSet.FieldByName('priorityBadge').AsString := '?'
else
DataSet.FieldByName('priorityBadge').AsString := UpperCase(rawPriority);
DataSet.FieldByName('complaintStatusKey').AsString := statusKey;
if Trim(rawCategory) = '' then
DataSet.FieldByName('pngName').AsString := Format('default_%s.png', [statusKey])
else
DataSet.FieldByName('pngName').AsString :=
Format('%s_%s.png', [HandleUniqueFilenames(rawCategory), statusKey]);
end;
function TWCAPIData.GetBadgeCounts: TJSONObject;
function TBFDAPIDataModule.HandleUniqueFilenames(const category: string): string;
var
i: Integer;
ch: Char;
lowered, resultBuilder: string;
begin
Logger.Log(3, '---TWCAPIData.GetBadgeCounts initiated');
lowered := Trim(LowerCase(category));
resultBuilder := '';
for i := 1 to Length(lowered) do
begin
ch := lowered[i];
if ch.IsLetterOrDigit then
resultBuilder := resultBuilder + ch
else
resultBuilder := resultBuilder + '_';
end;
Result := resultBuilder;
end;
procedure TBFDAPIDataModule.UniAlerter1Event(Sender: TDAAlerter; const EventName, Message: string);
begin
if SameText(EventName, 'disupdate') then
TInterlocked.Exchange(FCADUpdate, 1);
end;
function TBFDAPIDataModule.BadgeCounts(const BaseQuery: TUniQuery): Integer;
var
Q: TUniQuery;
WrappedSQL: string;
begin
Q := TUniQuery.Create(nil);
try
Q.Connection := BaseQuery.Connection;
// Wrap the original query text in a COUNT(*) shell
WrappedSQL := 'select count(*) as CNT from (' + BaseQuery.SQL.Text + ') t';
Q.SQL.Text := WrappedSQL;
// Carry over params (if the base query uses any)
Q.Params.AssignValues(BaseQuery.Params);
Q.Open;
Result := Q.Fields[0].AsInteger;
finally
Q.Free;
end;
end;
function DelphiColorToHtml(AColor: Integer): string;
begin
Result :=
'#' +
IntToHex(AColor and $FF, 2) +
IntToHex((AColor shr 8) and $FF, 2) +
IntToHex((AColor shr 16) and $FF, 2);
end;
function ComplaintDisplayStatus(StatusCode, StatusDesc, HoldUnitName: string): string;
begin
StatusCode := Trim(StatusCode);
StatusDesc := Trim(StatusDesc);
HoldUnitName := Trim(HoldUnitName);
if ((StatusCode = '5') or
((StatusCode = '4') and (HoldUnitName <> ''))) and
(HoldUnitName <> '') then
Result := 'H-' + HoldUnitName
else if StatusDesc <> '' then
Result := StatusDesc
else
Result := 'Pending';
end;
procedure TBFDAPIDataModule.ConfigureQueryTimeouts;
begin
// Note: Preserve the existing Oracle query timeout settings.
end;
function TBFDAPIDataModule.GetBadgeCounts: TJSONObject;
begin
Logger.Log(3, '---TBFDAPIDataModule.GetBadgeCounts initiated');
Result := TJSONObject.Create;
try
try
with ApiDB.uqBadgeCounts do
with uqBadgeCounts do
begin
Open;
try
Result.AddPair('BadgeComplaints', TJSONNumber.Create(FieldByName('COMPLAINTS').AsInteger));
Result.AddPair('BadgeUnits', TJSONNumber.Create(FieldByName('UNITS').AsInteger));
Result.AddPair(
'BadgeComplaints',
TJSONNumber.Create(FieldByName('COMPLAINTS').AsInteger)
);
Result.AddPair(
'BadgeUnits',
TJSONNumber.Create(FieldByName('UNITS').AsInteger)
);
finally
Close;
end;
......@@ -97,32 +495,33 @@ begin
except
on E: Exception do
begin
Logger.Log(2, '---TWCAPIData.GetBadgeCounts error: ' + E.ClassName + ': ' + E.Message);
Logger.Log(2, '---TBFDAPIDataModule.GetBadgeCounts error: ' + E.ClassName + ': ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load badge counts');
end;
end;
Logger.Log(3, '---TWCAPIData.GetBadgeCounts End');
Logger.Log(3, '---TBFDAPIDataModule.GetBadgeCounts End');
except
Result.Free;
raise;
end;
end;
function TWCAPIData.GetComplaintMap(FormatComplaintNumber: Boolean): TJSONObject;
// Note: BFD retains raw complaint numbers for both HTTP and WebSocket maps.
function TBFDAPIDataModule.GetComplaintMap(FormatComplaintNumber: Boolean): TJSONObject;
var
data: TJSONArray;
emitted: Integer;
item: TJSONObject;
UnitsByComplaintMap: TObjectDictionary<string, TJSONArray>;
complaintId: string;
complaintNumber: string;
unitArray: TJSONArray;
unitStatus: string;
latestUpdate: TDateTime;
unitObj: TJSONObject;
statusColor: string;
begin
Logger.Log(3, '---TWCAPIData.GetComplaintMap initiated');
Logger.Log(3, '---TBFDAPIDataModule.GetComplaintMap initiated');
Result := TJSONObject.Create;
try
......@@ -132,12 +531,12 @@ begin
UnitsByComplaintMap := TObjectDictionary<string, TJSONArray>.Create([doOwnsValues]);
try
try
ApiDB.uqMapComplaintUnitsList.Close;
ApiDB.uqMapComplaintUnitsList.Open;
uqMapComplaintUnitsList.Close;
uqMapComplaintUnitsList.Open;
try
while not ApiDB.uqMapComplaintUnitsList.Eof do
while not uqMapComplaintUnitsList.Eof do
begin
complaintId := ApiDB.uqMapComplaintUnitsListCOMPLAINTID.AsString;
complaintId := uqMapComplaintUnitsListCOMPLAINTID.AsString;
if not UnitsByComplaintMap.TryGetValue(complaintId, unitArray) then
begin
......@@ -147,34 +546,40 @@ begin
unitStatus := 'Dispatched';
if not ApiDB.uqMapComplaintUnitsListDATECLEARED.IsNull then
if not uqMapComplaintUnitsListDATECLEARED.IsNull then
unitStatus := 'Cleared'
else if not ApiDB.uqMapComplaintUnitsListDATEARRIVED.IsNull then
else if not uqMapComplaintUnitsListDATEARRIVED.IsNull then
unitStatus := 'On Scene'
else if not ApiDB.uqMapComplaintUnitsListDATERESPONDED.IsNull then
else if not uqMapComplaintUnitsListDATERESPONDED.IsNull then
unitStatus := 'Enroute';
latestUpdate := 0;
if not ApiDB.uqMapComplaintUnitsListDATEDISPATCHED.IsNull then
latestUpdate := ApiDB.uqMapComplaintUnitsListDATEDISPATCHED.AsDateTime;
if not uqMapComplaintUnitsListDATEDISPATCHED.IsNull then
latestUpdate := uqMapComplaintUnitsListDATEDISPATCHED.AsDateTime;
if (not ApiDB.uqMapComplaintUnitsListDATERESPONDED.IsNull) and
(ApiDB.uqMapComplaintUnitsListDATERESPONDED.AsDateTime > latestUpdate) then
latestUpdate := ApiDB.uqMapComplaintUnitsListDATERESPONDED.AsDateTime;
if (not uqMapComplaintUnitsListDATERESPONDED.IsNull) and
(uqMapComplaintUnitsListDATERESPONDED.AsDateTime > latestUpdate) then
begin
latestUpdate := uqMapComplaintUnitsListDATERESPONDED.AsDateTime;
end;
if (not ApiDB.uqMapComplaintUnitsListDATEARRIVED.IsNull) and
(ApiDB.uqMapComplaintUnitsListDATEARRIVED.AsDateTime > latestUpdate) then
latestUpdate := ApiDB.uqMapComplaintUnitsListDATEARRIVED.AsDateTime;
if (not uqMapComplaintUnitsListDATEARRIVED.IsNull) and
(uqMapComplaintUnitsListDATEARRIVED.AsDateTime > latestUpdate) then
begin
latestUpdate := uqMapComplaintUnitsListDATEARRIVED.AsDateTime;
end;
if (not ApiDB.uqMapComplaintUnitsListDATECLEARED.IsNull) and
(ApiDB.uqMapComplaintUnitsListDATECLEARED.AsDateTime > latestUpdate) then
latestUpdate := ApiDB.uqMapComplaintUnitsListDATECLEARED.AsDateTime;
if (not uqMapComplaintUnitsListDATECLEARED.IsNull) and
(uqMapComplaintUnitsListDATECLEARED.AsDateTime > latestUpdate) then
begin
latestUpdate := uqMapComplaintUnitsListDATECLEARED.AsDateTime;
end;
unitObj := TJSONObject.Create;
unitArray.AddElement(unitObj);
unitObj.AddPair('Unit', ApiDB.uqMapComplaintUnitsListUNITNAME.AsString);
unitObj.AddPair('Unit', uqMapComplaintUnitsListUNITNAME.AsString);
unitObj.AddPair('Status', unitStatus);
if latestUpdate <> 0 then
......@@ -182,76 +587,77 @@ begin
else
unitObj.AddPair('Updated', '');
ApiDB.uqMapComplaintUnitsList.Next;
uqMapComplaintUnitsList.Next;
end;
finally
ApiDB.uqMapComplaintUnitsList.Close;
uqMapComplaintUnitsList.Close;
end;
emitted := 0;
ApiDB.uqMapComplaints.Close;
ApiDB.uqMapComplaints.Open;
uqMapComplaints.Close;
uqMapComplaints.Open;
try
while not ApiDB.uqMapComplaints.Eof do
while not uqMapComplaints.Eof do
begin
item := TJSONObject.Create;
data.AddElement(item);
item.AddPair('ComplaintId', ApiDB.uqMapComplaintsCOMPLAINTID.AsString);
complaintId := uqMapComplaintsCOMPLAINTID.AsString;
complaintNumber := ApiDB.uqMapComplaintsCOMPLAINT.AsString;
// Note: Preserve the existing HTTP formatting and raw WebSocket value.
if FormatComplaintNumber then
statusColor := '#FFFFFF';
if not uqMapComplaintsSTATUS_COLOR.IsNull then
begin
complaintNumber := Trim(complaintNumber);
if Length(complaintNumber) > 2 then
complaintNumber := Copy(complaintNumber, 1, 2) + '-' + Copy(complaintNumber, 3, MaxInt);
statusColor := DelphiColorToHtml(
uqMapComplaintsSTATUS_COLOR.AsInteger
);
end;
item.AddPair('Complaint', complaintNumber);
item.AddPair('DispatchDistrict', ApiDB.uqMapComplaintsDISPATCHDISTRICT.AsString);
item.AddPair('Agency', ApiDB.uqMapComplaintsAGENCY.AsString);
item.AddPair('AgencyName', ApiDB.uqMapComplaintsAGENCY_NAME.AsString);
item.AddPair('DispatchCodeDesc', ApiDB.uqMapComplaintsDISPATCH_CODE_DESC.AsString);
item.AddPair('DispatchCodeCategory', ApiDB.uqMapComplaintsDISPATCHCODECATEGORY.AsString);
item.AddPair('Priority', ApiDB.uqMapComplaintsPRIORITY.AsString);
item.AddPair('PriorityBadge', ApiDB.uqMapComplaintspriorityBadge.AsString);
item.AddPair('ComplaintStatusKey', ApiDB.uqMapComplaintscomplaintStatusKey.AsString);
item.AddPair('pngName', ApiDB.uqMapComplaintspngName.AsString);
item.AddPair('Address', ApiDB.uqMapComplaintsADDRESS.AsString);
item.AddPair('Business', ApiDB.uqMapComplaintsBUSINESS.AsString);
complaintId := ApiDB.uqMapComplaintsCOMPLAINTID.AsString;
item.AddPair('ComplaintId', complaintId);
item.AddPair('Complaint', uqMapComplaintsCOMPLAINT.AsString);
item.AddPair('DispatchDistrict', uqMapComplaintsDISPATCHDISTRICT.AsString);
item.AddPair('Agency', uqMapComplaintsAGENCY.AsString);
item.AddPair('AgencyName', uqMapComplaintsAGENCY_NAME.AsString);
item.AddPair('DispatchCodeDesc', uqMapComplaintsDISPATCH_CODE_DESC.AsString);
item.AddPair('DispatchCodeCategory', uqMapComplaintsDISPATCHCODECATEGORY.AsString);
item.AddPair('Priority', uqMapComplaintsPRIORITY.AsString);
item.AddPair('PriorityBadge', uqMapComplaintspriorityBadge.AsString);
item.AddPair('ComplaintStatusKey', uqMapComplaintscomplaintStatusKey.AsString);
item.AddPair('ComplaintStatus', uqMapComplaintsCOMPLAINT_STATUS.AsString);
item.AddPair('ComplaintStatusDesc', uqMapComplaintsCOMPLAINT_STATUS_DESC.AsString);
item.AddPair('StatusColor', statusColor);
item.AddPair('pngName', uqMapComplaintspngName.AsString);
item.AddPair('Address', uqMapComplaintsADDRESS.AsString);
item.AddPair('Business', uqMapComplaintsBUSINESS.AsString);
if UnitsByComplaintMap.TryGetValue(complaintId, unitArray) then
item.AddPair('Units', TJSONArray(unitArray.Clone))
else
item.AddPair('Units', TJSONArray.Create);
item.AddPair('Lat', TJSONNumber.Create(ApiDB.uqMapComplaintsLAT.AsFloat));
item.AddPair('Lng', TJSONNumber.Create(ApiDB.uqMapComplaintsLNG.AsFloat));
item.AddPair('Lat', TJSONNumber.Create(uqMapComplaintsLAT.AsFloat));
item.AddPair('Lng', TJSONNumber.Create(uqMapComplaintsLNG.AsFloat));
Inc(emitted);
ApiDB.uqMapComplaints.Next;
uqMapComplaints.Next;
end;
finally
ApiDB.uqMapComplaints.Close;
uqMapComplaints.Close;
end;
Result.AddPair('count', TJSONNumber.Create(data.Count));
Result.AddPair('returned', TJSONNumber.Create(emitted));
Logger.Log(3, '---TWCAPIData.GetComplaintMap End (returned=' + IntToStr(emitted) + ')');
Logger.Log(3, '---TBFDAPIDataModule.GetComplaintMap End (returned=' + IntToStr(emitted) + ')');
except
on E: EXDataHttpException do
begin
Logger.Log(2, '---TWCAPIData.GetComplaintMap http error: ' + E.ClassName + ': ' + E.Message);
Logger.Log(2, '---TBFDAPIDataModule.GetComplaintMap http error: ' + E.ClassName + ': ' + E.Message);
raise;
end;
on E: Exception do
begin
Logger.Log(2, '---TWCAPIData.GetComplaintMap error: ' + E.ClassName + ': ' + E.Message);
Logger.Log(2, '---TBFDAPIDataModule.GetComplaintMap error: ' + E.ClassName + ': ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load complaint map');
end;
end;
......@@ -264,14 +670,15 @@ begin
end;
end;
function TWCAPIData.GetUnitMap: TJSONObject;
function TBFDAPIDataModule.GetUnitMap: TJSONObject;
var
data: TJSONArray;
item: TJSONObject;
unitStatus: string;
updateTimeText: string;
lastStatusChangeText: string;
begin
Logger.Log(4, '---TWCAPIData.GetUnitMap initiated');
Logger.Log(4, '---TBFDAPIDataModule.GetUnitMap initiated');
Result := TJSONObject.Create;
try
......@@ -279,7 +686,7 @@ begin
Result.AddPair('data', data);
try
with ApiDB.uqMapUnits do
with uqMapUnits do
begin
Close;
Open;
......@@ -287,44 +694,70 @@ begin
First;
while not Eof do
begin
if (not ApiDB.uqMapUnitsGPS_LATITUDE.IsNull) and (not ApiDB.uqMapUnitsGPS_LONGITUDE.IsNull) then
if (not uqMapUnitsGPS_LATITUDE.IsNull) and
(not uqMapUnitsGPS_LONGITUDE.IsNull) then
begin
item := TJSONObject.Create;
data.AddElement(item);
item.AddPair('UnitId', ApiDB.uqMapUnitsUNITID.AsString);
item.AddPair('UnitName', ApiDB.uqMapUnitsUNITNAME.AsString);
item.AddPair('UnitBadge', ApiDB.uqMapUnitsUNITNAME.AsString);
item.AddPair('Agency', ApiDB.uqMapUnitsAGENCY.AsString);
item.AddPair('AgencyName', ApiDB.uqMapUnitsAGENCY_NAME.AsString);
item.AddPair('AgencyType', ApiDB.uqMapUnitsAGENCYTYPE.AsString);
item.AddPair('UnitId', uqMapUnitsUNITID.AsString);
item.AddPair('UnitName', uqMapUnitsUNITNAME.AsString);
item.AddPair('UnitBadge', uqMapUnitsUNITNAME.AsString);
item.AddPair('Agency', uqMapUnitsAGENCY.AsString);
item.AddPair('AgencyName', uqMapUnitsAGENCY_NAME.AsString);
item.AddPair('AgencyType', uqMapUnitsAGENCYTYPE.AsString);
item.AddPair('Lat', TJSONNumber.Create(uqMapUnitsGPS_LATITUDE.AsFloat));
item.AddPair('Lng', TJSONNumber.Create(uqMapUnitsGPS_LONGITUDE.AsFloat));
item.AddPair('CarNumber', uqMapUnitsCARNUMBER.AsString);
item.AddPair('CurrentStation', uqMapUnitsCURRENT_STATION.AsString);
item.AddPair('MainStation', uqMapUnitsMAIN_STATION.AsString);
item.AddPair('MovingToStation', uqMapUnitsMOVING_TO_STATION.AsString);
item.AddPair('UnitDesc', uqMapUnitsUNIT_DESC.AsString);
item.AddPair('UnitType', uqMapUnitsUNIT_TYPE.AsString);
item.AddPair('Manpower', uqMapUnitsMANPOWER.AsString);
item.AddPair('Lat', TJSONNumber.Create(ApiDB.uqMapUnitsGPS_LATITUDE.AsFloat));
item.AddPair('Lng', TJSONNumber.Create(ApiDB.uqMapUnitsGPS_LONGITUDE.AsFloat));
item.AddPair(
'Undermanned',
TJSONBool.Create(uqMapUnitsMANPOWER.AsInteger = 1)
);
item.AddPair('CallType', ApiDB.uqMapUnitsCALL_TYPE.AsString);
item.AddPair('Priority', ApiDB.uqMapUnitsPRIORITY.AsString);
item.AddPair('CallType', uqMapUnitsCALL_TYPE.AsString);
item.AddPair('Priority', uqMapUnitsPRIORITY.AsString);
unitStatus := ApiDB.uqMapUnitsUNIT_STATUS_DESC.AsString;
if Trim(unitStatus) = '' then
unitStatus := Trim(uqMapUnitsUNIT_STATUS_DESC.AsString);
if unitStatus = '' then
unitStatus := 'Available';
item.AddPair('Status', unitStatus);
item.AddPair('CurrentStatus', uqMapUnitsCURRENT_STATUS.AsString);
item.AddPair('UnavailableReason', uqMapUnitsUNAVAILABLE_REASON.AsString);
updateTimeText := '';
if not ApiDB.uqMapUnitsUPDATE_TIME.IsNull then
updateTimeText := FormatDateTime('yyyy-mm-dd hh:nn:ss', ApiDB.uqMapUnitsUPDATE_TIME.AsDateTime);
if not uqMapUnitsUPDATE_TIME.IsNull then
begin
updateTimeText := FormatDateTime(
'yyyy-mm-dd hh:nn:ss',
uqMapUnitsUPDATE_TIME.AsDateTime
);
end;
item.AddPair('UpdateTime', updateTimeText);
item.AddPair('Officer1Lname', ApiDB.uqMapUnitsOFFICER1_LNAME.AsString);
item.AddPair('Officer1Fname', ApiDB.uqMapUnitsOFFICER1_FNAME.AsString);
item.AddPair('Officer1Empnum', ApiDB.uqMapUnitsOFFICER1_EMPNUM.AsString);
item.AddPair('Officer2Lname', ApiDB.uqMapUnitsOFFICER2_LNAME.AsString);
item.AddPair('Officer2Fname', ApiDB.uqMapUnitsOFFICER2_FNAME.AsString);
item.AddPair('Officer2Empnum', ApiDB.uqMapUnitsOFFICER2_EMPNUM.AsString);
item.AddPair('CanShowDetails', TJSONBool.Create(not ApiDB.uqMapUnitsDIS_UNITID.IsNull));
lastStatusChangeText := '';
if not uqMapUnitsLASTSTATUSCHANGE.IsNull then
begin
lastStatusChangeText := FormatDateTime(
'yyyy-mm-dd hh:nn:ss',
uqMapUnitsLASTSTATUSCHANGE.AsDateTime
);
end;
item.AddPair('LastStatusChange', lastStatusChangeText);
item.AddPair(
'CanShowDetails',
TJSONBool.Create(not uqMapUnitsDIS_UNITID.IsNull)
);
end;
Next;
......@@ -339,185 +772,202 @@ begin
except
on E: EXDataHttpException do
begin
Logger.Log(2, '---TWCAPIData.GetUnitMap http error: ' + E.ClassName + ': ' + E.Message);
Logger.Log(2, '---TBFDAPIDataModule.GetUnitMap http error: ' + E.ClassName + ': ' + E.Message);
raise;
end;
on E: Exception do
begin
Logger.Log(2, '---TWCAPIData.GetUnitMap error: ' + E.ClassName + ': ' + E.Message);
Logger.Log(2, '---TBFDAPIDataModule.GetUnitMap error: ' + E.ClassName + ': ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load unit map');
end;
end;
Logger.Log(4, '---TWCAPIData.GetUnitMap End');
Logger.Log(4, '---TBFDAPIDataModule.GetUnitMap End');
except
Result.Free;
raise;
end;
end;
function TWCAPIData.GetComplaintList: TJSONObject;
function TBFDAPIDataModule.GetComplaintList: TJSONObject;
var
data: TJSONArray;
lastDistrict: string;
item: TJSONObject;
status: string;
statusCode: string;
statusColor: string;
holdUnit: string;
complaintNumber: string;
colorVal: Integer;
begin
Logger.Log(3, '---TWCAPIData.GetComplaintList initiated');
Logger.Log(3, '---TBFDAPIDataModule.GetComplaintList initiated');
Result := TJSONObject.Create;
try
data := TJSONArray.Create;
Result.AddPair('data', data);
try
lastDistrict := '';
try
with ApiDB.uqComplaintList do
begin
Close;
Open;
with uqComplaintList do
begin
Open;
try
(FieldByName('DATEREPORTED') as TDateTimeField).DisplayFormat := 'yyyy-mm-dd hh:nn:ss';
First;
while not Eof do
begin
var status: string;
var statusColor: string;
var statusTextColor: string;
statusCode := Trim(uqComplaintListSTATUS.AsString);
holdUnit := Trim(uqComplaintListHOLDUNITNAME.AsString);
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
status := ComplaintDisplayStatus(
statusCode,
uqComplaintListSTATUS_DESC.AsString,
holdUnit
);
statusColor := '#FFFFFF';
if not uqComplaintListSTATUS_COLOR.IsNull then
begin
status := 'Pending';
statusColor := '#FF8080';
statusTextColor := '#000000';
statusColor := DelphiColorToHtml(
uqComplaintListSTATUS_COLOR.AsInteger
);
end;
var item := TJSONObject.Create;
item := TJSONObject.Create;
data.AddElement(item);
var curAgency := Trim(ApiDB.uqComplaintListAGENCY.AsString);
if curAgency = '' then
curAgency := 'Unknown Agency';
colorVal := 0;
if not uqComplaintListPRIORITY_COLOR.IsNull then
colorVal := uqComplaintListPRIORITY_COLOR.AsInteger;
if not SameText(curAgency, lastDistrict) then
item.AddPair('DistrictHeader', curAgency);
lastDistrict := curAgency;
item.AddPair('PriorityColor', DelphiColorToHtml(colorVal));
item.AddPair('PriorityTextColor', '#000000');
item.AddPair('AgencyLine', 'Agency: ' + curAgency);
complaintNumber := uqComplaintListcomplaintNumber.AsString;
var colorVal := ApiDB.uqComplaintListPRIORITY_COLOR.AsInteger;
item.AddPair('PriorityColor', '#' + IntToHex(colorVal and $FFFFFF, 6));
item.AddPair('PriorityTextColor', '#000000');
item.AddPair('ComplaintId', ApiDB.uqComplaintListCOMPLAINTID.AsString);
item.AddPair('Complaint', ApiDB.uqComplaintListcomplaintNumber.AsString);
item.AddPair('Agency', ApiDB.uqComplaintListAGENCY.AsString);
item.AddPair('Priority', ApiDB.uqComplaintListPRIORITY.AsString);
item.AddPair('DispatchCodeDesc', ApiDB.uqComplaintListDISPATCH_CODE_DESC.AsString);
item.AddPair('pngName', ApiDB.uqComplaintListpngName.AsString);
item.AddPair('Address', ApiDB.uqComplaintListADDRESS.AsString);
item.AddPair('Business', ApiDB.uqComplaintListBUSINESS.AsString);
item.AddPair('CFSId', ApiDB.uqComplaintListCFSID.AsString);
item.AddPair('ComplaintId', uqComplaintListCOMPLAINTID.AsString);
item.AddPair('Complaint', complaintNumber);
item.AddPair('Agency', uqComplaintListAGENCY.AsString);
item.AddPair('Priority', uqComplaintListPRIORITY.AsString);
item.AddPair('DispatchCodeDesc', uqComplaintListDISPATCH_CODE_DESC.AsString);
item.AddPair('Address', uqComplaintListADDRESS.AsString);
item.AddPair('Business', uqComplaintListBUSINESS.AsString);
item.AddPair('CFSId', uqComplaintListCFSID.AsString);
item.AddPair('StatusCode', statusCode);
item.AddPair('Status', status);
item.AddPair('StatusColor', statusColor);
item.AddPair('StatusTextColor', statusTextColor);
item.AddPair('DispatchDistrict', ApiDB.uqComplaintListDISPATCHDISTRICT.AsString);
item.AddPair('DateReported', ApiDB.uqComplaintListDATEREPORTED.AsString);
item.AddPair('StatusTextColor', '#000000');
item.AddPair('HoldUnitName', holdUnit);
item.AddPair('FireResponder', uqComplaintListFIRERESPONDER.AsString);
item.AddPair('EMSResponder', uqComplaintListEMSRESPONDER.AsString);
item.AddPair('AlarmLevel', uqComplaintListALARMLEVEL.AsString);
item.AddPair('ResponseZone', uqComplaintListRESPONSE_ZONE.AsString);
item.AddPair('EMSResponseType', uqComplaintListEMS_RESPONSE_TYPE.AsString);
item.AddPair('Warnings', uqComplaintListWARNINGS.AsString);
item.AddPair('Contacts', uqComplaintListCONTACTS.AsString);
item.AddPair('History', uqComplaintListHISTORY.AsString);
item.AddPair('DispatchDistrict', uqComplaintListDISPATCHDISTRICT.AsString);
item.AddPair('DateReported', uqComplaintListDATEREPORTED.AsString);
Next;
end;
finally
Close;
end;
finally
ApiDB.uqComplaintList.Close;
end;
Result.AddPair('count', TJSONNumber.Create(data.Count));
Result.AddPair('returned', TJSONNumber.Create(data.Count));
except
Logger.Log(2, '---TWCAPIData.GetComplaintList End (error)');
Logger.Log(2, '---TBFDAPIDataModule.GetComplaintList End (error)');
raise EXDataHttpException.Create(500, 'Failed to load complaints list');
end;
Logger.Log(3, '---TWCAPIData.GetComplaintList End');
Logger.Log(3, '---TBFDAPIDataModule.GetComplaintList End');
except
Result.Free;
raise;
end;
end;
function TWCAPIData.GetUnitList: TJSONObject;
function TBFDAPIDataModule.GetUnitList: TJSONObject;
var
data: TJSONArray;
lastAgency: string;
item: TJSONObject;
lastStation: string;
curStation: string;
statusDesc: string;
complaintNumber: string;
lastStatusChangeText: string;
mapLat: Double;
mapLng: Double;
canShowMap: Boolean;
begin
Logger.Log(3, '---TWCAPIData.GetUnitList initiated');
Logger.Log(3, '---TBFDAPIDataModule.GetUnitList initiated');
Result := TJSONObject.Create;
try
data := TJSONArray.Create;
Result.AddPair('data', data);
try
lastAgency := '';
lastStation := '';
try
with ApiDB.uqUnitList do
begin
Close;
Open;
with uqUnitList do
begin
Open;
try
First;
while not Eof do
begin
var item := TJSONObject.Create;
item := TJSONObject.Create;
data.AddElement(item);
// Section: Group header shown once when the agency changes.
var curAgency := Trim(ApiDB.uqUnitListAGENCY_NAME.AsString);
if curAgency = '' then
curAgency := Trim(ApiDB.uqUnitListAGENCY.AsString);
if curAgency = '' then
curAgency := 'Unknown Agency';
curStation := Trim(uqUnitListCURRENT_STATION.AsString);
if curStation = '' then
curStation := 'No Station';
if not SameText(curAgency, lastAgency) then
if not SameText(curStation, lastStation) then
begin
item.AddPair('AgencyHeader', curAgency);
lastAgency := curAgency;
item.AddPair('StationHeader', curStation);
lastStation := curStation;
end
else
item.AddPair('AgencyHeader', '');
// Section: Core unit identity.
item.AddPair('UnitId', ApiDB.uqUnitListUNITID.AsString);
item.AddPair('UnitName', ApiDB.uqUnitListUNITNAME.AsString);
item.AddPair('Agency', ApiDB.uqUnitListAGENCY.AsString);
item.AddPair('AgencyName', ApiDB.uqUnitListAGENCY_NAME.AsString);
item.AddPair('AgencyType', ApiDB.uqUnitListAGENCYTYPE.AsString);
item.AddPair('CarNumberDesc', ApiDB.uqUnitListCARNUMBER_DESC.AsString);
item.AddPair('District', ApiDB.uqUnitListDISTRICT_DESC.AsString);
item.AddPair('Sector', ApiDB.uqUnitListSECTOR_DESC.AsString);
item.AddPair('CallType', ApiDB.uqUnitListCALL_TYPE.AsString);
// Section: Map button availability.
var canShowMap := False;
if (not ApiDB.uqUnitListGPS_LATITUDE.IsNull) and
(not ApiDB.uqUnitListGPS_LONGITUDE.IsNull) then
item.AddPair('StationHeader', '');
item.AddPair('UnitId', uqUnitListUNITID.AsString);
item.AddPair('UnitName', uqUnitListUNITNAME.AsString);
item.AddPair('Agency', uqUnitListAGENCY.AsString);
item.AddPair('AgencyName', uqUnitListAGENCY_NAME.AsString);
item.AddPair('AgencyType', uqUnitListAGENCYTYPE.AsString);
item.AddPair('CurrentStation', uqUnitListCURRENT_STATION.AsString);
item.AddPair('MainStation', uqUnitListMAIN_STATION.AsString);
item.AddPair('MovingToStation', uqUnitListMOVING_TO_STATION.AsString);
item.AddPair('CarNumberDesc', uqUnitListCARNUMBER_DESC.AsString);
item.AddPair('UnitDesc', uqUnitListUNIT_DESC.AsString);
item.AddPair('UnitType', uqUnitListUNIT_TYPE.AsString);
item.AddPair('Manpower', uqUnitListMANPOWER.AsString);
item.AddPair(
'Undermanned',
TJSONBool.Create(uqUnitListMANPOWER.AsInteger = 1)
);
item.AddPair('Dispatchable', uqUnitListDISPATCHABLE.AsString);
item.AddPair('CallType', uqUnitListCALL_TYPE.AsString);
canShowMap := False;
if (not uqUnitListGPS_LATITUDE.IsNull) and
(not uqUnitListGPS_LONGITUDE.IsNull) then
begin
var mapLat := ApiDB.uqUnitListGPS_LATITUDE.AsFloat;
var mapLng := ApiDB.uqUnitListGPS_LONGITUDE.AsFloat;
mapLat := uqUnitListGPS_LATITUDE.AsFloat;
mapLng := uqUnitListGPS_LONGITUDE.AsFloat;
canShowMap :=
((mapLat <> 0) or (mapLng <> 0)) and
......@@ -526,183 +976,203 @@ begin
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"'
)
IfThen(canShowMap, '', 'disabled="disabled" aria-disabled="true"')
);
item.AddPair(
'MapButtonTitle',
IfThen(
canShowMap,
'Show on map',
'No map location available'
)
IfThen(canShowMap, 'Show on map', 'No map location available')
);
// Section: Current complaint assignment.
var complaintNumber :=
Trim(ApiDB.uqUnitListCOMPLAINT.AsString);
complaintNumber := Trim(uqUnitListCOMPLAINT.AsString);
item.AddPair(
'Location',
ApiDB.uqUnitListLOCATION.AsString
);
item.AddPair('Location', uqUnitListLOCATION.AsString);
item.AddPair('Complaint', complaintNumber);
if complaintNumber <> '' then
item.AddPair(
'ComplaintHeader',
' - ' + complaintNumber
)
else
item.AddPair('ComplaintHeader', '');
// Section: Default to Available when there is no active CFS row.
var statusDesc :=
ApiDB.uqUnitListUNIT_STATUS_DESC.AsString;
item.AddPair(
'ComplaintHeader',
IfThen(complaintNumber <> '', ' - ' + complaintNumber, '')
);
statusDesc := Trim(uqUnitListUNIT_STATUS_DESC.AsString);
if statusDesc = '' then
statusDesc := 'Available';
item.AddPair('Status', statusDesc);
item.AddPair('UnitStatus', uqUnitListUNITSTATUS.AsString);
item.AddPair('UnavailableReason', uqUnitListUNAVAILABLE_REASON.AsString);
// Section: Primary officer.
var o1 :=
Trim(ApiDB.uqUnitListOFFICER1_LAST_NAME.AsString);
var f1 :=
Trim(ApiDB.uqUnitListOFFICER1_FIRST_NAME.AsString);
var m1 :=
Trim(ApiDB.uqUnitListOFFICER1_MI.AsString);
if o1 <> '' then
lastStatusChangeText := '';
if not uqUnitListLASTSTATUSCHANGE.IsNull then
begin
if f1 <> '' then
o1 := o1 + ', ' + f1;
if m1 <> '' then
o1 := o1 + ' ' + m1;
item.AddPair('Officer1', o1);
lastStatusChangeText := FormatDateTime(
'yyyy-mm-dd hh:nn:ss',
uqUnitListLASTSTATUSCHANGE.AsDateTime
);
end;
// Section: Secondary officer.
var o2 :=
Trim(ApiDB.uqUnitListOFFICER2_LAST_NAME.AsString);
var f2 :=
Trim(ApiDB.uqUnitListOFFICER2_FIRST_NAME.AsString);
var m2 :=
Trim(ApiDB.uqUnitListOFFICER2_MI.AsString);
if o2 <> '' then
begin
if f2 <> '' then
o2 := o2 + ', ' + f2;
if m2 <> '' then
o2 := o2 + ' ' + m2;
item.AddPair('Officer2', o2);
end;
item.AddPair('LastStatusChange', lastStatusChangeText);
Next;
end;
finally
Close;
end;
finally
ApiDB.uqUnitList.Close;
end;
Result.AddPair(
'count',
TJSONNumber.Create(data.Count)
);
Result.AddPair(
'returned',
TJSONNumber.Create(data.Count)
);
Result.AddPair('count', TJSONNumber.Create(data.Count));
Result.AddPair('returned', TJSONNumber.Create(data.Count));
except
Logger.Log(
3,
'---TWCAPIData.GetUnitList End (error)'
);
raise EXDataHttpException.Create(
500,
'Failed to load units list'
);
Logger.Log(3, '---TBFDAPIDataModule.GetUnitList End (error)');
raise EXDataHttpException.Create(500, 'Failed to load units list');
end;
Logger.Log(3, '---TWCAPIData.GetUnitList End');
Logger.Log(3, '---TBFDAPIDataModule.GetUnitList End');
except
Result.Free;
raise;
end;
end;
function TWCAPIData.GetComplaintDetails(ComplaintId: string): TJSONObject;
function TBFDAPIDataModule.GetComplaintDetails(ComplaintId: string): TJSONObject;
var
obj: TJSONObject;
status: string;
statusColor: string;
begin
Logger.Log(3,'---TWCAPIData.GetComplaintDetails initiated: '+ComplaintId);
Logger.Log(3, '---TBFDAPIDataModule.GetComplaintDetails initiated: ' + ComplaintId);
Result := TJSONObject.Create;
try
try
with ApiDB.uqComplaintDetails do
with uqComplaintDetails do
begin
Close;
ParamByName('COMPLAINTID').AsString := ComplaintId;
Open;
try
if Eof then raise EXDataHttpException.Create(404,'Complaint not found');
if Eof then
raise EXDataHttpException.Create(404, 'Complaint not found');
if not Locate('STATUS', 0, []) then
raise EXDataHttpException.Create(404, 'Complaint not found');
status := ComplaintDisplayStatus(
uqComplaintDetailsCOMPLAINT_STATUS.AsString,
uqComplaintDetailsCOMPLAINT_STATUS_DESC.AsString,
uqComplaintDetailsHOLDUNITNAME.AsString
);
statusColor := '#FFFFFF';
if not uqComplaintDetailsCOMPLAINT_STATUS_COLOR.IsNull then
begin
statusColor := DelphiColorToHtml(
uqComplaintDetailsCOMPLAINT_STATUS_COLOR.AsInteger
);
end;
obj := TJSONObject.Create;
Result.AddPair('data', obj);
obj.AddPair('ComplaintId', ApiDB.uqComplaintDetailsCOMPLAINTID.AsString);
obj.AddPair('CFSId', ApiDB.uqComplaintDetailsCFSID.AsString);
obj.AddPair('Complaint', ApiDB.uqComplaintDetailsCOMPLAINT.AsString);
obj.AddPair('Priority', ApiDB.uqComplaintDetailsPRIORITY.AsString);
obj.AddPair('DispatchCode', ApiDB.uqComplaintDetailsDISPATCHCODE.AsString);
obj.AddPair('DispatchCodeDesc', ApiDB.uqComplaintDetailsDISPATCH_CODE_DESC.AsString);
obj.AddPair('DispatchDistrict', ApiDB.uqComplaintDetailsDISPATCHDISTRICT.AsString);
obj.AddPair('Address', ApiDB.uqComplaintDetailsADDRESS.AsString);
obj.AddPair('Business',ApiDB.uqComplaintDetailsBUSINESS.AsString);
obj.AddPair('History', ApiDB.uqComplaintDetailsHISTORY.AsString);
obj.AddPair('Contacts', ApiDB.uqComplaintDetailsCONTACTS.AsString);
obj.AddPair('Warnings', ApiDB.uqComplaintDetailsWARNINGS.AsString);
if ApiDB.uqComplaintDetailsDATEREPORTED.IsNull then
obj.AddPair('ComplaintId', uqComplaintDetailsCOMPLAINTID.AsString);
obj.AddPair('CFSId', uqComplaintDetailsCFSID.AsString);
obj.AddPair('Complaint', uqComplaintDetailsCOMPLAINT.AsString);
obj.AddPair('Priority', uqComplaintDetailsPRIORITY.AsString);
obj.AddPair('DispatchCode', uqComplaintDetailsDISPATCHCODE.AsString);
obj.AddPair('DispatchCodeDesc', uqComplaintDetailsDISPATCH_CODE_DESC.AsString);
obj.AddPair('DispatchDistrict', uqComplaintDetailsDISPATCHDISTRICT.AsString);
obj.AddPair('Address', uqComplaintDetailsADDRESS.AsString);
obj.AddPair('Business', uqComplaintDetailsBUSINESS.AsString);
obj.AddPair('Status', status);
obj.AddPair('StatusCode', uqComplaintDetailsCOMPLAINT_STATUS.AsString);
obj.AddPair('StatusDesc', uqComplaintDetailsCOMPLAINT_STATUS_DESC.AsString);
obj.AddPair('StatusColor', statusColor);
obj.AddPair('HoldUnitName', uqComplaintDetailsHOLDUNITNAME.AsString);
obj.AddPair('FireResponder', uqComplaintDetailsFIRERESPONDER.AsString);
obj.AddPair('EMSResponder', uqComplaintDetailsEMSRESPONDER.AsString);
obj.AddPair('AlarmLevel', uqComplaintDetailsALARMLEVEL.AsString);
obj.AddPair('ResponseZone', uqComplaintDetailsRESPONSE_ZONE.AsString);
obj.AddPair('EMSResponseType', uqComplaintDetailsEMS_RESPONSE_TYPE.AsString);
obj.AddPair('History', uqComplaintDetailsHISTORY.AsString);
obj.AddPair('Contacts', uqComplaintDetailsCONTACTS.AsString);
obj.AddPair('Warnings', uqComplaintDetailsWARNINGS.AsString);
if uqComplaintDetailsDATEREPORTED.IsNull then
obj.AddPair('DateReported', '')
else
obj.AddPair('DateReported', FormatDateTime('yyyy-mm-dd hh:nn:ss', ApiDB.uqComplaintDetailsDATEREPORTED.AsDateTime));
obj.AddPair(
'DateReported',
FormatDateTime(
'yyyy-mm-dd hh:nn:ss',
uqComplaintDetailsDATEREPORTED.AsDateTime
)
);
if ApiDB.uqComplaintDetailsDATERECEIVED.IsNull then
if uqComplaintDetailsDATERECEIVED.IsNull then
obj.AddPair('DateReceived', '')
else
obj.AddPair('DateReceived', FormatDateTime('yyyy-mm-dd hh:nn:ss', ApiDB.uqComplaintDetailsDATERECEIVED.AsDateTime));
obj.AddPair(
'DateReceived',
FormatDateTime(
'yyyy-mm-dd hh:nn:ss',
uqComplaintDetailsDATERECEIVED.AsDateTime
)
);
if ApiDB.uqComplaintDetailsDATEDISPATCHED.IsNull then
if uqComplaintDetailsDATEDISPATCHED.IsNull then
obj.AddPair('DateDispatched', '')
else
obj.AddPair('DateDispatched', FormatDateTime('yyyy-mm-dd hh:nn:ss', ApiDB.uqComplaintDetailsDATEDISPATCHED.AsDateTime));
obj.AddPair(
'DateDispatched',
FormatDateTime(
'yyyy-mm-dd hh:nn:ss',
uqComplaintDetailsDATEDISPATCHED.AsDateTime
)
);
if ApiDB.uqComplaintDetailsDATERESPONDED.IsNull then
if uqComplaintDetailsDATERESPONDED.IsNull then
obj.AddPair('DateResponded', '')
else
obj.AddPair('DateResponded', FormatDateTime('yyyy-mm-dd hh:nn:ss', ApiDB.uqComplaintDetailsDATERESPONDED.AsDateTime));
obj.AddPair(
'DateResponded',
FormatDateTime(
'yyyy-mm-dd hh:nn:ss',
uqComplaintDetailsDATERESPONDED.AsDateTime
)
);
if ApiDB.uqComplaintDetailsDATEARRIVED.IsNull then
if uqComplaintDetailsDATEARRIVED.IsNull then
obj.AddPair('DateArrived', '')
else
obj.AddPair('DateArrived', FormatDateTime('yyyy-mm-dd hh:nn:ss', ApiDB.uqComplaintDetailsDATEARRIVED.AsDateTime));
obj.AddPair(
'DateArrived',
FormatDateTime(
'yyyy-mm-dd hh:nn:ss',
uqComplaintDetailsDATEARRIVED.AsDateTime
)
);
if ApiDB.uqComplaintDetailsDATECLEARED.IsNull then
if uqComplaintDetailsDATECLEARED.IsNull then
obj.AddPair('DateCleared', '')
else
obj.AddPair('DateCleared', FormatDateTime('yyyy-mm-dd hh:nn:ss', ApiDB.uqComplaintDetailsDATECLEARED.AsDateTime));
obj.AddPair(
'DateCleared',
FormatDateTime(
'yyyy-mm-dd hh:nn:ss',
uqComplaintDetailsDATECLEARED.AsDateTime
)
);
finally
Close;
......@@ -711,85 +1181,154 @@ begin
except
on E: EXDataHttpException do
begin
Logger.Log(3,'---TWCAPIData.GetComplaintDetails not found');
Logger.Log(3, '---TBFDAPIDataModule.GetComplaintDetails not found');
raise;
end;
on E: Exception do
begin
Logger.Log(3,'---TWCAPIData.GetComplaintDetails error: '+E.Message);
raise EXDataHttpException.Create(500,'Failed to load complaint details');
Logger.Log(3, '---TBFDAPIDataModule.GetComplaintDetails error: ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load complaint details');
end;
end;
Logger.Log(3,'---TWCAPIData.GetComplaintDetails End');
Logger.Log(3, '---TBFDAPIDataModule.GetComplaintDetails End');
except
Result.Free;
raise;
end;
end;
function TWCAPIData.GetComplaintArchiveDetails(ComplaintId: string): TJSONObject;
function TBFDAPIDataModule.GetComplaintArchiveDetails(ComplaintId: string): TJSONObject;
var
obj: TJSONObject;
status: string;
statusColor: string;
begin
Logger.Log(3,'---TWCAPIData.GetComplaintArchiveDetails initiated: '+ComplaintId);
Logger.Log(3, '---TBFDAPIDataModule.GetComplaintArchiveDetails initiated: ' + ComplaintId);
Result := TJSONObject.Create;
try
try
with ApiDB.uqComplaintDetails do
with uqComplaintDetails do
begin
Close;
ParamByName('COMPLAINTID').AsString := ComplaintId;
Open;
try
if Eof then raise EXDataHttpException.Create(404,'Complaint not found');
if Eof then
raise EXDataHttpException.Create(404, 'Complaint not found');
if not Locate('STATUS', 1, []) then
raise EXDataHttpException.Create(404,'Complaint archive not found');
raise EXDataHttpException.Create(404, 'Complaint archive not found');
status := ComplaintDisplayStatus(
uqComplaintDetailsCOMPLAINT_STATUS.AsString,
uqComplaintDetailsCOMPLAINT_STATUS_DESC.AsString,
uqComplaintDetailsHOLDUNITNAME.AsString
);
statusColor := '#FFFFFF';
if not uqComplaintDetailsCOMPLAINT_STATUS_COLOR.IsNull then
begin
statusColor := DelphiColorToHtml(
uqComplaintDetailsCOMPLAINT_STATUS_COLOR.AsInteger
);
end;
obj := TJSONObject.Create;
Result.AddPair('data', obj);
obj.AddPair('ComplaintId', ApiDB.uqComplaintDetailsCOMPLAINTID.AsString);
obj.AddPair('CFSId', ApiDB.uqComplaintDetailsCFSID.AsString);
obj.AddPair('Complaint', ApiDB.uqComplaintDetailsCOMPLAINT.AsString);
obj.AddPair('Priority', ApiDB.uqComplaintDetailsPRIORITY.AsString);
obj.AddPair('DispatchCode', ApiDB.uqComplaintDetailsDISPATCHCODE.AsString);
obj.AddPair('DispatchCodeDesc', ApiDB.uqComplaintDetailsDISPATCH_CODE_DESC.AsString);
obj.AddPair('DispatchDistrict', ApiDB.uqComplaintDetailsDISPATCHDISTRICT.AsString);
obj.AddPair('Address', ApiDB.uqComplaintDetailsADDRESS.AsString);
obj.AddPair('Business', ApiDB.uqComplaintDetailsBUSINESS.AsString);
obj.AddPair('History', ApiDB.uqComplaintDetailsHISTORY.AsString);
obj.AddPair('Contacts', ApiDB.uqComplaintDetailsCONTACTS.AsString);
obj.AddPair('Warnings', ApiDB.uqComplaintDetailsWARNINGS.AsString);
if ApiDB.uqComplaintDetailsDATEREPORTED.IsNull then
obj.AddPair('ComplaintId', uqComplaintDetailsCOMPLAINTID.AsString);
obj.AddPair('CFSId', uqComplaintDetailsCFSID.AsString);
obj.AddPair('Complaint', uqComplaintDetailsCOMPLAINT.AsString);
obj.AddPair('Priority', uqComplaintDetailsPRIORITY.AsString);
obj.AddPair('DispatchCode', uqComplaintDetailsDISPATCHCODE.AsString);
obj.AddPair('DispatchCodeDesc', uqComplaintDetailsDISPATCH_CODE_DESC.AsString);
obj.AddPair('DispatchDistrict', uqComplaintDetailsDISPATCHDISTRICT.AsString);
obj.AddPair('Address', uqComplaintDetailsADDRESS.AsString);
obj.AddPair('Business', uqComplaintDetailsBUSINESS.AsString);
obj.AddPair('Status', status);
obj.AddPair('StatusCode', uqComplaintDetailsCOMPLAINT_STATUS.AsString);
obj.AddPair('StatusDesc', uqComplaintDetailsCOMPLAINT_STATUS_DESC.AsString);
obj.AddPair('StatusColor', statusColor);
obj.AddPair('HoldUnitName', uqComplaintDetailsHOLDUNITNAME.AsString);
obj.AddPair('FireResponder', uqComplaintDetailsFIRERESPONDER.AsString);
obj.AddPair('EMSResponder', uqComplaintDetailsEMSRESPONDER.AsString);
obj.AddPair('AlarmLevel', uqComplaintDetailsALARMLEVEL.AsString);
obj.AddPair('ResponseZone', uqComplaintDetailsRESPONSE_ZONE.AsString);
obj.AddPair('EMSResponseType', uqComplaintDetailsEMS_RESPONSE_TYPE.AsString);
obj.AddPair('History', uqComplaintDetailsHISTORY.AsString);
obj.AddPair('Contacts', uqComplaintDetailsCONTACTS.AsString);
obj.AddPair('Warnings', uqComplaintDetailsWARNINGS.AsString);
if uqComplaintDetailsDATEREPORTED.IsNull then
obj.AddPair('DateReported', '')
else
obj.AddPair('DateReported', FormatDateTime('yyyy-mm-dd hh:nn:ss', ApiDB.uqComplaintDetailsDATEREPORTED.AsDateTime));
obj.AddPair(
'DateReported',
FormatDateTime(
'yyyy-mm-dd hh:nn:ss',
uqComplaintDetailsDATEREPORTED.AsDateTime
)
);
if ApiDB.uqComplaintDetailsDATERECEIVED.IsNull then
if uqComplaintDetailsDATERECEIVED.IsNull then
obj.AddPair('DateReceived', '')
else
obj.AddPair('DateReceived', FormatDateTime('yyyy-mm-dd hh:nn:ss', ApiDB.uqComplaintDetailsDATERECEIVED.AsDateTime));
obj.AddPair(
'DateReceived',
FormatDateTime(
'yyyy-mm-dd hh:nn:ss',
uqComplaintDetailsDATERECEIVED.AsDateTime
)
);
if ApiDB.uqComplaintDetailsDATEDISPATCHED.IsNull then
if uqComplaintDetailsDATEDISPATCHED.IsNull then
obj.AddPair('DateDispatched', '')
else
obj.AddPair('DateDispatched', FormatDateTime('yyyy-mm-dd hh:nn:ss', ApiDB.uqComplaintDetailsDATEDISPATCHED.AsDateTime));
obj.AddPair(
'DateDispatched',
FormatDateTime(
'yyyy-mm-dd hh:nn:ss',
uqComplaintDetailsDATEDISPATCHED.AsDateTime
)
);
if ApiDB.uqComplaintDetailsDATERESPONDED.IsNull then
if uqComplaintDetailsDATERESPONDED.IsNull then
obj.AddPair('DateResponded', '')
else
obj.AddPair('DateResponded', FormatDateTime('yyyy-mm-dd hh:nn:ss', ApiDB.uqComplaintDetailsDATERESPONDED.AsDateTime));
obj.AddPair(
'DateResponded',
FormatDateTime(
'yyyy-mm-dd hh:nn:ss',
uqComplaintDetailsDATERESPONDED.AsDateTime
)
);
if ApiDB.uqComplaintDetailsDATEARRIVED.IsNull then
if uqComplaintDetailsDATEARRIVED.IsNull then
obj.AddPair('DateArrived', '')
else
obj.AddPair('DateArrived', FormatDateTime('yyyy-mm-dd hh:nn:ss', ApiDB.uqComplaintDetailsDATEARRIVED.AsDateTime));
obj.AddPair(
'DateArrived',
FormatDateTime(
'yyyy-mm-dd hh:nn:ss',
uqComplaintDetailsDATEARRIVED.AsDateTime
)
);
if ApiDB.uqComplaintDetailsDATECLEARED.IsNull then
if uqComplaintDetailsDATECLEARED.IsNull then
obj.AddPair('DateCleared', '')
else
obj.AddPair('DateCleared', FormatDateTime('yyyy-mm-dd hh:nn:ss', ApiDB.uqComplaintDetailsDATECLEARED.AsDateTime));
obj.AddPair(
'DateCleared',
FormatDateTime(
'yyyy-mm-dd hh:nn:ss',
uqComplaintDetailsDATECLEARED.AsDateTime
)
);
finally
Close;
......@@ -798,29 +1337,30 @@ begin
except
on E: EXDataHttpException do
begin
Logger.Log(3,'---TWCAPIData.GetComplaintArchiveDetails not found');
Logger.Log(3, '---TBFDAPIDataModule.GetComplaintArchiveDetails not found');
raise;
end;
on E: Exception do
begin
Logger.Log(3,'---TWCAPIData.GetComplaintArchiveDetails error: '+E.Message);
raise EXDataHttpException.Create(500,'Failed to load complaint archive details');
Logger.Log(3, '---TBFDAPIDataModule.GetComplaintArchiveDetails error: ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load complaint archive details');
end;
end;
Logger.Log(3,'---TWCAPIData.GetComplaintArchiveDetails End');
Logger.Log(3, '---TBFDAPIDataModule.GetComplaintArchiveDetails End');
except
Result.Free;
raise;
end;
end;
function TWCAPIData.GetComplaintMemos(CfsId: string): TJSONObject;
function TBFDAPIDataModule.GetComplaintMemos(CfsId: string): TJSONObject;
var
data: TJSONArray;
item: TJSONObject;
ts: string;
begin
Logger.Log(3, '---TWCAPIData.GetComplaintMemos initiated: ' + CfsId);
Logger.Log(3, '---TBFDAPIDataModule.GetComplaintMemos initiated: ' + CfsId);
Result := TJSONObject.Create;
try
......@@ -828,7 +1368,7 @@ begin
Result.AddPair('data', data);
try
with ApiDB.uqCFSMemos do
with uqCFSMemos do
begin
ParamByName('CFSID').AsString := CfsId;
Open;
......@@ -839,18 +1379,21 @@ begin
item := TJSONObject.Create;
data.AddElement(item);
item.AddPair('MemoId', ApiDB.uqCFSMemosMEMO_ID.AsString);
item.AddPair('CFSId', ApiDB.uqCFSMemosCFSID.AsString);
item.AddPair('MemoType', ApiDB.uqCFSMemosMEMO_TYPE.AsString);
item.AddPair('MemoId', uqCFSMemosMEMO_ID.AsString);
item.AddPair('CFSId', uqCFSMemosCFSID.AsString);
item.AddPair('MemoType', uqCFSMemosMEMO_TYPE.AsString);
if ApiDB.uqCFSMemosTIMESTAMP.IsNull then
if uqCFSMemosTIMESTAMP.IsNull then
ts := ''
else
ts := FormatDateTime('yyyy-mm-dd' + ' ' + 'hh:nn:ss', ApiDB.uqCFSMemosTIMESTAMP.AsDateTime);
item.AddPair('Timestamp', ts);
ts := FormatDateTime(
'yyyy-mm-dd hh:nn:ss',
uqCFSMemosTIMESTAMP.AsDateTime
);
item.AddPair('BadgeNumber', ApiDB.uqCFSMemosBADGE_NUMBER.AsString);
item.AddPair('Remarks', ApiDB.uqCFSMemosREMARKS.AsString);
item.AddPair('Timestamp', ts);
item.AddPair('BadgeNumber', uqCFSMemosBADGE_NUMBER.AsString);
item.AddPair('Remarks', uqCFSMemosREMARKS.AsString);
Next;
end;
......@@ -864,29 +1407,30 @@ begin
except
on E: EXDataHttpException do
begin
Logger.Log(2, '---TWCAPIData.GetComplaintMemos http error: ' + E.ClassName + ': ' + E.Message);
Logger.Log(2, '---TBFDAPIDataModule.GetComplaintMemos http error: ' + E.ClassName + ': ' + E.Message);
raise;
end;
on E: Exception do
begin
Logger.Log(2, '---TWCAPIData.GetComplaintMemos error: ' + E.ClassName + ': ' + E.Message);
Logger.Log(2, '---TBFDAPIDataModule.GetComplaintMemos error: ' + E.ClassName + ': ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load complaint memos');
end;
end;
Logger.Log(3, '---TWCAPIData.GetComplaintMemos End');
Logger.Log(3, '---TBFDAPIDataModule.GetComplaintMemos End');
except
Result.Free;
raise;
end;
end;
function TWCAPIData.GetComplaintHistory(ComplaintId: string): TJSONObject;
function TBFDAPIDataModule.GetComplaintHistory(ComplaintId: string): TJSONObject;
var
dataArr: TJSONArray;
rowObj: TJSONObject;
returnedCount: Integer;
begin
Logger.Log(4, '---TWCAPIData.GetComplaintHistory initiated: ' + ComplaintId);
Logger.Log(4, '---TBFDAPIDataModule.GetComplaintHistory initiated: ' + ComplaintId);
Result := TJSONObject.Create;
try
......@@ -896,7 +1440,7 @@ begin
returnedCount := 0;
try
with ApiDB.uqComplaintHistory do
with uqComplaintHistory do
begin
ParamByName('COMPLAINTID').AsString := ComplaintId;
Open;
......@@ -909,17 +1453,23 @@ begin
rowObj := TJSONObject.Create;
dataArr.AddElement(rowObj);
rowObj.AddPair('ComplaintId', ApiDB.uqComplaintHistoryCOMPLAINTID.AsString);
rowObj.AddPair('Complaint', ApiDB.uqComplaintHistoryCOMPLAINT.AsString);
rowObj.AddPair('Apartment', ApiDB.uqComplaintHistoryAPARTMENT.AsString);
rowObj.AddPair('ComplaintId', uqComplaintHistoryCOMPLAINTID.AsString);
rowObj.AddPair('Complaint', uqComplaintHistoryCOMPLAINT.AsString);
rowObj.AddPair('Apartment', uqComplaintHistoryAPARTMENT.AsString);
if ApiDB.uqComplaintHistoryDATEREPORTED.IsNull then
if uqComplaintHistoryDATEREPORTED.IsNull then
rowObj.AddPair('DateReported', '')
else
rowObj.AddPair('DateReported', FormatDateTime('yyyy-mm-dd', ApiDB.uqComplaintHistoryDATEREPORTED.AsDateTime));
rowObj.AddPair(
'DateReported',
FormatDateTime(
'yyyy-mm-dd',
uqComplaintHistoryDATEREPORTED.AsDateTime
)
);
rowObj.AddPair('DPriority', ApiDB.uqComplaintHistoryDPRIORITY.AsString);
rowObj.AddPair('DCallType', ApiDB.uqComplaintHistoryDCALLTYPE.AsString);
rowObj.AddPair('DPriority', uqComplaintHistoryDPRIORITY.AsString);
rowObj.AddPair('DCallType', uqComplaintHistoryDCALLTYPE.AsString);
Inc(returnedCount);
Next;
......@@ -932,16 +1482,20 @@ begin
Result.AddPair('count', TJSONNumber.Create(returnedCount));
Result.AddPair('returned', TJSONNumber.Create(returnedCount));
Logger.Log(3, '---TWCAPIData.GetComplaintHistory End (returned=' + IntToStr(returnedCount) + ')');
Logger.Log(
3,
'---TBFDAPIDataModule.GetComplaintHistory End (returned=' +
IntToStr(returnedCount) + ')'
);
except
on E: EXDataHttpException do
begin
Logger.Log(2, '---TWCAPIData.GetComplaintHistory http error: ' + E.Message);
Logger.Log(2, '---TBFDAPIDataModule.GetComplaintHistory http error: ' + E.Message);
raise;
end;
on E: Exception do
begin
Logger.Log(2, '---TWCAPIData.GetComplaintHistory error: ' + E.ClassName + ': ' + E.Message);
Logger.Log(2, '---TBFDAPIDataModule.GetComplaintHistory error: ' + E.ClassName + ': ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load complaint history');
end;
end;
......@@ -951,13 +1505,13 @@ begin
end;
end;
function TWCAPIData.GetComplaintContacts(ComplaintId: string): TJSONObject;
function TBFDAPIDataModule.GetComplaintContacts(ComplaintId: string): TJSONObject;
var
dataArr: TJSONArray;
rowObj: TJSONObject;
returnedCount: Integer;
begin
Logger.Log(4, '---TWCAPIData.GetComplaintContacts initiated: ' + ComplaintId);
Logger.Log(4, '---TBFDAPIDataModule.GetComplaintContacts initiated: ' + ComplaintId);
Result := TJSONObject.Create;
try
......@@ -967,7 +1521,7 @@ begin
returnedCount := 0;
try
with ApiDB.uqComplaintContacts do
with uqComplaintContacts do
begin
ParamByName('COMPLAINTID').AsString := ComplaintId;
Open;
......@@ -977,10 +1531,10 @@ begin
rowObj := TJSONObject.Create;
dataArr.AddElement(rowObj);
rowObj.AddPair('Name', FieldByName('NAME').AsString);
rowObj.AddPair('Phone', FieldByName('PHONE').AsString);
rowObj.AddPair('DContactType', FieldByName('DCONTACTTYPE').AsString);
rowObj.AddPair('Remarks', FieldByName('REMARKS').AsString);
rowObj.AddPair('Name', uqComplaintContactsNAME.AsString);
rowObj.AddPair('Phone', uqComplaintContactsPHONE.AsString);
rowObj.AddPair('DContactType', uqComplaintContactsDCONTACTTYPE.AsString);
rowObj.AddPair('Remarks', uqComplaintContactsREMARKS.AsString);
Inc(returnedCount);
Next;
......@@ -993,16 +1547,20 @@ begin
Result.AddPair('count', TJSONNumber.Create(returnedCount));
Result.AddPair('returned', TJSONNumber.Create(returnedCount));
Logger.Log(3, '---TWCAPIData.GetComplaintContacts End (returned=' + IntToStr(returnedCount) + ')');
Logger.Log(
3,
'---TBFDAPIDataModule.GetComplaintContacts End (returned=' +
IntToStr(returnedCount) + ')'
);
except
on E: EXDataHttpException do
begin
Logger.Log(2, '---TWCAPIData.GetComplaintContacts http error: ' + E.Message);
Logger.Log(2, '---TBFDAPIDataModule.GetComplaintContacts http error: ' + E.Message);
raise;
end;
on E: Exception do
begin
Logger.Log(2, '---TWCAPIData.GetComplaintContacts error: ' + E.ClassName + ': ' + E.Message);
Logger.Log(2, '---TBFDAPIDataModule.GetComplaintContacts error: ' + E.ClassName + ': ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load complaint contacts');
end;
end;
......@@ -1012,7 +1570,7 @@ begin
end;
end;
function TWCAPIData.GetComplaintWarnings(ComplaintId: string): TJSONObject;
function TBFDAPIDataModule.GetComplaintWarnings(ComplaintId: string): TJSONObject;
var
dataArr: TJSONArray;
rowObj: TJSONObject;
......@@ -1021,7 +1579,7 @@ var
apartmentText: string;
cityText: string;
begin
Logger.Log(3, '---TWCAPIData.GetComplaintWarnings initiated: ' + ComplaintId);
Logger.Log(3, '---TBFDAPIDataModule.GetComplaintWarnings initiated: ' + ComplaintId);
Result := TJSONObject.Create;
try
......@@ -1031,7 +1589,7 @@ begin
returnedCount := 0;
try
with ApiDB.uqComplaintWarnings do
with uqComplaintWarnings do
begin
ParamByName('COMPLAINTID').AsString := ComplaintId;
Open;
......@@ -1042,18 +1600,18 @@ begin
dataArr.AddElement(rowObj);
addressText := Trim(
ApiDB.uqComplaintWarningsSTRNUMBER.AsString + ' ' +
ApiDB.uqComplaintWarningsSTRHNUMBER.AsString + ' ' +
ApiDB.uqComplaintWarningsSTRPREFIX.AsString + ' ' +
ApiDB.uqComplaintWarningsSTRNAME.AsString + ' ' +
ApiDB.uqComplaintWarningsSTRSUFFIX.AsString
uqComplaintWarningsSTRNUMBER.AsString + ' ' +
uqComplaintWarningsSTRHNUMBER.AsString + ' ' +
uqComplaintWarningsSTRPREFIX.AsString + ' ' +
uqComplaintWarningsSTRNAME.AsString + ' ' +
uqComplaintWarningsSTRSUFFIX.AsString
);
apartmentText := Trim(ApiDB.uqComplaintWarningsAPARTMENT.AsString);
apartmentText := Trim(uqComplaintWarningsAPARTMENT.AsString);
if apartmentText <> '' then
addressText := Trim(addressText + ' ' + apartmentText);
cityText := Trim(ApiDB.uqComplaintWarningsCITY.AsString);
cityText := Trim(uqComplaintWarningsCITY.AsString);
if cityText <> '' then
begin
if addressText <> '' then
......@@ -1062,9 +1620,9 @@ begin
addressText := cityText;
end;
rowObj.AddPair('CodeDesc', ApiDB.uqComplaintWarningsCODE_DESC.AsString);
rowObj.AddPair('CodeDesc', uqComplaintWarningsCODE_DESC.AsString);
rowObj.AddPair('Address', addressText);
rowObj.AddPair('Notes', ApiDB.uqComplaintWarningsNOTES.AsString);
rowObj.AddPair('Notes', uqComplaintWarningsNOTES.AsString);
Inc(returnedCount);
Next;
......@@ -1077,16 +1635,20 @@ begin
Result.AddPair('count', TJSONNumber.Create(returnedCount));
Result.AddPair('returned', TJSONNumber.Create(returnedCount));
Logger.Log(3, '---TWCAPIData.GetComplaintWarnings End (returned=' + IntToStr(returnedCount) + ')');
Logger.Log(
3,
'---TBFDAPIDataModule.GetComplaintWarnings End (returned=' +
IntToStr(returnedCount) + ')'
);
except
on E: EXDataHttpException do
begin
Logger.Log(2, '---TWCAPIData.GetComplaintWarnings http error: ' + E.Message);
Logger.Log(2, '---TBFDAPIDataModule.GetComplaintWarnings http error: ' + E.Message);
raise;
end;
on E: Exception do
begin
Logger.Log(2, '---TWCAPIData.GetComplaintWarnings error: ' + E.ClassName + ': ' + E.Message);
Logger.Log(2, '---TBFDAPIDataModule.GetComplaintWarnings error: ' + E.ClassName + ': ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load complaint warnings');
end;
end;
......@@ -1096,7 +1658,7 @@ begin
end;
end;
function TWCAPIData.GetUnitLogs(UnitId: string): TJSONObject;
function TBFDAPIDataModule.GetUnitLogs(UnitId: string): TJSONObject;
var
dataArr: TJSONArray;
rowObj: TJSONObject;
......@@ -1104,7 +1666,7 @@ var
ts: string;
complaintText: string;
begin
Logger.Log(4, '---TWCAPIData.GetUnitLogs initiated: ' + UnitId);
Logger.Log(4, '---TBFDAPIDataModule.GetUnitLogs initiated: ' + UnitId);
Result := TJSONObject.Create;
try
......@@ -1114,7 +1676,7 @@ begin
returnedCount := 0;
try
with ApiDB.uqUnitLogs do
with uqUnitLogs do
begin
ParamByName('UNITID').AsString := UnitId;
Open;
......@@ -1125,14 +1687,19 @@ begin
dataArr.AddElement(rowObj);
ts := '';
if not ApiDB.uqUnitLogsLOG_TIME.IsNull then
ts := FormatDateTime('yyyy-mm-dd' + ' ' + 'HH:nn:ss', ApiDB.uqUnitLogsLOG_TIME.AsDateTime);
if not uqUnitLogsLOG_TIME.IsNull then
begin
ts := FormatDateTime(
'yyyy-mm-dd HH:nn:ss',
uqUnitLogsLOG_TIME.AsDateTime
);
end;
complaintText := Trim(ApiDB.uqUnitLogsCOMPLAINT_NUM.AsString);
complaintText := Trim(uqUnitLogsCOMPLAINT_NUM.AsString);
rowObj.AddPair('LogTime', ts);
rowObj.AddPair('Complaint', complaintText);
rowObj.AddPair('Log', ApiDB.uqUnitLogsLOG_TEXT.AsString);
rowObj.AddPair('Log', uqUnitLogsLOG_TEXT.AsString);
Inc(returnedCount);
Next;
......@@ -1145,16 +1712,20 @@ begin
Result.AddPair('count', TJSONNumber.Create(returnedCount));
Result.AddPair('returned', TJSONNumber.Create(returnedCount));
Logger.Log(4, '---TWCAPIData.GetUnitLogs End (returned=' + IntToStr(returnedCount) + ')');
Logger.Log(
4,
'---TBFDAPIDataModule.GetUnitLogs End (returned=' +
IntToStr(returnedCount) + ')'
);
except
on E: EXDataHttpException do
begin
Logger.Log(2, '---TWCAPIData.GetUnitLogs http error: ' + E.Message);
Logger.Log(2, '---TBFDAPIDataModule.GetUnitLogs http error: ' + E.Message);
raise;
end;
on E: Exception do
begin
Logger.Log(2, '---TWCAPIData.GetUnitLogs error: ' + E.ClassName + ': ' + E.Message);
Logger.Log(2, '---TBFDAPIDataModule.GetUnitLogs error: ' + E.ClassName + ': ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load unit logs');
end;
end;
......@@ -1164,18 +1735,19 @@ begin
end;
end;
function TWCAPIData.GetUnitDetails(UnitId: string): TJSONObject;
function TBFDAPIDataModule.GetUnitDetails(UnitId: string): TJSONObject;
var
obj: TJSONObject;
updateTimeText: string;
lastStatusChangeText: string;
unitStatus: string;
begin
Logger.Log(4, '---TWCAPIData.GetUnitDetails initiated: ' + UnitId);
Logger.Log(4, '---TBFDAPIDataModule.GetUnitDetails initiated: ' + UnitId);
Result := TJSONObject.Create;
try
try
with ApiDB.uqUnitDetails do
with uqUnitDetails do
begin
Close;
ParamByName('UNITID').AsString := UnitId;
......@@ -1187,30 +1759,55 @@ begin
obj := TJSONObject.Create;
Result.AddPair('data', obj);
obj.AddPair('UnitId', ApiDB.uqUnitDetailsUNITID.AsString);
obj.AddPair('UnitName', ApiDB.uqUnitDetailsUNITNAME.AsString);
obj.AddPair('CarNumberDesc', ApiDB.uqUnitDetailsCARNUMBER_DESC.AsString);
obj.AddPair('District', ApiDB.uqUnitDetailsDISTRICT_DESC.AsString);
obj.AddPair('Location', ApiDB.uqUnitDetailsLOCATION.AsString);
obj.AddPair('UnitId', uqUnitDetailsUNITID.AsString);
obj.AddPair('UnitName', uqUnitDetailsUNITNAME.AsString);
obj.AddPair('CarNumberDesc', uqUnitDetailsCARNUMBER_DESC.AsString);
obj.AddPair('District', uqUnitDetailsDISTRICT_DESC.AsString);
obj.AddPair('Location', uqUnitDetailsLOCATION.AsString);
unitStatus := Trim(ApiDB.uqUnitDetailsUNIT_STATUS_DESC.AsString);
unitStatus := Trim(uqUnitDetailsUNIT_STATUS_DESC.AsString);
if unitStatus = '' then
unitStatus := 'Available';
obj.AddPair('Status', unitStatus);
obj.AddPair('Officer1Lname', ApiDB.uqUnitDetailsOFFICER1_LNAME.AsString);
obj.AddPair('Officer1Fname', ApiDB.uqUnitDetailsOFFICER1_FNAME.AsString);
obj.AddPair('Officer1Empnum', ApiDB.uqUnitDetailsOFFICER1_EMPNUM.AsString);
obj.AddPair('Officer2Lname', ApiDB.uqUnitDetailsOFFICER2_LNAME.AsString);
obj.AddPair('Officer2Fname', ApiDB.uqUnitDetailsOFFICER2_FNAME.AsString);
obj.AddPair('Officer2Empnum', ApiDB.uqUnitDetailsOFFICER2_EMPNUM.AsString);
obj.AddPair('Status', unitStatus);
obj.AddPair('CurrentStatus', uqUnitDetailsCURRENT_STATUS.AsString);
obj.AddPair('CurrentStation', uqUnitDetailsCURRENT_STATION.AsString);
obj.AddPair('MainStation', uqUnitDetailsMAIN_STATION.AsString);
obj.AddPair('MovingToStation', uqUnitDetailsMOVING_TO_STATION.AsString);
obj.AddPair('CarNumber', uqUnitDetailsCARNUMBER_DESC.AsString);
obj.AddPair('UnitDesc', uqUnitDetailsUNIT_DESC.AsString);
obj.AddPair('UnitType', uqUnitDetailsUNIT_TYPE.AsString);
obj.AddPair('Manpower', uqUnitDetailsMANPOWER.AsString);
obj.AddPair(
'Undermanned',
TJSONBool.Create(uqUnitDetailsMANPOWER.AsInteger = 1)
);
obj.AddPair('Dispatchable', uqUnitDetailsDISPATCHABLE.AsString);
obj.AddPair('UnavailableReason', uqUnitDetailsUNAVAILABLE_REASON.AsString);
obj.AddPair('Complaint', uqUnitDetailsCOMPLAINT.AsString);
obj.AddPair('CallType', uqUnitDetailsCALL_TYPE.AsString);
updateTimeText := '';
if not ApiDB.uqUnitDetailsUPDATE_TIME.IsNull then
updateTimeText := FormatDateTime('yyyy-mm-dd hh:nn:ss', ApiDB.uqUnitDetailsUPDATE_TIME.AsDateTime);
if not uqUnitDetailsUPDATE_TIME.IsNull then
begin
updateTimeText := FormatDateTime(
'yyyy-mm-dd hh:nn:ss',
uqUnitDetailsUPDATE_TIME.AsDateTime
);
end;
obj.AddPair('UpdateTime', updateTimeText);
lastStatusChangeText := '';
if not uqUnitDetailsLASTSTATUSCHANGE.IsNull then
begin
lastStatusChangeText := FormatDateTime(
'yyyy-mm-dd hh:nn:ss',
uqUnitDetailsLASTSTATUSCHANGE.AsDateTime
);
end;
obj.AddPair('LastStatusChange', lastStatusChangeText);
finally
Close;
end;
......@@ -1218,17 +1815,17 @@ begin
except
on E: EXDataHttpException do
begin
Logger.Log(2, '---TWCAPIData.GetUnitDetails http error: ' + E.ClassName + ': ' + E.Message);
Logger.Log(2, '---TBFDAPIDataModule.GetUnitDetails http error: ' + E.ClassName + ': ' + E.Message);
raise;
end;
on E: Exception do
begin
Logger.Log(2, '---TWCAPIData.GetUnitDetails error: ' + E.ClassName + ': ' + E.Message);
Logger.Log(2, '---TBFDAPIDataModule.GetUnitDetails error: ' + E.ClassName + ': ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load unit details');
end;
end;
Logger.Log(4, '---TWCAPIData.GetUnitDetails End');
Logger.Log(4, '---TBFDAPIDataModule.GetUnitDetails End');
except
Result.Free;
raise;
......
emiMobileServer/Clients/BFD/Server/BFD.Auth.Database.dfm 0 → 100644
object BFDAuthDatabase: TBFDAuthDatabase
OnCreate = DataModuleCreate
OnDestroy = DataModuleDestroy
Height = 373
Width = 649
PixelsPerInch = 144
object uqMisc: TUniQuery
Connection = ucENTCAD
FetchRows = 100
Left = 349
Top = 75
end
object uqAuth: TUniQuery
Connection = ucENTCAD
SQL.Strings = (
'select u.* from users u '
'where upper(user_name) = :USER_NAME '
'and u.dept = :AGENCY')
Left = 150
Top = 74
end
object OracleUniProvider1: TOracleUniProvider
Left = 345
Top = 247
end
object ucENTCAD: TUniConnection
ProviderName = 'Oracle'
Username = 'EMFIRECAD'
Server = 'BFD'
LoginPrompt = False
Left = 190
Top = 247
EncryptedPassword = 'BAFFB2FFB9FFB6FFADFFBAFFBCFFBEFFBBFF'
end
object uqAgencies: TUniQuery
Connection = ucENTCAD
SQL.Strings = (
'select agencyid as agency '
'from agency '
'where login = ''T'' '
'order by agencyid')
Left = 40
Top = 200
end
object uqAgencyConfig: TUniQuery
Connection = ucENTCAD
SQL.Strings = (
'select agencyid, agencyname '
'from agency '
'where login = ''T'' '
'order by agencyname')
Left = 160
Top = 200
end
end
emiMobileServer/Clients/BFD/Server/BFD.Auth.Database.pas 0 → 100644
unit BFD.Auth.Database;
interface
uses
Client.Auth, System.SysUtils, System.Classes, MemDS,
Data.DB, DBAccess, Uni, UniProvider, OracleUniProvider;
type
TBFDAuthDatabase = class(TClientAuth)
uqMisc: TUniQuery;
uqAuth: TUniQuery;
uqAgencies: TUniQuery;
uqAgencyConfig: TUniQuery;
OracleUniProvider1: TOracleUniProvider;
ucENTCAD: TUniConnection;
procedure DataModuleCreate(Sender: TObject);
procedure DataModuleDestroy(Sender: TObject);
private
{ Private declarations }
protected
function GetConnection: TUniConnection; override;
function GetUserData: TDataSet; override;
function GetAgencies: TDataSet; override;
function GetAgencyConfig: TDataSet; override;
public
{ Public declarations }
procedure OpenUser(User, Agency: string); override;
procedure OpenAgencies; override;
procedure OpenAgencyConfig; override;
procedure SetLoginAuditEntry( userStr: string ); override;
end;
var
BFDAuthDatabase: TBFDAuthDatabase;
implementation
uses
System.JSON,
Common.Config,
Common.Logging,
Common.Ini,
uLibrary;
{%CLASSGROUP 'Vcl.Controls.TControl'}
{$R *.dfm}
function TBFDAuthDatabase.GetConnection: TUniConnection;
begin
Result := ucENTCAD;
end;
function TBFDAuthDatabase.GetUserData: TDataSet;
begin
Result := uqAuth;
end;
function TBFDAuthDatabase.GetAgencies: TDataSet;
begin
Result := uqAgencies;
end;
function TBFDAuthDatabase.GetAgencyConfig: TDataSet;
begin
Result := uqAgencyConfig;
end;
procedure TBFDAuthDatabase.OpenUser(User, Agency: string);
begin
uqAuth.Close;
uqAuth.ParamByName('USER_NAME').AsString := UpperCase(Trim(User));
uqAuth.ParamByName('AGENCY').AsString := UpperCase(Trim(Agency));
uqAuth.Open;
end;
procedure TBFDAuthDatabase.OpenAgencies;
begin
uqAgencies.Close;
uqAgencies.Open;
end;
procedure TBFDAuthDatabase.OpenAgencyConfig;
begin
uqAgencyConfig.Close;
uqAgencyConfig.Open;
end;
procedure TBFDAuthDatabase.DataModuleCreate(Sender: TObject);
begin
IniEntries.ConfigureConnection(ucENTCAD);
try
Logger.Log(2, '');
Logger.Log(2, 'Connecting to Oracle auth database...');
if not ucENTCAD.Connected then
ucENTCAD.Connect;
Logger.Log(2, 'Oracle auth database connected');
except
on E: Exception do
begin
Logger.Log(2, Format('Failed to connect to auth database: %s', [E.Message]));
raise;
end;
end;
end;
procedure TBFDAuthDatabase.DataModuleDestroy(Sender: TObject);
begin
if ucENTCAD.Connected then
ucENTCAD.Disconnect;
end;
procedure TBFDAuthDatabase.SetLoginAuditEntry( userStr: string );
var
auditMasterId: string;
userInfo: TStringList;
username: string;
fullname: string;
agency: string;
userid: string;
personnelid: string;
begin
Logger.Log( 3, 'TBFDAuthDatabase.SetLoginAuditEntry - start' );
userInfo := TStringList.Create;
try
userInfo.Delimiter := '&';
userInfo.StrictDelimiter := True;
userInfo.DelimitedText := userStr;
username := userInfo.Values['username'];
fullname := userInfo.Values['fullname'];
agency := userInfo.Values['agency'];
userid := userInfo.Values['userId'];
personnelid := userInfo.Values['personnelid'];
if ServerConfig.auditEnabled then
begin
auditMasterId := GetNextSeqVal(uqMisc, 'SEQ_AUDIT_MASTERID');
SetMasterAuditEntry(uqMisc, auditMasterId, 'AUTH', '', agency, personnelid, fullname, 'Login', '', 'emiMobile');
end
else
begin
Logger.Log( 3, 'SetSearchAuditEntry->SetMasterAuditEntry - auditEnabled = false' );
end;
finally
userInfo.Free;
end;
end;
end.
emiMobileServer/Clients/BFD/Web/Auth.Service.pas
......@@ -7,30 +7,80 @@ uses
XData.Web.Client;
const
TOKEN_NAME = 'WEBEMIMOBILE_TOKEN';
TOKEN_NAME = 'BFDEMIMOBILE_TOKEN';
CREDENTIAL_NAME = 'BFDEMIMOBILE_CREDENTIAL_ID';
KEY_TYPE_NAME = 'BFDEMIMOBILE_KEY_TYPE';
DEVICE_MANAGER_TOKEN_NAME = 'BFDEMIMOBILE_DEVICE_MANAGER_TOKEN';
type
TOnLoginSuccess = reference to procedure;
TOnLoginError = reference to procedure(AMsg: string);
TOnProfileSuccess = reference to procedure;
TOnProfileError = reference to procedure(AMsg: string);
TOnLoginError = reference to procedure(AMsg: string);
TOnCodeSentSuccess = reference to procedure;
TOnBeginSuccess = reference to procedure(AChallenge, AChallengeToken: string);
TOnDeviceSuccess = reference to procedure;
TOnDeviceError = reference to procedure(AMsg: string);
TOnGetDeviceUserOK = reference to procedure(AUsername, AAgency: string);
TAuthService = class
private
FClient: TXDataWebClient;
procedure SetToken(AToken: string);
procedure DeleteToken;
procedure SetCredentialId(AId: string);
procedure SetKeyType(AType: string);
public
constructor Create; reintroduce;
destructor Destroy; override;
procedure Login(AUser, APassword, AAgency: string; ASuccess: TOnLoginSuccess;
AError: TOnLoginError);
function DeviceManagementMode: Boolean;
procedure LoginDeviceManager(AUser, APassword, AAgency: string;
ASuccess: TOnLoginSuccess; AError: TOnLoginError);
// JWT helpers
procedure Logout;
function GetToken: string;
function Authenticated: Boolean;
function TokenExpirationDate: TDateTime;
function TokenExpired: Boolean;
function TokenPayload: JS.TJSObject;
// Credential storage
function GetCredentialId: string;
function IsDeviceRegistered: Boolean;
function IsSimpleKey: Boolean;
procedure ClearCredentialId;
// Section: Device registration verification
procedure BeginRegistration(APhoneNumber: string;
ASuccess: TOnCodeSentSuccess; AError: TOnDeviceError);
procedure VerifyRegistrationCode(APhoneNumber, AVerificationCode: string;
ASuccess: TOnBeginSuccess;
AError: TOnDeviceError);
// Section: WebAuthn registration
procedure CompleteRegistration(APhoneNumber, ACredentialId,
AAttestationObject, AClientDataJSON, AChallengeToken: string;
ASuccess: TOnDeviceSuccess; AError: TOnDeviceError);
// WebAuthn authentication — two-step (called from within Login flow)
procedure BeginAuthentication(ACredentialId: string;
ASuccess: TOnBeginSuccess; AError: TOnLoginError);
procedure LoginWithAssertion(AUser, APassword, AAgency, ACredentialId,
AChallengeToken, AAuthenticatorData, AClientDataJSON, ASignature: string;
ASuccess: TOnLoginSuccess; AError: TOnLoginError);
// Passkey-only auto-login (no password) — uses stored username on device record
procedure GetDeviceUser(ACredentialId: string; ASuccess: TOnGetDeviceUserOK);
procedure LoginAutomatic(ACredentialId, AChallengeToken,
AAuthenticatorData, AClientDataJSON, ASignature: string;
ASuccess: TOnLoginSuccess; AError: TOnLoginError);
// Simple-key registration and login
procedure CompleteRegistrationSimple(APhoneNumber, ADeviceKey, AChallengeToken: string;
ASuccess: TOnDeviceSuccess; AError: TOnDeviceError);
procedure LoginDeviceKey(ACredentialId, AChallengeToken: string;
ASuccess: TOnLoginSuccess; AError: TOnLoginError);
procedure LoginPasswordAndSimpleKey(AUser, APassword, AAgency,
ACredentialId, AChallengeToken: string;
ASuccess: TOnLoginSuccess; AError: TOnLoginError);
end;
TJwtHelper = class
......@@ -55,44 +105,261 @@ var
function AuthService: TAuthService;
begin
if not Assigned(_AuthService) then
begin
_AuthService := TAuthService.Create;
end;
Result := _AuthService;
end;
{ TAuthService }
function TAuthService.Authenticated: Boolean;
begin
Result := not isNull(window.localStorage.getItem(TOKEN_NAME)) and
(window.localStorage.getItem(TOKEN_NAME) <> '');
end;
constructor TAuthService.Create;
begin
FClient := TXDataWebClient.Create(nil);
FClient.Connection := DMConnection.AuthConnection;
end;
procedure TAuthService.DeleteToken;
begin
window.localStorage.removeItem(TOKEN_NAME);
end;
destructor TAuthService.Destroy;
begin
FClient.Free;
inherited;
end;
// ---- JWT storage ----
procedure TAuthService.SetToken(AToken: string);
begin
if DeviceManagementMode then
window.sessionStorage.setItem(DEVICE_MANAGER_TOKEN_NAME, AToken)
else
window.localStorage.setItem(TOKEN_NAME, AToken);
end;
procedure TAuthService.DeleteToken;
begin
if DeviceManagementMode then
window.sessionStorage.removeItem(DEVICE_MANAGER_TOKEN_NAME)
else
window.localStorage.removeItem(TOKEN_NAME);
end;
function TAuthService.GetToken: string;
begin
Result := window.localStorage.getItem(TOKEN_NAME);
if DeviceManagementMode then
Result := window.sessionStorage.getItem(DEVICE_MANAGER_TOKEN_NAME)
else
Result := window.localStorage.getItem(TOKEN_NAME);
end;
function TAuthService.Authenticated: Boolean;
begin
Result := not isNull(GetToken) and (GetToken <> '');
end;
function TAuthService.DeviceManagementMode: Boolean;
begin
Result := TJSURLSearchParams.new(window.location.search).has('devices');
end;
procedure TAuthService.LoginDeviceManager(AUser, APassword, AAgency: string;
ASuccess: TOnLoginSuccess; AError: TOnLoginError);
procedure OnLoad(Response: TXDataClientResponse);
begin
SetToken(JS.toString(JS.TJSObject(Response.Result).Properties['value']));
ASuccess;
end;
procedure OnError(Error: TXDataClientError);
begin
AError(Format('%s: %s', [Error.ErrorCode, Error.ErrorMessage]));
end;
begin
FClient.RawInvoke('IAuthService.LoginDeviceManager', [AUser, APassword, AAgency], @OnLoad, @OnError);
end;
procedure TAuthService.Logout;
begin
DeleteToken;
end;
// ---- Credential ID storage ----
procedure TAuthService.SetCredentialId(AId: string);
begin
window.localStorage.setItem(CREDENTIAL_NAME, AId);
end;
procedure TAuthService.SetKeyType(AType: string);
begin
window.localStorage.setItem(KEY_TYPE_NAME, AType);
end;
procedure TAuthService.ClearCredentialId;
begin
window.localStorage.removeItem(CREDENTIAL_NAME);
window.localStorage.removeItem(KEY_TYPE_NAME);
end;
function TAuthService.IsSimpleKey: Boolean;
begin
Result := window.localStorage.getItem(KEY_TYPE_NAME) = 'simple';
end;
function TAuthService.GetCredentialId: string;
begin
Result := window.localStorage.getItem(CREDENTIAL_NAME);
end;
function TAuthService.IsDeviceRegistered: Boolean;
begin
Result := not isNull(window.localStorage.getItem(CREDENTIAL_NAME)) and
(window.localStorage.getItem(CREDENTIAL_NAME) <> '');
end;
// ---- WebAuthn registration ----
procedure TAuthService.BeginRegistration(APhoneNumber: string;
ASuccess: TOnCodeSentSuccess; AError: TOnDeviceError);
procedure OnLoad(Response: TXDataClientResponse);
var
resp: JS.TJSObject;
status: string;
begin
resp := JS.TJSObject(Response.Result);
status := JS.toString(resp.Properties['status']);
if status = 'error' then
begin
AError(JS.toString(resp.Properties['message']));
Exit;
end;
ASuccess;
end;
procedure OnError(Error: TXDataClientError);
begin
AError(Format('%s: %s', [Error.ErrorCode, Error.ErrorMessage]));
end;
begin
FClient.RawInvoke(
'IAuthService.BeginRegistration',
[APhoneNumber],
@OnLoad, @OnError
);
end;
procedure TAuthService.VerifyRegistrationCode(APhoneNumber,
AVerificationCode: string; ASuccess: TOnBeginSuccess;
AError: TOnDeviceError);
procedure OnLoad(Response: TXDataClientResponse);
var
resp: JS.TJSObject;
challenge, token, status: string;
begin
resp := JS.TJSObject(Response.Result);
status := JS.toString(resp.Properties['status']);
if status = 'error' then
begin
AError(JS.toString(resp.Properties['message']));
Exit;
end;
challenge := JS.toString(resp.Properties['challenge']);
token := JS.toString(resp.Properties['challengeToken']);
ASuccess(challenge, token);
end;
procedure OnError(Error: TXDataClientError);
begin
AError(Format('%s: %s', [Error.ErrorCode, Error.ErrorMessage]));
end;
begin
FClient.RawInvoke(
'IAuthService.VerifyRegistrationCode',
[APhoneNumber, AVerificationCode],
@OnLoad, @OnError
);
end;
procedure TAuthService.CompleteRegistration(APhoneNumber, ACredentialId,
AAttestationObject, AClientDataJSON, AChallengeToken: string;
ASuccess: TOnDeviceSuccess; AError: TOnDeviceError);
procedure OnLoad(Response: TXDataClientResponse);
var
resp: JS.TJSObject;
status, msg, credId: string;
begin
resp := JS.TJSObject(Response.Result);
status := JS.toString(resp.Properties['status']);
msg := JS.toString(resp.Properties['message']);
credId := JS.toString(resp.Properties['credentialId']);
if status = 'revoked' then
AError('Access denied: ' + msg)
else if status = 'ok' then
begin
SetCredentialId(credId);
SetKeyType('webauthn');
ASuccess;
end
else
AError(msg);
end;
procedure OnError(Error: TXDataClientError);
begin
AError(Format('%s: %s', [Error.ErrorCode, Error.ErrorMessage]));
end;
begin
FClient.RawInvoke(
'IAuthService.CompleteRegistration',
[APhoneNumber, ACredentialId, AAttestationObject, AClientDataJSON, AChallengeToken],
@OnLoad, @OnError
);
end;
// ---- WebAuthn authentication ----
procedure TAuthService.BeginAuthentication(ACredentialId: string;
ASuccess: TOnBeginSuccess; AError: TOnLoginError);
procedure OnLoad(Response: TXDataClientResponse);
var
resp: JS.TJSObject;
challenge, token, errMsg: string;
begin
resp := JS.TJSObject(Response.Result);
errMsg := JS.toString(resp.Properties['error']);
if errMsg <> '' then
begin
AError(errMsg);
Exit;
end;
challenge := JS.toString(resp.Properties['challenge']);
token := JS.toString(resp.Properties['challengeToken']);
ASuccess(challenge, token);
end;
procedure OnError(Error: TXDataClientError);
begin
AError(Format('%s: %s', [Error.ErrorCode, Error.ErrorMessage]));
end;
begin
FClient.RawInvoke(
'IAuthService.BeginAuthentication',
[ACredentialId],
@OnLoad, @OnError
);
end;
procedure TAuthService.Login(AUser, APassword, AAgency: string; ASuccess: TOnLoginSuccess;
AError: TOnLoginError);
procedure TAuthService.LoginWithAssertion(AUser, APassword, AAgency, ACredentialId,
AChallengeToken, AAuthenticatorData, AClientDataJSON, ASignature: string;
ASuccess: TOnLoginSuccess; AError: TOnLoginError);
procedure OnLoad(Response: TXDataClientResponse);
var
......@@ -109,28 +376,150 @@ procedure TAuthService.Login(AUser, APassword, AAgency: string; ASuccess: TOnLog
end;
begin
if (AUser = '') or (APassword = '') or (AAgency = '') then
FClient.RawInvoke(
'IAuthService.Login',
[AUser, APassword, AAgency, ACredentialId,
AChallengeToken, AAuthenticatorData, AClientDataJSON, ASignature],
@OnLoad, @OnError
);
end;
// ---- Passkey auto-login ----
procedure TAuthService.GetDeviceUser(ACredentialId: string; ASuccess: TOnGetDeviceUserOK);
procedure OnLoad(Response: TXDataClientResponse);
var
resp: JS.TJSObject;
begin
resp := JS.TJSObject(Response.Result);
ASuccess(
JS.toString(resp.Properties['username']),
JS.toString(resp.Properties['agency'])
);
end;
begin
FClient.RawInvoke('IAuthService.GetDeviceUser', [ACredentialId], @OnLoad);
end;
procedure TAuthService.LoginAutomatic(ACredentialId, AChallengeToken,
AAuthenticatorData, AClientDataJSON, ASignature: string;
ASuccess: TOnLoginSuccess; AError: TOnLoginError);
procedure OnLoad(Response: TXDataClientResponse);
var
Token: JS.TJSObject;
begin
Token := JS.TJSObject(Response.Result);
SetToken(JS.toString(Token.Properties['value']));
ASuccess;
end;
procedure OnError(Error: TXDataClientError);
begin
AError('Please enter a username, password, and agency');
Exit;
AError(Format('%s: %s', [Error.ErrorCode, Error.ErrorMessage]));
end;
begin
FClient.RawInvoke(
'IAuthService.Login', [AUser, APassword, AAgency],
'IAuthService.LoginAutomatic',
[ACredentialId, AChallengeToken, AAuthenticatorData, AClientDataJSON, ASignature],
@OnLoad, @OnError
);
end;
procedure TAuthService.Logout;
// ---- Simple-key registration and login ----
procedure TAuthService.CompleteRegistrationSimple(APhoneNumber, ADeviceKey, AChallengeToken: string;
ASuccess: TOnDeviceSuccess; AError: TOnDeviceError);
procedure OnLoad(Response: TXDataClientResponse);
var
resp: JS.TJSObject;
status, msg, credId: string;
begin
resp := JS.TJSObject(Response.Result);
status := JS.toString(resp.Properties['status']);
msg := JS.toString(resp.Properties['message']);
credId := JS.toString(resp.Properties['credentialId']);
if status = 'ok' then
begin
SetCredentialId(credId);
SetKeyType('simple');
ASuccess;
end
else
AError(msg);
end;
procedure OnError(Error: TXDataClientError);
begin
AError(Format('%s: %s', [Error.ErrorCode, Error.ErrorMessage]));
end;
begin
DeleteToken;
FClient.RawInvoke(
'IAuthService.CompleteRegistrationSimple',
[APhoneNumber, ADeviceKey, AChallengeToken],
@OnLoad, @OnError
);
end;
procedure TAuthService.SetToken(AToken: string);
procedure TAuthService.LoginDeviceKey(ACredentialId, AChallengeToken: string;
ASuccess: TOnLoginSuccess; AError: TOnLoginError);
procedure OnLoad(Response: TXDataClientResponse);
var
Token: JS.TJSObject;
begin
Token := JS.TJSObject(Response.Result);
SetToken(JS.toString(Token.Properties['value']));
ASuccess;
end;
procedure OnError(Error: TXDataClientError);
begin
AError(Format('%s: %s', [Error.ErrorCode, Error.ErrorMessage]));
end;
begin
FClient.RawInvoke(
'IAuthService.LoginDeviceKey',
[ACredentialId, AChallengeToken],
@OnLoad, @OnError
);
end;
procedure TAuthService.LoginPasswordAndSimpleKey(AUser, APassword, AAgency,
ACredentialId, AChallengeToken: string;
ASuccess: TOnLoginSuccess; AError: TOnLoginError);
procedure OnLoad(Response: TXDataClientResponse);
var
Token: JS.TJSObject;
begin
Token := JS.TJSObject(Response.Result);
SetToken(JS.toString(Token.Properties['value']));
ASuccess;
end;
procedure OnError(Error: TXDataClientError);
begin
AError(Format('%s: %s', [Error.ErrorCode, Error.ErrorMessage]));
end;
begin
window.localStorage.setItem(TOKEN_NAME, AToken);
FClient.RawInvoke(
'IAuthService.LoginPasswordAndSimpleKey',
[AUser, APassword, AAgency, ACredentialId, AChallengeToken],
@OnLoad, @OnError
);
end;
// ---- Token helpers ----
function TAuthService.TokenExpirationDate: TDateTime;
var
ExpirationDate: TJSDate;
......@@ -176,7 +565,7 @@ begin
Result := '';
asm
var Token = AToken.split('.');
if (Token.length = 3) {
if (Token.length === 3) {
Result = Token[1];
Result = atob(Result);
}
......
emiMobileServer/Clients/BFD/Web/ConnectionModule.pas
......@@ -4,7 +4,7 @@ interface
uses
System.SysUtils, System.Classes, WEBLib.Modules, XData.Web.Connection,
App.Types, App.Config, XData.Web.Client;
XData.Web.Client, App.Types, App.Config;
type
TDMConnection = class(TWebDataModule)
......@@ -18,12 +18,12 @@ type
private
FUnauthorizedAccessProc: TUnauthorizedAccessProc;
FWsUrl: string;
procedure VerifyVersion(SuccessProc: TSuccessProc);
public
property WsUrl: string read FWsUrl;
const clientVersion = '9.4.0';
const clientVersion = '0.9.4.9';
procedure InitApp(SuccessProc: TSuccessProc;
UnauthorizedAccessProc: TUnauthorizedAccessProc);
procedure SetClientConfig(Callback: TVersionCheckCallback);
end;
var
......@@ -57,7 +57,8 @@ procedure TDMConnection.ApiConnectionResponse(
Args: TXDataWebConnectionResponse);
begin
if Args.Response.StatusCode = 401 then
FUnauthorizedAccessProc(Format('%d: %s',[Args.Response.StatusCode, Args.Response.ContentAsText]));
FUnauthorizedAccessProc(Format('%d: %s',
[Args.Response.StatusCode, Args.Response.ContentAsText]));
end;
procedure TDMConnection.AuthConnectionError(Error: TXDataWebConnectionError);
......@@ -79,7 +80,11 @@ procedure TDMConnection.InitApp(SuccessProc: TSuccessProc;
if Config.WsUrl <> '' then
FWsUrl := Config.WsUrl;
AuthConnection.Open(SuccessProc);
AuthConnection.Open(
procedure
begin
VerifyVersion(SuccessProc);
end);
end;
begin
......@@ -87,8 +92,7 @@ begin
LoadConfig(@ConfigLoaded);
end;
procedure TDMConnection.SetClientConfig(Callback: TVersionCheckCallback);
procedure TDMConnection.VerifyVersion(SuccessProc: TSuccessProc);
begin
XDataWebClient1.Connection := AuthConnection;
......@@ -100,15 +104,21 @@ begin
begin
jsonResult := TJSObject(Response.Result);
if jsonResult.HasOwnProperty('error') then
if Assigned(jsonResult) and jsonResult.HasOwnProperty('error') then
error := string(jsonResult['error'])
else
error := '';
if error <> '' then
Callback(False, error)
TFViewErrorPage.Display(
error + sLineBreak + sLineBreak +
'Current client version: v' + clientVersion)
else
Callback(True, '');
SuccessProc;
end,
procedure(Error: TXDataClientError)
begin
TFViewErrorPage.Display(Error.ErrorMessage);
end);
end;
......
emiMobileServer/Clients/BFD/Web/Module.Websocket.pas
unit Module.Websocket;
unit Module.Websocket;
interface
uses
System.SysUtils, System.Classes, WEBLib.WebSocketClient, Web, WEBLib.Controls, WEBLib.Modules,
Auth.Service, JS;
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;
TWsConnectionState = (
wcsStopped,
wcsConnecting,
wcsConnected,
wcsReconnecting,
wcsOffline
);
TWsConnectionStateHandler = procedure(AState: TWsConnectionState) of object;
TWsNotifyHandler = procedure of object;
TdmWebsocket = class(TWebDataModule)
procedure WebDataModuleCreate(Sender: TObject);
procedure WebDataModuleDestroy(Sender: TObject);
......@@ -25,24 +36,83 @@ type
AData: TBytes);
procedure DispatchMessage(const AMessage: string);
procedure AttemptConnect;
procedure ScheduleReconnect(AImmediate: Boolean);
procedure RequestSocketRestart(AImmediate: Boolean);
procedure ScheduleHeartbeat(ADelayMs: Integer);
procedure SendHeartbeat;
procedure SendHeartbeatAck;
procedure NoteSocketActivity;
procedure HandleAuthenticationExpired;
procedure SetConnectionState(AState: TWsConnectionState);
procedure CancelReconnectTimer;
procedure CancelConnectTimeout;
procedure CancelHeartbeatTimer;
procedure CancelHeartbeatTimeout;
procedure CancelAllTimers;
procedure RegisterLifecycleListeners;
procedure UnregisterLifecycleListeners;
procedure AttachSocketEvents;
procedure DetachSocketEvents(ASocket: TWebSocketClient);
procedure ReplaceSocket(ACreateReplacement: Boolean);
procedure HandlePause(Event: TJSEvent);
procedure HandleResume(Event: TJSEvent);
procedure HandleVisibilityChange(Event: TJSEvent);
procedure HandleOnline(Event: TJSEvent);
procedure HandleOffline(Event: TJSEvent);
procedure EnterPausedState;
procedure ResumeFromPausedState;
function ConfigureSocket: Boolean;
function AuthenticationIsValid: Boolean;
function BrowserIsOnline: Boolean;
function DocumentIsHidden: Boolean;
function NextReconnectDelayMs: Integer;
function AddJitter(ABaseMs: Integer): Integer;
function UrlEncode(const AValue: string): string;
FBaseWsUrl: string;
FState: TWsConnectionState;
FStarted: Boolean;
FPaused: Boolean;
FConnecting: Boolean;
FTransportMayBeActive: Boolean;
FAttemptedConnection: Boolean;
FHasConnected: Boolean;
FRecoveryPending: Boolean;
FHeartbeatOutstanding: Boolean;
FAuthenticationNotified: Boolean;
FDestroyingManager: Boolean;
FLifecycleListenersRegistered: Boolean;
FReconnectAttempt: Integer;
FReconnectTimerId: NativeInt;
FConnectTimeoutId: NativeInt;
FHeartbeatTimerId: NativeInt;
FHeartbeatTimeoutId: NativeInt;
FOnBadgeCounts: TWsDataHandler;
FOnUnitMap: TWsDataHandler;
FOnComplaintMap: TWsDataHandler;
FOnUnitList: TWsDataHandler;
FOnBadgeCounts: TWsDataHandler;
FOnUnitMap: TWsDataHandler;
FOnComplaintMap: TWsDataHandler;
FOnUnitList: TWsDataHandler;
FOnComplaintList: TWsDataHandler;
FOnStateChanged: TWsConnectionStateHandler;
FOnRecoveryRequired: TWsNotifyHandler;
FOnAuthenticationExpired: TWsNotifyHandler;
public
EMiMobileWebSocketClient: TWebSocketClient;
procedure Connect(const AWsUrl: string);
procedure Stop;
// 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;
// Assign these before calling Connect so pushes and state changes 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;
property OnStateChanged: TWsConnectionStateHandler read FOnStateChanged write FOnStateChanged;
property OnRecoveryRequired: TWsNotifyHandler read FOnRecoveryRequired write FOnRecoveryRequired;
property OnAuthenticationExpired: TWsNotifyHandler read FOnAuthenticationExpired write FOnAuthenticationExpired;
property State: TWsConnectionState read FState;
end;
var
......@@ -50,27 +120,112 @@ var
implementation
uses
ConnectionModule;
{%CLASSGROUP 'Vcl.Controls.TControl'}
{$R *.dfm}
procedure TdmWebsocket.Connect(const AWsUrl: string);
const
CONNECT_TIMEOUT_MS = 15000;
HEARTBEAT_INTERVAL_MS = 20000;
HEARTBEAT_TIMEOUT_MS = 10000;
function TdmWebsocket.AddJitter(ABaseMs: Integer): Integer;
begin
Result := ABaseMs;
asm
Result = ABaseMs + Math.round(((Math.random() * 0.2) - 0.1) * ABaseMs);
end;
if Result < 250 then
Result := 250;
end;
function TdmWebsocket.AuthenticationIsValid: Boolean;
begin
Result := False;
try
Result := AuthService.Authenticated and (not AuthService.TokenExpired);
except
Result := False;
end;
end;
function TdmWebsocket.BrowserIsOnline: Boolean;
begin
Result := True;
asm
if ((typeof navigator !== 'undefined') && ('onLine' in navigator)) {
Result = navigator.onLine !== false;
}
end;
end;
procedure TdmWebsocket.CancelAllTimers;
begin
CancelReconnectTimer;
CancelConnectTimeout;
CancelHeartbeatTimer;
CancelHeartbeatTimeout;
end;
procedure TdmWebsocket.CancelConnectTimeout;
begin
if FConnectTimeoutId = 0 then
Exit;
window.clearTimeout(FConnectTimeoutId);
FConnectTimeoutId := 0;
end;
procedure TdmWebsocket.CancelHeartbeatTimeout;
begin
if FHeartbeatTimeoutId = 0 then
Exit;
window.clearTimeout(FHeartbeatTimeoutId);
FHeartbeatTimeoutId := 0;
end;
procedure TdmWebsocket.CancelHeartbeatTimer;
begin
if FHeartbeatTimerId = 0 then
Exit;
window.clearTimeout(FHeartbeatTimerId);
FHeartbeatTimerId := 0;
end;
procedure TdmWebsocket.CancelReconnectTimer;
begin
if FReconnectTimerId = 0 then
Exit;
window.clearTimeout(FReconnectTimerId);
FReconnectTimerId := 0;
end;
function TdmWebsocket.ConfigureSocket: Boolean;
var
Rest, HostPort, Scheme, Path, Token: string;
ColonSlashSlash, SlashPos, ColonPos: Integer;
begin
if AWsUrl = '' then
Exit;
Result := False;
// Parse ws://host:port/path or wss://host:port/path
ColonSlashSlash := Pos('://', AWsUrl);
ColonSlashSlash := Pos('://', FBaseWsUrl);
if ColonSlashSlash = 0 then
Exit;
Scheme := LowerCase(Copy(AWsUrl, 1, ColonSlashSlash - 1));
Rest := Copy(AWsUrl, ColonSlashSlash + 3, MaxInt);
Scheme := LowerCase(Copy(FBaseWsUrl, 1, ColonSlashSlash - 1));
if (Scheme <> 'ws') and (Scheme <> 'wss') then
Exit;
Rest := Copy(FBaseWsUrl, ColonSlashSlash + 3, MaxInt);
SlashPos := Pos('/', Rest);
if SlashPos > 0 then
begin
HostPort := Copy(Rest, 1, SlashPos - 1);
......@@ -82,14 +237,18 @@ begin
Path := '/';
end;
// Append JWT token as query param — browsers can't set Authorization headers on WebSocket.
if HostPort = '' then
Exit;
// Browsers cannot add an Authorization header during a WebSocket handshake.
// Build this path for every attempt so a stale token is never reused.
Token := AuthService.GetToken;
if Token <> '' then
begin
if Pos('?', Path) > 0 then
Path := Path + '&token=' + Token
Path := Path + '&token=' + UrlEncode(Token)
else
Path := Path + '?token=' + Token;
Path := Path + '?token=' + UrlEncode(Token);
end;
EMiMobileWebSocketClient.PathName := Path;
......@@ -99,9 +258,11 @@ begin
begin
EMiMobileWebSocketClient.HostName := Copy(HostPort, 1, ColonPos - 1);
if Scheme = 'wss' then
EMiMobileWebSocketClient.Port := StrToIntDef(Copy(HostPort, ColonPos + 1, MaxInt), 443)
EMiMobileWebSocketClient.Port := StrToIntDef(
Copy(HostPort, ColonPos + 1, MaxInt), 443)
else
EMiMobileWebSocketClient.Port := StrToIntDef(Copy(HostPort, ColonPos + 1, MaxInt), 80);
EMiMobileWebSocketClient.Port := StrToIntDef(
Copy(HostPort, ColonPos + 1, MaxInt), 80);
end
else
begin
......@@ -112,12 +273,209 @@ begin
EMiMobileWebSocketClient.Port := 80;
end;
console.log('WS: connecting to ' + AWsUrl);
EMiMobileWebSocketClient.UseSSL := Scheme = 'wss';
Result := True;
end;
procedure TdmWebsocket.Connect(const AWsUrl: string);
begin
if Trim(AWsUrl) = '' then
begin
Stop;
console.log('WS: no WebSocket URL configured');
Exit;
end;
if FStarted and SameText(FBaseWsUrl, AWsUrl) then
begin
if FPaused or (FState = wcsConnected) or (FState = wcsConnecting) or
(FReconnectTimerId <> 0) then
Exit;
ScheduleReconnect(True);
Exit;
end;
if FStarted then
begin
FBaseWsUrl := AWsUrl;
FRecoveryPending := True;
FReconnectAttempt := 0;
RequestSocketRestart(True);
Exit;
end;
FBaseWsUrl := AWsUrl;
FStarted := True;
FPaused := DocumentIsHidden;
FConnecting := False;
FAttemptedConnection := False;
FHasConnected := False;
FRecoveryPending := False;
FHeartbeatOutstanding := False;
FAuthenticationNotified := False;
FReconnectAttempt := 0;
if FPaused then
begin
SetConnectionState(wcsStopped);
Exit;
end;
if not AuthenticationIsValid then
begin
HandleAuthenticationExpired;
Exit;
end;
EMiMobileWebSocketClient.UseSSL := (Scheme = 'wss');
EMiMobileWebSocketClient.Active := True;
if not BrowserIsOnline then
begin
SetConnectionState(wcsOffline);
Exit;
end;
console.log('WS: Active set to true');
AttemptConnect;
end;
procedure TdmWebsocket.AttemptConnect;
begin
if (not FStarted) or FPaused or FDestroyingManager then
Exit;
if FConnecting or (FState = wcsConnected) then
Exit;
if not AuthenticationIsValid then
begin
HandleAuthenticationExpired;
Exit;
end;
if not BrowserIsOnline then
begin
SetConnectionState(wcsOffline);
Exit;
end;
if FTransportMayBeActive then
begin
RequestSocketRestart(True);
Exit;
end;
if not Assigned(EMiMobileWebSocketClient) then
begin
EMiMobileWebSocketClient := TWebSocketClient.Create(Self);
AttachSocketEvents;
end;
if not ConfigureSocket then
begin
console.log('WS: invalid WebSocket URL');
FStarted := False;
SetConnectionState(wcsStopped);
Exit;
end;
if FAttemptedConnection then
SetConnectionState(wcsReconnecting)
else
SetConnectionState(wcsConnecting);
FAttemptedConnection := True;
FConnecting := True;
FTransportMayBeActive := True;
CancelConnectTimeout;
FConnectTimeoutId := window.setTimeout(
procedure
begin
FConnectTimeoutId := 0;
if (not FStarted) or FPaused or (not FConnecting) then
Exit;
console.log('WS: connection attempt timed out');
FConnecting := False;
FRecoveryPending := True;
RequestSocketRestart(False);
end,
CONNECT_TIMEOUT_MS);
try
console.log('WS: connection attempt');
EMiMobileWebSocketClient.Connect;
except
on E: Exception do
begin
console.log('WS: connection attempt failed: ' + E.Message);
FConnecting := False;
FRecoveryPending := True;
RequestSocketRestart(False);
end;
end;
end;
procedure TdmWebsocket.AttachSocketEvents;
begin
if not Assigned(EMiMobileWebSocketClient) then
Exit;
EMiMobileWebSocketClient.OnConnect := EMiMobileWebSocketClientConnect;
EMiMobileWebSocketClient.OnDisconnect := EMiMobileWebSocketClientDisconnect;
EMiMobileWebSocketClient.OnDataReceived := EMiMobileWebSocketClientDataReceived;
EMiMobileWebSocketClient.OnMessageReceived := EMiMobileWebSocketClientMessageReceived;
EMiMobileWebSocketClient.OnBinaryDataReceived := EMiMobileWebSocketClientBinaryDataReceived;
end;
procedure TdmWebsocket.DetachSocketEvents(ASocket: TWebSocketClient);
begin
if not Assigned(ASocket) then
Exit;
ASocket.OnConnect := nil;
ASocket.OnDisconnect := nil;
ASocket.OnDataReceived := nil;
ASocket.OnMessageReceived := nil;
ASocket.OnBinaryDataReceived := nil;
end;
procedure TdmWebsocket.ReplaceSocket(ACreateReplacement: Boolean);
var
oldSocket: TWebSocketClient;
begin
oldSocket := EMiMobileWebSocketClient;
EMiMobileWebSocketClient := nil;
if Assigned(oldSocket) then
begin
DetachSocketEvents(oldSocket);
try
oldSocket.Disconnect;
except
on E: Exception do
console.log('WS: disconnect failed: ' + E.Message);
end;
oldSocket.Free;
end;
FTransportMayBeActive := False;
if ACreateReplacement and (not FDestroyingManager) then
begin
EMiMobileWebSocketClient := TWebSocketClient.Create(Self);
AttachSocketEvents;
end;
end;
function TdmWebsocket.DocumentIsHidden: Boolean;
begin
Result := False;
asm
if (typeof document !== 'undefined') {
Result = !!document.hidden;
}
end;
end;
procedure TdmWebsocket.DispatchMessage(const AMessage: string);
......@@ -148,6 +506,15 @@ begin
messageType := string(obj['message']);
if SameText(messageType, 'heartbeat_ack') then
Exit;
if SameText(messageType, 'heartbeat') then
begin
SendHeartbeatAck;
Exit;
end;
if SameText(messageType, 'test_message') then
begin
messageText := string(obj['text']);
......@@ -187,51 +554,554 @@ end;
procedure TdmWebsocket.EMiMobileWebSocketClientBinaryDataReceived(
Sender: TObject; AData: TBytes);
begin
if Sender <> EMiMobileWebSocketClient then
Exit;
if not AuthenticationIsValid then
begin
HandleAuthenticationExpired;
Exit;
end;
NoteSocketActivity;
console.log('WS: binary data received (ignored)');
end;
procedure TdmWebsocket.EMiMobileWebSocketClientConnect(Sender: TObject);
var
msg: TJSObject;
payload: TJSObject;
userId: string;
recoveryRequired: Boolean;
begin
if Sender <> EMiMobileWebSocketClient then
Exit;
if (not FStarted) or FDestroyingManager then
begin
ReplaceSocket(False);
Exit;
end;
if FPaused then
begin
SetConnectionState(wcsStopped);
ReplaceSocket(True);
Exit;
end;
if not BrowserIsOnline then
begin
SetConnectionState(wcsOffline);
ReplaceSocket(True);
Exit;
end;
if not AuthenticationIsValid then
begin
HandleAuthenticationExpired;
Exit;
end;
try
payload := AuthService.TokenPayload;
if not Assigned(payload) then
begin
HandleAuthenticationExpired;
Exit;
end;
userId := JS.toString(payload.Properties['user_name']);
if (Trim(userId) = '') or SameText(userId, 'undefined') or
SameText(userId, 'null') then
begin
HandleAuthenticationExpired;
Exit;
end;
msg := TJSObject.new;
msg['message'] := 'identify';
msg['userId'] := userId;
msg['clientVersion'] := TDMConnection.clientVersion;
EMiMobileWebSocketClient.Send(TJSJSON.stringify(msg));
except
on E: Exception do
begin
console.log('WS: identify failed: ' + E.Message);
FConnecting := False;
FRecoveryPending := True;
RequestSocketRestart(False);
Exit;
end;
end;
console.log('WS: connected');
CancelConnectTimeout;
CancelReconnectTimer;
FConnecting := False;
FTransportMayBeActive := True;
FHeartbeatOutstanding := False;
FReconnectAttempt := 0;
FAuthenticationNotified := False;
msg := TJSObject.new;
msg['message'] := 'identify';
msg['userId'] := JS.toString(AuthService.TokenPayload.Properties['user_name']);
recoveryRequired := FRecoveryPending or FHasConnected;
FRecoveryPending := False;
FHasConnected := True;
SetConnectionState(wcsConnected);
ScheduleHeartbeat(1000);
EMiMobileWebSocketClient.Send(TJSJSON.stringify(msg));
if recoveryRequired and Assigned(FOnRecoveryRequired) then
FOnRecoveryRequired;
end;
procedure TdmWebsocket.EMiMobileWebSocketClientDataReceived(Sender: TObject;
Origin: string; SocketData: TJSObjectRecord);
begin
if Sender <> EMiMobileWebSocketClient then
Exit;
// Text messages arrive via EMiMobileWebSocketClientMessageReceived.
end;
procedure TdmWebsocket.EMiMobileWebSocketClientDisconnect(Sender: TObject);
begin
if Sender <> EMiMobileWebSocketClient then
Exit;
console.log('WS: disconnected');
CancelConnectTimeout;
CancelHeartbeatTimer;
CancelHeartbeatTimeout;
FConnecting := False;
FTransportMayBeActive := False;
FHeartbeatOutstanding := False;
if (not FStarted) or FDestroyingManager then
begin
SetConnectionState(wcsStopped);
Exit;
end;
if FPaused then
begin
SetConnectionState(wcsStopped);
Exit;
end;
if not BrowserIsOnline then
begin
SetConnectionState(wcsOffline);
Exit;
end;
FRecoveryPending := True;
ScheduleReconnect(False);
end;
procedure TdmWebsocket.EMiMobileWebSocketClientMessageReceived(Sender: TObject;
AMessage: string);
begin
if Sender <> EMiMobileWebSocketClient then
Exit;
if not AuthenticationIsValid then
begin
HandleAuthenticationExpired;
Exit;
end;
NoteSocketActivity;
DispatchMessage(AMessage);
end;
procedure TdmWebsocket.EnterPausedState;
begin
if FPaused then
Exit;
FPaused := True;
FRecoveryPending := FStarted;
FConnecting := False;
FHeartbeatOutstanding := False;
CancelAllTimers;
SetConnectionState(wcsStopped);
ReplaceSocket(True);
end;
procedure TdmWebsocket.HandleAuthenticationExpired;
var
notifyAuthenticationExpired: Boolean;
begin
notifyAuthenticationExpired := not FAuthenticationNotified;
FAuthenticationNotified := True;
FStarted := False;
FPaused := False;
FConnecting := False;
FHeartbeatOutstanding := False;
CancelAllTimers;
SetConnectionState(wcsStopped);
ReplaceSocket(False);
if notifyAuthenticationExpired and Assigned(FOnAuthenticationExpired) then
FOnAuthenticationExpired;
end;
procedure TdmWebsocket.HandleOffline(Event: TJSEvent);
begin
if (not FStarted) or FPaused then
Exit;
FRecoveryPending := True;
FConnecting := False;
FHeartbeatOutstanding := False;
CancelAllTimers;
SetConnectionState(wcsOffline);
ReplaceSocket(True);
end;
procedure TdmWebsocket.HandleOnline(Event: TJSEvent);
begin
if (not FStarted) or FPaused then
Exit;
if not AuthenticationIsValid then
begin
HandleAuthenticationExpired;
Exit;
end;
FRecoveryPending := True;
FReconnectAttempt := 0;
if FTransportMayBeActive then
RequestSocketRestart(True)
else
ScheduleReconnect(True);
end;
procedure TdmWebsocket.HandlePause(Event: TJSEvent);
begin
EnterPausedState;
end;
procedure TdmWebsocket.HandleResume(Event: TJSEvent);
begin
ResumeFromPausedState;
end;
procedure TdmWebsocket.HandleVisibilityChange(Event: TJSEvent);
begin
if DocumentIsHidden then
EnterPausedState
else
ResumeFromPausedState;
end;
function TdmWebsocket.NextReconnectDelayMs: Integer;
var
baseDelay: Integer;
begin
case FReconnectAttempt of
0: baseDelay := 1000;
1: baseDelay := 2000;
2: baseDelay := 5000;
3: baseDelay := 10000;
else
baseDelay := 30000;
end;
Inc(FReconnectAttempt);
Result := AddJitter(baseDelay);
end;
procedure TdmWebsocket.NoteSocketActivity;
begin
if FState <> wcsConnected then
Exit;
FHeartbeatOutstanding := False;
CancelHeartbeatTimeout;
if FHeartbeatTimerId = 0 then
ScheduleHeartbeat(HEARTBEAT_INTERVAL_MS);
end;
procedure TdmWebsocket.RegisterLifecycleListeners;
begin
if FLifecycleListenersRegistered then
Exit;
Document.addEventListener('pause', @HandlePause);
Document.addEventListener('resume', @HandleResume);
Document.addEventListener('visibilitychange', @HandleVisibilityChange);
window.addEventListener('online', @HandleOnline);
window.addEventListener('offline', @HandleOffline);
FLifecycleListenersRegistered := True;
end;
procedure TdmWebsocket.RequestSocketRestart(AImmediate: Boolean);
begin
if (not FStarted) or FPaused or FDestroyingManager then
Exit;
if not AuthenticationIsValid then
begin
HandleAuthenticationExpired;
Exit;
end;
if not BrowserIsOnline then
begin
SetConnectionState(wcsOffline);
Exit;
end;
FRecoveryPending := True;
FConnecting := False;
FHeartbeatOutstanding := False;
CancelConnectTimeout;
CancelHeartbeatTimer;
CancelHeartbeatTimeout;
SetConnectionState(wcsReconnecting);
// Detach and retire the current component before a replacement is opened.
// A late browser close from the old socket then has neither live handlers
// nor a matching Sender, so it cannot change the new connection's state.
ReplaceSocket(True);
ScheduleReconnect(AImmediate);
end;
procedure TdmWebsocket.ResumeFromPausedState;
begin
if not FStarted then
Exit;
FPaused := False;
FRecoveryPending := True;
FReconnectAttempt := 0;
if not AuthenticationIsValid then
begin
HandleAuthenticationExpired;
Exit;
end;
if not BrowserIsOnline then
begin
SetConnectionState(wcsOffline);
Exit;
end;
if FTransportMayBeActive then
RequestSocketRestart(True)
else
ScheduleReconnect(True);
end;
procedure TdmWebsocket.ScheduleHeartbeat(ADelayMs: Integer);
begin
CancelHeartbeatTimer;
if (not FStarted) or FPaused or (FState <> wcsConnected) then
Exit;
FHeartbeatTimerId := window.setTimeout(
procedure
begin
FHeartbeatTimerId := 0;
SendHeartbeat;
end,
ADelayMs);
end;
procedure TdmWebsocket.ScheduleReconnect(AImmediate: Boolean);
var
delayMs: Integer;
begin
if (not FStarted) or FPaused or FDestroyingManager then
Exit;
if not AuthenticationIsValid then
begin
HandleAuthenticationExpired;
Exit;
end;
if not BrowserIsOnline then
begin
SetConnectionState(wcsOffline);
Exit;
end;
if AImmediate then
CancelReconnectTimer
else if FReconnectTimerId <> 0 then
Exit;
if AImmediate then
delayMs := 0
else
delayMs := NextReconnectDelayMs;
if FAttemptedConnection then
SetConnectionState(wcsReconnecting)
else
SetConnectionState(wcsConnecting);
FReconnectTimerId := window.setTimeout(
procedure
begin
FReconnectTimerId := 0;
AttemptConnect;
end,
delayMs);
end;
procedure TdmWebsocket.SendHeartbeat;
var
msg: TJSObject;
begin
if (not FStarted) or FPaused or (FState <> wcsConnected) then
Exit;
if not AuthenticationIsValid then
begin
HandleAuthenticationExpired;
Exit;
end;
msg := TJSObject.new;
msg['message'] := 'heartbeat';
try
EMiMobileWebSocketClient.Send(TJSJSON.stringify(msg));
except
on E: Exception do
begin
console.log('WS: heartbeat send failed: ' + E.Message);
RequestSocketRestart(False);
Exit;
end;
end;
FHeartbeatOutstanding := True;
CancelHeartbeatTimeout;
FHeartbeatTimeoutId := window.setTimeout(
procedure
begin
FHeartbeatTimeoutId := 0;
if (not FStarted) or FPaused or
(FState <> wcsConnected) or (not FHeartbeatOutstanding) then
Exit;
console.log('WS: heartbeat timed out');
FHeartbeatOutstanding := False;
RequestSocketRestart(False);
end,
HEARTBEAT_TIMEOUT_MS);
end;
procedure TdmWebsocket.SendHeartbeatAck;
var
msg: TJSObject;
begin
if (not FStarted) or FPaused or (FState <> wcsConnected) then
Exit;
msg := TJSObject.new;
msg['message'] := 'heartbeat_ack';
try
EMiMobileWebSocketClient.Send(TJSJSON.stringify(msg));
except
on E: Exception do
begin
console.log('WS: heartbeat acknowledgement failed: ' + E.Message);
RequestSocketRestart(False);
end;
end;
end;
procedure TdmWebsocket.SetConnectionState(AState: TWsConnectionState);
begin
if FState = AState then
Exit;
FState := AState;
if (not FDestroyingManager) and Assigned(FOnStateChanged) then
FOnStateChanged(AState);
end;
procedure TdmWebsocket.Stop;
begin
FStarted := False;
FPaused := False;
FConnecting := False;
FRecoveryPending := False;
FHeartbeatOutstanding := False;
CancelAllTimers;
SetConnectionState(wcsStopped);
ReplaceSocket(False);
end;
procedure TdmWebsocket.UnregisterLifecycleListeners;
begin
if not FLifecycleListenersRegistered then
Exit;
Document.removeEventListener('pause', @HandlePause);
Document.removeEventListener('resume', @HandleResume);
Document.removeEventListener('visibilitychange', @HandleVisibilityChange);
window.removeEventListener('online', @HandleOnline);
window.removeEventListener('offline', @HandleOffline);
FLifecycleListenersRegistered := False;
end;
function TdmWebsocket.UrlEncode(const AValue: string): string;
begin
Result := '';
asm
Result = encodeURIComponent(AValue);
end;
end;
procedure TdmWebsocket.WebDataModuleCreate(Sender: TObject);
begin
console.log('WS: datamodule created');
EMiMobileWebSocketClient.OnConnect := EMiMobileWebSocketClientConnect;
EMiMobileWebSocketClient.OnDisconnect := EMiMobileWebSocketClientDisconnect;
EMiMobileWebSocketClient.OnMessageReceived := EMiMobileWebSocketClientMessageReceived;
FState := wcsStopped;
FReconnectTimerId := 0;
FConnectTimeoutId := 0;
FHeartbeatTimerId := 0;
FHeartbeatTimeoutId := 0;
AttachSocketEvents;
RegisterLifecycleListeners;
end;
procedure TdmWebsocket.WebDataModuleDestroy(Sender: TObject);
begin
FDestroyingManager := True;
UnregisterLifecycleListeners;
Stop;
FOnBadgeCounts := nil;
FOnUnitMap := nil;
FOnComplaintMap := nil;
FOnUnitList := nil;
FOnComplaintList := nil;
FOnStateChanged := nil;
FOnRecoveryRequired := nil;
FOnAuthenticationExpired := nil;
if dmWebsocket = Self then
dmWebsocket := nil;
end;
end.
emiMobileServer/Clients/BFD/Web/Utils.pas
......@@ -15,6 +15,7 @@ function FormatPhoneNumber(PhoneNumber: string): string;
procedure ApplyReportTitle(CurrentReportType: string);
procedure ShowToast(const MessageText: string; const ToastType: string = 'success');
procedure ShowConfirmationModal(msg, leftLabel, rightLabel: string; ConfirmProc: TProc<Boolean>);
procedure ShowInformationModal(const Title, MessageText: string);
// function FormatDollarValue(ValueStr: string): string;
......@@ -206,12 +207,12 @@ begin
btnLeft.onclick = function () {
bsModal.hide();
ConfirmProc(true); // user confirmed
ConfirmProc(false);
};
btnRight.onclick = function () {
bsModal.hide();
ConfirmProc(false); // user canceled
ConfirmProc(true);
};
bsModal = new bootstrap.Modal(modal, { keyboard: false });
......@@ -220,6 +221,28 @@ begin
end;
procedure ShowInformationModal(const Title, MessageText: string);
begin
asm
var modal = document.getElementById('main_information_modal');
var title = document.getElementById('main_information_modal_title');
var body = document.getElementById('main_information_modal_body');
if (!modal) return;
if (title) title.innerText = Title;
if (body) body.innerText = MessageText;
if (modal.parentNode !== document.body) {
document.body.appendChild(modal);
}
var bsModal = bootstrap.Modal.getOrCreateInstance(modal);
bsModal.show();
end;
end;
function CalculateAge(DateOfBirth: TDateTime): Integer;
var
Today, BirthDate: TJSDate;
......
emiMobileServer/Clients/BFD/Web/View.DeviceManager.dfm 0 → 100644
object FViewDeviceManager: TFViewDeviceManager
Width = 900
Height = 600
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
ParentFont = False
OnCreate = WebFormCreate
object pnlMessage: TWebPanel
Left = 8
Top = 8
Width = 200
Height = 33
ElementID = 'view.devmgr.message'
TabOrder = 0
object lblMessage: TWebLabel
Left = 8
Top = 8
Width = 42
Height = 13
Caption = 'Message'
ElementID = 'view.devmgr.message.label'
HeightPercent = 100.000000000000000000
WidthPercent = 100.000000000000000000
end
object btnCloseNotification: TWebButton
Left = 170
Top = 4
Width = 22
Height = 25
ElementID = 'view.devmgr.message.button'
HeightPercent = 100.000000000000000000
WidthPercent = 100.000000000000000000
OnClick = btnCloseNotificationClick
end
end
object edtNewDeviceName: TWebEdit
Left = 8
Top = 50
Width = 175
Height = 25
ElementID = 'view.devmgr.newname'
HeightPercent = 100.000000000000000000
TabOrder = 1
WidthPercent = 100.000000000000000000
end
object edtNewPhoneNumber: TWebEdit
Left = 192
Top = 50
Width = 155
Height = 25
ElementID = 'view.devmgr.newphone'
HeightPercent = 100.000000000000000000
TabOrder = 2
TextHint = '(303) 555-1234'
WidthPercent = 100.000000000000000000
end
object btnAddDevice: TWebButton
Left = 356
Top = 50
Width = 60
Height = 25
Caption = 'Add'
ElementID = 'view.devmgr.btnadd'
HeightPercent = 100.000000000000000000
TabOrder = 3
WidthPercent = 100.000000000000000000
OnClick = btnAddDeviceClick
end
object btnLogout: TWebButton
Left = 720
Top = 50
Width = 75
Height = 25
Caption = 'Log Out'
ElementID = 'view.devmgr.btnlogout'
HeightPercent = 100.000000000000000000
Visible = False
WidthPercent = 100.000000000000000000
OnClick = btnLogoutClick
end
object XDataWebClient: TXDataWebClient
Connection = DMConnection.ApiConnection
Left = 800
Top = 8
end
end
emiMobileServer/Clients/BFD/Web/View.DeviceManager.html 0 → 100644
<div class="container-fluid p-3 h-100 d-flex flex-column">
<div class="d-flex align-items-center mb-3">
<h5 class="mb-0 me-auto">Device Management</h5>
<button id="view.devmgr.btnlogout" class="btn btn-outline-secondary btn-sm me-2" type="button">
Log Out
</button>
<button id="view.devmgr.btnrefresh"
class="btn btn-outline-secondary btn-sm"
onclick="document.dispatchEvent(new CustomEvent('devmgr-refresh'))">
Refresh
</button>
</div>
<!-- Notification bar -->
<div id="view.devmgr.message"
class="alert alert-danger d-flex align-items-start d-none mb-3"
role="alert">
<span id="view.devmgr.message.label" class="me-auto"></span>
<button id="view.devmgr.message.button"
type="button"
class="btn-close ms-2"
aria-label="Close"></button>
</div>
<!-- Add pending device -->
<div class="card mb-3">
<div class="card-body py-2">
<div class="d-flex align-items-start gap-2 flex-wrap">
<span class="fw-semibold text-nowrap small mt-2">Add Device:</span>
<div style="width:180px;">
<input type="text"
id="view.devmgr.newname"
class="form-control form-control-sm"
placeholder="Device name"
required>
<div class="invalid-feedback small">Device name is required.</div>
</div>
<div style="width:160px;">
<input type="tel"
id="view.devmgr.newphone"
class="form-control form-control-sm"
placeholder="(303) 555-1234"
required>
<div class="invalid-feedback small">Phone number is required.</div>
</div>
<div style="width:140px;">
<select id="view.devmgr.newtype"
class="form-select form-select-sm"
required>
<option value="" selected>Device type</option>
<option value="iphone">iPhone</option>
<option value="android">Android</option>
<option value="browser">Browser</option>
<option value="other">Other</option>
</select>
<div class="invalid-feedback small">Device type is required.</div>
</div>
<button id="view.devmgr.btnadd"
class="btn btn-primary btn-sm">Add</button>
</div>
</div>
</div>
<!-- Device table -->
<div class="table-responsive flex-grow-1">
<table class="table table-sm table-hover align-middle" id="view.devmgr.table">
<thead class="table-light sticky-top">
<tr>
<th style="min-width:130px;">Device Name</th>
<th style="min-width:120px;">Phone</th>
<th style="min-width:145px;">Verification Code</th>
<th style="min-width:140px;">Username</th>
<th>Browser / User Agent</th>
<th style="min-width:135px;">Registered</th>
<th style="min-width:80px;">Status</th>
<th style="min-width:85px;">Access</th>
<th style="min-width:75px;">Delete</th>
<th style="min-width:90px;">Send Link</th>
</tr>
</thead>
<tbody id="view.devmgr.tbody">
</tbody>
</table>
<p id="view.devmgr.empty" class="text-muted d-none text-center py-4">
No devices found.
</p>
</div>
<!-- Information modal used by Utils.ShowInformationModal -->
<div class="modal fade" id="main_information_modal" tabindex="-1"
aria-labelledby="main_information_modal_title" aria-hidden="true">
<div class="modal-dialog modal-dialog-centered modal-sm mx-auto px-3">
<div class="modal-content shadow-lg">
<div class="modal-header">
<h5 class="modal-title" id="main_information_modal_title">Information</h5>
<button type="button" class="btn-close" data-bs-dismiss="modal" aria-label="Close"></button>
</div>
<div class="modal-body fs-6 fw-bold" id="main_information_modal_body"></div>
<div class="modal-footer">
<button type="button" class="btn btn-primary w-100" data-bs-dismiss="modal">OK</button>
</div>
</div>
</div>
</div>
<!-- Section: Confirmation modal used by Utils.ShowConfirmationModal -->
<div class="modal fade" id="main_confirmation_modal" tabindex="-1" aria-hidden="true">
<div class="modal-dialog">
<div class="modal-content shadow-lg">
<div class="modal-header">
<h5 class="modal-title">Confirm</h5>
<button type="button" class="btn-close" data-bs-dismiss="modal" aria-label="Close"></button>
</div>
<div class="modal-body fw-bold" id="main_modal_body"></div>
<div class="modal-footer justify-content-center">
<button type="button" class="btn btn-secondary me-3" id="btn_confirm_left">Cancel</button>
<button type="button" class="btn btn-danger" id="btn_confirm_right">Delete</button>
</div>
</div>
</div>
</div>
</div>
emiMobileServer/Clients/BFD/Web/View.DeviceManager.pas 0 → 100644
unit View.DeviceManager;
interface
uses
System.SysUtils, System.Classes, Web, JS, WEBLib.Graphics, WEBLib.Controls,
WEBLib.Forms, WEBLib.Dialogs, Vcl.Controls, Vcl.StdCtrls, WEBLib.StdCtrls,
WEBLib.ExtCtrls, XData.Web.Client, ConnectionModule;
type
TFViewDeviceManager = class(TWebForm)
XDataWebClient: TXDataWebClient;
pnlMessage: TWebPanel;
lblMessage: TWebLabel;
btnCloseNotification: TWebButton;
edtNewDeviceName: TWebEdit;
edtNewPhoneNumber: TWebEdit;
btnAddDevice: TWebButton;
btnLogout: TWebButton;
procedure btnLogoutClick(Sender: TObject);
procedure WebFormCreate(Sender: TObject);
procedure btnCloseNotificationClick(Sender: TObject);
procedure btnAddDeviceClick(Sender: TObject);
private
procedure ShowNotification(const AMsg: string; AIsError: Boolean = True);
procedure HideNotification;
procedure ClearTable;
procedure AddDeviceRow(const ACredentialId, AName, ADeviceType,
APhoneNumber, AUsername, AUserAgent, ARegisteredAt, AStatus,
AVerificationCode: string;
AVerificationCodeActive: Boolean);
[async] procedure LoadDevices;
[async] procedure RevokeDevice(const ACredentialId, AName: string);
[async] procedure UnrevokeDevice(const ACredentialId, AName: string);
procedure ConfirmDeleteDevice(ACredentialId, APhoneNumber,
AName: string; AIsPending: Boolean);
[async] procedure DeletePendingDevice(const APhoneNumber, AName: string);
[async] procedure DeleteDevice(ACredentialId, AName: string);
[async] procedure SendAppLink(const APhoneNumber, AName: string);
[async] procedure AddPendingDevice;
[async] procedure UpdateDeviceUsername(const ACredentialId, AUsername: string);
public
end;
var
FViewDeviceManager: TFViewDeviceManager;
implementation
uses
Auth.Service,
Utils;
{$R *.dfm}
function FormatPhoneDisplay(const AE164: string): string;
var
digits: string;
begin
if Length(AE164) = 12 then
digits := Copy(AE164, 3, 10)
else
digits := AE164;
if Length(digits) = 10 then
Result := '(' + Copy(digits,1,3) + ') ' + Copy(digits,4,3) + '-' + Copy(digits,7,4)
else
Result := AE164;
end;
procedure TFViewDeviceManager.WebFormCreate(Sender: TObject);
begin
btnLogout.Visible := AuthService.DeviceManagementMode;
HideNotification;
LoadDevices;
asm
var nameInput = document.getElementById('view.devmgr.newname');
if (nameInput) {
nameInput.addEventListener('input', function() {
nameInput.classList.remove('is-invalid');
});
}
// Format phone input on-the-fly
var inp = document.getElementById('view.devmgr.newphone');
if (inp) {
inp.addEventListener('input', function() {
inp.classList.remove('is-invalid');
var digits = inp.value.replace(/\D/g, '');
if (digits.length > 10) digits = digits.slice(0, 10);
var fmt = '';
if (digits.length > 6)
fmt = '(' + digits.slice(0,3) + ') ' + digits.slice(3,6) + '-' + digits.slice(6);
else if (digits.length > 3)
fmt = '(' + digits.slice(0,3) + ') ' + digits.slice(3);
else if (digits.length > 0)
fmt = '(' + digits;
inp.value = fmt;
});
}
var typeSelect = document.getElementById('view.devmgr.newtype');
if (typeSelect) {
typeSelect.addEventListener('change', function() {
typeSelect.classList.remove('is-invalid');
});
}
end;
end;
procedure TFViewDeviceManager.btnLogoutClick(Sender: TObject);
begin
AuthService.Logout;
window.location.reload(False);
end;
procedure TFViewDeviceManager.btnCloseNotificationClick(Sender: TObject);
begin
HideNotification;
end;
procedure TFViewDeviceManager.ShowNotification(const AMsg: string; AIsError: Boolean);
begin
lblMessage.Caption := AMsg;
asm
var el = document.getElementById('view.devmgr.message');
if (el) {
el.classList.remove('alert-danger', 'alert-success');
el.classList.add(AIsError ? 'alert-danger' : 'alert-success');
el.classList.remove('d-none');
}
end;
end;
procedure TFViewDeviceManager.HideNotification;
begin
asm
var el = document.getElementById('view.devmgr.message');
if (el) el.classList.add('d-none');
end;
end;
procedure TFViewDeviceManager.ClearTable;
begin
asm
var tbody = document.getElementById('view.devmgr.tbody');
if (tbody) tbody.innerHTML = '';
var empty = document.getElementById('view.devmgr.empty');
if (empty) empty.classList.add('d-none');
end;
end;
procedure TFViewDeviceManager.AddDeviceRow(const ACredentialId, AName,
ADeviceType, APhoneNumber, AUsername, AUserAgent, ARegisteredAt, AStatus,
AVerificationCode: string; AVerificationCodeActive: Boolean);
var
tbody, tr, tdName, tdPhone, tdCode, tdUser, tdAgent, tdReg, tdStatus,
tdAccess, tdDelete, tdSend: TJSHTMLElement;
btn, btnSend, inp: TJSHTMLElement;
displayDate, displayPhone: string;
isPending, isRevoked, isActive, isIPhone, isAndroid: Boolean;
begin
tbody := TJSHTMLElement(document.getElementById('view.devmgr.tbody'));
if not Assigned(tbody) then Exit;
isPending := AStatus = 'pending';
isRevoked := AStatus = 'revoked';
isActive := AStatus = 'active';
isIPhone := SameText(ADeviceType, 'iphone');
isAndroid := SameText(ADeviceType, 'android');
displayPhone := FormatPhoneDisplay(APhoneNumber);
tr := TJSHTMLElement(document.createElement('tr'));
if isRevoked then tr.classList.add('table-secondary');
if isPending then tr.classList.add('table-warning');
// Device name
tdName := TJSHTMLElement(document.createElement('td'));
if AName <> '' then
tdName.innerText := AName
else
tdName.innerHTML := '<em class="text-muted">unnamed</em>';
tr.appendChild(tdName);
// Phone number
tdPhone := TJSHTMLElement(document.createElement('td'));
tdPhone.innerText := displayPhone;
tr.appendChild(tdPhone);
// Section: Verification code
tdCode := TJSHTMLElement(document.createElement('td'));
if isPending and (AVerificationCode <> '') then
begin
if AVerificationCodeActive then
tdCode.innerHTML := '<span class="font-monospace">' + AVerificationCode +
'</span> <span class="badge bg-success">Active</span>'
else
tdCode.innerHTML := '<span class="font-monospace">' + AVerificationCode +
'</span> <span class="badge bg-secondary">Inactive</span>';
end
else if isPending then
tdCode.innerHTML := '<em class="text-muted small">Not sent</em>'
else
tdCode.innerHTML := '<em class="text-muted small">—</em>';
tr.appendChild(tdCode);
// Username — editable for active devices
tdUser := TJSHTMLElement(document.createElement('td'));
if isActive then
begin
tdUser.innerHTML :=
'<div>' +
'<input type="text" class="form-control form-control-sm devmgr-username-input" ' +
'style="max-width:110px;" value="' + AUsername + '" ' +
'placeholder="username">' +
'</div>';
inp := TJSHTMLElement(tdUser.querySelector('.devmgr-username-input'));
if Assigned(inp) then
inp.addEventListener('change', TJSRawEventHandler(
procedure(Event: TJSEvent)
begin
UpdateDeviceUsername(ACredentialId, string(TJSHTMLInputElement(inp).value));
end));
end
else if AUsername <> '' then
tdUser.innerText := AUsername
else
tdUser.innerHTML := '<em class="text-muted small">—</em>';
tr.appendChild(tdUser);
// User agent (truncated)
tdAgent := TJSHTMLElement(document.createElement('td'));
if not isPending then
begin
tdAgent.setAttribute('title', AUserAgent);
tdAgent.style.setProperty('max-width', '220px');
tdAgent.style.setProperty('overflow', 'hidden');
tdAgent.style.setProperty('text-overflow', 'ellipsis');
tdAgent.style.setProperty('white-space', 'nowrap');
tdAgent.innerText := AUserAgent;
end
else
tdAgent.innerHTML := '<em class="text-muted small">awaiting registration</em>';
tr.appendChild(tdAgent);
// Registered at
displayDate := ARegisteredAt;
if Length(displayDate) >= 19 then
displayDate := Copy(displayDate, 1, 19).Replace('T', ' ');
tdReg := TJSHTMLElement(document.createElement('td'));
if not isPending then
tdReg.innerText := displayDate
else
tdReg.innerHTML := '<em class="text-muted small">—</em>';
tr.appendChild(tdReg);
// Status badge
tdStatus := TJSHTMLElement(document.createElement('td'));
if isPending then
tdStatus.innerHTML := '<span class="badge bg-warning text-dark">Pending</span>'
else if isRevoked then
tdStatus.innerHTML := '<span class="badge bg-secondary">Revoked</span>'
else
tdStatus.innerHTML := '<span class="badge bg-success">Active</span>';
tr.appendChild(tdStatus);
// Section: Access action
tdAccess := TJSHTMLElement(document.createElement('td'));
if isRevoked then
begin
btn := TJSHTMLElement(document.createElement('button'));
btn.className := 'btn btn-outline-success btn-sm';
btn.innerText := 'Unrevoke';
btn.addEventListener('click', procedure(Event: TJSMouseEvent)
begin
UnrevokeDevice(ACredentialId, AName);
end);
tdAccess.appendChild(btn);
end
else if isActive then
begin
btn := TJSHTMLElement(document.createElement('button'));
btn.className := 'btn btn-danger btn-sm';
btn.innerText := 'Revoke';
btn.addEventListener('click', procedure(Event: TJSMouseEvent)
begin
RevokeDevice(ACredentialId, AName);
end);
tdAccess.appendChild(btn);
end
else
tdAccess.innerHTML := '<span class="text-muted">—</span>';
tr.appendChild(tdAccess);
// Section: Delete action
tdDelete := TJSHTMLElement(document.createElement('td'));
btn := TJSHTMLElement(document.createElement('button'));
btn.className := 'btn btn-outline-danger btn-sm';
btn.innerText := 'Delete';
btn.addEventListener('click', procedure(Event: TJSMouseEvent)
begin
ConfirmDeleteDevice(ACredentialId, APhoneNumber, AName, isPending);
end);
tdDelete.appendChild(btn);
tr.appendChild(tdDelete);
// Section: Send link action
tdSend := TJSHTMLElement(document.createElement('td'));
if (not isRevoked) and (APhoneNumber <> '') and (isIPhone or isAndroid) then
begin
btnSend := TJSHTMLElement(document.createElement('button'));
btnSend.className := 'btn btn-outline-primary btn-sm';
btnSend.innerText := 'Send Link';
btnSend.addEventListener('click', procedure(Event: TJSMouseEvent)
begin
if isAndroid then
ShowInformationModal('Android App',
'Android app installation is not available yet.')
else
SendAppLink(APhoneNumber, AName);
end);
tdSend.appendChild(btnSend);
end
else
tdSend.innerHTML := '<span class="text-muted">—</span>';
tr.appendChild(tdSend);
tbody.appendChild(tr);
end;
procedure TFViewDeviceManager.LoadDevices;
var
resp: TXDataClientResponse;
list: TJSObject;
data: TJSArray;
item: TJSObject;
i, count: Integer;
begin
ClearTable;
HideNotification;
try
resp := await(XDataWebClient.RawInvokeAsync('IApiService.GetDeviceList', []));
list := TJSObject(resp.Result);
data := TJSArray(list['data']);
count := Integer(list['count']);
if count = 0 then
begin
asm
var el = document.getElementById('view.devmgr.empty');
if (el) el.classList.remove('d-none');
end;
Exit;
end;
for i := 0 to data.Length - 1 do
begin
item := TJSObject(data[i]);
AddDeviceRow(
string(item['credential_id']),
string(item['device_name']),
string(item['device_type']),
string(item['phone_number']),
string(item['username']),
string(item['user_agent']),
string(item['registered_at']),
string(item['status']),
string(item['verification_code']),
JS.toBoolean(item['verification_code_active'])
);
end;
except
on E: Exception do
ShowNotification('Failed to load devices: ' + E.Message);
end;
end;
procedure TFViewDeviceManager.RevokeDevice(const ACredentialId, AName: string);
var
resp: TXDataClientResponse;
res: TJSObject;
status: string;
begin
try
resp := await(XDataWebClient.RawInvokeAsync('IApiService.RevokeDevice', [ACredentialId]));
res := TJSObject(resp.Result);
status := string(res['status']);
if status = 'ok' then
begin
ShowNotification('Device "' + AName + '" has been revoked.', False);
LoadDevices;
end
else
ShowNotification(string(res['message']));
except
on E: Exception do
ShowNotification('Revoke failed: ' + E.Message);
end;
end;
procedure TFViewDeviceManager.ConfirmDeleteDevice(ACredentialId,
APhoneNumber, AName: string; AIsPending: Boolean);
begin
ShowConfirmationModal(
'Are you sure you want to permanently delete device "' + AName +
'"? This cannot be undone.',
'Cancel', 'Delete',
procedure(Confirmed: Boolean)
begin
if not Confirmed then
Exit;
if AIsPending then
DeletePendingDevice(APhoneNumber, AName)
else
DeleteDevice(ACredentialId, AName);
end);
end;
procedure TFViewDeviceManager.DeletePendingDevice(const APhoneNumber, AName: string);
var
resp: TXDataClientResponse;
res: TJSObject;
status: string;
begin
try
resp := await(XDataWebClient.RawInvokeAsync('IApiService.DeletePendingDevice', [APhoneNumber]));
res := TJSObject(resp.Result);
status := string(res['status']);
if status = 'ok' then
begin
ShowNotification('Pending device "' + AName + '" removed.', False);
LoadDevices;
end
else
ShowNotification(string(res['message']));
except
on E: Exception do
ShowNotification('Delete failed: ' + E.Message);
end;
end;
procedure TFViewDeviceManager.DeleteDevice(ACredentialId, AName: string);
var
resp: TXDataClientResponse;
res: TJSObject;
status: string;
begin
try
resp := await(XDataWebClient.RawInvokeAsync('IApiService.DeleteDevice', [ACredentialId]));
res := TJSObject(resp.Result);
status := string(res['status']);
if status = 'ok' then
begin
ShowNotification('Device "' + AName + '" has been deleted.', False);
LoadDevices;
end
else
ShowNotification(string(res['message']));
except
on E: Exception do
ShowNotification('Delete failed: ' + E.Message);
end;
end;
procedure TFViewDeviceManager.SendAppLink(const APhoneNumber, AName: string);
var
resp: TXDataClientResponse;
res: TJSObject;
status: string;
begin
try
resp := await(XDataWebClient.RawInvokeAsync('IApiService.SendAppLink', [APhoneNumber]));
res := TJSObject(resp.Result);
status := string(res['status']);
if status = 'ok' then
ShowNotification('App link sent to "' + AName + '" via SMS.', False)
else
ShowNotification(string(res['message']));
except
on E: Exception do
ShowNotification('Send failed: ' + E.Message);
end;
end;
procedure TFViewDeviceManager.UnrevokeDevice(const ACredentialId, AName: string);
var
resp: TXDataClientResponse;
res: TJSObject;
status: string;
begin
try
resp := await(XDataWebClient.RawInvokeAsync('IApiService.UnrevokeDevice', [ACredentialId]));
res := TJSObject(resp.Result);
status := string(res['status']);
if status = 'ok' then
begin
ShowNotification('Device "' + AName + '" has been restored.', False);
LoadDevices;
end
else
ShowNotification(string(res['message']));
except
on E: Exception do
ShowNotification('Unrevoke failed: ' + E.Message);
end;
end;
procedure TFViewDeviceManager.btnAddDeviceClick(Sender: TObject);
begin
AddPendingDevice;
end;
procedure TFViewDeviceManager.UpdateDeviceUsername(const ACredentialId, AUsername: string);
var
resp: TXDataClientResponse;
res: TJSObject;
status: string;
begin
try
resp := await(XDataWebClient.RawInvokeAsync('IApiService.UpdateDeviceUsername', [ACredentialId, AUsername]));
res := TJSObject(resp.Result);
status := string(res['status']);
if status = 'ok' then
ShowNotification('Username updated.', False)
else
ShowNotification(string(res['message']));
except
on E: Exception do
ShowNotification('Update failed: ' + E.Message);
end;
end;
procedure TFViewDeviceManager.AddPendingDevice;
var
deviceName, phoneNumber, deviceType: string;
nameElement, phoneElement, typeElement: TJSHTMLElement;
resp: TXDataClientResponse;
res: TJSObject;
status: string;
valid: Boolean;
begin
deviceName := Trim(edtNewDeviceName.Text);
phoneNumber := Trim(edtNewPhoneNumber.Text);
nameElement := TJSHTMLElement(document.getElementById('view.devmgr.newname'));
phoneElement := TJSHTMLElement(document.getElementById('view.devmgr.newphone'));
typeElement := TJSHTMLElement(document.getElementById('view.devmgr.newtype'));
deviceType := '';
if Assigned(typeElement) then
deviceType := Trim(string(TJSHTMLSelectElement(typeElement).value));
valid := True;
if Assigned(nameElement) then
nameElement.classList.remove('is-invalid');
if Assigned(phoneElement) then
phoneElement.classList.remove('is-invalid');
if Assigned(typeElement) then
typeElement.classList.remove('is-invalid');
if deviceName = '' then
begin
if Assigned(nameElement) then
nameElement.classList.add('is-invalid');
valid := False;
end;
if phoneNumber = '' then
begin
if Assigned(phoneElement) then
phoneElement.classList.add('is-invalid');
valid := False;
end;
if deviceType = '' then
begin
if Assigned(typeElement) then
typeElement.classList.add('is-invalid');
valid := False;
end;
if not valid then
Exit;
try
resp := await(XDataWebClient.RawInvokeAsync('IApiService.AddPendingDevice',
[deviceName, phoneNumber, deviceType]));
res := TJSObject(resp.Result);
status := string(res['status']);
if status = 'ok' then
begin
edtNewDeviceName.Text := '';
edtNewPhoneNumber.Text := '';
TJSHTMLSelectElement(typeElement).value := '';
ShowNotification('Device "' + deviceName + '" added — waiting for user to register.', False);
LoadDevices;
end
else
ShowNotification(string(res['message']));
except
on E: Exception do
ShowNotification('Add failed: ' + E.Message);
end;
end;
end.
emiMobileServer/Clients/BFD/Web/View.DeviceRegistration.dfm 0 → 100644
object FViewDeviceRegistration: TFViewDeviceRegistration
Width = 640
Height = 480
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
ParentFont = False
OnCreate = WebFormCreate
object edtPhoneNumber: TWebEdit
Left = 240
Top = 136
Width = 121
Height = 21
ElementID = 'view.devicereg.edtphonenumber'
HeightPercent = 100.000000000000000000
TextHint = '(303) 555-1234'
WidthPercent = 100.000000000000000000
end
object btnRegister: TWebButton
Left = 240
Top = 163
Width = 121
Height = 25
Caption = 'Send Code'
ElementID = 'view.devicereg.btnregister'
HeightPercent = 100.000000000000000000
TabOrder = 1
WidthPercent = 100.000000000000000000
OnClick = btnRegisterClick
end
object pnlVerification: TWebPanel
Left = 240
Top = 194
Width = 177
Height = 58
ElementID = 'view.devicereg.verification'
TabOrder = 2
object edtVerificationCode: TWebEdit
Left = 0
Top = 0
Width = 121
Height = 21
ElementID = 'view.devicereg.edtverificationcode'
HeightPercent = 100.000000000000000000
TextHint = 'Six-digit code'
WidthPercent = 100.000000000000000000
end
object btnVerifyCode: TWebButton
Left = 0
Top = 27
Width = 121
Height = 25
Caption = 'Verify and Register'
ElementID = 'view.devicereg.btnverify'
HeightPercent = 100.000000000000000000
TabOrder = 1
WidthPercent = 100.000000000000000000
OnClick = btnVerifyCodeClick
end
end
object pnlMessage: TWebPanel
Left = 240
Top = 65
Width = 121
Height = 33
ElementID = 'view.devicereg.message'
TabOrder = 3
object lblMessage: TWebLabel
Left = 16
Top = 11
Width = 42
Height = 13
Caption = 'Message'
ElementID = 'view.devicereg.message.label'
HeightPercent = 100.000000000000000000
WidthPercent = 100.000000000000000000
end
object btnCloseNotification: TWebButton
Left = 96
Top = 3
Width = 22
Height = 25
ElementID = 'view.devicereg.message.button'
HeightPercent = 100.000000000000000000
WidthPercent = 100.000000000000000000
OnClick = btnCloseNotificationClick
end
end
object XDataWebClient: TXDataWebClient
Connection = DMConnection.AuthConnection
Left = 492
Top = 102
end
end
emiMobileServer/Clients/BFD/Web/View.DeviceRegistration.html 0 → 100644
<div class="container">
<nav class="navbar navbar-light bg-light border rounded-bottom"
style="--bs-border-color: #d6d6d6; --bs-border-radius: 0.25rem;">
<div class="container-fluid">
<a id="view.devicereg.apptitle"
class="navbar-brand text-secondary small"
href="index.html">
emiMobile
</a>
</div>
</nav>
<div class="row justify-content-center mt-4">
<div class="col-12 col-sm-10 col-md-8 col-lg-5 col-xl-4">
<div class="card shadow-sm">
<div class="card-header">
<h5 class="card-title mb-0 text-center">
Register This Device
</h5>
</div>
<div class="card-body">
<!-- Notification bar -->
<div id="view.devicereg.message"
class="alert alert-danger d-flex align-items-start d-none mb-3"
role="alert">
<span id="view.devicereg.message.label" class="me-auto"></span>
<button id="view.devicereg.message.button"
type="button"
class="btn-close ms-2"
aria-label="Close"></button>
</div>
<p class="text-muted small mb-3">
This browser has not been registered for emiMobile access.
Enter the phone number your administrator registered for this device,
then click <strong>Send Code</strong>.
</p>
<div class="mb-3">
<label class="form-label small text-muted">Phone number</label>
<input id="view.devicereg.edtphonenumber"
class="form-control"
type="tel"
placeholder="(303) 555-1234"
autofocus>
</div>
<div id="view.devicereg.verification" class="mb-3 d-none">
<label class="form-label small text-muted">Verification code</label>
<input id="view.devicereg.edtverificationcode"
class="form-control mb-2"
type="text"
inputmode="numeric"
autocomplete="one-time-code"
maxlength="6"
placeholder="Six-digit code">
<button id="view.devicereg.btnverify"
class="btn btn-primary w-100">
Verify and Register
</button>
</div>
<div class="mb-3">
<p class="text-muted small mb-1">Browser</p>
<p id="view.devicereg.useragent"
class="text-muted small text-truncate"
style="max-width:100%; overflow:hidden; white-space:nowrap;"></p>
</div>
<button id="view.devicereg.btnregister"
class="btn btn-outline-primary w-100">
Send Code
</button>
</div>
<div class="card-footer text-muted small">
Registration is required once per browser. Clearing browser storage will require re-registration.
</div>
</div>
</div>
</div>
</div>
emiMobileServer/Clients/BFD/Web/View.DeviceRegistration.pas 0 → 100644
unit View.DeviceRegistration;
interface
uses
System.SysUtils, System.Classes, WEBLib.Graphics, WEBLib.Controls, WEBLib.Forms, WEBLib.Dialogs,
Vcl.Controls, Vcl.StdCtrls, WEBLib.StdCtrls, WEBLib.JSON,
JS, XData.Web.Connection, WEBLib.ExtCtrls,
App.Types, ConnectionModule, XData.Web.Client;
type
TFViewDeviceRegistration = class(TWebForm)
edtPhoneNumber: TWebEdit;
btnRegister: TWebButton;
pnlVerification: TWebPanel;
edtVerificationCode: TWebEdit;
btnVerifyCode: TWebButton;
pnlMessage: TWebPanel;
lblMessage: TWebLabel;
btnCloseNotification: TWebButton;
XDataWebClient: TXDataWebClient;
procedure btnRegisterClick(Sender: TObject);
procedure btnVerifyCodeClick(Sender: TObject);
procedure btnCloseNotificationClick(Sender: TObject);
procedure WebFormCreate(Sender: TObject);
private
FRegistrationProc: TSuccessProc;
procedure ShowNotification(const AMsg: string; AIsError: Boolean = True);
procedure HideNotification;
procedure SetBusy(ABusy: Boolean);
procedure SetVerifyBusy(ABusy: Boolean);
procedure DoWebAuthnCreate(APhoneNumber, AChallenge, AChallengeToken: string);
procedure DoSimpleKeyCreate(APhoneNumber, AChallengeToken: string);
public
class procedure Display(ARegistrationProc: TSuccessProc);
end;
var
FViewDeviceRegistration: TFViewDeviceRegistration;
implementation
uses
Auth.Service,
View.ErrorPage;
{$R *.dfm}
class procedure TFViewDeviceRegistration.Display(ARegistrationProc: TSuccessProc);
begin
if Assigned(FViewDeviceRegistration) then
FViewDeviceRegistration.Free;
FViewDeviceRegistration := TFViewDeviceRegistration.CreateNew;
FViewDeviceRegistration.FRegistrationProc := ARegistrationProc;
end;
procedure TFViewDeviceRegistration.WebFormCreate(Sender: TObject);
var
userAgent: string;
begin
HideNotification;
pnlVerification.ElementHandle.classList.add('d-none');
userAgent := '';
asm
userAgent = navigator.userAgent;
end;
asm
var el = document.getElementById('view.devicereg.useragent');
if (el) el.textContent = userAgent;
// Format phone number on-the-fly as the user types
var inp = document.getElementById('view.devicereg.edtphonenumber');
if (inp) {
inp.addEventListener('input', function() {
var digits = inp.value.replace(/\D/g, '');
if (digits.length > 10) digits = digits.slice(0, 10);
var formatted = '';
if (digits.length > 6)
formatted = '(' + digits.slice(0,3) + ') ' + digits.slice(3,6) + '-' + digits.slice(6);
else if (digits.length > 3)
formatted = '(' + digits.slice(0,3) + ') ' + digits.slice(3);
else if (digits.length > 0)
formatted = '(' + digits;
inp.value = formatted;
});
}
end;
end;
procedure TFViewDeviceRegistration.SetBusy(ABusy: Boolean);
begin
asm
var btn = document.getElementById('view.devicereg.btnregister');
if (btn) {
btn.disabled = ABusy;
btn.textContent = ABusy ? 'Sending...' : 'Send Code';
}
end;
end;
procedure TFViewDeviceRegistration.SetVerifyBusy(ABusy: Boolean);
begin
asm
var btn = document.getElementById('view.devicereg.btnverify');
if (btn) {
btn.disabled = ABusy;
btn.textContent = ABusy ? 'Verifying...' : 'Verify and Register';
}
end;
end;
procedure TFViewDeviceRegistration.btnRegisterClick(Sender: TObject);
var
phoneNumber: string;
procedure OnCodeSent;
begin
SetBusy(False);
edtPhoneNumber.Enabled := False;
pnlVerification.ElementHandle.classList.remove('d-none');
edtVerificationCode.SetFocus;
ShowNotification('Verification code sent. Enter the six-digit code to continue.', False);
end;
procedure OnCodeError(AMsg: string);
begin
SetBusy(False);
ShowNotification(AMsg);
end;
begin
phoneNumber := Trim(edtPhoneNumber.Text);
if phoneNumber = '' then
begin
ShowNotification('Please enter your phone number.');
Exit;
end;
SetBusy(True);
HideNotification;
AuthService.BeginRegistration(phoneNumber, @OnCodeSent, @OnCodeError);
end;
procedure TFViewDeviceRegistration.btnVerifyCodeClick(Sender: TObject);
var
phoneNumber, verificationCode: string;
i: Integer;
procedure OnVerified(AChallenge, AChallengeToken: string);
begin
DoSimpleKeyCreate(phoneNumber, AChallengeToken);
end;
procedure OnVerifyError(AMsg: string);
begin
SetVerifyBusy(False);
ShowNotification(AMsg);
end;
begin
phoneNumber := Trim(edtPhoneNumber.Text);
verificationCode := Trim(edtVerificationCode.Text);
if Length(verificationCode) <> 6 then
begin
ShowNotification('Please enter the six-digit verification code.');
Exit;
end;
for i := 1 to Length(verificationCode) do
if (verificationCode[i] < '0') or (verificationCode[i] > '9') then
begin
ShowNotification('Please enter the six-digit verification code.');
Exit;
end;
SetVerifyBusy(True);
HideNotification;
AuthService.VerifyRegistrationCode(phoneNumber, verificationCode,
@OnVerified, @OnVerifyError);
end;
procedure TFViewDeviceRegistration.DoWebAuthnCreate(
APhoneNumber, AChallenge, AChallengeToken: string);
var
phoneNumber, challenge, challengeToken: string;
procedure OnCompleteOK;
begin
FRegistrationProc;
end;
procedure OnCompleteError(AMsg: string);
begin
SetVerifyBusy(False);
ShowNotification(AMsg);
end;
procedure OnCredential(ACredentialId, AAttestationObject, AClientDataJSON: string);
begin
AuthService.CompleteRegistration(
phoneNumber, ACredentialId, AAttestationObject, AClientDataJSON, challengeToken,
@OnCompleteOK, @OnCompleteError
);
end;
procedure OnWebAuthnError(AMsg: string);
begin
SetVerifyBusy(False);
ShowNotification(AMsg);
end;
begin
phoneNumber := APhoneNumber;
challenge := AChallenge;
challengeToken := AChallengeToken;
asm
(function() {
function b64urlToArr(b64) {
b64 = b64.replace(/-/g, '+').replace(/_/g, '/');
while (b64.length % 4) b64 += '=';
var bin = atob(b64);
var arr = new Uint8Array(bin.length);
for (var i = 0; i < bin.length; i++) arr[i] = bin.charCodeAt(i);
return arr;
}
function arrToB64url(buf) {
var bin = String.fromCharCode.apply(null, new Uint8Array(buf));
return btoa(bin).replace(/\+/g, '-').replace(/\//g, '_').replace(/=/g, '');
}
var userId = new Uint8Array(16);
crypto.getRandomValues(userId);
navigator.credentials.create({
publicKey: {
challenge: b64urlToArr(challenge),
rp: { id: window.location.hostname, name: 'emiMobile' },
user: { id: userId, name: 'emimobile-user', displayName: 'emiMobile User' },
pubKeyCredParams: [{ alg: -7, type: 'public-key' }],
timeout: 60000,
attestation: 'none',
authenticatorSelection: {
userVerification: 'required',
residentKey: 'preferred'
}
}
}).then(function(cred) {
var credId = arrToB64url(cred.rawId);
var attObj = arrToB64url(cred.response.attestationObject);
var cdJson = arrToB64url(cred.response.clientDataJSON);
OnCredential(credId, attObj, cdJson);
}).catch(function(err) {
OnWebAuthnError('WebAuthn error: ' + err.message);
});
})();
end;
end;
procedure TFViewDeviceRegistration.DoSimpleKeyCreate(APhoneNumber, AChallengeToken: string);
var
phoneNumber, challengeToken, deviceKey: string;
procedure OnCompleteOK;
begin
FRegistrationProc;
end;
procedure OnCompleteError(AMsg: string);
begin
SetVerifyBusy(False);
ShowNotification(AMsg);
end;
begin
phoneNumber := APhoneNumber;
challengeToken := AChallengeToken;
deviceKey := '';
asm
var keyBytes = new Uint8Array(32);
crypto.getRandomValues(keyBytes);
var bin = String.fromCharCode.apply(null, keyBytes);
deviceKey = btoa(bin).replace(/\+/g, '-').replace(/\//g, '_').replace(/=/g, '');
end;
if deviceKey = '' then
begin
SetVerifyBusy(False);
ShowNotification('Failed to generate device key.');
Exit;
end;
AuthService.CompleteRegistrationSimple(
phoneNumber, deviceKey, challengeToken,
@OnCompleteOK, @OnCompleteError
);
end;
procedure TFViewDeviceRegistration.btnCloseNotificationClick(Sender: TObject);
begin
HideNotification;
end;
procedure TFViewDeviceRegistration.ShowNotification(const AMsg: string; AIsError: Boolean);
begin
if AMsg <> '' then
begin
lblMessage.Caption := AMsg;
asm
var el = document.getElementById('view.devicereg.message');
if (el) {
el.classList.remove('alert-danger', 'alert-warning');
el.classList.add(AIsError ? 'alert-danger' : 'alert-warning');
el.classList.remove('d-none');
}
end;
end;
end;
procedure TFViewDeviceRegistration.HideNotification;
begin
asm
var el = document.getElementById('view.devicereg.message');
if (el) el.classList.add('d-none');
end;
end;
end.
emiMobileServer/Clients/BFD/Web/View.Login.dfm
......@@ -41,6 +41,18 @@ object FViewLogin: TFViewLogin
TextHint = 'Password'
WidthPercent = 100.000000000000000000
end
object btnShowPassword: TWebButton
Left = 367
Top = 163
Width = 50
Height = 21
Caption = 'Show'
ElementID = 'view.login.btnshowpassword'
HeightPercent = 100.000000000000000000
TabOrder = 2
WidthPercent = 100.000000000000000000
OnClick = btnShowPasswordClick
end
object btnLogin: TWebButton
Left = 240
Top = 217
......@@ -49,7 +61,7 @@ object FViewLogin: TFViewLogin
Caption = 'Login'
ElementID = 'view.login.btnlogin'
HeightPercent = 100.000000000000000000
TabOrder = 2
TabOrder = 3
WidthPercent = 100.000000000000000000
OnClick = btnLoginClick
end
......@@ -59,7 +71,7 @@ object FViewLogin: TFViewLogin
Width = 121
Height = 33
ElementID = 'view.login.message'
TabOrder = 3
TabOrder = 4
object lblMessage: TWebLabel
Left = 16
Top = 11
......@@ -97,6 +109,18 @@ object FViewLogin: TFViewLogin
DisplayText = 'BUF - Buffalo Police Department'
end>
end
object btnPasskeyLogin: TWebButton
Left = 240
Top = 244
Width = 121
Height = 25
Caption = 'Sign In with Passkey'
ElementID = 'view.login.btnpasskeylogin'
HeightPercent = 100.000000000000000000
TabOrder = 5
WidthPercent = 100.000000000000000000
OnClick = btnPasskeyLoginClick
end
object XDataWebClient: TXDataWebClient
Connection = DMConnection.AuthConnection
Left = 492
......
emiMobileServer/Clients/BFD/Web/View.Login.html
......@@ -29,31 +29,53 @@
aria-label="Close"></button>
</div>
<div class="mb-3">
<input id="view.login.edtusername"
class="form-control"
type="text"
placeholder="Username"
autofocus>
<!-- Auto-login section (shown when device has a stored username) -->
<div id="view.login.autosection" class="d-none">
<p class="text-center text-muted mb-1 small">Signing in as</p>
<p id="view.login.autouserlabel"
class="text-center fw-semibold fs-5 mb-3"></p>
<button id="view.login.btnpasskeylogin"
class="btn btn-primary w-100 mb-2">
Sign In with Passkey
</button>
<div class="text-center">
<a id="view.login.switchmanual" href="#"
class="small text-muted">Use a different account</a>
</div>
</div>
<div class="mb-3">
<input id="view.login.edtpassword"
class="form-control"
type="password"
placeholder="Password">
</div>
<div class="mb-3">
<select id="view.login.edtagency" class="form-select">
<!-- populated dynamically -->
</select>
<!-- Manual login section -->
<div id="view.login.manualsection">
<div class="mb-3">
<input id="view.login.edtusername"
class="form-control"
type="text"
placeholder="Username"
autofocus>
</div>
<div class="input-group mb-3">
<input id="view.login.edtpassword"
class="form-control"
type="password"
placeholder="Password">
<button id="view.login.btnshowpassword"
class="btn btn-outline-secondary"
type="button">Show</button>
</div>
<div class="mb-3">
<select id="view.login.edtagency" class="form-select">
<!-- populated dynamically -->
</select>
</div>
<button id="view.login.btnlogin"
class="btn btn-primary w-100">
Login
</button>
</div>
<button id="view.login.btnlogin"
class="btn btn-primary w-100">
Login
</button>
</div>
<div class="card-footer text-muted small">
Please use your lems username &amp; password to login.
<div class="card-footer text-muted small d-flex justify-content-between">
<span>Please use your lems username &amp; password to login.</span>
<span id="view.login.version" class="opacity-75"></span>
</div>
</div>
</div>
......
emiMobileServer/Clients/BFD/Web/View.Login.pas
unit View.Login;
unit View.Login;
interface
uses
System.SysUtils, System.Classes, WEBLib.Graphics, WEBLib.Controls, WEBLib.Forms, WEBLib.Dialogs,
Vcl.Controls, Vcl.StdCtrls, WEBLib.StdCtrls, WEBLib.JSON,
Vcl.Controls, Vcl.StdCtrls, WEBLib.StdCtrls, WEBLib.JSON, Web,
JS, XData.Web.Connection, WEBLib.ExtCtrls,
App.Types, ConnectionModule, XData.Web.Client;
......@@ -13,21 +13,31 @@ type
WebLabel1: TWebLabel;
edtUsername: TWebEdit;
edtPassword: TWebEdit;
btnShowPassword: TWebButton;
btnLogin: TWebButton;
btnPasskeyLogin: TWebButton;
pnlMessage: TWebPanel;
lblMessage: TWebLabel;
btnCloseNotification: TWebButton;
XDataWebClient: TXDataWebClient;
lucbAgency: TWebLookupComboBox;
procedure btnLoginClick(Sender: TObject);
procedure btnPasskeyLoginClick(Sender: TObject);
procedure btnShowPasswordClick(Sender: TObject);
procedure btnCloseNotificationClick(Sender: TObject);
procedure WebFormCreate(Sender: TObject);
private
FLoginProc: TSuccessProc;
FMessage: string;
FAutoUsername: string;
FAutoAgency: string;
procedure ShowNotification(Notification: string);
procedure HideNotification;
procedure GetAgencyConfigList;
procedure SetBusy(ABusy: Boolean);
procedure DoWebAuthnGet(AUser, APassword, AAgency, ACredentialId,
AChallenge, AChallengeToken: string);
procedure DoPasskeyAutoLogin(ACredentialId, AChallenge, AChallengeToken: string);
public
class procedure Display(LoginProc: TSuccessProc); overload;
class procedure Display(LoginProc: TSuccessProc; AMsg: string); overload;
......@@ -63,36 +73,353 @@ begin
FViewLogin.FLoginProc := LoginProc;
end;
procedure TFViewLogin.WebFormCreate(Sender: TObject);
var
el: TJSElement;
credId: string;
procedure OnDeviceUser(AUsername, AAgency: string);
begin
FAutoUsername := AUsername;
FAutoAgency := AAgency;
if AuthService.IsSimpleKey then
Exit;
if AUsername <> '' then
begin
asm
var autoSection = document.getElementById('view.login.autosection');
var manualSection = document.getElementById('view.login.manualsection');
var lbl = document.getElementById('view.login.autouserlabel');
if (autoSection) autoSection.classList.remove('d-none');
if (manualSection) manualSection.classList.add('d-none');
if (lbl) lbl.textContent = AUsername;
// "Use a different account" — pure JS show/hide
var lnk = document.getElementById('view.login.switchmanual');
if (lnk) {
lnk.addEventListener('click', function(e) {
e.preventDefault();
document.getElementById('view.login.autosection').classList.add('d-none');
document.getElementById('view.login.manualsection').classList.remove('d-none');
});
}
end;
end;
end;
begin
// lblAppTitle.Caption := 'EM Systems - webCharms App ver 0.9.2.22';
GetAgencyConfigList();
GetAgencyConfigList;
el := Document.getElementById('view.login.version');
if Assigned(el) then
TJSHtmlElement(el).innerText := 'v' + TDMConnection.clientVersion;
if FMessage <> '' then
ShowNotification(FMessage)
else
HideNotification;
if AuthService.DeviceManagementMode then
begin
el := Document.getElementById('view.login.title');
if Assigned(el) then
TJSHtmlElement(el).innerText := 'Device Management Sign In';
Exit;
end;
credId := AuthService.GetCredentialId;
if credId <> '' then
AuthService.GetDeviceUser(credId, @OnDeviceUser);
end;
procedure TFViewLogin.SetBusy(ABusy: Boolean);
begin
asm
var btn = document.getElementById('view.login.btnlogin');
if (btn) {
btn.disabled = ABusy;
btn.textContent = ABusy ? 'Verifying...' : 'Login';
}
end;
end;
procedure TFViewLogin.btnLoginClick(Sender: TObject);
var
user, password, agency, credentialId: string;
procedure LoginSuccess;
procedure OnLoginOK;
begin
FLoginProc;
end;
procedure LoginError(AMsg: string);
procedure OnLoginError(AMsg: string);
begin
SetBusy(False);
ShowNotification('Login Error: ' + AMsg);
end;
procedure OnBeginOK(AChallenge, AChallengeToken: string);
begin
if AuthService.IsSimpleKey then
AuthService.LoginPasswordAndSimpleKey(
user, password, agency, credentialId, AChallengeToken,
@OnLoginOK, @OnLoginError)
else
DoWebAuthnGet(user, password, agency, credentialId, AChallenge, AChallengeToken);
end;
procedure OnBeginError(AMsg: string);
begin
SetBusy(False);
ShowNotification('Login Error: ' + AMsg);
end;
begin
AuthService.Login(
edtUsername.Text, edtPassword.Text, lucbAgency.Value,
@LoginSuccess,
@LoginError
);
user := edtUsername.Text;
password := edtPassword.Text;
agency := lucbAgency.Value;
if (user = '') or (password = '') or (agency = '') then
begin
ShowNotification('Please enter a username, password, and agency.');
Exit;
end;
if AuthService.DeviceManagementMode then
begin
SetBusy(True);
HideNotification;
AuthService.LoginDeviceManager(user, password, agency, @OnLoginOK, @OnLoginError);
Exit;
end;
credentialId := AuthService.GetCredentialId;
if credentialId = '' then
begin
ShowNotification('Device not registered. Please restart the app to register this device.');
Exit;
end;
SetBusy(True);
HideNotification;
AuthService.BeginAuthentication(credentialId, @OnBeginOK, @OnBeginError);
end;
procedure TFViewLogin.btnPasskeyLoginClick(Sender: TObject);
var
credId: string;
procedure OnLoginOK;
begin
FLoginProc;
end;
procedure OnLoginError(AMsg: string);
begin
SetBusy(False);
ShowNotification('Login Error: ' + AMsg);
asm
var autoSection = document.getElementById('view.login.autosection');
var manualSection = document.getElementById('view.login.manualsection');
if (autoSection) autoSection.classList.add('d-none');
if (manualSection) manualSection.classList.remove('d-none');
end;
end;
procedure OnBeginOK(AChallenge, AChallengeToken: string);
begin
if AuthService.IsSimpleKey then
AuthService.LoginDeviceKey(credId, AChallengeToken, @OnLoginOK, @OnLoginError)
else
DoPasskeyAutoLogin(credId, AChallenge, AChallengeToken);
end;
procedure OnBeginError(AMsg: string);
begin
SetBusy(False);
ShowNotification('Login Error: ' + AMsg);
end;
begin
credId := AuthService.GetCredentialId;
if credId = '' then
begin
ShowNotification('Device not registered. Please restart the app.');
Exit;
end;
SetBusy(True);
HideNotification;
AuthService.BeginAuthentication(credId, @OnBeginOK, @OnBeginError);
end;
procedure TFViewLogin.DoWebAuthnGet(AUser, APassword, AAgency, ACredentialId,
AChallenge, AChallengeToken: string);
var
user, password, agency, credentialId, challenge, challengeToken: string;
procedure OnLoginOK;
begin
FLoginProc;
end;
procedure OnLoginError(AMsg: string);
begin
SetBusy(False);
ShowNotification('Login Error: ' + AMsg);
end;
procedure OnAssertion(AAuthData, AClientDataJSON, ASignature: string);
begin
AuthService.LoginWithAssertion(
user, password, agency, credentialId, challengeToken,
AAuthData, AClientDataJSON, ASignature,
@OnLoginOK, @OnLoginError
);
end;
procedure OnWebAuthnError(AMsg: string);
begin
SetBusy(False);
ShowNotification('Login Error: ' + AMsg);
end;
begin
user := AUser;
password := APassword;
agency := AAgency;
credentialId := ACredentialId;
challenge := AChallenge;
challengeToken := AChallengeToken;
asm
(function() {
function b64urlToArr(b64) {
b64 = b64.replace(/-/g, '+').replace(/_/g, '/');
while (b64.length % 4) b64 += '=';
var bin = atob(b64);
var arr = new Uint8Array(bin.length);
for (var i = 0; i < bin.length; i++) arr[i] = bin.charCodeAt(i);
return arr;
}
function arrToB64url(buf) {
var bin = String.fromCharCode.apply(null, new Uint8Array(buf));
return btoa(bin).replace(/\+/g, '-').replace(/\//g, '_').replace(/=/g, '');
}
navigator.credentials.get({
publicKey: {
challenge: b64urlToArr(challenge),
rpId: window.location.hostname,
allowCredentials: [{
id: b64urlToArr(credentialId),
type: 'public-key'
}],
timeout: 60000,
userVerification: 'required'
}
}).then(function(assertion) {
var authData = arrToB64url(assertion.response.authenticatorData);
var cdJson = arrToB64url(assertion.response.clientDataJSON);
var sig = arrToB64url(assertion.response.signature);
OnAssertion(authData, cdJson, sig);
}).catch(function(err) {
OnWebAuthnError('WebAuthn error: ' + err.message);
});
})();
end;
end;
procedure TFViewLogin.DoPasskeyAutoLogin(ACredentialId, AChallenge, AChallengeToken: string);
var
credentialId, challenge, challengeToken: string;
procedure OnLoginOK;
begin
FLoginProc;
end;
procedure OnLoginError(AMsg: string);
begin
SetBusy(False);
ShowNotification('Login Error: ' + AMsg);
// If auto-login fails, fall back to manual form
asm
var autoSection = document.getElementById('view.login.autosection');
var manualSection = document.getElementById('view.login.manualsection');
if (autoSection) autoSection.classList.add('d-none');
if (manualSection) manualSection.classList.remove('d-none');
end;
end;
procedure OnAssertion(AAuthData, AClientDataJSON, ASignature: string);
begin
AuthService.LoginAutomatic(
credentialId, challengeToken,
AAuthData, AClientDataJSON, ASignature,
@OnLoginOK, @OnLoginError
);
end;
procedure OnWebAuthnError(AMsg: string);
begin
SetBusy(False);
ShowNotification('Passkey Error: ' + AMsg);
end;
begin
credentialId := ACredentialId;
challenge := AChallenge;
challengeToken := AChallengeToken;
asm
(function() {
function b64urlToArr(b64) {
b64 = b64.replace(/-/g, '+').replace(/_/g, '/');
while (b64.length % 4) b64 += '=';
var bin = atob(b64);
var arr = new Uint8Array(bin.length);
for (var i = 0; i < bin.length; i++) arr[i] = bin.charCodeAt(i);
return arr;
}
function arrToB64url(buf) {
var bin = String.fromCharCode.apply(null, new Uint8Array(buf));
return btoa(bin).replace(/\+/g, '-').replace(/\//g, '_').replace(/=/g, '');
}
navigator.credentials.get({
publicKey: {
challenge: b64urlToArr(challenge),
rpId: window.location.hostname,
allowCredentials: [{ id: b64urlToArr(credentialId), type: 'public-key' }],
timeout: 60000,
userVerification: 'required'
}
}).then(function(assertion) {
var authData = arrToB64url(assertion.response.authenticatorData);
var cdJson = arrToB64url(assertion.response.clientDataJSON);
var sig = arrToB64url(assertion.response.signature);
OnAssertion(authData, cdJson, sig);
}).catch(function(err) {
OnWebAuthnError('WebAuthn error: ' + err.message);
});
})();
end;
end;
procedure TFViewLogin.btnShowPasswordClick(Sender: TObject);
begin
if edtPassword.PasswordChar = #0 then
begin
edtPassword.PasswordChar := '*';
edtPassword.ElementHandle.setAttribute('type', 'password');
btnShowPassword.Caption := 'Show';
end
else
begin
edtPassword.PasswordChar := #0;
edtPassword.ElementHandle.setAttribute('type', 'text');
btnShowPassword.Caption := 'Hide';
end;
end;
......@@ -101,8 +428,6 @@ procedure TFViewLogin.GetAgencyConfigList;
procedure OnLoad(Response: TXDataClientResponse);
var
jsResponse: TJSObject;
count: Integer;
returned: Integer;
jsArray: TJSArray;
jsObject: TJSObject;
agency: string;
......@@ -110,17 +435,14 @@ procedure TFViewLogin.GetAgencyConfigList;
i: Integer;
begin
jsResponse := TJSObject(Response.Result);
count := Integer(jsResponse['count']);
returned := Integer(jsResponse['returned']);
jsArray := TJSArray(TJSObject(Response.Result)['data']);
jsArray := TJSArray(TJSObject(Response.Result)['data']);
lucbAgency.LookupValues.Clear;
for i := 0 to jsArray.Length - 1 do
begin
jsObject := TJSObject( jsArray[i] );
agency := string( jsObject['agency'] );
name := string( jsObject['name'] );
lucbAgency.LookupValues.AddPair( agency, agency + ' - ' + name );
jsObject := TJSObject(jsArray[i]);
agency := string(jsObject['agency']);
name := string(jsObject['name']);
lucbAgency.LookupValues.AddPair(agency, agency + ' - ' + name);
end;
end;
......@@ -136,23 +458,20 @@ begin
);
end;
procedure TFViewLogin.ShowNotification(Notification: string);
begin
if Notification <> '' then
begin
lblMessage.Caption := Notification;
pnlMessage.ElementHandle.hidden := False;
pnlMessage.ElementHandle.classList.remove('d-none');
end;
end;
procedure TFViewLogin.HideNotification;
begin
pnlMessage.ElementHandle.hidden := True;
pnlMessage.ElementHandle.classList.add('d-none');
end;
procedure TFViewLogin.btnCloseNotificationClick(Sender: TObject);
begin
HideNotification;
......
emiMobileServer/Clients/BFD/Web/View.Main.dfm
......@@ -221,6 +221,21 @@ object FViewMain: TFViewMain
WidthPercent = 100.000000000000000000
OnClick = btnLogoutClick
end
object btnDevices: TWebButton
Left = 320
Top = 66
Width = 96
Height = 25
Caption = 'Devices'
ChildOrder = 17
ElementID = 'btn_devices'
ElementFont = efCSS
HeightStyle = ssAuto
HeightPercent = 100.000000000000000000
Visible = False
WidthPercent = 100.000000000000000000
OnClick = btnDevicesClick
end
object xdwcBadgeCounts: TXDataWebClient
Connection = DMConnection.ApiConnection
Left = 44
......
emiMobileServer/Clients/BFD/Web/View.Main.html
<div class="d-flex flex-column vh-100">
<!-- Top Nav -->
<nav class="navbar navbar-light bg-primary border-light text-light py-2 flex-shrink-0">
<nav id="top_nav" class="navbar navbar-light bg-primary border-light text-light py-2 flex-shrink-0">
<div class="container-fluid">
<!-- App title + current view title -->
......@@ -11,11 +11,34 @@
<span id="lbl_main_title" class="navbar-brand text-light mb-0 ms-1"></span>
</div>
<!-- Right: Connection / Logout -->
<!-- Right: Connection / Menu -->
<div class="d-flex align-items-center gap-2 ms-auto">
<span id="view.main.lblconnection" class="navbar-text text-light small"></span>
<button id="btn_logout" type="button" class="btn btn-outline-light btn-sm">Logout</button>
<span id="view.main.lblconnection"
class="connection-status connection-status-connecting"
role="status"
aria-live="polite"
aria-atomic="true"
aria-label="Live updates: Connecting"
title="Live updates: Connecting">
<span class="connection-status-dot" aria-hidden="true"></span>
<span id="view.main.lblconnectiontext" class="connection-status-text">Connecting</span>
</span>
<div class="dropdown">
<button type="button"
class="btn btn-outline-light btn-sm"
data-bs-toggle="dropdown"
aria-expanded="false"
aria-label="Menu">
<i class="fas fa-bars" aria-hidden="true"></i>
</button>
<ul class="dropdown-menu dropdown-menu-end">
<li><button id="btn_devices" type="button" class="dropdown-item d-none">Devices</button></li>
<li><button id="btn_logout" type="button" class="dropdown-item">Logout</button></li>
<li><hr class="dropdown-divider"></li>
<li><span id="view.main.version" class="dropdown-item-text text-muted small"></span></li>
</ul>
</div>
</div>
</div>
</nav>
......@@ -64,7 +87,7 @@
<i class="far fa-map me-1"></i>Map
</button>
<button id="view.main.btncomplaints" type="button" class="btn btn-primary position-relative">
<i class="fa fa-exclamation-circle me-1"></i>Incidents
<i class="fa fa-exclamation-circle me-1"></i>Complaints
<span id="view.main.badgecomplaints"
class="position-absolute top-0 start-100 translate-middle mt-1 badge rounded-pill bg-danger">0</span>
</button>
......@@ -78,6 +101,23 @@
</nav>
</div>
<!-- Information modal -->
<div class="modal fade" id="main_information_modal" tabindex="-1"
aria-labelledby="main_information_modal_title" aria-hidden="true">
<div class="modal-dialog modal-dialog-centered modal-sm mx-auto px-3">
<div class="modal-content shadow-lg">
<div class="modal-header">
<h5 class="modal-title" id="main_information_modal_title">Information</h5>
<button type="button" class="btn-close" data-bs-dismiss="modal" aria-label="Close"></button>
</div>
<div class="modal-body fs-6 fw-bold" id="main_information_modal_body"></div>
<div class="modal-footer">
<button type="button" class="btn btn-primary w-100" data-bs-dismiss="modal">OK</button>
</div>
</div>
</div>
</div>
<!-- Spinner -->
<div id="spinner" class="position-absolute top-50 start-50 translate-middle d-none">
<div class="lds-roller">
......
emiMobileServer/Clients/BFD/Web/View.Main.pas
unit View.Main;
unit View.Main;
interface
......@@ -33,6 +33,7 @@ type
pnlArchive: TWebPanel;
btnArchiveModalClose: TWebButton;
btnLogout: TWebButton;
btnDevices: TWebButton;
procedure WebFormCreate(Sender: TObject);
procedure mnuLogoutClick(Sender: TObject);
procedure lblLogoutClick(Sender: TObject);
......@@ -44,6 +45,7 @@ type
procedure btnDetailsModalCloseClick(Sender: TObject);
procedure btnArchiveModalCloseClick(Sender: TObject);
procedure btnLogoutClick(Sender: TObject);
procedure btnDevicesClick(Sender: TObject);
private
{ Private declarations }
FUserInfo: string;
......@@ -54,7 +56,11 @@ type
FDetailsForm: TWebForm;
FArchiveForm: TWebForm;
FLogoutProc: TLogoutProc;
FBadgeRefreshInProgress: Boolean;
FBadgeRefreshPending: Boolean;
FPendingWsBadgeCounts: TJSObject;
[async] procedure RefreshBadgesAsync;
procedure ApplyBadgeCounts(aData: TJSObject);
procedure ShowUnitDetails(UnitId: string);
procedure SetHeaderTitle(const title: string);
procedure HideDetailsModal;
......@@ -68,6 +74,10 @@ type
procedure HandleWsComplaintMap(aData: TJSObject);
procedure HandleWsUnitList(aData: TJSObject);
procedure HandleWsComplaintList(aData: TJSObject);
procedure HandleWsConnectionState(AState: TWsConnectionState);
procedure HandleWsRecoveryRequired;
procedure HandleWsAuthenticationExpired;
procedure ResyncLiveData;
type TActivePanel = (apNone, apMap, apUnits, apComplaints);
var
......@@ -84,6 +94,7 @@ type
public
{ Public declarations }
destructor Destroy; override;
class procedure Display(LogoutProc: TLogoutProc);
procedure ShowForm( AFormClass: TWebFormClass );
procedure ShowComplaintDetails(ComplaintId: string);
......@@ -110,6 +121,7 @@ uses
View.EditUser,
View.UnitDetails,
View.ComplaintArchive,
View.DeviceManager,
Utils;
{$R *.dfm}
......@@ -121,9 +133,15 @@ const
procedure TFViewMain.WebFormCreate(Sender: TObject);
var
userName: string;
el: TJSElement;
begin
userName := JS.toString(AuthService.TokenPayload.Properties['user_name']);
lblUsername.Caption := ' ' + userName.ToLower + ' ';
el := Document.getElementById('view.main.version');
if Assigned(el) then
TJSHtmlElement(el).innerText := 'Version ' + TDMConnection.clientVersion;
FChildForm := nil;
FDetailsForm := nil;
FArchiveForm := nil;
......@@ -133,9 +151,21 @@ begin
FMapRefreshTick := 0;
FUnitsRefreshTick := 0;
FComplaintsRefreshTick := 0;
FBadgeRefreshInProgress := False;
FBadgeRefreshPending := False;
FPendingWsBadgeCounts := nil;
if (not (JS.toBoolean(AuthService.TokenPayload.Properties['user_admin']))) then
lblUsers.Visible := false;
if JS.toBoolean(AuthService.TokenPayload.Properties['user_admin']) then
begin
// Show admin controls
btnDevices.Visible := True;
asm
var el = document.getElementById('btn_devices');
if (el) el.classList.remove('d-none');
end;
end
else
lblUsers.Visible := False;
Utils.HideSpinner('spinner');
......@@ -169,9 +199,27 @@ begin
dmWebsocket.OnComplaintMap := HandleWsComplaintMap;
dmWebsocket.OnUnitList := HandleWsUnitList;
dmWebsocket.OnComplaintList := HandleWsComplaintList;
dmWebsocket.OnStateChanged := HandleWsConnectionState;
dmWebsocket.OnRecoveryRequired := HandleWsRecoveryRequired;
dmWebsocket.OnAuthenticationExpired := HandleWsAuthenticationExpired;
dmWebsocket.Connect(DMConnection.WsUrl);
end;
destructor TFViewMain.Destroy;
begin
if Assigned(dmWebsocket) and (dmWebsocket.Owner = Self) then
begin
dmWebsocket.Stop;
dmWebsocket.Free;
dmWebsocket := nil;
end;
if FViewMain = Self then
FViewMain := nil;
inherited;
end;
procedure TFViewMain.SetActivePanel(panel: TActivePanel);
begin
FActivePanel := panel;
......@@ -278,6 +326,11 @@ begin
FLogoutProc;
end;
procedure TFViewMain.btnDevicesClick(Sender: TObject);
begin
ShowForm(TFViewDeviceManager);
end;
procedure TFViewMain.btnMapClick(Sender: TObject);
begin
ShowForm(TFViewMap);
......@@ -462,10 +515,13 @@ end;
// WebSocket push handlers
// ---------------------------------------------------------------------------
procedure TFViewMain.HandleWsBadgeCounts(aData: TJSObject);
procedure TFViewMain.ApplyBadgeCounts(aData: TJSObject);
var
el: TJSElement;
begin
if not Assigned(aData) then
Exit;
el := Document.getElementById('view.main.badgecomplaints');
if Assigned(el) then
TJSHtmlElement(el).innerText := string(aData['BadgeComplaints']);
......@@ -475,6 +531,17 @@ begin
TJSHtmlElement(el).innerText := string(aData['BadgeUnits']);
end;
procedure TFViewMain.HandleWsBadgeCounts(aData: TJSObject);
begin
if FBadgeRefreshInProgress then
begin
FPendingWsBadgeCounts := aData;
Exit;
end;
ApplyBadgeCounts(aData);
end;
procedure TFViewMain.HandleWsUnitMap(aData: TJSObject);
begin
if Assigned(FMapForm) then
......@@ -499,6 +566,83 @@ begin
FComplaintsForm.ApplyWsData(aData);
end;
procedure TFViewMain.HandleWsConnectionState(AState: TWsConnectionState);
var
statusElement: TJSHTMLElement;
textElement: TJSHTMLElement;
statusText: string;
statusClass: string;
begin
case AState of
wcsConnecting:
begin
statusText := 'Connecting';
statusClass := 'connecting';
end;
wcsConnected:
begin
statusText := 'Connected';
statusClass := 'connected';
end;
wcsReconnecting:
begin
statusText := 'Reconnecting';
statusClass := 'reconnecting';
end;
wcsOffline:
begin
statusText := 'Offline';
statusClass := 'offline';
end;
else
begin
statusText := 'Disconnected';
statusClass := 'stopped';
end;
end;
statusElement := TJSHTMLElement(Document.getElementById('view.main.lblconnection'));
if Assigned(statusElement) then
begin
statusElement.setAttribute('class', 'connection-status connection-status-' + statusClass);
statusElement.setAttribute('aria-label', 'Live updates: ' + statusText);
statusElement.setAttribute('title', 'Live updates: ' + statusText);
end;
textElement := TJSHTMLElement(Document.getElementById('view.main.lblconnectiontext'));
if Assigned(textElement) then
textElement.innerText := statusText;
end;
procedure TFViewMain.HandleWsRecoveryRequired;
begin
ResyncLiveData;
end;
procedure TFViewMain.HandleWsAuthenticationExpired;
begin
if Assigned(dmWebsocket) then
dmWebsocket.Stop;
if Assigned(FLogoutProc) then
FLogoutProc('Your session has expired. Please sign in again.');
end;
procedure TFViewMain.ResyncLiveData;
begin
if (not AuthService.Authenticated) or AuthService.TokenExpired then
begin
HandleWsAuthenticationExpired;
Exit;
end;
Console.Log('WS: resynchronizing live data');
RefreshBadgesAsync;
Inc(FGlobalRefreshTick);
RefreshActivePanelFromTimer;
end;
// ---------------------------------------------------------------------------
procedure TFViewMain.tmrBadgeCountsTimer(Sender: TObject);
......@@ -522,25 +666,52 @@ var
badgeObj: TJSObject;
el: TJSElement;
begin
if FBadgeRefreshInProgress then
begin
FBadgeRefreshPending := True;
Exit;
end;
FBadgeRefreshInProgress := True;
try
resp := await(xdwcBadgeCounts.RawInvokeAsync('IApiService.GetBadgeCounts', []));
badgeObj := TJSObject(resp.Result);
el := Document.getElementById('view.main.badgecomplaints');
if Assigned(el) then
TJSHtmlElement(el).innerText := string(badgeObj['BadgeComplaints']);
el := Document.getElementById('view.main.badgeunits');
if Assigned(el) then
TJSHtmlElement(el).innerText := string(badgeObj['BadgeUnits']);
except
on E: Exception do
try
resp := await(xdwcBadgeCounts.RawInvokeAsync('IApiService.GetBadgeCounts', []));
badgeObj := TJSObject(resp.Result);
if Assigned(FPendingWsBadgeCounts) then
begin
ApplyBadgeCounts(FPendingWsBadgeCounts);
FPendingWsBadgeCounts := nil;
end
else
ApplyBadgeCounts(badgeObj);
except
on E: Exception do
begin
if Assigned(FPendingWsBadgeCounts) then
begin
ApplyBadgeCounts(FPendingWsBadgeCounts);
FPendingWsBadgeCounts := nil;
end
else
begin
el := Document.getElementById('view.main.badgecomplaints');
if Assigned(el) then TJSHtmlElement(el).innerText := '�';
el := Document.getElementById('view.main.badgeunits');
if Assigned(el) then TJSHtmlElement(el).innerText := '�';
end;
Console.Log('Badge refresh error: ' + E.Message);
end;
end;
finally
FBadgeRefreshInProgress := False;
if FBadgeRefreshPending then
begin
el := Document.getElementById('view.main.badgecomplaints');
if Assigned(el) then TJSHtmlElement(el).innerText := '�';
el := Document.getElementById('view.main.badgeunits');
if Assigned(el) then TJSHtmlElement(el).innerText := '�';
Console.Log('Badge refresh error: ' + E.Message);
FBadgeRefreshPending := False;
RefreshBadgesAsync;
end;
end;
end;
......
emiMobileServer/Clients/BFD/Web/bfdEmiMobile.dpr
program bfdEmiMobile;
program bfdEmiMobile;
{$R *.dres}
uses
Vcl.Forms,
System.SysUtils,
XData.Web.Connection,
Auth.Service in 'Auth.Service.pas',
App.Types in 'App.Types.pas',
......@@ -26,19 +27,25 @@ uses
uMapFilters in 'uMapFilters.pas',
View.ComplaintArchive in 'View.ComplaintArchive.pas' {FViewComplaintArchive: TWebForm} {*.html},
uMapMarkerJs in 'uMapMarkerJs.pas',
Module.Websocket in 'Module.Websocket.pas' {dmWebsocket: TDataModule};
Module.Websocket in 'Module.Websocket.pas' {dmWebsocket: TDataModule},
View.DeviceRegistration in 'View.DeviceRegistration.pas' {FViewDeviceRegistration: TWebForm} {*.html},
View.DeviceManager in 'View.DeviceManager.pas' {FViewDeviceManager: TWebForm} {*.html};
{$R *.res}
procedure DisplayLoginView(AMessage: string = ''); forward;
procedure DisplayDeviceRegistrationView; forward;
procedure DisplayMainView;
procedure ConnectProc;
begin
if Assigned(FViewLogin) then
FViewLogin.Free;
TFViewMain.Display(@DisplayLoginView);
FreeAndNil(FViewLogin);
if AuthService.DeviceManagementMode then
FViewDeviceManager := TFViewDeviceManager.CreateNew
else
TFViewMain.Display(@DisplayLoginView);
end;
begin
......@@ -52,11 +59,29 @@ procedure DisplayLoginView(AMessage: string);
begin
AuthService.Logout;
DMConnection.ApiConnection.Connected := False;
if Assigned(FViewDeviceManager) then
FreeAndNil(FViewDeviceManager);
if Assigned(FViewMain) then
FViewMain.Free;
TFViewLogin.Display(@DisplayMainView, AMessage);
end;
procedure DisplayDeviceRegistrationView;
procedure OnRegistered;
begin
// Device registered — proceed to login
if Assigned(FViewDeviceRegistration) then
FViewDeviceRegistration.Free;
TFViewLogin.Display(@DisplayMainView);
end;
begin
if Assigned(FViewDeviceRegistration) then
FViewDeviceRegistration.Free;
TFViewDeviceRegistration.Display(@OnRegistered);
end;
procedure UnauthorizedAccessProc(AMessage: string);
begin
DisplayLoginView(AMessage);
......@@ -64,40 +89,24 @@ end;
procedure StartApplication;
begin
DMConnection.SetClientConfig(
procedure(Success: Boolean; ErrorMessage: string)
begin
if Success then
begin
if (not AuthService.Authenticated) or AuthService.TokenExpired then
DisplayLoginView
else
DisplayMainView;
end
else
begin
asm
var dlg = document.createElement("dialog");
dlg.classList.add("shadow", "rounded", "border", "p-4");
dlg.style.maxWidth = "500px";
dlg.style.width = "90%";
dlg.style.fontFamily = "system-ui, sans-serif";
dlg.innerHTML =
"<h5 class='fw-bold mb-3 text-danger'>emiMobile</h5>" +
"<p class='mb-3' style='white-space: pre-wrap;'>" + ErrorMessage + "</p>" +
"<div class='text-end'>" +
"<button id='refreshBtn' class='btn btn-primary'>Reload</button></div>";
document.body.appendChild(dlg);
dlg.showModal();
document.getElementById("refreshBtn").addEventListener("click", function () {
location.reload(true); // Hard refresh
});
end;
end;
end);
if AuthService.DeviceManagementMode then
begin
DisplayLoginView;
Exit;
end;
// Step 1: device must be registered before login is allowed
if not AuthService.IsDeviceRegistered then
begin
DisplayDeviceRegistrationView;
Exit;
end;
// Step 2: normal JWT auth check
if (not AuthService.Authenticated) or AuthService.TokenExpired then
DisplayLoginView
else
DisplayMainView;
end;
......
emiMobileServer/Clients/BFD/Web/bfdEmiMobile.dproj
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<ProjectGuid>{DB6F5DBF-7E4B-45DA-AFFA-6C8DF15BA740}</ProjectGuid>
<ProjectGuid>{12815250-11C0-427B-ABB7-1200FCC6061E}</ProjectGuid>
<ProjectVersion>20.4</ProjectVersion>
<FrameworkType>VCL</FrameworkType>
<MainSource>bfdEmiMobile.dpr</MainSource>
......@@ -200,6 +200,14 @@
<FormType>dfm</FormType>
<DesignClass>TDataModule</DesignClass>
</DCCReference>
<DCCReference Include="View.DeviceRegistration.pas">
<Form>FViewDeviceRegistration</Form>
<DesignClass>TWebForm</DesignClass>
</DCCReference>
<DCCReference Include="View.DeviceManager.pas">
<Form>FViewDeviceManager</Form>
<DesignClass>TWebForm</DesignClass>
</DCCReference>
<None Include="index.html"/>
<None Include="css\app.css"/>
<None Include="css\spinner.css"/>
......@@ -493,13 +501,13 @@
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile LocalName="Win32\Debug\webCharms.exe" Configuration="Debug" Class="ProjectOutput"/>
<DeployFile LocalName="Win32\Debug\bfdEmiMobile.exe" Configuration="Debug" Class="ProjectOutput">
<Platform Name="Win32">
<RemoteName>bfdEmiMobile.exe</RemoteName>
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile LocalName="Win32\Debug\webCharms.exe" Configuration="Debug" Class="ProjectOutput"/>
<DeployFile LocalName="Win32\Debug\webEnvoyCalls.exe" Configuration="Debug" Class="ProjectOutput"/>
<DeployFile LocalName="assets\bpddistricts-updated.geojson" Configuration="Debug" Class="ProjectFile">
<Platform Name="Win32">
......
emiMobileServer/Clients/BFD/Web/config/config.json
{
"AuthUrl" : "http://localhost:2009/emimobile/auth/",
"ApiUrl" : "http://localhost:2009/emimobile/api/",
"AppUrl" : "http://localhost:2009/emimobile/app/",
"AuthUrl" : "http://localhost:2001/emsys/emimobile/auth/",
"ApiUrl" : "http://localhost:2001/emsys/emimobile/api/",
"AppUrl" : "http://localhost:2001/emsys/emimobile/app/",
"WsUrl": "ws://localhost:8091/"
}
emiMobileServer/Clients/BFD/Web/css/app.css
......@@ -121,3 +121,68 @@ html, body {
.connection-status {
display: inline-flex;
align-items: center;
gap: 0.35rem;
min-height: 1.75rem;
padding: 0.2rem 0.55rem;
border: 1px solid rgba(255, 255, 255, 0.35);
border-radius: 999px;
color: #fff;
font-size: 0.75rem;
font-weight: 600;
line-height: 1;
white-space: nowrap;
}
.connection-status-dot {
width: 0.55rem;
height: 0.55rem;
flex: 0 0 auto;
border-radius: 50%;
background-color: #adb5bd;
}
.connection-status-connected .connection-status-dot {
background-color: #75d995;
box-shadow: 0 0 0 0.14rem rgba(117, 217, 149, 0.2);
}
.connection-status-connecting .connection-status-dot,
.connection-status-reconnecting .connection-status-dot {
background-color: #ffd166;
animation: connection-status-pulse 1.4s ease-in-out infinite;
}
.connection-status-offline .connection-status-dot,
.connection-status-stopped .connection-status-dot {
background-color: #ff8b94;
}
@keyframes connection-status-pulse {
0%, 100% { opacity: 0.45; }
50% { opacity: 1; }
}
@media (max-width: 430px) {
.connection-status {
width: 1.75rem;
justify-content: center;
padding-right: 0;
padding-left: 0;
}
.connection-status-text {
display: none;
}
}
@media (prefers-reduced-motion: reduce) {
.connection-status-connecting .connection-status-dot,
.connection-status-reconnecting .connection-status-dot {
animation: none;
}
}
emiMobileServer/Clients/WC/Server/WC.Api.Database.pas
......@@ -3,6 +3,7 @@ unit WC.Api.Database;
interface
uses
Client.Data, System.JSON, System.StrUtils, XData.Sys.Exceptions,
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, DAAlerter,
......@@ -10,7 +11,7 @@ uses
UniAlerter;
type
TWCAPIDataModule = class(TDataModule)
TWCAPIDataModule = class(TClientData)
uqMapUnits: TUniQuery;
uqUnitList: TUniQuery;
uqComplaintUnits: TUniQuery;
......@@ -218,12 +219,26 @@ type
FCADUpdate: Integer;
FUpdateListenerFailed: Integer;
public
procedure ConfigureQueryTimeouts; override;
function GetBadgeCounts: TJSONObject; override;
function GetComplaintMap(FormatComplaintNumber: Boolean = True): TJSONObject; override;
function GetUnitMap: TJSONObject; override;
function GetComplaintList: TJSONObject; override;
function GetUnitList: TJSONObject; override;
function GetComplaintDetails(ComplaintId: string): TJSONObject; override;
function GetComplaintArchiveDetails(ComplaintId: string): TJSONObject; override;
function GetComplaintMemos(CfsId: string): TJSONObject; override;
function GetComplaintHistory(ComplaintId: string): TJSONObject; override;
function GetComplaintContacts(ComplaintId: string): TJSONObject; override;
function GetComplaintWarnings(ComplaintId: string): TJSONObject; override;
function GetUnitLogs(UnitId: string): TJSONObject; override;
function GetUnitDetails(UnitId: string): TJSONObject; override;
function HandleUniqueFilenames(const category: string): string;
function BadgeCounts(const BaseQuery: TUniQuery): Integer;
function EnsureConnected: Boolean;
function StartUpdateListener: Boolean;
function EnsureConnected: Boolean; override;
function StartUpdateListener: Boolean; override;
procedure MarkCADUpdate;
function ConsumeCADUpdate: Boolean;
function ConsumeCADUpdate: Boolean; override;
end;
var
......@@ -241,13 +256,7 @@ begin
FCADUpdate := 0;
FUpdateListenerFailed := 0;
ucENTCAD.ProviderName := 'PostgreSQL';
ucENTCAD.Server := IniEntries.DatabaseServer;
ucENTCAD.Port := IniEntries.DatabasePort;
ucENTCAD.Database := IniEntries.DatabaseName;
ucENTCAD.Username := IniEntries.DatabaseUsername;
ucENTCAD.Password := IniEntries.DatabasePassword;
ucENTCAD.LoginPrompt := False;
IniEntries.ConfigureConnection(ucENTCAD);
end;
......@@ -444,4 +453,1174 @@ begin
end;
end;
procedure TWCAPIDataModule.ConfigureQueryTimeouts;
const
COMMAND_TIMEOUT_SECONDS = 15;
begin
uqBadgeCounts.SpecificOptions.Values['CommandTimeout'] := IntToStr(COMMAND_TIMEOUT_SECONDS);
uqMapUnits.SpecificOptions.Values['CommandTimeout'] := IntToStr(COMMAND_TIMEOUT_SECONDS);
uqMapComplaintUnitsList.SpecificOptions.Values['CommandTimeout'] := IntToStr(COMMAND_TIMEOUT_SECONDS);
uqMapComplaints.SpecificOptions.Values['CommandTimeout'] := IntToStr(COMMAND_TIMEOUT_SECONDS);
uqUnitList.SpecificOptions.Values['CommandTimeout'] := IntToStr(COMMAND_TIMEOUT_SECONDS);
uqComplaintList.SpecificOptions.Values['CommandTimeout'] := IntToStr(COMMAND_TIMEOUT_SECONDS);
end;
function TWCAPIDataModule.GetBadgeCounts: TJSONObject;
begin
Logger.Log(3, '---TWCAPIDataModule.GetBadgeCounts initiated');
Result := TJSONObject.Create;
try
try
with uqBadgeCounts do
begin
Open;
try
Result.AddPair('BadgeComplaints', TJSONNumber.Create(FieldByName('COMPLAINTS').AsInteger));
Result.AddPair('BadgeUnits', TJSONNumber.Create(FieldByName('UNITS').AsInteger));
finally
Close;
end;
end;
except
on E: Exception do
begin
Logger.Log(2, '---TWCAPIDataModule.GetBadgeCounts error: ' + E.ClassName + ': ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load badge counts');
end;
end;
Logger.Log(3, '---TWCAPIDataModule.GetBadgeCounts End');
except
Result.Free;
raise;
end;
end;
function TWCAPIDataModule.GetComplaintMap(FormatComplaintNumber: Boolean): TJSONObject;
var
data: TJSONArray;
emitted: Integer;
item: TJSONObject;
UnitsByComplaintMap: TObjectDictionary<string, TJSONArray>;
complaintId: string;
complaintNumber: string;
unitArray: TJSONArray;
unitStatus: string;
latestUpdate: TDateTime;
unitObj: TJSONObject;
begin
Logger.Log(3, '---TWCAPIDataModule.GetComplaintMap initiated');
Result := TJSONObject.Create;
try
data := TJSONArray.Create;
Result.AddPair('data', data);
UnitsByComplaintMap := TObjectDictionary<string, TJSONArray>.Create([doOwnsValues]);
try
try
uqMapComplaintUnitsList.Close;
uqMapComplaintUnitsList.Open;
try
while not uqMapComplaintUnitsList.Eof do
begin
complaintId := uqMapComplaintUnitsListCOMPLAINTID.AsString;
if not UnitsByComplaintMap.TryGetValue(complaintId, unitArray) then
begin
unitArray := TJSONArray.Create;
UnitsByComplaintMap.Add(complaintId, unitArray);
end;
unitStatus := 'Dispatched';
if not uqMapComplaintUnitsListDATECLEARED.IsNull then
unitStatus := 'Cleared'
else if not uqMapComplaintUnitsListDATEARRIVED.IsNull then
unitStatus := 'On Scene'
else if not uqMapComplaintUnitsListDATERESPONDED.IsNull then
unitStatus := 'Enroute';
latestUpdate := 0;
if not uqMapComplaintUnitsListDATEDISPATCHED.IsNull then
latestUpdate := uqMapComplaintUnitsListDATEDISPATCHED.AsDateTime;
if (not uqMapComplaintUnitsListDATERESPONDED.IsNull) and
(uqMapComplaintUnitsListDATERESPONDED.AsDateTime > latestUpdate) then
latestUpdate := uqMapComplaintUnitsListDATERESPONDED.AsDateTime;
if (not uqMapComplaintUnitsListDATEARRIVED.IsNull) and
(uqMapComplaintUnitsListDATEARRIVED.AsDateTime > latestUpdate) then
latestUpdate := uqMapComplaintUnitsListDATEARRIVED.AsDateTime;
if (not uqMapComplaintUnitsListDATECLEARED.IsNull) and
(uqMapComplaintUnitsListDATECLEARED.AsDateTime > latestUpdate) then
latestUpdate := uqMapComplaintUnitsListDATECLEARED.AsDateTime;
unitObj := TJSONObject.Create;
unitArray.AddElement(unitObj);
unitObj.AddPair('Unit', uqMapComplaintUnitsListUNITNAME.AsString);
unitObj.AddPair('Status', unitStatus);
if latestUpdate <> 0 then
unitObj.AddPair('Updated', FormatDateTime('yyyy-mm-dd hh:nn:ss', latestUpdate))
else
unitObj.AddPair('Updated', '');
uqMapComplaintUnitsList.Next;
end;
finally
uqMapComplaintUnitsList.Close;
end;
emitted := 0;
uqMapComplaints.Close;
uqMapComplaints.Open;
try
while not uqMapComplaints.Eof do
begin
item := TJSONObject.Create;
data.AddElement(item);
item.AddPair('ComplaintId', uqMapComplaintsCOMPLAINTID.AsString);
complaintNumber := uqMapComplaintsCOMPLAINT.AsString;
// Note: Preserve the existing HTTP formatting and raw WebSocket value.
if FormatComplaintNumber then
begin
complaintNumber := Trim(complaintNumber);
if Length(complaintNumber) > 2 then
complaintNumber := Copy(complaintNumber, 1, 2) + '-' + Copy(complaintNumber, 3, MaxInt);
end;
item.AddPair('Complaint', complaintNumber);
item.AddPair('DispatchDistrict', uqMapComplaintsDISPATCHDISTRICT.AsString);
item.AddPair('Agency', uqMapComplaintsAGENCY.AsString);
item.AddPair('AgencyName', uqMapComplaintsAGENCY_NAME.AsString);
item.AddPair('DispatchCodeDesc', uqMapComplaintsDISPATCH_CODE_DESC.AsString);
item.AddPair('DispatchCodeCategory', uqMapComplaintsDISPATCHCODECATEGORY.AsString);
item.AddPair('Priority', uqMapComplaintsPRIORITY.AsString);
item.AddPair('PriorityBadge', uqMapComplaintspriorityBadge.AsString);
item.AddPair('ComplaintStatusKey', uqMapComplaintscomplaintStatusKey.AsString);
item.AddPair('pngName', uqMapComplaintspngName.AsString);
item.AddPair('Address', uqMapComplaintsADDRESS.AsString);
item.AddPair('Business', uqMapComplaintsBUSINESS.AsString);
complaintId := uqMapComplaintsCOMPLAINTID.AsString;
if UnitsByComplaintMap.TryGetValue(complaintId, unitArray) then
item.AddPair('Units', TJSONArray(unitArray.Clone))
else
item.AddPair('Units', TJSONArray.Create);
item.AddPair('Lat', TJSONNumber.Create(uqMapComplaintsLAT.AsFloat));
item.AddPair('Lng', TJSONNumber.Create(uqMapComplaintsLNG.AsFloat));
Inc(emitted);
uqMapComplaints.Next;
end;
finally
uqMapComplaints.Close;
end;
Result.AddPair('count', TJSONNumber.Create(data.Count));
Result.AddPair('returned', TJSONNumber.Create(emitted));
Logger.Log(3, '---TWCAPIDataModule.GetComplaintMap End (returned=' + IntToStr(emitted) + ')');
except
on E: EXDataHttpException do
begin
Logger.Log(2, '---TWCAPIDataModule.GetComplaintMap http error: ' + E.ClassName + ': ' + E.Message);
raise;
end;
on E: Exception do
begin
Logger.Log(2, '---TWCAPIDataModule.GetComplaintMap error: ' + E.ClassName + ': ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load complaint map');
end;
end;
finally
UnitsByComplaintMap.Free;
end;
except
Result.Free;
raise;
end;
end;
function TWCAPIDataModule.GetUnitMap: TJSONObject;
var
data: TJSONArray;
item: TJSONObject;
unitStatus: string;
updateTimeText: string;
begin
Logger.Log(4, '---TWCAPIDataModule.GetUnitMap initiated');
Result := TJSONObject.Create;
try
data := TJSONArray.Create;
Result.AddPair('data', data);
try
with uqMapUnits do
begin
Close;
Open;
try
First;
while not Eof do
begin
if (not uqMapUnitsGPS_LATITUDE.IsNull) and (not uqMapUnitsGPS_LONGITUDE.IsNull) then
begin
item := TJSONObject.Create;
data.AddElement(item);
item.AddPair('UnitId', uqMapUnitsUNITID.AsString);
item.AddPair('UnitName', uqMapUnitsUNITNAME.AsString);
item.AddPair('UnitBadge', uqMapUnitsUNITNAME.AsString);
item.AddPair('Agency', uqMapUnitsAGENCY.AsString);
item.AddPair('AgencyName', uqMapUnitsAGENCY_NAME.AsString);
item.AddPair('AgencyType', uqMapUnitsAGENCYTYPE.AsString);
item.AddPair('Lat', TJSONNumber.Create(uqMapUnitsGPS_LATITUDE.AsFloat));
item.AddPair('Lng', TJSONNumber.Create(uqMapUnitsGPS_LONGITUDE.AsFloat));
item.AddPair('CallType', uqMapUnitsCALL_TYPE.AsString);
item.AddPair('Priority', uqMapUnitsPRIORITY.AsString);
unitStatus := uqMapUnitsUNIT_STATUS_DESC.AsString;
if Trim(unitStatus) = '' then
unitStatus := 'Available';
item.AddPair('Status', unitStatus);
updateTimeText := '';
if not uqMapUnitsUPDATE_TIME.IsNull then
updateTimeText := FormatDateTime('yyyy-mm-dd hh:nn:ss', uqMapUnitsUPDATE_TIME.AsDateTime);
item.AddPair('UpdateTime', updateTimeText);
item.AddPair('Officer1Lname', uqMapUnitsOFFICER1_LNAME.AsString);
item.AddPair('Officer1Fname', uqMapUnitsOFFICER1_FNAME.AsString);
item.AddPair('Officer1Empnum', uqMapUnitsOFFICER1_EMPNUM.AsString);
item.AddPair('Officer2Lname', uqMapUnitsOFFICER2_LNAME.AsString);
item.AddPair('Officer2Fname', uqMapUnitsOFFICER2_FNAME.AsString);
item.AddPair('Officer2Empnum', uqMapUnitsOFFICER2_EMPNUM.AsString);
item.AddPair('CanShowDetails', TJSONBool.Create(not uqMapUnitsDIS_UNITID.IsNull));
end;
Next;
end;
finally
Close;
end;
end;
Result.AddPair('count', TJSONNumber.Create(data.Count));
Result.AddPair('returned', TJSONNumber.Create(data.Count));
except
on E: EXDataHttpException do
begin
Logger.Log(2, '---TWCAPIDataModule.GetUnitMap http error: ' + E.ClassName + ': ' + E.Message);
raise;
end;
on E: Exception do
begin
Logger.Log(2, '---TWCAPIDataModule.GetUnitMap error: ' + E.ClassName + ': ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load unit map');
end;
end;
Logger.Log(4, '---TWCAPIDataModule.GetUnitMap End');
except
Result.Free;
raise;
end;
end;
function TWCAPIDataModule.GetComplaintList: TJSONObject;
var
data: TJSONArray;
lastDistrict: string;
begin
Logger.Log(3, '---TWCAPIDataModule.GetComplaintList initiated');
Result := TJSONObject.Create;
try
data := TJSONArray.Create;
Result.AddPair('data', data);
try
lastDistrict := '';
try
with uqComplaintList do
begin
Close;
Open;
(FieldByName('DATEREPORTED') as TDateTimeField).DisplayFormat := 'yyyy-mm-dd hh:nn:ss';
First;
while not Eof do
begin
var status: string;
var statusColor: string;
var statusTextColor: string;
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;
var item := TJSONObject.Create;
data.AddElement(item);
var curAgency := Trim(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);
var colorVal := uqComplaintListPRIORITY_COLOR.AsInteger;
item.AddPair('PriorityColor', '#' + IntToHex(colorVal and $FFFFFF, 6));
item.AddPair('PriorityTextColor', '#000000');
item.AddPair('ComplaintId', uqComplaintListCOMPLAINTID.AsString);
item.AddPair('Complaint', uqComplaintListcomplaintNumber.AsString);
item.AddPair('Agency', uqComplaintListAGENCY.AsString);
item.AddPair('Priority', uqComplaintListPRIORITY.AsString);
item.AddPair('DispatchCodeDesc', uqComplaintListDISPATCH_CODE_DESC.AsString);
item.AddPair('pngName', uqComplaintListpngName.AsString);
item.AddPair('Address', uqComplaintListADDRESS.AsString);
item.AddPair('Business', uqComplaintListBUSINESS.AsString);
item.AddPair('CFSId', uqComplaintListCFSID.AsString);
item.AddPair('Status', status);
item.AddPair('StatusColor', statusColor);
item.AddPair('StatusTextColor', statusTextColor);
item.AddPair('DispatchDistrict', uqComplaintListDISPATCHDISTRICT.AsString);
item.AddPair('DateReported', uqComplaintListDATEREPORTED.AsString);
Next;
end;
end;
finally
uqComplaintList.Close;
end;
Result.AddPair('count', TJSONNumber.Create(data.Count));
Result.AddPair('returned', TJSONNumber.Create(data.Count));
except
Logger.Log(2, '---TWCAPIDataModule.GetComplaintList End (error)');
raise EXDataHttpException.Create(500, 'Failed to load complaints list');
end;
Logger.Log(3, '---TWCAPIDataModule.GetComplaintList End');
except
Result.Free;
raise;
end;
end;
function TWCAPIDataModule.GetUnitList: TJSONObject;
var
data: TJSONArray;
lastAgency: string;
begin
Logger.Log(3, '---TWCAPIDataModule.GetUnitList initiated');
Result := TJSONObject.Create;
try
data := TJSONArray.Create;
Result.AddPair('data', data);
try
lastAgency := '';
try
with uqUnitList do
begin
Close;
Open;
First;
while not Eof do
begin
var item := TJSONObject.Create;
data.AddElement(item);
// Section: Group header shown once when the agency changes.
var curAgency := Trim(uqUnitListAGENCY_NAME.AsString);
if curAgency = '' then
curAgency := Trim(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', '');
// Section: Core unit identity.
item.AddPair('UnitId', uqUnitListUNITID.AsString);
item.AddPair('UnitName', uqUnitListUNITNAME.AsString);
item.AddPair('Agency', uqUnitListAGENCY.AsString);
item.AddPair('AgencyName', uqUnitListAGENCY_NAME.AsString);
item.AddPair('AgencyType', uqUnitListAGENCYTYPE.AsString);
item.AddPair('CarNumberDesc', uqUnitListCARNUMBER_DESC.AsString);
item.AddPair('District', uqUnitListDISTRICT_DESC.AsString);
item.AddPair('Sector', uqUnitListSECTOR_DESC.AsString);
item.AddPair('CallType', uqUnitListCALL_TYPE.AsString);
// Section: Map button availability.
var canShowMap := False;
if (not uqUnitListGPS_LATITUDE.IsNull) and
(not uqUnitListGPS_LONGITUDE.IsNull) then
begin
var mapLat := uqUnitListGPS_LATITUDE.AsFloat;
var mapLng := 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'
)
);
// Section: Current complaint assignment.
var complaintNumber :=
Trim(uqUnitListCOMPLAINT.AsString);
item.AddPair(
'Location',
uqUnitListLOCATION.AsString
);
item.AddPair('Complaint', complaintNumber);
if complaintNumber <> '' then
item.AddPair(
'ComplaintHeader',
' - ' + complaintNumber
)
else
item.AddPair('ComplaintHeader', '');
// Section: Default to Available when there is no active CFS row.
var statusDesc :=
uqUnitListUNIT_STATUS_DESC.AsString;
if statusDesc = '' then
statusDesc := 'Available';
item.AddPair('Status', statusDesc);
// Section: Primary officer.
var o1 :=
Trim(uqUnitListOFFICER1_LAST_NAME.AsString);
var f1 :=
Trim(uqUnitListOFFICER1_FIRST_NAME.AsString);
var m1 :=
Trim(uqUnitListOFFICER1_MI.AsString);
if o1 <> '' then
begin
if f1 <> '' then
o1 := o1 + ', ' + f1;
if m1 <> '' then
o1 := o1 + ' ' + m1;
item.AddPair('Officer1', o1);
end;
// Section: Secondary officer.
var o2 :=
Trim(uqUnitListOFFICER2_LAST_NAME.AsString);
var f2 :=
Trim(uqUnitListOFFICER2_FIRST_NAME.AsString);
var m2 :=
Trim(uqUnitListOFFICER2_MI.AsString);
if o2 <> '' then
begin
if f2 <> '' then
o2 := o2 + ', ' + f2;
if m2 <> '' then
o2 := o2 + ' ' + m2;
item.AddPair('Officer2', o2);
end;
Next;
end;
end;
finally
uqUnitList.Close;
end;
Result.AddPair(
'count',
TJSONNumber.Create(data.Count)
);
Result.AddPair(
'returned',
TJSONNumber.Create(data.Count)
);
except
Logger.Log(
3,
'---TWCAPIDataModule.GetUnitList End (error)'
);
raise EXDataHttpException.Create(
500,
'Failed to load units list'
);
end;
Logger.Log(3, '---TWCAPIDataModule.GetUnitList End');
except
Result.Free;
raise;
end;
end;
function TWCAPIDataModule.GetComplaintDetails(ComplaintId: string): TJSONObject;
var
obj: TJSONObject;
begin
Logger.Log(3,'---TWCAPIDataModule.GetComplaintDetails initiated: '+ComplaintId);
Result := TJSONObject.Create;
try
try
with uqComplaintDetails do
begin
ParamByName('COMPLAINTID').AsString := ComplaintId;
Open;
try
if Eof then raise EXDataHttpException.Create(404,'Complaint not found');
obj := TJSONObject.Create;
Result.AddPair('data', obj);
obj.AddPair('ComplaintId', uqComplaintDetailsCOMPLAINTID.AsString);
obj.AddPair('CFSId', uqComplaintDetailsCFSID.AsString);
obj.AddPair('Complaint', uqComplaintDetailsCOMPLAINT.AsString);
obj.AddPair('Priority', uqComplaintDetailsPRIORITY.AsString);
obj.AddPair('DispatchCode', uqComplaintDetailsDISPATCHCODE.AsString);
obj.AddPair('DispatchCodeDesc', uqComplaintDetailsDISPATCH_CODE_DESC.AsString);
obj.AddPair('DispatchDistrict', uqComplaintDetailsDISPATCHDISTRICT.AsString);
obj.AddPair('Address', uqComplaintDetailsADDRESS.AsString);
obj.AddPair('Business',uqComplaintDetailsBUSINESS.AsString);
obj.AddPair('History', uqComplaintDetailsHISTORY.AsString);
obj.AddPair('Contacts', uqComplaintDetailsCONTACTS.AsString);
obj.AddPair('Warnings', uqComplaintDetailsWARNINGS.AsString);
if uqComplaintDetailsDATEREPORTED.IsNull then
obj.AddPair('DateReported', '')
else
obj.AddPair('DateReported', FormatDateTime('yyyy-mm-dd hh:nn:ss', uqComplaintDetailsDATEREPORTED.AsDateTime));
if uqComplaintDetailsDATERECEIVED.IsNull then
obj.AddPair('DateReceived', '')
else
obj.AddPair('DateReceived', FormatDateTime('yyyy-mm-dd hh:nn:ss', uqComplaintDetailsDATERECEIVED.AsDateTime));
if uqComplaintDetailsDATEDISPATCHED.IsNull then
obj.AddPair('DateDispatched', '')
else
obj.AddPair('DateDispatched', FormatDateTime('yyyy-mm-dd hh:nn:ss', uqComplaintDetailsDATEDISPATCHED.AsDateTime));
if uqComplaintDetailsDATERESPONDED.IsNull then
obj.AddPair('DateResponded', '')
else
obj.AddPair('DateResponded', FormatDateTime('yyyy-mm-dd hh:nn:ss', uqComplaintDetailsDATERESPONDED.AsDateTime));
if uqComplaintDetailsDATEARRIVED.IsNull then
obj.AddPair('DateArrived', '')
else
obj.AddPair('DateArrived', FormatDateTime('yyyy-mm-dd hh:nn:ss', uqComplaintDetailsDATEARRIVED.AsDateTime));
if uqComplaintDetailsDATECLEARED.IsNull then
obj.AddPair('DateCleared', '')
else
obj.AddPair('DateCleared', FormatDateTime('yyyy-mm-dd hh:nn:ss', uqComplaintDetailsDATECLEARED.AsDateTime));
finally
Close;
end;
end;
except
on E: EXDataHttpException do
begin
Logger.Log(3,'---TWCAPIDataModule.GetComplaintDetails not found');
raise;
end;
on E: Exception do
begin
Logger.Log(3,'---TWCAPIDataModule.GetComplaintDetails error: '+E.Message);
raise EXDataHttpException.Create(500,'Failed to load complaint details');
end;
end;
Logger.Log(3,'---TWCAPIDataModule.GetComplaintDetails End');
except
Result.Free;
raise;
end;
end;
function TWCAPIDataModule.GetComplaintArchiveDetails(ComplaintId: string): TJSONObject;
var
obj: TJSONObject;
begin
Logger.Log(3,'---TWCAPIDataModule.GetComplaintArchiveDetails initiated: '+ComplaintId);
Result := TJSONObject.Create;
try
try
with uqComplaintDetails do
begin
ParamByName('COMPLAINTID').AsString := ComplaintId;
Open;
try
if Eof then raise EXDataHttpException.Create(404,'Complaint not found');
if not Locate('STATUS', 1, []) then
raise EXDataHttpException.Create(404,'Complaint archive not found');
obj := TJSONObject.Create;
Result.AddPair('data', obj);
obj.AddPair('ComplaintId', uqComplaintDetailsCOMPLAINTID.AsString);
obj.AddPair('CFSId', uqComplaintDetailsCFSID.AsString);
obj.AddPair('Complaint', uqComplaintDetailsCOMPLAINT.AsString);
obj.AddPair('Priority', uqComplaintDetailsPRIORITY.AsString);
obj.AddPair('DispatchCode', uqComplaintDetailsDISPATCHCODE.AsString);
obj.AddPair('DispatchCodeDesc', uqComplaintDetailsDISPATCH_CODE_DESC.AsString);
obj.AddPair('DispatchDistrict', uqComplaintDetailsDISPATCHDISTRICT.AsString);
obj.AddPair('Address', uqComplaintDetailsADDRESS.AsString);
obj.AddPair('Business', uqComplaintDetailsBUSINESS.AsString);
obj.AddPair('History', uqComplaintDetailsHISTORY.AsString);
obj.AddPair('Contacts', uqComplaintDetailsCONTACTS.AsString);
obj.AddPair('Warnings', uqComplaintDetailsWARNINGS.AsString);
if uqComplaintDetailsDATEREPORTED.IsNull then
obj.AddPair('DateReported', '')
else
obj.AddPair('DateReported', FormatDateTime('yyyy-mm-dd hh:nn:ss', uqComplaintDetailsDATEREPORTED.AsDateTime));
if uqComplaintDetailsDATERECEIVED.IsNull then
obj.AddPair('DateReceived', '')
else
obj.AddPair('DateReceived', FormatDateTime('yyyy-mm-dd hh:nn:ss', uqComplaintDetailsDATERECEIVED.AsDateTime));
if uqComplaintDetailsDATEDISPATCHED.IsNull then
obj.AddPair('DateDispatched', '')
else
obj.AddPair('DateDispatched', FormatDateTime('yyyy-mm-dd hh:nn:ss', uqComplaintDetailsDATEDISPATCHED.AsDateTime));
if uqComplaintDetailsDATERESPONDED.IsNull then
obj.AddPair('DateResponded', '')
else
obj.AddPair('DateResponded', FormatDateTime('yyyy-mm-dd hh:nn:ss', uqComplaintDetailsDATERESPONDED.AsDateTime));
if uqComplaintDetailsDATEARRIVED.IsNull then
obj.AddPair('DateArrived', '')
else
obj.AddPair('DateArrived', FormatDateTime('yyyy-mm-dd hh:nn:ss', uqComplaintDetailsDATEARRIVED.AsDateTime));
if uqComplaintDetailsDATECLEARED.IsNull then
obj.AddPair('DateCleared', '')
else
obj.AddPair('DateCleared', FormatDateTime('yyyy-mm-dd hh:nn:ss', uqComplaintDetailsDATECLEARED.AsDateTime));
finally
Close;
end;
end;
except
on E: EXDataHttpException do
begin
Logger.Log(3,'---TWCAPIDataModule.GetComplaintArchiveDetails not found');
raise;
end;
on E: Exception do
begin
Logger.Log(3,'---TWCAPIDataModule.GetComplaintArchiveDetails error: '+E.Message);
raise EXDataHttpException.Create(500,'Failed to load complaint archive details');
end;
end;
Logger.Log(3,'---TWCAPIDataModule.GetComplaintArchiveDetails End');
except
Result.Free;
raise;
end;
end;
function TWCAPIDataModule.GetComplaintMemos(CfsId: string): TJSONObject;
var
data: TJSONArray;
item: TJSONObject;
ts: string;
begin
Logger.Log(3, '---TWCAPIDataModule.GetComplaintMemos initiated: ' + CfsId);
Result := TJSONObject.Create;
try
data := TJSONArray.Create;
Result.AddPair('data', data);
try
with uqCFSMemos do
begin
ParamByName('CFSID').AsString := CfsId;
Open;
try
First;
while not Eof do
begin
item := TJSONObject.Create;
data.AddElement(item);
item.AddPair('MemoId', uqCFSMemosMEMO_ID.AsString);
item.AddPair('CFSId', uqCFSMemosCFSID.AsString);
item.AddPair('MemoType', uqCFSMemosMEMO_TYPE.AsString);
if uqCFSMemosTIMESTAMP.IsNull then
ts := ''
else
ts := FormatDateTime('yyyy-mm-dd' + ' ' + 'hh:nn:ss', uqCFSMemosTIMESTAMP.AsDateTime);
item.AddPair('Timestamp', ts);
item.AddPair('BadgeNumber', uqCFSMemosBADGE_NUMBER.AsString);
item.AddPair('Remarks', uqCFSMemosREMARKS.AsString);
Next;
end;
finally
Close;
end;
end;
Result.AddPair('count', TJSONNumber.Create(data.Count));
Result.AddPair('returned', TJSONNumber.Create(data.Count));
except
on E: EXDataHttpException do
begin
Logger.Log(2, '---TWCAPIDataModule.GetComplaintMemos http error: ' + E.ClassName + ': ' + E.Message);
raise;
end;
on E: Exception do
begin
Logger.Log(2, '---TWCAPIDataModule.GetComplaintMemos error: ' + E.ClassName + ': ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load complaint memos');
end;
end;
Logger.Log(3, '---TWCAPIDataModule.GetComplaintMemos End');
except
Result.Free;
raise;
end;
end;
function TWCAPIDataModule.GetComplaintHistory(ComplaintId: string): TJSONObject;
var
dataArr: TJSONArray;
rowObj: TJSONObject;
returnedCount: Integer;
begin
Logger.Log(4, '---TWCAPIDataModule.GetComplaintHistory initiated: ' + ComplaintId);
Result := TJSONObject.Create;
try
dataArr := TJSONArray.Create;
Result.AddPair('data', dataArr);
returnedCount := 0;
try
with uqComplaintHistory do
begin
ParamByName('COMPLAINTID').AsString := ComplaintId;
Open;
try
while not Eof do
begin
if returnedCount >= 50 then
Break;
rowObj := TJSONObject.Create;
dataArr.AddElement(rowObj);
rowObj.AddPair('ComplaintId', uqComplaintHistoryCOMPLAINTID.AsString);
rowObj.AddPair('Complaint', uqComplaintHistoryCOMPLAINT.AsString);
rowObj.AddPair('Apartment', uqComplaintHistoryAPARTMENT.AsString);
if uqComplaintHistoryDATEREPORTED.IsNull then
rowObj.AddPair('DateReported', '')
else
rowObj.AddPair('DateReported', FormatDateTime('yyyy-mm-dd', uqComplaintHistoryDATEREPORTED.AsDateTime));
rowObj.AddPair('DPriority', uqComplaintHistoryDPRIORITY.AsString);
rowObj.AddPair('DCallType', uqComplaintHistoryDCALLTYPE.AsString);
Inc(returnedCount);
Next;
end;
finally
Close;
end;
end;
Result.AddPair('count', TJSONNumber.Create(returnedCount));
Result.AddPair('returned', TJSONNumber.Create(returnedCount));
Logger.Log(3, '---TWCAPIDataModule.GetComplaintHistory End (returned=' + IntToStr(returnedCount) + ')');
except
on E: EXDataHttpException do
begin
Logger.Log(2, '---TWCAPIDataModule.GetComplaintHistory http error: ' + E.Message);
raise;
end;
on E: Exception do
begin
Logger.Log(2, '---TWCAPIDataModule.GetComplaintHistory error: ' + E.ClassName + ': ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load complaint history');
end;
end;
except
Result.Free;
raise;
end;
end;
function TWCAPIDataModule.GetComplaintContacts(ComplaintId: string): TJSONObject;
var
dataArr: TJSONArray;
rowObj: TJSONObject;
returnedCount: Integer;
begin
Logger.Log(4, '---TWCAPIDataModule.GetComplaintContacts initiated: ' + ComplaintId);
Result := TJSONObject.Create;
try
dataArr := TJSONArray.Create;
Result.AddPair('data', dataArr);
returnedCount := 0;
try
with uqComplaintContacts do
begin
ParamByName('COMPLAINTID').AsString := ComplaintId;
Open;
try
while not Eof do
begin
rowObj := TJSONObject.Create;
dataArr.AddElement(rowObj);
rowObj.AddPair('Name', FieldByName('NAME').AsString);
rowObj.AddPair('Phone', FieldByName('PHONE').AsString);
rowObj.AddPair('DContactType', FieldByName('DCONTACTTYPE').AsString);
rowObj.AddPair('Remarks', FieldByName('REMARKS').AsString);
Inc(returnedCount);
Next;
end;
finally
Close;
end;
end;
Result.AddPair('count', TJSONNumber.Create(returnedCount));
Result.AddPair('returned', TJSONNumber.Create(returnedCount));
Logger.Log(3, '---TWCAPIDataModule.GetComplaintContacts End (returned=' + IntToStr(returnedCount) + ')');
except
on E: EXDataHttpException do
begin
Logger.Log(2, '---TWCAPIDataModule.GetComplaintContacts http error: ' + E.Message);
raise;
end;
on E: Exception do
begin
Logger.Log(2, '---TWCAPIDataModule.GetComplaintContacts error: ' + E.ClassName + ': ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load complaint contacts');
end;
end;
except
Result.Free;
raise;
end;
end;
function TWCAPIDataModule.GetComplaintWarnings(ComplaintId: string): TJSONObject;
var
dataArr: TJSONArray;
rowObj: TJSONObject;
returnedCount: Integer;
addressText: string;
apartmentText: string;
cityText: string;
begin
Logger.Log(3, '---TWCAPIDataModule.GetComplaintWarnings initiated: ' + ComplaintId);
Result := TJSONObject.Create;
try
dataArr := TJSONArray.Create;
Result.AddPair('data', dataArr);
returnedCount := 0;
try
with uqComplaintWarnings do
begin
ParamByName('COMPLAINTID').AsString := ComplaintId;
Open;
try
while not Eof do
begin
rowObj := TJSONObject.Create;
dataArr.AddElement(rowObj);
addressText := Trim(
uqComplaintWarningsSTRNUMBER.AsString + ' ' +
uqComplaintWarningsSTRHNUMBER.AsString + ' ' +
uqComplaintWarningsSTRPREFIX.AsString + ' ' +
uqComplaintWarningsSTRNAME.AsString + ' ' +
uqComplaintWarningsSTRSUFFIX.AsString
);
apartmentText := Trim(uqComplaintWarningsAPARTMENT.AsString);
if apartmentText <> '' then
addressText := Trim(addressText + ' ' + apartmentText);
cityText := Trim(uqComplaintWarningsCITY.AsString);
if cityText <> '' then
begin
if addressText <> '' then
addressText := addressText + ', ' + cityText
else
addressText := cityText;
end;
rowObj.AddPair('CodeDesc', uqComplaintWarningsCODE_DESC.AsString);
rowObj.AddPair('Address', addressText);
rowObj.AddPair('Notes', uqComplaintWarningsNOTES.AsString);
Inc(returnedCount);
Next;
end;
finally
Close;
end;
end;
Result.AddPair('count', TJSONNumber.Create(returnedCount));
Result.AddPair('returned', TJSONNumber.Create(returnedCount));
Logger.Log(3, '---TWCAPIDataModule.GetComplaintWarnings End (returned=' + IntToStr(returnedCount) + ')');
except
on E: EXDataHttpException do
begin
Logger.Log(2, '---TWCAPIDataModule.GetComplaintWarnings http error: ' + E.Message);
raise;
end;
on E: Exception do
begin
Logger.Log(2, '---TWCAPIDataModule.GetComplaintWarnings error: ' + E.ClassName + ': ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load complaint warnings');
end;
end;
except
Result.Free;
raise;
end;
end;
function TWCAPIDataModule.GetUnitLogs(UnitId: string): TJSONObject;
var
dataArr: TJSONArray;
rowObj: TJSONObject;
returnedCount: Integer;
ts: string;
complaintText: string;
begin
Logger.Log(4, '---TWCAPIDataModule.GetUnitLogs initiated: ' + UnitId);
Result := TJSONObject.Create;
try
dataArr := TJSONArray.Create;
Result.AddPair('data', dataArr);
returnedCount := 0;
try
with uqUnitLogs do
begin
ParamByName('UNITID').AsString := UnitId;
Open;
try
while not Eof do
begin
rowObj := TJSONObject.Create;
dataArr.AddElement(rowObj);
ts := '';
if not uqUnitLogsLOG_TIME.IsNull then
ts := FormatDateTime('yyyy-mm-dd' + ' ' + 'HH:nn:ss', uqUnitLogsLOG_TIME.AsDateTime);
complaintText := Trim(uqUnitLogsCOMPLAINT_NUM.AsString);
rowObj.AddPair('LogTime', ts);
rowObj.AddPair('Complaint', complaintText);
rowObj.AddPair('Log', uqUnitLogsLOG_TEXT.AsString);
Inc(returnedCount);
Next;
end;
finally
Close;
end;
end;
Result.AddPair('count', TJSONNumber.Create(returnedCount));
Result.AddPair('returned', TJSONNumber.Create(returnedCount));
Logger.Log(4, '---TWCAPIDataModule.GetUnitLogs End (returned=' + IntToStr(returnedCount) + ')');
except
on E: EXDataHttpException do
begin
Logger.Log(2, '---TWCAPIDataModule.GetUnitLogs http error: ' + E.Message);
raise;
end;
on E: Exception do
begin
Logger.Log(2, '---TWCAPIDataModule.GetUnitLogs error: ' + E.ClassName + ': ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load unit logs');
end;
end;
except
Result.Free;
raise;
end;
end;
function TWCAPIDataModule.GetUnitDetails(UnitId: string): TJSONObject;
var
obj: TJSONObject;
updateTimeText: string;
unitStatus: string;
begin
Logger.Log(4, '---TWCAPIDataModule.GetUnitDetails initiated: ' + UnitId);
Result := TJSONObject.Create;
try
try
with uqUnitDetails do
begin
Close;
ParamByName('UNITID').AsString := UnitId;
Open;
try
if Eof then
raise EXDataHttpException.Create(404, 'Unit not found');
obj := TJSONObject.Create;
Result.AddPair('data', obj);
obj.AddPair('UnitId', uqUnitDetailsUNITID.AsString);
obj.AddPair('UnitName', uqUnitDetailsUNITNAME.AsString);
obj.AddPair('CarNumberDesc', uqUnitDetailsCARNUMBER_DESC.AsString);
obj.AddPair('District', uqUnitDetailsDISTRICT_DESC.AsString);
obj.AddPair('Location', uqUnitDetailsLOCATION.AsString);
unitStatus := Trim(uqUnitDetailsUNIT_STATUS_DESC.AsString);
if unitStatus = '' then
unitStatus := 'Available';
obj.AddPair('Status', unitStatus);
obj.AddPair('Officer1Lname', uqUnitDetailsOFFICER1_LNAME.AsString);
obj.AddPair('Officer1Fname', uqUnitDetailsOFFICER1_FNAME.AsString);
obj.AddPair('Officer1Empnum', uqUnitDetailsOFFICER1_EMPNUM.AsString);
obj.AddPair('Officer2Lname', uqUnitDetailsOFFICER2_LNAME.AsString);
obj.AddPair('Officer2Fname', uqUnitDetailsOFFICER2_FNAME.AsString);
obj.AddPair('Officer2Empnum', uqUnitDetailsOFFICER2_EMPNUM.AsString);
updateTimeText := '';
if not uqUnitDetailsUPDATE_TIME.IsNull then
updateTimeText := FormatDateTime('yyyy-mm-dd hh:nn:ss', uqUnitDetailsUPDATE_TIME.AsDateTime);
obj.AddPair('UpdateTime', updateTimeText);
finally
Close;
end;
end;
except
on E: EXDataHttpException do
begin
Logger.Log(2, '---TWCAPIDataModule.GetUnitDetails http error: ' + E.ClassName + ': ' + E.Message);
raise;
end;
on E: Exception do
begin
Logger.Log(2, '---TWCAPIDataModule.GetUnitDetails error: ' + E.ClassName + ': ' + E.Message);
raise EXDataHttpException.Create(500, 'Failed to load unit details');
end;
end;
Logger.Log(4, '---TWCAPIDataModule.GetUnitDetails End');
except
Result.Free;
raise;
end;
end;
end.
emiMobileServer/Source/Auth.Database.dfm → emiMobileServer/Clients/WC/Server/WC.Auth.Database.dfm
object AuthDatabase: TAuthDatabase
object WCAuthDatabase: TWCAuthDatabase
OnCreate = DataModuleCreate
OnDestroy = DataModuleDestroy
Height = 249
......@@ -18,15 +18,12 @@ object AuthDatabase: TAuthDatabase
Top = 145
EncryptedPassword = '9AFF92FF8CFF86FF8CFFCFFFCEFF'
end
object uqUserPref: TUniQuery
Connection = ucLemsOCSO
SQL.Strings = (
'SELECT * FROM USER_PREFERENCES')
Left = 160
Top = 52
end
object uqAuth: TUniQuery
Connection = ucLemsOCSO
SQL.Strings = (
'select u.* from lems.users u '
'where upper(user_name) = :USER_NAME '
'and u.dept = :AGENCY')
Left = 88
Top = 48
end
......@@ -34,4 +31,24 @@ object AuthDatabase: TAuthDatabase
Left = 90
Top = 148
end
object uqAgencies: TUniQuery
Connection = ucLemsOCSO
SQL.Strings = (
'select agencyid as agency '
'from lems.agency '
'where login = ''T'' '
'order by agencyid')
Left = 40
Top = 200
end
object uqAgencyConfig: TUniQuery
Connection = ucLemsOCSO
SQL.Strings = (
'select agencyid, agencyname '
'from lems.agency '
'where login = ''T'' '
'order by agencyname')
Left = 160
Top = 200
end
end
emiMobileServer/Source/Auth.Database.pas → emiMobileServer/Clients/WC/Server/WC.Auth.Database.pas
unit Auth.Database;
unit WC.Auth.Database;
interface
uses
System.SysUtils, System.Classes, MemDS,
Client.Auth, System.SysUtils, System.Classes, MemDS,
Data.DB, DBAccess, Uni, UniProvider, PostgreSQLUniProvider;
type
TAuthDatabase = class(TDataModule)
TWCAuthDatabase = class(TClientAuth)
uqMisc: TUniQuery;
ucLemsOCSO: TUniConnection;
uqUserPref: TUniQuery;
uqAuth: TUniQuery;
uqAgencies: TUniQuery;
uqAgencyConfig: TUniQuery;
PostgreSQLUniProvider1: TPostgreSQLUniProvider;
procedure DataModuleCreate(Sender: TObject);
procedure DataModuleDestroy(Sender: TObject);
private
{ Private declarations }
protected
function GetConnection: TUniConnection; override;
function GetUserData: TDataSet; override;
function GetAgencies: TDataSet; override;
function GetAgencyConfig: TDataSet; override;
public
{ Public declarations }
procedure SetLoginAuditEntry( userStr: string );
procedure OpenUser(User, Agency: string); override;
procedure OpenAgencies; override;
procedure OpenAgencyConfig; override;
procedure SetLoginAuditEntry( userStr: string ); override;
end;
var
AuthDatabase: TAuthDatabase;
WCAuthDatabase: TWCAuthDatabase;
implementation
......@@ -38,15 +47,49 @@ uses
{$R *.dfm}
procedure TAuthDatabase.DataModuleCreate(Sender: TObject);
function TWCAuthDatabase.GetConnection: TUniConnection;
begin
ucLemsOCSO.ProviderName := 'PostgreSQL';
ucLemsOCSO.Server := IniEntries.DatabaseServer;
ucLemsOCSO.Port := IniEntries.DatabasePort;
ucLemsOCSO.Database := IniEntries.DatabaseName;
ucLemsOCSO.Username := IniEntries.DatabaseUsername;
ucLemsOCSO.Password := IniEntries.DatabasePassword;
ucLemsOCSO.LoginPrompt := False;
Result := ucLemsOCSO;
end;
function TWCAuthDatabase.GetUserData: TDataSet;
begin
Result := uqAuth;
end;
function TWCAuthDatabase.GetAgencies: TDataSet;
begin
Result := uqAgencies;
end;
function TWCAuthDatabase.GetAgencyConfig: TDataSet;
begin
Result := uqAgencyConfig;
end;
procedure TWCAuthDatabase.OpenUser(User, Agency: string);
begin
uqAuth.Close;
uqAuth.ParamByName('USER_NAME').AsString := UpperCase(Trim(User));
uqAuth.ParamByName('AGENCY').AsString := UpperCase(Trim(Agency));
uqAuth.Open;
end;
procedure TWCAuthDatabase.OpenAgencies;
begin
uqAgencies.Close;
uqAgencies.Open;
end;
procedure TWCAuthDatabase.OpenAgencyConfig;
begin
uqAgencyConfig.Close;
uqAgencyConfig.Open;
end;
procedure TWCAuthDatabase.DataModuleCreate(Sender: TObject);
begin
IniEntries.ConfigureConnection(ucLemsOCSO);
try
Logger.Log(2, '');
......@@ -60,13 +103,13 @@ begin
end;
procedure TAuthDatabase.DataModuleDestroy(Sender: TObject);
procedure TWCAuthDatabase.DataModuleDestroy(Sender: TObject);
begin
if ucLemsOCSO.Connected then
ucLemsOCSO.Disconnect;
end;
procedure TAuthDatabase.SetLoginAuditEntry( userStr: string );
procedure TWCAuthDatabase.SetLoginAuditEntry( userStr: string );
var
auditMasterId: string;
userInfo: TStringList;
......@@ -76,7 +119,7 @@ var
userid: string;
personnelid: string;
begin
Logger.Log( 3, 'TAuthDatabase.SetLoginAuditEntry - start' );
Logger.Log( 3, 'TWCAuthDatabase.SetLoginAuditEntry - start' );
userInfo := TStringList.Create;
try
......
emiMobileServer/Core/Server/Client.Selection.pas deleted 100644 → 0
unit Client.Selection;
interface
uses
Client.Data;
procedure ValidateClient;
function CreateClientData: TClientData;
implementation
uses
System.SysUtils, Common.Ini, WC.Api.Data;
procedure ValidateClient;
begin
if IniEntries.Client = '' then
raise Exception.Create('Missing [Application] Client in the server INI file. Set Client=WC.');
if IniEntries.Client = 'BFD' then
raise Exception.Create('BFD is not supported by this server yet. Use the existing BFD server.');
if IniEntries.Client <> 'WC' then
raise Exception.CreateFmt('Unrecognized [Application] Client "%s". Supported client: WC.', [IniEntries.Client]);
end;
function CreateClientData: TClientData;
begin
ValidateClient;
Result := TWCAPIData.Create;
end;
end.
emiMobileServer/Shared/Clients/Client.Auth.pas 0 → 100644
unit Client.Auth;
interface
uses
System.Classes, Data.DB, Uni;
type
TClientAuth = class abstract(TDataModule)
protected
function GetConnection: TUniConnection; virtual; abstract;
function GetUserData: TDataSet; virtual; abstract;
function GetAgencies: TDataSet; virtual; abstract;
function GetAgencyConfig: TDataSet; virtual; abstract;
public
procedure OpenUser(User, Agency: string); virtual; abstract;
procedure OpenAgencies; virtual; abstract;
procedure OpenAgencyConfig; virtual; abstract;
procedure SetLoginAuditEntry(userStr: string); virtual; abstract;
// Note: The module owns these datasets and the connection; callers must not free them.
property Connection: TUniConnection read GetConnection;
property UserData: TDataSet read GetUserData;
property Agencies: TDataSet read GetAgencies;
property AgencyConfig: TDataSet read GetAgencyConfig;
end;
implementation
end.
emiMobileServer/Core/Server/Client.Data.pas → emiMobileServer/Shared/Clients/Client.Data.pas
......@@ -3,11 +3,11 @@ unit Client.Data;
interface
uses
System.JSON;
System.Classes, System.JSON;
type
// Note: Each instance owns its data connection. Returned JSON belongs to the caller.
TClientData = class abstract
TClientData = class abstract(TDataModule)
public
function EnsureConnected: Boolean; virtual; abstract;
procedure ConfigureQueryTimeouts; virtual; abstract;
......
emiMobileServer/Shared/Clients/Client.Selection.pas 0 → 100644
unit Client.Selection;
interface
uses
Client.Data, Client.Auth, Device.Store, Uni;
function CreateClientAuth: TClientAuth;
procedure ValidateClient;
function CreateDeviceStore(AConnection: TUniConnection = nil): TDeviceStore;
function CreateClientData: TClientData;
implementation
uses
System.SysUtils, Common.Ini, WC.Api.Database, WC.Auth.Database, PostgreSQL.Device.Database,
BFD.Api.Database, BFD.Auth.Database, Oracle.Device.Database;
function CreateClientAuth: TClientAuth;
begin
if IniEntries.Client = 'BFD' then
Result := TBFDAuthDatabase.Create(nil)
else
Result := TWCAuthDatabase.Create(nil);
end;
procedure ValidateClient;
begin
if IniEntries.Client = '' then
raise Exception.Create('Missing [Application] Client in the server INI file. Set Client=WC or Client=BFD.');
if (IniEntries.Client <> 'WC') and (IniEntries.Client <> 'BFD') then
raise Exception.CreateFmt('Unrecognized [Application] Client "%s". Supported clients: WC, BFD.', [IniEntries.Client]);
end;
function CreateClientData: TClientData;
begin
if IniEntries.Client = 'BFD' then
Result := TBFDAPIDataModule.Create(nil)
else
Result := TWCAPIDataModule.Create(nil);
end;
function CreateDeviceStore(AConnection: TUniConnection): TDeviceStore;
begin
if IniEntries.Client = 'BFD' then
Result := TOracleDeviceDatabase.Create(nil)
else
Result := TPostgreSQLDeviceDatabase.Create(nil);
try
if Assigned(AConnection) then
Result.UseConnection(AConnection)
else
begin
IniEntries.ConfigureConnection(Result.Connection);
Result.Connection.Connect;
end;
except
Result.Free;
raise;
end;
end;
end.
emiMobileServer/Shared/Clients/Device.Store.pas 0 → 100644
unit Device.Store;
interface
uses
System.Classes, System.SysUtils, Data.DB, Uni;
type
// Note: Returned datasets belong to this store. Read and close them; do not free them.
TDeviceStore = class abstract(TDataModule)
protected
function GetConnection: TUniConnection; virtual; abstract;
public
// Note: A supplied connection is borrowed and must outlive this store.
procedure UseConnection(AConnection: TUniConnection); virtual; abstract;
property Connection: TUniConnection read GetConnection;
function PendingDevice(PhoneNumber: string): TDataSet; virtual; abstract;
function SetVerificationCode(Code: string; PhoneNumber: string): Int64; virtual; abstract;
function ConsumeVerificationCode(PhoneNumber: string; Code: string): Int64; virtual; abstract;
function ActivateWebAuthnDevice(CredentialId: string; UserAgent: string; PublicKeyX: TBytes; PublicKeyY: TBytes; PublicKeyAlg: Integer; SignCount: Integer; PhoneNumber: string): Int64; virtual; abstract;
function UnrevokedDeviceUser(CredentialId: string): TDataSet; virtual; abstract;
function ActiveDeviceUser(CredentialId: string): TDataSet; virtual; abstract;
function UnrevokedDeviceKey(CredentialId: string): TDataSet; virtual; abstract;
function UpdateSignCount(SignCount: Integer; CredentialId: string): Int64; virtual; abstract;
function SaveDeviceUser(Username: string; Agency: string; CredentialId: string): Int64; virtual; abstract;
function ActiveDeviceKey(CredentialId: string): TDataSet; virtual; abstract;
function ActivateSimpleDevice(CredentialId: string; UserAgent: string; PhoneNumber: string): Int64; virtual; abstract;
function ActiveSimpleDeviceUser(CredentialId: string): TDataSet; virtual; abstract;
function ActiveSimpleDevice(CredentialId: string): TDataSet; virtual; abstract;
function DeviceStatus(CredentialId: string): TDataSet; virtual; abstract;
function DeviceList: TDataSet; virtual; abstract;
function RevokeDevice(RevokedBy: string; CredentialId: string): Int64; virtual; abstract;
function UnrevokeDevice(CredentialId: string): Int64; virtual; abstract;
function PendingPhone(PhoneNumber: string): TDataSet; virtual; abstract;
function AddPendingDevice(DeviceName: string; DeviceType: string; PhoneNumber: string): Int64; virtual; abstract;
function DeletePendingDevice(PhoneNumber: string): Int64; virtual; abstract;
function DeleteDevice(CredentialId: string): Int64; virtual; abstract;
function ReserveRedeemCode(PhoneNumber: string; out Code: string): Boolean; virtual; abstract;
function UpdateDeviceUsername(Username: string; CredentialId: string): Int64; virtual; abstract;
function ActiveDevice(CredentialId: string): TDataSet; virtual; abstract;
end;
implementation
end.
emiMobileServer/Shared/Database/Oracle/Oracle.Device.Database.dfm 0 → 100644
object OracleDeviceDatabase: TOracleDeviceDatabase
Height = 720
Width = 1000
object ucDevices: TUniConnection
ProviderName = 'Oracle'
LoginPrompt = False
Connected = False
Left = 40
Top = 24
end
object OracleUniProvider1: TOracleUniProvider
Left = 176
Top = 24
end
object uqPendingDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT ID, DEVICE_NAME'
'FROM DEVICE_REGISTRATIONS'
'WHERE PHONE_NUMBER = :PHONE'
' AND STATUS = ''pending''')
ReadOnly = True
Active = False
Left = 60
Top = 110
ParamData = <
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
end>
end
object uqSetVerificationCode: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE DEVICE_REGISTRATIONS'
'SET VERIFICATION_CODE = :CODE, VERIFICATION_EXPIRES_AT = SYSTIMESTAMP + INTERVAL ''5'' MINUTE'
'WHERE PHONE_NUMBER = :PHONE'
' AND STATUS = ''pending''')
Active = False
Left = 250
Top = 110
ParamData = <
item
DataType = ftString
Name = 'CODE'
ParamType = ptInput
end
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
end>
end
object uqConsumeVerificationCode: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE DEVICE_REGISTRATIONS'
'SET VERIFICATION_CODE = NULL, VERIFICATION_EXPIRES_AT = NULL'
'WHERE PHONE_NUMBER = :PHONE'
' AND STATUS = ''pending'''
' AND VERIFICATION_CODE = :CODE'
' AND VERIFICATION_EXPIRES_AT > SYSTIMESTAMP')
Active = False
Left = 630
Top = 110
ParamData = <
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
end
item
DataType = ftString
Name = 'CODE'
ParamType = ptInput
end>
end
object uqActivateWebAuthnDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE DEVICE_REGISTRATIONS'
'SET CREDENTIAL_ID = :CID, USER_AGENT = :AGENT, PUBLIC_KEY_X = :KEYX, PUBLIC_KEY_Y = :KEYY, PUBLIC_KEY_ALG = :ALG, SIGN_COUNT = :CNT, VERIFICATION_CODE = NULL, VERIFICATION_EXPIRES_AT = NULL, STATUS = ''active'', REGISTERED_AT = SYSTIMESTAMP'
'WHERE PHONE_NUMBER = :PHONE'
' AND STATUS = ''pending''')
Active = False
Left = 820
Top = 110
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end
item
DataType = ftMemo
Name = 'AGENT'
ParamType = ptInput
end
item
DataType = ftVarBytes
Name = 'KEYX'
ParamType = ptInput
Size = 32
end
item
DataType = ftVarBytes
Name = 'KEYY'
ParamType = ptInput
Size = 32
end
item
DataType = ftInteger
Name = 'ALG'
ParamType = ptInput
end
item
DataType = ftInteger
Name = 'CNT'
ParamType = ptInput
end
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
end>
end
object uqUnrevokedDeviceUser: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT USERNAME, AGENCY'
'FROM DEVICE_REGISTRATIONS'
'WHERE CREDENTIAL_ID = :CID'
' AND REVOKED_AT IS NULL')
ReadOnly = True
Active = False
Left = 60
Top = 220
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqActiveDeviceUser: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT USERNAME, AGENCY'
'FROM DEVICE_REGISTRATIONS'
'WHERE CREDENTIAL_ID = :CID'
' AND STATUS = ''active''')
ReadOnly = True
Active = False
Left = 250
Top = 220
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqUnrevokedDeviceKey: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT PUBLIC_KEY_X, PUBLIC_KEY_Y, SIGN_COUNT'
'FROM DEVICE_REGISTRATIONS'
'WHERE CREDENTIAL_ID = :CID'
' AND REVOKED_AT IS NULL')
ReadOnly = True
Active = False
Left = 440
Top = 220
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqUpdateSignCount: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE DEVICE_REGISTRATIONS'
'SET SIGN_COUNT = :CNT'
'WHERE CREDENTIAL_ID = :CID')
Active = False
Left = 630
Top = 220
ParamData = <
item
DataType = ftInteger
Name = 'CNT'
ParamType = ptInput
end
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqSaveDeviceUser: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE DEVICE_REGISTRATIONS'
'SET USERNAME = :UNAME, AGENCY = :AGCY'
'WHERE CREDENTIAL_ID = :CID')
Active = False
Left = 820
Top = 220
ParamData = <
item
DataType = ftString
Name = 'UNAME'
ParamType = ptInput
end
item
DataType = ftString
Name = 'AGCY'
ParamType = ptInput
end
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqActiveDeviceKey: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT PUBLIC_KEY_X, PUBLIC_KEY_Y, SIGN_COUNT, USERNAME, AGENCY'
'FROM DEVICE_REGISTRATIONS'
'WHERE CREDENTIAL_ID = :CID'
' AND STATUS = ''active''')
ReadOnly = True
Active = False
Left = 60
Top = 330
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqActivateSimpleDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE DEVICE_REGISTRATIONS'
'SET CREDENTIAL_ID = :CID, USER_AGENT = :AGENT, KEY_TYPE = ''simple'', VERIFICATION_CODE = NULL, VERIFICATION_EXPIRES_AT = NULL, STATUS = ''active'', REGISTERED_AT = SYSTIMESTAMP'
'WHERE PHONE_NUMBER = :PHONE'
' AND STATUS = ''pending''')
Active = False
Left = 250
Top = 330
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end
item
DataType = ftMemo
Name = 'AGENT'
ParamType = ptInput
end
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
end>
end
object uqActiveSimpleDeviceUser: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT USERNAME, AGENCY'
'FROM DEVICE_REGISTRATIONS'
'WHERE CREDENTIAL_ID = :CID'
' AND KEY_TYPE = ''simple'''
' AND STATUS = ''active''')
ReadOnly = True
Active = False
Left = 440
Top = 330
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqActiveSimpleDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT ID'
'FROM DEVICE_REGISTRATIONS'
'WHERE CREDENTIAL_ID = :CID'
' AND KEY_TYPE = ''simple'''
' AND STATUS = ''active''')
ReadOnly = True
Active = False
Left = 630
Top = 330
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqDeviceStatus: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT STATUS'
'FROM DEVICE_REGISTRATIONS'
'WHERE CREDENTIAL_ID = :CID')
ReadOnly = True
Active = False
Left = 820
Top = 330
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqDeviceList: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT ID, CREDENTIAL_ID, DEVICE_NAME, DEVICE_TYPE, PHONE_NUMBER, USERNAME, USER_AGENT, REGISTERED_AT, REVOKED_AT, REVOKED_BY, STATUS, VERIFICATION_CODE, CASE WHEN STATUS = ''pending'''
' AND VERIFICATION_EXPIRES_AT > SYSTIMESTAMP THEN 1 ELSE 0 END AS VERIFICATION_CODE_ACTIVE'
'FROM DEVICE_REGISTRATIONS'
'ORDER BY REGISTERED_AT DESC')
ReadOnly = True
Active = False
Left = 60
Top = 440
end
object uqRevokeDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE DEVICE_REGISTRATIONS'
'SET REVOKED_AT = SYSTIMESTAMP, REVOKED_BY = :REVOKED_BY, STATUS = ''revoked'''
'WHERE CREDENTIAL_ID = :CID'
' AND STATUS = ''active''')
Active = False
Left = 250
Top = 440
ParamData = <
item
DataType = ftString
Name = 'REVOKED_BY'
ParamType = ptInput
end
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqUnrevokeDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE DEVICE_REGISTRATIONS'
'SET REVOKED_AT = NULL, REVOKED_BY = NULL, STATUS = ''active'''
'WHERE CREDENTIAL_ID = :CID'
' AND STATUS = ''revoked''')
Active = False
Left = 440
Top = 440
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqPendingPhone: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT ID'
'FROM DEVICE_REGISTRATIONS'
'WHERE PHONE_NUMBER = :PHONE'
' AND STATUS = ''pending''')
ReadOnly = True
Active = False
Left = 630
Top = 440
ParamData = <
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
end>
end
object uqAddPendingDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'INSERT INTO DEVICE_REGISTRATIONS (DEVICE_NAME, DEVICE_TYPE, PHONE_NUMBER, STATUS)'
'VALUES (:NAME, :TYPE, :PHONE, ''pending'')')
Active = False
Left = 820
Top = 440
ParamData = <
item
DataType = ftString
Name = 'NAME'
ParamType = ptInput
end
item
DataType = ftString
Name = 'TYPE'
ParamType = ptInput
end
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
end>
end
object uqDeletePendingDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'DELETE'
'FROM DEVICE_REGISTRATIONS'
'WHERE PHONE_NUMBER = :PHONE'
' AND STATUS = ''pending''')
Active = False
Left = 60
Top = 550
ParamData = <
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
end>
end
object uqDeleteDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'DELETE'
'FROM DEVICE_REGISTRATIONS'
'WHERE CREDENTIAL_ID = :CID')
Active = False
Left = 250
Top = 550
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqReserveRedeemCode: TUniQuery
Connection = ucDevices
SQL.Strings = (
'DECLARE'
' CURSOR AVAILABLE_CODES IS'
' SELECT ID, CODE FROM REDEEM_CODES'
' WHERE USED_AT IS NULL'
' ORDER BY ID'
' FOR UPDATE SKIP LOCKED;'
' AVAILABLE_CODE AVAILABLE_CODES%ROWTYPE;'
'BEGIN'
' :CODE := NULL;'
' OPEN AVAILABLE_CODES;'
' FETCH AVAILABLE_CODES INTO AVAILABLE_CODE;'
' IF AVAILABLE_CODES%FOUND THEN'
' UPDATE REDEEM_CODES'
' SET USED_AT = SYSTIMESTAMP, USED_FOR = :PHONE'
' WHERE CURRENT OF AVAILABLE_CODES;'
' :CODE := AVAILABLE_CODE.CODE;'
' END IF;'
' CLOSE AVAILABLE_CODES;'
'END;')
Active = False
Left = 440
Top = 550
ParamData = <
item
DataType = ftString
Name = 'CODE'
ParamType = ptOutput
Size = 20
end
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
end>
end
object uqUpdateDeviceUsername: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE DEVICE_REGISTRATIONS'
'SET USERNAME = :UNAME'
'WHERE CREDENTIAL_ID = :CID'
' AND STATUS = ''active''')
Active = False
Left = 630
Top = 550
ParamData = <
item
DataType = ftString
Name = 'UNAME'
ParamType = ptInput
end
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqActiveDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT ID'
'FROM DEVICE_REGISTRATIONS'
'WHERE CREDENTIAL_ID = :CID'
' AND STATUS = ''active''')
ReadOnly = True
Active = False
Left = 820
Top = 550
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
end
emiMobileServer/Shared/Database/Oracle/Oracle.Device.Database.pas 0 → 100644
unit Oracle.Device.Database;
interface
uses
System.SysUtils, System.Classes, Data.DB, DBAccess, MemDS, Uni, UniProvider,
OracleUniProvider, Device.Store;
type
TOracleDeviceDatabase = class(TDeviceStore)
ucDevices: TUniConnection;
OracleUniProvider1: TOracleUniProvider;
uqPendingDevice: TUniQuery;
uqSetVerificationCode: TUniQuery;
uqConsumeVerificationCode: TUniQuery;
uqActivateWebAuthnDevice: TUniQuery;
uqUnrevokedDeviceUser: TUniQuery;
uqActiveDeviceUser: TUniQuery;
uqUnrevokedDeviceKey: TUniQuery;
uqUpdateSignCount: TUniQuery;
uqSaveDeviceUser: TUniQuery;
uqActiveDeviceKey: TUniQuery;
uqActivateSimpleDevice: TUniQuery;
uqActiveSimpleDeviceUser: TUniQuery;
uqActiveSimpleDevice: TUniQuery;
uqDeviceStatus: TUniQuery;
uqDeviceList: TUniQuery;
uqRevokeDevice: TUniQuery;
uqUnrevokeDevice: TUniQuery;
uqPendingPhone: TUniQuery;
uqAddPendingDevice: TUniQuery;
uqDeletePendingDevice: TUniQuery;
uqDeleteDevice: TUniQuery;
uqReserveRedeemCode: TUniQuery;
uqUpdateDeviceUsername: TUniQuery;
uqActiveDevice: TUniQuery;
private
FConnection: TUniConnection;
protected
function GetConnection: TUniConnection; override;
public
procedure UseConnection(AConnection: TUniConnection); override;
function PendingDevice(PhoneNumber: string): TDataSet; override;
function SetVerificationCode(Code: string; PhoneNumber: string): Int64; override;
function ConsumeVerificationCode(PhoneNumber: string; Code: string): Int64; override;
function ActivateWebAuthnDevice(CredentialId: string; UserAgent: string; PublicKeyX: TBytes; PublicKeyY: TBytes; PublicKeyAlg: Integer; SignCount: Integer; PhoneNumber: string): Int64; override;
function UnrevokedDeviceUser(CredentialId: string): TDataSet; override;
function ActiveDeviceUser(CredentialId: string): TDataSet; override;
function UnrevokedDeviceKey(CredentialId: string): TDataSet; override;
function UpdateSignCount(SignCount: Integer; CredentialId: string): Int64; override;
function SaveDeviceUser(Username: string; Agency: string; CredentialId: string): Int64; override;
function ActiveDeviceKey(CredentialId: string): TDataSet; override;
function ActivateSimpleDevice(CredentialId: string; UserAgent: string; PhoneNumber: string): Int64; override;
function ActiveSimpleDeviceUser(CredentialId: string): TDataSet; override;
function ActiveSimpleDevice(CredentialId: string): TDataSet; override;
function DeviceStatus(CredentialId: string): TDataSet; override;
function DeviceList: TDataSet; override;
function RevokeDevice(RevokedBy: string; CredentialId: string): Int64; override;
function UnrevokeDevice(CredentialId: string): Int64; override;
function PendingPhone(PhoneNumber: string): TDataSet; override;
function AddPendingDevice(DeviceName: string; DeviceType: string; PhoneNumber: string): Int64; override;
function DeletePendingDevice(PhoneNumber: string): Int64; override;
function DeleteDevice(CredentialId: string): Int64; override;
function ReserveRedeemCode(PhoneNumber: string; out Code: string): Boolean; override;
function UpdateDeviceUsername(Username: string; CredentialId: string): Int64; override;
function ActiveDevice(CredentialId: string): TDataSet; override;
end;
var
OracleDeviceDatabase: TOracleDeviceDatabase;
implementation
{%CLASSGROUP 'Vcl.Controls.TControl'}
{$R *.dfm}
function TOracleDeviceDatabase.GetConnection: TUniConnection;
begin
if Assigned(FConnection) then
Result := FConnection
else
Result := ucDevices;
end;
procedure TOracleDeviceDatabase.UseConnection(AConnection: TUniConnection);
var
i: Integer;
begin
FConnection := AConnection;
for i := 0 to ComponentCount - 1 do
if Components[i] is TUniQuery then
TUniQuery(Components[i]).Connection := Connection;
end;
function TOracleDeviceDatabase.PendingDevice(PhoneNumber: string): TDataSet;
begin
uqPendingDevice.Close;
uqPendingDevice.ParamByName('PHONE').AsString := PhoneNumber;
uqPendingDevice.Open;
Result := uqPendingDevice;
end;
function TOracleDeviceDatabase.SetVerificationCode(Code: string; PhoneNumber: string): Int64;
begin
uqSetVerificationCode.Close;
uqSetVerificationCode.ParamByName('CODE').AsString := Code;
uqSetVerificationCode.ParamByName('PHONE').AsString := PhoneNumber;
uqSetVerificationCode.ExecSQL;
Result := uqSetVerificationCode.RowsAffected;
end;
function TOracleDeviceDatabase.ConsumeVerificationCode(PhoneNumber: string; Code: string): Int64;
begin
uqConsumeVerificationCode.Close;
uqConsumeVerificationCode.ParamByName('PHONE').AsString := PhoneNumber;
uqConsumeVerificationCode.ParamByName('CODE').AsString := Code;
uqConsumeVerificationCode.ExecSQL;
Result := uqConsumeVerificationCode.RowsAffected;
end;
function TOracleDeviceDatabase.ActivateWebAuthnDevice(CredentialId: string; UserAgent: string; PublicKeyX: TBytes; PublicKeyY: TBytes; PublicKeyAlg: Integer; SignCount: Integer; PhoneNumber: string): Int64;
begin
uqActivateWebAuthnDevice.Close;
uqActivateWebAuthnDevice.ParamByName('CID').AsString := CredentialId;
uqActivateWebAuthnDevice.ParamByName('AGENT').AsString := UserAgent;
uqActivateWebAuthnDevice.ParamByName('KEYX').AsBytes := PublicKeyX;
uqActivateWebAuthnDevice.ParamByName('KEYY').AsBytes := PublicKeyY;
uqActivateWebAuthnDevice.ParamByName('ALG').AsInteger := PublicKeyAlg;
uqActivateWebAuthnDevice.ParamByName('CNT').AsInteger := SignCount;
uqActivateWebAuthnDevice.ParamByName('PHONE').AsString := PhoneNumber;
uqActivateWebAuthnDevice.ExecSQL;
Result := uqActivateWebAuthnDevice.RowsAffected;
end;
function TOracleDeviceDatabase.UnrevokedDeviceUser(CredentialId: string): TDataSet;
begin
uqUnrevokedDeviceUser.Close;
uqUnrevokedDeviceUser.ParamByName('CID').AsString := CredentialId;
uqUnrevokedDeviceUser.Open;
Result := uqUnrevokedDeviceUser;
end;
function TOracleDeviceDatabase.ActiveDeviceUser(CredentialId: string): TDataSet;
begin
uqActiveDeviceUser.Close;
uqActiveDeviceUser.ParamByName('CID').AsString := CredentialId;
uqActiveDeviceUser.Open;
Result := uqActiveDeviceUser;
end;
function TOracleDeviceDatabase.UnrevokedDeviceKey(CredentialId: string): TDataSet;
begin
uqUnrevokedDeviceKey.Close;
uqUnrevokedDeviceKey.ParamByName('CID').AsString := CredentialId;
uqUnrevokedDeviceKey.Open;
Result := uqUnrevokedDeviceKey;
end;
function TOracleDeviceDatabase.UpdateSignCount(SignCount: Integer; CredentialId: string): Int64;
begin
uqUpdateSignCount.Close;
uqUpdateSignCount.ParamByName('CNT').AsInteger := SignCount;
uqUpdateSignCount.ParamByName('CID').AsString := CredentialId;
uqUpdateSignCount.ExecSQL;
Result := uqUpdateSignCount.RowsAffected;
end;
function TOracleDeviceDatabase.SaveDeviceUser(Username: string; Agency: string; CredentialId: string): Int64;
begin
uqSaveDeviceUser.Close;
uqSaveDeviceUser.ParamByName('UNAME').AsString := Username;
uqSaveDeviceUser.ParamByName('AGCY').AsString := Agency;
uqSaveDeviceUser.ParamByName('CID').AsString := CredentialId;
uqSaveDeviceUser.ExecSQL;
Result := uqSaveDeviceUser.RowsAffected;
end;
function TOracleDeviceDatabase.ActiveDeviceKey(CredentialId: string): TDataSet;
begin
uqActiveDeviceKey.Close;
uqActiveDeviceKey.ParamByName('CID').AsString := CredentialId;
uqActiveDeviceKey.Open;
Result := uqActiveDeviceKey;
end;
function TOracleDeviceDatabase.ActivateSimpleDevice(CredentialId: string; UserAgent: string; PhoneNumber: string): Int64;
begin
uqActivateSimpleDevice.Close;
uqActivateSimpleDevice.ParamByName('CID').AsString := CredentialId;
uqActivateSimpleDevice.ParamByName('AGENT').AsString := UserAgent;
uqActivateSimpleDevice.ParamByName('PHONE').AsString := PhoneNumber;
uqActivateSimpleDevice.ExecSQL;
Result := uqActivateSimpleDevice.RowsAffected;
end;
function TOracleDeviceDatabase.ActiveSimpleDeviceUser(CredentialId: string): TDataSet;
begin
uqActiveSimpleDeviceUser.Close;
uqActiveSimpleDeviceUser.ParamByName('CID').AsString := CredentialId;
uqActiveSimpleDeviceUser.Open;
Result := uqActiveSimpleDeviceUser;
end;
function TOracleDeviceDatabase.ActiveSimpleDevice(CredentialId: string): TDataSet;
begin
uqActiveSimpleDevice.Close;
uqActiveSimpleDevice.ParamByName('CID').AsString := CredentialId;
uqActiveSimpleDevice.Open;
Result := uqActiveSimpleDevice;
end;
function TOracleDeviceDatabase.DeviceStatus(CredentialId: string): TDataSet;
begin
uqDeviceStatus.Close;
uqDeviceStatus.ParamByName('CID').AsString := CredentialId;
uqDeviceStatus.Open;
Result := uqDeviceStatus;
end;
function TOracleDeviceDatabase.DeviceList: TDataSet;
begin
uqDeviceList.Close;
uqDeviceList.Open;
Result := uqDeviceList;
end;
function TOracleDeviceDatabase.RevokeDevice(RevokedBy: string; CredentialId: string): Int64;
begin
uqRevokeDevice.Close;
uqRevokeDevice.ParamByName('REVOKED_BY').AsString := RevokedBy;
uqRevokeDevice.ParamByName('CID').AsString := CredentialId;
uqRevokeDevice.ExecSQL;
Result := uqRevokeDevice.RowsAffected;
end;
function TOracleDeviceDatabase.UnrevokeDevice(CredentialId: string): Int64;
begin
uqUnrevokeDevice.Close;
uqUnrevokeDevice.ParamByName('CID').AsString := CredentialId;
uqUnrevokeDevice.ExecSQL;
Result := uqUnrevokeDevice.RowsAffected;
end;
function TOracleDeviceDatabase.PendingPhone(PhoneNumber: string): TDataSet;
begin
uqPendingPhone.Close;
uqPendingPhone.ParamByName('PHONE').AsString := PhoneNumber;
uqPendingPhone.Open;
Result := uqPendingPhone;
end;
function TOracleDeviceDatabase.AddPendingDevice(DeviceName: string; DeviceType: string; PhoneNumber: string): Int64;
begin
uqAddPendingDevice.Close;
uqAddPendingDevice.ParamByName('NAME').AsString := DeviceName;
uqAddPendingDevice.ParamByName('TYPE').AsString := DeviceType;
uqAddPendingDevice.ParamByName('PHONE').AsString := PhoneNumber;
uqAddPendingDevice.ExecSQL;
Result := uqAddPendingDevice.RowsAffected;
end;
function TOracleDeviceDatabase.DeletePendingDevice(PhoneNumber: string): Int64;
begin
uqDeletePendingDevice.Close;
uqDeletePendingDevice.ParamByName('PHONE').AsString := PhoneNumber;
uqDeletePendingDevice.ExecSQL;
Result := uqDeletePendingDevice.RowsAffected;
end;
function TOracleDeviceDatabase.DeleteDevice(CredentialId: string): Int64;
begin
uqDeleteDevice.Close;
uqDeleteDevice.ParamByName('CID').AsString := CredentialId;
uqDeleteDevice.ExecSQL;
Result := uqDeleteDevice.RowsAffected;
end;
function TOracleDeviceDatabase.ReserveRedeemCode(PhoneNumber: string; out Code: string): Boolean;
begin
Code := '';
Connection.StartTransaction;
try
uqReserveRedeemCode.ParamByName('PHONE').AsString := PhoneNumber;
uqReserveRedeemCode.ExecSQL;
Code := uqReserveRedeemCode.ParamByName('CODE').AsString;
Result := Code <> '';
if Result then
Connection.Commit
else
Connection.Rollback;
except
Connection.Rollback;
raise;
end;
end;
function TOracleDeviceDatabase.UpdateDeviceUsername(Username: string; CredentialId: string): Int64;
begin
uqUpdateDeviceUsername.Close;
uqUpdateDeviceUsername.ParamByName('UNAME').AsString := Username;
uqUpdateDeviceUsername.ParamByName('CID').AsString := CredentialId;
uqUpdateDeviceUsername.ExecSQL;
Result := uqUpdateDeviceUsername.RowsAffected;
end;
function TOracleDeviceDatabase.ActiveDevice(CredentialId: string): TDataSet;
begin
uqActiveDevice.Close;
uqActiveDevice.ParamByName('CID').AsString := CredentialId;
uqActiveDevice.Open;
Result := uqActiveDevice;
end;
end.
emiMobileServer/Shared/Database/Oracle/README.md 0 → 100644
# Oracle device storage
Current configuration: Shared/Server/Common.Ini.pas reads [Oracle] Server, Username, Password for Client=BFD. Server is the existing TNS alias. The same ConfigureConnection method configures CAD, authentication and standalone device-store connections. Designer credentials are not a runtime fallback. Oracle.Connection has been removed.
Use the common server project for WC and BFD. The standalone BFD project is retired.
Prepared for Oracle 19c. No tables have been created and no database statements have been executed.
`Oracle.Device.Database.pas/.dfm` contains 25 designer UniQueries translated from WC's current authentication, device administration, and WebSocket device checks. It implements TDeviceStore and is referenced by the standalone BFD project for compilation and designer access, but is not auto-created or selected by application services. The connection has no credentials and starts disconnected; every query starts inactive. Connection configuration for Oracle belongs to the later integration step. UseConnection can borrow an existing connection; the store does not free it.
## Table assumptions
Unqualified uppercase names resolve in the same schema as the CAD tables for now. The final schema owner is still to be discussed.
- `DEVICE_REGISTRATIONS`: `ID`, `CREDENTIAL_ID`, `DEVICE_NAME`, `DEVICE_TYPE`, `PHONE_NUMBER`, `USER_AGENT`, `PUBLIC_KEY_X`, `PUBLIC_KEY_Y`, `PUBLIC_KEY_ALG`, `SIGN_COUNT`, `REGISTERED_AT`, `REVOKED_AT`, `REVOKED_BY`, `STATUS`, `KEY_TYPE`, `USERNAME`, `AGENCY`, `VERIFICATION_CODE`, `VERIFICATION_EXPIRES_AT`.
- `REDEEM_CODES`: `ID`, `CODE`, `USED_AT`, `USED_FOR`. This is needed for WC's app-download link workflow; no redeem-code seed data was copied.
The eventual schema must supply generated IDs, WC-compatible defaults, and credential/code uniqueness. Pending registrations need nullable credentials and public keys. Binary key parameters are `ftVarBytes` with size 32, intended for Oracle `RAW(32)` public-key coordinates. The user-agent parameter is `ftMemo`, intended for CLOB storage. Time fields should preserve WC's time-zone-aware expiry behavior; queries use `SYSTIMESTAMP`. Redeem codes retain WC's 20-character limit. Final DDL and remaining field sizes are deferred.
WC's checked-in SQL scripts do not define `DEVICE_TYPE`, `VERIFICATION_CODE`, or `VERIFICATION_EXPIRES_AT`, although current code uses them. Those requirements were taken from service code. Do not treat the old scripts as a complete schema or run their destructive table-recreation statements.
## Behavior retained
- Stored status/key-type values remain lowercase (`pending`, `active`, `revoked`, `simple`, `webauthn`); uppercase applies to identifiers.
- Existing active-status versus non-revoked filters remain distinct, matching their WC callers.
- Verification code consumption is a conditional UPDATE that checks pending status, code, and expiry and clears the code. Integration must check RowsAffected as WC does.
- Registration activation retains the pending-row condition. Integration must preserve its RowsAffected checks.
- Device-list verification activity uses a numeric CASE result (1/0), replacing PostgreSQL's boolean expression. Validate UniDAC field conversion when connected.
- `ReserveRedeemCode` starts a transaction, executes a PL/SQL cursor that fetches one unlocked unused code, marks it used, and commits. No available row returns False and rolls back. Exceptions roll back. Call it with a configured connection and no existing transaction. The eventual caller should keep WC's existing order: reserve/commit first, then send the SMS.
- No authentication bypass or test-mode boolean has been added.
Oracle cursor/locking reference: https://docs.oracle.com/en/database/oracle/oracle-database/19/lnpls/transaction-processing-and-control.html
## Validation and remaining work
The standalone BFD server builds successfully with this unit. An offline Delphi smoke test instantiated the data module, loaded its DFM, confirmed all 25 queries were inactive and attached to the disconnected connection, checked key/output parameter types, and freed the module. Static checks matched SQL bind names to DFM parameter declarations.
SQL execution, Oracle parameter binding, timestamp/boolean conversions, uniqueness behavior, and concurrent code allocation still require tests against the eventual tables. The shared Device.Store boundary and PostgreSQL counterpart are implemented, and WC services use them. Oracle operations implement the same contract but still require live validation and selection/configuration integration. Client=BFD remains disabled in the common server.
## Oracle connection configuration
The existing BFD connection uses an Oracle client/TNS alias. The new Oracle.Connection unit reads this section from the executable's INI:
```ini
[Oracle]
Server=BFD
Username=YOUR_ORACLE_USERNAME
Password=YOUR_ORACLE_PASSWORD
```
Use the actual credentials locally. Server is the TNS alias, not the PostgreSQL host from the old BFD [Database] section. No PostgreSQL port or database-name settings are applied to Oracle.
BFD CAD and auth modules apply this section before connecting. For compatibility with the standalone server, an absent Oracle section retains their existing designer settings. A present but incomplete section fails with a configuration error. A standalone Oracle device store requires the section; a store borrowing the auth connection uses that connection's settings.
The common server now compiles the BFD CAD/auth and Oracle device implementations and includes their selection branches. ValidateClient still rejects BFD before any branch executes. Removing that block alone is not a completed integration: require explicit Oracle configuration for the common-server CAD/auth path, finish the web/auth integration, create and test the deferred device tables, and validate Oracle listener behavior on the shared WebSocket worker before enabling BFD.
No running INI was changed and no database tables were created. Both server builds passed; Oracle INI connections have not been runtime-tested.
## Latest activation checkpoint
The user manually created both tables in dbForge. The common server now accepts Client=BFD and requires explicit Oracle INI settings. Earlier descriptions of the startup block are historical. Server=BFD still uses the existing TNS alias; credentials come from the INI. Both builds passed, but Oracle query/binding/listener and device-flow checks remain pending. Use webClientVersion=9.4.0 for the current BFD web project.
The earlier checkpoint text above is historical. Current schema was manually created by the user; real-number BFD browser registration and login were successful. ClearVerificationCode was removed after the send-before-save fix, leaving 24 Oracle designer queries.
emiMobileServer/Shared/Database/PostgreSQL/PostgreSQL.Device.Database.dfm 0 → 100644
object PostgreSQLDeviceDatabase: TPostgreSQLDeviceDatabase
Left = 0
Top = 0
ClientHeight = 703
ClientWidth = 774
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = 'Segoe UI'
Font.Style = []
TextHeight = 15
object ucDevices: TUniConnection
ProviderName = 'PostgreSQL'
LoginPrompt = False
Left = 40
Top = 24
end
object PostgreSQLUniProvider1: TPostgreSQLUniProvider
Left = 180
Top = 24
end
object uqPendingDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT id, device_name FROM lems.device_registrations WHERE phon' +
'e_number = :PHONE AND status = '#39'pending'#39)
Left = 60
Top = 110
ParamData = <
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
Value = nil
end>
end
object uqSetVerificationCode: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.device_registrations SET verification_code = :CODE, ' +
' verification_expires_at = NOW() + INTERVAL '#39'5 minutes'#39' WHERE' +
' phone_number = :PHONE AND status = '#39'pending'#39)
Left = 188
Top = 178
ParamData = <
item
DataType = ftString
Name = 'CODE'
ParamType = ptInput
Value = nil
end
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
Value = nil
end>
end
object uqConsumeVerificationCode: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.device_registrations SET verification_code = NULL, v' +
'erification_expires_at = NULL WHERE phone_number = :PHONE AND st' +
'atus = '#39'pending'#39' AND verification_code = :CODE AND verification_' +
'expires_at > NOW()')
Left = 502
Top = 130
ParamData = <
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
Value = nil
end
item
DataType = ftString
Name = 'CODE'
ParamType = ptInput
Value = nil
end>
end
object uqActivateWebAuthnDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.device_registrations SET credential_id = :CID, user_' +
'agent = :AGENT, public_key_x = :KEYX, public_key_y = :KEYY, ' +
' public_key_alg = :ALG, sign_count = :CNT, verification_c' +
'ode = NULL, verification_expires_at = NULL, status = '#39'active' +
#39', registered_at = NOW() WHERE phone_number = :PHONE AND status ' +
'= '#39'pending'#39)
Left = 618
Top = 164
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
Value = nil
end
item
DataType = ftString
Name = 'AGENT'
ParamType = ptInput
Value = nil
end
item
DataType = ftVarBytes
Name = 'KEYX'
ParamType = ptInput
Size = 32
Value = nil
end
item
DataType = ftVarBytes
Name = 'KEYY'
ParamType = ptInput
Size = 32
Value = nil
end
item
DataType = ftInteger
Name = 'ALG'
ParamType = ptInput
Value = nil
end
item
DataType = ftInteger
Name = 'CNT'
ParamType = ptInput
Value = nil
end
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
Value = nil
end>
end
object uqUnrevokedDeviceUser: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT username, agency FROM lems.device_registrations WHERE cre' +
'dential_id = :CID AND revoked_at IS NULL')
Left = 60
Top = 206
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
Value = nil
end>
end
object uqActiveDeviceUser: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT username, agency FROM lems.device_registrations WHERE cre' +
'dential_id = :CID AND status = '#39'active'#39)
Left = 190
Top = 280
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
Value = nil
end>
end
object uqUnrevokedDeviceKey: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT public_key_x, public_key_y, sign_count FROM lems.device_r' +
'egistrations WHERE credential_id = :CID AND revoked_at IS NULL')
Left = 326
Top = 254
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
Value = nil
end>
end
object uqUpdateSignCount: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.device_registrations SET sign_count = :CNT WHERE cre' +
'dential_id = :CID')
Left = 506
Top = 208
ParamData = <
item
DataType = ftInteger
Name = 'CNT'
ParamType = ptInput
Value = nil
end
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
Value = nil
end>
end
object uqSaveDeviceUser: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.device_registrations SET username = :UNAME, agency =' +
' :AGCY WHERE credential_id = :CID')
Left = 614
Top = 230
ParamData = <
item
DataType = ftString
Name = 'UNAME'
ParamType = ptInput
Value = nil
end
item
DataType = ftString
Name = 'AGCY'
ParamType = ptInput
Value = nil
end
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
Value = nil
end>
end
object uqActiveDeviceKey: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT public_key_x, public_key_y, sign_count, username, agency ' +
'FROM lems.device_registrations WHERE credential_id = :CID AND st' +
'atus = '#39'active'#39)
Left = 60
Top = 316
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
Value = nil
end>
end
object uqActivateSimpleDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.device_registrations SET credential_id = :CID, user_' +
'agent = :AGENT, key_type = '#39'simple'#39', verification_code =' +
' NULL, verification_expires_at = NULL, status = '#39'active'#39', re' +
'gistered_at = NOW() WHERE phone_number = :PHONE AND status = '#39'pe' +
'nding'#39)
Left = 190
Top = 364
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
Value = nil
end
item
DataType = ftString
Name = 'AGENT'
ParamType = ptInput
Value = nil
end
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
Value = nil
end>
end
object uqActiveSimpleDeviceUser: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT username, agency FROM lems.device_registrations WHERE cre' +
'dential_id = :CID AND key_type = '#39'simple'#39' AND status = '#39'active'#39)
Left = 326
Top = 326
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
Value = nil
end>
end
object uqActiveSimpleDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT id FROM lems.device_registrations WHERE credential_id = :' +
'CID AND key_type = '#39'simple'#39' AND status = '#39'active'#39)
Left = 500
Top = 294
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
Value = nil
end>
end
object uqDeviceStatus: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT status FROM lems.device_registrations WHERE credential_id' +
' = :CID')
Left = 614
Top = 322
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
Value = nil
end>
end
object uqDeviceList: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT id, credential_id, device_name, device_type, phone_number' +
', username, user_agent, registered_at, revoked_at, revoked_by,' +
' status, verification_code, COALESCE(status = '#39'pending'#39' AND ' +
'verification_expires_at > NOW(), FALSE) AS verification_code' +
'_active FROM lems.device_registrations ORDER BY registered_at DE' +
'SC')
Left = 62
Top = 422
end
object uqRevokeDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.device_registrations SET revoked_at = NOW(), revoked' +
'_by = :REVOKED_BY, status = '#39'revoked'#39' WHERE credential_id = :CID' +
' AND status = '#39'active'#39)
Left = 186
Top = 448
ParamData = <
item
DataType = ftString
Name = 'REVOKED_BY'
ParamType = ptInput
Value = nil
end
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
Value = nil
end>
end
object uqUnrevokeDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.device_registrations SET revoked_at = NULL, revoked_' +
'by = NULL, status = '#39'active'#39' WHERE credential_id = :CID AND stat' +
'us = '#39'revoked'#39)
Left = 328
Top = 414
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
Value = nil
end>
end
object uqPendingPhone: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT id FROM lems.device_registrations WHERE phone_number = :P' +
'HONE AND status = '#39'pending'#39)
Left = 470
Top = 458
ParamData = <
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
Value = nil
end>
end
object uqAddPendingDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'INSERT INTO lems.device_registrations (device_name, device_type,' +
' phone_number, status) VALUES (:NAME, :TYPE, :PHONE, '#39'pending'#39')')
Left = 610
Top = 426
ParamData = <
item
DataType = ftString
Name = 'NAME'
ParamType = ptInput
Value = nil
end
item
DataType = ftString
Name = 'TYPE'
ParamType = ptInput
Value = nil
end
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
Value = nil
end>
end
object uqDeletePendingDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'DELETE FROM lems.device_registrations WHERE phone_number = :PHON' +
'E AND status = '#39'pending'#39)
Left = 60
Top = 566
ParamData = <
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
Value = nil
end>
end
object uqDeleteDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'DELETE FROM lems.device_registrations WHERE credential_id = :CID')
Left = 188
Top = 530
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
Value = nil
end>
end
object uqReserveRedeemCode: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT code FROM lems.redeem_codes WHERE used_at IS NULL ORDER B' +
'Y id LIMIT 1 FOR UPDATE SKIP LOCKED')
Left = 326
Top = 494
end
object uqMarkRedeemCodeUsed: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.redeem_codes SET used_at = NOW(), used_for = :PHONE ' +
'WHERE code = :CODE')
Left = 480
Top = 582
ParamData = <
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
Value = nil
end
item
DataType = ftString
Name = 'CODE'
ParamType = ptInput
Value = nil
end>
end
object uqUpdateDeviceUsername: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.device_registrations SET username = :UNAME WHERE cre' +
'dential_id = :CID AND status = '#39'active'#39)
Left = 618
Top = 522
ParamData = <
item
DataType = ftString
Name = 'UNAME'
ParamType = ptInput
Value = nil
end
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
Value = nil
end>
end
object uqActiveDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT id FROM lems.device_registrations WHERE credential_id = :' +
'CID AND status = '#39'active'#39)
Left = 70
Top = 630
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
Value = nil
end>
end
end
emiMobileServer/Shared/Database/PostgreSQL/PostgreSQL.Device.Database.pas 0 → 100644
unit PostgreSQL.Device.Database;
interface
uses
System.SysUtils, System.Classes, Data.DB, DBAccess, MemDS, Uni, UniProvider,
PostgreSQLUniProvider, Device.Store;
type
TPostgreSQLDeviceDatabase = class(TDeviceStore)
ucDevices: TUniConnection;
PostgreSQLUniProvider1: TPostgreSQLUniProvider;
uqPendingDevice: TUniQuery;
uqSetVerificationCode: TUniQuery;
uqConsumeVerificationCode: TUniQuery;
uqActivateWebAuthnDevice: TUniQuery;
uqUnrevokedDeviceUser: TUniQuery;
uqActiveDeviceUser: TUniQuery;
uqUnrevokedDeviceKey: TUniQuery;
uqUpdateSignCount: TUniQuery;
uqSaveDeviceUser: TUniQuery;
uqActiveDeviceKey: TUniQuery;
uqActivateSimpleDevice: TUniQuery;
uqActiveSimpleDeviceUser: TUniQuery;
uqActiveSimpleDevice: TUniQuery;
uqDeviceStatus: TUniQuery;
uqDeviceList: TUniQuery;
uqRevokeDevice: TUniQuery;
uqUnrevokeDevice: TUniQuery;
uqPendingPhone: TUniQuery;
uqAddPendingDevice: TUniQuery;
uqDeletePendingDevice: TUniQuery;
uqDeleteDevice: TUniQuery;
uqReserveRedeemCode: TUniQuery;
uqMarkRedeemCodeUsed: TUniQuery;
uqUpdateDeviceUsername: TUniQuery;
uqActiveDevice: TUniQuery;
private
FConnection: TUniConnection;
protected
function GetConnection: TUniConnection; override;
public
procedure UseConnection(AConnection: TUniConnection); override;
function PendingDevice(PhoneNumber: string): TDataSet; override;
function SetVerificationCode(Code: string; PhoneNumber: string): Int64; override;
function ConsumeVerificationCode(PhoneNumber: string; Code: string): Int64; override;
function ActivateWebAuthnDevice(CredentialId: string; UserAgent: string; PublicKeyX: TBytes; PublicKeyY: TBytes; PublicKeyAlg: Integer; SignCount: Integer; PhoneNumber: string): Int64; override;
function UnrevokedDeviceUser(CredentialId: string): TDataSet; override;
function ActiveDeviceUser(CredentialId: string): TDataSet; override;
function UnrevokedDeviceKey(CredentialId: string): TDataSet; override;
function UpdateSignCount(SignCount: Integer; CredentialId: string): Int64; override;
function SaveDeviceUser(Username: string; Agency: string; CredentialId: string): Int64; override;
function ActiveDeviceKey(CredentialId: string): TDataSet; override;
function ActivateSimpleDevice(CredentialId: string; UserAgent: string; PhoneNumber: string): Int64; override;
function ActiveSimpleDeviceUser(CredentialId: string): TDataSet; override;
function ActiveSimpleDevice(CredentialId: string): TDataSet; override;
function DeviceStatus(CredentialId: string): TDataSet; override;
function DeviceList: TDataSet; override;
function RevokeDevice(RevokedBy: string; CredentialId: string): Int64; override;
function UnrevokeDevice(CredentialId: string): Int64; override;
function PendingPhone(PhoneNumber: string): TDataSet; override;
function AddPendingDevice(DeviceName: string; DeviceType: string; PhoneNumber: string): Int64; override;
function DeletePendingDevice(PhoneNumber: string): Int64; override;
function DeleteDevice(CredentialId: string): Int64; override;
function ReserveRedeemCode(PhoneNumber: string; out Code: string): Boolean; override;
function UpdateDeviceUsername(Username: string; CredentialId: string): Int64; override;
function ActiveDevice(CredentialId: string): TDataSet; override;
end;
var
PostgreSQLDeviceDatabase: TPostgreSQLDeviceDatabase;
implementation
{%CLASSGROUP 'Vcl.Controls.TControl'}
{$R *.dfm}
function TPostgreSQLDeviceDatabase.GetConnection: TUniConnection;
begin
if Assigned(FConnection) then
Result := FConnection
else
Result := ucDevices;
end;
procedure TPostgreSQLDeviceDatabase.UseConnection(AConnection: TUniConnection);
var
i: Integer;
begin
FConnection := AConnection;
for i := 0 to ComponentCount - 1 do
if Components[i] is TUniQuery then
TUniQuery(Components[i]).Connection := Connection;
end;
function TPostgreSQLDeviceDatabase.PendingDevice(PhoneNumber: string): TDataSet;
begin
uqPendingDevice.Close;
uqPendingDevice.ParamByName('PHONE').AsString := PhoneNumber;
uqPendingDevice.Open;
Result := uqPendingDevice;
end;
function TPostgreSQLDeviceDatabase.SetVerificationCode(Code: string; PhoneNumber: string): Int64;
begin
uqSetVerificationCode.Close;
uqSetVerificationCode.ParamByName('CODE').AsString := Code;
uqSetVerificationCode.ParamByName('PHONE').AsString := PhoneNumber;
uqSetVerificationCode.ExecSQL;
Result := uqSetVerificationCode.RowsAffected;
end;
function TPostgreSQLDeviceDatabase.ConsumeVerificationCode(PhoneNumber: string; Code: string): Int64;
begin
uqConsumeVerificationCode.Close;
uqConsumeVerificationCode.ParamByName('PHONE').AsString := PhoneNumber;
uqConsumeVerificationCode.ParamByName('CODE').AsString := Code;
uqConsumeVerificationCode.ExecSQL;
Result := uqConsumeVerificationCode.RowsAffected;
end;
function TPostgreSQLDeviceDatabase.ActivateWebAuthnDevice(CredentialId: string; UserAgent: string; PublicKeyX: TBytes; PublicKeyY: TBytes; PublicKeyAlg: Integer; SignCount: Integer; PhoneNumber: string): Int64;
begin
uqActivateWebAuthnDevice.Close;
uqActivateWebAuthnDevice.ParamByName('CID').AsString := CredentialId;
uqActivateWebAuthnDevice.ParamByName('AGENT').AsString := UserAgent;
uqActivateWebAuthnDevice.ParamByName('KEYX').AsBytes := PublicKeyX;
uqActivateWebAuthnDevice.ParamByName('KEYY').AsBytes := PublicKeyY;
uqActivateWebAuthnDevice.ParamByName('ALG').AsInteger := PublicKeyAlg;
uqActivateWebAuthnDevice.ParamByName('CNT').AsInteger := SignCount;
uqActivateWebAuthnDevice.ParamByName('PHONE').AsString := PhoneNumber;
uqActivateWebAuthnDevice.ExecSQL;
Result := uqActivateWebAuthnDevice.RowsAffected;
end;
function TPostgreSQLDeviceDatabase.UnrevokedDeviceUser(CredentialId: string): TDataSet;
begin
uqUnrevokedDeviceUser.Close;
uqUnrevokedDeviceUser.ParamByName('CID').AsString := CredentialId;
uqUnrevokedDeviceUser.Open;
Result := uqUnrevokedDeviceUser;
end;
function TPostgreSQLDeviceDatabase.ActiveDeviceUser(CredentialId: string): TDataSet;
begin
uqActiveDeviceUser.Close;
uqActiveDeviceUser.ParamByName('CID').AsString := CredentialId;
uqActiveDeviceUser.Open;
Result := uqActiveDeviceUser;
end;
function TPostgreSQLDeviceDatabase.UnrevokedDeviceKey(CredentialId: string): TDataSet;
begin
uqUnrevokedDeviceKey.Close;
uqUnrevokedDeviceKey.ParamByName('CID').AsString := CredentialId;
uqUnrevokedDeviceKey.Open;
Result := uqUnrevokedDeviceKey;
end;
function TPostgreSQLDeviceDatabase.UpdateSignCount(SignCount: Integer; CredentialId: string): Int64;
begin
uqUpdateSignCount.Close;
uqUpdateSignCount.ParamByName('CNT').AsInteger := SignCount;
uqUpdateSignCount.ParamByName('CID').AsString := CredentialId;
uqUpdateSignCount.ExecSQL;
Result := uqUpdateSignCount.RowsAffected;
end;
function TPostgreSQLDeviceDatabase.SaveDeviceUser(Username: string; Agency: string; CredentialId: string): Int64;
begin
uqSaveDeviceUser.Close;
uqSaveDeviceUser.ParamByName('UNAME').AsString := Username;
uqSaveDeviceUser.ParamByName('AGCY').AsString := Agency;
uqSaveDeviceUser.ParamByName('CID').AsString := CredentialId;
uqSaveDeviceUser.ExecSQL;
Result := uqSaveDeviceUser.RowsAffected;
end;
function TPostgreSQLDeviceDatabase.ActiveDeviceKey(CredentialId: string): TDataSet;
begin
uqActiveDeviceKey.Close;
uqActiveDeviceKey.ParamByName('CID').AsString := CredentialId;
uqActiveDeviceKey.Open;
Result := uqActiveDeviceKey;
end;
function TPostgreSQLDeviceDatabase.ActivateSimpleDevice(CredentialId: string; UserAgent: string; PhoneNumber: string): Int64;
begin
uqActivateSimpleDevice.Close;
uqActivateSimpleDevice.ParamByName('CID').AsString := CredentialId;
uqActivateSimpleDevice.ParamByName('AGENT').AsString := UserAgent;
uqActivateSimpleDevice.ParamByName('PHONE').AsString := PhoneNumber;
uqActivateSimpleDevice.ExecSQL;
Result := uqActivateSimpleDevice.RowsAffected;
end;
function TPostgreSQLDeviceDatabase.ActiveSimpleDeviceUser(CredentialId: string): TDataSet;
begin
uqActiveSimpleDeviceUser.Close;
uqActiveSimpleDeviceUser.ParamByName('CID').AsString := CredentialId;
uqActiveSimpleDeviceUser.Open;
Result := uqActiveSimpleDeviceUser;
end;
function TPostgreSQLDeviceDatabase.ActiveSimpleDevice(CredentialId: string): TDataSet;
begin
uqActiveSimpleDevice.Close;
uqActiveSimpleDevice.ParamByName('CID').AsString := CredentialId;
uqActiveSimpleDevice.Open;
Result := uqActiveSimpleDevice;
end;
function TPostgreSQLDeviceDatabase.DeviceStatus(CredentialId: string): TDataSet;
begin
uqDeviceStatus.Close;
uqDeviceStatus.ParamByName('CID').AsString := CredentialId;
uqDeviceStatus.Open;
Result := uqDeviceStatus;
end;
function TPostgreSQLDeviceDatabase.DeviceList: TDataSet;
begin
uqDeviceList.Close;
uqDeviceList.Open;
Result := uqDeviceList;
end;
function TPostgreSQLDeviceDatabase.RevokeDevice(RevokedBy: string; CredentialId: string): Int64;
begin
uqRevokeDevice.Close;
uqRevokeDevice.ParamByName('REVOKED_BY').AsString := RevokedBy;
uqRevokeDevice.ParamByName('CID').AsString := CredentialId;
uqRevokeDevice.ExecSQL;
Result := uqRevokeDevice.RowsAffected;
end;
function TPostgreSQLDeviceDatabase.UnrevokeDevice(CredentialId: string): Int64;
begin
uqUnrevokeDevice.Close;
uqUnrevokeDevice.ParamByName('CID').AsString := CredentialId;
uqUnrevokeDevice.ExecSQL;
Result := uqUnrevokeDevice.RowsAffected;
end;
function TPostgreSQLDeviceDatabase.PendingPhone(PhoneNumber: string): TDataSet;
begin
uqPendingPhone.Close;
uqPendingPhone.ParamByName('PHONE').AsString := PhoneNumber;
uqPendingPhone.Open;
Result := uqPendingPhone;
end;
function TPostgreSQLDeviceDatabase.AddPendingDevice(DeviceName: string; DeviceType: string; PhoneNumber: string): Int64;
begin
uqAddPendingDevice.Close;
uqAddPendingDevice.ParamByName('NAME').AsString := DeviceName;
uqAddPendingDevice.ParamByName('TYPE').AsString := DeviceType;
uqAddPendingDevice.ParamByName('PHONE').AsString := PhoneNumber;
uqAddPendingDevice.ExecSQL;
Result := uqAddPendingDevice.RowsAffected;
end;
function TPostgreSQLDeviceDatabase.DeletePendingDevice(PhoneNumber: string): Int64;
begin
uqDeletePendingDevice.Close;
uqDeletePendingDevice.ParamByName('PHONE').AsString := PhoneNumber;
uqDeletePendingDevice.ExecSQL;
Result := uqDeletePendingDevice.RowsAffected;
end;
function TPostgreSQLDeviceDatabase.DeleteDevice(CredentialId: string): Int64;
begin
uqDeleteDevice.Close;
uqDeleteDevice.ParamByName('CID').AsString := CredentialId;
uqDeleteDevice.ExecSQL;
Result := uqDeleteDevice.RowsAffected;
end;
function TPostgreSQLDeviceDatabase.ReserveRedeemCode(PhoneNumber: string; out Code: string): Boolean;
begin
Code := '';
Connection.StartTransaction;
try
uqReserveRedeemCode.Close;
uqReserveRedeemCode.Open;
try
Result := not uqReserveRedeemCode.IsEmpty;
if Result then
Code := uqReserveRedeemCode.FieldByName('code').AsString;
finally
uqReserveRedeemCode.Close;
end;
if Result then
begin
uqMarkRedeemCodeUsed.ParamByName('PHONE').AsString := PhoneNumber;
uqMarkRedeemCodeUsed.ParamByName('CODE').AsString := Code;
uqMarkRedeemCodeUsed.ExecSQL;
end;
if Result then
Connection.Commit
else
Connection.Rollback;
except
Connection.Rollback;
raise;
end;
end;
function TPostgreSQLDeviceDatabase.UpdateDeviceUsername(Username: string; CredentialId: string): Int64;
begin
uqUpdateDeviceUsername.Close;
uqUpdateDeviceUsername.ParamByName('UNAME').AsString := Username;
uqUpdateDeviceUsername.ParamByName('CID').AsString := CredentialId;
uqUpdateDeviceUsername.ExecSQL;
Result := uqUpdateDeviceUsername.RowsAffected;
end;
function TPostgreSQLDeviceDatabase.ActiveDevice(CredentialId: string): TDataSet;
begin
uqActiveDevice.Close;
uqActiveDevice.ParamByName('CID').AsString := CredentialId;
uqActiveDevice.Open;
Result := uqActiveDevice;
end;
end.
emiMobileServer/Shared/Database/PostgreSQL/__history/PostgreSQL.Device.Database.dfm.~1~ 0 → 100644
object PostgreSQLDeviceDatabase: TPostgreSQLDeviceDatabase
Height = 820
Width = 1000
object ucDevices: TUniConnection
ProviderName = 'PostgreSQL'
LoginPrompt = False
Connected = False
Left = 40
Top = 24
end
object PostgreSQLUniProvider1: TPostgreSQLUniProvider
Left = 180
Top = 24
end
object uqPendingDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT id, device_name FROM lems.device_registrations WHERE phone_number = :PHONE AND status = ''pending''')
Active = False
Left = 60
Top = 110
ParamData = <
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
end>
end
object uqSetVerificationCode: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.device_registrations SET verification_code = :CODE, verification_expires_at = NOW() + INTERVAL ''5 minutes'' WHERE phone_number = :PHONE AND status = ''pending''')
Active = False
Left = 250
Top = 110
ParamData = <
item
DataType = ftString
Name = 'CODE'
ParamType = ptInput
end
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
end>
end
object uqClearVerificationCode: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.device_registrations SET verification_code = NULL, verification_expires_at = NULL WHERE phone_number = :PHONE AND status = ''pending'' AND verification_code = :CODE')
Active = False
Left = 440
Top = 110
ParamData = <
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
end
item
DataType = ftString
Name = 'CODE'
ParamType = ptInput
end>
end
object uqConsumeVerificationCode: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.device_registrations SET verification_code = NULL, verification_expires_at = NULL WHERE phone_number = :PHONE AND status = ''pending'' AND verification_code = :CODE AND verification_expires_at > NOW()')
Active = False
Left = 630
Top = 110
ParamData = <
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
end
item
DataType = ftString
Name = 'CODE'
ParamType = ptInput
end>
end
object uqActivateWebAuthnDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.device_registrations SET credential_id = :CID, user_agent = :AGENT, public_key_x = :KEYX, public_key_y = :KEYY, public_key_alg = :ALG, sign_count = :CNT, verification_code = NULL, verification_expires_at = NULL, status = ''active'', registered_at = NOW() WHERE phone_number = :PHONE AND status = ''pending''')
Active = False
Left = 820
Top = 110
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end
item
DataType = ftString
Name = 'AGENT'
ParamType = ptInput
end
item
DataType = ftVarBytes
Name = 'KEYX'
ParamType = ptInput
Size = 32
end
item
DataType = ftVarBytes
Name = 'KEYY'
ParamType = ptInput
Size = 32
end
item
DataType = ftInteger
Name = 'ALG'
ParamType = ptInput
end
item
DataType = ftInteger
Name = 'CNT'
ParamType = ptInput
end
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
end>
end
object uqUnrevokedDeviceUser: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT username, agency FROM lems.device_registrations WHERE credential_id = :CID AND revoked_at IS NULL')
Active = False
Left = 60
Top = 220
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqActiveDeviceUser: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT username, agency FROM lems.device_registrations WHERE credential_id = :CID AND status = ''active''')
Active = False
Left = 250
Top = 220
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqUnrevokedDeviceKey: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT public_key_x, public_key_y, sign_count FROM lems.device_registrations WHERE credential_id = :CID AND revoked_at IS NULL')
Active = False
Left = 440
Top = 220
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqUpdateSignCount: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.device_registrations SET sign_count = :CNT WHERE credential_id = :CID')
Active = False
Left = 630
Top = 220
ParamData = <
item
DataType = ftInteger
Name = 'CNT'
ParamType = ptInput
end
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqSaveDeviceUser: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.device_registrations SET username = :UNAME, agency = :AGCY WHERE credential_id = :CID')
Active = False
Left = 820
Top = 220
ParamData = <
item
DataType = ftString
Name = 'UNAME'
ParamType = ptInput
end
item
DataType = ftString
Name = 'AGCY'
ParamType = ptInput
end
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqActiveDeviceKey: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT public_key_x, public_key_y, sign_count, username, agency FROM lems.device_registrations WHERE credential_id = :CID AND status = ''active''')
Active = False
Left = 60
Top = 330
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqActivateSimpleDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.device_registrations SET credential_id = :CID, user_agent = :AGENT, key_type = ''simple'', verification_code = NULL, verification_expires_at = NULL, status = ''active'', registered_at = NOW() WHERE phone_number = :PHONE AND status = ''pending''')
Active = False
Left = 250
Top = 330
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end
item
DataType = ftString
Name = 'AGENT'
ParamType = ptInput
end
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
end>
end
object uqActiveSimpleDeviceUser: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT username, agency FROM lems.device_registrations WHERE credential_id = :CID AND key_type = ''simple'' AND status = ''active''')
Active = False
Left = 440
Top = 330
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqActiveSimpleDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT id FROM lems.device_registrations WHERE credential_id = :CID AND key_type = ''simple'' AND status = ''active''')
Active = False
Left = 630
Top = 330
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqDeviceStatus: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT status FROM lems.device_registrations WHERE credential_id = :CID')
Active = False
Left = 820
Top = 330
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqDeviceList: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT id, credential_id, device_name, device_type, phone_number, username, user_agent, registered_at, revoked_at, revoked_by, status, verification_code, COALESCE(status = ''pending'' AND verification_expires_at > NOW(), FALSE) AS verification_code_active FROM lems.device_registrations ORDER BY registered_at DESC')
Active = False
Left = 60
Top = 440
end
object uqRevokeDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.device_registrations SET revoked_at = NOW(), revoked_by = :REVOKED_BY, status = ''revoked'' WHERE credential_id = :CID AND status = ''active''')
Active = False
Left = 250
Top = 440
ParamData = <
item
DataType = ftString
Name = 'REVOKED_BY'
ParamType = ptInput
end
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqUnrevokeDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.device_registrations SET revoked_at = NULL, revoked_by = NULL, status = ''active'' WHERE credential_id = :CID AND status = ''revoked''')
Active = False
Left = 440
Top = 440
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqPendingPhone: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT id FROM lems.device_registrations WHERE phone_number = :PHONE AND status = ''pending''')
Active = False
Left = 630
Top = 440
ParamData = <
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
end>
end
object uqAddPendingDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'INSERT INTO lems.device_registrations (device_name, device_type, phone_number, status) VALUES (:NAME, :TYPE, :PHONE, ''pending'')')
Active = False
Left = 820
Top = 440
ParamData = <
item
DataType = ftString
Name = 'NAME'
ParamType = ptInput
end
item
DataType = ftString
Name = 'TYPE'
ParamType = ptInput
end
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
end>
end
object uqDeletePendingDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'DELETE FROM lems.device_registrations WHERE phone_number = :PHONE AND status = ''pending''')
Active = False
Left = 60
Top = 550
ParamData = <
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
end>
end
object uqDeleteDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'DELETE FROM lems.device_registrations WHERE credential_id = :CID')
Active = False
Left = 250
Top = 550
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqReserveRedeemCode: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT code FROM lems.redeem_codes WHERE used_at IS NULL ORDER BY id LIMIT 1 FOR UPDATE SKIP LOCKED')
Active = False
Left = 440
Top = 550
end
object uqMarkRedeemCodeUsed: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.redeem_codes SET used_at = NOW(), used_for = :PHONE WHERE code = :CODE')
Active = False
Left = 630
Top = 550
ParamData = <
item
DataType = ftString
Name = 'PHONE'
ParamType = ptInput
end
item
DataType = ftString
Name = 'CODE'
ParamType = ptInput
end>
end
object uqUpdateDeviceUsername: TUniQuery
Connection = ucDevices
SQL.Strings = (
'UPDATE lems.device_registrations SET username = :UNAME WHERE credential_id = :CID AND status = ''active''')
Active = False
Left = 820
Top = 550
ParamData = <
item
DataType = ftString
Name = 'UNAME'
ParamType = ptInput
end
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
object uqActiveDevice: TUniQuery
Connection = ucDevices
SQL.Strings = (
'SELECT id FROM lems.device_registrations WHERE credential_id = :CID AND status = ''active''')
Active = False
Left = 60
Top = 660
ParamData = <
item
DataType = ftString
Name = 'CID'
ParamType = ptInput
end>
end
end
emiMobileServer/Shared/Database/README.md 0 → 100644
# Device storage
`Core/Server/Device.Store.pas` defines the shared device-storage operations. PostgreSQL and Oracle designer data modules implement those operations with their own UniQueries and SQL.
## Ownership and use
- Authentication creates a store through `Client.Selection.CreateDeviceStore(authDB.ucLemsOCSO)` and borrows its existing connection. Free the store before the authentication module.
- API device operations and WebSocket activity checks create a store with `CreateDeviceStore`, which owns a separately configured connection. Free the store when that operation completes.
- Read operations return store-owned `TDataSet` results. Callers read/close those results; do not free them or retain them beyond the store's lifetime. Repeating the same operation reuses its query.
- Write operations return affected-row counts. Services retain their existing zero-row/not-found handling.
- `ReserveRedeemCode` owns its transaction and returns False when no unused code is available. Call without an existing transaction. Services still send the SMS only after reservation commits, matching WC.
- Authorization, phone validation, verification-code generation, cryptographic checks, JWT issuance, DTO/JSON creation, and SMS delivery remain in the services.
## Current selection
Only WC/PostgreSQL is enabled in Client.Selection. Authentication, API device management, and WebSocket device checks no longer contain device-storage SQL. CAD agency/user authentication queries remain separate and still need client-specific integration before BFD can use the common server.
The Oracle implementation shares the operation contract and retains its uppercase Oracle 19c queries. It is not selected at runtime. No Oracle tables were created; no bypass switch was introduced.
## Verification
Both server projects compiled into temporary output folders. An offline Delphi test loaded both data-module DFMs, checked all queries stayed inactive, checked borrowed/default connection assignment, and verified a borrowed connection survived store destruction. No database was connected by that test.
Static comparisons verified PostgreSQL's 26 query texts against the original service SQL, checked call arguments and parameter bindings, and preserved response assignments, access guards, and exception messages. Oracle's query DFM was unchanged by the shared-interface extraction.
Live WC verification is pending: registration/verification, password and automatic device login, device listing, revoke/unrevoke, pending-device changes, username changes, WebSocket access checks, and app-link reservation/delivery where configured. Oracle SQL execution and concurrency tests await the tables.
emiMobileServer/Source/Api.ServiceImpl.pas → emiMobileServer/Shared/Server/Api.ServiceImpl.pas
......@@ -3,14 +3,13 @@ unit Api.ServiceImpl;
interface
uses
XData.Server.Module, XData.Service.Common, Client.Data, Data.DB,
XData.Server.Module, XData.Service.Common, Client.Data, Device.Store, Data.DB,
System.SysUtils, System.Generics.Collections, XData.Sys.Exceptions, System.StrUtils,
System.Hash, System.Classes, Common.Logging, System.JSON, Api.Service, VCL.Forms,
Auth.Service, Uni, UniProvider, PostgreSQLUniProvider, Common.Ini,
Auth.Service,
Sparkle.HttpServer.Context, System.NetEncoding, Common.Config,
System.Net.HttpClient, System.Net.URLClient;
type
[ServiceImplementation]
TApiService = class(TInterfacedObject, IApiService)
......@@ -23,7 +22,6 @@ type
procedure RequireMobileAccess;
procedure RequireAdmin;
procedure RequireActiveDevice;
function OpenLemsConnection: TUniConnection;
public
constructor Create;
destructor Destroy; override;
......@@ -56,7 +54,6 @@ implementation
uses
uLibrary, Client.Selection;
constructor TApiService.Create;
begin
Logger.Log(3, 'TApiService.Create');
......@@ -84,8 +81,6 @@ begin
inherited Destroy;
end;
function TApiService.GetBadgeCounts: TJSONObject;
begin
RequireMobileAccess;
......@@ -239,8 +234,8 @@ var
parts: TArray<string>;
padLen: Integer;
payloadObj: TJSONObject;
conn: TUniConnection;
q: TUniQuery;
store: TDeviceStore;
q: TDataSet;
begin
credId := '';
try
......@@ -271,23 +266,15 @@ begin
if credId = '' then Exit; // JWT predates this feature — allow through
deviceStatus := '';
conn := OpenLemsConnection;
store := CreateDeviceStore;
try
q := TUniQuery.Create(nil);
try
q.Connection := conn;
q.SQL.Text :=
'SELECT status FROM lems.device_registrations WHERE credential_id = :CID';
q.ParamByName('CID').AsString := credId;
q.Open;
if not q.IsEmpty then
deviceStatus := q.FieldByName('status').AsString;
q.Close;
finally
q.Free;
end;
q := store.DeviceStatus(credId);
if not q.IsEmpty then
deviceStatus := q.FieldByName('status').AsString;
q.Close;
finally
conn.Free;
store.Free;
end;
if deviceStatus = '' then
......@@ -303,23 +290,10 @@ begin
end;
end;
function TApiService.OpenLemsConnection: TUniConnection;
begin
Result := TUniConnection.Create(nil);
Result.ProviderName := 'PostgreSQL';
Result.Server := IniEntries.DatabaseServer;
Result.Port := IniEntries.DatabasePort;
Result.Database := IniEntries.DatabaseName;
Result.Username := IniEntries.DatabaseUsername;
Result.Password := IniEntries.DatabasePassword;
Result.LoginPrompt := False;
Result.Connect;
end;
function TApiService.GetDeviceList: TDeviceList;
var
conn: TUniConnection;
q: TUniQuery;
store: TDeviceStore;
q: TDataSet;
item: TDeviceItem;
begin
RequireAdmin;
......@@ -331,54 +305,44 @@ begin
Result.data := TList<TDeviceItem>.Create;
TXDataOperationContext.Current.Handler.ManagedObjects.Add(Result.data);
conn := OpenLemsConnection;
store := CreateDeviceStore;
try
q := TUniQuery.Create(nil);
q := store.DeviceList;
try
q.Connection := conn;
q.SQL.Text :=
'SELECT id, credential_id, device_name, device_type, phone_number, username, ' +
' user_agent, registered_at, revoked_at, revoked_by, status, ' +
' verification_code, ' +
' COALESCE(status = ''pending'' AND verification_expires_at > NOW(), FALSE) ' +
' AS verification_code_active ' +
'FROM lems.device_registrations ' +
'ORDER BY registered_at DESC';
q.Open;
try
while not q.Eof do
begin
item := TDeviceItem.Create;
TXDataOperationContext.Current.Handler.ManagedObjects.Add(item);
item.id := q.FieldByName('id').AsInteger;
item.credential_id := q.FieldByName('credential_id').AsString;
item.device_name := q.FieldByName('device_name').AsString;
item.device_type := q.FieldByName('device_type').AsString;
item.phone_number := q.FieldByName('phone_number').AsString;
item.username := q.FieldByName('username').AsString;
item.user_agent := q.FieldByName('user_agent').AsString;
item.registered_at := q.FieldByName('registered_at').AsString;
if q.FieldByName('revoked_at').IsNull then
item.revoked_at := ''
else
item.revoked_at := q.FieldByName('revoked_at').AsString;
item.revoked_by := q.FieldByName('revoked_by').AsString;
item.status := q.FieldByName('status').AsString;
item.verification_code := q.FieldByName('verification_code').AsString;
item.verification_code_active := q.FieldByName('verification_code_active').AsBoolean;
Result.data.Add(item);
q.Next;
end;
finally
q.Close;
while not q.Eof do
begin
item := TDeviceItem.Create;
TXDataOperationContext.Current.Handler.ManagedObjects.Add(item);
item.id := q.FieldByName('id').AsInteger;
item.credential_id := q.FieldByName('credential_id').AsString;
item.device_name := q.FieldByName('device_name').AsString;
item.device_type := q.FieldByName('device_type').AsString;
item.phone_number := q.FieldByName('phone_number').AsString;
item.username := q.FieldByName('username').AsString;
item.user_agent := q.FieldByName('user_agent').AsString;
item.registered_at := q.FieldByName('registered_at').AsString;
if q.FieldByName('revoked_at').IsNull then
item.revoked_at := ''
else
item.revoked_at := q.FieldByName('revoked_at').AsString;
item.revoked_by := q.FieldByName('revoked_by').AsString;
item.status := q.FieldByName('status').AsString;
item.verification_code := q.FieldByName('verification_code').AsString;
if q.FieldByName('verification_code_active').DataType = ftBoolean then
item.verification_code_active := q.FieldByName('verification_code_active').AsBoolean
else
item.verification_code_active := q.FieldByName('verification_code_active').AsInteger = 1;
Result.data.Add(item);
q.Next;
end;
finally
q.Free;
q.Close;
end;
finally
conn.Free;
store.Free;
end;
Result.count := Result.data.Count;
......@@ -388,8 +352,8 @@ end;
function TApiService.RevokeDevice(const CredentialId: string): TJSONObject;
var
conn: TUniConnection;
q: TUniQuery;
affectedRows: Int64;
store: TDeviceStore;
ctx: THttpServerContext;
revokedBy, authHeader, b64p, payload: string;
parts: TArray<string>;
......@@ -440,44 +404,32 @@ begin
Logger.Log(2, Format('TApiService.RevokeDevice - credId: %s by: %s', [Copy(CredentialId, 1, 20), revokedBy]));
conn := OpenLemsConnection;
store := CreateDeviceStore;
try
q := TUniQuery.Create(nil);
try
q.Connection := conn;
q.SQL.Text :=
'UPDATE lems.device_registrations ' +
'SET revoked_at = NOW(), revoked_by = :REVOKED_BY, status = ''revoked'' ' +
'WHERE credential_id = :CID AND status = ''active''';
q.ParamByName('REVOKED_BY').AsString := revokedBy;
q.ParamByName('CID').AsString := Trim(CredentialId);
q.ExecSQL;
if q.RowsAffected > 0 then
begin
Logger.Log(2, 'TApiService.RevokeDevice - revoked credential: ' + Copy(CredentialId, 1, 20));
Result.AddPair('status', 'ok');
Result.AddPair('message', 'Device access revoked.');
end
else
begin
Logger.Log(2, 'TApiService.RevokeDevice - not found or already revoked: ' + Copy(CredentialId, 1, 20));
Result.AddPair('status', 'error');
Result.AddPair('message', 'Device not found or already revoked.');
end;
finally
q.Free;
affectedRows := store.RevokeDevice(revokedBy, Trim(CredentialId));
if affectedRows > 0 then
begin
Logger.Log(2, 'TApiService.RevokeDevice - revoked credential: ' + Copy(CredentialId, 1, 20));
Result.AddPair('status', 'ok');
Result.AddPair('message', 'Device access revoked.');
end
else
begin
Logger.Log(2, 'TApiService.RevokeDevice - not found or already revoked: ' + Copy(CredentialId, 1, 20));
Result.AddPair('status', 'error');
Result.AddPair('message', 'Device not found or already revoked.');
end;
finally
conn.Free;
store.Free;
end;
end;
function TApiService.UnrevokeDevice(const CredentialId: string): TJSONObject;
var
conn: TUniConnection;
q: TUniQuery;
affectedRows: Int64;
store: TDeviceStore;
begin
RequireAdmin;
......@@ -493,35 +445,25 @@ begin
Logger.Log(2, 'TApiService.UnrevokeDevice - credId: ' + Copy(CredentialId, 1, 20));
conn := OpenLemsConnection;
store := CreateDeviceStore;
try
q := TUniQuery.Create(nil);
try
q.Connection := conn;
q.SQL.Text :=
'UPDATE lems.device_registrations ' +
'SET revoked_at = NULL, revoked_by = NULL, status = ''active'' ' +
'WHERE credential_id = :CID AND status = ''revoked''';
q.ParamByName('CID').AsString := Trim(CredentialId);
q.ExecSQL;
if q.RowsAffected > 0 then
begin
Logger.Log(2, 'TApiService.UnrevokeDevice - restored: ' + Copy(CredentialId, 1, 20));
Result.AddPair('status', 'ok');
Result.AddPair('message', 'Device access restored.');
end
else
begin
Logger.Log(2, 'TApiService.UnrevokeDevice - not found or not revoked: ' + Copy(CredentialId, 1, 20));
Result.AddPair('status', 'error');
Result.AddPair('message', 'Device not found or not revoked.');
end;
finally
q.Free;
affectedRows := store.UnrevokeDevice(Trim(CredentialId));
if affectedRows > 0 then
begin
Logger.Log(2, 'TApiService.UnrevokeDevice - restored: ' + Copy(CredentialId, 1, 20));
Result.AddPair('status', 'ok');
Result.AddPair('message', 'Device access restored.');
end
else
begin
Logger.Log(2, 'TApiService.UnrevokeDevice - not found or not revoked: ' + Copy(CredentialId, 1, 20));
Result.AddPair('status', 'error');
Result.AddPair('message', 'Device not found or not revoked.');
end;
finally
conn.Free;
store.Free;
end;
end;
......@@ -544,8 +486,8 @@ end;
function TApiService.AddPendingDevice(const DeviceName, PhoneNumber,
DeviceType: string): TJSONObject;
var
conn: TUniConnection;
q: TUniQuery;
store: TDeviceStore;
q: TDataSet;
normalizedPhone, normalizedDeviceType: string;
begin
RequireAdmin;
......@@ -582,51 +524,35 @@ begin
end;
end;
conn := OpenLemsConnection;
store := CreateDeviceStore;
try
q := TUniQuery.Create(nil);
try
q.Connection := conn;
// Reject if a pending entry with this phone already exists
q.SQL.Text :=
'SELECT id FROM lems.device_registrations ' +
'WHERE phone_number = :PHONE AND status = ''pending''';
q.ParamByName('PHONE').AsString := normalizedPhone;
q.Open;
if not q.IsEmpty then
begin
q.Close;
Result.AddPair('status', 'error');
Result.AddPair('message', 'A pending entry for that phone number already exists.');
Exit;
end;
// Reject if a pending entry with this phone already exists
q := store.PendingPhone(normalizedPhone);
if not q.IsEmpty then
begin
q.Close;
Result.AddPair('status', 'error');
Result.AddPair('message', 'A pending entry for that phone number already exists.');
Exit;
end;
q.Close;
q.SQL.Text :=
'INSERT INTO lems.device_registrations ' +
'(device_name, device_type, phone_number, status) ' +
'VALUES (:NAME, :TYPE, :PHONE, ''pending'')';
q.ParamByName('NAME').AsString := Trim(DeviceName);
q.ParamByName('TYPE').AsString := normalizedDeviceType;
q.ParamByName('PHONE').AsString := normalizedPhone;
q.ExecSQL;
store.AddPendingDevice(Trim(DeviceName), normalizedDeviceType, normalizedPhone);
Logger.Log(2, 'TApiService.AddPendingDevice - added "' + Trim(DeviceName) + '" phone: ' + normalizedPhone);
Result.AddPair('status', 'ok');
Result.AddPair('message', 'Pending device added.');
Logger.Log(2, 'TApiService.AddPendingDevice - added "' + Trim(DeviceName) + '" phone: ' + normalizedPhone);
Result.AddPair('status', 'ok');
Result.AddPair('message', 'Pending device added.');
finally
q.Free;
end;
finally
conn.Free;
store.Free;
end;
end;
function TApiService.DeletePendingDevice(const PhoneNumber: string): TJSONObject;
var
conn: TUniConnection;
q: TUniQuery;
affectedRows: Int64;
store: TDeviceStore;
normalizedPhone: string;
begin
RequireAdmin;
......@@ -645,40 +571,31 @@ begin
end;
end;
conn := OpenLemsConnection;
store := CreateDeviceStore;
try
q := TUniQuery.Create(nil);
try
q.Connection := conn;
q.SQL.Text :=
'DELETE FROM lems.device_registrations ' +
'WHERE phone_number = :PHONE AND status = ''pending''';
q.ParamByName('PHONE').AsString := normalizedPhone;
q.ExecSQL;
if q.RowsAffected > 0 then
begin
Logger.Log(2, 'TApiService.DeletePendingDevice - deleted phone: ' + normalizedPhone);
Result.AddPair('status', 'ok');
Result.AddPair('message', 'Pending device removed.');
end
else
begin
Result.AddPair('status', 'error');
Result.AddPair('message', 'Pending device not found.');
end;
finally
q.Free;
affectedRows := store.DeletePendingDevice(normalizedPhone);
if affectedRows > 0 then
begin
Logger.Log(2, 'TApiService.DeletePendingDevice - deleted phone: ' + normalizedPhone);
Result.AddPair('status', 'ok');
Result.AddPair('message', 'Pending device removed.');
end
else
begin
Result.AddPair('status', 'error');
Result.AddPair('message', 'Pending device not found.');
end;
finally
conn.Free;
store.Free;
end;
end;
function TApiService.DeleteDevice(CredentialId: string): TJSONObject;
var
conn: TUniConnection;
q: TUniQuery;
affectedRows: Int64;
store: TDeviceStore;
begin
RequireAdmin;
......@@ -692,41 +609,31 @@ begin
Exit;
end;
conn := OpenLemsConnection;
store := CreateDeviceStore;
try
q := TUniQuery.Create(nil);
try
q.Connection := conn;
q.SQL.Text :=
'DELETE FROM lems.device_registrations ' +
'WHERE credential_id = :CID';
q.ParamByName('CID').AsString := Trim(CredentialId);
q.ExecSQL;
if q.RowsAffected > 0 then
begin
Logger.Log(2, 'TApiService.DeleteDevice - deleted credential: ' +
Copy(CredentialId, 1, 20));
Result.AddPair('status', 'ok');
Result.AddPair('message', 'Device deleted.');
end
else
begin
Result.AddPair('status', 'error');
Result.AddPair('message', 'Device not found.');
end;
finally
q.Free;
affectedRows := store.DeleteDevice(Trim(CredentialId));
if affectedRows > 0 then
begin
Logger.Log(2, 'TApiService.DeleteDevice - deleted credential: ' +
Copy(CredentialId, 1, 20));
Result.AddPair('status', 'ok');
Result.AddPair('message', 'Device deleted.');
end
else
begin
Result.AddPair('status', 'error');
Result.AddPair('message', 'Device not found.');
end;
finally
conn.Free;
store.Free;
end;
end;
function TApiService.SendAppLink(const PhoneNumber: string): TJSONObject;
var
conn: TUniConnection;
q: TUniQuery;
store: TDeviceStore;
normalizedPhone, redeemCode, linkUrl, msgBody: string;
httpClient: THTTPClient;
bodyStream: TStringStream;
......@@ -759,47 +666,16 @@ begin
// Pick an unused redeem code (SKIP LOCKED for concurrent safety)
redeemCode := '';
conn := OpenLemsConnection;
store := CreateDeviceStore;
try
q := TUniQuery.Create(nil);
try
q.Connection := conn;
conn.StartTransaction;
try
q.SQL.Text :=
'SELECT code FROM lems.redeem_codes ' +
'WHERE used_at IS NULL ' +
'ORDER BY id ' +
'LIMIT 1 FOR UPDATE SKIP LOCKED';
q.Open;
if q.IsEmpty then
begin
q.Close;
conn.Rollback;
Result.AddPair('status', 'error');
Result.AddPair('message', 'No unused redeem codes available.');
Exit;
end;
redeemCode := q.FieldByName('code').AsString;
q.Close;
q.SQL.Text :=
'UPDATE lems.redeem_codes SET used_at = NOW(), used_for = :PHONE ' +
'WHERE code = :CODE';
q.ParamByName('PHONE').AsString := normalizedPhone;
q.ParamByName('CODE').AsString := redeemCode;
q.ExecSQL;
conn.Commit;
except
conn.Rollback;
raise;
end;
finally
q.Free;
if not store.ReserveRedeemCode(normalizedPhone, redeemCode) then
begin
Result.AddPair('status', 'error');
Result.AddPair('message', 'No unused redeem codes available.');
Exit;
end;
finally
conn.Free;
store.Free;
end;
// Build and send Twilio SMS
......@@ -838,8 +714,8 @@ end;
function TApiService.UpdateDeviceUsername(const CredentialId, Username: string): TJSONObject;
var
conn: TUniConnection;
q: TUniQuery;
affectedRows: Int64;
store: TDeviceStore;
begin
RequireAdmin;
......@@ -853,30 +729,19 @@ begin
Exit;
end;
conn := OpenLemsConnection;
store := CreateDeviceStore;
try
q := TUniQuery.Create(nil);
try
q.Connection := conn;
q.SQL.Text :=
'UPDATE lems.device_registrations ' +
'SET username = :UNAME ' +
'WHERE credential_id = :CID AND status = ''active''';
q.ParamByName('UNAME').AsString := Trim(Username);
q.ParamByName('CID').AsString := Trim(CredentialId);
q.ExecSQL;
if q.RowsAffected = 0 then
begin
Result.AddPair('status', 'error');
Result.AddPair('message', 'Device not found or not active.');
Exit;
end;
finally
q.Free;
affectedRows := store.UpdateDeviceUsername(Trim(Username), Trim(CredentialId));
if affectedRows = 0 then
begin
Result.AddPair('status', 'error');
Result.AddPair('message', 'Device not found or not active.');
Exit;
end;
finally
conn.Free;
store.Free;
end;
Logger.Log(2, Format('TApiService.UpdateDeviceUsername - set username "%s" on credId %s',
......
emiMobileServer/Source/Auth.ServiceImpl.pas → emiMobileServer/Shared/Server/Auth.ServiceImpl.pas
unit Auth.ServiceImpl;
unit Auth.ServiceImpl;
interface
......@@ -6,14 +6,15 @@ uses
XData.Service.Common,
XData.Server.Module,
Auth.Service,
Auth.Database,
Client.Auth, Device.Store,
Uni, Data.DB, System.JSON, System.SysUtils, System.IOUtils, IniFiles;
type
[ServiceImplementation]
TAuthService = class(TInterfacedObject, IAuthService)
strict private
authDB: TAuthDatabase;
authDB: TClientAuth;
FDeviceStore: TDeviceStore;
private
userName: string;
userFullName: string;
......@@ -22,14 +23,12 @@ type
userId: string;
userPersonnelId: string;
userIsAdmin: Boolean;
//procedure AfterConstruction; override;
//procedure BeforeDestruction; override;
function VerifyVersion(ClientVersion: string): TJSONObject;
function CheckUser(const User, Password, Agency: string): Integer;
function LoadUserByName(const User, Agency: string): Boolean;
function Decrypt(inStr, keyStr: AnsiString): AnsiString;
function GenerateVerificationCode: string;
procedure SendVerificationText(const PhoneNumber, Code: string);
function SendVerificationText(const PhoneNumber, Code: string): Boolean;
// Returns True and sets AChallengeB64 if token is valid and of the expected type
function VerifyChallengeToken(const ChallengeToken, ExpectedType: string;
out AChallengeB64: string): Boolean;
......@@ -61,6 +60,7 @@ type
implementation
uses
Client.Selection,
System.DateUtils,
System.Classes,
System.Generics.Collections,
......@@ -82,19 +82,21 @@ begin
Logger.Log(3, 'TAuthService.Create');
inherited Create;
authDB := TAuthDatabase.Create(nil);
authDB := CreateClientAuth;
if not authDB.ucLemsOCSO.Connected then
if not authDB.Connection.Connected then
begin
Logger.Log(1, 'Unable to connect to auth database');
raise EXDataHttpException.Create(500, 'Unable to connect to the database. Please contact EM Systems support.');
end;
FDeviceStore := CreateDeviceStore(authDB.Connection);
Logger.Log(3, 'AuthDatabase created');
end;
destructor TAuthService.Destroy;
begin
FDeviceStore.Free;
authDB.Free;
Logger.Log(3, 'AuthDatabase destroyed');
inherited Destroy;
......@@ -209,7 +211,7 @@ begin
Result := FormatFloat('000000', value mod 1000000);
end;
procedure TAuthService.SendVerificationText(const PhoneNumber, Code: string);
function TAuthService.SendVerificationText(const PhoneNumber, Code: string): Boolean;
var
httpClient: THTTPClient;
bodyStream: TStringStream;
......@@ -239,9 +241,10 @@ begin
response := httpClient.Post(
'https://api.twilio.com/2010-04-01/Accounts/' +
ServerConfig.twilioAccountSid + '/Messages.json', bodyStream);
if response.StatusCode >= 300 then
raise Exception.CreateFmt('Twilio error %d: %s',
[response.StatusCode, response.ContentAsString]);
Result := (response.StatusCode >= 200) and (response.StatusCode < 300);
if not Result then
Logger.Log(2, Format('Twilio rejected verification SMS, HTTP %d: %s',
[response.StatusCode, response.ContentAsString]));
finally
bodyStream.Free;
end;
......@@ -256,9 +259,10 @@ end;
function TAuthService.BeginRegistration(const PhoneNumber: string): TJSONObject;
var
affectedRows: Int64;
code, normalizedPhone, deviceName: string;
deviceId: Integer;
q: TUniQuery;
q: TDataSet;
begin
Logger.Log(3, '---TAuthService.BeginRegistration initiated with phone number: ' + PhoneNumber);
......@@ -284,72 +288,30 @@ begin
end;
// Verify phone number was pre-authorized by admin
q := TUniQuery.Create(nil);
try
q.Connection := authDB.ucLemsOCSO;
q.SQL.Text :=
'SELECT id, device_name FROM lems.device_registrations ' +
'WHERE phone_number = :PHONE AND status = ''pending''';
q.ParamByName('PHONE').AsString := normalizedPhone;
q.Open;
if q.IsEmpty then
begin
q.Close;
Logger.Log(2, 'BeginRegistration - phone not pre-authorized: "' + normalizedPhone + '"');
Result.AddPair('status', 'error');
Result.AddPair('message', 'Phone number not recognized. Contact your administrator.');
Exit;
end;
deviceId := q.FieldByName('id').AsInteger;
deviceName := q.FieldByName('device_name').AsString;
q := FDeviceStore.PendingDevice(normalizedPhone);
if q.IsEmpty then
begin
q.Close;
finally
q.Free;
Logger.Log(2, 'BeginRegistration - phone not pre-authorized: "' + normalizedPhone + '"');
Result.AddPair('status', 'error');
Result.AddPair('message', 'Phone number not recognized. Contact your administrator.');
Exit;
end;
deviceId := q.FieldByName('id').AsInteger;
deviceName := q.FieldByName('device_name').AsString;
q.Close;
code := GenerateVerificationCode;
q := TUniQuery.Create(nil);
try
q.Connection := authDB.ucLemsOCSO;
q.SQL.Text :=
'UPDATE lems.device_registrations ' +
'SET verification_code = :CODE, ' +
' verification_expires_at = NOW() + INTERVAL ''5 minutes'' ' +
'WHERE phone_number = :PHONE AND status = ''pending''';
q.ParamByName('CODE').AsString := code;
q.ParamByName('PHONE').AsString := normalizedPhone;
q.ExecSQL;
if q.RowsAffected = 0 then
if not SendVerificationText(normalizedPhone, code) then
begin
Result.AddPair('status', 'error');
Result.AddPair('message', 'Phone number not recognized. Contact your administrator.');
Result.AddPair('message', 'The SMS provider rejected the verification message. Contact your administrator to check the phone number and SMS configuration.');
Exit;
end;
finally
q.Free;
end;
try
SendVerificationText(normalizedPhone, code);
except
on E: Exception do
begin
q := TUniQuery.Create(nil);
try
q.Connection := authDB.ucLemsOCSO;
q.SQL.Text :=
'UPDATE lems.device_registrations ' +
'SET verification_code = NULL, verification_expires_at = NULL ' +
'WHERE phone_number = :PHONE AND status = ''pending'' ' +
'AND verification_code = :CODE';
q.ParamByName('PHONE').AsString := normalizedPhone;
q.ParamByName('CODE').AsString := code;
q.ExecSQL;
finally
q.Free;
end;
Logger.Log(2, '--Error sending registration verification code: ' + E.Message);
Result.AddPair('status', 'error');
Result.AddPair('message', 'The verification code could not be sent. Please try again.');
......@@ -357,6 +319,15 @@ begin
end;
end;
// Note: Persist the code only after the SMS provider accepts the message.
affectedRows := FDeviceStore.SetVerificationCode(code, normalizedPhone);
if affectedRows = 0 then
begin
Result.AddPair('status', 'error');
Result.AddPair('message', 'Phone number not recognized. Contact your administrator.');
Exit;
end;
Logger.Log(3, Format(
'Verification code sent for device id %d and device name: %s',
[deviceId, deviceName]));
......@@ -368,9 +339,9 @@ end;
function TAuthService.VerifyRegistrationCode(const PhoneNumber,
VerificationCode: string): TJSONObject;
var
affectedRows: Int64;
normalizedPhone, token, challengeB64: string;
verificationValid: Boolean;
q: TUniQuery;
begin
Result := TJSONObject.Create;
TXDataOperationContext.Current.Handler.ManagedObjects.Add(Result);
......@@ -389,21 +360,9 @@ begin
verificationValid := False;
if Length(Trim(VerificationCode)) = 6 then
begin
q := TUniQuery.Create(nil);
try
q.Connection := authDB.ucLemsOCSO;
q.SQL.Text :=
'UPDATE lems.device_registrations ' +
'SET verification_code = NULL, verification_expires_at = NULL ' +
'WHERE phone_number = :PHONE AND status = ''pending'' ' +
'AND verification_code = :CODE AND verification_expires_at > NOW()';
q.ParamByName('PHONE').AsString := normalizedPhone;
q.ParamByName('CODE').AsString := Trim(VerificationCode);
q.ExecSQL;
verificationValid := q.RowsAffected > 0;
finally
q.Free;
end;
affectedRows := FDeviceStore.ConsumeVerificationCode(normalizedPhone, Trim(VerificationCode));
verificationValid := affectedRows > 0;
end;
if not verificationValid then
......@@ -433,6 +392,7 @@ end;
function TAuthService.CompleteRegistration(const PhoneNumber, CredentialId,
AttestationObject, ClientDataJSON, ChallengeToken: string): TJSONObject;
var
affectedRows: Int64;
challengeB64: string;
cdJsonBytes, attObjBytes, credIdBytes: TBytes;
cdJsonText: string;
......@@ -444,7 +404,6 @@ var
signCount: Cardinal;
pubKeyAlg: Integer;
expectedRpIdHash: TBytes;
q: TUniQuery;
credIdB64: string;
begin
Result := TJSONObject.Create;
......@@ -520,7 +479,6 @@ begin
effectiveRpId := ServerConfig.rpId;
Logger.Log(2, 'CompleteRegistration - effectiveRpId: "' + effectiveRpId + '" origin: "' + originVal + '"');
// 3. Decode attestationObject and extract authData
try
attObjBytes := Base64UrlDecode(AttestationObject);
......@@ -583,41 +541,20 @@ begin
end;
// 9. Activate the pending row
q := TUniQuery.Create(nil);
try
q.Connection := authDB.ucLemsOCSO;
var ctx := THttpServerContext.Current;
var userAgent: string := '';
if ctx <> nil then
userAgent := ctx.Request.Headers.Get('User-Agent');
q.SQL.Text :=
'UPDATE lems.device_registrations ' +
'SET credential_id = :CID, user_agent = :AGENT, ' +
' public_key_x = :KEYX, public_key_y = :KEYY, ' +
' public_key_alg = :ALG, sign_count = :CNT, ' +
' verification_code = NULL, verification_expires_at = NULL, ' +
' status = ''active'', registered_at = NOW() ' +
'WHERE phone_number = :PHONE AND status = ''pending''';
q.ParamByName('CID').AsString := Trim(CredentialId);
q.ParamByName('AGENT').AsString := userAgent;
q.ParamByName('KEYX').AsBytes := pubKeyX;
q.ParamByName('KEYY').AsBytes := pubKeyY;
q.ParamByName('ALG').AsInteger := pubKeyAlg;
q.ParamByName('CNT').AsInteger := Integer(signCount);
q.ParamByName('PHONE').AsString := normalizedPhone;
q.ExecSQL;
if q.RowsAffected = 0 then
begin
Logger.Log(2, 'CompleteRegistration - no pending row for phone "' + normalizedPhone + '"');
Result.AddPair('status', 'error');
Result.AddPair('message', 'Phone number is not pending registration. Contact your administrator.');
Exit;
end;
finally
q.Free;
var ctx := THttpServerContext.Current;
var userAgent: string := '';
if ctx <> nil then
userAgent := ctx.Request.Headers.Get('User-Agent');
affectedRows := FDeviceStore.ActivateWebAuthnDevice(Trim(CredentialId), userAgent, pubKeyX, pubKeyY, pubKeyAlg, Integer(signCount), normalizedPhone);
if affectedRows = 0 then
begin
Logger.Log(2, 'CompleteRegistration - no pending row for phone "' + normalizedPhone + '"');
Result.AddPair('status', 'error');
Result.AddPair('message', 'Phone number is not pending registration. Contact your administrator.');
Exit;
end;
Logger.Log(2, 'CompleteRegistration - activated credential for phone "' + normalizedPhone + '"');
......@@ -632,7 +569,7 @@ end;
function TAuthService.BeginAuthentication(const CredentialId: string): TJSONObject;
var
q: TUniQuery;
q: TDataSet;
token, challengeB64: string;
begin
Logger.Log(2, 'AuthService.BeginAuthentication - credId: ' + Copy(CredentialId, 1, 20));
......@@ -647,26 +584,16 @@ begin
end;
// Verify the credential exists and is not revoked
q := TUniQuery.Create(nil);
q := FDeviceStore.UnrevokedDeviceUser(Trim(CredentialId));
try
q.Connection := authDB.ucLemsOCSO;
q.SQL.Text :=
'SELECT username, agency FROM lems.device_registrations ' +
'WHERE credential_id = :CID AND revoked_at IS NULL';
q.ParamByName('CID').AsString := Trim(CredentialId);
q.Open;
try
if q.IsEmpty then
begin
Logger.Log(2, 'BeginAuthentication - credential not found or revoked');
Result.AddPair('error', 'Device not registered or access has been revoked.');
Exit;
end;
finally
q.Close;
if q.IsEmpty then
begin
Logger.Log(2, 'BeginAuthentication - credential not found or revoked');
Result.AddPair('error', 'Device not registered or access has been revoked.');
Exit;
end;
finally
q.Free;
q.Close;
end;
token := MakeChallengeToken('auth');
......@@ -683,7 +610,7 @@ end;
function TAuthService.GetDeviceUser(const CredentialId: string): TJSONObject;
var
q: TUniQuery;
q: TDataSet;
begin
Result := TJSONObject.Create;
TXDataOperationContext.Current.Handler.ManagedObjects.Add(Result);
......@@ -694,32 +621,22 @@ begin
Result.AddPair('agency', '');
Exit;
end;
q := TUniQuery.Create(nil);
q := FDeviceStore.ActiveDeviceUser(Trim(CredentialId));
try
q.Connection := authDB.ucLemsOCSO;
q.SQL.Text :=
'SELECT username, agency FROM lems.device_registrations ' +
'WHERE credential_id = :CID AND status = ''active''';
q.ParamByName('CID').AsString := Trim(CredentialId);
q.Open;
try
if q.IsEmpty then
begin
Result.AddPair('username', '');
Result.AddPair('agency', '');
end
else
begin
Result.AddPair('username', q.FieldByName('username').AsString);
Result.AddPair('agency', q.FieldByName('agency').AsString);
end;
finally
q.Close;
if q.IsEmpty then
begin
Result.AddPair('username', '');
Result.AddPair('agency', '');
end
else
begin
Result.AddPair('username', q.FieldByName('username').AsString);
Result.AddPair('agency', q.FieldByName('agency').AsString);
end;
finally
q.Free;
q.Close;
end;
end;
// ---------------------------------------------------------------------------
......@@ -740,7 +657,7 @@ var
signCount: Cardinal;
pubKeyX, pubKeyY: TBytes;
message: TBytes;
q: TUniQuery;
q: TDataSet;
storedSignCount: Int64;
JWT: TJWT;
begin
......@@ -805,29 +722,18 @@ begin
Logger.Log(2, Format('AuthService.Login - effectiveRpId: "%s" origin: "%s"', [loginEffectiveRpId, loginOriginVal]));
// 4. Load credential from DB
q := TUniQuery.Create(nil);
q := FDeviceStore.UnrevokedDeviceKey(Trim(credentialId));
try
q.Connection := authDB.ucLemsOCSO;
q.SQL.Text :=
'SELECT public_key_x, public_key_y, sign_count ' +
'FROM lems.device_registrations ' +
'WHERE credential_id = :CID AND revoked_at IS NULL';
q.ParamByName('CID').AsString := Trim(credentialId);
q.Open;
try
if q.IsEmpty then
begin
Logger.Log(2, 'AuthService.Login - credential not found or revoked: ' + Copy(credentialId, 1, 20));
raise EXDataHttpUnauthorized.Create('Device not registered or access has been revoked.');
end;
pubKeyX := q.FieldByName('public_key_x').AsBytes;
pubKeyY := q.FieldByName('public_key_y').AsBytes;
storedSignCount := q.FieldByName('sign_count').AsLargeInt;
finally
q.Close;
if q.IsEmpty then
begin
Logger.Log(2, 'AuthService.Login - credential not found or revoked: ' + Copy(credentialId, 1, 20));
raise EXDataHttpUnauthorized.Create('Device not registered or access has been revoked.');
end;
pubKeyX := q.FieldByName('public_key_x').AsBytes;
pubKeyY := q.FieldByName('public_key_y').AsBytes;
storedSignCount := q.FieldByName('sign_count').AsLargeInt;
finally
q.Free;
q.Close;
end;
// 5. Parse authenticatorData
......@@ -880,18 +786,7 @@ begin
if (storedSignCount > 0) and (Int64(signCount) <= storedSignCount) then
Logger.Log(1, 'AuthService.Login - WARNING: sign count did not increase (possible cloned authenticator)');
q := TUniQuery.Create(nil);
try
q.Connection := authDB.ucLemsOCSO;
q.SQL.Text :=
'UPDATE lems.device_registrations SET sign_count = :CNT WHERE credential_id = :CID';
q.ParamByName('CNT').AsInteger := Integer(signCount);
q.ParamByName('CID').AsString := Trim(credentialId);
q.ExecSQL;
finally
q.Free;
end;
FDeviceStore.UpdateSignCount(Integer(signCount), Trim(credentialId));
// 8. Issue JWT
Logger.Log(2, Format('AuthService.Login - success for User: "%s" Agency: "%s"', [user, agency]));
......@@ -915,20 +810,8 @@ begin
end;
// 9. Persist username + agency on the device record so future auto-login works
q := TUniQuery.Create(nil);
try
q.Connection := authDB.ucLemsOCSO;
q.SQL.Text :=
'UPDATE lems.device_registrations ' +
'SET username = :UNAME, agency = :AGCY ' +
'WHERE credential_id = :CID';
q.ParamByName('UNAME').AsString := userName;
q.ParamByName('AGCY').AsString := userAgency;
q.ParamByName('CID').AsString := Trim(credentialId);
q.ExecSQL;
finally
q.Free;
end;
FDeviceStore.SaveDeviceUser(userName, userAgency, Trim(credentialId));
end;
// ---------------------------------------------------------------------------
......@@ -937,31 +820,24 @@ end;
function TAuthService.LoadUserByName(const User, Agency: string): Boolean;
begin
authDB.uqAuth.Close;
authDB.uqAuth.SQL.Text :=
'select u.* from lems.users u ' +
'where upper(user_name) = :USER_NAME ' +
'and u.dept = :AGENCY';
authDB.uqAuth.ParamByName('USER_NAME').AsString := UpperCase(Trim(User));
authDB.uqAuth.ParamByName('AGENCY').AsString := UpperCase(Trim(Agency));
authDB.uqAuth.Open;
authDB.OpenUser(User, Agency);
try
if authDB.uqAuth.IsEmpty then
if authDB.UserData.IsEmpty then
Exit(False);
if authDB.uqAuth.FieldByName('active').AsString = 'F' then
if authDB.UserData.FieldByName('active').AsString = 'F' then
Exit(False);
userName := authDB.uqAuth.FieldByName('user_name').AsString;
userFullName := authDB.uqAuth.FieldByName('firstname').AsString + ' ' +
authDB.uqAuth.FieldByName('lastname').AsString;
userAgency := authDB.uqAuth.FieldByName('dept').AsString;
userBadge := authDB.uqAuth.FieldByName('badgenum').AsString;
userId := authDB.uqAuth.FieldByName('userid').AsString;
userPersonnelId := authDB.uqAuth.FieldByName('personnelid').AsString;
userName := authDB.UserData.FieldByName('user_name').AsString;
userFullName := authDB.UserData.FieldByName('firstname').AsString + ' ' +
authDB.UserData.FieldByName('lastname').AsString;
userAgency := authDB.UserData.FieldByName('dept').AsString;
userBadge := authDB.UserData.FieldByName('badgenum').AsString;
userId := authDB.UserData.FieldByName('userid').AsString;
userPersonnelId := authDB.UserData.FieldByName('personnelid').AsString;
userIsAdmin := SameText(Trim(User), 'admin');
Result := True;
finally
authDB.uqAuth.Close;
authDB.UserData.Close;
end;
end;
......@@ -983,7 +859,7 @@ var
signCount: Cardinal;
pubKeyX, pubKeyY: TBytes;
message: TBytes;
q: TUniQuery;
q: TDataSet;
storedSignCount: Int64;
storedUsername, storedAgency: string;
JWT: TJWT;
......@@ -1027,28 +903,17 @@ begin
// 3. Load credential + stored username/agency from DB
storedUsername := '';
storedAgency := '';
q := TUniQuery.Create(nil);
q := FDeviceStore.ActiveDeviceKey(Trim(CredentialId));
try
q.Connection := authDB.ucLemsOCSO;
q.SQL.Text :=
'SELECT public_key_x, public_key_y, sign_count, username, agency ' +
'FROM lems.device_registrations ' +
'WHERE credential_id = :CID AND status = ''active''';
q.ParamByName('CID').AsString := Trim(CredentialId);
q.Open;
try
if q.IsEmpty then
raise EXDataHttpUnauthorized.Create('Device not registered or access has been revoked.');
pubKeyX := q.FieldByName('public_key_x').AsBytes;
pubKeyY := q.FieldByName('public_key_y').AsBytes;
storedSignCount := q.FieldByName('sign_count').AsLargeInt;
storedUsername := q.FieldByName('username').AsString;
storedAgency := q.FieldByName('agency').AsString;
finally
q.Close;
end;
if q.IsEmpty then
raise EXDataHttpUnauthorized.Create('Device not registered or access has been revoked.');
pubKeyX := q.FieldByName('public_key_x').AsBytes;
pubKeyY := q.FieldByName('public_key_y').AsBytes;
storedSignCount := q.FieldByName('sign_count').AsLargeInt;
storedUsername := q.FieldByName('username').AsString;
storedAgency := q.FieldByName('agency').AsString;
finally
q.Free;
q.Close;
end;
if (storedUsername = '') or (storedAgency = '') then
......@@ -1099,18 +964,7 @@ begin
if (storedSignCount > 0) and (Int64(signCount) <= storedSignCount) then
Logger.Log(1, 'AuthService.LoginAutomatic - WARNING: sign count did not increase');
q := TUniQuery.Create(nil);
try
q.Connection := authDB.ucLemsOCSO;
q.SQL.Text :=
'UPDATE lems.device_registrations SET sign_count = :CNT WHERE credential_id = :CID';
q.ParamByName('CNT').AsInteger := Integer(signCount);
q.ParamByName('CID').AsString := Trim(CredentialId);
q.ExecSQL;
finally
q.Free;
end;
FDeviceStore.UpdateSignCount(Integer(signCount), Trim(CredentialId));
// 7. Load user details from CAD (no password check)
if not LoadUserByName(storedUsername, storedAgency) then
......@@ -1147,8 +1001,8 @@ end;
function TAuthService.CompleteRegistrationSimple(const PhoneNumber, DeviceKey,
ChallengeToken: string): TJSONObject;
var
affectedRows: Int64;
challengeB64, normalizedPhone: string;
q: TUniQuery;
begin
Result := TJSONObject.Create;
TXDataOperationContext.Current.Handler.ManagedObjects.Add(Result);
......@@ -1181,36 +1035,19 @@ begin
Exit;
end;
q := TUniQuery.Create(nil);
try
q.Connection := authDB.ucLemsOCSO;
var ctx := THttpServerContext.Current;
var userAgent: string := '';
if ctx <> nil then
userAgent := ctx.Request.Headers.Get('User-Agent');
q.SQL.Text :=
'UPDATE lems.device_registrations ' +
'SET credential_id = :CID, user_agent = :AGENT, ' +
' key_type = ''simple'', ' +
' verification_code = NULL, verification_expires_at = NULL, ' +
' status = ''active'', registered_at = NOW() ' +
'WHERE phone_number = :PHONE AND status = ''pending''';
q.ParamByName('CID').AsString := Trim(DeviceKey);
q.ParamByName('AGENT').AsString := userAgent;
q.ParamByName('PHONE').AsString := normalizedPhone;
q.ExecSQL;
if q.RowsAffected = 0 then
begin
Logger.Log(2, 'CompleteRegistrationSimple - no pending row for "' + normalizedPhone + '"');
Result.AddPair('status', 'error');
Result.AddPair('message', 'Phone number is not pending registration. Contact your administrator.');
Exit;
end;
finally
q.Free;
var ctx := THttpServerContext.Current;
var userAgent: string := '';
if ctx <> nil then
userAgent := ctx.Request.Headers.Get('User-Agent');
affectedRows := FDeviceStore.ActivateSimpleDevice(Trim(DeviceKey), userAgent, normalizedPhone);
if affectedRows = 0 then
begin
Logger.Log(2, 'CompleteRegistrationSimple - no pending row for "' + normalizedPhone + '"');
Result.AddPair('status', 'error');
Result.AddPair('message', 'Phone number is not pending registration. Contact your administrator.');
Exit;
end;
Logger.Log(2, 'CompleteRegistrationSimple - activated simple key for "' + normalizedPhone + '"');
......@@ -1227,7 +1064,7 @@ function TAuthService.LoginDeviceKey(const CredentialId, ChallengeToken: string)
var
challengeB64: string;
storedUsername, storedAgency: string;
q: TUniQuery;
q: TDataSet;
JWT: TJWT;
begin
Logger.Log(2, 'AuthService.LoginDeviceKey - credId: ' + Copy(CredentialId, 1, 20));
......@@ -1237,24 +1074,14 @@ begin
storedUsername := '';
storedAgency := '';
q := TUniQuery.Create(nil);
q := FDeviceStore.ActiveSimpleDeviceUser(Trim(CredentialId));
try
q.Connection := authDB.ucLemsOCSO;
q.SQL.Text :=
'SELECT username, agency FROM lems.device_registrations ' +
'WHERE credential_id = :CID AND key_type = ''simple'' AND status = ''active''';
q.ParamByName('CID').AsString := Trim(CredentialId);
q.Open;
try
if q.IsEmpty then
raise EXDataHttpUnauthorized.Create('Device not registered, revoked, or not a simple-key device.');
storedUsername := q.FieldByName('username').AsString;
storedAgency := q.FieldByName('agency').AsString;
finally
q.Close;
end;
if q.IsEmpty then
raise EXDataHttpUnauthorized.Create('Device not registered, revoked, or not a simple-key device.');
storedUsername := q.FieldByName('username').AsString;
storedAgency := q.FieldByName('agency').AsString;
finally
q.Free;
q.Close;
end;
if (storedUsername = '') or (storedAgency = '') then
......@@ -1295,7 +1122,7 @@ function TAuthService.LoginPasswordAndSimpleKey(const User, Password, Agency,
var
challengeB64: string;
userState: Integer;
q: TUniQuery;
q: TDataSet;
JWT: TJWT;
begin
Logger.Log(1, Format('AuthService.LoginPasswordAndSimpleKey - User: "%s" Agency: "%s"', [User, Agency]));
......@@ -1317,23 +1144,12 @@ begin
if not VerifyChallengeToken(ChallengeToken, 'auth', challengeB64) then
raise EXDataHttpUnauthorized.Create('Invalid or expired authentication challenge.');
q := TUniQuery.Create(nil);
q := FDeviceStore.ActiveSimpleDevice(Trim(CredentialId));
try
q.Connection := authDB.ucLemsOCSO;
q.SQL.Text :=
'SELECT id FROM lems.device_registrations ' +
'WHERE credential_id = :CID AND key_type = ''simple'' AND status = ''active''';
q.ParamByName('CID').AsString := Trim(CredentialId);
q.Open;
try
if q.IsEmpty then
raise EXDataHttpUnauthorized.Create('Device not registered or not a simple-key device.');
finally
q.Close;
end;
if q.IsEmpty then
raise EXDataHttpUnauthorized.Create('Device not registered or not a simple-key device.');
finally
q.Free;
q.Close;
end;
Logger.Log(2, Format('AuthService.LoginPasswordAndSimpleKey - success for User: "%s"', [User]));
......@@ -1357,20 +1173,8 @@ begin
end;
// Persist username + agency so future auto-logins work
q := TUniQuery.Create(nil);
try
q.Connection := authDB.ucLemsOCSO;
q.SQL.Text :=
'UPDATE lems.device_registrations ' +
'SET username = :UNAME, agency = :AGCY ' +
'WHERE credential_id = :CID';
q.ParamByName('UNAME').AsString := userName;
q.ParamByName('AGCY').AsString := userAgency;
q.ParamByName('CID').AsString := Trim(CredentialId);
q.ExecSQL;
finally
q.Free;
end;
FDeviceStore.SaveDeviceUser(userName, userAgency, Trim(CredentialId));
end;
// ---------------------------------------------------------------------------
......@@ -1383,15 +1187,9 @@ var
begin
Logger.Log(2, 'TAuthService.GetAgenciesList - call');
if authDB.ucLemsOCSO.Connected then
if authDB.Connection.Connected then
begin
authDB.uqAuth.Close;
authDB.uqAuth.SQL.Text :=
'select agencyid as agency ' +
'from lems.agency ' +
'where login = ''T'' ' +
'order by agencyid';
authDB.uqAuth.Open;
authDB.OpenAgencies;
Result := TAgenciesList.Create;
TXDataOperationContext.Current.Handler.ManagedObjects.Add(Result);
......@@ -1400,15 +1198,15 @@ begin
TXDataOperationContext.Current.Handler.ManagedObjects.Add(Result.data);
try
while not authDB.uqAuth.Eof do
while not authDB.Agencies.Eof do
begin
agency := TAgencyItem.Create(authDB.uqAuth.FieldByName('agency').AsString);
agency := TAgencyItem.Create(authDB.Agencies.FieldByName('agency').AsString);
TXDataOperationContext.Current.Handler.ManagedObjects.Add(agency);
Result.Data.Add(agency);
authDB.uqAuth.Next;
authDB.Agencies.Next;
end;
finally
authDB.uqAuth.Close;
authDB.Agencies.Close;
end;
Result.count := Result.data.count;
......@@ -1425,19 +1223,10 @@ end;
function TAuthService.GetAgencyConfigList: TAgencyConfigList;
var
agencyConfig: TAgencyConfigItem;
sql: string;
begin
Logger.Log(2, 'AuthService.GetAgencyConfigList - call');
authDB.uqAuth.Close;
sql := 'select agencyid, agencyname ' +
'from lems.agency ' +
'where login = ''T'' ' +
'order by agencyname';
authDB.uqAuth.SQL.Text := sql;
authDB.uqAuth.Open;
authDB.OpenAgencyConfig;
Result := TAgencyConfigList.Create;
TXDataOperationContext.Current.Handler.ManagedObjects.Add(Result);
......@@ -1446,20 +1235,20 @@ begin
TXDataOperationContext.Current.Handler.ManagedObjects.Add(Result.data);
try
while not authDB.uqAuth.Eof do
while not authDB.AgencyConfig.Eof do
begin
agencyConfig := TAgencyConfigItem.Create;
TXDataOperationContext.Current.Handler.ManagedObjects.Add(agencyConfig);
Result.data.Add(agencyConfig);
agencyConfig.id := authDB.uqAuth.FieldByName('agencyid').AsString;
agencyConfig.agency := authDB.uqAuth.FieldByName('agencyid').AsString;
agencyConfig.name := authDB.uqAuth.FieldByName('agencyname').AsString;
agencyConfig.id := authDB.AgencyConfig.FieldByName('agencyid').AsString;
agencyConfig.agency := authDB.AgencyConfig.FieldByName('agencyid').AsString;
agencyConfig.name := authDB.AgencyConfig.FieldByName('agencyname').AsString;
authDB.uqAuth.Next;
authDB.AgencyConfig.Next;
end;
finally
authDB.uqAuth.Close;
authDB.AgencyConfig.Close;
end;
Result.count := Result.data.Count;
......@@ -1510,53 +1299,6 @@ begin
end;
end;
//
//function TAuthService.Login(const User, Password, Agency: string): string;
//var
// userState: Integer;
// JWT: TJWT;
//begin
// Logger.Log(1, Format('AuthService.Login - User: "%s" Agency: "%s"', [User, Agency]));
// userState := CheckUser(User, Password, Agency);
//
// try
// userState := CheckUser(User, Password, Agency);
// except
// on E: Exception do
// begin
// Logger.Log(2, 'AuthService.Login - CheckUser error: ' + E.ClassName + ': ' + E.Message);
// raise EXDataHttpException.Create(500, 'Login failed');
// end;
// end;
//
// if userState = 0 then
// begin
// Logger.Log(2, Format('AuthService.Login - invalid login for User: "%s" Agency: "%s"', [User, Agency]));
// raise EXDataHttpUnauthorized.Create('Invalid user or password');
// end;
//
// if userState = 1 then
// begin
// Logger.Log(2, Format('AuthService.Login - inactive user: "%s" Agency: "%s"', [User, Agency]));
// raise EXDataHttpUnauthorized.Create('User not active');
// end;
//
// JWT := TJWT.Create;
// try
// JWT.Claims.JWTId := LowerCase(Copy(TUtils.GuidToVariant(TUtils.NewGuid), 2, 36));
// JWT.Claims.IssuedAt := Now;
// JWT.Claims.Expiration := IncHour(Now, 24);
// JWT.Claims.SetClaimOfType<string>('user_name', userName);
// JWT.Claims.SetClaimOfType<string>('user_fullname', userFullName);
// JWT.Claims.SetClaimOfType<string>('user_agency', userAgency);
// JWT.Claims.SetClaimOfType<string>('user_badge', userBadge);
// JWT.Claims.SetClaimOfType<string>('user_id', userId);
// JWT.Claims.SetClaimOfType<string>('user_personnelid', userPersonnelId);
// Result := TJOSE.SHA256CompactToken(ServerConfig.jwtTokenSecret, JWT);
// finally
// JWT.Free;
// end;
//end;
function TAuthService.LoginDeviceManager(User, Password, Agency: string): string;
var
......@@ -1597,35 +1339,26 @@ begin
Logger.Log(3, Format('LoginService.CheckUser - User: "%s" Agency: "%s"', [User, Agency]));
passwordKey := 'wx3cFo$kIf2jrk(gOmvi7uvPfk*iorE8@kfm+nvR6jfh=swDqalpokSjf';
authDB.uqAuth.Close;
authDB.uqAuth.SQL.Text :=
'select u.* from lems.users u ' +
'where upper(user_name) = :USER_NAME ' +
'and u.dept = :AGENCY';
authDB.uqAuth.ParamByName('USER_NAME').AsString := UpperCase(Trim(User));
authDB.uqAuth.ParamByName('AGENCY').AsString := UpperCase(Trim(Agency));
Logger.Log(4, 'LoginService.CheckUser - opening user lookup query');
authDB.uqAuth.Open;
authDB.OpenUser(User, Agency);
try
if authDB.uqAuth.IsEmpty then
if authDB.UserData.IsEmpty then
Result := 0
else
begin
if authDB.uqAuth.FieldByName('active').AsString = 'F' then
if authDB.UserData.FieldByName('active').AsString = 'F' then
Result := 1
else
begin
decryptedPassword := Uppercase(Trim(Decrypt(authDB.uqAuth.FieldByName('password').AsString, passwordKey)));
decryptedPassword := Uppercase(Trim(Decrypt(authDB.UserData.FieldByName('password').AsString, passwordKey)));
if decryptedPassword = Uppercase(Trim(Password)) then
begin
userName := authDB.uqAuth.FieldByName('user_name').AsString;
userFullName := authDB.uqAuth.FieldByName('firstname').AsString + ' ' + authDB.uqAuth.FieldByName('lastname').AsString;
userAgency := authDB.uqAuth.FieldByName('dept').AsString;
userBadge := authDB.uqAuth.FieldByName('badgenum').AsString;
userId := authDB.uqAuth.FieldByName('userid').AsString;
userPersonnelId := authDB.uqAuth.FieldByName('personnelid').AsString;
userName := authDB.UserData.FieldByName('user_name').AsString;
userFullName := authDB.UserData.FieldByName('firstname').AsString + ' ' + authDB.UserData.FieldByName('lastname').AsString;
userAgency := authDB.UserData.FieldByName('dept').AsString;
userBadge := authDB.UserData.FieldByName('badgenum').AsString;
userId := authDB.UserData.FieldByName('userid').AsString;
userPersonnelId := authDB.UserData.FieldByName('personnelid').AsString;
userIsAdmin := SameText(Trim(User), 'admin');
......@@ -1643,7 +1376,7 @@ begin
end;
end;
finally
authDB.uqAuth.Close;
authDB.UserData.Close;
end;
end;
......
emiMobileServer/Source/Common.Config.pas → emiMobileServer/Shared/Server/Common.Config.pas
......@@ -66,6 +66,7 @@ var
begin
Logger.Log(1, '--LoadServerConfig - start');
ValidateClient;
IniEntries.ValidateDatabaseSettings;
serverConfig.FWebAppFolder := TPath.Combine(TPath.Combine(ExtractFilePath(ParamStr(0)), 'static'), IniEntries.Client);
Logger.Log(1, '-- Client: ' + IniEntries.Client + ' [from ini]');
......
emiMobileServer/Source/Common.Ini.pas → emiMobileServer/Shared/Server/Common.Ini.pas
......@@ -3,7 +3,7 @@ unit Common.Ini;
interface
uses
System.SysUtils, System.IniFiles, Vcl.Forms;
System.SysUtils, System.IniFiles, Vcl.Forms, Uni;
type
TIniEntries = class
......@@ -41,6 +41,8 @@ type
public
constructor Create;
procedure ValidateDatabaseSettings;
procedure ConfigureConnection(Connection: TUniConnection);
property Client: string read FClient;
// [Settings]
......@@ -139,9 +141,48 @@ begin
FDatabasePassword := iniFile.ReadString('Database', 'Password', '');
FDatabasePasswordFromIni := iniFile.ValueExists('Database', 'Password');
// Note: Oracle uses a TNS alias; PostgreSQL uses host, port, and database.
if FClient = 'BFD' then
begin
FDatabaseServer := Trim(iniFile.ReadString('Oracle', 'Server', ''));
FDatabaseUsername := Trim(iniFile.ReadString('Oracle', 'Username', ''));
FDatabasePassword := iniFile.ReadString('Oracle', 'Password', '');
FDatabaseServerFromIni := iniFile.ValueExists('Oracle', 'Server');
FDatabaseUsernameFromIni := iniFile.ValueExists('Oracle', 'Username');
FDatabasePasswordFromIni := iniFile.ValueExists('Oracle', 'Password');
FDatabasePort := 0;
FDatabaseName := '';
FDatabasePortFromIni := False;
FDatabaseNameFromIni := False;
end;
finally
iniFile.Free;
end;
end;
procedure TIniEntries.ValidateDatabaseSettings;
begin
if (FClient = 'BFD') and
((FDatabaseServer = '') or (FDatabaseUsername = '') or (FDatabasePassword = '')) then
raise Exception.Create('Set Server, Username, and Password in the server INI [Oracle] section.');
end;
procedure TIniEntries.ConfigureConnection(Connection: TUniConnection);
begin
if FClient = 'BFD' then
Connection.ProviderName := 'Oracle'
else
begin
Connection.ProviderName := 'PostgreSQL';
Connection.Port := FDatabasePort;
Connection.Database := FDatabaseName;
end;
Connection.Server := FDatabaseServer;
Connection.Username := FDatabaseUsername;
Connection.Password := FDatabasePassword;
Connection.LoginPrompt := False;
end;
end.
emiMobileServer/Source/Main.pas → emiMobileServer/Shared/Server/Main.pas
......@@ -60,7 +60,6 @@ uses
Common.Config,
Common.Ini,
Sparkle.Utils,
WC.Api.Database,
System.StrUtils;
{$R *.dfm}
......@@ -191,12 +190,17 @@ 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->Port', IniEntries.DatabasePort.ToString, IniEntries.DatabasePortFromIni));
Logger.Log(1, LogValue('--Database->Name', IniEntries.DatabaseName, IniEntries.DatabaseNameFromIni));
Logger.Log(1, LogValue('--Database->Username', IniEntries.DataBaseUsername, IniEntries.DatabaseUsernameFromIni));
Logger.Log(1, LogValue('--Database->Password', IniEntries.DatabasePassword, IniEntries.DatabasePasswordFromIni));
if IniEntries.Client = 'BFD' then
Logger.Log(1, '--- Oracle database: using [Oracle] INI settings ---')
else
begin
Logger.Log(1, '--- Database ---');
Logger.Log(1, LogValue('--Database->Server', IniEntries.DatabaseServer, IniEntries.DatabaseServerFromIni));
Logger.Log(1, LogValue('--Database->Port', IniEntries.DatabasePort.ToString, IniEntries.DatabasePortFromIni));
Logger.Log(1, LogValue('--Database->Name', IniEntries.DatabaseName, IniEntries.DatabaseNameFromIni));
Logger.Log(1, LogValue('--Database->Username', IniEntries.DataBaseUsername, IniEntries.DatabaseUsernameFromIni));
Logger.Log(1, LogValue('--Database->Password', '[configured]', IniEntries.DatabasePasswordFromIni));
end;
Logger.Log(1, '');
Logger.Log(1, '');
......
emiMobileServer/Source/WebSocket.Manager.pas → emiMobileServer/Shared/Server/WebSocket.Manager.pas
......@@ -92,11 +92,11 @@ type
implementation
uses
Device.Store, Client.Selection, Data.DB,
System.DateUtils,
System.NetEncoding,
IdStackConsts,
DBAccess,
Uni,
Bcl.JOSE.Core.JWT,
Bcl.JOSE.Core.Builder,
Common.Config,
......@@ -160,35 +160,13 @@ end;
function TWebSocketManager.IsDeviceActive(const ACredentialId: string): Boolean;
var
connection: TUniConnection;
query: TUniQuery;
store: TDeviceStore;
begin
Result := False;
connection := TUniConnection.Create(nil);
store := CreateDeviceStore;
try
connection.ProviderName := 'PostgreSQL';
connection.Server := IniEntries.DatabaseServer;
connection.Port := IniEntries.DatabasePort;
connection.Database := IniEntries.DatabaseName;
connection.Username := IniEntries.DatabaseUsername;
connection.Password := IniEntries.DatabasePassword;
connection.LoginPrompt := False;
connection.Connect;
query := TUniQuery.Create(nil);
try
query.Connection := connection;
query.SQL.Text :=
'SELECT id FROM lems.device_registrations ' +
'WHERE credential_id = :CID AND status = ''active''';
query.ParamByName('CID').AsString := ACredentialId;
query.Open;
Result := not query.IsEmpty;
finally
query.Free;
end;
Result := not store.ActiveDevice(ACredentialId).IsEmpty;
finally
connection.Free;
store.Free;
end;
end;
......
emiMobileServer/Source/Ws.DataModel.pas → emiMobileServer/Shared/Server/Ws.DataModel.pas
unit Ws.DataModel;
// Server-side WebSocket data model.
// Note: Owns a main-thread PostgreSQL notification listener and a worker thread that
// Note: Owns a main-thread client notification listener and a worker thread that
// queries the database for the five data sets used by the polling timers that
// existed in each connected browser client, then broadcasts the results to
// every handshaked WebSocket connection via the supplied broadcast callback.
......@@ -77,12 +77,16 @@ end;
destructor TWsDataModel.Destroy;
begin
FListenerTimer.Enabled := False;
if Assigned(FListenerTimer) then
FListenerTimer.Enabled := False;
FListenerTimer.Free;
FThread.Terminate;
FStopEvent.SetEvent;
FThread.WaitFor;
FThread.Free;
if Assigned(FThread) then
begin
FThread.Terminate;
FStopEvent.SetEvent;
FThread.WaitFor;
FThread.Free;
end;
FListenerData.Free;
FStopEvent.Free;
inherited;
......
emiMobileServer/Source/WebSocketServer.pas deleted 100644 → 0
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.Service.pas deleted 100644 → 0
unit Ws.Service;
interface
const
WS_MODEL = 'WsApi'; // retained for call-site compatibility in Main.pas
implementation
end.
emiMobileServer/Source/Ws.ServiceImpl.pas deleted 100644 → 0
unit Ws.ServiceImpl;
// Stub retained for project compatibility. Implementation moved to Ws.Server.Module.
interface
implementation
end.
emiMobileServer/Source/shared/LoginRequest.pas deleted 100644 → 0
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/bin/emiMobileServer.ini
[Application]
Client=WC
Client=BFD
[Settings]
LogFileNum=154
webClientVersion=0.9.4.9
LogFileNum=172
webClientVersion=9.4.0
MemoLogLevel=3
FileLogLevel=4
......@@ -23,3 +23,8 @@ Username=postgres
--Password=postgreSQL
Password=emsys01
--Postgre!SQL
[Oracle]
Server=BFD
Username=EMFIRECAD
Password=EMFIRECAD
emiMobileServer/emiMobileServer.dpr
......@@ -8,36 +8,37 @@ uses
Vcl.StdCtrls,
IniFiles,
Vcl.Forms,
Api.Server.Module in 'Source\Api.Server.Module.pas' {ApiServerModule: TDataModule},
Main in 'Source\Main.pas' {FMain},
Common.Logging in 'Source\Common.Logging.pas',
Client.Data in 'Core\Server\Client.Data.pas',
Client.Selection in 'Core\Server\Client.Selection.pas',
WC.Api.Data in 'Clients\WC\Server\WC.Api.Data.pas',
Api.Server.Module in 'Shared\Server\Api.Server.Module.pas' {ApiServerModule: TDataModule},
Main in 'Shared\Server\Main.pas' {FMain},
Common.Logging in 'Shared\Server\Common.Logging.pas',
BFD.Api.Database in 'Clients\BFD\Server\BFD.Api.Database.pas' {BFDAPIDataModule: TDataModule},
BFD.Auth.Database in 'Clients\BFD\Server\BFD.Auth.Database.pas' {BFDAuthDatabase: TDataModule},
Oracle.Device.Database in 'Shared\Database\Oracle\Oracle.Device.Database.pas' {OracleDeviceDatabase: TDataModule},
Device.Store in 'Shared\Clients\Device.Store.pas',
Client.Auth in 'Shared\Clients\Client.Auth.pas',
PostgreSQL.Device.Database in 'Shared\Database\PostgreSQL\PostgreSQL.Device.Database.pas' {PostgreSQLDeviceDatabase: TDataModule},
Client.Data in 'Shared\Clients\Client.Data.pas',
Client.Selection in 'Shared\Clients\Client.Selection.pas',
WC.Api.Database in 'Clients\WC\Server\WC.Api.Database.pas' {WCAPIDataModule: TDataModule},
Common.Middleware.Logging in 'Source\Common.Middleware.Logging.pas',
Common.Config in 'Source\Common.Config.pas',
Auth.Server.Module in 'Source\Auth.Server.Module.pas' {AuthServerModule: TDataModule},
Auth.Database in 'Source\Auth.Database.pas' {AuthDatabase: TDataModule},
uLibrary in 'Source\uLibrary.pas',
Auth.Service in 'Source\Auth.Service.pas',
Api.Service in 'Source\Api.Service.pas',
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',
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',
Webauthn.Cbor in 'Source\Webauthn.Cbor.pas',
Webauthn.Crypto in 'Source\Webauthn.Crypto.pas';
Common.Middleware.Logging in 'Shared\Server\Common.Middleware.Logging.pas',
Common.Config in 'Shared\Server\Common.Config.pas',
Auth.Server.Module in 'Shared\Server\Auth.Server.Module.pas' {AuthServerModule: TDataModule},
WC.Auth.Database in 'Clients\WC\Server\WC.Auth.Database.pas' {WCAuthDatabase: TDataModule},
uLibrary in 'Shared\Server\uLibrary.pas',
Auth.Service in 'Shared\Server\Auth.Service.pas',
Api.Service in 'Shared\Server\Api.Service.pas',
Auth.ServiceImpl in 'Shared\Server\Auth.ServiceImpl.pas',
Api.ServiceImpl in 'Shared\Server\Api.ServiceImpl.pas',
App.Server.Module in 'Shared\Server\App.Server.Module.pas' {AppServerModule: TDataModule},
Common.Ini in 'Shared\Server\Common.Ini.pas',
BaseRequest in 'Shared\Models\BaseRequest.pas',
Pkg.Json.DTO in 'Shared\Models\Pkg.Json.DTO.pas',
Ws.Server.Module in 'Shared\Server\Ws.Server.Module.pas' {WsServerModule: TDataModule},
Ws.DataModel in 'Shared\Server\Ws.DataModel.pas',
WsMessages in 'Shared\Models\WsMessages.pas',
WebSocket.Manager in 'Shared\Server\WebSocket.Manager.pas',
Webauthn.Cbor in 'Shared\Server\Webauthn.Cbor.pas',
Webauthn.Crypto in 'Shared\Server\Webauthn.Crypto.pas';
type
TMemoLogAppender = class( TInterfacedObject, ILogAppender )
......
emiMobileServer/emiMobileServer.dproj
......@@ -134,57 +134,73 @@
<DelphiCompile Include="$(MainSource)">
<MainSource>MainSource</MainSource>
</DelphiCompile>
<DCCReference Include="Source\Api.Server.Module.pas">
<DCCReference Include="Shared\Server\Api.Server.Module.pas">
<Form>ApiServerModule</Form>
<DesignClass>TDataModule</DesignClass>
</DCCReference>
<DCCReference Include="Source\Main.pas">
<DCCReference Include="Shared\Server\Main.pas">
<Form>FMain</Form>
</DCCReference>
<DCCReference Include="Source\Common.Logging.pas"/>
<DCCReference Include="Core\Server\Client.Data.pas"/>
<DCCReference Include="Core\Server\Client.Selection.pas"/>
<DCCReference Include="Clients\WC\Server\WC.Api.Data.pas"/>
<DCCReference Include="Shared\Server\Common.Logging.pas"/>
<DCCReference Include="Clients\BFD\Server\BFD.Api.Database.pas">
<Form>BFDAPIDataModule</Form>
<FormType>dfm</FormType>
<DesignClass>TDataModule</DesignClass>
</DCCReference>
<DCCReference Include="Clients\BFD\Server\BFD.Auth.Database.pas">
<Form>BFDAuthDatabase</Form>
<FormType>dfm</FormType>
<DesignClass>TDataModule</DesignClass>
</DCCReference>
<DCCReference Include="Shared\Database\Oracle\Oracle.Device.Database.pas">
<Form>OracleDeviceDatabase</Form>
<FormType>dfm</FormType>
<DesignClass>TDataModule</DesignClass>
</DCCReference>
<DCCReference Include="Shared\Clients\Device.Store.pas"/>
<DCCReference Include="Shared\Clients\Client.Auth.pas"/>
<DCCReference Include="Shared\Database\PostgreSQL\PostgreSQL.Device.Database.pas">
<Form>PostgreSQLDeviceDatabase</Form>
<DesignClass>TDataModule</DesignClass>
</DCCReference>
<DCCReference Include="Shared\Clients\Client.Data.pas"/>
<DCCReference Include="Shared\Clients\Client.Selection.pas"/>
<DCCReference Include="Clients\WC\Server\WC.Api.Database.pas">
<Form>WCAPIDataModule</Form>
<DesignClass>TDataModule</DesignClass>
</DCCReference>
<DCCReference Include="Source\Common.Middleware.Logging.pas"/>
<DCCReference Include="Source\Common.Config.pas"/>
<DCCReference Include="Source\Auth.Server.Module.pas">
<DCCReference Include="Shared\Server\Common.Middleware.Logging.pas"/>
<DCCReference Include="Shared\Server\Common.Config.pas"/>
<DCCReference Include="Shared\Server\Auth.Server.Module.pas">
<Form>AuthServerModule</Form>
<DesignClass>TDataModule</DesignClass>
</DCCReference>
<DCCReference Include="Source\Auth.Database.pas">
<Form>AuthDatabase</Form>
<DCCReference Include="Clients\WC\Server\WC.Auth.Database.pas">
<Form>WCAuthDatabase</Form>
<DesignClass>TDataModule</DesignClass>
</DCCReference>
<DCCReference Include="Source\uLibrary.pas"/>
<DCCReference Include="Source\Auth.Service.pas"/>
<DCCReference Include="Source\Api.Service.pas"/>
<DCCReference Include="Source\Auth.ServiceImpl.pas"/>
<DCCReference Include="Source\Api.ServiceImpl.pas"/>
<DCCReference Include="Source\App.Server.Module.pas">
<DCCReference Include="Shared\Server\uLibrary.pas"/>
<DCCReference Include="Shared\Server\Auth.Service.pas"/>
<DCCReference Include="Shared\Server\Api.Service.pas"/>
<DCCReference Include="Shared\Server\Auth.ServiceImpl.pas"/>
<DCCReference Include="Shared\Server\Api.ServiceImpl.pas"/>
<DCCReference Include="Shared\Server\App.Server.Module.pas">
<Form>AppServerModule</Form>
<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">
<DCCReference Include="Shared\Server\Common.Ini.pas"/>
<DCCReference Include="Shared\Models\BaseRequest.pas"/>
<DCCReference Include="Shared\Models\Pkg.Json.DTO.pas"/>
<DCCReference Include="Shared\Server\Ws.Server.Module.pas">
<Form>WsServerModule</Form>
<FormType>dfm</FormType>
<DesignClass>TDataModule</DesignClass>
</DCCReference>
<DCCReference Include="Source\Ws.DataModel.pas"/>
<DCCReference Include="Source\shared\WsMessages.pas"/>
<DCCReference Include="Source\WebSocket.Manager.pas"/>
<DCCReference Include="Source\Webauthn.Cbor.pas"/>
<DCCReference Include="Source\Webauthn.Crypto.pas"/>
<DCCReference Include="Shared\Server\Ws.DataModel.pas"/>
<DCCReference Include="Shared\Models\WsMessages.pas"/>
<DCCReference Include="Shared\Server\WebSocket.Manager.pas"/>
<DCCReference Include="Shared\Server\Webauthn.Cbor.pas"/>
<DCCReference Include="Shared\Server\Webauthn.Crypto.pas"/>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>
......
emiMobile_BFD @ 13d204d6
Subproject commit 13d204d656b7ccc69148d12d46d95e642e8b0a44
folder-layout.md
# Proposed emiMobile folder and unit layout
Planning specification, October 16, 2026. The client web projects have been moved to Clients/WC/Web and Clients/BFD/Web, and BFD's project has been renamed bfdEmiMobile. Both relocated projects built successfully per the user. Output settings now target bin/static/WC and bin/static/BFD, and the existing separate servers' JSON web roots point to those locations. These output changes still require rebuild/runtime verification. All other separation below remains the proposed target.
## Repository structure
# emiMobile folder layout
```text
emiMobile/
README.md
CORE-PLAN.md
FOLDER-LAYOUT.md
emiMobileServer/
emiMobileServer.dpr
emiMobileServer.dproj
Core/
Server/
Main.pas / .dfm
Common.Ini.pas
Common.Config.pas
Common.Logging.pas
Common.Middleware.Logging.pas
Api.Service.pas
Api.ServiceImpl.pas
Api.Server.Module.pas / .dfm
Auth.Service.pas
Auth.ServiceImpl.pas
Auth.Server.Module.pas / .dfm
App.Server.Module.pas / .dfm
WebSocket.Manager.pas
Ws.DataModel.pas
Ws.Server.Module.pas / .dfm
Webauthn.Cbor.pas
Webauthn.Crypto.pas
Client.Data.pas [new]
Client.Selection.pas [new]
Device.Store.pas [new]
shared/
BaseRequest.pas
LoginRequest.pas
Pkg.Json.DTO.pas
WsMessages.pas
utils/
DTOGeneratorUtils.pas
Web/
App.Config.pas
App.Types.pas
Auth.Service.pas
ConnectionModule.pas / .dfm
Module.Websocket.pas / .dfm
Utils.pas
Paginator.Plugins.pas
View.Main.pas / .dfm / .html
View.Login.pas / .dfm / .html
View.DeviceRegistration.pas / .dfm / .html
View.DeviceManager.pas / .dfm / .html
View.ErrorPage.pas / .dfm / .html
css/
app.css
spinner.css
emiMobileServer/
emiMobileServer.dproj
Shared/
Server/ Common services and application startup
Clients/ Client selection and common data/auth interfaces
Database/
PostgreSQL/
PostgreSQL.Device.Database.pas / .dfm [new]
Migrations/
[reviewed application-schema SQL]
Oracle/
Oracle.Device.Database.pas / .dfm [new]
Migrations/
[equivalent Oracle application-schema SQL]
Clients/
Oracle/ Oracle device storage and connection settings
PostgreSQL/ PostgreSQL device storage
Models/ Request, response, and WebSocket message types
Clients/
WC/
Server/ Wyoming CAD and authentication modules
Web/ wcEmiMobile.dproj and Wyoming web sources
BFD/
Server/ Buffalo CAD and authentication modules
Web/ bfdEmiMobile.dproj and Buffalo web sources
bin/
emiMobileServer.ini
emiMobileServer.json
static/
WC/
Server/
WC.Api.Database.pas / .dfm
WC.Auth.Database.pas / .dfm
WC.Api.Data.pas [new]
WC.Library.pas
Web/
wcEmiMobile.dpr
wcEmiMobile.dproj
Client.Settings.pas [new]
index.html
View.Map.pas / .dfm / .html
View.Units.pas / .dfm / .html
View.UnitDetails.pas / .dfm / .html
View.Complaints.pas / .dfm / .html
View.ComplaintDetails.pas / .dfm / .html
View.ComplaintArchive.pas / .dfm / .html
uMapFilters.pas
uMapMarkerJs.pas
config/
config.json
assets/
markers/
[WC boundary files and used assets]
Config/
emiMobileServer.ini.example
emiMobileServer.json.example
BFD/
Server/
BFD.Api.Database.pas / .dfm
BFD.Auth.Database.pas / .dfm
BFD.Api.Data.pas [new]
BFD.Library.pas
Web/
bfdEmiMobile.dpr
bfdEmiMobile.dproj
Client.Settings.pas [new]
index.html
View.Map.pas / .dfm / .html
View.Units.pas / .dfm / .html
View.UnitDetails.pas / .dfm / .html
View.Complaints.pas / .dfm / .html
View.ComplaintDetails.pas / .dfm / .html
View.ComplaintArchive.pas / .dfm / .html
uMapFilters.pas
uMapMarkerJs.pas
config/
config.json
assets/
markers/
[BFD boundary files and used assets]
Config/
emiMobileServer.ini.example
emiMobileServer.json.example
bin/ [generated/local runtime files]
emiMobileServer.exe
emiMobileServer.ini
emiMobileServer.json
logs/
static/
WC/
BFD/
Legacy/
[retained inactive source, described below]
```
## Naming and responsibilities
Shared contains code used by both clients. Clients contains each client's own code. bin contains runtime configuration and build output.
- Keep current names for shared units. Server and web Auth.Service remain separate, as today; server and web projects must have separate search paths.
- Both client server implementations compile into one executable. Prefix their unit and class names with WC/BFD to avoid collisions. For example, WC.Api.Database contains TWCAPIDataModule and BFD.Api.Database contains TBFDAPIDataModule. Rename DFM class declarations and references consistently during implementation. Keep query names such as uqMapUnits within each module.
- Client.Data defines the narrow CAD/user-access operations required by shared services. It does not expose concrete persistent query fields. Exact Delphi signatures and ownership are to be designed from existing call sites before implementation.
- Client.Selection is the central selection point for creating WC/BFD data implementations and PostgreSQL/Oracle device stores. It creates instances for the relevant request or worker; it does not provide one global shared query connection. Invalid Client fails before service startup. The earlier name Client.Factory meant object creation only; no factory framework is intended.
- WC.Api.Data and BFD.Api.Data implement client CAD response building, using their client database modules. Shared API services and Ws.DataModel call the same builders for corresponding list/map data. Keep XData response ownership and WebSocket serialization ownership explicit.
- Device.Store defines application persistence operations required by shared authentication/device workflows. PostgreSQL.Device.Database and Oracle.Device.Database implement those operations, including verification and redemption storage where required. No duplicate registration workflow belongs in these modules.
- WC.Auth.Database and BFD.Auth.Database retain CAD agency/user lookup and audit differences. Move current raw CAD lookup SQL out of shared Auth.ServiceImpl as needed; route through the selected client implementation. Authentication/token rules remain in core.
- WC.Library and BFD.Library initially preserve each existing uLibrary implementation, including database-specific sequence/audit behavior. Share verified common parts later only when worthwhile.
- Client.Settings is a small web unit for existing presentation differences such as Complaint/Incident labels. Each separately compiled web project explicitly includes its own copy. It does not select server databases or override server access rules.
- Keep client web form unit names unchanged initially: each web project includes only its own forms plus shared forms. Use explicit references, never a search path containing both client Web folders.
- Core/Web/View.Main, login, device forms, styles, and utilities represent reconciled target behavior, not simple file moves. WC is the starting point for new device/live-update behavior; preserve BFD terminology through settings.
- Map, list, detail, archive forms and marker/filter units remain client-local in the initial layout. Preserve each .pas/.dfm/.html set together. Later sharing of map mechanics is separate work.
The shared server project stays at emiMobileServer/emiMobileServer.dproj. Select WC or BFD through the INI. Each client still deploys to a separate machine.
## Build and runtime rules
The standalone BFD server is retired. Its files remain under emiMobile_BFD as historical reference, not a supported project. Use the common server for both clients.
- No project group is required or proposed. Open emiMobileServer.dproj, wcEmiMobile.dproj, and bfdEmiMobile.dproj individually. Match client .dpr names to their .dproj names. No second server project remains in the target layout.
- Preserve the existing bin output convention. Web outputs become emiMobileServer/bin/static/WC and emiMobileServer/bin/static/BFD. These are runtime outputs, not source folders.
- Resolve the static root relative to the executable directory, not the process working directory. Client=WC selects static/WC; Client=BFD selects static/BFD. Remove the independent webAppFolder override from the effective runtime configuration when implementing this rule.
- Generated web output contains its HTML templates, JS, shared CSS, client configuration, and required assets. Explicitly configure shared resource deployment and verify it with a pilot shared form; cross-directory TMS packaging is not yet build-tested.
- Keep compiler intermediate output separate per project/configuration; never mix server and web DCUs or WC/BFD web intermediates.
- Deploy the common executable, deployment-specific INI/JSON, and only static/<selected client>. WC and BFD run on different machines.
- Track sanitized configuration examples. Do not copy live connection secrets into tracked examples.
- One local server process selects one client. When testing the other client locally, change its local configuration and restart; simultaneous local instances are outside the initial scope.
The main project's former Source, Core, and Database directories have been consolidated into Shared. Unit names, designer resources, and application behavior were preserved. Both server projects compile with the new paths.
## Inactive files and migration
Each client Server folder now contains Api.Database (designer queries plus response-building methods) and Auth.Database (login/user/agency queries). The separate Api.Data wrapper units have been removed. Shared/Clients/Client.Data remains the common data-module contract used by client selection, API services, and WebSockets.
- Preserve unused Users, EditUser, EditUser2, UserProfile, Admin forms and View.Home.html outside active projects in Legacy/Web if/when the move is approved. Do not delete them as incidental cleanup.
- Review Markers.pas, WebSocketServer.pas, Ws.Service.pas, and Ws.ServiceImpl.pas references before assigning them to active Core or Legacy; apparent duplication or empty implementations alone is not permission to delete them. Retain original files until that check is complete.
- Keep old standalone BFD checkout/history intact until Git consolidation is agreed. Do not move its .git directory into the new client source folder.
- Existing SQL files are migration inputs, not an approved automatic migration sequence. Review destructive statements and seed data before creating deployment-ready migrations.
- Implement in small stages. This target structure does not authorize a wholesale move/refactor or imply all units are currently compatible.
Connection settings for both clients are loaded and applied by Shared/Server/Common.Ini.pas. The unused DTO generator is retained in tools/ outside the application project.
tools/README.md 0 → 100644
# Development tools
DTOGeneratorUtils.pas is a retained Delphi source-generation utility. It is not part of the emiMobile server build. It uses UniDAC and Pkg.Json.DTO; this is reference tooling, not a standalone executable project.
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