Zaki/Password-Manager
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat: MFA tools, single-instance, tray polish, prefs persistence

Browse Source 
Session highlights:

- feat(prefs): DPAPI-backed key/value store (PM.UserPrefs) — fixes
  rememberedUsername being lost across reboots due to the random
  ephemeral HTTP port changing the localStorage origin every launch.
  Bridge cmd://prefs/{get,set} round-trips through Delphi.

- feat(tray): icon visible from startup (NIM_ADD at constructor, not
  at first minimize). Tray context menu themed via uxtheme!135
  SetPreferredAppMode so it follows the app's dark/light setting.

- feat(single-instance): named mutex + RegisterWindowMessage broadcast.
  Second launch posts WM_PMSHOW to HWND_BROADCAST and exits; the
  running bridge restores the window from tray. Mutex lives in Local\
  namespace so distinct Windows users can still each run one.

- feat(mfa): Authenticator sidebar view (live TOTP codes for every
  entry with a secret) + standalone TOTP generator modal (paste
  base32 / otpauth:// URI, or generate a random 20-byte secret).

- feat(sidebar): Folders / Tags / Tools sections collapsible with
  chevron toggle. Badge counts stay visible when collapsed. State
  persisted in settings_json (synced across devices).

- feat(autofill): hotkey when vault is locked now restores the app
  and focuses the master password input instead of no-op'ing
  silently. Cleaner UX for the common "I hit Ctrl+Shift+L but the
  vault was locked" path.

- feat(quick-unlock): when enabled, skip lockVault on Windows lock /
  sleep. Rationale: the DPAPI blob already gates access via the
  Windows account, so re-locking on top of the OS lock is redundant.
  Idle auto-lock still fires (separate opt-in).

- fix(quick-unlock): re-sync state.quickUnlockEnabled from DPAPI
  source-of-truth at boot, instead of trusting (now-volatile)
  localStorage.

- docs: CLAUDE.md updated with all new modules, bridge commands,
  and the port-ephemeral pitfall.

Co-Authored-By: Claude Opus 4.7 <noreply@anthropic.com>
This commit is contained in:
Zaki
2026-06-08 21:31:39 +01:00
parent 664db65437
commit 40b3154a34
38 changed files with 8165 additions and 548 deletions
Download Patch File Download Diff File Expand all files Collapse all files
delphi-backend/Source/PM.Bridge.pas
+519 -14
View File
@@ -31,7 +31,8 @@ interface
uses
System.SysUtils, System.Classes, System.Math,
FMX.Types, FMX.Forms,
Winapi.Windows, Winapi.ShellAPI, Winapi.Messages;
Winapi.Windows, Winapi.ShellAPI, Winapi.Messages,
PM.SingleInstance;
type
// -------------------------------------------------------------------------
@@ -44,12 +45,29 @@ type
public
constructor Create;
destructor Destroy; override;
function ReadText: string;
// Copy AText to the clipboard, excluding it from Win+V history.
// AClearAfterMs = 0 disables auto-clear; default is 30 seconds.
procedure SetText(const AText: string; AClearAfterMs: Integer = 30000);
procedure Clear;
end;
// Distinguishes the "fill everything" hotkey (Ctrl+Shift+L) from the
// "password only" hotkey (Ctrl+Shift+P). The host decides what to type
// based on this kind.
TAutofillKind = (akFull, akPasswordOnly);
// Fired when an autofill hotkey is pressed. Args are the foreground
// window HWND and its title (captured before any focus change), plus
// the kind of fill requested.
// Declared as a method pointer (not TProc<>) because Delphi has no implicit
// conversion from "procedure of object" to "reference to procedure" — the
// host wires this with a regular form method (BridgeAutofillRequest).
TAutofillRequestEvent = procedure(AKind: TAutofillKind;
ATargetHWND: HWND; const ATitle: string) of object;
TNewEntryHotkeyEvent = procedure(const AWindowTitle: string) of object;
// -------------------------------------------------------------------------
// TPMBridge
// -------------------------------------------------------------------------
@@ -64,10 +82,28 @@ type
FPowerNotify: THandle; // registration handle from PowerRegisterSuspendResumeNotification
FSecureClipboard: TSecureClipboard;
FBalloonShown: Boolean;
// Window placement captured at MinimizeToTray time. Replayed on
// RestoreFromTray so the window comes back in the same state
// (maximised / normal + position + size) as before hiding.
FSavedPlacement: TWindowPlacement;
FHasSavedPlacement: Boolean;
FOnSystemLock: TProc;
FOnTrayRestore: TProc;
FOnLockRequest: TProc;
FOnQuit: TProc;
// Autofill: global hotkeys → inject credentials into browser. Combos
// are user-configurable from Settings; defaults are Ctrl+Shift+L /
// Ctrl+Shift+P. We track which IDs are actually live so unregister
// doesn't blindly call UnregisterHotKey on unregistered IDs (which
// would set GetLastError noise during shutdown).
FAutofillRegistered: Boolean;
FAutofillFullActive: Boolean;
FAutofillPwdActive: Boolean;
FOnAutofillRequest: TAutofillRequestEvent;
FDebugHotkeyRegistered: Boolean;
FOnDebugHotkey: TProc;
FNewEntryHotkeyRegistered: Boolean;
FOnNewEntryHotkey: TNewEntryHotkeyEvent;
procedure MsgWindowHandler(var AMsg: TMessage);
procedure PrepareNid;
procedure ShowTrayMenu;
@@ -80,8 +116,35 @@ type
procedure MinimizeToTray;
// Restore main window and remove tray icon.
procedure RestoreFromTray;
// Apply Windows dark-mode title bar to the main form. Win10 19044+
// / Win11 only — no-op on older builds. Safe to call repeatedly.
procedure ApplyTitleBarTheme(ADark: Boolean);
// Register the two autofill global hotkeys (full + password-only) with
// the given Win32 modifier flags (MOD_CONTROL/MOD_SHIFT/MOD_ALT/MOD_WIN
// bitmask) and virtual-key codes. Replaces any prior registration —
// safe to call repeatedly to swap combos at runtime.
// Returns True if both hotkeys registered successfully. If one or both
// failed (clash with another app), best-effort: whichever succeeded
// stays active.
function SetAutofillHotkeys(AFullMods, AFullVk,
APwdMods, APwdVk: Word): Boolean;
// Convenience wrapper: register the historical defaults (Ctrl+Shift+L
// and Ctrl+Shift+P). Used by the host on first start; runtime changes
// go through SetAutofillHotkeys.
procedure RegisterAutofillHotkey;
// Unregister both autofill hotkeys.
procedure UnregisterAutofillHotkey;
// Simulate username + Tab + password keystrokes into ATargetHWND.
// ATargetHWND = 0 → type into whatever window has focus.
// If AUsername is empty, only the password is typed (no Tab) — matches
// the password-only hotkey path AND avoids spurious Tab on entries
// without a stored username.
procedure ExecuteAutofill(ATargetHWND: HWND;
const AUsername, APassword: string);
property SecureClipboard: TSecureClipboard read FSecureClipboard;
property TrayAdded: Boolean read FTrayAdded;
property AutofillRegistered: Boolean read FAutofillRegistered;
// Fired on main thread when Windows locks the session (WTS_SESSION_LOCK).
property OnSystemLock: TProc read FOnSystemLock write FOnSystemLock;
// Fired on main thread when the user clicks the tray icon.
@@ -94,6 +157,17 @@ type
// bridge does not call it itself, so the host stays in control of
// shutdown order (server stop, save state, etc.).
property OnQuit: TProc read FOnQuit write FOnQuit;
// Fired on main thread when the autofill hotkey fires.
// Args: (ATargetHWND, AWindowTitle). Handler calls ExecuteJavaScript
// to let JS match the title against vault entries.
property OnAutofillRequest: TAutofillRequestEvent
read FOnAutofillRequest write FOnAutofillRequest;
property OnDebugHotkey: TProc
read FOnDebugHotkey write FOnDebugHotkey;
// Fires on Ctrl+Shift+A. Arg = foreground window title (stripped of
// browser suffix by the JS layer before pre-fill).
property OnNewEntryHotkey: TNewEntryHotkeyEvent
read FOnNewEntryHotkey write FOnNewEntryHotkey;
end;
implementation
@@ -130,6 +204,17 @@ const
PBT_APMRESUMEAUTOMATIC = $0012;
PBT_APMRESUMESUSPEND = $0007;
// Autofill hotkeys — Ctrl+Shift+L (full) and Ctrl+Shift+P (password only).
// IDs must not clash with other RegisterHotKey calls in this process;
// 42-43 are arbitrary and well outside the range used by FMX internals.
const
AUTOFILL_HOTKEY_ID_FULL = 42; // Ctrl+Shift+L → user + Tab + password
AUTOFILL_HOTKEY_ID_PWDONLY = 43; // Ctrl+Shift+P → password only
DEBUG_HOTKEY_ID = 44; // Ctrl+Shift+D → toggle debug panel
NEW_ENTRY_HOTKEY_ID = 45; // Ctrl+Shift+A → quick-add from window title
AF_MOD_CONTROL = $0002; // same value as MOD_CONTROL
AF_MOD_SHIFT = $0004; // same value as MOD_SHIFT
// Dynamic WTS function pointers — wtsapi32.dll is not guaranteed on all
// Windows SKUs (e.g. minimal Server Core without Session Services), so
// we load it at runtime and tolerate absence gracefully.
@@ -256,6 +341,28 @@ begin
end;
end;
function TSecureClipboard.ReadText: string;
var
H: THandle;
P: PChar;
begin
Result := '';
if not OpenClipboard(0) then Exit;
try
H := GetClipboardData(CF_UNICODETEXT);
if H = 0 then Exit;
P := PChar(GlobalLock(H));
if P <> nil then
try
Result := P;
finally
GlobalUnlock(H);
end;
finally
CloseClipboard;
end;
end;
// =============================================================================
// TPMBridge
// =============================================================================
@@ -273,6 +380,14 @@ begin
PrepareNid;
// Add the tray icon eagerly so it's visible from app startup, regardless
// of whether the window is shown or hidden. Without this, the tray icon
// only appears the first time the user minimizes — meaning fresh-launch
// users can't lock/quit from the tray and discover the feature only by
// accident. NIM_DELETE is now only called at shutdown.
if Shell_NotifyIcon(NIM_ADD, @FNid) then
FTrayAdded := True;
// Session-lock detection (fails silently if wtsapi32.dll is absent).
LoadWtsApi;
if Assigned(_WTSRegister) then
@@ -286,10 +401,21 @@ begin
LoadPowerApi;
if Assigned(_PowerRegister) then
_PowerRegister(DEVICE_NOTIFY_WINDOW_HANDLE, FMsgWindow, FPowerNotify);
FDebugHotkeyRegistered := RegisterHotKey(FMsgWindow, DEBUG_HOTKEY_ID,
AF_MOD_CONTROL or AF_MOD_SHIFT, Ord('D'));
FNewEntryHotkeyRegistered := RegisterHotKey(FMsgWindow, NEW_ENTRY_HOTKEY_ID,
AF_MOD_CONTROL or AF_MOD_SHIFT, Ord('A'));
end;
destructor TPMBridge.Destroy;
begin
if FDebugHotkeyRegistered then
UnregisterHotKey(FMsgWindow, DEBUG_HOTKEY_ID);
if FNewEntryHotkeyRegistered then
UnregisterHotKey(FMsgWindow, NEW_ENTRY_HOTKEY_ID);
if (FPowerNotify <> 0) and Assigned(_PowerUnregister) then
_PowerUnregister(FPowerNotify);
@@ -379,11 +505,8 @@ procedure TPMBridge.MinimizeToTray;
var
LFormHwnd, LAppHwnd: HWND;
begin
if not FTrayAdded then
begin
if Shell_NotifyIcon(NIM_ADD, @FNid) then
FTrayAdded := True;
end;
// Tray icon is added at construction time and persists for the app's
// lifetime — no NIM_ADD here.
// Extra safety: clear the clipboard immediately when the user minimizes,
// rather than waiting for the 30s auto-clear timer to fire. A password
@@ -394,6 +517,15 @@ begin
LFormHwnd := MainFormHWND(FMainForm);
LAppHwnd := FindFMXAppWindow;
// 0. Snapshot the window placement BEFORE hiding so RestoreFromTray can
// replay the exact same state (maximised / normal + size + position).
// Without this, ShowWindow(SW_RESTORE) below always returns to the
// "normal" state — a window that was maximised before hiding comes
// back un-maximised.
FillChar(FSavedPlacement, SizeOf(FSavedPlacement), 0);
FSavedPlacement.length := SizeOf(FSavedPlacement);
FHasSavedPlacement := GetWindowPlacement(LFormHwnd, @FSavedPlacement);
// 1. Hide the visible form via both FMX state and Win32 ShowWindow.
// Keeps the form invisible to the user.
FMainForm.Hide;
@@ -442,12 +574,7 @@ procedure TPMBridge.RestoreFromTray;
var
LFormHwnd, LAppHwnd: HWND;
begin
if FTrayAdded then
begin
Shell_NotifyIcon(NIM_DELETE, @FNid);
FTrayAdded := False;
end;
// Tray icon stays in the tray — we only show the window again.
LFormHwnd := MainFormHWND(FMainForm);
LAppHwnd := FindFMXAppWindow;
@@ -457,8 +584,23 @@ begin
ShowWindow(LAppHwnd, SW_SHOW);
FMainForm.Show;
ShowWindow(LFormHwnd, SW_SHOW);
ShowWindow(LFormHwnd, SW_RESTORE);
// Restore to the exact pre-tray state (maximised/normal + size + pos).
// Falls back to SW_RESTORE if we never captured a placement (e.g. tray
// restore was triggered without a prior MinimizeToTray call).
if FHasSavedPlacement then
begin
// showCmd governs whether the window comes back maximised or normal;
// it's what SW_RESTORE clobbers. We force it ourselves.
if FSavedPlacement.showCmd = SW_SHOWMINIMIZED then
FSavedPlacement.showCmd := SW_SHOWNORMAL; // never restore as minimised
SetWindowPlacement(LFormHwnd, @FSavedPlacement);
end
else
begin
ShowWindow(LFormHwnd, SW_SHOW);
ShowWindow(LFormHwnd, SW_RESTORE);
end;
SetForegroundWindow(LFormHwnd);
end;
@@ -543,9 +685,372 @@ begin
// suspends — fast handler required (no UI prompts, no network).
if AMsg.WParam = PBT_APMSUSPEND then
if Assigned(FOnSystemLock) then FOnSystemLock();
end
else if (AMsg.Msg <> 0) and (AMsg.Msg = WM_PMShowMessage) then
begin
// A second instance was launched and PostMessage'd HWND_BROADCAST.
// Bring our window back to the front instead of letting that second
// process spawn its own UI.
if Assigned(FOnTrayRestore) then FOnTrayRestore();
end
else if (AMsg.Msg = WM_HOTKEY) and (AMsg.WParam = DEBUG_HOTKEY_ID) then
begin
if Assigned(FOnDebugHotkey) then FOnDebugHotkey();
end
else if (AMsg.Msg = WM_HOTKEY) and (AMsg.WParam = NEW_ENTRY_HOTKEY_ID) then
begin
if Assigned(FOnNewEntryHotkey) then
begin
var LTarget := GetForegroundWindow;
var LTitle: string;
SetLength(LTitle, 512);
var LLen := GetWindowTextW(LTarget, PChar(LTitle), 512);
SetLength(LTitle, LLen);
FOnNewEntryHotkey(LTitle);
end;
end
else if (AMsg.Msg = WM_HOTKEY) and Assigned(FOnAutofillRequest) and
((AMsg.WParam = AUTOFILL_HOTKEY_ID_FULL) or
(AMsg.WParam = AUTOFILL_HOTKEY_ID_PWDONLY)) then
begin
// Capture the foreground window BEFORE any focus change, then fire the
// callback so the host can match the title against vault entries.
var LKind: TAutofillKind;
if AMsg.WParam = AUTOFILL_HOTKEY_ID_PWDONLY then
LKind := akPasswordOnly
else
LKind := akFull;
var LTarget := GetForegroundWindow;
var LTitle: string;
SetLength(LTitle, 512);
var LLen := GetWindowTextW(LTarget, PChar(LTitle), 512);
SetLength(LTitle, LLen);
FOnAutofillRequest(LKind, LTarget, LTitle);
end;
AMsg.Result := DefWindowProc(FMsgWindow, AMsg.Msg, AMsg.WParam, AMsg.LParam);
end;
// =============================================================================
// TPMBridge — Autofill hotkey + SendInput
// =============================================================================
function TPMBridge.SetAutofillHotkeys(AFullMods, AFullVk,
APwdMods, APwdVk: Word): Boolean;
begin
// Tear down whatever is currently registered before installing the new
// combos. RegisterHotKey would fail if the same ID is already taken.
if FAutofillFullActive then
begin
UnregisterHotKey(FMsgWindow, AUTOFILL_HOTKEY_ID_FULL);
FAutofillFullActive := False;
end;
if FAutofillPwdActive then
begin
UnregisterHotKey(FMsgWindow, AUTOFILL_HOTKEY_ID_PWDONLY);
FAutofillPwdActive := False;
end;
// Best-effort registration. A failure (typically MOD_x clash with another
// app's global hotkey) is silent: the other slot can still be live.
if (AFullVk <> 0) and (AFullMods <> 0) then
FAutofillFullActive := RegisterHotKey(FMsgWindow,
AUTOFILL_HOTKEY_ID_FULL, AFullMods, AFullVk);
if (APwdVk <> 0) and (APwdMods <> 0) then
FAutofillPwdActive := RegisterHotKey(FMsgWindow,
AUTOFILL_HOTKEY_ID_PWDONLY, APwdMods, APwdVk);
FAutofillRegistered := FAutofillFullActive or FAutofillPwdActive;
Result := FAutofillFullActive and FAutofillPwdActive;
end;
procedure TPMBridge.ApplyTitleBarTheme(ADark: Boolean);
const
DWMWA_USE_IMMERSIVE_DARK_MODE = 20;
// uxtheme.dll private API, stable since Win10 1809. File Explorer, Edge
// and Office use this to opt their UI (including popup menus, scrollbars,
// tooltips) into dark mode. Signature changed in 1903 to take an enum:
// 0=Default 1=AllowDark 2=ForceDark 3=ForceLight 4=Max
// We use ForceDark / ForceLight for unambiguous behaviour.
APPMODE_DEFAULT = 0;
APPMODE_FORCE_DARK = 2;
APPMODE_FORCE_LIGHT = 3;
type
TDwmSetWindowAttribute = function(hwnd: HWND; dwAttribute: DWORD;
pvAttribute: Pointer; cbAttribute: DWORD): HRESULT; stdcall;
TSetPreferredAppMode = function(AppMode: Integer): Integer; stdcall;
TFlushMenuThemes = procedure; stdcall;
var
DwmLib, UxLib: HMODULE;
DwmSetWindowAttribute: TDwmSetWindowAttribute;
SetPreferredAppMode: TSetPreferredAppMode;
FlushMenuThemes: TFlushMenuThemes;
DarkFlag: BOOL;
FormHwnd: HWND;
begin
if FMainForm = nil then Exit;
FormHwnd := MainFormHWND(FMainForm);
if FormHwnd = 0 then Exit;
// 1. Title bar (DWM immersive dark mode).
DwmLib := LoadLibrary('dwmapi.dll');
if DwmLib <> 0 then
try
@DwmSetWindowAttribute := GetProcAddress(DwmLib, 'DwmSetWindowAttribute');
if Assigned(DwmSetWindowAttribute) then
begin
DarkFlag := ADark;
DwmSetWindowAttribute(FormHwnd, DWMWA_USE_IMMERSIVE_DARK_MODE,
@DarkFlag, SizeOf(DarkFlag));
end;
finally
FreeLibrary(DwmLib);
end;
// 2. App-wide preferred mode (themes popup menus, scrollbars, tooltips).
// Loaded by ordinal because the functions are not exported by name.
UxLib := LoadLibrary('uxtheme.dll');
if UxLib <> 0 then
try
@SetPreferredAppMode := GetProcAddress(UxLib, MAKEINTRESOURCE(135));
@FlushMenuThemes := GetProcAddress(UxLib, MAKEINTRESOURCE(136));
if Assigned(SetPreferredAppMode) then
begin
if ADark then SetPreferredAppMode(APPMODE_FORCE_DARK)
else SetPreferredAppMode(APPMODE_FORCE_LIGHT);
if Assigned(FlushMenuThemes) then FlushMenuThemes;
end;
finally
FreeLibrary(UxLib);
end;
end;
procedure TPMBridge.RegisterAutofillHotkey;
begin
// Convenience default — Ctrl+Shift+L (full) + Ctrl+Shift+P (password).
// Idempotent: calling twice with the same combos is harmless.
SetAutofillHotkeys(AF_MOD_CONTROL or AF_MOD_SHIFT, Ord('L'),
AF_MOD_CONTROL or AF_MOD_SHIFT, Ord('P'));
end;
procedure TPMBridge.UnregisterAutofillHotkey;
begin
if FAutofillFullActive then
begin
UnregisterHotKey(FMsgWindow, AUTOFILL_HOTKEY_ID_FULL);
FAutofillFullActive := False;
end;
if FAutofillPwdActive then
begin
UnregisterHotKey(FMsgWindow, AUTOFILL_HOTKEY_ID_PWDONLY);
FAutofillPwdActive := False;
end;
FAutofillRegistered := False;
end;
// Block until the user releases Ctrl, Shift, Alt, and Win, or until ATimeoutMs
// elapses. Without this, an autofill triggered by Ctrl+Shift+L injects
// keystrokes WHILE Ctrl+Shift are physically held — turning our Tab into
// Ctrl+Tab (next tab in Chrome), our 's' into Ctrl+S, etc. 1000 ms is a
// generous bound; typical release happens within 50-150 ms.
procedure WaitForModifierRelease(ATimeoutMs: Cardinal);
var
LStart: Cardinal;
begin
LStart := GetTickCount;
while ((GetAsyncKeyState(VK_CONTROL) and $8000) <> 0)
or ((GetAsyncKeyState(VK_SHIFT) and $8000) <> 0)
or ((GetAsyncKeyState(VK_MENU) and $8000) <> 0) // Alt
or ((GetAsyncKeyState(VK_LWIN) and $8000) <> 0)
or ((GetAsyncKeyState(VK_RWIN) and $8000) <> 0) do
begin
Sleep(15);
if GetTickCount - LStart > ATimeoutMs then Break;
end;
end;
// Build (and immediately send) a key-down+up pair for each char in AText
// using KEYEVENTF_UNICODE. Returns nothing — best-effort.
procedure SendUnicodeString(const AText: string);
var
LInputs: TArray<TInput>;
LCount, I: Integer;
begin
if AText = '' then Exit;
SetLength(LInputs, Length(AText) * 2);
LCount := 0;
for I := 1 to Length(AText) do
begin
FillChar(LInputs[LCount], SizeOf(TInput), 0);
FillChar(LInputs[LCount + 1], SizeOf(TInput), 0);
LInputs[LCount].Itype := INPUT_KEYBOARD;
LInputs[LCount].ki.wScan := Ord(AText[I]);
LInputs[LCount].ki.dwFlags := KEYEVENTF_UNICODE;
LInputs[LCount + 1] := LInputs[LCount];
LInputs[LCount + 1].ki.dwFlags := KEYEVENTF_UNICODE or KEYEVENTF_KEYUP;
Inc(LCount, 2);
end;
SendInput(LCount, @LInputs[0], SizeOf(TInput));
end;
// Send one virtual-key press (down+up).
procedure SendVKey(AVk: Word);
var
LInputs: array[0..1] of TInput;
begin
FillChar(LInputs, SizeOf(LInputs), 0);
LInputs[0].Itype := INPUT_KEYBOARD;
LInputs[0].ki.wVk := AVk;
LInputs[1] := LInputs[0];
LInputs[1].ki.dwFlags := KEYEVENTF_KEYUP;
SendInput(2, @LInputs[0], SizeOf(TInput));
end;
procedure SendSelectAllAndDelete;
var
LInputs: array[0..5] of TInput;
begin
FillChar(LInputs, SizeOf(LInputs), 0);
LInputs[0].Itype := INPUT_KEYBOARD;
LInputs[0].ki.wVk := VK_CONTROL;
LInputs[1].Itype := INPUT_KEYBOARD;
LInputs[1].ki.wVk := Ord('A');
LInputs[2].Itype := INPUT_KEYBOARD;
LInputs[2].ki.wVk := Ord('A');
LInputs[2].ki.dwFlags := KEYEVENTF_KEYUP;
LInputs[3].Itype := INPUT_KEYBOARD;
LInputs[3].ki.wVk := VK_CONTROL;
LInputs[3].ki.dwFlags := KEYEVENTF_KEYUP;
LInputs[4].Itype := INPUT_KEYBOARD;
LInputs[4].ki.wVk := VK_DELETE;
LInputs[5] := LInputs[4];
LInputs[5].ki.dwFlags := KEYEVENTF_KEYUP;
SendInput(6, @LInputs[0], SizeOf(TInput));
end;
// Always-attach foreground switch. The early SetForegroundWindow shortcut
// was unreliable after the picker click — Win10/11 still refused the focus
// hand-off even when our process was foreground. Always doing the attach
// dance is slightly slower but actually works.
function ForceForegroundWindow(ATargetHwnd: HWND): Boolean;
const
ForegroundPollIntervalMs = 20;
ForegroundPollTimeoutMs = 600;
var
CallerThread, TargetThread, TargetPid: DWORD;
ThreadsAttached: Boolean;
WaitStart: Cardinal;
begin
Result := False;
if (ATargetHwnd = 0) or not IsWindow(ATargetHwnd) then Exit;
TargetPid := 0;
TargetThread := GetWindowThreadProcessId(ATargetHwnd, TargetPid);
CallerThread := GetCurrentThreadId;
if TargetThread = 0 then Exit;
ThreadsAttached := (TargetThread <> CallerThread) and
AttachThreadInput(CallerThread, TargetThread, True);
try
if IsIconic(ATargetHwnd) then
ShowWindow(ATargetHwnd, SW_RESTORE);
BringWindowToTop(ATargetHwnd);
SetWindowPos(ATargetHwnd, HWND_TOP, 0, 0, 0, 0,
SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
SetForegroundWindow(ATargetHwnd);
WaitStart := GetTickCount;
while GetForegroundWindow <> ATargetHwnd do
begin
if GetTickCount - WaitStart > ForegroundPollTimeoutMs then Break;
Sleep(ForegroundPollIntervalMs);
SetForegroundWindow(ATargetHwnd);
end;
Result := GetForegroundWindow = ATargetHwnd;
finally
if ThreadsAttached then
AttachThreadInput(CallerThread, TargetThread, False);
end;
end;
procedure ClickTargetCenterToGrabFocus(ATargetHwnd: HWND);
const
PostClickSettleMs = 40;
var
WindowRect: TRect;
CenterAbsX, CenterAbsY, ScreenW, ScreenH: Integer;
SavedCursor: TPoint;
MouseInputs: array[0..2] of TInput;
begin
if (ATargetHwnd = 0) or not IsWindow(ATargetHwnd) then Exit;
if not GetWindowRect(ATargetHwnd, WindowRect) then Exit;
CenterAbsX := (WindowRect.Left + WindowRect.Right) div 2;
CenterAbsY := (WindowRect.Top + WindowRect.Bottom) div 2;
ScreenW := GetSystemMetrics(SM_CXSCREEN);
ScreenH := GetSystemMetrics(SM_CYSCREEN);
if (ScreenW <= 0) or (ScreenH <= 0) then Exit;
GetCursorPos(SavedCursor);
FillChar(MouseInputs, SizeOf(MouseInputs), 0);
MouseInputs[0].Itype := INPUT_MOUSE;
MouseInputs[0].mi.dx := (CenterAbsX * 65535) div ScreenW;
MouseInputs[0].mi.dy := (CenterAbsY * 65535) div ScreenH;
MouseInputs[0].mi.dwFlags:= MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE or MOUSEEVENTF_LEFTDOWN;
MouseInputs[1] := MouseInputs[0];
MouseInputs[1].mi.dwFlags:= MOUSEEVENTF_LEFTUP;
MouseInputs[2].Itype := INPUT_MOUSE;
MouseInputs[2].mi.dx := (SavedCursor.X * 65535) div ScreenW;
MouseInputs[2].mi.dy := (SavedCursor.Y * 65535) div ScreenH;
MouseInputs[2].mi.dwFlags:= MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE;
SendInput(3, @MouseInputs[0], SizeOf(TInput));
Sleep(PostClickSettleMs);
end;
procedure TPMBridge.ExecuteAutofill(ATargetHWND: HWND;
const AUsername, APassword: string);
const
MinimizeSettleMs = 80;
FocusSettleDelayMs = 120;
var
OwnFormHwnd: HWND;
begin
OwnFormHwnd := MainFormHWND(FMainForm);
if GetForegroundWindow = OwnFormHwnd then
begin
ShowWindow(OwnFormHwnd, SW_MINIMIZE);
Sleep(MinimizeSettleMs);
end;
if ATargetHWND <> 0 then
ForceForegroundWindow(ATargetHWND);
WaitForModifierRelease(1000);
Sleep(FocusSettleDelayMs);
if AUsername = '' then
begin
SendSelectAllAndDelete;
Sleep(60);
SendUnicodeString(APassword);
Exit;
end;
SendSelectAllAndDelete;
Sleep(60);
SendUnicodeString(AUsername);
Sleep(200);
SendVKey(VK_TAB);
Sleep(200);
SendSelectAllAndDelete;
Sleep(60);
SendUnicodeString(APassword);
end;
end.
delphi-backend/Source/PM.Database.pas
+10
View File
@@ -231,6 +231,10 @@ begin
// UI V2: tags stored as comma-separated TEXT (e.g. "work,important,2fa").
// Simple format, search via LIKE %tag%. Frontend handles parsing/joining.
AddColumnIfMissing('vault_entries', 'tags', 'TEXT DEFAULT ''''');
// Optional human-friendly display name. When empty, the UI falls back
// to `site`. Lets the user store the raw URL/host (used for autofill
// domain matching) while showing something nicer on cards/slideovers.
AddColumnIfMissing('vault_entries', 'title', 'TEXT DEFAULT ''''');
// TOTP (2FA) — RFC 6238. Secret + IV are AES-GCM ciphertext / IV pair
// encrypted client-side with the user's master-derived key, exactly like
// encrypted_password. The server treats them as opaque blobs and never
@@ -244,6 +248,12 @@ begin
// (600 000 as of 2026). Login flow transparently re-hashes legacy users
// and re-encrypts their entries on the client side.
AddColumnIfMissing('users', 'kdf_iterations', 'INTEGER DEFAULT 100000');
AddColumnIfMissing('recovery_keys', 'remaining_uses', 'INTEGER DEFAULT 5');
// Server-side preferences blob (JSON). Synced across devices on login,
// saved on every change from the JS settings panel. Device-specific
// toggles (quick-unlock DPAPI, Win32 autofill hotkey) intentionally stay
// in localStorage and are NOT included here.
AddColumnIfMissing('users', 'settings_json', 'TEXT DEFAULT ''{}''');
AddColumnIfMissing('sessions', 'csrf_token', 'TEXT');
end;
delphi-backend/Source/PM.HTTPServer.pas
+111 -14
View File
@@ -1,4 +1,4 @@
unit PM.HTTPServer;
unit PM.HTTPServer;
{
Indy TIdHTTPServer wrapper.
@@ -12,8 +12,10 @@ interface
uses
System.SysUtils, System.Classes, System.IOUtils,
IdHTTPServer, IdContext, IdCustomHTTPServer, IdSocketHandle,
PM.Router, PM.JSON, PM.Database, PM.StaticFiles, PM.EmbeddedAssets;
Winapi.Windows,
IdHTTPServer, IdContext, IdCustomHTTPServer, IdSocketHandle, IdTCPConnection,
PM.Router, PM.JSON, PM.Database, PM.StaticFiles, PM.EmbeddedAssets,
PM.Crypto, PM.ProcessLockdown;
type
TLogProc = reference to procedure(const AMsg: string);
@@ -22,6 +24,10 @@ type
private
FServer: TIdHTTPServer;
FOnLog: TLogProc;
FAccessToken: string;
FRequireAccessToken: Boolean;
FRequireProcessCheck: Boolean;
FBoundPort: Integer;
procedure HandleCommand(AContext: TIdContext;
ARequest: TIdHTTPRequestInfo; AResponse: TIdHTTPResponseInfo);
procedure HandleCommandOther(AContext: TIdContext;
@@ -34,13 +40,23 @@ type
AResponse: TIdHTTPResponseInfo);
procedure Log(const AMsg: string);
function GetActive: Boolean;
function ValidateAccessToken(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo): Boolean;
function ValidateConnectingProcess(AContext: TIdContext;
AResponse: TIdHTTPResponseInfo): Boolean;
public
constructor Create;
destructor Destroy; override;
procedure Start(APort: Integer);
procedure Start(APort: Integer; SameFolder: Boolean;
ARequireAccessToken: Boolean = True;
ARequireProcessCheck: Boolean = True);
procedure Stop;
property Active: Boolean read GetActive;
property OnLog: TLogProc read FOnLog write FOnLog;
property AccessToken: string read FAccessToken;
property RequireAccessToken: Boolean read FRequireAccessToken;
property RequireProcessCheck: Boolean read FRequireProcessCheck;
property BoundPort: Integer read FBoundPort;
end;
implementation
@@ -96,16 +112,34 @@ begin
if Assigned(FOnLog) then FOnLog(AMsg);
end;
procedure TPMHTTPServer.Start(APort: Integer);
procedure TPMHTTPServer.Start(APort: Integer; SameFolder: Boolean;
ARequireAccessToken: Boolean; ARequireProcessCheck: Boolean);
const
EphemeralPortMin = 49152;
EphemeralPortMax = 65535;
var
LBinding: TIdSocketHandle;
LDBPath, LWebRoot: string;
LDBPath, LWebRoot, LResolvedPort: string;
LRequestedPort: Integer;
begin
if FServer.Active then Exit;
// Resolve vault.db AND the web root (parent of the exe = Z:\password-manager\)
LDBPath := TPath.GetFullPath(TPath.Combine(ExtractFilePath(ParamStr(0)), '..\vault.db'));
LWebRoot := TPath.GetFullPath(TPath.Combine(ExtractFilePath(ParamStr(0)), '..\'));
FRequireAccessToken := ARequireAccessToken;
FRequireProcessCheck := ARequireProcessCheck;
if FRequireAccessToken then
FAccessToken := PM.Crypto.RandomHex(32)
else
FAccessToken := '';
LRequestedPort := APort;
if LRequestedPort = 0 then
LRequestedPort := EphemeralPortMin + Random(EphemeralPortMax - EphemeralPortMin);
var pathParent := '..\';
if SameFolder then
pathParent := '';
LDBPath := TPath.GetFullPath(TPath.Combine(ExtractFilePath(ParamStr(0)), pathParent+'vault.db'));
LWebRoot := TPath.GetFullPath(TPath.Combine(ExtractFilePath(ParamStr(0)), pathParent));
Log('Opening database: ' + LDBPath);
InitDatabase(LDBPath);
Log('Database ready.');
@@ -115,10 +149,15 @@ begin
FServer.Bindings.Clear;
LBinding := FServer.Bindings.Add;
LBinding.IP := '127.0.0.1';
LBinding.Port := APort;
LBinding.Port := LRequestedPort;
FServer.Active := True;
Log('Server started on http://127.0.0.1:' + IntToStr(APort));
FBoundPort := LRequestedPort;
LResolvedPort := IntToStr(FBoundPort);
Log(Format('Server started on http://127.0.0.1:%s (token:%s process_check:%s)',
[LResolvedPort,
BoolToStr(FRequireAccessToken, True),
BoolToStr(FRequireProcessCheck, True)]));
end;
procedure TPMHTTPServer.Stop;
@@ -176,12 +215,70 @@ begin
end;
end;
function TPMHTTPServer.ValidateConnectingProcess(AContext: TIdContext;
AResponse: TIdHTTPResponseInfo): Boolean;
var
Binding: TIdSocketHandle;
ConnectingPid: DWORD;
begin
if not FRequireProcessCheck then Exit(True);
Result := False;
Binding := AContext.Binding;
if Binding = nil then
begin
AResponse.ResponseNo := 404;
AResponse.ContentText := '';
Exit;
end;
ConnectingPid := GetPidOfTcpConnection(Word(Binding.PeerPort), Word(Binding.Port));
if (ConnectingPid <> 0) and IsDescendantOfCurrentProcess(ConnectingPid) then
Exit(True);
Log(Format('Rejected request from foreign PID %d (%s %s)',
[ConnectingPid, AContext.Connection.Socket.Binding.PeerIP, '']));
AResponse.ResponseNo := 404;
AResponse.ContentText := '';
end;
function TPMHTTPServer.ValidateAccessToken(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo): Boolean;
const
CookieName = 'pm_token';
QueryParamName = 'pmt';
SetCookieHeader = 'Set-Cookie';
var
CookieHeader, QueryToken: string;
begin
if not FRequireAccessToken then Exit(True);
CookieHeader := ARequest.RawHeaders.Values['Cookie'];
if (CookieHeader <> '') and
(Pos(CookieName + '=' + FAccessToken, CookieHeader) > 0) then
Exit(True);
QueryToken := ARequest.Params.Values[QueryParamName];
if QueryToken = FAccessToken then
begin
AResponse.CustomHeaders.AddValue(SetCookieHeader,
CookieName + '=' + FAccessToken +
'; Path=/; HttpOnly; SameSite=Strict');
Exit(True);
end;
AResponse.ResponseNo := 404;
AResponse.ContentText := '';
Result := False;
end;
procedure TPMHTTPServer.HandleCommand(AContext: TIdContext;
ARequest: TIdHTTPRequestInfo; AResponse: TIdHTTPResponseInfo);
begin
ApplySecurityHeaders(ARequest, AResponse);
if not ValidateConnectingProcess(AContext, AResponse) then Exit;
if not ValidateAccessToken(ARequest, AResponse) then Exit;
try
// Order: API route → embedded resource (production) → disk static (dev) → 404
if Router.DispatchRequest(ARequest, AResponse) then Exit;
if TryServeEmbedded(ARequest, AResponse) then Exit;
if Assigned(StaticServer) and StaticServer.TryServe(ARequest, AResponse) then Exit;
@@ -199,14 +296,14 @@ procedure TPMHTTPServer.HandleCommandOther(AContext: TIdContext;
ARequest: TIdHTTPRequestInfo; AResponse: TIdHTTPResponseInfo);
begin
ApplySecurityHeaders(ARequest, AResponse);
// OPTIONS preflight
if SameText(ARequest.Command, 'OPTIONS') then
begin
AResponse.ResponseNo := 204;
AResponse.ContentText := '';
Exit;
end;
// Routes for PUT / DELETE go through here in Indy
if not ValidateConnectingProcess(AContext, AResponse) then Exit;
if not ValidateAccessToken(ARequest, AResponse) then Exit;
try
if not Router.DispatchRequest(ARequest, AResponse) then
TJSONHelper.SendError(AResponse, 404, 'Not found');
delphi-backend/Source/PM.JSON.pas
-1
View File
@@ -24,7 +24,6 @@ var
LSS: TStringStream;
LValue: TJSONValue;
begin
Result := nil;
if ARequest.PostStream = nil then Exit(TJSONObject.Create);
LSS := TStringStream.Create('', TEncoding.UTF8);
try
delphi-backend/Source/PM.ProcessLockdown.pas
+116
View File
@@ -0,0 +1,116 @@
unit PM.ProcessLockdown;
interface
uses
Winapi.Windows;
function GetPidOfTcpConnection(ALocalPort, ARemotePort: Word): DWORD;
function IsDescendantOfCurrentProcess(APid: DWORD): Boolean;
implementation
uses
System.SysUtils, System.Generics.Collections, Winapi.WinSock,
Winapi.TlHelp32;
const
IPHLPAPI = 'iphlpapi.dll';
AF_INET_LOCAL = 2;
TCP_TABLE_OWNER_PID_CONNECTIONS = 4;
NO_ERROR = 0;
type
MIB_TCPROW_OWNER_PID = record
dwState: DWORD;
dwLocalAddr: DWORD;
dwLocalPort: DWORD;
dwRemoteAddr: DWORD;
dwRemotePort: DWORD;
dwOwningPid: DWORD;
end;
MIB_TCPTABLE_OWNER_PID = record
dwNumEntries: DWORD;
table: array[0..0] of MIB_TCPROW_OWNER_PID;
end;
PMIB_TCPTABLE_OWNER_PID = ^MIB_TCPTABLE_OWNER_PID;
function GetExtendedTcpTable(pTcpTable: Pointer; pdwSize: PDWORD;
bOrder: BOOL; ulAf: ULONG; TableClass: DWORD; Reserved: ULONG): DWORD;
stdcall; external IPHLPAPI;
function GetPidOfTcpConnection(ALocalPort, ARemotePort: Word): DWORD;
var
Size: DWORD;
Buffer: PMIB_TCPTABLE_OWNER_PID;
i: Integer;
Row: ^MIB_TCPROW_OWNER_PID;
WantedLocal, WantedRemote: Word;
begin
Result := 0;
Size := 0;
GetExtendedTcpTable(nil, @Size, False, AF_INET_LOCAL,
TCP_TABLE_OWNER_PID_CONNECTIONS, 0);
if Size = 0 then Exit;
GetMem(Buffer, Size);
try
if GetExtendedTcpTable(Buffer, @Size, False, AF_INET_LOCAL,
TCP_TABLE_OWNER_PID_CONNECTIONS, 0) <> NO_ERROR then Exit;
WantedLocal := ntohs(ALocalPort);
WantedRemote := ntohs(ARemotePort);
Row := @Buffer.table[0];
for i := 0 to Buffer.dwNumEntries - 1 do
begin
if (Word(Row.dwLocalPort) = WantedLocal) and
(Word(Row.dwRemotePort) = WantedRemote) then
Exit(Row.dwOwningPid);
Inc(Row);
end;
finally
FreeMem(Buffer);
end;
end;
function IsDescendantOfCurrentProcess(APid: DWORD): Boolean;
const
MaxDepth = 32;
var
Snap: THandle;
Entry: TProcessEntry32W;
ParentMap: TDictionary<DWORD, DWORD>;
Current, RootPid: DWORD;
Depth: Integer;
begin
Result := False;
if APid = 0 then Exit;
RootPid := GetCurrentProcessId;
if APid = RootPid then Exit(True);
Snap := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if Snap = INVALID_HANDLE_VALUE then Exit;
ParentMap := TDictionary<DWORD, DWORD>.Create;
try
Entry.dwSize := SizeOf(Entry);
if Process32FirstW(Snap, Entry) then
repeat
ParentMap.AddOrSetValue(Entry.th32ProcessID, Entry.th32ParentProcessID);
until not Process32NextW(Snap, Entry);
Current := APid;
for Depth := 0 to MaxDepth do
begin
if Current = RootPid then Exit(True);
if not ParentMap.TryGetValue(Current, Current) then Exit;
if (Current = 0) or (Current = 4) then Exit;
end;
finally
ParentMap.Free;
CloseHandle(Snap);
end;
end;
end.
delphi-backend/Source/PM.RateLimit.pas
+1 -1
View File
@@ -23,6 +23,7 @@ interface
uses
System.SysUtils, System.JSON,
Data.DB,
FireDAC.Comp.Client, FireDAC.Stan.Param, IdCustomHTTPServer,
PM.Database;
@@ -67,7 +68,6 @@ function CheckRateLimit(const AIP: string): Integer;
var
LQ: TFDQuery;
begin
Result := 0;
DB.Lock;
try
LQ := TFDQuery.Create(nil);
delphi-backend/Source/PM.Session.pas
+1 -1
View File
@@ -16,6 +16,7 @@ interface
uses
System.SysUtils, System.Classes, System.StrUtils,
Data.DB,
FireDAC.Comp.Client, FireDAC.Stan.Param,
IdCustomHTTPServer,
PM.Database, PM.Crypto, PM.JSON;
@@ -55,7 +56,6 @@ var
LQ: TFDQuery;
LExpires: TDateTime;
begin
Result := 0;
LToken := ExtractBearerToken(ARequest);
if LToken = '' then
begin
delphi-backend/Source/PM.SingleInstance.pas
+76
View File
@@ -0,0 +1,76 @@
unit PM.SingleInstance;
{
Single-instance guard.
AcquireOrSignal:
- First instance: creates a named mutex and returns True. Caller proceeds.
- Subsequent instance: detects the mutex, broadcasts WM_PMSHOW so the
running instance restores from tray, returns False. Caller exits.
WM_PMSHOW is a RegisterWindowMessage('PMServer_ShowExisting') — system-
unique, all processes that register the same string get the same ID.
PM.Bridge listens for it on its message-only window.
}
interface
uses
Winapi.Windows, Winapi.Messages;
const
// Mutex name lives in the Local\ namespace → per-user-session, so a
// second user on the same machine (RDP, Switch User) can still launch
// their own instance. The Global\ namespace would block them.
PMSERVER_MUTEX_NAME = 'Local\PMServer.SingleInstance.Mutex';
// System-wide unique message ID, computed once. Bridge + .dpr both call
// this to get the same UINT.
function WM_PMShowMessage: UINT;
// Try to become the single instance. True = we are first; False = another
// instance was already running (we have signalled it and the caller must
// exit immediately).
function AcquireOrSignal: Boolean;
implementation
var
_Mutex: THandle = 0;
_WmShow: UINT = 0;
function WM_PMShowMessage: UINT;
begin
if _WmShow = 0 then
_WmShow := RegisterWindowMessage('PMServer_ShowExisting');
Result := _WmShow;
end;
function AcquireOrSignal: Boolean;
var
LErr: DWORD;
begin
_Mutex := CreateMutex(nil, True, PMSERVER_MUTEX_NAME);
LErr := GetLastError;
if (_Mutex <> 0) and (LErr <> ERROR_ALREADY_EXISTS) then
begin
// We are the first instance. Keep the mutex alive for the process
// lifetime — Windows releases it automatically on exit.
Result := True;
Exit;
end;
// Another instance is already running. Close our handle (it isn't ours)
// and broadcast the show-message to all top-level windows. The running
// bridge picks it up on its message-only window.
if _Mutex <> 0 then
begin
CloseHandle(_Mutex);
_Mutex := 0;
end;
PostMessage(HWND_BROADCAST, WM_PMShowMessage, 0, 0);
Result := False;
end;
end.
delphi-backend/Source/PM.UserPrefs.pas
+180
View File
@@ -0,0 +1,180 @@
unit PM.UserPrefs;
{
Device-bound key/value prefs persisted across launches.
Problem solved: the HTTP server binds an ephemeral port that changes on
every start (49152-65535). localStorage is keyed by origin (scheme+host
+port) so a different port = a fresh localStorage = anything persisted
there is lost between launches. For prefs that must survive a reboot
(remembered username, etc.) we persist them via this unit instead.
Storage: %LOCALAPPDATA%\PMServer\prefs.bin
Format: DPAPI-encrypted UTF-8 JSON object {"key":"value",....
Scope: current Windows user (same threat model as PM.QuickUnlock).
}
interface
uses
System.SysUtils, System.Classes, System.IOUtils, System.JSON,
Winapi.Windows;
function GetPref(const AKey: string): string;
procedure SetPref(const AKey, AValue: string);
implementation
type
TDataBlob = record
cbData: DWORD;
pbData: PByte;
end;
PDataBlob = ^TDataBlob;
function CryptProtectData(pDataIn: PDataBlob; szDataDescr: PWideChar;
pOptionalEntropy: PDataBlob; pvReserved: Pointer; pPromptStruct: Pointer;
dwFlags: DWORD; pDataOut: PDataBlob): BOOL; stdcall;
external 'crypt32.dll' name 'CryptProtectData';
function CryptUnprotectData(pDataIn: PDataBlob; ppszDataDescr: PPWideChar;
pOptionalEntropy: PDataBlob; pvReserved: Pointer; pPromptStruct: Pointer;
dwFlags: DWORD; pDataOut: PDataBlob): BOOL; stdcall;
external 'crypt32.dll' name 'CryptUnprotectData';
function LocalFree(hMem: HLOCAL): HLOCAL; stdcall;
external 'kernel32.dll' name 'LocalFree';
function StorageDir: string;
begin
Result := TPath.Combine(GetEnvironmentVariable('LOCALAPPDATA'), 'PMServer');
end;
function StorageFile: string;
begin
Result := TPath.Combine(StorageDir, 'prefs.bin');
end;
procedure EnsureStorageDir;
begin
if not TDirectory.Exists(StorageDir) then
TDirectory.CreateDirectory(StorageDir);
end;
function LoadAll: TJSONObject;
var
LEncrypted: TBytes;
LIn, LOut: TDataBlob;
LStream: TFileStream;
LPlain: string;
LValue: TJSONValue;
begin
// Default to an empty object; every error path just Exits with this.
// Only the success path replaces it with the parsed JSON.
Result := TJSONObject.Create;
if not TFile.Exists(StorageFile) then Exit;
try
LStream := TFileStream.Create(StorageFile, fmOpenRead or fmShareDenyWrite);
try
SetLength(LEncrypted, LStream.Size);
if Length(LEncrypted) > 0 then
LStream.ReadBuffer(LEncrypted[0], LStream.Size);
finally
LStream.Free;
end;
except
Exit;
end;
if Length(LEncrypted) = 0 then Exit;
LIn.cbData := Length(LEncrypted);
LIn.pbData := @LEncrypted[0];
LOut.pbData := nil;
LOut.cbData := 0;
if not CryptUnprotectData(@LIn, nil, nil, nil, nil, 0, @LOut) then Exit;
try
SetString(LPlain, PAnsiChar(LOut.pbData), LOut.cbData);
LValue := TJSONObject.ParseJSONValue(TEncoding.UTF8.GetBytes(LPlain), 0);
if LValue is TJSONObject then
begin
// Replace the default empty object with the parsed one.
Result.Free;
Result := TJSONObject(LValue);
end
else if LValue <> nil then
LValue.Free;
finally
if LOut.pbData <> nil then LocalFree(HLOCAL(LOut.pbData));
end;
end;
procedure SaveAll(AObj: TJSONObject);
var
LBytes: TBytes;
LIn, LOut: TDataBlob;
LStream: TFileStream;
LJsonStr: string;
begin
LJsonStr := AObj.ToJSON;
LBytes := TEncoding.UTF8.GetBytes(LJsonStr);
if Length(LBytes) = 0 then Exit;
LIn.cbData := Length(LBytes);
LIn.pbData := @LBytes[0];
LOut.pbData := nil;
LOut.cbData := 0;
if not CryptProtectData(@LIn, nil, nil, nil, nil, 0, @LOut) then Exit;
try
EnsureStorageDir;
LStream := TFileStream.Create(StorageFile, fmCreate);
try
LStream.WriteBuffer(LOut.pbData^, LOut.cbData);
finally
LStream.Free;
end;
finally
if LOut.pbData <> nil then LocalFree(HLOCAL(LOut.pbData));
end;
end;
function GetPref(const AKey: string): string;
var
LObj: TJSONObject;
LValue: TJSONValue;
begin
Result := '';
LObj := LoadAll;
try
if LObj = nil then Exit;
LValue := LObj.GetValue(AKey);
if LValue <> nil then
Result := LValue.Value;
finally
LObj.Free;
end;
end;
procedure SetPref(const AKey, AValue: string);
var
LObj: TJSONObject;
LExisting: TJSONValue;
begin
LObj := LoadAll;
try
if LObj = nil then LObj := TJSONObject.Create;
LExisting := LObj.GetValue(AKey);
if LExisting <> nil then
LObj.RemovePair(AKey).Free;
LObj.AddPair(AKey, AValue);
SaveAll(LObj);
finally
LObj.Free;
end;
end;
end.