unit UMainForm; interface uses System.SysUtils, System.Classes, System.UITypes, System.NetEncoding, System.StrUtils, Winapi.Windows, 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, PM.HTTPServer, PM.Bridge, PM.QuickUnlock, PM.UserPrefs; 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; 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; 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 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 WebBrowserInitialized(Sender: TObject); 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; FBridge.OnAutofillRequest := BridgeAutofillRequest; FBridge.OnDebugHotkey := BridgeDebugHotkey; FBridge.OnNewEntryHotkey := BridgeNewEntryHotkey; FBridge.RegisterAutofillHotkey; // Ctrl+Shift+L active from startup FBridge.ApplyTitleBarTheme(True); // dark by default, JS may toggle later FAutofillTargetHWND := 0; WebBrowser.OnBeforeNavigate := WebBrowserBeforeNavigate; WebBrowser.OnInitialized := WebBrowserInitialized; // 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.'); 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); end; procedure TMainForm.FormDestroy(Sender: TObject); begin FBridge.Free; FServer.Free; end; procedure TMainForm.WebBrowserInitialized(Sender: TObject); begin WebBrowser.EnableContextMenu := False; WebBrowser.EnableShowDebugConsole := False; 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; // 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)); FNavTimer.Enabled := False; FNavTimer.Enabled := True; end; procedure TMainForm.NavTimerTick(Sender: TObject); begin FNavTimer.Enabled := False; if FPendingURL = '' then Exit; LogLine('Navigating to: ' + MaskAccessToken(FPendingURL)); WebBrowser.Navigate(FPendingURL); FPendingURL := ''; end; procedure TMainForm.btnStartClick(Sender: TObject); var LPort: Integer; begin 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.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; 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 // ---- 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 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; 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 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') // ---- 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 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; ForegroundAfter: HWND; begin TargetHwnd := FAutofillPendingHWND; PendingUser := FAutofillPendingUser; PendingPass := FAutofillPendingPass; FAutofillPendingHWND := 0; FAutofillPendingUser := ''; FAutofillPendingPass := ''; 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)])); 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; end.