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/Handlers/PM.Handler.Audit.pas
+65
View File
@@ -0,0 +1,65 @@
unit PM.Handler.Audit;
(*
POST /audit body {action, site} -> {ok:true}
Light-weight endpoint that lets the JS layer append an entry to audit_log
without going through the full entries pipeline. Used by the autofill
feature to record which site was filled (action = "autofill:<site>").
The bearer token identifies the user — no data beyond the action string
is stored.
*)
interface
implementation
uses
System.SysUtils, System.JSON,
IdCustomHTTPServer,
PM.Router, PM.JSON, PM.Session, PM.Audit;
function GetClientIP(ARequest: TIdHTTPRequestInfo): string;
begin
Result := ARequest.RemoteIP;
if Result = '' then Result := '127.0.0.1';
end;
procedure HandlePostAudit(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
var
LUserId: Integer;
LBody: TJSONObject;
LAction, LSite: string;
begin
LUserId := Authenticate(ARequest, AResponse);
RequireCSRF(ARequest, AResponse, LUserId);
LBody := TJSONHelper.ReadBody(ARequest);
try
LAction := LBody.GetValue<string>('action', '');
LSite := LBody.GetValue<string>('site', '');
finally
LBody.Free;
end;
if LAction = '' then
begin
TJSONHelper.SendError(AResponse, 400, 'action required');
Exit;
end;
// Keep the log compact: "autofill:github.com" rather than repeating
// structured columns we don't have in the current schema.
if LSite <> '' then
LAction := LAction + ':' + LSite;
LogAudit(LUserId, LAction, GetClientIP(ARequest));
TJSONHelper.SendOK(AResponse);
end;
initialization
Router.Register('POST', '/audit', HandlePostAudit);
end.
delphi-backend/Handlers/PM.Handler.Auth.pas
+18 -5
View File
@@ -19,9 +19,9 @@ interface
implementation
uses
System.SysUtils, System.JSON, System.Classes,
FireDAC.Comp.Client,
IdCustomHTTPServer,Data.DB,
System.SysUtils, System.JSON, System.Classes, System.Generics.Collections,
Data.DB, FireDAC.Comp.Client, FireDAC.Stan.Param,
IdCustomHTTPServer,
PM.Router, PM.JSON, PM.Database, PM.Crypto,
PM.Session, PM.RateLimit, PM.Audit;
@@ -961,8 +961,21 @@ begin
DB.Unlock;
end;
// Step 5: invalidate every other session for this user. The CURRENT
// session token is still valid — caller stays logged in.
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text := 'DELETE FROM recovery_keys WHERE user_id = :uid';
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.ExecSQL;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
DeleteAllUserSessions(LUserId);
finally
LBody.Free;
delphi-backend/Handlers/PM.Handler.Entries.pas
+64 -8
View File
@@ -16,6 +16,7 @@ implementation
uses
System.SysUtils, System.JSON, System.StrUtils, System.NetEncoding,
System.Generics.Collections,
Data.DB, FireDAC.Comp.Client, FireDAC.Stan.Param,
IdCustomHTTPServer, IdGlobalProtocols, IdURI,
PM.Router, PM.JSON, PM.Database, PM.Session, PM.Audit, PM.RateLimit;
@@ -91,6 +92,7 @@ begin
LObj := TJSONObject.Create;
LObj.AddPair('id', TJSONNumber.Create(LQ.FieldByName('id').AsInteger));
LObj.AddPair('site', LQ.FieldByName('site').AsString);
LObj.AddPair('title', LQ.FieldByName('title').AsString);
LObj.AddPair('username', LQ.FieldByName('username').AsString);
LObj.AddPair('encrypted_password', LQ.FieldByName('encrypted_password').AsString);
LObj.AddPair('iv', LQ.FieldByName('iv').AsString);
@@ -135,7 +137,7 @@ procedure HandleCreateEntry(ARequest: TIdHTTPRequestInfo;
var
LUserId, LNewId: Integer;
LBody, LObj: TJSONObject;
LSite, LUser, LFolder, LEnc, LIV, LTags, LNow, LTotpSec, LTotpIv: string;
LSite, LTitle, LUser, LFolder, LEnc, LIV, LTags, LNow, LTotpSec, LTotpIv: string;
LQ: TFDQuery;
begin
try
@@ -148,6 +150,7 @@ begin
LBody := TJSONHelper.ReadBody(ARequest);
try
LSite := Trim(LBody.GetValue<string>('site', ''));
LTitle := Trim(LBody.GetValue<string>('title', ''));
LUser := Trim(LBody.GetValue<string>('username', ''));
LFolder := Trim(LBody.GetValue<string>('folder', 'All'));
LEnc := LBody.GetValue<string>('encrypted_password', '');
@@ -175,11 +178,12 @@ begin
LQ.Connection := DB.Connection;
LQ.SQL.Text :=
'INSERT INTO vault_entries ' +
'(user_id, site, username, encrypted_password, iv, encryption_method, ' +
'(user_id, site, title, username, encrypted_password, iv, encryption_method, ' +
' folder, tags, totp_secret, totp_iv, created_at, updated_at) ' +
'VALUES (:uid, :s, :u, :e, :i, ''client'', :f, :t, :ts, :tiv, :c, :c2)';
'VALUES (:uid, :s, :tt, :u, :e, :i, ''client'', :f, :t, :ts, :tiv, :c, :c2)';
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.ParamByName('s').AsString := LSite;
LQ.ParamByName('tt').AsString := LTitle;
LQ.ParamByName('u').AsString := LUser;
LQ.ParamByName('e').AsString := LEnc;
LQ.ParamByName('i').AsString := LIV;
@@ -216,6 +220,7 @@ begin
LObj := TJSONObject.Create;
LObj.AddPair('id', TJSONNumber.Create(LNewId));
LObj.AddPair('site', LSite);
LObj.AddPair('title', LTitle);
LObj.AddPair('username', LUser);
LObj.AddPair('folder', LFolder);
LObj.AddPair('tags', LTags);
@@ -229,7 +234,7 @@ procedure HandleUpdateEntry(ARequest: TIdHTTPRequestInfo;
var
LUserId, LId: Integer;
LBody: TJSONObject;
LSite, LUser, LFolder, LEnc, LIV, LTags, LNow, LTotpSec, LTotpIv: string;
LSite, LTitle, LUser, LFolder, LEnc, LIV, LTags, LNow, LTotpSec, LTotpIv: string;
LQ: TFDQuery;
begin
try
@@ -249,6 +254,7 @@ begin
LBody := TJSONHelper.ReadBody(ARequest);
try
LSite := Trim(LBody.GetValue<string>('site', ''));
LTitle := Trim(LBody.GetValue<string>('title', ''));
LUser := Trim(LBody.GetValue<string>('username', ''));
LFolder := Trim(LBody.GetValue<string>('folder', 'All'));
LEnc := LBody.GetValue<string>('encrypted_password', '');
@@ -274,11 +280,12 @@ begin
LQ.Connection := DB.Connection;
LQ.SQL.Text :=
'UPDATE vault_entries ' +
'SET site=:s, username=:u, encrypted_password=:e, iv=:i, ' +
'SET site=:s, title=:tt, username=:u, encrypted_password=:e, iv=:i, ' +
' folder=:f, tags=:t, totp_secret=:ts, totp_iv=:tiv, ' +
' updated_at=:c ' +
'WHERE id=:id AND user_id=:uid';
LQ.ParamByName('s').AsString := LSite;
LQ.ParamByName('tt').AsString := LTitle;
LQ.ParamByName('u').AsString := LUser;
LQ.ParamByName('e').AsString := LEnc;
LQ.ParamByName('i').AsString := LIV;
@@ -501,7 +508,7 @@ var
LUserId, I, LImported: Integer;
LBody, LObj, LEntry: TJSONObject;
LArr: TJSONArray;
LSite, LUser, LFolder, LEnc, LIV, LTags, LTotpSec, LTotpIv, LNow: string;
LSite, LTitle, LUser, LFolder, LEnc, LIV, LTags, LTotpSec, LTotpIv, LNow: string;
LQ: TFDQuery;
begin
try
@@ -540,9 +547,9 @@ begin
LQ.Connection := DB.Connection;
LQ.SQL.Text :=
'INSERT INTO vault_entries ' +
'(user_id, site, username, encrypted_password, iv, encryption_method, ' +
'(user_id, site, title, username, encrypted_password, iv, encryption_method, ' +
' folder, tags, totp_secret, totp_iv, created_at, updated_at) ' +
'VALUES (:uid, :s, :u, :e, :i, ''client'', :f, :t, :ts, :tiv, :c, :c2)';
'VALUES (:uid, :s, :tt, :u, :e, :i, ''client'', :f, :t, :ts, :tiv, :c, :c2)';
// Declare optional TOTP param types ONCE — the prepared statement
// is reused across every imported entry, and FireDAC needs the
// type set before the first .Clear call would otherwise fail
@@ -554,6 +561,7 @@ begin
begin
LEntry := LArr.Items[I] as TJSONObject;
LSite := Trim(LEntry.GetValue<string>('site', ''));
LTitle := Trim(LEntry.GetValue<string>('title', ''));
LUser := Trim(LEntry.GetValue<string>('username', ''));
LFolder := Trim(LEntry.GetValue<string>('folder', 'All'));
LEnc := LEntry.GetValue<string>('encrypted_password', '');
@@ -569,6 +577,7 @@ begin
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.ParamByName('s').AsString := LSite;
LQ.ParamByName('tt').AsString := LTitle;
LQ.ParamByName('u').AsString := LUser;
LQ.ParamByName('e').AsString := LEnc;
LQ.ParamByName('i').AsString := LIV;
@@ -604,6 +613,52 @@ begin
TJSONHelper.SendJSON(AResponse, LObj);
end;
procedure HandleEntriesCount(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
var
LUserId, LActive, LTrashed: Integer;
LQ: TFDQuery;
LObj: TJSONObject;
begin
try
LUserId := Authenticate(ARequest, AResponse);
except
on ESessionRejected do Exit;
end;
LActive := 0;
LTrashed := 0;
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text :=
'SELECT deleted, COUNT(*) AS cnt FROM vault_entries ' +
'WHERE user_id = :uid GROUP BY deleted';
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.Open;
while not LQ.Eof do
begin
if LQ.FieldByName('deleted').AsInteger = 0 then
LActive := LQ.FieldByName('cnt').AsInteger
else
LTrashed := LQ.FieldByName('cnt').AsInteger;
LQ.Next;
end;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
LObj := TJSONObject.Create;
LObj.AddPair('active', TJSONNumber.Create(LActive));
LObj.AddPair('trashed', TJSONNumber.Create(LTrashed));
TJSONHelper.SendJSON(AResponse, LObj);
end;
initialization
// /entries/trash/empty must be registered BEFORE /entries/{id} to win the regex match.
// Same logic for /entries/bulk-import — register before the catch-all /entries/{id}.
@@ -611,6 +666,7 @@ initialization
Router.Register('POST', '/entries/bulk-import', HandleBulkImport);
Router.Register('POST', '/entries/(\d+)/restore', HandleRestoreEntry);
Router.Register('POST', '/entries/(\d+)/favorite', HandleToggleFavorite);
Router.Register('GET', '/entries/count', HandleEntriesCount);
Router.Register('GET', '/entries', HandleGetEntries);
Router.Register('POST', '/entries', HandleCreateEntry);
Router.Register('PUT', '/entries/(\d+)', HandleUpdateEntry);
delphi-backend/Handlers/PM.Handler.Recovery.pas
+33 -19
View File
@@ -33,7 +33,7 @@ implementation
uses
System.SysUtils, System.JSON,
FireDAC.Comp.Client, FireDAC.Stan.Param,
Data.DB, FireDAC.Comp.Client, FireDAC.Stan.Param,
IdCustomHTTPServer,
PM.Router, PM.JSON, PM.Database, PM.Crypto, PM.Session, PM.Audit, PM.RateLimit;
@@ -122,19 +122,21 @@ begin
LConfigured := False;
LCreatedAt := '';
var RemainingUses: Integer := 0;
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text :=
'SELECT created_at FROM recovery_keys WHERE user_id = :uid';
'SELECT created_at, remaining_uses FROM recovery_keys WHERE user_id = :uid';
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.Open;
if not LQ.IsEmpty then
begin
LConfigured := True;
LCreatedAt := LQ.FieldByName('created_at').AsString;
RemainingUses := LQ.FieldByName('remaining_uses').AsInteger;
end;
finally
LQ.Free;
@@ -146,6 +148,7 @@ begin
LObj := TJSONObject.Create;
LObj.AddPair('configured', TJSONBool.Create(LConfigured));
if LConfigured then LObj.AddPair('created_at', LCreatedAt);
if LConfigured then LObj.AddPair('remaining_uses', TJSONNumber.Create(RemainingUses));
TJSONHelper.SendJSON(AResponse, LObj);
end;
@@ -208,8 +211,8 @@ begin
LQ.SQL.Text :=
'INSERT INTO recovery_keys ' +
' (user_id, code_hash, kdf_salt, wrapped_key, wrapped_iv) ' +
'VALUES (:uid, :ch, :ks, :wk, :wi)';
' (user_id, code_hash, kdf_salt, wrapped_key, wrapped_iv, remaining_uses) ' +
'VALUES (:uid, :ch, :ks, :wk, :wi, 5)';
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.ParamByName('ch').AsString := LCodeHash;
LQ.ParamByName('ks').AsString := LKdfSalt;
@@ -271,7 +274,7 @@ var
LBody, LObj: TJSONObject;
LUser, LCode, LCodeHash, LIP, LStoredHash, LKdfSalt, LWrappedKey, LWrappedIv,
LSalt, LToken, LCSRF: string;
LUserId, LKdfIters: Integer;
LUserId, LKdfIters, LCurrentUses, LNewUses: Integer;
LQ: TFDQuery;
begin
LIP := GetClientIP(ARequest);
@@ -307,7 +310,7 @@ begin
// Join to users to look up by username + verify the code in one shot.
LQ.SQL.Text :=
'SELECT u.id, u.salt, u.kdf_iterations, ' +
' rk.code_hash, rk.kdf_salt, rk.wrapped_key, rk.wrapped_iv ' +
' rk.code_hash, rk.kdf_salt, rk.wrapped_key, rk.wrapped_iv, rk.remaining_uses ' +
'FROM users u ' +
'LEFT JOIN recovery_keys rk ON rk.user_id = u.id ' +
'WHERE u.username = :u';
@@ -315,20 +318,19 @@ begin
LQ.Open;
if LQ.IsEmpty then
begin
// User doesn't exist OR has no recovery key configured. Same error
// either way to avoid leaking which.
RecordAttempt(LIP);
RecordFailedAccountAttempt(LUser, LIP);
TJSONHelper.SendError(AResponse, 401, 'Invalid username or recovery code');
Exit;
end;
LUserId := LQ.FieldByName('id').AsInteger;
LSalt := LQ.FieldByName('salt').AsString;
LKdfIters := LQ.FieldByName('kdf_iterations').AsInteger;
LStoredHash := LQ.FieldByName('code_hash').AsString;
LKdfSalt := LQ.FieldByName('kdf_salt').AsString;
LWrappedKey := LQ.FieldByName('wrapped_key').AsString;
LWrappedIv := LQ.FieldByName('wrapped_iv').AsString;
LUserId := LQ.FieldByName('id').AsInteger;
LSalt := LQ.FieldByName('salt').AsString;
LKdfIters := LQ.FieldByName('kdf_iterations').AsInteger;
LStoredHash := LQ.FieldByName('code_hash').AsString;
LKdfSalt := LQ.FieldByName('kdf_salt').AsString;
LWrappedKey := LQ.FieldByName('wrapped_key').AsString;
LWrappedIv := LQ.FieldByName('wrapped_iv').AsString;
LCurrentUses := LQ.FieldByName('remaining_uses').AsInteger;
finally
LQ.Free;
end;
@@ -361,13 +363,24 @@ begin
Exit;
end;
// Code matches. Consume (delete the row) inside the same lock so the
// single-use guarantee holds even under concurrent requests.
// Code matches. Decrement remaining_uses ; if it drops to 0, delete
// the row (last use). The row is also deleted when the user
// successfully changes their master password (in PM.Handler.Auth).
LNewUses := LCurrentUses - 1;
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text := 'DELETE FROM recovery_keys WHERE user_id = :uid';
LQ.ParamByName('uid').AsInteger := LUserId;
if LNewUses <= 0 then
begin
LQ.SQL.Text := 'DELETE FROM recovery_keys WHERE user_id = :uid';
LQ.ParamByName('uid').AsInteger := LUserId;
end
else
begin
LQ.SQL.Text := 'UPDATE recovery_keys SET remaining_uses = :u WHERE user_id = :uid';
LQ.ParamByName('u').AsInteger := LNewUses;
LQ.ParamByName('uid').AsInteger := LUserId;
end;
LQ.ExecSQL;
finally
LQ.Free;
@@ -391,6 +404,7 @@ begin
LObj.AddPair('wrappedKey', LWrappedKey);
LObj.AddPair('wrappedIv', LWrappedIv);
LObj.AddPair('kdfSalt', LKdfSalt);
LObj.AddPair('remainingUses', TJSONNumber.Create(LNewUses));
TJSONHelper.SendJSON(AResponse, LObj);
end;
delphi-backend/Handlers/PM.Handler.Settings.pas
+113
View File
@@ -0,0 +1,113 @@
unit PM.Handler.Settings;
(*
GET /settings -> {<arbitrary JSON object stored as-is>}
PUT /settings body: {<arbitrary JSON object>} -> {message:"OK"}
Persists a per-user preferences blob (users.settings_json). The server
treats the body as opaque JSON — schema lives in the JS layer. Any client
reading it should tolerate unknown keys for forward compatibility.
Device-specific toggles (quick-unlock DPAPI, autofill hotkey) deliberately
stay in localStorage on the client and are NOT included in this blob.
*)
interface
implementation
uses
System.SysUtils, System.JSON, System.Classes,
Data.DB, FireDAC.Comp.Client, FireDAC.Stan.Param,
IdCustomHTTPServer,
PM.Router, PM.JSON, PM.Session, PM.Database;
procedure HandleGetSettings(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
var
LUserId: Integer;
LQ: TFDQuery;
LRaw: string;
LObj: TJSONValue;
begin
LUserId := Authenticate(ARequest, AResponse);
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text := 'SELECT settings_json FROM users WHERE id = :uid';
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.Open;
if LQ.IsEmpty then
LRaw := '{}'
else
LRaw := LQ.FieldByName('settings_json').AsString;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
if Trim(LRaw) = '' then LRaw := '{}';
// Validate so a corrupt row doesn't return malformed JSON to the client.
LObj := TJSONObject.ParseJSONValue(LRaw);
if LObj = nil then LObj := TJSONObject.Create;
TJSONHelper.SendJSON(AResponse, LObj); // SendJSON frees the object
end;
procedure HandlePutSettings(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
var
LUserId: Integer;
LBody: TJSONObject;
LSerialized: string;
LQ: TFDQuery;
begin
LUserId := Authenticate(ARequest, AResponse);
RequireCSRF(ARequest, AResponse, LUserId);
LBody := TJSONHelper.ReadBody(ARequest);
try
// Re-serialize to a canonical compact form (strips comments / extra
// whitespace, and guarantees what we store is valid JSON).
LSerialized := LBody.ToJSON;
finally
LBody.Free;
end;
// Soft cap to protect the row from a runaway client (typical settings
// blob is a few hundred bytes; 16 KB leaves room for future flags).
if Length(LSerialized) > 16384 then
begin
TJSONHelper.SendError(AResponse, 413, 'Settings payload too large');
Exit;
end;
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text := 'UPDATE users SET settings_json = :s WHERE id = :uid';
LQ.ParamByName('s').AsString := LSerialized;
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.ExecSQL;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
TJSONHelper.SendOK(AResponse);
end;
initialization
Router.Register('GET', '/settings', HandleGetSettings);
Router.Register('PUT', '/settings', HandlePutSettings);
end.
delphi-backend/PMServer.dpr
+12 -1
View File
@@ -3,6 +3,7 @@ program PMServer;
uses
System.StartUpCopy,
FMX.Forms,
PM.SingleInstance in 'Source\PM.SingleInstance.pas',
UMainForm in 'UMainForm.pas' {MainForm},
PM.JSON in 'Source\PM.JSON.pas',
PM.Database in 'Source\PM.Database.pas',
@@ -16,17 +17,27 @@ uses
PM.HTTPServer in 'Source\PM.HTTPServer.pas',
PM.Bridge in 'Source\PM.Bridge.pas',
PM.QuickUnlock in 'Source\PM.QuickUnlock.pas',
PM.UserPrefs in 'Source\PM.UserPrefs.pas',
PM.ProcessLockdown in 'Source\PM.ProcessLockdown.pas',
PM.Handler.Ping in 'Handlers\PM.Handler.Ping.pas',
PM.Handler.Auth in 'Handlers\PM.Handler.Auth.pas',
PM.Handler.Folders in 'Handlers\PM.Handler.Folders.pas',
PM.Handler.Entries in 'Handlers\PM.Handler.Entries.pas',
PM.Handler.Passkey in 'Handlers\PM.Handler.Passkey.pas',
PM.Handler.Recovery in 'Handlers\PM.Handler.Recovery.pas';
PM.Handler.Recovery in 'Handlers\PM.Handler.Recovery.pas',
PM.Handler.Audit in 'Handlers\PM.Handler.Audit.pas',
PM.Handler.Settings in 'Handlers\PM.Handler.Settings.pas';
{$R *.res}
{$R assets\assets.res}
begin
// Single-instance: if another PMServer is running, bring it to front
// (it'll handle WM_PMSHOW on its message-only window) and exit. Avoids
// two icons in the tray and two HTTP servers fighting for the port.
if not PM.SingleInstance.AcquireOrSignal then
Exit;
Application.Initialize;
Application.CreateForm(TMainForm, MainForm);
Application.Run;
delphi-backend/PMServer.dproj
+1250 -272
View File
File diff suppressed because it is too large Load Diff
delphi-backend/PMServer.res
BIN
View File
Binary file not shown.
delphi-backend/PMServer_Icon.ico
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 100 KiB

delphi-backend/PMServer_Icon1.ico
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 100 KiB

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.
delphi-backend/UMainForm.fmx
+2 -2
View File
@@ -1,15 +1,15 @@
object MainForm: TMainForm
Left = 0
Top = 0
Caption = 'Password Manager - Delphi Backend'
Caption = 'Password Manager'
ClientHeight = 720
ClientWidth = 1100
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
OnCreate = FormCreate
OnDestroy = FormDestroy
OnCloseQuery = FormCloseQuery
OnDestroy = FormDestroy
DesignerMasterStyle = 0
object PanelTop: TPanel
Align = Top
delphi-backend/UMainForm.pas
+290 -21
View File
@@ -4,12 +4,14 @@ 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.Dialogs, FMX.DialogService,
FMX.TMSFNCTypes, FMX.TMSFNCUtils, FMX.TMSFNCGraphics, FMX.TMSFNCGraphicsTypes,
FMX.TMSFNCCustomControl, FMX.TMSFNCWebBrowser,
PM.HTTPServer, PM.Bridge, PM.QuickUnlock;
PM.HTTPServer, PM.Bridge, PM.QuickUnlock, PM.UserPrefs;
type
TMainForm = class(TForm)
@@ -37,9 +39,17 @@ type
FBridge: TPMBridge;
FPendingURL: string;
FNavTimer: TTimer;
FNavAttempts: Integer;
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;
@@ -52,6 +62,11 @@ type
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
@@ -67,13 +82,19 @@ begin
FServer.OnLog := LogLine;
FBridge := TPMBridge.Create(Self);
FBridge.OnSystemLock := BridgeSystemLock;
FBridge.OnTrayRestore := BridgeTrayRestore;
FBridge.OnLockRequest := BridgeLockRequest;
FBridge.OnQuit := BridgeQuit;
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;
// Wire the cmd:// bridge before any navigation happens.
WebBrowser.OnBeforeNavigate := WebBrowserBeforeNavigate;
WebBrowser.OnInitialized := WebBrowserInitialized;
// Delayed-Navigate timer: TTMSFNCWebBrowser (WebView2 backend) ignores
// Navigate() calls until Edge Chromium finishes its async init (~1-2s).
@@ -88,6 +109,28 @@ begin
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);
@@ -96,7 +139,36 @@ begin
FServer.Free;
end;
procedure TMainForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
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.
@@ -138,20 +210,31 @@ begin
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:' + edtPort.Text + '/index.html';
LogLine('Will navigate embedded browser in ~1.5s to: ' + FPendingURL);
// Schedule a single Navigate after Edge has had time to initialize.
FNavTimer.Enabled := False; // restart timer if already running
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; // one-shot
FNavTimer.Enabled := False;
if FPendingURL = '' then Exit;
LogLine('Navigating to: ' + FPendingURL);
LogLine('Navigating to: ' + MaskAccessToken(FPendingURL));
WebBrowser.Navigate(FPendingURL);
FPendingURL := '';
end;
@@ -162,15 +245,16 @@ var
begin
LPort := StrToIntDef(edtPort.Text, 8765);
try
FServer.Start(LPort);
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);
MessageDlg('Failed to start: ' + E.Message,
TMsgDlgType.mtError, [TMsgDlgBtn.mbOK], 0);
TDialogService.MessageDialog('Failed to start: ' + E.Message,
TMsgDlgType.mtError, [TMsgDlgBtn.mbOK], TMsgDlgBtn.mbOK, 0, nil);
end;
end;
end;
@@ -279,6 +363,17 @@ begin
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.
@@ -332,15 +427,145 @@ begin
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 — lock the vault in the JS layer immediately.
LogLine('Windows session locked — locking vault');
WebBrowser.ExecuteJavaScript('if(typeof lockVault==="function")lockVault()');
// 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;
@@ -375,4 +600,48 @@ begin
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.
delphi-backend/app.ico
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 100 KiB

delphi-backend/app.png
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 7.6 KiB

delphi-backend/assets/assets.res
BIN
View File
Binary file not shown.