feat: Delphi backend + JS↔Delphi bridge (clipboard, tray, auto-lock)
Introduces the Delphi 12 FMX backend (PMServer) that hosts the embedded
WebView2 vault on 127.0.0.1, and a native bridge between JS and Delphi
that wires three privacy-focused features:
1. Secure clipboard
Copying a password registers the Win32 "ExcludeClipboardContentFromMonitorProcessing"
format alongside CF_UNICODETEXT, so Win+V clipboard history never sees
the value. Auto-clears after 30s via TTimer. Bridge.copySecure() in
app.js routes all password/username/secret copy paths through the
native layer when running inside the Delphi WebView2 (falls back to
navigator.clipboard for the PHP standalone).
2. Tray icon (X-to-tray when server running)
Closing the dev panel hides both the form HWND and the TFMAppClass
per-process proxy window that owns the FMX taskbar entry — the form's
HWND alone is not the taskbar-visible one in FMX (took some iteration
to discover). Tray menu: Open, Lock vault, Quit. Clipboard is force-
cleared on minimize as extra safety. First-time minimize fires a
balloon notification so the user knows the app is still running.
3. Auto-lock on Windows session lock (Win+L)
wtsapi32.dll!WTSRegisterSessionNotification on a dedicated message-only
window. On WM_WTSSESSION_CHANGE / WTS_SESSION_LOCK, the bridge calls
ExecuteJavaScript('lockVault()'). Same path used by the tray "Lock vault"
menu item.
Bridge architecture:
- JS → Delphi via cmd:// URLs intercepted in OnBeforeNavigate
(pattern lifted from DeskInsight Monaco). Currently exposes
cmd://clipboard/copy?text=...&clear=... and cmd://clipboard/clear.
- Delphi → JS via TTMSFNCWebBrowser.ExecuteJavaScript with guarded
calls (typeof check) so the bridge degrades cleanly if app.js isn't
loaded yet.
Files:
- Source/PM.Bridge.pas (new) — TSecureClipboard + TPMBridge
- UMainForm.pas/.fmx — bridge wiring, FormCloseQuery intercept, tray
callbacks (BridgeTrayRestore / BridgeLockRequest / BridgeQuit)
- js/app.js — Bridge object, 5 navigator.clipboard sites migrated to
Bridge.copySecure with PHP-compatible fallback, Bridge.onTrayRestore
handler that resets the auto-lock timer
.gitignore extended with Delphi build artifacts (*.dcu, Win32/, Win64/,
__history/, __recovery/, *.identcache, *.dsk, *.local, etc.) so source
checkouts stay clean.
This commit is contained in:
@@ -0,0 +1,325 @@
|
||||
unit UMainForm;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
System.SysUtils, System.Classes, System.UITypes, System.NetEncoding,
|
||||
FMX.Forms, FMX.Controls, FMX.Controls.Presentation, FMX.StdCtrls,
|
||||
FMX.Memo, FMX.Memo.Types, FMX.ScrollBox, FMX.Edit, FMX.Layouts, FMX.Types,
|
||||
FMX.Dialogs,
|
||||
FMX.TMSFNCTypes, FMX.TMSFNCUtils, FMX.TMSFNCGraphics, FMX.TMSFNCGraphicsTypes,
|
||||
FMX.TMSFNCCustomControl, FMX.TMSFNCWebBrowser,
|
||||
PM.HTTPServer, PM.Bridge;
|
||||
|
||||
type
|
||||
TMainForm = class(TForm)
|
||||
PanelTop: TPanel;
|
||||
btnStart: TButton;
|
||||
btnStop: TButton;
|
||||
lblStatus: TLabel;
|
||||
edtPort: TEdit;
|
||||
lblPort: TLabel;
|
||||
btnToggleLog: TButton;
|
||||
btnReload: TButton;
|
||||
PanelLog: TPanel;
|
||||
Memo: TMemo;
|
||||
Splitter: TSplitter;
|
||||
WebBrowser: TTMSFNCWebBrowser;
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure FormDestroy(Sender: TObject);
|
||||
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
|
||||
procedure btnStartClick(Sender: TObject);
|
||||
procedure btnStopClick(Sender: TObject);
|
||||
procedure btnToggleLogClick(Sender: TObject);
|
||||
procedure btnReloadClick(Sender: TObject);
|
||||
private
|
||||
FServer: TPMHTTPServer;
|
||||
FBridge: TPMBridge;
|
||||
FPendingURL: string;
|
||||
FNavTimer: TTimer;
|
||||
FNavAttempts: Integer;
|
||||
FQuitting: Boolean; // set when user picks "Quit" in tray menu — bypasses
|
||||
// FormCloseQuery's minimize-to-tray intercept.
|
||||
procedure LogLine(const AMsg: string);
|
||||
procedure UpdateButtons;
|
||||
procedure NavigateToVault;
|
||||
procedure NavTimerTick(Sender: TObject);
|
||||
// JS↔Delphi bridge
|
||||
procedure WebBrowserBeforeNavigate(Sender: TObject;
|
||||
var Params: TTMSFNCCustomWebBrowserBeforeNavigateParams);
|
||||
procedure HandleBridgeCommand(const ACmd, AParams: string);
|
||||
procedure BridgeSystemLock;
|
||||
procedure BridgeTrayRestore;
|
||||
procedure BridgeLockRequest;
|
||||
procedure BridgeQuit;
|
||||
end;
|
||||
|
||||
var
|
||||
MainForm: TMainForm;
|
||||
|
||||
implementation
|
||||
|
||||
{$R *.fmx}
|
||||
|
||||
procedure TMainForm.FormCreate(Sender: TObject);
|
||||
begin
|
||||
FServer := TPMHTTPServer.Create;
|
||||
FServer.OnLog := LogLine;
|
||||
|
||||
FBridge := TPMBridge.Create(Self);
|
||||
FBridge.OnSystemLock := BridgeSystemLock;
|
||||
FBridge.OnTrayRestore := BridgeTrayRestore;
|
||||
FBridge.OnLockRequest := BridgeLockRequest;
|
||||
FBridge.OnQuit := BridgeQuit;
|
||||
|
||||
// Wire the cmd:// bridge before any navigation happens.
|
||||
WebBrowser.OnBeforeNavigate := WebBrowserBeforeNavigate;
|
||||
|
||||
// Delayed-Navigate timer: TTMSFNCWebBrowser (WebView2 backend) ignores
|
||||
// Navigate() calls until Edge Chromium finishes its async init (~1-2s).
|
||||
// We wait 1.5 s after Start, then issue a SINGLE Navigate — no retry loop
|
||||
// (retrying caused the loaded page to reload every interval, making icons
|
||||
// flash). If Edge needed longer than 1.5 s, user clicks Reload.
|
||||
FNavTimer := TTimer.Create(Self);
|
||||
FNavTimer.Interval := 1500;
|
||||
FNavTimer.Enabled := False;
|
||||
FNavTimer.OnTimer := NavTimerTick;
|
||||
|
||||
UpdateButtons;
|
||||
LogLine('Password Manager - Delphi backend ready.');
|
||||
LogLine('Click Start to launch server + embedded web vault.');
|
||||
end;
|
||||
|
||||
procedure TMainForm.FormDestroy(Sender: TObject);
|
||||
begin
|
||||
FBridge.Free;
|
||||
FServer.Free;
|
||||
end;
|
||||
|
||||
procedure TMainForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
|
||||
begin
|
||||
// The tray-menu "Quit" handler sets FQuitting before triggering close,
|
||||
// so we bypass the minimize-to-tray intercept in that case.
|
||||
if FQuitting then Exit;
|
||||
|
||||
// Otherwise: minimize to tray on close instead of quitting, so the vault
|
||||
// stays available without the dev-panel being visible.
|
||||
// When the server is stopped, allow normal close — there's no vault to
|
||||
// keep alive in the background.
|
||||
if FServer.Active then
|
||||
begin
|
||||
CanClose := False;
|
||||
FBridge.MinimizeToTray;
|
||||
LogLine('Minimized to tray. Click the tray icon to restore.');
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TMainForm.LogLine(const AMsg: string);
|
||||
begin
|
||||
// Synchronize handles both cases: if already on main thread, runs inline;
|
||||
// otherwise marshals. Avoids overload resolution issues with TThread.Queue.
|
||||
TThread.Synchronize(nil,
|
||||
procedure
|
||||
begin
|
||||
Memo.Lines.Add(FormatDateTime('hh:nn:ss', Now) + ' ' + AMsg);
|
||||
Memo.GoToTextEnd;
|
||||
end);
|
||||
end;
|
||||
|
||||
procedure TMainForm.UpdateButtons;
|
||||
begin
|
||||
btnStart.Enabled := not FServer.Active;
|
||||
btnStop.Enabled := FServer.Active;
|
||||
btnReload.Enabled := FServer.Active;
|
||||
edtPort.Enabled := not FServer.Active;
|
||||
if FServer.Active then
|
||||
lblStatus.Text := 'Running on http://127.0.0.1:' + edtPort.Text
|
||||
else
|
||||
lblStatus.Text := 'Stopped';
|
||||
end;
|
||||
|
||||
procedure TMainForm.NavigateToVault;
|
||||
begin
|
||||
FPendingURL := 'http://127.0.0.1:' + edtPort.Text + '/index.html';
|
||||
LogLine('Will navigate embedded browser in ~1.5s to: ' + FPendingURL);
|
||||
// Schedule a single Navigate after Edge has had time to initialize.
|
||||
FNavTimer.Enabled := False; // restart timer if already running
|
||||
FNavTimer.Enabled := True;
|
||||
end;
|
||||
|
||||
procedure TMainForm.NavTimerTick(Sender: TObject);
|
||||
begin
|
||||
FNavTimer.Enabled := False; // one-shot
|
||||
if FPendingURL = '' then Exit;
|
||||
LogLine('Navigating to: ' + FPendingURL);
|
||||
WebBrowser.Navigate(FPendingURL);
|
||||
FPendingURL := '';
|
||||
end;
|
||||
|
||||
procedure TMainForm.btnStartClick(Sender: TObject);
|
||||
var
|
||||
LPort: Integer;
|
||||
begin
|
||||
LPort := StrToIntDef(edtPort.Text, 8765);
|
||||
try
|
||||
FServer.Start(LPort);
|
||||
UpdateButtons;
|
||||
NavigateToVault;
|
||||
except
|
||||
on E: Exception do
|
||||
begin
|
||||
LogLine('ERROR starting server: ' + E.Message);
|
||||
MessageDlg('Failed to start: ' + E.Message,
|
||||
TMsgDlgType.mtError, [TMsgDlgBtn.mbOK], 0);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TMainForm.btnStopClick(Sender: TObject);
|
||||
begin
|
||||
FServer.Stop;
|
||||
UpdateButtons;
|
||||
FPendingURL := '';
|
||||
FNavTimer.Enabled := False;
|
||||
WebBrowser.Navigate('about:blank');
|
||||
end;
|
||||
|
||||
procedure TMainForm.btnReloadClick(Sender: TObject);
|
||||
begin
|
||||
if FServer.Active then NavigateToVault;
|
||||
end;
|
||||
|
||||
procedure TMainForm.btnToggleLogClick(Sender: TObject);
|
||||
begin
|
||||
PanelLog.Visible := not PanelLog.Visible;
|
||||
Splitter.Visible := PanelLog.Visible;
|
||||
if PanelLog.Visible then
|
||||
btnToggleLog.Text := 'Hide log'
|
||||
else
|
||||
btnToggleLog.Text := 'Show log';
|
||||
end;
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// JS↔Delphi bridge
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
procedure TMainForm.WebBrowserBeforeNavigate(Sender: TObject;
|
||||
var Params: TTMSFNCCustomWebBrowserBeforeNavigateParams);
|
||||
var
|
||||
URL, Cmd, ParamStr: string;
|
||||
P: Integer;
|
||||
begin
|
||||
URL := Params.URL;
|
||||
if not URL.StartsWith('cmd://') then Exit;
|
||||
|
||||
Params.Cancel := True;
|
||||
URL := URL.Substring(6); // strip 'cmd://'
|
||||
|
||||
P := Pos('?', URL);
|
||||
if P > 0 then
|
||||
begin
|
||||
Cmd := Copy(URL, 1, P - 1);
|
||||
ParamStr := Copy(URL, P + 1, MaxInt);
|
||||
end
|
||||
else
|
||||
begin
|
||||
Cmd := URL;
|
||||
ParamStr := '';
|
||||
end;
|
||||
|
||||
// Defer to avoid WebView2 re-entrance issues.
|
||||
TThread.ForceQueue(nil,
|
||||
procedure
|
||||
begin
|
||||
HandleBridgeCommand(Cmd, ParamStr);
|
||||
end);
|
||||
end;
|
||||
|
||||
procedure TMainForm.HandleBridgeCommand(const ACmd, AParams: string);
|
||||
|
||||
function GetParam(const AKey: string): string;
|
||||
var
|
||||
Parts: TArray<string>;
|
||||
Part, K, V: string;
|
||||
EqPos: Integer;
|
||||
begin
|
||||
Result := '';
|
||||
Parts := AParams.Split(['&']);
|
||||
for Part in Parts do
|
||||
begin
|
||||
EqPos := Pos('=', Part);
|
||||
if EqPos > 0 then
|
||||
begin
|
||||
K := Copy(Part, 1, EqPos - 1);
|
||||
V := Copy(Part, EqPos + 1, MaxInt);
|
||||
if SameText(K, AKey) then
|
||||
begin
|
||||
Result := TNetEncoding.URL.Decode(V);
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
LText: string;
|
||||
LClearMs: Integer;
|
||||
begin
|
||||
if ACmd = 'clipboard/copy' then
|
||||
begin
|
||||
LText := GetParam('text');
|
||||
LClearMs := StrToIntDef(GetParam('clear'), 30000);
|
||||
FBridge.SecureClipboard.SetText(LText, LClearMs);
|
||||
LogLine(Format('Secure clipboard set (auto-clear in %ds)', [LClearMs div 1000]));
|
||||
end
|
||||
|
||||
else if ACmd = 'clipboard/clear' then
|
||||
begin
|
||||
FBridge.SecureClipboard.Clear;
|
||||
LogLine('Clipboard cleared by JS request');
|
||||
end
|
||||
|
||||
else
|
||||
LogLine('Bridge: unknown command "' + ACmd + '"');
|
||||
end;
|
||||
|
||||
procedure TMainForm.BridgeSystemLock;
|
||||
begin
|
||||
// Windows session locked — lock the vault in the JS layer immediately.
|
||||
LogLine('Windows session locked — locking vault');
|
||||
WebBrowser.ExecuteJavaScript('if(typeof lockVault==="function")lockVault()');
|
||||
end;
|
||||
|
||||
procedure TMainForm.BridgeTrayRestore;
|
||||
begin
|
||||
FBridge.RestoreFromTray;
|
||||
// Notify the JS layer: the UI may want to reset the auto-lock timer,
|
||||
// refresh state, or show a "welcome back" toast.
|
||||
WebBrowser.ExecuteJavaScript(
|
||||
'if(window.Bridge&&typeof Bridge.onTrayRestore==="function")Bridge.onTrayRestore()');
|
||||
LogLine('Restored from tray');
|
||||
end;
|
||||
|
||||
procedure TMainForm.BridgeLockRequest;
|
||||
begin
|
||||
// User picked "Lock vault" from the tray menu. Trigger lockVault() in
|
||||
// JS — same path as the WTS_SESSION_LOCK auto-lock.
|
||||
LogLine('Lock requested from tray menu');
|
||||
WebBrowser.ExecuteJavaScript('if(typeof lockVault==="function")lockVault()');
|
||||
end;
|
||||
|
||||
procedure TMainForm.BridgeQuit;
|
||||
begin
|
||||
// Re-entry guard: if Quit was already requested, ignore further calls.
|
||||
if FQuitting then Exit;
|
||||
|
||||
LogLine('>>> BridgeQuit invoked (Quit from tray menu)');
|
||||
FQuitting := True;
|
||||
// Restore the form first so the tray icon goes away and FormDestroy
|
||||
// executes from a normal (non-hidden) state. RestoreFromTray also
|
||||
// deletes the tray icon.
|
||||
FBridge.RestoreFromTray;
|
||||
Application.Terminate;
|
||||
end;
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user