r-zakarya
7440d07793
Profile picture / avatar - users.avatar_b64 column (nullable, cosmetic, not encrypted) + GET/POST /avatar endpoints mirroring the settings handler pattern. - Top-right chip + Settings→Account show a round avatar: custom picture if set, otherwise the username's initial on a deterministic hash-picked colour (stable across renders). - Upload downscales + center-crops to a 128px JPEG via FileReader → data: URI (NOT blob:, which the CSP's `img-src 'self' data:` blocks) before POSTing. Remove button clears it. - Carried in the encrypted JSON export; restored on import only when the current account has no picture (never clobbers a local one). Tombstone restore-then-sync fix - POST /entries and POST /entries/bulk-import now DELETE any tombstone matching an inserted uuid (same transaction) so a restored backup isn't re-killed on the next sync by its own stale tombstone. - applyRemoteSnapshot arbitrates remote tombstones by timestamp: a tombstone is skipped when the local entry with that uuid is newer than deleted_at (resurrection wins). Ties / unparseable timestamps favour KEEP. loadEntries() up front so updated_at reflects the live rows. WebView2 navigation race - Black-window-on-cold-start fix: the 1.5s nav timer no longer consumes FPendingURL when WebView2 isn't initialised yet (it re-arms, bounded to ~10 retries). FBrowserInitialized flag set in OnInitialized; after the retry budget we Navigate best-effort rather than loop forever. Sync UX - Bidirectional toast: "pulled X new · Y updated · Z deleted · pushed N entries" so a 0/0/0 pull still shows the vault was uploaded. - FolderPOST/PUT: pre-declare ftString on color/icon params (fixes the earlier [SQLite]-335 on NULL bind, already in play for CSV import). Docs - CLAUDE.md sync section documents tombstone purge-on-insert + resurrection arbitration. Co-Authored-By: Claude Opus 4.7 <noreply@anthropic.com>
1407 lines
53 KiB
ObjectPascal
1407 lines
53 KiB
ObjectPascal
unit UMainForm;
|
|
|
|
// ----------------------------------------------------------------------
|
|
// WebBrowser engine switch — compile-time directive.
|
|
//
|
|
// Uncomment USE_EDGE_BROWSER to build against TTMSFNCEdgeWebBrowser
|
|
// (Windows-only, direct WebView2 wrapper). Default = TTMSFNCWebBrowser
|
|
// (cross-platform abstraction also on WebView2 under Windows). Both
|
|
// expose the same TTMSFNCCustomWebBrowser API for OnBeforeNavigate /
|
|
// ExecuteJavaScript / Navigate, so the bridge cmd:// glue is unchanged.
|
|
// ----------------------------------------------------------------------
|
|
{$DEFINE USE_EDGE_BROWSER}
|
|
|
|
interface
|
|
|
|
|
|
|
|
uses
|
|
System.SysUtils, System.Classes, System.UITypes, System.NetEncoding,
|
|
System.StrUtils, System.Generics.Collections, System.IOUtils, System.JSON,
|
|
System.Net.HttpClient, System.Net.URLClient,
|
|
Winapi.Windows, Winapi.ShellAPI,
|
|
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.DialogService,
|
|
FMX.TMSFNCTypes, FMX.TMSFNCUtils, FMX.TMSFNCGraphics, FMX.TMSFNCGraphicsTypes,
|
|
FMX.TMSFNCCustomControl, FMX.TMSFNCWebBrowser,
|
|
// ICoreWebView2 / ICoreWebView2Settings3 COM interface declarations —
|
|
// used to disable browser accelerator keys (Ctrl+P, Ctrl+J, F12, etc.)
|
|
// via the AreBrowserAcceleratorKeysEnabled property that Settings.* doesn't
|
|
// expose at the TMS wrapper level.
|
|
FMX.TMSFNCWebBrowser.Win,
|
|
{$IFDEF USE_EDGE_BROWSER}
|
|
FMX.TMSFNCEdgeWebBrowser,
|
|
{$ENDIF}
|
|
PM.HTTPServer, PM.Bridge, PM.QuickUnlock, PM.PinUnlock, PM.UserPrefs, PM.AutoStart,
|
|
PM.Favicon,
|
|
FMX.Platform.Win, FMX.Menus; // WindowHandleToPlatform → HWND for visibility check
|
|
const
|
|
// Bump on each release. Surfaced to JS via cmd://app/version, displayed
|
|
// in Settings → Account so users can report bugs with the right build.
|
|
APP_VERSION = '1.0.0';
|
|
type
|
|
// Concrete class chosen at compile time. Both inherit from
|
|
// TTMSFNCCustomWebBrowser so we use that as the field type — events
|
|
// and ExecuteJavaScript live on the base class.
|
|
{$IFDEF USE_EDGE_BROWSER}
|
|
TWebBrowserClass = TTMSFNCEdgeWebBrowser;
|
|
{$ELSE}
|
|
TWebBrowserClass = TTMSFNCWebBrowser;
|
|
{$ENDIF}
|
|
|
|
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;
|
|
PopupMenu1: TPopupMenu;
|
|
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;
|
|
// Set once WebView2 fires OnInitialized. The nav timer only consumes
|
|
// FPendingURL when this is True — otherwise a timer tick that lands
|
|
// before the engine is ready would Navigate() into the void AND clear
|
|
// FPendingURL, leaving OnInitialized nothing to do → permanent black
|
|
// window on slow cold starts.
|
|
FBrowserInitialized: Boolean;
|
|
FNavRetries: Integer; // bounded retry count for the deferred nav timer
|
|
FRequireAccessToken: Boolean;
|
|
FRequireProcessCheck: Boolean;
|
|
FQuitting: Boolean; // set when user picks "Quit" in tray menu — bypasses
|
|
// FormCloseQuery's minimize-to-tray intercept.
|
|
FAutofillTargetHWND: HWND; // saved at hotkey time, consumed on /execute
|
|
// Pending payload for the 60ms delay timer (focus settle before SendInput).
|
|
// Cleared inside AutofillTimerTick.
|
|
FAutofillPendingHWND: HWND;
|
|
FAutofillPendingUser: string;
|
|
FAutofillPendingPass: string;
|
|
// True when the JS layer asked us to hide back to the tray AFTER the
|
|
// autofill SendInput completes. Used by the Ctrl+Shift+Q hotkey path
|
|
// when invoked while the app was in the tray — we can't hide before
|
|
// SendInput because Win10/11 anti-focus-stealing rules then refuse to
|
|
// hand focus to the target window.
|
|
FAutofillPendingHide: Boolean;
|
|
// Created dynamically in FormCreate so the directive can pick either
|
|
// TTMSFNCWebBrowser or TTMSFNCEdgeWebBrowser at compile time without
|
|
// needing two .fmx variants. Aligned to Client to fill the remaining
|
|
// space between PanelTop (top) and PanelLog/Splitter (bottom).
|
|
WebBrowser: TWebBrowserClass;
|
|
procedure AutofillTimerTick(Sender: TObject);
|
|
procedure LogLine(const AMsg: string);
|
|
procedure UpdateButtons;
|
|
procedure NavigateToVault;
|
|
procedure NavTimerTick(Sender: TObject);
|
|
// JS↔Delphi bridge
|
|
procedure WebBrowserBeforeNavigate(Sender: TObject;
|
|
var Params: TTMSFNCCustomWebBrowserBeforeNavigateParams);
|
|
procedure WebBrowserGetContextMenu(Sender: TObject;
|
|
ATarget: TTMSFNCWebBrowserTargetItem;
|
|
AContextMenu: TObjectList<TTMSFNCWebBrowserContextMenuItem>);
|
|
procedure HandleBridgeCommand(const ACmd, AParams: string);
|
|
procedure BridgeSystemLock;
|
|
procedure BridgeTrayRestore;
|
|
procedure BridgeLockRequest;
|
|
procedure BridgeQuit;
|
|
procedure BridgeAutofillRequest(AKind: TAutofillKind;
|
|
ATargetHWND: HWND; const ATitle: string);
|
|
procedure BridgeDebugHotkey;
|
|
procedure BridgeNewEntryHotkey(const AWindowTitle: string);
|
|
procedure BridgeQuickSearchRequest;
|
|
procedure BridgeQuickSearchHotkey(AKind: TAutofillKind;
|
|
ATargetHWND: HWND; const ATitle: string);
|
|
procedure WebBrowserInitialized(Sender: TObject);
|
|
end;
|
|
|
|
var
|
|
MainForm: TMainForm;
|
|
|
|
implementation
|
|
|
|
{$R *.fmx}
|
|
|
|
// Forward — used by WebBrowserInitialized (which sits above the actual
|
|
// definition lower in the unit).
|
|
function MaskAccessToken(const AUrl: string): string; forward;
|
|
|
|
procedure TMainForm.FormCreate(Sender: TObject);
|
|
begin
|
|
// Create the WebBrowser control programmatically so the {$IFDEF
|
|
// USE_EDGE_BROWSER} directive can swap the concrete class without a
|
|
// second .fmx variant. Align Client to fill the area below PanelTop
|
|
// and above the (collapsible) PanelLog + Splitter.
|
|
WebBrowser := TWebBrowserClass.Create(Self);
|
|
// Wire events BEFORE Parent assignment: setting Parent triggers the
|
|
// TMS browser's async WebView2 init, which fires OnInitialized when
|
|
// Edge Chromium is ready. If we assigned the handlers afterwards we'd
|
|
// miss the event on fast / pre-warmed Edge installs (and the
|
|
// Settings.EnableContextMenu / SetAcceleratorKeys calls inside would
|
|
// never run, leaving the native context menu and Ctrl+P/J live).
|
|
WebBrowser.OnBeforeNavigate := WebBrowserBeforeNavigate;
|
|
WebBrowser.OnInitialized := WebBrowserInitialized;
|
|
{$IFDEF USE_EDGE_BROWSER}
|
|
// On TTMSFNCEdgeWebBrowser the event is published.
|
|
// On TTMSFNCWebBrowser the same property is only re-published inside a
|
|
// conditional ($IFNDEF FNCLIB) block — depending on the FNC build, it
|
|
// may not be accessible. Restricting the assignment to the Edge build
|
|
// keeps the unconditional path TTMSFNCWebBrowser-safe.
|
|
WebBrowser.OnGetContextMenu := WebBrowserGetContextMenu;
|
|
{$ENDIF}
|
|
WebBrowser.Parent := Self;
|
|
WebBrowser.Align := TAlignLayout.Client;
|
|
|
|
FServer := TPMHTTPServer.Create;
|
|
FServer.OnLog := LogLine;
|
|
|
|
FBridge := TPMBridge.Create(Self);
|
|
FBridge.OnSystemLock := BridgeSystemLock;
|
|
FBridge.OnTrayRestore := BridgeTrayRestore;
|
|
FBridge.OnLockRequest := BridgeLockRequest;
|
|
FBridge.OnQuit := BridgeQuit;
|
|
FBridge.OnAutofillRequest := BridgeAutofillRequest;
|
|
FBridge.OnDebugHotkey := BridgeDebugHotkey;
|
|
FBridge.OnNewEntryHotkey := BridgeNewEntryHotkey;
|
|
FBridge.OnQuickSearchRequest := BridgeQuickSearchRequest;
|
|
FBridge.OnQuickSearchHotkey := BridgeQuickSearchHotkey;
|
|
FBridge.RegisterAutofillHotkey; // Ctrl+Shift+L active from startup
|
|
FBridge.ApplyTitleBarTheme(True); // dark by default, JS may toggle later
|
|
FAutofillTargetHWND := 0;
|
|
// 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 - d backend ready.');
|
|
LogLine('Click Start to launch server + embedded web vault.');
|
|
PanelTop.Visible := False;
|
|
FRequireAccessToken := True;
|
|
FRequireProcessCheck := True;
|
|
edtPort.Text := '0';
|
|
if FileExists('config.txt') then
|
|
begin
|
|
var configList := TStringList.Create;
|
|
configList.LoadFromFile('config.txt');
|
|
try
|
|
var defPort := StrToIntDef(configList.Values['port'], 0);
|
|
edtPort.Text := defPort.ToString;
|
|
PanelTop.Visible := configList.Values['debug'].ToLower.Equals('true');
|
|
if configList.Values['require_token'].ToLower.Equals('false') then
|
|
FRequireAccessToken := False;
|
|
if configList.Values['require_process_check'].ToLower.Equals('false') then
|
|
FRequireProcessCheck := False;
|
|
finally
|
|
FreeAndNil(configList);
|
|
end;
|
|
end;
|
|
btnStartClick(Nil);
|
|
btnToggleLogClick(nil);
|
|
|
|
// CLI flag --tray (set by the "Start with Windows" registry entry):
|
|
// launch directly into the tray instead of popping a window during
|
|
// the Windows login. Defer to ForceQueue so the form has finished its
|
|
// initial Show before we hide it — minimises the visible flash.
|
|
if FindCmdLineSwitch('tray', True) then
|
|
begin
|
|
// Suppress the first-time tray balloon for autostart launches —
|
|
// it's noise when Windows itself put us in the tray (the user
|
|
// didn't actively minimise). Manual launches still see it once.
|
|
FBridge.BalloonShown := True;
|
|
TThread.ForceQueue(nil,
|
|
procedure
|
|
begin
|
|
FBridge.MinimizeToTray;
|
|
LogLine('Launched with --tray, minimised at startup (balloon suppressed)');
|
|
end);
|
|
end;
|
|
end;
|
|
|
|
procedure TMainForm.FormDestroy(Sender: TObject);
|
|
begin
|
|
FBridge.Free;
|
|
FServer.Free;
|
|
end;
|
|
|
|
procedure TMainForm.WebBrowserInitialized(Sender: TObject);
|
|
var
|
|
LUnk: IUnknown;
|
|
LCtrl: ICoreWebView2Controller;
|
|
LWv2: ICoreWebView2;
|
|
LSettings: ICoreWebView2Settings;
|
|
LSettings3: ICoreWebView2Settings3;
|
|
LPtr: Pointer;
|
|
begin
|
|
// Disable native Edge context menu + DevTools via the TMS-wrapped settings.
|
|
// Disable browser-level accelerator keys (Ctrl+P / Ctrl+J / Ctrl+H /
|
|
// Ctrl+S / F12 / etc.). TMS's NativeBrowser returns the
|
|
// ICoreWebView2Controller, not the ICoreWebView2 — so we walk the chain:
|
|
// Controller → get_CoreWebView2 → get_Settings → QI(Settings3) → set_.
|
|
// Pointer→Interface cast must go through an explicit AddRef to keep the
|
|
// refcount balanced (otherwise the auto-Release at scope exit frees a
|
|
// reference TMS is still holding → AV at next use).
|
|
LPtr := WebBrowser.NativeBrowser;
|
|
if LPtr <> nil then
|
|
begin
|
|
Pointer(LUnk) := LPtr;
|
|
LUnk._AddRef;
|
|
if Supports(LUnk, ICoreWebView2Controller, LCtrl) then
|
|
begin
|
|
LCtrl.get_CoreWebView2(LWv2);
|
|
if Assigned(LWv2) then
|
|
begin
|
|
LWv2.get_Settings(LSettings);
|
|
if Assigned(LSettings) and
|
|
Supports(LSettings, ICoreWebView2Settings3, LSettings3) then
|
|
LSettings3.set_AreBrowserAcceleratorKeysEnabled(False);
|
|
end;
|
|
end;
|
|
end;
|
|
{$IFDEF USE_EDGE_BROWSER}
|
|
WebBrowser.Settings.EnableContextMenu := False;
|
|
WebBrowser.Settings.EnableShowDebugConsole := False;
|
|
{$ELSE}
|
|
WebBrowser.EnableContextMenu := False;
|
|
WebBrowser.EnableShowDebugConsole := False;
|
|
WebBrowser.PopupMenu := PopupMenu1;
|
|
{$ENDIF}
|
|
|
|
// Race-safe navigation fallback: the 1.5 s timer in NavigateToVault
|
|
// assumes WebView2 finishes its async init within that window. On slow
|
|
// boots / cold-start machines Edge Chromium can take 2-3 s, and the
|
|
// timer's Navigate() call lands while the browser is still uninitialised
|
|
// → silently dropped → blank window forever. OnInitialized fires once
|
|
// the engine is ready, so if a navigation is still pending here, do it
|
|
// now. The timer either already ran (FPendingURL == '') or runs later
|
|
// and no-ops on the empty string.
|
|
FBrowserInitialized := True;
|
|
FNavTimer.Enabled := False;
|
|
if FPendingURL <> '' then
|
|
begin
|
|
LogLine('OnInitialized fallback nav to: ' + MaskAccessToken(FPendingURL));
|
|
WebBrowser.Navigate(FPendingURL);
|
|
FPendingURL := '';
|
|
end;
|
|
end;
|
|
|
|
procedure TMainForm.BridgeQuickSearchHotkey(AKind: TAutofillKind;
|
|
ATargetHWND: HWND; const ATitle: string);
|
|
var
|
|
LWasHidden: Boolean;
|
|
LWasHiddenJs: string;
|
|
begin
|
|
// Ctrl+Shift+Q anywhere — save the foreground HWND so the JS layer's
|
|
// cmd://autofill/execute (fired after the user picks an entry) sends
|
|
// the password into it. Then pop the modal in fill mode.
|
|
if not FServer.Active then Exit;
|
|
FAutofillTargetHWND := ATargetHWND;
|
|
LWasHidden := (not Self.Visible) or
|
|
IsIconic(WindowHandleToPlatform(Self.Handle).Wnd);
|
|
FBridge.RestoreFromTray;
|
|
LWasHiddenJs := BoolToStr(LWasHidden, True).ToLower;
|
|
// Second arg forFill=true tells JS to SendInput on pick instead of copy.
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&typeof Bridge.openQuickSearch==="function")' +
|
|
'Bridge.openQuickSearch(' + LWasHiddenJs + ',true)');
|
|
LogLine(Format('Quick-search hotkey — target=%s, title="%s"',
|
|
[IntToHex(ATargetHWND, 8), ATitle]));
|
|
end;
|
|
|
|
procedure TMainForm.BridgeQuickSearchRequest;
|
|
var
|
|
LWasHidden: Boolean;
|
|
LWasHiddenJs: string;
|
|
begin
|
|
// Tray menu "Quick search…" — bring the window back so the user can
|
|
// see the modal, then ask JS to open it. JS handles the locked-vault
|
|
// case (shows the auth screen with master-pw focused instead).
|
|
if not FServer.Active then Exit;
|
|
// Remember whether the window was hidden BEFORE we restore — after the
|
|
// user picks an entry the JS layer asks us to minimize back so they can
|
|
// paste into the target app without an extra alt-tab.
|
|
LWasHidden := (not Self.Visible) or
|
|
IsIconic(WindowHandleToPlatform(Self.Handle).Wnd);
|
|
FBridge.RestoreFromTray;
|
|
LWasHiddenJs := BoolToStr(LWasHidden, True).ToLower;
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&typeof Bridge.openQuickSearch==="function")' +
|
|
'Bridge.openQuickSearch(' + LWasHiddenJs + ')');
|
|
LogLine('Quick search requested from tray menu (wasHidden=' + LWasHiddenJs + ')');
|
|
end;
|
|
|
|
procedure TMainForm.BridgeNewEntryHotkey(const AWindowTitle: string);
|
|
var
|
|
EscapedTitle: string;
|
|
begin
|
|
if not FServer.Active then Exit;
|
|
FBridge.RestoreFromTray;
|
|
EscapedTitle := StringReplace(AWindowTitle, '\', '\\', [rfReplaceAll]);
|
|
EscapedTitle := StringReplace(EscapedTitle, '"', '\"', [rfReplaceAll]);
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&typeof Bridge.onNewEntryFromTitle==="function")' +
|
|
'Bridge.onNewEntryFromTitle("' + EscapedTitle + '")');
|
|
LogLine('New entry hotkey — title: "' + AWindowTitle + '"');
|
|
end;
|
|
|
|
procedure TMainForm.BridgeDebugHotkey;
|
|
begin
|
|
if not FileExists('config.txt') then
|
|
Exit;
|
|
PanelTop.Visible := not PanelTop.Visible;
|
|
LogLine('Debug panel ' + IfThen(PanelTop.Visible, 'shown', 'hidden') +
|
|
' via Ctrl+Shift+D');
|
|
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;
|
|
|
|
// Windows shutdown / logoff / restart: WM_QUERYENDSESSION flipped the
|
|
// bridge's flag. Let the form close normally so FServer.Free and the
|
|
// FireDAC connection get a chance to checkpoint the WAL — otherwise
|
|
// Windows force-kills us at the shutdown timeout and we leave
|
|
// -shm / -wal files next to vault.db.
|
|
if Assigned(FBridge) and FBridge.ShutdownPending then
|
|
begin
|
|
FQuitting := True;
|
|
LogLine('System shutdown detected — closing normally.');
|
|
Exit;
|
|
end;
|
|
|
|
// 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;
|
|
|
|
function MaskAccessToken(const AUrl: string): string;
|
|
var
|
|
TokenPos: Integer;
|
|
begin
|
|
Result := AUrl;
|
|
TokenPos := Pos('?pmt=', Result);
|
|
if TokenPos > 0 then
|
|
Result := Copy(Result, 1, TokenPos + 4) + '***';
|
|
end;
|
|
|
|
procedure TMainForm.NavigateToVault;
|
|
begin
|
|
FPendingURL := 'http://127.0.0.1:' + FServer.BoundPort.ToString + '/index.html';
|
|
if FServer.RequireAccessToken then
|
|
FPendingURL := FPendingURL + '?pmt=' + FServer.AccessToken;
|
|
LogLine('Will navigate embedded browser in ~1.5s to: ' + MaskAccessToken(FPendingURL));
|
|
FNavRetries := 0;
|
|
FNavTimer.Enabled := False;
|
|
FNavTimer.Enabled := True;
|
|
end;
|
|
|
|
procedure TMainForm.NavTimerTick(Sender: TObject);
|
|
begin
|
|
FNavTimer.Enabled := False;
|
|
if FPendingURL = '' then Exit;
|
|
// Engine not ready yet: Navigate() would be silently dropped. Leave
|
|
// FPendingURL intact and re-arm — either this timer catches the engine
|
|
// once it's up, or OnInitialized fires first and does the nav. Whoever
|
|
// wins clears FPendingURL so the other no-ops (no reload flash).
|
|
// Bounded to ~10 retries (15 s): if OnInitialized never fires (missing /
|
|
// broken WebView2 runtime), we stop deferring and attempt Navigate once
|
|
// anyway — best effort beats an eternal retry loop on a blank window.
|
|
if (not FBrowserInitialized) and (FNavRetries < 10) then
|
|
begin
|
|
Inc(FNavRetries);
|
|
LogLine(Format('Nav deferred — WebView2 not initialised (retry %d/10).',
|
|
[FNavRetries]));
|
|
FNavTimer.Enabled := True;
|
|
Exit;
|
|
end;
|
|
if not FBrowserInitialized then
|
|
LogLine('WebView2 still not initialised after retries — attempting nav anyway.');
|
|
LogLine('Navigating to: ' + MaskAccessToken(FPendingURL));
|
|
WebBrowser.Navigate(FPendingURL);
|
|
FPendingURL := '';
|
|
end;
|
|
|
|
procedure TMainForm.btnStartClick(Sender: TObject);
|
|
var
|
|
LPort: Integer;
|
|
begin
|
|
// WebBrowser.Navigate('about:blank');
|
|
// exit;
|
|
LPort := StrToIntDef(edtPort.Text, 8765);
|
|
try
|
|
FServer.Start(LPort, True, FRequireAccessToken, FRequireProcessCheck);
|
|
edtPort.Text := FServer.BoundPort.ToString;
|
|
UpdateButtons;
|
|
NavigateToVault;
|
|
except
|
|
on E: Exception do
|
|
begin
|
|
LogLine('ERROR starting server: ' + E.Message);
|
|
TDialogService.MessageDialog('Failed to start: ' + E.Message,
|
|
TMsgDlgType.mtError, [TMsgDlgBtn.mbOK], TMsgDlgBtn.mbOK, 0, nil);
|
|
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.WebBrowserGetContextMenu(Sender: TObject;
|
|
ATarget: TTMSFNCWebBrowserTargetItem;
|
|
AContextMenu: TObjectList<TTMSFNCWebBrowserContextMenuItem>);
|
|
begin
|
|
// Clearing the items leaves WebView2 with nothing to show → the native
|
|
// right-click menu is suppressed entirely. The JS layer renders a
|
|
// custom Cut/Copy/Paste menu on text inputs via installCustomContextMenu().
|
|
AContextMenu.Clear;
|
|
end;
|
|
|
|
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 if ACmd = 'clipboard/read' then
|
|
begin
|
|
var ClipText := FBridge.SecureClipboard.ReadText;
|
|
var Escaped := StringReplace(ClipText, '\', '\\', [rfReplaceAll]);
|
|
Escaped := StringReplace(Escaped, '"', '\"', [rfReplaceAll]);
|
|
Escaped := StringReplace(Escaped, #13, '\r', [rfReplaceAll]);
|
|
Escaped := StringReplace(Escaped, #10, '\n', [rfReplaceAll]);
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onClipboardRead)Bridge.onClipboardRead("' + Escaped + '")');
|
|
end
|
|
|
|
// ---- Quick unlock (DPAPI persistence of the vault key) ----
|
|
// store: client provides a base64-encoded blob (UTF-8 JSON, content
|
|
// opaque to us). We DPAPI-encrypt and stash on disk.
|
|
// get: we DPAPI-decrypt, base64-encode, send back via ExecuteJavaScript.
|
|
// clear: forget-me.
|
|
else if ACmd = 'quickunlock/store' then
|
|
begin
|
|
LText := GetParam('data'); // base64 of UTF-8 JSON blob
|
|
if LText = '' then Exit;
|
|
var LBytes := TNetEncoding.Base64.DecodeStringToBytes(LText);
|
|
if PM.QuickUnlock.StoreQuickUnlock(LBytes) then
|
|
LogLine(Format('Quick unlock stored (%d bytes)', [Length(LBytes)]))
|
|
else
|
|
LogLine('Quick unlock store FAILED (DPAPI error)');
|
|
end
|
|
|
|
else if ACmd = 'quickunlock/get' then
|
|
begin
|
|
var LBytes: TBytes;
|
|
if PM.QuickUnlock.LoadQuickUnlock(LBytes) and (Length(LBytes) > 0) then
|
|
begin
|
|
var LB64 := TNetEncoding.Base64.EncodeBytesToString(LBytes);
|
|
// Strip newlines that the Base64 encoder may insert (line-wrapping
|
|
// breaks the JS-side decoder) before injecting into a JS string.
|
|
LB64 := StringReplace(LB64, #13, '', [rfReplaceAll]);
|
|
LB64 := StringReplace(LB64, #10, '', [rfReplaceAll]);
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onQuickUnlockResult)' +
|
|
'Bridge.onQuickUnlockResult("' + LB64 + '")');
|
|
LogLine('Quick unlock served');
|
|
end
|
|
else
|
|
begin
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onQuickUnlockResult)' +
|
|
'Bridge.onQuickUnlockResult(null)');
|
|
end;
|
|
end
|
|
|
|
else if ACmd = 'quickunlock/clear' then
|
|
begin
|
|
PM.QuickUnlock.ClearQuickUnlock;
|
|
LogLine('Quick unlock cleared');
|
|
end
|
|
|
|
else if ACmd = 'quickunlock/status' then
|
|
begin
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onQuickUnlockStatus)' +
|
|
'Bridge.onQuickUnlockStatus(' +
|
|
BoolToStr(PM.QuickUnlock.HasQuickUnlock, True).ToLower + ')');
|
|
end
|
|
|
|
// ---- PIN unlock (DPAPI blob, PIN-derived wrap of the vault key) ----
|
|
// Same wire model as quickunlock — opaque base64 payload in / out.
|
|
else if ACmd = 'pin/store' then
|
|
begin
|
|
LText := GetParam('data');
|
|
if LText = '' then Exit;
|
|
var LBytes := TNetEncoding.Base64.DecodeStringToBytes(LText);
|
|
if PM.PinUnlock.StorePinUnlock(LBytes) then
|
|
LogLine(Format('PIN blob stored (%d bytes)', [Length(LBytes)]))
|
|
else
|
|
LogLine('PIN blob store FAILED (DPAPI error)');
|
|
end
|
|
|
|
else if ACmd = 'pin/get' then
|
|
begin
|
|
var LBytes: TBytes;
|
|
if PM.PinUnlock.LoadPinUnlock(LBytes) and (Length(LBytes) > 0) then
|
|
begin
|
|
var LB64 := TNetEncoding.Base64.EncodeBytesToString(LBytes);
|
|
LB64 := StringReplace(LB64, #13, '', [rfReplaceAll]);
|
|
LB64 := StringReplace(LB64, #10, '', [rfReplaceAll]);
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onPinResult)' +
|
|
'Bridge.onPinResult("' + LB64 + '")');
|
|
LogLine('PIN blob served');
|
|
end
|
|
else
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onPinResult)Bridge.onPinResult(null)');
|
|
end
|
|
|
|
else if ACmd = 'pin/clear' then
|
|
begin
|
|
PM.PinUnlock.ClearPinUnlock;
|
|
LogLine('PIN blob cleared');
|
|
end
|
|
|
|
else if ACmd = 'pin/status' then
|
|
begin
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onPinStatus)' +
|
|
'Bridge.onPinStatus(' +
|
|
BoolToStr(PM.PinUnlock.HasPinUnlock, True).ToLower + ')');
|
|
end
|
|
|
|
// ---- Autofill --------------------------------------------------------
|
|
// configure: JS calls this on page load / settings change to sync the
|
|
// hotkey registration state with the user's localStorage preference.
|
|
// Uses the historical defaults (Ctrl+Shift+L / Ctrl+Shift+P) — for
|
|
// custom combos, JS sends cmd://autofill/hotkeys instead.
|
|
else if ACmd = 'autofill/configure' then
|
|
begin
|
|
if GetParam('enabled') = '1' then
|
|
begin
|
|
FBridge.RegisterAutofillHotkey;
|
|
LogLine('Autofill hotkeys registered (defaults)');
|
|
end
|
|
else
|
|
begin
|
|
FBridge.UnregisterAutofillHotkey;
|
|
LogLine('Autofill hotkeys unregistered');
|
|
end;
|
|
end
|
|
|
|
// hotkeys: JS pushes the user-configured combos. Params:
|
|
// enabled = '1' | '0'
|
|
// full_mods = MOD_x bitmask (decimal), full_vk = VK code (decimal)
|
|
// pwd_mods, pwd_vk = same for the password-only hotkey
|
|
// If enabled=0, we just unregister and ignore the rest. If enabled=1,
|
|
// we register both with the supplied combos (replacing any prior).
|
|
else if ACmd = 'autofill/hotkeys' then
|
|
begin
|
|
// Quick-search combo is set unconditionally (independent of the
|
|
// autofill enabled flag) so the picker stays armed even when the
|
|
// autofill hotkeys are turned off.
|
|
if GetParam('qs_vk') <> '' then
|
|
begin
|
|
var LQsMods := Word(StrToIntDef(GetParam('qs_mods'), 6));
|
|
var LQsVk := Word(StrToIntDef(GetParam('qs_vk'), Ord('Q')));
|
|
var LQsOk := FBridge.SetQuickSearchHotkey(LQsMods, LQsVk);
|
|
LogLine(Format('Quick-search hotkey set — mods:%d vk:%d (ok=%s)',
|
|
[LQsMods, LQsVk, BoolToStr(LQsOk, True)]));
|
|
end;
|
|
if GetParam('enabled') <> '1' then
|
|
begin
|
|
FBridge.UnregisterAutofillHotkey;
|
|
LogLine('Autofill hotkeys unregistered (custom)');
|
|
end
|
|
else
|
|
begin
|
|
var LFullMods := Word(StrToIntDef(GetParam('full_mods'), 6)); // Ctrl+Shift
|
|
var LFullVk := Word(StrToIntDef(GetParam('full_vk'), Ord('L')));
|
|
var LPwdMods := Word(StrToIntDef(GetParam('pwd_mods'), 6));
|
|
var LPwdVk := Word(StrToIntDef(GetParam('pwd_vk'), Ord('P')));
|
|
var LAllOk := FBridge.SetAutofillHotkeys(LFullMods, LFullVk,
|
|
LPwdMods, LPwdVk);
|
|
LogLine(Format('Autofill hotkeys set — full=mods:%d vk:%d pwd=mods:%d vk:%d (all_ok=%s)',
|
|
[LFullMods, LFullVk, LPwdMods, LPwdVk, BoolToStr(LAllOk, True)]));
|
|
// Notify JS of the result so the UI can flag a failed-to-register combo
|
|
// (typically a clash with another app's global hotkey).
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onAutofillHotkeysResult)' +
|
|
'Bridge.onAutofillHotkeysResult(' + BoolToStr(LAllOk, True).ToLower + ')');
|
|
end;
|
|
end
|
|
|
|
// execute: JS has matched an entry, decrypted the password, and is
|
|
// telling Delphi to type username + Tab + password into the saved HWND.
|
|
else if ACmd = 'autofill/execute' then
|
|
begin
|
|
FAutofillPendingUser := GetParam('username');
|
|
FAutofillPendingPass := GetParam('password');
|
|
FAutofillPendingHWND := FAutofillTargetHWND;
|
|
FAutofillPendingHide := GetParam('hide_after') = '1';
|
|
FAutofillTargetHWND := 0;
|
|
|
|
// Small timer so SetForegroundWindow has time to take effect before
|
|
// SendInput fires — avoids the first keystrokes going to our window.
|
|
// TTimer.OnTimer is a TNotifyEvent (method, not anon proc) → we use a
|
|
// dedicated method on the form and stash the payload in fields.
|
|
var LTimer := TTimer.Create(Self);
|
|
LTimer.Interval := 60;
|
|
LTimer.OnTimer := AutofillTimerTick;
|
|
LTimer.Enabled := True;
|
|
end
|
|
|
|
// cancel: JS found no match or user dismissed the picker — nothing to type.
|
|
else if ACmd = 'autofill/cancel' then
|
|
begin
|
|
FAutofillTargetHWND := 0;
|
|
LogLine('Autofill cancelled (no match or dismissed)');
|
|
end
|
|
|
|
// focus: JS asks us to bring the main window to front (e.g. when the
|
|
// autofill picker opens — without this the picker is shown in the
|
|
// WebView but the user might not notice if our window was minimised
|
|
// or behind other apps). The Target HWND stays saved; ExecuteAutofill
|
|
// restores it later via ForceForegroundWindow.
|
|
else if ACmd = 'app/focus' then
|
|
begin
|
|
FBridge.RestoreFromTray;
|
|
LogLine('App brought to front (autofill picker)');
|
|
end
|
|
|
|
// Used by the quick-search modal: after the user picks an entry the
|
|
// password is on the clipboard — if the app was hidden when invoked
|
|
// from the tray menu, hide it again so the user can paste straight
|
|
// into the target app without alt-tabbing.
|
|
else if ACmd = 'app/minimize' then
|
|
FBridge.MinimizeToTray
|
|
|
|
// Tray balloon notifications on/off. JS pushes the user setting at
|
|
// startup (settings_json sync) and whenever they flip the toggle.
|
|
else if ACmd = 'tray/notifications' then
|
|
begin
|
|
FBridge.ShowNotifications := GetParam('enabled') = '1';
|
|
LogLine('Tray notifications ' +
|
|
IfThen(FBridge.ShowNotifications, 'enabled', 'disabled'));
|
|
end
|
|
|
|
else if ACmd = 'app/ready' then
|
|
begin
|
|
WebBrowser.SetFocus;
|
|
WebBrowser.ExecuteJavaScript(
|
|
'setTimeout(()=>{var u=document.getElementById("loginUsername"),' +
|
|
'p=document.getElementById("loginPassword");' +
|
|
'if(u&&u.value){p&&p.focus();}else{u&&u.focus();}},0)');
|
|
end
|
|
|
|
else if ACmd = 'app/theme' then
|
|
FBridge.ApplyTitleBarTheme(GetParam('mode') = 'dark')
|
|
|
|
// Build/version string exposed to JS for the Settings → About panel.
|
|
// Hardcoded const — bump manually on releases. Kept simple to avoid
|
|
// pulling Windows resource version info at runtime.
|
|
else if ACmd = 'app/version' then
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onVersionResult)' +
|
|
'Bridge.onVersionResult("' + APP_VERSION + '")')
|
|
|
|
// Launch context: the HKCU Run entry passes -tray so we can tell
|
|
// "Windows started me at boot" from "user double-clicked the exe".
|
|
// Useful for Settings → Account display and for conditional behavior
|
|
// (e.g. skip first-time tooltips on autostart).
|
|
else if ACmd = 'app/launch-mode' then
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onLaunchModeResult)' +
|
|
'Bridge.onLaunchModeResult("' +
|
|
IfThen(FindCmdLineSwitch('tray', True), 'auto', 'manual') + '")')
|
|
|
|
// Open the entry's site in the user's default browser. We restrict the
|
|
// scheme to http(s) so JS can't smuggle a file:// or other handler that
|
|
// would invoke arbitrary Windows applications.
|
|
else if ACmd = 'app/open-url' then
|
|
begin
|
|
var LUrl := GetParam('url');
|
|
if (LUrl <> '') and
|
|
(LUrl.ToLower.StartsWith('http://') or LUrl.ToLower.StartsWith('https://')) then
|
|
begin
|
|
ShellExecute(0, 'open', PChar(LUrl), nil, nil, 1); // SW_SHOWNORMAL = 1
|
|
LogLine('Opened URL: ' + LUrl);
|
|
end
|
|
else
|
|
LogLine('Refused to open non-http(s) URL: ' + LUrl);
|
|
end
|
|
|
|
// ---- Device-bound prefs (DPAPI key/value) ----------------------------
|
|
// Used for prefs that must survive the ephemeral-port reset of the
|
|
// WebView2 localStorage (rememberedUsername, etc.).
|
|
else if ACmd = 'prefs/get' then
|
|
begin
|
|
var LKey := GetParam('key');
|
|
if LKey = '' then Exit;
|
|
var LVal := PM.UserPrefs.GetPref(LKey);
|
|
var LEscapedKey := StringReplace(LKey, '\', '\\', [rfReplaceAll]);
|
|
LEscapedKey := StringReplace(LEscapedKey, '"', '\"', [rfReplaceAll]);
|
|
var LEscapedVal := StringReplace(LVal, '\', '\\', [rfReplaceAll]);
|
|
LEscapedVal := StringReplace(LEscapedVal, '"', '\"', [rfReplaceAll]);
|
|
LEscapedVal := StringReplace(LEscapedVal, #13, '\r', [rfReplaceAll]);
|
|
LEscapedVal := StringReplace(LEscapedVal, #10, '\n', [rfReplaceAll]);
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onPrefResult)' +
|
|
'Bridge.onPrefResult("' + LEscapedKey + '","' + LEscapedVal + '")');
|
|
end
|
|
|
|
else if ACmd = 'prefs/set' then
|
|
begin
|
|
var LKey := GetParam('key');
|
|
if LKey = '' then Exit;
|
|
PM.UserPrefs.SetPref(LKey, GetParam('value'));
|
|
end
|
|
|
|
// ---- Start with Windows (HKCU Run registry) --------------------------
|
|
else if ACmd = 'autostart/get' then
|
|
begin
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onAutoStartStatus)' +
|
|
'Bridge.onAutoStartStatus(' +
|
|
BoolToStr(PM.AutoStart.IsAutoStartEnabled, True).ToLower + ')');
|
|
end
|
|
|
|
// ---- Favicon proxy (Delphi-side fetch to keep CSP tight + privacy
|
|
// centralised on one upstream domain). Async: the HTTP GET would
|
|
// block the main thread for up to 5 s on slow networks.
|
|
else if ACmd = 'favicon/fetch' then
|
|
begin
|
|
var LHost := GetParam('host');
|
|
var LReqId := GetParam('reqId'); // opaque, echoed back to JS resolver
|
|
if LHost = '' then Exit;
|
|
LogLine('favicon/fetch host="' + LHost + '" reqId=' + LReqId);
|
|
TThread.CreateAnonymousThread(
|
|
procedure
|
|
var
|
|
LDataUri: string;
|
|
begin
|
|
LDataUri := PM.Favicon.FetchFaviconDataUri(LHost,
|
|
procedure(const ALine: string)
|
|
begin
|
|
TThread.Queue(nil,
|
|
procedure
|
|
begin
|
|
LogLine('favicon[' + LHost + ']: ' + ALine);
|
|
end);
|
|
end);
|
|
TThread.Queue(nil,
|
|
procedure
|
|
begin
|
|
if LDataUri = '' then
|
|
LogLine('favicon: NO RESULT for "' + LHost +
|
|
'" (TLS error? OpenSSL DLLs missing? DDG 404?)')
|
|
else
|
|
LogLine(Format('favicon: got %d bytes for "%s"',
|
|
[Length(LDataUri), LHost]));
|
|
end);
|
|
TThread.Queue(nil,
|
|
procedure
|
|
var
|
|
LEscHost, LEscData, LEscReq: string;
|
|
begin
|
|
LEscHost := StringReplace(LHost, '\', '\\', [rfReplaceAll]);
|
|
LEscHost := StringReplace(LEscHost, '"', '\"', [rfReplaceAll]);
|
|
LEscReq := StringReplace(LReqId, '\', '\\', [rfReplaceAll]);
|
|
LEscReq := StringReplace(LEscReq, '"', '\"', [rfReplaceAll]);
|
|
// The data URI is base64 (ASCII-safe) plus a small prefix —
|
|
// no embedded quotes by construction, but escape anyway.
|
|
LEscData := StringReplace(LDataUri, '\', '\\', [rfReplaceAll]);
|
|
LEscData := StringReplace(LEscData, '"', '\"', [rfReplaceAll]);
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onFaviconResult)' +
|
|
'Bridge.onFaviconResult("' + LEscReq + '","' + LEscHost + '","' +
|
|
LEscData + '")');
|
|
end);
|
|
end).Start;
|
|
end
|
|
|
|
else if ACmd = 'autostart/set' then
|
|
begin
|
|
var LOk := PM.AutoStart.SetAutoStart(GetParam('enabled') = '1');
|
|
LogLine(Format('Autostart set to %s (ok=%s)',
|
|
[GetParam('enabled'), BoolToStr(LOk, True)]));
|
|
// Echo back the resulting state so the UI re-syncs (covers the
|
|
// case where the registry write was blocked silently).
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onAutoStartStatus)' +
|
|
'Bridge.onAutoStartStatus(' +
|
|
BoolToStr(PM.AutoStart.IsAutoStartEnabled, True).ToLower + ')');
|
|
end
|
|
|
|
// ---- WebDAV remote sync (THTTPClient → WinHTTP, async) --------------
|
|
// cmd://webdav/get | put | test ?reqId=&url=&user=&pwd=[&data=]
|
|
// Callback: Bridge.onWebdavResult(reqId, status, bodyOrError)
|
|
// - GET ok → status=200, body=base64 of response bytes
|
|
// - GET 404 → status=404, body='' (caller treats as "no remote yet")
|
|
// - PUT ok → status=200/201/204, body=''
|
|
// - test → status=200..399 means reachable, body=''
|
|
// Network errors → status=0, body=exception message.
|
|
else if (ACmd = 'webdav/get') or (ACmd = 'webdav/put') or (ACmd = 'webdav/test') then
|
|
begin
|
|
var LMethod := ACmd;
|
|
var LReqId := GetParam('reqId');
|
|
var LUrl := GetParam('url');
|
|
var LUser := GetParam('user');
|
|
var LPwd := GetParam('pwd');
|
|
var LData := GetParam('data');
|
|
TThread.CreateAnonymousThread(
|
|
procedure
|
|
var
|
|
LHttp: System.Net.HttpClient.THTTPClient;
|
|
LResp: System.Net.HttpClient.IHTTPResponse;
|
|
LBodyStream: TBytesStream;
|
|
LReqStream: TBytesStream;
|
|
LBytes: TBytes;
|
|
LBodyB64: string;
|
|
LStatus: Integer;
|
|
LErr: string;
|
|
begin
|
|
LStatus := 0;
|
|
LBodyB64 := '';
|
|
LErr := '';
|
|
try
|
|
LHttp := System.Net.HttpClient.THTTPClient.Create;
|
|
try
|
|
LHttp.ConnectionTimeout := 10000;
|
|
LHttp.ResponseTimeout := 30000;
|
|
if (LUser <> '') then
|
|
begin
|
|
LHttp.CredentialsStorage.AddCredential(
|
|
System.Net.URLClient.TCredentialsStorage.TCredential.Create(
|
|
System.Net.URLClient.TAuthTargetType.Server, '', '', LUser, LPwd));
|
|
end;
|
|
if LMethod = 'webdav/get' then
|
|
begin
|
|
LBodyStream := TBytesStream.Create;
|
|
try
|
|
LResp := LHttp.Get(LUrl, LBodyStream);
|
|
LStatus := LResp.StatusCode;
|
|
if (LStatus >= 200) and (LStatus < 300) and (LBodyStream.Size > 0) then
|
|
begin
|
|
SetLength(LBytes, LBodyStream.Size);
|
|
Move(LBodyStream.Bytes[0], LBytes[0], LBodyStream.Size);
|
|
LBodyB64 := TNetEncoding.Base64.EncodeBytesToString(LBytes);
|
|
LBodyB64 := StringReplace(LBodyB64, #13, '', [rfReplaceAll]);
|
|
LBodyB64 := StringReplace(LBodyB64, #10, '', [rfReplaceAll]);
|
|
end;
|
|
finally
|
|
LBodyStream.Free;
|
|
end;
|
|
end
|
|
else if LMethod = 'webdav/put' then
|
|
begin
|
|
LBytes := TNetEncoding.Base64.DecodeStringToBytes(LData);
|
|
LReqStream := TBytesStream.Create(LBytes);
|
|
try
|
|
LResp := LHttp.Put(LUrl, LReqStream);
|
|
LStatus := LResp.StatusCode;
|
|
finally
|
|
LReqStream.Free;
|
|
end;
|
|
end
|
|
else // webdav/test — HEAD is widely supported even when PROPFIND isn't
|
|
begin
|
|
LResp := LHttp.Head(LUrl);
|
|
LStatus := LResp.StatusCode;
|
|
end;
|
|
finally
|
|
LHttp.Free;
|
|
end;
|
|
except
|
|
on E: Exception do
|
|
begin
|
|
LStatus := 0;
|
|
LErr := E.Message;
|
|
end;
|
|
end;
|
|
TThread.Queue(nil,
|
|
procedure
|
|
var
|
|
LEscReq, LEscPayload: string;
|
|
begin
|
|
LEscReq := StringReplace(LReqId, '"', '\"', [rfReplaceAll]);
|
|
// GET success path → ship body base64. Otherwise the field
|
|
// carries either the empty string or the exception message
|
|
// (for status=0 network errors).
|
|
if (LMethod = 'webdav/get') and (LStatus >= 200) and (LStatus < 300) then
|
|
LEscPayload := LBodyB64
|
|
else
|
|
LEscPayload := LErr;
|
|
LEscPayload := StringReplace(LEscPayload, '\', '\\', [rfReplaceAll]);
|
|
LEscPayload := StringReplace(LEscPayload, '"', '\"', [rfReplaceAll]);
|
|
LEscPayload := StringReplace(LEscPayload, #13, '', [rfReplaceAll]);
|
|
LEscPayload := StringReplace(LEscPayload, #10, '\n', [rfReplaceAll]);
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onWebdavResult)' +
|
|
'Bridge.onWebdavResult("' + LEscReq + '",' +
|
|
IntToStr(LStatus) + ',"' + LEscPayload + '")');
|
|
LogLine(Format('%s %s → %d (%d bytes payload)',
|
|
[LMethod, LUrl, LStatus, Length(LEscPayload)]));
|
|
end);
|
|
end).Start;
|
|
end
|
|
|
|
// ---- Native file save (bypasses WebView2's browser download UI) ------
|
|
// JS sends: cmd://file/save?name=<filename>&data=<base64>&reqId=<id>
|
|
// Delphi opens GetSaveFileName, writes the decoded bytes, then calls
|
|
// Bridge.onFileSaveResult(reqId, ok, path). All synchronous on the UI
|
|
// thread — payloads are small (a vault JSON export is well under 1 MB).
|
|
else if ACmd = 'file/save' then
|
|
begin
|
|
var LName := GetParam('name');
|
|
var LData := GetParam('data');
|
|
var LReqId := GetParam('reqId');
|
|
var LOk := False;
|
|
var LPath := '';
|
|
var LErr := '';
|
|
try
|
|
var LBytes := TNetEncoding.Base64.DecodeStringToBytes(LData);
|
|
var LDlg := TSaveDialog.Create(nil);
|
|
try
|
|
LDlg.FileName := LName;
|
|
var LExt := ExtractFileExt(LName);
|
|
if LExt = '.json' then LDlg.Filter := 'JSON file (*.json)|*.json|All files (*.*)|*.*'
|
|
else if LExt = '.csv' then LDlg.Filter := 'CSV file (*.csv)|*.csv|All files (*.*)|*.*'
|
|
else LDlg.Filter := 'All files (*.*)|*.*';
|
|
LDlg.DefaultExt := LExt.TrimLeft(['.']);
|
|
LDlg.Options := LDlg.Options + [TOpenOption.ofOverwritePrompt];
|
|
if LDlg.Execute then
|
|
begin
|
|
LPath := LDlg.FileName;
|
|
var LStream := TFileStream.Create(LPath, fmCreate);
|
|
try
|
|
if Length(LBytes) > 0 then
|
|
LStream.WriteBuffer(LBytes[0], Length(LBytes));
|
|
finally
|
|
LStream.Free;
|
|
end;
|
|
LOk := True;
|
|
LogLine(Format('File saved: %s (%d bytes)', [LPath, Length(LBytes)]));
|
|
end
|
|
else
|
|
LogLine('File save cancelled by user');
|
|
finally
|
|
LDlg.Free;
|
|
end;
|
|
except
|
|
on E: Exception do
|
|
begin
|
|
LErr := E.Message;
|
|
LogLine('File save FAILED: ' + LErr);
|
|
end;
|
|
end;
|
|
var LEscReq := StringReplace(LReqId, '"', '\"', [rfReplaceAll]);
|
|
var LEscPath := StringReplace(LPath, '\', '\\', [rfReplaceAll]);
|
|
LEscPath := StringReplace(LEscPath, '"', '\"', [rfReplaceAll]);
|
|
var LEscErr := StringReplace(LErr, '\', '\\', [rfReplaceAll]);
|
|
LEscErr := StringReplace(LEscErr, '"', '\"', [rfReplaceAll]);
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onFileSaveResult)' +
|
|
'Bridge.onFileSaveResult("' + LEscReq + '",' +
|
|
BoolToStr(LOk, True).ToLower + ',"' + LEscPath + '","' + LEscErr + '")');
|
|
end
|
|
|
|
// ---- Auto-backup: folder picker (modal Win32 dialog) -----------------
|
|
// cmd://folder/pick?reqId=<id>
|
|
// Callback: Bridge.onFolderPickResult(reqId, path) (path = '' on cancel)
|
|
else if ACmd = 'folder/pick' then
|
|
begin
|
|
var LReqId := GetParam('reqId');
|
|
var LDir := '';
|
|
SelectDirectory('Choose backup folder', '', LDir);
|
|
var LEscReq := StringReplace(LReqId, '"', '\"', [rfReplaceAll]);
|
|
var LEscDir := StringReplace(LDir, '\', '\\', [rfReplaceAll]);
|
|
LEscDir := StringReplace(LEscDir, '"', '\"', [rfReplaceAll]);
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onFolderPickResult)' +
|
|
'Bridge.onFolderPickResult("' + LEscReq + '","' + LEscDir + '")');
|
|
if LDir <> '' then LogLine('Folder picked: ' + LDir);
|
|
end
|
|
|
|
// ---- Auto-backup: silent file write (no dialog) ----------------------
|
|
// cmd://file/write?path=<full>&data=<base64>&reqId=<id>
|
|
// Callback: Bridge.onFileWriteResult(reqId, ok, error)
|
|
else if ACmd = 'file/write' then
|
|
begin
|
|
var LPath := GetParam('path');
|
|
var LData := GetParam('data');
|
|
var LReqId := GetParam('reqId');
|
|
var LOk := False;
|
|
var LErr := '';
|
|
try
|
|
var LBytes := TNetEncoding.Base64.DecodeStringToBytes(LData);
|
|
var LStream := TFileStream.Create(LPath, fmCreate);
|
|
try
|
|
if Length(LBytes) > 0 then
|
|
LStream.WriteBuffer(LBytes[0], Length(LBytes));
|
|
finally
|
|
LStream.Free;
|
|
end;
|
|
LOk := True;
|
|
LogLine(Format('File written: %s (%d bytes)', [LPath, Length(LBytes)]));
|
|
except
|
|
on E: Exception do
|
|
begin
|
|
LErr := E.Message;
|
|
LogLine('File write FAILED for "' + LPath + '": ' + LErr);
|
|
end;
|
|
end;
|
|
var LEscReq := StringReplace(LReqId, '"', '\"', [rfReplaceAll]);
|
|
var LEscErr := StringReplace(LErr, '\', '\\', [rfReplaceAll]);
|
|
LEscErr := StringReplace(LEscErr, '"', '\"', [rfReplaceAll]);
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onFileWriteResult)' +
|
|
'Bridge.onFileWriteResult("' + LEscReq + '",' +
|
|
BoolToStr(LOk, True).ToLower + ',"' + LEscErr + '")');
|
|
end
|
|
|
|
// ---- Auto-backup: list files in dir matching name prefix --------------
|
|
// cmd://file/listMatch?dir=<full>&prefix=<str>&reqId=<id>
|
|
// Callback: Bridge.onFileListResult(reqId, jsonArr)
|
|
// Each item: {name, size, mtime} (mtime = ISO).
|
|
else if ACmd = 'file/listMatch' then
|
|
begin
|
|
var LDir := GetParam('dir');
|
|
var LPrefix := GetParam('prefix');
|
|
var LReqId := GetParam('reqId');
|
|
var LArr := TJSONArray.Create;
|
|
try
|
|
if (LDir <> '') and TDirectory.Exists(LDir) then
|
|
begin
|
|
var LFiles := TDirectory.GetFiles(LDir, LPrefix + '*');
|
|
for var F in LFiles do
|
|
begin
|
|
var LObj := TJSONObject.Create;
|
|
LObj.AddPair('name', ExtractFileName(F));
|
|
LObj.AddPair('size', TJSONNumber.Create(TFile.GetSize(F)));
|
|
LObj.AddPair('mtime',
|
|
FormatDateTime('yyyy-mm-dd"T"hh:nn:ss', TFile.GetLastWriteTime(F)));
|
|
LArr.Add(LObj);
|
|
end;
|
|
end;
|
|
var LJSON := LArr.ToString;
|
|
var LEscReq := StringReplace(LReqId, '"', '\"', [rfReplaceAll]);
|
|
var LEscJson := StringReplace(LJSON, '\', '\\', [rfReplaceAll]);
|
|
LEscJson := StringReplace(LEscJson, '"', '\"', [rfReplaceAll]);
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onFileListResult)' +
|
|
'Bridge.onFileListResult("' + LEscReq + '","' + LEscJson + '")');
|
|
finally
|
|
LArr.Free;
|
|
end;
|
|
end
|
|
|
|
// ---- Auto-backup: delete a single file (for retention pruning) -------
|
|
// cmd://file/delete?path=<full>&reqId=<id>
|
|
// Callback: Bridge.onFileDeleteResult(reqId, ok)
|
|
else if ACmd = 'file/delete' then
|
|
begin
|
|
var LPath := GetParam('path');
|
|
var LReqId := GetParam('reqId');
|
|
var LOk := False;
|
|
try
|
|
if TFile.Exists(LPath) then
|
|
begin
|
|
TFile.Delete(LPath);
|
|
LOk := True;
|
|
LogLine('File deleted: ' + LPath);
|
|
end;
|
|
except
|
|
on E: Exception do
|
|
LogLine('File delete FAILED for "' + LPath + '": ' + E.Message);
|
|
end;
|
|
var LEscReq := StringReplace(LReqId, '"', '\"', [rfReplaceAll]);
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&Bridge.onFileDeleteResult)' +
|
|
'Bridge.onFileDeleteResult("' + LEscReq + '",' +
|
|
BoolToStr(LOk, True).ToLower + ')');
|
|
end
|
|
|
|
else
|
|
LogLine('Bridge: unknown command "' + ACmd + '"');
|
|
end;
|
|
|
|
procedure TMainForm.BridgeSystemLock;
|
|
begin
|
|
// Windows session locked or system suspending — delegate to Bridge.onSystemLock
|
|
// in JS which honours the "quick unlock" opt-out (DPAPI already gates
|
|
// access via the Windows account, so re-locking on top of Windows lock
|
|
// is redundant for users who enabled it).
|
|
LogLine('Windows session locked / suspend — notifying JS');
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&typeof Bridge.onSystemLock==="function")Bridge.onSystemLock();' +
|
|
'else 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;
|
|
|
|
procedure TMainForm.AutofillTimerTick(Sender: TObject);
|
|
var
|
|
TargetHwnd: HWND;
|
|
PendingUser, PendingPass: string;
|
|
HideAfter: Boolean;
|
|
ForegroundAfter: HWND;
|
|
begin
|
|
TargetHwnd := FAutofillPendingHWND;
|
|
PendingUser := FAutofillPendingUser;
|
|
PendingPass := FAutofillPendingPass;
|
|
HideAfter := FAutofillPendingHide;
|
|
FAutofillPendingHWND := 0;
|
|
FAutofillPendingUser := '';
|
|
FAutofillPendingPass := '';
|
|
FAutofillPendingHide := False;
|
|
|
|
TTimer(Sender).Enabled := False;
|
|
TTimer(Sender).Free;
|
|
|
|
FBridge.ExecuteAutofill(TargetHwnd, PendingUser, PendingPass);
|
|
ForegroundAfter := GetForegroundWindow;
|
|
LogLine(Format('Autofill executed — target=%s, foreground_after=%s, match=%s',
|
|
[IntToHex(TargetHwnd, 8), IntToHex(ForegroundAfter, 8),
|
|
BoolToStr(ForegroundAfter = TargetHwnd, True)]));
|
|
|
|
// Hide-after (Ctrl+Shift+Q from tray): SendInput is done, the target
|
|
// already has focus — now we can safely tray ourselves without
|
|
// confusing the Win10/11 foreground-stealing watchdog.
|
|
if HideAfter then
|
|
begin
|
|
FBridge.MinimizeToTray;
|
|
LogLine('Hidden back to tray (post-autofill).');
|
|
end;
|
|
end;
|
|
|
|
procedure TMainForm.BridgeAutofillRequest(AKind: TAutofillKind;
|
|
ATargetHWND: HWND; const ATitle: string);
|
|
var
|
|
LTitle, LKind: string;
|
|
begin
|
|
if not FServer.Active then Exit;
|
|
FAutofillTargetHWND := ATargetHWND;
|
|
|
|
// Escape the title for safe injection into a JS string literal.
|
|
LTitle := ATitle;
|
|
LTitle := LTitle.Replace('\', '\\');
|
|
LTitle := LTitle.Replace('"', '\"');
|
|
|
|
if AKind = akPasswordOnly then LKind := 'password' else LKind := 'full';
|
|
|
|
WebBrowser.ExecuteJavaScript(
|
|
'if(window.Bridge&&typeof Bridge.onAutofillRequest==="function")' +
|
|
'Bridge.onAutofillRequest("' + LTitle + '","' + LKind + '")');
|
|
LogLine('Autofill hotkey (' + LKind + ') — foreground: "' + ATitle + '"');
|
|
end;
|
|
|
|
initialization
|
|
// WebView2 ships with a long list of "phone home" behaviours enabled by
|
|
// default (SmartScreen lookups, component updates, sync, UMA telemetry,
|
|
// domain reliability beacons, optimisation hints, etc.). For a vault
|
|
// that's meant to be 100% offline we disable them by passing flags
|
|
// through WEBVIEW2_ADDITIONAL_BROWSER_ARGUMENTS — the standard way to
|
|
// configure the embedded Chromium without touching system policy.
|
|
//
|
|
// Must be set BEFORE the TMS FNC WebBrowser instantiates its
|
|
// CoreWebView2Environment, hence the unit initialization block.
|
|
SetEnvironmentVariable('WEBVIEW2_ADDITIONAL_BROWSER_ARGUMENTS',
|
|
'--disable-background-networking ' +
|
|
'--disable-sync ' +
|
|
'--disable-component-update ' +
|
|
'--no-default-browser-check ' +
|
|
'--no-pings ' +
|
|
'--disable-client-side-phishing-detection ' +
|
|
'--disable-domain-reliability ' +
|
|
'--disable-breakpad ' +
|
|
'--disable-crash-reporter ' +
|
|
'--no-experiments ' +
|
|
'--metrics-recording-only ' +
|
|
'--disable-features=MediaRouter,OptimizationHints,InterestFeedContentSuggestions,' +
|
|
'CalculateNativeWinOcclusion,HardwareMediaKeyHandling,Translate,' +
|
|
'NetworkServiceInProcess,BackgroundFetch,SafeBrowsingEnhancedProtection,' +
|
|
'AutofillServerCommunication,PrivacySandboxAdsAPIsOverride'
|
|
);
|
|
|
|
end.
|