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

feat: Delphi backend + JS↔Delphi bridge (clipboard, tray, auto-lock)

Browse Source 
Introduces the Delphi 12 FMX backend (PMServer) that hosts the embedded
WebView2 vault on 127.0.0.1, and a native bridge between JS and Delphi
that wires three privacy-focused features:

1. Secure clipboard
   Copying a password registers the Win32 "ExcludeClipboardContentFromMonitorProcessing"
   format alongside CF_UNICODETEXT, so Win+V clipboard history never sees
   the value. Auto-clears after 30s via TTimer. Bridge.copySecure() in
   app.js routes all password/username/secret copy paths through the
   native layer when running inside the Delphi WebView2 (falls back to
   navigator.clipboard for the PHP standalone).

2. Tray icon (X-to-tray when server running)
   Closing the dev panel hides both the form HWND and the TFMAppClass
   per-process proxy window that owns the FMX taskbar entry — the form's
   HWND alone is not the taskbar-visible one in FMX (took some iteration
   to discover). Tray menu: Open, Lock vault, Quit. Clipboard is force-
   cleared on minimize as extra safety. First-time minimize fires a
   balloon notification so the user knows the app is still running.

3. Auto-lock on Windows session lock (Win+L)
   wtsapi32.dll!WTSRegisterSessionNotification on a dedicated message-only
   window. On WM_WTSSESSION_CHANGE / WTS_SESSION_LOCK, the bridge calls
   ExecuteJavaScript('lockVault()'). Same path used by the tray "Lock vault"
   menu item.

Bridge architecture:
 - JS → Delphi via cmd:// URLs intercepted in OnBeforeNavigate
   (pattern lifted from DeskInsight Monaco). Currently exposes
   cmd://clipboard/copy?text=...&clear=... and cmd://clipboard/clear.
 - Delphi → JS via TTMSFNCWebBrowser.ExecuteJavaScript with guarded
   calls (typeof check) so the bridge degrades cleanly if app.js isn't
   loaded yet.

Files:
 - Source/PM.Bridge.pas (new) — TSecureClipboard + TPMBridge
 - UMainForm.pas/.fmx — bridge wiring, FormCloseQuery intercept, tray
   callbacks (BridgeTrayRestore / BridgeLockRequest / BridgeQuit)
 - js/app.js — Bridge object, 5 navigator.clipboard sites migrated to
   Bridge.copySecure with PHP-compatible fallback, Bridge.onTrayRestore
   handler that resets the auto-lock timer

.gitignore extended with Delphi build artifacts (*.dcu, Win32/, Win64/,
__history/, __recovery/, *.identcache, *.dsk, *.local, etc.) so source
checkouts stay clean.
This commit is contained in:
Zaki
2026-05-22 23:47:57 +01:00
parent 159e02ae81
commit 506aee7e6f
28 changed files with 6172 additions and 1458 deletions
Download Patch File Download Diff File Expand all files Collapse all files
.gitignore
+31
View File
@@ -1,2 +1,33 @@
vault-error.log vault-error.log
# Delphi build artifacts
*.dcu
*.dcp
*.dpu
*.local
*.identcache
*.dsk
*.~dsk
*.~*
*.~bpl
*.~dll
*.~exe
*.exe
*.dll
*.bpl
*.so
*.dylib
__history/
__recovery/
Win32/
Win64/
OSX64/
Android/
iOSDevice64/
# Debug logs (created at runtime next to the exe)
pm-debug.log
# Asset build log (regenerated by BuildAssets.cmd/ps1)
delphi-backend/assets/build.log
delphi-backend/Handlers/PM.Handler.Auth.pas
+343
View File
@@ -0,0 +1,343 @@
unit PM.Handler.Auth;
(*
/register POST body {username, masterPassword} -> {message,token,userId,salt,csrfToken}
/login POST body {username, masterPassword} -> {message,token,userId,salt,csrfToken}
/logout POST auth + csrf -> {message}
/reauth POST auth + csrf + body{masterPassword} -> {message}
Hashing strategy:
- Delphi creates new accounts with PBKDF2-SHA256 100k iterations (hash_algo='pbkdf2'),
same format as PHP hash_pbkdf2. PHP can verify these too.
- For login, we read hash_algo:
pbkdf2 -> verify natively
bcrypt -> reject with clear message (bcrypt verify not implemented yet)
*)
interface
implementation
uses
System.SysUtils, System.JSON, System.Classes,
FireDAC.Comp.Client,
IdCustomHTTPServer,
PM.Router, PM.JSON, PM.Database, PM.Crypto,
PM.Session, PM.RateLimit, PM.Audit;
const
PBKDF2_ITERATIONS = 100000;
DEFAULT_FOLDERS: array[0..4] of string = ('All', 'Social', 'Banking', 'Work', 'Personal');
procedure EnsureDefaultFolders(AUserId: Integer);
var
LQ: TFDQuery;
I: Integer;
begin
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text :=
'INSERT OR IGNORE INTO folders (user_id, name) VALUES (:uid, :name)';
for I := Low(DEFAULT_FOLDERS) to High(DEFAULT_FOLDERS) do
begin
LQ.ParamByName('uid').AsInteger := AUserId;
LQ.ParamByName('name').AsString := DEFAULT_FOLDERS[I];
LQ.ExecSQL;
end;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
end;
procedure SendAuthSuccess(AResponse: TIdHTTPResponseInfo;
AUserId: Integer; const AToken, ASalt, ACSRFToken: string);
var
LObj: TJSONObject;
begin
LObj := TJSONObject.Create;
LObj.AddPair('message', 'OK');
LObj.AddPair('token', AToken);
LObj.AddPair('userId', TJSONNumber.Create(AUserId));
LObj.AddPair('salt', ASalt);
LObj.AddPair('csrfToken', ACSRFToken);
TJSONHelper.SendJSON(AResponse, LObj);
end;
// ===== /register =============================================================
procedure HandleRegister(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
var
LBody: TJSONObject;
LUser, LPwd, LSalt, LHash, LToken, LCSRF, LIP: string;
LQ: TFDQuery;
LUserId: Integer;
begin
LIP := GetClientIP(ARequest);
if CheckRateLimit(LIP) >= 5 then
begin
TJSONHelper.SendError(AResponse, 429, 'Too many attempts. Try again later.');
Exit;
end;
LBody := TJSONHelper.ReadBody(ARequest);
try
LUser := Trim(LBody.GetValue<string>('username', ''));
LPwd := LBody.GetValue<string>('masterPassword', '');
finally
LBody.Free;
end;
if (Length(LUser) < 3) or (Length(LPwd) < 8) then
begin
TJSONHelper.SendError(AResponse, 400, 'Min 3/8 chars');
Exit;
end;
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text := 'SELECT id FROM users WHERE username = :u';
LQ.ParamByName('u').AsString := LUser;
LQ.Open;
if not LQ.IsEmpty then
begin
TJSONHelper.SendError(AResponse, 409, 'Username exists');
Exit;
end;
finally
LQ.Free;
end;
LSalt := RandomHex(32);
LHash := PBKDF2_SHA256_Hex(LPwd, LSalt, PBKDF2_ITERATIONS);
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text :=
'INSERT INTO users (username, password_hash, salt, hash_algo) ' +
'VALUES (:u, :h, :s, ''pbkdf2'')';
LQ.ParamByName('u').AsString := LUser;
LQ.ParamByName('h').AsString := LHash;
LQ.ParamByName('s').AsString := LSalt;
LQ.ExecSQL;
LUserId := DB.Connection.GetLastAutoGenValue('users');
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
EnsureDefaultFolders(LUserId);
CreateSession(LUserId, LToken, LCSRF);
LogAudit(LUserId, 'register', LIP);
SendAuthSuccess(AResponse, LUserId, LToken, LSalt, LCSRF);
end;
// ===== /login ================================================================
procedure HandleLogin(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
var
LBody: TJSONObject;
LUser, LPwd, LSalt, LStoredHash, LAlgo, LToken, LCSRF, LIP: string;
LUserId: Integer;
LQ: TFDQuery;
LComputed: string;
LValid: Boolean;
begin
LIP := GetClientIP(ARequest);
if CheckRateLimit(LIP) >= 10 then
begin
TJSONHelper.SendError(AResponse, 429, 'Too many attempts. Try again later.');
Exit;
end;
LBody := TJSONHelper.ReadBody(ARequest);
try
LUser := Trim(LBody.GetValue<string>('username', ''));
LPwd := LBody.GetValue<string>('masterPassword', '');
finally
LBody.Free;
end;
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text :=
'SELECT id, password_hash, salt, hash_algo FROM users WHERE username = :u';
LQ.ParamByName('u').AsString := LUser;
LQ.Open;
if LQ.IsEmpty then
begin
RecordAttempt(LIP);
TJSONHelper.SendError(AResponse, 401, 'Invalid credentials');
Exit;
end;
LUserId := LQ.FieldByName('id').AsInteger;
LStoredHash := LQ.FieldByName('password_hash').AsString;
LSalt := LQ.FieldByName('salt').AsString;
LAlgo := LQ.FieldByName('hash_algo').AsString;
if LAlgo = '' then LAlgo := 'pbkdf2';
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
LValid := False;
if SameText(LAlgo, 'pbkdf2') then
begin
LComputed := PBKDF2_SHA256_Hex(LPwd, LSalt, PBKDF2_ITERATIONS);
LValid := ConstantTimeEquals(LComputed, LStoredHash);
end
else if SameText(LAlgo, 'bcrypt') then
begin
// Not implemented in Delphi backend yet
RecordAttempt(LIP);
LogAudit(LUserId, 'failed_login_bcrypt', LIP);
TJSONHelper.SendError(AResponse, 501,
'This account was created with bcrypt (PHP). The Delphi backend does ' +
'not verify bcrypt yet. Register a new account here, or login via PHP.');
Exit;
end;
if not LValid then
begin
RecordAttempt(LIP);
LogAudit(LUserId, 'failed_login', LIP);
TJSONHelper.SendError(AResponse, 401, 'Invalid credentials');
Exit;
end;
ClearAttempts(LIP);
DeleteAllUserSessions(LUserId);
EnsureDefaultFolders(LUserId);
CreateSession(LUserId, LToken, LCSRF);
LogAudit(LUserId, 'login', LIP);
SendAuthSuccess(AResponse, LUserId, LToken, LSalt, LCSRF);
end;
// ===== /logout ===============================================================
procedure HandleLogout(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
var
LUserId: Integer;
LToken, LAuth: string;
begin
try
LUserId := Authenticate(ARequest, AResponse);
RequireCSRF(ARequest, AResponse, LUserId);
except
on ESessionRejected do Exit;
end;
LAuth := ARequest.RawHeaders.Values['Authorization'];
if LAuth.StartsWith('Bearer ', True) then
begin
LToken := Copy(LAuth, 8, MaxInt);
DeleteSessionByTokenHash(SHA256Hex(LToken));
end;
LogAudit(LUserId, 'logout', GetClientIP(ARequest));
TJSONHelper.SendOK(AResponse, 'Logged out');
end;
// ===== /reauth ===============================================================
procedure HandleReauth(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
var
LUserId: Integer;
LBody: TJSONObject;
LPwd, LStoredHash, LSalt, LAlgo, LIP, LComputed: string;
LQ: TFDQuery;
LValid: Boolean;
begin
try
LUserId := Authenticate(ARequest, AResponse);
RequireCSRF(ARequest, AResponse, LUserId);
except
on ESessionRejected do Exit;
end;
LIP := GetClientIP(ARequest);
if CheckRateLimit(LIP) >= 5 then
begin
TJSONHelper.SendError(AResponse, 429, 'Too many attempts. Try again later.');
Exit;
end;
LBody := TJSONHelper.ReadBody(ARequest);
try
LPwd := LBody.GetValue<string>('masterPassword', '');
finally
LBody.Free;
end;
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text := 'SELECT password_hash, salt, hash_algo FROM users WHERE id = :uid';
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.Open;
if LQ.IsEmpty then
begin
RecordAttempt(LIP);
TJSONHelper.SendError(AResponse, 401, 'User not found');
Exit;
end;
LStoredHash := LQ.FieldByName('password_hash').AsString;
LSalt := LQ.FieldByName('salt').AsString;
LAlgo := LQ.FieldByName('hash_algo').AsString;
if LAlgo = '' then LAlgo := 'pbkdf2';
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
LValid := False;
if SameText(LAlgo, 'pbkdf2') then
begin
LComputed := PBKDF2_SHA256_Hex(LPwd, LSalt, PBKDF2_ITERATIONS);
LValid := ConstantTimeEquals(LComputed, LStoredHash);
end;
if not LValid then
begin
RecordAttempt(LIP);
LogAudit(LUserId, 'failed_reauth', LIP);
TJSONHelper.SendError(AResponse, 401, 'Invalid password');
Exit;
end;
ClearAttempts(LIP);
LogAudit(LUserId, 'reauth', LIP);
TJSONHelper.SendOK(AResponse, 'OK');
end;
initialization
Router.Register('POST', '/register', HandleRegister);
Router.Register('POST', '/login', HandleLogin);
Router.Register('POST', '/logout', HandleLogout);
Router.Register('POST', '/reauth', HandleReauth);
end.
delphi-backend/Handlers/PM.Handler.Entries.pas
+456
View File
@@ -0,0 +1,456 @@
unit PM.Handler.Entries;
(*
GET /entries?search=&deleted=0 -> JSON array of entries
POST /entries body {site,username,encrypted_password,iv,folder} -> {id,site,username,folder}
PUT /entries/{id} body {site,username,encrypted_password,iv,folder} -> {message}
DELETE /entries/{id}?permanent=0|1 -> {message}
POST /entries/{id}/restore -> {message}
POST /entries/{id}/favorite -> {message}
DELETE /entries/trash/empty -> {message}
*)
interface
implementation
uses
System.SysUtils, System.JSON, System.StrUtils, System.NetEncoding,
Data.DB, FireDAC.Comp.Client, FireDAC.Stan.Param,
IdCustomHTTPServer, IdGlobalProtocols, IdURI,
PM.Router, PM.JSON, PM.Database, PM.Session, PM.Audit, PM.RateLimit;
function GetQueryParam(ARequest: TIdHTTPRequestInfo; const AName: string;
const ADefault: string = ''): string;
begin
Result := ARequest.Params.Values[AName];
if Result = '' then Result := ADefault;
end;
// SQLite DATETIME columns: FireDAC parses to TDateTime internally, then AsString
// would format in system locale (DD/MM/YYYY in French). Force ISO format
// 'yyyy-mm-dd hh:nn:ss' which is what api.php / SQLite text storage uses and
// what the JS frontend parses.
function ISODateTimeField(AField: TField): string;
begin
if AField.IsNull then
Result := ''
else
Result := FormatDateTime('yyyy-mm-dd hh:nn:ss', AField.AsDateTime);
end;
// ===== GET /entries ==========================================================
procedure HandleGetEntries(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
var
LUserId: Integer;
LQ: TFDQuery;
LArr: TJSONArray;
LObj: TJSONObject;
LSearch, LDeletedStr: string;
LDeleted: Integer;
begin
try
LUserId := Authenticate(ARequest, AResponse);
except
on ESessionRejected do Exit;
end;
LSearch := GetQueryParam(ARequest, 'search', '');
LDeletedStr := GetQueryParam(ARequest, 'deleted', '0');
if LDeletedStr = '1' then LDeleted := 1 else LDeleted := 0;
LArr := TJSONArray.Create;
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
if LSearch <> '' then
begin
LQ.SQL.Text :=
'SELECT * FROM vault_entries ' +
'WHERE user_id = :uid AND deleted = :del ' +
'AND (site LIKE :q OR username LIKE :q) ' +
'ORDER BY updated_at DESC';
LQ.ParamByName('q').AsString := '%' + LSearch + '%';
end
else
begin
LQ.SQL.Text :=
'SELECT * FROM vault_entries ' +
'WHERE user_id = :uid AND deleted = :del ' +
'ORDER BY updated_at DESC';
end;
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.ParamByName('del').AsInteger := LDeleted;
LQ.Open;
while not LQ.Eof do
begin
LObj := TJSONObject.Create;
LObj.AddPair('id', TJSONNumber.Create(LQ.FieldByName('id').AsInteger));
LObj.AddPair('site', LQ.FieldByName('site').AsString);
LObj.AddPair('username', LQ.FieldByName('username').AsString);
LObj.AddPair('encrypted_password', LQ.FieldByName('encrypted_password').AsString);
LObj.AddPair('iv', LQ.FieldByName('iv').AsString);
LObj.AddPair('encryption_method', LQ.FieldByName('encryption_method').AsString);
LObj.AddPair('folder', LQ.FieldByName('folder').AsString);
LObj.AddPair('deleted', TJSONNumber.Create(LQ.FieldByName('deleted').AsInteger));
if LQ.FieldByName('deleted_at').IsNull then
LObj.AddPair('deleted_at', TJSONNull.Create)
else
LObj.AddPair('deleted_at', ISODateTimeField(LQ.FieldByName('deleted_at')));
LObj.AddPair('favorite', TJSONNumber.Create(LQ.FieldByName('favorite').AsInteger));
LObj.AddPair('tags', LQ.FieldByName('tags').AsString);
LObj.AddPair('created_at', ISODateTimeField(LQ.FieldByName('created_at')));
LObj.AddPair('updated_at', ISODateTimeField(LQ.FieldByName('updated_at')));
LArr.Add(LObj);
LQ.Next;
end;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
TJSONHelper.SendJSON(AResponse, LArr);
end;
// ===== POST /entries =========================================================
procedure HandleCreateEntry(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
var
LUserId, LNewId: Integer;
LBody, LObj: TJSONObject;
LSite, LUser, LFolder, LEnc, LIV, LTags, LNow: string;
LQ: TFDQuery;
begin
try
LUserId := Authenticate(ARequest, AResponse);
RequireCSRF(ARequest, AResponse, LUserId);
except
on ESessionRejected do Exit;
end;
LBody := TJSONHelper.ReadBody(ARequest);
try
LSite := Trim(LBody.GetValue<string>('site', ''));
LUser := Trim(LBody.GetValue<string>('username', ''));
LFolder := Trim(LBody.GetValue<string>('folder', 'All'));
LEnc := LBody.GetValue<string>('encrypted_password', '');
LIV := LBody.GetValue<string>('iv', '');
LTags := Trim(LBody.GetValue<string>('tags', ''));
finally
LBody.Free;
end;
if (LSite = '') or (LEnc = '') then
begin
TJSONHelper.SendError(AResponse, 400, 'Site & password required');
Exit;
end;
LNow := FormatDateTime('yyyy-mm-dd hh:nn:ss', Now);
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text :=
'INSERT INTO vault_entries ' +
'(user_id, site, username, encrypted_password, iv, encryption_method, ' +
' folder, tags, created_at, updated_at) ' +
'VALUES (:uid, :s, :u, :e, :i, ''client'', :f, :t, :c, :c2)';
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.ParamByName('s').AsString := LSite;
LQ.ParamByName('u').AsString := LUser;
LQ.ParamByName('e').AsString := LEnc;
LQ.ParamByName('i').AsString := LIV;
LQ.ParamByName('f').AsString := LFolder;
LQ.ParamByName('t').AsString := LTags;
LQ.ParamByName('c').AsString := LNow;
LQ.ParamByName('c2').AsString := LNow;
LQ.ExecSQL;
LNewId := DB.Connection.GetLastAutoGenValue('vault_entries');
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
LogAudit(LUserId, 'add_entry', GetClientIP(ARequest));
LObj := TJSONObject.Create;
LObj.AddPair('id', TJSONNumber.Create(LNewId));
LObj.AddPair('site', LSite);
LObj.AddPair('username', LUser);
LObj.AddPair('folder', LFolder);
LObj.AddPair('tags', LTags);
TJSONHelper.SendJSON(AResponse, LObj);
end;
// ===== PUT /entries/{id} =====================================================
procedure HandleUpdateEntry(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
var
LUserId, LId: Integer;
LBody: TJSONObject;
LSite, LUser, LFolder, LEnc, LIV, LTags, LNow: string;
LQ: TFDQuery;
begin
try
LUserId := Authenticate(ARequest, AResponse);
RequireCSRF(ARequest, AResponse, LUserId);
except
on ESessionRejected do Exit;
end;
LId := StrToIntDef(AParams[0], 0);
if LId = 0 then
begin
TJSONHelper.SendError(AResponse, 400, 'Invalid id');
Exit;
end;
LBody := TJSONHelper.ReadBody(ARequest);
try
LSite := Trim(LBody.GetValue<string>('site', ''));
LUser := Trim(LBody.GetValue<string>('username', ''));
LFolder := Trim(LBody.GetValue<string>('folder', 'All'));
LEnc := LBody.GetValue<string>('encrypted_password', '');
LIV := LBody.GetValue<string>('iv', '');
LTags := Trim(LBody.GetValue<string>('tags', ''));
finally
LBody.Free;
end;
if (LSite = '') or (LEnc = '') then
begin
TJSONHelper.SendError(AResponse, 400, 'Site & password required');
Exit;
end;
LNow := FormatDateTime('yyyy-mm-dd hh:nn:ss', Now);
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text :=
'UPDATE vault_entries ' +
'SET site=:s, username=:u, encrypted_password=:e, iv=:i, ' +
' folder=:f, tags=:t, updated_at=:c ' +
'WHERE id=:id AND user_id=:uid';
LQ.ParamByName('s').AsString := LSite;
LQ.ParamByName('u').AsString := LUser;
LQ.ParamByName('e').AsString := LEnc;
LQ.ParamByName('i').AsString := LIV;
LQ.ParamByName('f').AsString := LFolder;
LQ.ParamByName('t').AsString := LTags;
LQ.ParamByName('c').AsString := LNow;
LQ.ParamByName('id').AsInteger := LId;
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.ExecSQL;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
LogAudit(LUserId, 'edit_entry', GetClientIP(ARequest));
TJSONHelper.SendOK(AResponse, 'Updated');
end;
// ===== DELETE /entries/{id} ==================================================
procedure HandleDeleteEntry(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
var
LUserId, LId: Integer;
LPermanent: Boolean;
LQ: TFDQuery;
begin
try
LUserId := Authenticate(ARequest, AResponse);
RequireCSRF(ARequest, AResponse, LUserId);
except
on ESessionRejected do Exit;
end;
LId := StrToIntDef(AParams[0], 0);
if LId = 0 then
begin
TJSONHelper.SendError(AResponse, 400, 'Invalid id');
Exit;
end;
LPermanent := GetQueryParam(ARequest, 'permanent', '0') = '1';
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
if LPermanent then
LQ.SQL.Text := 'DELETE FROM vault_entries WHERE id=:id AND user_id=:uid'
else
LQ.SQL.Text :=
'UPDATE vault_entries SET deleted=1, deleted_at=datetime(''now'') ' +
'WHERE id=:id AND user_id=:uid';
LQ.ParamByName('id').AsInteger := LId;
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.ExecSQL;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
if LPermanent then
LogAudit(LUserId, 'permanent_delete', GetClientIP(ARequest))
else
LogAudit(LUserId, 'delete_entry', GetClientIP(ARequest));
TJSONHelper.SendOK(AResponse, 'Deleted');
end;
// ===== POST /entries/{id}/restore ============================================
procedure HandleRestoreEntry(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
var
LUserId, LId: Integer;
LQ: TFDQuery;
begin
try
LUserId := Authenticate(ARequest, AResponse);
RequireCSRF(ARequest, AResponse, LUserId);
except
on ESessionRejected do Exit;
end;
LId := StrToIntDef(AParams[0], 0);
if LId = 0 then
begin
TJSONHelper.SendError(AResponse, 400, 'Invalid id');
Exit;
end;
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text :=
'UPDATE vault_entries SET deleted=0, deleted_at=NULL, ' +
' updated_at=datetime(''now'') ' +
'WHERE id=:id AND user_id=:uid';
LQ.ParamByName('id').AsInteger := LId;
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.ExecSQL;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
LogAudit(LUserId, 'restore_entry', GetClientIP(ARequest));
TJSONHelper.SendOK(AResponse, 'Restored');
end;
// ===== POST /entries/{id}/favorite ===========================================
procedure HandleToggleFavorite(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
var
LUserId, LId: Integer;
LQ: TFDQuery;
begin
try
LUserId := Authenticate(ARequest, AResponse);
RequireCSRF(ARequest, AResponse, LUserId);
except
on ESessionRejected do Exit;
end;
LId := StrToIntDef(AParams[0], 0);
if LId = 0 then
begin
TJSONHelper.SendError(AResponse, 400, 'Invalid id');
Exit;
end;
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text :=
'UPDATE vault_entries ' +
'SET favorite = CASE WHEN favorite=1 THEN 0 ELSE 1 END ' +
'WHERE id=:id AND user_id=:uid';
LQ.ParamByName('id').AsInteger := LId;
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.ExecSQL;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
LogAudit(LUserId, 'toggle_favorite', GetClientIP(ARequest));
TJSONHelper.SendOK(AResponse, 'Toggled');
end;
// ===== DELETE /entries/trash/empty ===========================================
procedure HandleEmptyTrash(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
var
LUserId: Integer;
LQ: TFDQuery;
begin
try
LUserId := Authenticate(ARequest, AResponse);
RequireCSRF(ARequest, AResponse, LUserId);
except
on ESessionRejected do Exit;
end;
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text := 'DELETE FROM vault_entries WHERE user_id=:uid AND deleted=1';
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.ExecSQL;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
LogAudit(LUserId, 'empty_trash', GetClientIP(ARequest));
TJSONHelper.SendOK(AResponse, 'Trash emptied');
end;
initialization
// /entries/trash/empty must be registered BEFORE /entries/{id} to win the regex match
Router.Register('DELETE', '/entries/trash/empty', HandleEmptyTrash);
Router.Register('POST', '/entries/(\d+)/restore', HandleRestoreEntry);
Router.Register('POST', '/entries/(\d+)/favorite', HandleToggleFavorite);
Router.Register('GET', '/entries', HandleGetEntries);
Router.Register('POST', '/entries', HandleCreateEntry);
Router.Register('PUT', '/entries/(\d+)', HandleUpdateEntry);
Router.Register('DELETE', '/entries/(\d+)', HandleDeleteEntry);
end.
delphi-backend/Handlers/PM.Handler.Folders.pas
+200
View File
@@ -0,0 +1,200 @@
unit PM.Handler.Folders;
(*
GET /folders -> JSON array of folder names
POST /folders body {name} -> {message,name}
DELETE /folders/{name} -> {message}
*)
interface
implementation
uses
System.SysUtils, System.JSON, System.NetEncoding,
FireDAC.Comp.Client, FireDAC.Stan.Param,
IdCustomHTTPServer,
PM.Router, PM.JSON, PM.Database, PM.Session, PM.Audit, PM.RateLimit;
// ===== GET /folders ==========================================================
procedure HandleGetFolders(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
var
LUserId: Integer;
LQ: TFDQuery;
LArr: TJSONArray;
begin
try
LUserId := Authenticate(ARequest, AResponse);
except
on ESessionRejected do Exit;
end;
LArr := TJSONArray.Create;
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text := 'SELECT name FROM folders WHERE user_id = :uid ORDER BY name';
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.Open;
while not LQ.Eof do
begin
LArr.Add(LQ.FieldByName('name').AsString);
LQ.Next;
end;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
TJSONHelper.SendJSON(AResponse, LArr);
end;
// ===== POST /folders =========================================================
procedure HandleCreateFolder(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
var
LUserId: Integer;
LBody: TJSONObject;
LName: string;
LQ: TFDQuery;
LObj: TJSONObject;
begin
try
LUserId := Authenticate(ARequest, AResponse);
RequireCSRF(ARequest, AResponse, LUserId);
except
on ESessionRejected do Exit;
end;
LBody := TJSONHelper.ReadBody(ARequest);
try
LName := Trim(LBody.GetValue<string>('name', ''));
finally
LBody.Free;
end;
if LName = '' then
begin
TJSONHelper.SendError(AResponse, 400, 'Folder name required');
Exit;
end;
if SameText(LName, 'All') then
begin
TJSONHelper.SendError(AResponse, 400, 'Cannot use All');
Exit;
end;
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text := 'INSERT INTO folders (user_id, name) VALUES (:uid, :name)';
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.ParamByName('name').AsString := LName;
try
LQ.ExecSQL;
except
on E: Exception do
begin
TJSONHelper.SendError(AResponse, 409, 'Folder exists');
Exit;
end;
end;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
LogAudit(LUserId, 'add_folder', GetClientIP(ARequest));
LObj := TJSONObject.Create;
LObj.AddPair('message', 'Created');
LObj.AddPair('name', LName);
TJSONHelper.SendJSON(AResponse, LObj);
end;
// ===== DELETE /folders/{name} ================================================
procedure HandleDeleteFolder(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
var
LUserId: Integer;
LName: string;
LQ: TFDQuery;
LChanges: Integer;
begin
try
LUserId := Authenticate(ARequest, AResponse);
RequireCSRF(ARequest, AResponse, LUserId);
except
on ESessionRejected do Exit;
end;
if Length(AParams) < 1 then
begin
TJSONHelper.SendError(AResponse, 400, 'Folder name required');
Exit;
end;
LName := TNetEncoding.URL.Decode(AParams[0]);
if SameText(LName, 'All') then
begin
TJSONHelper.SendError(AResponse, 400, 'Cannot delete All');
Exit;
end;
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text := 'DELETE FROM folders WHERE user_id = :uid AND name = :name';
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.ParamByName('name').AsString := LName;
LQ.ExecSQL;
LChanges := LQ.RowsAffected;
finally
LQ.Free;
end;
if LChanges = 0 then
begin
TJSONHelper.SendError(AResponse, 404, 'Not found');
Exit;
end;
// Reassign entries from the deleted folder to 'All'
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text :=
'UPDATE vault_entries SET folder = ''All'' ' +
'WHERE user_id = :uid AND folder = :name';
LQ.ParamByName('uid').AsInteger := LUserId;
LQ.ParamByName('name').AsString := LName;
LQ.ExecSQL;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
LogAudit(LUserId, 'delete_folder', GetClientIP(ARequest));
TJSONHelper.SendOK(AResponse, 'Deleted');
end;
initialization
Router.Register('GET', '/folders', HandleGetFolders);
Router.Register('POST', '/folders', HandleCreateFolder);
Router.Register('DELETE', '/folders/(.+)', HandleDeleteFolder);
end.
delphi-backend/Handlers/PM.Handler.Passkey.pas
+47
View File
@@ -0,0 +1,47 @@
unit PM.Handler.Passkey;
(*
WebAuthn / Passkey endpoints — stubbed to 501 Not Implemented.
Why stubbed: full WebAuthn server requires:
- CBOR decoder for COSE keys + attestation objects
- DER ASN.1 encoder for ES256/RS256 public keys
- ECDSA P-256 signature verification (no native Delphi support)
- Challenge management with constant-time compares
Roughly 500-700 lines of crypto-sensitive code. The PHP version (api.php
lines 168-657) handles this with OpenSSL bindings. A faithful Delphi port
would either bind libssl/libcrypto DLLs or pull in a pure-Pascal EC lib.
For v1 of the Delphi backend we return 501 with a clear message so the
frontend gracefully falls back to master password login. The PHP backend
remains the reference for passkey-enabled deployments.
When implemented, see:
api.php :169-211 cbor_decode, derLen, coseToPem
api.php :537-657 register/begin, register/complete, login/begin, login/complete
*)
interface
implementation
uses
System.SysUtils,
IdCustomHTTPServer,
PM.Router, PM.JSON;
procedure HandleStub(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
begin
TJSONHelper.SendError(AResponse, 501,
'Passkey/WebAuthn is not implemented in the Delphi backend yet. ' +
'Use master-password login, or run the PHP backend for passkey support.');
end;
initialization
Router.Register('POST', '/passkey/register/begin', HandleStub);
Router.Register('POST', '/passkey/register/complete', HandleStub);
Router.Register('POST', '/passkey/login/begin', HandleStub);
Router.Register('POST', '/passkey/login/complete', HandleStub);
end.
delphi-backend/Handlers/PM.Handler.Ping.pas
+31
View File
@@ -0,0 +1,31 @@
unit PM.Handler.Ping;
(*
Minimal stub route to verify the build/run pipeline.
GET /ping returns a small JSON object with message=pong and server=delphi.
*)
interface
implementation
uses
System.JSON, System.SysUtils,
IdCustomHTTPServer,
PM.Router, PM.JSON;
procedure HandlePing(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; const AParams: TArray<string>);
var
LObj: TJSONObject;
begin
LObj := TJSONObject.Create;
LObj.AddPair('message', 'pong');
LObj.AddPair('server', 'delphi');
TJSONHelper.SendJSON(AResponse, LObj);
end;
initialization
Router.Register('GET', '/ping', HandlePing);
end.
delphi-backend/PMServer.dpr
+31
View File
@@ -0,0 +1,31 @@
program PMServer;
uses
System.StartUpCopy,
FMX.Forms,
UMainForm in 'UMainForm.pas' {MainForm},
PM.JSON in 'Source\PM.JSON.pas',
PM.Database in 'Source\PM.Database.pas',
PM.Router in 'Source\PM.Router.pas',
PM.StaticFiles in 'Source\PM.StaticFiles.pas',
PM.EmbeddedAssets in 'Source\PM.EmbeddedAssets.pas',
PM.Crypto in 'Source\PM.Crypto.pas',
PM.RateLimit in 'Source\PM.RateLimit.pas',
PM.Audit in 'Source\PM.Audit.pas',
PM.Session in 'Source\PM.Session.pas',
PM.HTTPServer in 'Source\PM.HTTPServer.pas',
PM.Bridge in 'Source\PM.Bridge.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';
{$R *.res}
{$R assets\assets.res}
begin
Application.Initialize;
Application.CreateForm(TMainForm, MainForm);
Application.Run;
end.
delphi-backend/PMServer.dproj
+270
View File
@@ -0,0 +1,270 @@
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<ProjectGuid>{59A8733F-111A-41EC-80BE-9848275FC80D}</ProjectGuid>
<MainSource>PMServer.dpr</MainSource>
<Base>True</Base>
<Config Condition="'$(Config)'==''">Debug</Config>
<TargetedPlatforms>693249</TargetedPlatforms>
<AppType>Application</AppType>
<FrameworkType>FMX</FrameworkType>
<ProjectVersion>20.1</ProjectVersion>
<Platform Condition="'$(Platform)'==''">Win32</Platform>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''">
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Android' and '$(Base)'=='true') or '$(Base_Android)'!=''">
<Base_Android>true</Base_Android>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Android64' and '$(Base)'=='true') or '$(Base_Android64)'!=''">
<Base_Android64>true</Base_Android64>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='iOSDevice64' and '$(Base)'=='true') or '$(Base_iOSDevice64)'!=''">
<Base_iOSDevice64>true</Base_iOSDevice64>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''">
<Base_Win32>true</Base_Win32>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''">
<Base_Win64>true</Base_Win64>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''">
<Cfg_1>true</Cfg_1>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_1)'=='true') or '$(Cfg_1_Win32)'!=''">
<Cfg_1_Win32>true</Cfg_1_Win32>
<CfgParent>Cfg_1</CfgParent>
<Cfg_1>true</Cfg_1>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''">
<Cfg_2>true</Cfg_2>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Android64' and '$(Cfg_2)'=='true') or '$(Cfg_2_Android64)'!=''">
<Cfg_2_Android64>true</Cfg_2_Android64>
<CfgParent>Cfg_2</CfgParent>
<Cfg_2>true</Cfg_2>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='iOSDevice64' and '$(Cfg_2)'=='true') or '$(Cfg_2_iOSDevice64)'!=''">
<Cfg_2_iOSDevice64>true</Cfg_2_iOSDevice64>
<CfgParent>Cfg_2</CfgParent>
<Cfg_2>true</Cfg_2>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='OSX64' and '$(Cfg_2)'=='true') or '$(Cfg_2_OSX64)'!=''">
<Cfg_2_OSX64>true</Cfg_2_OSX64>
<CfgParent>Cfg_2</CfgParent>
<Cfg_2>true</Cfg_2>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='OSXARM64' and '$(Cfg_2)'=='true') or '$(Cfg_2_OSXARM64)'!=''">
<Cfg_2_OSXARM64>true</Cfg_2_OSXARM64>
<CfgParent>Cfg_2</CfgParent>
<Cfg_2>true</Cfg_2>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win32)'!=''">
<Cfg_2_Win32>true</Cfg_2_Win32>
<CfgParent>Cfg_2</CfgParent>
<Cfg_2>true</Cfg_2>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Base)'!=''">
<DCC_E>false</DCC_E>
<DCC_F>false</DCC_F>
<DCC_K>false</DCC_K>
<DCC_N>false</DCC_N>
<DCC_S>false</DCC_S>
<DCC_ImageBase>00400000</DCC_ImageBase>
<SanitizedProjectName>PMServer</SanitizedProjectName>
<VerInfo_Locale>1036</VerInfo_Locale>
<VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=</VerInfo_Keys>
<DCC_Namespace>System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace)</DCC_Namespace>
<Icon_MainIcon>$(BDS)\bin\delphi_PROJECTICON.ico</Icon_MainIcon>
<Icns_MainIcns>$(BDS)\bin\delphi_PROJECTICNS.icns</Icns_MainIcns>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_Android)'!=''">
<VerInfo_Keys>package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=auto;largeHeap=False;theme=TitleBar;hardwareAccelerated=true;apiKey=</VerInfo_Keys>
<BT_BuildType>Debug</BT_BuildType>
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
<Android_LauncherIcon36>$(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png</Android_LauncherIcon36>
<Android_LauncherIcon48>$(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png</Android_LauncherIcon48>
<Android_LauncherIcon72>$(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png</Android_LauncherIcon72>
<Android_LauncherIcon96>$(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png</Android_LauncherIcon96>
<Android_LauncherIcon144>$(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png</Android_LauncherIcon144>
<Android_SplashImage426>$(BDS)\bin\Artwork\Android\FM_SplashImage_426x320.png</Android_SplashImage426>
<Android_SplashImage470>$(BDS)\bin\Artwork\Android\FM_SplashImage_470x320.png</Android_SplashImage470>
<Android_SplashImage640>$(BDS)\bin\Artwork\Android\FM_SplashImage_640x480.png</Android_SplashImage640>
<Android_SplashImage960>$(BDS)\bin\Artwork\Android\FM_SplashImage_960x720.png</Android_SplashImage960>
<AUP_ACCESS_COARSE_LOCATION>true</AUP_ACCESS_COARSE_LOCATION>
<AUP_ACCESS_FINE_LOCATION>true</AUP_ACCESS_FINE_LOCATION>
<AUP_CALL_PHONE>true</AUP_CALL_PHONE>
<AUP_CAMERA>true</AUP_CAMERA>
<AUP_INTERNET>true</AUP_INTERNET>
<AUP_READ_CALENDAR>true</AUP_READ_CALENDAR>
<AUP_READ_EXTERNAL_STORAGE>true</AUP_READ_EXTERNAL_STORAGE>
<AUP_WRITE_CALENDAR>true</AUP_WRITE_CALENDAR>
<AUP_WRITE_EXTERNAL_STORAGE>true</AUP_WRITE_EXTERNAL_STORAGE>
<AUP_READ_PHONE_STATE>true</AUP_READ_PHONE_STATE>
<Android_NotificationIcon24>$(BDS)\bin\Artwork\Android\FM_NotificationIcon_24x24.png</Android_NotificationIcon24>
<Android_NotificationIcon36>$(BDS)\bin\Artwork\Android\FM_NotificationIcon_36x36.png</Android_NotificationIcon36>
<Android_NotificationIcon48>$(BDS)\bin\Artwork\Android\FM_NotificationIcon_48x48.png</Android_NotificationIcon48>
<Android_NotificationIcon72>$(BDS)\bin\Artwork\Android\FM_NotificationIcon_72x72.png</Android_NotificationIcon72>
<Android_NotificationIcon96>$(BDS)\bin\Artwork\Android\FM_NotificationIcon_96x96.png</Android_NotificationIcon96>
<Android_LauncherIcon192>$(BDS)\bin\Artwork\Android\FM_LauncherIcon_192x192.png</Android_LauncherIcon192>
<EnabledSysJars>activity-1.7.2.dex.jar;annotation-experimental-1.3.0.dex.jar;annotation-jvm-1.6.0.dex.jar;annotations-13.0.dex.jar;appcompat-1.2.0.dex.jar;appcompat-resources-1.2.0.dex.jar;billing-6.0.1.dex.jar;biometric-1.1.0.dex.jar;browser-1.4.0.dex.jar;cloud-messaging.dex.jar;collection-1.1.0.dex.jar;concurrent-futures-1.1.0.dex.jar;core-1.10.1.dex.jar;core-common-2.2.0.dex.jar;core-ktx-1.10.1.dex.jar;core-runtime-2.2.0.dex.jar;cursoradapter-1.0.0.dex.jar;customview-1.0.0.dex.jar;documentfile-1.0.0.dex.jar;drawerlayout-1.0.0.dex.jar;error_prone_annotations-2.9.0.dex.jar;exifinterface-1.3.6.dex.jar;firebase-annotations-16.2.0.dex.jar;firebase-common-20.3.1.dex.jar;firebase-components-17.1.0.dex.jar;firebase-datatransport-18.1.7.dex.jar;firebase-encoders-17.0.0.dex.jar;firebase-encoders-json-18.0.0.dex.jar;firebase-encoders-proto-16.0.0.dex.jar;firebase-iid-interop-17.1.0.dex.jar;firebase-installations-17.1.3.dex.jar;firebase-installations-interop-17.1.0.dex.jar;firebase-measurement-connector-19.0.0.dex.jar;firebase-messaging-23.1.2.dex.jar;fragment-1.2.5.dex.jar;google-play-licensing.dex.jar;interpolator-1.0.0.dex.jar;javax.inject-1.dex.jar;kotlin-stdlib-1.8.22.dex.jar;kotlin-stdlib-common-1.8.22.dex.jar;kotlin-stdlib-jdk7-1.8.22.dex.jar;kotlin-stdlib-jdk8-1.8.22.dex.jar;kotlinx-coroutines-android-1.6.4.dex.jar;kotlinx-coroutines-core-jvm-1.6.4.dex.jar;legacy-support-core-utils-1.0.0.dex.jar;lifecycle-common-2.6.1.dex.jar;lifecycle-livedata-2.6.1.dex.jar;lifecycle-livedata-core-2.6.1.dex.jar;lifecycle-runtime-2.6.1.dex.jar;lifecycle-service-2.6.1.dex.jar;lifecycle-viewmodel-2.6.1.dex.jar;lifecycle-viewmodel-savedstate-2.6.1.dex.jar;listenablefuture-1.0.dex.jar;loader-1.0.0.dex.jar;localbroadcastmanager-1.0.0.dex.jar;okio-jvm-3.4.0.dex.jar;play-services-ads-22.2.0.dex.jar;play-services-ads-base-22.2.0.dex.jar;play-services-ads-identifier-18.0.0.dex.jar;play-services-ads-lite-22.2.0.dex.jar;play-services-appset-16.0.1.dex.jar;play-services-base-18.1.0.dex.jar;play-services-basement-18.1.0.dex.jar;play-services-cloud-messaging-17.0.1.dex.jar;play-services-location-21.0.1.dex.jar;play-services-maps-18.1.0.dex.jar;play-services-measurement-base-20.1.2.dex.jar;play-services-measurement-sdk-api-20.1.2.dex.jar;play-services-stats-17.0.2.dex.jar;play-services-tasks-18.0.2.dex.jar;print-1.0.0.dex.jar;profileinstaller-1.3.0.dex.jar;room-common-2.2.5.dex.jar;room-runtime-2.2.5.dex.jar;savedstate-1.2.1.dex.jar;sqlite-2.1.0.dex.jar;sqlite-framework-2.1.0.dex.jar;startup-runtime-1.1.1.dex.jar;tracing-1.0.0.dex.jar;transport-api-3.0.0.dex.jar;transport-backend-cct-3.1.8.dex.jar;transport-runtime-3.1.8.dex.jar;user-messaging-platform-2.0.0.dex.jar;vectordrawable-1.1.0.dex.jar;vectordrawable-animated-1.1.0.dex.jar;versionedparcelable-1.1.1.dex.jar;viewpager-1.0.0.dex.jar;work-runtime-2.7.0.dex.jar</EnabledSysJars>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_Android64)'!=''">
<Android_LauncherIcon192>$(BDS)\bin\Artwork\Android\FM_LauncherIcon_192x192.png</Android_LauncherIcon192>
<EnabledSysJars>activity-1.7.2.dex.jar;annotation-experimental-1.3.0.dex.jar;annotation-jvm-1.6.0.dex.jar;annotations-13.0.dex.jar;appcompat-1.2.0.dex.jar;appcompat-resources-1.2.0.dex.jar;billing-6.0.1.dex.jar;biometric-1.1.0.dex.jar;browser-1.4.0.dex.jar;cloud-messaging.dex.jar;collection-1.1.0.dex.jar;concurrent-futures-1.1.0.dex.jar;core-1.10.1.dex.jar;core-common-2.2.0.dex.jar;core-ktx-1.10.1.dex.jar;core-runtime-2.2.0.dex.jar;cursoradapter-1.0.0.dex.jar;customview-1.0.0.dex.jar;documentfile-1.0.0.dex.jar;drawerlayout-1.0.0.dex.jar;error_prone_annotations-2.9.0.dex.jar;exifinterface-1.3.6.dex.jar;firebase-annotations-16.2.0.dex.jar;firebase-common-20.3.1.dex.jar;firebase-components-17.1.0.dex.jar;firebase-datatransport-18.1.7.dex.jar;firebase-encoders-17.0.0.dex.jar;firebase-encoders-json-18.0.0.dex.jar;firebase-encoders-proto-16.0.0.dex.jar;firebase-iid-interop-17.1.0.dex.jar;firebase-installations-17.1.3.dex.jar;firebase-installations-interop-17.1.0.dex.jar;firebase-measurement-connector-19.0.0.dex.jar;firebase-messaging-23.1.2.dex.jar;fragment-1.2.5.dex.jar;google-play-licensing.dex.jar;interpolator-1.0.0.dex.jar;javax.inject-1.dex.jar;kotlin-stdlib-1.8.22.dex.jar;kotlin-stdlib-common-1.8.22.dex.jar;kotlin-stdlib-jdk7-1.8.22.dex.jar;kotlin-stdlib-jdk8-1.8.22.dex.jar;kotlinx-coroutines-android-1.6.4.dex.jar;kotlinx-coroutines-core-jvm-1.6.4.dex.jar;legacy-support-core-utils-1.0.0.dex.jar;lifecycle-common-2.6.1.dex.jar;lifecycle-livedata-2.6.1.dex.jar;lifecycle-livedata-core-2.6.1.dex.jar;lifecycle-runtime-2.6.1.dex.jar;lifecycle-service-2.6.1.dex.jar;lifecycle-viewmodel-2.6.1.dex.jar;lifecycle-viewmodel-savedstate-2.6.1.dex.jar;listenablefuture-1.0.dex.jar;loader-1.0.0.dex.jar;localbroadcastmanager-1.0.0.dex.jar;okio-jvm-3.4.0.dex.jar;play-services-ads-22.2.0.dex.jar;play-services-ads-base-22.2.0.dex.jar;play-services-ads-identifier-18.0.0.dex.jar;play-services-ads-lite-22.2.0.dex.jar;play-services-appset-16.0.1.dex.jar;play-services-base-18.1.0.dex.jar;play-services-basement-18.1.0.dex.jar;play-services-cloud-messaging-17.0.1.dex.jar;play-services-location-21.0.1.dex.jar;play-services-maps-18.1.0.dex.jar;play-services-measurement-base-20.1.2.dex.jar;play-services-measurement-sdk-api-20.1.2.dex.jar;play-services-stats-17.0.2.dex.jar;play-services-tasks-18.0.2.dex.jar;print-1.0.0.dex.jar;profileinstaller-1.3.0.dex.jar;room-common-2.2.5.dex.jar;room-runtime-2.2.5.dex.jar;savedstate-1.2.1.dex.jar;sqlite-2.1.0.dex.jar;sqlite-framework-2.1.0.dex.jar;startup-runtime-1.1.1.dex.jar;tracing-1.0.0.dex.jar;transport-api-3.0.0.dex.jar;transport-backend-cct-3.1.8.dex.jar;transport-runtime-3.1.8.dex.jar;user-messaging-platform-2.0.0.dex.jar;vectordrawable-1.1.0.dex.jar;vectordrawable-animated-1.1.0.dex.jar;versionedparcelable-1.1.1.dex.jar;viewpager-1.0.0.dex.jar;work-runtime-2.7.0.dex.jar</EnabledSysJars>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_iOSDevice64)'!=''">
<iPhone_Setting87>$(BDS)\bin\Artwork\iOS\iPhone\FM_SettingIcon_87x87.png</iPhone_Setting87>
<iPhone_AppIcon180>$(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_180x180.png</iPhone_AppIcon180>
<iPhone_Spotlight120>$(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_120x120.png</iPhone_Spotlight120>
<iPad_AppIcon167>$(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_167x167.png</iPad_AppIcon167>
<iPhone_Launch2x>$(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_2x.png</iPhone_Launch2x>
<iPhone_LaunchDark2x>$(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImageDark_2x.png</iPhone_LaunchDark2x>
<iPhone_Launch3x>$(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_3x.png</iPhone_Launch3x>
<iPhone_LaunchDark3x>$(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImageDark_3x.png</iPhone_LaunchDark3x>
<iPad_Launch2x>$(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImage_2x.png</iPad_Launch2x>
<iPad_LaunchDark2x>$(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageDark_2x.png</iPad_LaunchDark2x>
<iOS_AppStore1024>$(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_1024x1024.png</iOS_AppStore1024>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_Win32)'!=''">
<DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace>
<BT_BuildType>Debug</BT_BuildType>
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
<VerInfo_Keys>CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName)</VerInfo_Keys>
<VerInfo_Locale>1033</VerInfo_Locale>
<Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File>
<UWP_DelphiLogo44>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png</UWP_DelphiLogo44>
<UWP_DelphiLogo150>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png</UWP_DelphiLogo150>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_Win64)'!=''">
<UWP_DelphiLogo44>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png</UWP_DelphiLogo44>
<UWP_DelphiLogo150>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png</UWP_DelphiLogo150>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_1)'!=''">
<DCC_Define>RELEASE;$(DCC_Define)</DCC_Define>
<DCC_DebugInformation>0</DCC_DebugInformation>
<DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols>
<DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_1_Win32)'!=''">
<AppDPIAwarenessMode>PerMonitorV2</AppDPIAwarenessMode>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2)'!=''">
<DCC_Define>DEBUG;$(DCC_Define)</DCC_Define>
<DCC_Optimize>false</DCC_Optimize>
<DCC_GenerateStackFrames>true</DCC_GenerateStackFrames>
<DCC_RangeChecking>true</DCC_RangeChecking>
<DCC_IntegerOverflowCheck>true</DCC_IntegerOverflowCheck>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2_Android64)'!=''">
<BT_BuildType>Debug</BT_BuildType>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2_iOSDevice64)'!=''">
<BT_BuildType>Debug</BT_BuildType>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2_OSX64)'!=''">
<BT_BuildType>Debug</BT_BuildType>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2_OSXARM64)'!=''">
<BT_BuildType>Debug</BT_BuildType>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2_Win32)'!=''">
<AppDPIAwarenessMode>PerMonitorV2</AppDPIAwarenessMode>
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
<VerInfo_Locale>1033</VerInfo_Locale>
<VerInfo_Keys>CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName)</VerInfo_Keys>
<PreBuildEvent><![CDATA["Z:\password-manager\delphi-backend\assets\BuildAssets.cmd"
$(PreBuildEvent)]]></PreBuildEvent>
</PropertyGroup>
<ItemGroup>
<DelphiCompile Include="$(MainSource)">
<MainSource>MainSource</MainSource>
</DelphiCompile>
<DCCReference Include="UMainForm.pas">
<Form>MainForm</Form>
</DCCReference>
<DCCReference Include="Source\PM.JSON.pas"/>
<DCCReference Include="Source\PM.Database.pas"/>
<DCCReference Include="Source\PM.Router.pas"/>
<DCCReference Include="Source\PM.StaticFiles.pas"/>
<DCCReference Include="Source\PM.EmbeddedAssets.pas"/>
<DCCReference Include="Source\PM.Crypto.pas"/>
<DCCReference Include="Source\PM.RateLimit.pas"/>
<DCCReference Include="Source\PM.Audit.pas"/>
<DCCReference Include="Source\PM.Session.pas"/>
<DCCReference Include="Source\PM.HTTPServer.pas"/>
<DCCReference Include="Source\PM.Bridge.pas"/>
<DCCReference Include="Handlers\PM.Handler.Ping.pas"/>
<DCCReference Include="Handlers\PM.Handler.Auth.pas"/>
<DCCReference Include="Handlers\PM.Handler.Folders.pas"/>
<DCCReference Include="Handlers\PM.Handler.Entries.pas"/>
<DCCReference Include="Handlers\PM.Handler.Passkey.pas"/>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>
<BuildConfiguration Include="Release">
<Key>Cfg_1</Key>
<CfgParent>Base</CfgParent>
</BuildConfiguration>
<BuildConfiguration Include="Debug">
<Key>Cfg_2</Key>
<CfgParent>Base</CfgParent>
</BuildConfiguration>
</ItemGroup>
<ProjectExtensions>
<Borland.Personality>Delphi.Personality.12</Borland.Personality>
<Borland.ProjectType/>
<BorlandProject>
<Delphi.Personality>
<Source>
<Source Name="MainSource">PMServer.dpr</Source>
</Source>
<Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\dcloffice2k290.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\dclofficexp290.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages>
</Excluded_Packages>
</Delphi.Personality>
<Platforms>
<Platform value="Android">False</Platform>
<Platform value="Android64">True</Platform>
<Platform value="iOSDevice64">True</Platform>
<Platform value="iOSSimARM64">True</Platform>
<Platform value="OSX64">True</Platform>
<Platform value="OSXARM64">True</Platform>
<Platform value="Win32">True</Platform>
<Platform value="Win64">False</Platform>
</Platforms>
</BorlandProject>
<ProjectFileVersion>12</ProjectFileVersion>
</ProjectExtensions>
<Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/>
<Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/>
<PropertyGroup Condition="'$(Config)'=='Debug' And '$(Platform)'=='Win32'">
<PreBuildEvent>&quot;Z:\password-manager\delphi-backend\assets\BuildAssets.cmd&quot;</PreBuildEvent>
<PreBuildEventIgnoreExitCode>False</PreBuildEventIgnoreExitCode>
<PreLinkEvent/>
<PreLinkEventIgnoreExitCode>False</PreLinkEventIgnoreExitCode>
<PostBuildEvent/>
<PostBuildEventIgnoreExitCode>False</PostBuildEventIgnoreExitCode>
</PropertyGroup>
</Project>
delphi-backend/PMServer.res
BIN
View File
Binary file not shown.
delphi-backend/Source/PM.Audit.pas
+43
View File
@@ -0,0 +1,43 @@
unit PM.Audit;
{
Mirrors api.php logAudit().
user_id may be NULL for pre-auth events; pass 0 to record without user.
}
interface
uses
System.SysUtils, FireDAC.Comp.Client, FireDAC.Stan.Param,
PM.Database;
procedure LogAudit(AUserId: Integer; const AAction, AIP: string);
implementation
procedure LogAudit(AUserId: Integer; const AAction, AIP: string);
var
LQ: TFDQuery;
begin
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text := 'INSERT INTO audit_log (user_id, action, ip) VALUES (:uid, :action, :ip)';
if AUserId > 0 then
LQ.ParamByName('uid').AsInteger := AUserId
else
LQ.ParamByName('uid').Clear;
LQ.ParamByName('action').AsString := AAction;
LQ.ParamByName('ip').AsString := AIP;
LQ.ExecSQL;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
end;
end.
delphi-backend/Source/PM.Bridge.pas
+487
View File
@@ -0,0 +1,487 @@
unit PM.Bridge;
{
PM.Bridge — JS↔Delphi native capability bridge.
Three features exposed to the embedded WebView2 via cmd:// URLs:
1. TSecureClipboard
Sets text on the Windows clipboard alongside the
ExcludeClipboardContentFromMonitorProcessing format, which prevents
Win+V clipboard history from recording the password. Auto-clears
after a configurable delay via TTimer.
2. Tray icon (TPMBridge.MinimizeToTray / RestoreFromTray)
Shell_NotifyIcon-based. The main window hides; a tray icon appears.
Single-click or double-click on the tray icon restores the window.
OnTrayRestore is called on the main thread so the caller can Show/BringToFront.
3. Windows session-lock detection
WTSRegisterSessionNotification on a dedicated message-only window.
On WTS_SESSION_LOCK the bridge fires OnSystemLock (main thread) so
the Delphi host can inject lockVault() into the WebView2.
Both tray icon messages and WTS notifications are routed through a
single message-only window created with AllocateHWnd, avoiding any
subclassing of the FMX main window.
}
interface
uses
System.SysUtils, System.Classes, System.Math,
FMX.Types, FMX.Forms,
Winapi.Windows, Winapi.ShellAPI, Winapi.Messages;
type
// -------------------------------------------------------------------------
// TSecureClipboard
// -------------------------------------------------------------------------
TSecureClipboard = class
private
FClearTimer: TTimer;
procedure ClearTimerTick(Sender: TObject);
public
constructor Create;
destructor Destroy; override;
// 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;
// -------------------------------------------------------------------------
// TPMBridge
// -------------------------------------------------------------------------
TPMBridge = class
private
FMainForm: TForm;
FMsgWindow: HWND;
FTrayAdded: Boolean;
FIconOwned: Boolean; // true = we must call DestroyIcon on FIconHandle
FIconHandle: HICON;
FNid: TNotifyIconData;
FSecureClipboard: TSecureClipboard;
FBalloonShown: Boolean;
FOnSystemLock: TProc;
FOnTrayRestore: TProc;
FOnLockRequest: TProc;
FOnQuit: TProc;
procedure MsgWindowHandler(var AMsg: TMessage);
procedure PrepareNid;
procedure ShowTrayMenu;
procedure ShowFirstTimeBalloon;
function FindFMXAppWindow: HWND;
public
constructor Create(AMainForm: TForm);
destructor Destroy; override;
// Hide main window and show tray icon.
procedure MinimizeToTray;
// Restore main window and remove tray icon.
procedure RestoreFromTray;
property SecureClipboard: TSecureClipboard read FSecureClipboard;
property TrayAdded: Boolean read FTrayAdded;
// 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.
property OnTrayRestore: TProc read FOnTrayRestore write FOnTrayRestore;
// Fired when the user picks "Lock vault" from the tray menu. Handler
// should trigger the JS lockVault() (typically via ExecuteJavaScript).
property OnLockRequest: TProc read FOnLockRequest write FOnLockRequest;
// Fired when the user picks "Quit" from the tray menu. Handler must
// actually terminate the app (Application.Terminate or similar) — the
// 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;
end;
implementation
uses
FMX.Platform.Win;
// Win32 format name that suppresses Win+V clipboard history recording.
// Introduced in Windows 10 1809 (build 17763). Silently ignored on older builds.
const
CLIPBOARD_EXCLUDE_FORMAT = 'ExcludeClipboardContentFromMonitorProcessing';
// Tray callback message routed to our message-only window.
const
WM_TRAY_ICON = WM_APP + 1;
// WTS session change message and state constants (declared here to avoid
// a hard dependency on Winapi.WtsApi32 which varies across Delphi versions).
const
WM_WTSSESSION_CHANGE = $02B1;
WTS_SESSION_LOCK = 7;
NOTIFY_FOR_THIS_SESSION = 0;
// 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.
var
_WTSRegister : function(hWnd: HWND; dwFlags: DWORD): BOOL; stdcall = nil;
_WTSUnregister: function(hWnd: HWND): BOOL; stdcall = nil;
_WtsApiLoaded : Boolean = False;
_WtsLib : HMODULE = 0;
procedure LoadWtsApi;
begin
if _WtsApiLoaded then Exit;
_WtsApiLoaded := True;
_WtsLib := LoadLibrary('wtsapi32.dll');
if _WtsLib = 0 then Exit;
_WTSRegister := GetProcAddress(_WtsLib, 'WTSRegisterSessionNotification');
_WTSUnregister := GetProcAddress(_WtsLib, 'WTSUnRegisterSessionNotification');
end;
// =============================================================================
// TSecureClipboard
// =============================================================================
constructor TSecureClipboard.Create;
begin
inherited;
FClearTimer := TTimer.Create(nil);
FClearTimer.Enabled := False;
FClearTimer.OnTimer := ClearTimerTick;
end;
destructor TSecureClipboard.Destroy;
begin
FClearTimer.Free;
inherited;
end;
procedure TSecureClipboard.ClearTimerTick(Sender: TObject);
begin
FClearTimer.Enabled := False;
Clear;
end;
procedure TSecureClipboard.SetText(const AText: string; AClearAfterMs: Integer);
var
CFExclude: UINT;
LMem: THandle; // HGLOBAL — renamed to avoid Pascal's case-insensitive
// collision with the HGLOBAL type identifier.
LDest: Pointer;
LByteCount: NativeUInt;
begin
FClearTimer.Enabled := False;
// Register (or look up if already registered) the exclusion format.
CFExclude := RegisterClipboardFormat(CLIPBOARD_EXCLUDE_FORMAT);
LByteCount := NativeUInt(Length(AText) + 1) * SizeOf(Char);
LMem := GlobalAlloc(GMEM_MOVEABLE, LByteCount);
if LMem = 0 then Exit;
LDest := GlobalLock(LMem);
try
Move(PChar(AText)^, LDest^, LByteCount);
finally
GlobalUnlock(LMem);
end;
if not OpenClipboard(0) then
begin
GlobalFree(LMem);
Exit;
end;
try
EmptyClipboard;
// CF_UNICODETEXT ownership is transferred to the clipboard on success.
if SetClipboardData(CF_UNICODETEXT, LMem) = 0 then
GlobalFree(LMem);
// Exclusion marker: presence of this format is the signal to Windows;
// the data handle is nil and ignored by the subsystem.
SetClipboardData(CFExclude, 0);
finally
CloseClipboard;
end;
if AClearAfterMs > 0 then
begin
FClearTimer.Interval := AClearAfterMs;
FClearTimer.Enabled := True;
end;
end;
procedure TSecureClipboard.Clear;
begin
if OpenClipboard(0) then
try
EmptyClipboard;
finally
CloseClipboard;
end;
end;
// =============================================================================
// TPMBridge
// =============================================================================
constructor TPMBridge.Create(AMainForm: TForm);
begin
inherited Create;
FMainForm := AMainForm;
FSecureClipboard := TSecureClipboard.Create;
FTrayAdded := False;
FBalloonShown := False;
// Dedicated message-only window for tray + WTS notifications.
FMsgWindow := AllocateHWnd(MsgWindowHandler);
PrepareNid;
// Session-lock detection (fails silently if wtsapi32.dll is absent).
LoadWtsApi;
if Assigned(_WTSRegister) then
_WTSRegister(FMsgWindow, NOTIFY_FOR_THIS_SESSION);
end;
destructor TPMBridge.Destroy;
begin
if Assigned(_WTSUnregister) then
_WTSUnregister(FMsgWindow);
if FTrayAdded then
begin
Shell_NotifyIcon(NIM_DELETE, @FNid);
FTrayAdded := False;
end;
if FIconOwned and (FIconHandle <> 0) then
DestroyIcon(FIconHandle);
DeallocateHWnd(FMsgWindow);
FSecureClipboard.Free;
inherited;
end;
procedure TPMBridge.PrepareNid;
var
LargeIcon, SmallIcon: HICON;
begin
// Attempt to extract the small (16×16) icon from the exe.
// ExtractIconEx returns the number of icons extracted.
LargeIcon := 0;
SmallIcon := 0;
FIconOwned := False;
if ExtractIconEx(PChar(ParamStr(0)), 0, LargeIcon, SmallIcon, 1) > 0 then
begin
if LargeIcon <> 0 then DestroyIcon(LargeIcon); // we only need the small one
if SmallIcon <> 0 then
begin
FIconHandle := SmallIcon;
FIconOwned := True;
end;
end;
if FIconHandle = 0 then
FIconHandle := LoadIcon(0, IDI_APPLICATION); // shared system icon, never destroy
FillChar(FNid, SizeOf(FNid), 0);
FNid.cbSize := SizeOf(FNid);
FNid.Wnd := FMsgWindow;
FNid.uID := 1;
FNid.uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
FNid.uCallbackMessage := WM_TRAY_ICON;
FNid.hIcon := FIconHandle;
// szTip: array[0..127] of WideChar — copy tooltip text safely.
Move(PChar('Password Manager')^, FNid.szTip[0],
Min(Length('Password Manager'), High(FNid.szTip)) * SizeOf(Char));
end;
function MainFormHWND(AForm: TForm): HWND;
begin
Result := WindowHandleToPlatform(AForm.Handle).Wnd;
end;
function TPMBridge.FindFMXAppWindow: HWND;
var
LWnd: HWND;
LWndPid, LCurrentPid: DWORD;
begin
// FMX on Windows creates a hidden per-process window of class "TFMAppClass"
// that owns the application's taskbar entry — NOT the form's HWND.
// Hiding the form (via ShowWindow / Visible := False / WS_EX_TOOLWINDOW /
// ITaskbarList.DeleteTab) is therefore ineffective at removing the taskbar
// entry: those calls target the wrong window. The correct fix is to find
// the TFMAppClass window owned by our process and hide IT.
// Reference: https://stackoverflow.com/q/16768986
Result := 0;
LCurrentPid := GetCurrentProcessId;
LWnd := 0;
repeat
LWnd := FindWindowEx(0, LWnd, 'TFMAppClass', nil);
if LWnd <> 0 then
begin
LWndPid := 0;
GetWindowThreadProcessId(LWnd, LWndPid);
if LWndPid = LCurrentPid then
Exit(LWnd);
end;
until LWnd = 0;
end;
procedure TPMBridge.MinimizeToTray;
var
LFormHwnd, LAppHwnd: HWND;
begin
if not FTrayAdded then
begin
if Shell_NotifyIcon(NIM_ADD, @FNid) then
FTrayAdded := True;
end;
// Extra safety: clear the clipboard immediately when the user minimizes,
// rather than waiting for the 30s auto-clear timer to fire. A password
// the user just copied shouldn't sit in the clipboard while the app is
// out of sight.
FSecureClipboard.Clear;
LFormHwnd := MainFormHWND(FMainForm);
LAppHwnd := FindFMXAppWindow;
// 1. Hide the visible form via both FMX state and Win32 ShowWindow.
// Keeps the form invisible to the user.
FMainForm.Hide;
ShowWindow(LFormHwnd, SW_HIDE);
// 2. Hide the FMX application proxy window (TFMAppClass). THIS is what
// removes the entry from the taskbar — the form's HWND was never the
// taskbar-visible one in FMX.
if LAppHwnd <> 0 then
ShowWindow(LAppHwnd, SW_HIDE);
// 3. First-time only: pop a balloon notification so the user knows the
// app is still running in the tray (and didn't crash).
if not FBalloonShown then
begin
ShowFirstTimeBalloon;
FBalloonShown := True;
end;
end;
procedure TPMBridge.ShowFirstTimeBalloon;
var
LBalloon: TNotifyIconData;
const
BALLOON_TITLE = 'Password Manager';
BALLOON_TEXT = 'Still running in the tray — click the icon to restore, ' +
'right-click for menu.';
begin
// Build a separate TNotifyIconData with NIF_INFO set, NIM_MODIFY on the
// same uID. szInfo/szInfoTitle carry the balloon content. NIIF_INFO
// gives the system info icon — no scary warning glyph.
FillChar(LBalloon, SizeOf(LBalloon), 0);
LBalloon.cbSize := SizeOf(LBalloon);
LBalloon.Wnd := FMsgWindow;
LBalloon.uID := 1;
LBalloon.uFlags := NIF_INFO;
Move(PChar(BALLOON_TITLE)^, LBalloon.szInfoTitle[0],
Min(Length(BALLOON_TITLE), High(LBalloon.szInfoTitle)) * SizeOf(Char));
Move(PChar(BALLOON_TEXT)^, LBalloon.szInfo[0],
Min(Length(BALLOON_TEXT), High(LBalloon.szInfo)) * SizeOf(Char));
LBalloon.dwInfoFlags := NIIF_INFO;
Shell_NotifyIcon(NIM_MODIFY, @LBalloon);
end;
procedure TPMBridge.RestoreFromTray;
var
LFormHwnd, LAppHwnd: HWND;
begin
if FTrayAdded then
begin
Shell_NotifyIcon(NIM_DELETE, @FNid);
FTrayAdded := False;
end;
LFormHwnd := MainFormHWND(FMainForm);
LAppHwnd := FindFMXAppWindow;
// Reverse order: show the app proxy first so the taskbar entry comes back,
// then show and foreground the form.
if LAppHwnd <> 0 then
ShowWindow(LAppHwnd, SW_SHOW);
FMainForm.Show;
ShowWindow(LFormHwnd, SW_SHOW);
ShowWindow(LFormHwnd, SW_RESTORE);
SetForegroundWindow(LFormHwnd);
end;
procedure TPMBridge.ShowTrayMenu;
const
ID_OPEN = 1;
ID_LOCK = 2;
ID_QUIT = 3;
var
LMenu: HMENU;
LPt: TPoint;
LCmd: Cardinal;
begin
LMenu := CreatePopupMenu;
if LMenu = 0 then Exit;
try
AppendMenu(LMenu, MF_STRING, ID_OPEN, 'Open');
AppendMenu(LMenu, MF_STRING, ID_LOCK, 'Lock vault');
AppendMenu(LMenu, MF_SEPARATOR, 0, nil);
AppendMenu(LMenu, MF_STRING, ID_QUIT, 'Quit');
GetCursorPos(LPt);
// SetForegroundWindow + WM_NULL post is the canonical Win32 workaround
// that lets TrackPopupMenu auto-dismiss when the user clicks elsewhere.
// Without it, the menu can become "sticky" on a hidden window.
SetForegroundWindow(FMsgWindow);
// Delphi's TrackPopupMenu is declared as returning BOOL, but with
// TPM_RETURNCMD it actually returns the selected menu item ID (or 0).
// Cast through the declared return type to read the real value.
LCmd := Cardinal(TrackPopupMenu(LMenu,
TPM_RETURNCMD or TPM_RIGHTBUTTON or TPM_NONOTIFY,
LPt.X, LPt.Y, 0, FMsgWindow, nil));
PostMessage(FMsgWindow, WM_NULL, 0, 0);
case LCmd of
ID_OPEN: if Assigned(FOnTrayRestore) then FOnTrayRestore();
ID_LOCK: if Assigned(FOnLockRequest) then FOnLockRequest();
ID_QUIT: if Assigned(FOnQuit) then FOnQuit();
end;
finally
DestroyMenu(LMenu);
end;
end;
procedure TPMBridge.MsgWindowHandler(var AMsg: TMessage);
var
LMouseEvent: Word;
begin
// AllocateHWnd creates the window on the thread that called it (here: the
// main thread, since TPMBridge.Create runs from FormCreate). Windows
// dispatches messages on the owning thread, so this handler is already
// on the main thread — no need to marshal via TThread.Queue/ForceQueue.
if AMsg.Msg = WM_TRAY_ICON then
begin
// For Shell_NotifyIcon callback messages, the mouse event is in the
// low word of LParam (regardless of NOTIFYICON_VERSION). Extracting
// it via LOWORD is more portable than comparing the full LPARAM.
LMouseEvent := Word(AMsg.LParam and $FFFF);
if (LMouseEvent = WM_LBUTTONUP) or (LMouseEvent = WM_LBUTTONDBLCLK) then
begin
if Assigned(FOnTrayRestore) then FOnTrayRestore();
end
else if (LMouseEvent = WM_RBUTTONUP) or (LMouseEvent = WM_CONTEXTMENU) then
begin
ShowTrayMenu;
end;
end
else if AMsg.Msg = WM_WTSSESSION_CHANGE then
begin
if AMsg.WParam = WTS_SESSION_LOCK then
if Assigned(FOnSystemLock) then FOnSystemLock();
end;
AMsg.Result := DefWindowProc(FMsgWindow, AMsg.Msg, AMsg.WParam, AMsg.LParam);
end;
end.
delphi-backend/Source/PM.Crypto.pas
+269
View File
@@ -0,0 +1,269 @@
unit PM.Crypto;
{
Cryptographic primitives for the password manager backend.
- RandomBytes: cryptographically secure via Windows CNG (BCryptGenRandom)
- SHA256Hex / SHA256Bytes: identical to PHP hash('sha256', ...)
- PBKDF2_SHA256_Hex: identical to PHP hash_pbkdf2('sha256', pwd, salt, iters)
- ConstantTimeEquals: timing-safe comparison (api.php uses hash_equals())
- BytesToHex / HexToBytes: PHP bin2hex / hex2bin equivalents
NOTE on bcrypt: PHP api.php hashes new passwords with PASSWORD_BCRYPT.
This Delphi backend does NOT implement bcrypt verification yet (would take
~250 lines for Blowfish + EKS). Accounts created here use pbkdf2 — which
PHP knows how to verify and migrate. Bcrypt accounts from PHP cannot login
here yet; the auth handler returns a clear error in that case.
}
interface
uses
System.SysUtils, System.Classes, System.NetEncoding,
System.Hash;
function RandomBytes(ALen: Integer): TBytes;
function RandomHex(AByteLen: Integer): string;
function BytesToHex(const ABytes: TBytes): string;
function HexToBytes(const AHex: string): TBytes;
function SHA256Hex(const AInput: string): string; overload;
function SHA256Hex(const AInput: TBytes): string; overload;
function PBKDF2_SHA256_Hex(const APassword, ASaltHex: string;
AIterations: Integer; ADKLenBytes: Integer = 32): string;
// Sanity check at unit initialization — verifies PBKDF2-HMAC-SHA256 matches
// the reference (PHP-equivalent) output. Raises if implementation drifts.
procedure SelfTestCrypto;
function ConstantTimeEquals(const A, B: string): Boolean;
implementation
uses
Winapi.Windows;
// ===== Windows CNG random ====================================================
const
BCRYPT_USE_SYSTEM_PREFERRED_RNG = $00000002;
function BCryptGenRandom(hAlgorithm: Pointer; pbBuffer: PByte;
cbBuffer: ULONG; dwFlags: ULONG): NTSTATUS; stdcall;
external 'bcrypt.dll' name 'BCryptGenRandom';
function RandomBytes(ALen: Integer): TBytes;
var
LStatus: NTSTATUS;
begin
SetLength(Result, ALen);
if ALen = 0 then Exit;
LStatus := BCryptGenRandom(nil, @Result[0], ALen,
BCRYPT_USE_SYSTEM_PREFERRED_RNG);
if LStatus <> 0 then
raise Exception.CreateFmt('BCryptGenRandom failed (0x%x)', [LStatus]);
end;
function RandomHex(AByteLen: Integer): string;
begin
Result := BytesToHex(RandomBytes(AByteLen));
end;
// ===== Hex helpers (PHP bin2hex / hex2bin) ===================================
function BytesToHex(const ABytes: TBytes): string;
const
HEX: array[0..15] of Char =
('0','1','2','3','4','5','6','7','8','9','a','b','c','d','e','f');
var
I: Integer;
begin
SetLength(Result, Length(ABytes) * 2);
for I := 0 to High(ABytes) do
begin
Result[(I * 2) + 1] := HEX[ABytes[I] shr 4];
Result[(I * 2) + 2] := HEX[ABytes[I] and $0F];
end;
end;
function HexCharToInt(C: Char): Integer; inline;
begin
case C of
'0'..'9': Result := Ord(C) - Ord('0');
'a'..'f': Result := Ord(C) - Ord('a') + 10;
'A'..'F': Result := Ord(C) - Ord('A') + 10;
else
raise Exception.Create('Invalid hex character: ' + C);
end;
end;
function HexToBytes(const AHex: string): TBytes;
var
I, LLen: Integer;
begin
LLen := Length(AHex);
if Odd(LLen) then
raise Exception.Create('Hex string has odd length');
SetLength(Result, LLen div 2);
for I := 0 to High(Result) do
Result[I] := (HexCharToInt(AHex[(I * 2) + 1]) shl 4) or
HexCharToInt(AHex[(I * 2) + 2]);
end;
// ===== SHA256 ================================================================
function SHA256Hex(const AInput: string): string;
begin
Result := LowerCase(THashSHA2.GetHashString(AInput, THashSHA2.TSHA2Version.SHA256));
end;
function SHA256Hex(const AInput: TBytes): string;
var
H: THashSHA2;
begin
H := THashSHA2.Create(THashSHA2.TSHA2Version.SHA256);
if Length(AInput) > 0 then
H.Update(AInput);
Result := LowerCase(BytesToHex(H.HashAsBytes));
end;
// ===== PBKDF2-SHA256 =========================================================
// Matches PHP hash_pbkdf2('sha256', $password, $salt, $iterations) which
// returns lowercase hex. $salt is whatever bytes you pass — api.php stores
// salt as bin2hex(random_bytes(32)), then passes that hex STRING as the salt
// argument to hash_pbkdf2. So the "salt" fed to PBKDF2 is the 64-char hex
// representation, NOT the 32 raw bytes. We replicate that quirk here.
// Manual HMAC-SHA256 — avoid any ambiguity with System.Hash overloads.
// Verified against RFC 4231 test vectors.
function HMAC_SHA256(const AKey, AMsg: TBytes): TBytes;
const
BLOCK = 64; // SHA256 block size in bytes
var
LKey, LIpad, LOpad, LInner: TBytes;
I: Integer;
H: THashSHA2;
begin
// Step 1: derive working key
LKey := Copy(AKey, 0, Length(AKey));
if Length(LKey) > BLOCK then
begin
H := THashSHA2.Create(THashSHA2.TSHA2Version.SHA256);
H.Update(LKey);
LKey := H.HashAsBytes;
end;
if Length(LKey) < BLOCK then
SetLength(LKey, BLOCK); // zero-padded to block size
// Step 2: inner & outer pads
SetLength(LIpad, BLOCK);
SetLength(LOpad, BLOCK);
for I := 0 to BLOCK - 1 do
begin
LIpad[I] := LKey[I] xor $36;
LOpad[I] := LKey[I] xor $5C;
end;
// Step 3: inner = SHA256(ipad || msg)
H := THashSHA2.Create(THashSHA2.TSHA2Version.SHA256);
H.Update(LIpad);
if Length(AMsg) > 0 then H.Update(AMsg);
LInner := H.HashAsBytes;
// Step 4: result = SHA256(opad || inner)
H := THashSHA2.Create(THashSHA2.TSHA2Version.SHA256);
H.Update(LOpad);
H.Update(LInner);
Result := H.HashAsBytes;
end;
function PBKDF2_SHA256_Hex(const APassword, ASaltHex: string;
AIterations: Integer; ADKLenBytes: Integer): string;
var
LPwd, LSalt, LU, LT, LBlock: TBytes;
LBlocks, I, J, K: Integer;
LCtr: array[0..3] of Byte;
LOut: TBytes;
begin
LPwd := TEncoding.UTF8.GetBytes(APassword);
// PHP behavior: pass salt argument as-is. api.php passes the hex string,
// so HMAC sees the ascii bytes of the hex.
LSalt := TEncoding.UTF8.GetBytes(ASaltHex);
LBlocks := (ADKLenBytes + 31) div 32; // SHA256 block = 32 bytes
SetLength(LOut, 0);
for I := 1 to LBlocks do
begin
LCtr[0] := (I shr 24) and $FF;
LCtr[1] := (I shr 16) and $FF;
LCtr[2] := (I shr 8) and $FF;
LCtr[3] := I and $FF;
SetLength(LBlock, Length(LSalt) + 4);
if Length(LSalt) > 0 then
Move(LSalt[0], LBlock[0], Length(LSalt));
Move(LCtr[0], LBlock[Length(LSalt)], 4);
LU := HMAC_SHA256(LPwd, LBlock);
LT := Copy(LU, 0, Length(LU));
for J := 2 to AIterations do
begin
LU := HMAC_SHA256(LPwd, LU);
for K := 0 to High(LT) do
LT[K] := LT[K] xor LU[K];
end;
LOut := LOut + LT;
end;
SetLength(LOut, ADKLenBytes);
Result := BytesToHex(LOut);
end;
// ===== Timing-safe compare ===================================================
function ConstantTimeEquals(const A, B: string): Boolean;
var
I, LDiff, LLen: Integer;
begin
LLen := Length(A);
if Length(B) <> LLen then Exit(False);
LDiff := 0;
for I := 1 to LLen do
LDiff := LDiff or (Ord(A[I]) xor Ord(B[I]));
Result := LDiff = 0;
end;
// ===== Self-test =============================================================
procedure SelfTestCrypto;
const
// Test vector: password='password', salt='salt', iters=1, dkLen=32, sha256
// Independently verified: matches PHP hash_pbkdf2('sha256','password','salt',1)
EXPECTED_1 = '120fb6cffcf8b32c43e7225256c4f837a86548c92ccc35480805987cb70be17b';
// Same with iterations=2
EXPECTED_2 = 'ae4d0c95af6b46d32d0adff928f06dd02a303f8ef3c251dfd6e2d85a95474c43';
var
Got1, Got2: string;
begin
Got1 := PBKDF2_SHA256_Hex('password', 'salt', 1, 32);
if not SameText(Got1, EXPECTED_1) then
raise Exception.CreateFmt(
'PBKDF2 self-test FAILED (iters=1):'#10' expected %s'#10' got %s',
[EXPECTED_1, Got1]);
Got2 := PBKDF2_SHA256_Hex('password', 'salt', 2, 32);
if not SameText(Got2, EXPECTED_2) then
raise Exception.CreateFmt(
'PBKDF2 self-test FAILED (iters=2):'#10' expected %s'#10' got %s',
[EXPECTED_2, Got2]);
end;
initialization
SelfTestCrypto;
end.
delphi-backend/Source/PM.Database.pas
+229
View File
@@ -0,0 +1,229 @@
unit PM.Database;
{
SQLite connection (FireDAC) toward the shared vault.db file.
CreateSchema mirrors api.php (CREATE TABLE IF NOT EXISTS + ALTER migrations).
Per-thread connection is NOT implemented yet — single connection guarded by
TMonitor. Indy's TIdHTTPServer is thread-per-connection, so we serialize DB
access for safety until we move to a connection pool.
}
interface
uses
System.SysUtils, System.Classes, System.IOUtils, System.SyncObjs,
FireDAC.Comp.Client, FireDAC.Stan.Def, FireDAC.Stan.Async,
FireDAC.Phys.SQLite, FireDAC.DApt, FireDAC.Stan.Param,
FireDAC.FMXUI.Wait, FireDAC.Stan.Intf, FireDAC.UI.Intf,
Data.DB;
type
TPMDatabase = class
private
FConn: TFDConnection;
FLock: TCriticalSection;
FDBPath: string;
function ColumnExists(const ATable, AColumn: string): Boolean;
procedure AddColumnIfMissing(const ATable, AColumn, ADef: string);
procedure CreateSchema;
procedure ApplyMigrations;
procedure CleanupExpired;
public
constructor Create(const ADBPath: string);
destructor Destroy; override;
procedure Lock;
procedure Unlock;
property Connection: TFDConnection read FConn;
property DBPath: string read FDBPath;
end;
var
DB: TPMDatabase;
procedure InitDatabase(const ADBPath: string);
procedure DoneDatabase;
implementation
constructor TPMDatabase.Create(const ADBPath: string);
begin
inherited Create;
FDBPath := ADBPath;
FLock := TCriticalSection.Create;
FConn := TFDConnection.Create(nil);
FConn.DriverName := 'SQLite';
FConn.Params.Values['Database'] := FDBPath;
FConn.Params.Values['LockingMode'] := 'Normal';
FConn.Params.Values['Synchronous'] := 'Normal';
FConn.Params.Values['BusyTimeout'] := '5000';
FConn.Params.Values['JournalMode'] := 'WAL';
FConn.Open;
CreateSchema;
ApplyMigrations;
CleanupExpired;
end;
destructor TPMDatabase.Destroy;
begin
FConn.Free;
FLock.Free;
inherited;
end;
procedure TPMDatabase.Lock;
begin
FLock.Enter;
end;
procedure TPMDatabase.Unlock;
begin
FLock.Leave;
end;
procedure TPMDatabase.CreateSchema;
begin
FConn.ExecSQL(
'CREATE TABLE IF NOT EXISTS users (' +
' id INTEGER PRIMARY KEY AUTOINCREMENT,' +
' username TEXT UNIQUE NOT NULL,' +
' password_hash TEXT NOT NULL,' +
' salt TEXT NOT NULL,' +
' created_at DATETIME DEFAULT CURRENT_TIMESTAMP,' +
' hash_algo TEXT DEFAULT ''pbkdf2''' +
')');
FConn.ExecSQL(
'CREATE TABLE IF NOT EXISTS folders (' +
' id INTEGER PRIMARY KEY AUTOINCREMENT,' +
' user_id INTEGER NOT NULL,' +
' name TEXT NOT NULL,' +
' created_at DATETIME DEFAULT CURRENT_TIMESTAMP,' +
' FOREIGN KEY (user_id) REFERENCES users(id) ON DELETE CASCADE,' +
' UNIQUE(user_id, name)' +
')');
FConn.ExecSQL(
'CREATE TABLE IF NOT EXISTS vault_entries (' +
' id INTEGER PRIMARY KEY AUTOINCREMENT,' +
' user_id INTEGER NOT NULL,' +
' site TEXT NOT NULL,' +
' username TEXT NOT NULL,' +
' encrypted_password TEXT NOT NULL,' +
' iv TEXT NOT NULL,' +
' encryption_method TEXT DEFAULT ''server'',' +
' folder TEXT DEFAULT ''All'',' +
' deleted INTEGER DEFAULT 0,' +
' deleted_at DATETIME,' +
' favorite INTEGER DEFAULT 0,' +
' created_at DATETIME DEFAULT CURRENT_TIMESTAMP,' +
' updated_at DATETIME DEFAULT CURRENT_TIMESTAMP' +
')');
FConn.ExecSQL(
'CREATE TABLE IF NOT EXISTS sessions (' +
' id INTEGER PRIMARY KEY AUTOINCREMENT,' +
' user_id INTEGER NOT NULL,' +
' token_hash TEXT UNIQUE NOT NULL,' +
' csrf_token TEXT,' +
' created_at DATETIME DEFAULT CURRENT_TIMESTAMP,' +
' expires_at DATETIME NOT NULL,' +
' FOREIGN KEY (user_id) REFERENCES users(id) ON DELETE CASCADE' +
')');
FConn.ExecSQL(
'CREATE TABLE IF NOT EXISTS login_attempts (' +
' id INTEGER PRIMARY KEY AUTOINCREMENT,' +
' ip TEXT NOT NULL,' +
' attempted_at DATETIME DEFAULT CURRENT_TIMESTAMP' +
')');
FConn.ExecSQL(
'CREATE TABLE IF NOT EXISTS audit_log (' +
' id INTEGER PRIMARY KEY AUTOINCREMENT,' +
' user_id INTEGER,' +
' action TEXT NOT NULL,' +
' ip TEXT,' +
' created_at DATETIME DEFAULT CURRENT_TIMESTAMP' +
')');
FConn.ExecSQL(
'CREATE TABLE IF NOT EXISTS passkey_challenges (' +
' id INTEGER PRIMARY KEY AUTOINCREMENT,' +
' user_id INTEGER,' +
' challenge BLOB NOT NULL,' +
' type TEXT NOT NULL,' +
' created_at DATETIME DEFAULT CURRENT_TIMESTAMP' +
')');
FConn.ExecSQL(
'CREATE TABLE IF NOT EXISTS passkey_credentials (' +
' id INTEGER PRIMARY KEY AUTOINCREMENT,' +
' user_id INTEGER NOT NULL,' +
' credential_id BLOB NOT NULL UNIQUE,' +
' public_key BLOB NOT NULL,' +
' counter INTEGER DEFAULT 0,' +
' created_at DATETIME DEFAULT CURRENT_TIMESTAMP,' +
' FOREIGN KEY (user_id) REFERENCES users(id) ON DELETE CASCADE' +
')');
end;
function TPMDatabase.ColumnExists(const ATable, AColumn: string): Boolean;
var
LQ: TFDQuery;
begin
Result := False;
LQ := TFDQuery.Create(nil);
try
LQ.Connection := FConn;
// PRAGMA table_info returns one row per column with name in column 'name'
LQ.SQL.Text := 'PRAGMA table_info(' + ATable + ')';
LQ.Open;
while not LQ.Eof do
begin
if SameText(LQ.FieldByName('name').AsString, AColumn) then
Exit(True);
LQ.Next;
end;
finally
LQ.Free;
end;
end;
procedure TPMDatabase.AddColumnIfMissing(const ATable, AColumn, ADef: string);
begin
if not ColumnExists(ATable, AColumn) then
FConn.ExecSQL('ALTER TABLE ' + ATable + ' ADD COLUMN ' + AColumn + ' ' + ADef);
end;
procedure TPMDatabase.ApplyMigrations;
begin
// Idempotent: only ALTER when the column is actually missing — no exception
// bubbling up to the debugger like api.php's try/catch did.
AddColumnIfMissing('vault_entries', 'encryption_method', 'TEXT DEFAULT ''server''');
AddColumnIfMissing('vault_entries', 'folder', 'TEXT DEFAULT ''All''');
AddColumnIfMissing('vault_entries', 'deleted', 'INTEGER DEFAULT 0');
AddColumnIfMissing('vault_entries', 'deleted_at', 'DATETIME');
AddColumnIfMissing('vault_entries', 'favorite', 'INTEGER DEFAULT 0');
// 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 ''''');
AddColumnIfMissing('users', 'hash_algo', 'TEXT DEFAULT ''pbkdf2''');
AddColumnIfMissing('sessions', 'csrf_token', 'TEXT');
end;
procedure TPMDatabase.CleanupExpired;
begin
FConn.ExecSQL('DELETE FROM sessions WHERE expires_at < datetime(''now'')');
FConn.ExecSQL('DELETE FROM login_attempts WHERE attempted_at < datetime(''now'', ''-15 minutes'')');
FConn.ExecSQL('DELETE FROM audit_log WHERE created_at < datetime(''now'', ''-30 days'')');
FConn.ExecSQL('DELETE FROM passkey_challenges WHERE created_at < datetime(''now'', ''-10 minutes'')');
end;
procedure InitDatabase(const ADBPath: string);
begin
if DB = nil then
DB := TPMDatabase.Create(ADBPath);
end;
procedure DoneDatabase;
begin
FreeAndNil(DB);
end;
initialization
finalization
DoneDatabase;
end.
delphi-backend/Source/PM.EmbeddedAssets.pas
+115
View File
@@ -0,0 +1,115 @@
unit PM.EmbeddedAssets;
(*
Serves the password-manager HTML/JS/CSS from Win32 RCDATA resources
embedded inside PMServer.exe by BuildAssets.ps1.
Workflow:
1. Edit ../../index.html, ../../js/*.js, ../../css/*.css
2. Run delphi-backend/assets/BuildAssets.ps1
3. Rebuild — exe ships self-contained
4. Run — TryServe pulls bytes from HInstance resources
No disk I/O at runtime. No external files needed beside PMServer.exe.
The manifest (URL path -> resource name) is generated alongside the .res:
delphi-backend/assets/assets.inc, included below via {$I}. If the file
does not exist (BuildAssets.ps1 never ran), the compile-time fallback
registers no assets and TryServe always returns False.
*)
interface
uses
System.SysUtils, System.Classes,
IdCustomHTTPServer;
type
TEmbeddedAsset = record
UrlPath: string;
ResName: string;
end;
function TryServeEmbedded(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo): Boolean;
implementation
uses
Winapi.Windows;
// The manifest is auto-generated. A stub is checked in so the project
// compiles before BuildAssets.ps1 ever runs; running the script overwrites
// it with the real list.
{$I ..\assets\assets.inc}
function MimeTypeFor(const AExt: string): string;
var
E: string;
begin
E := LowerCase(AExt);
if (E = '.html') or (E = '.htm') then Exit('text/html; charset=utf-8');
if E = '.js' then Exit('application/javascript; charset=utf-8');
if E = '.mjs' then Exit('application/javascript; charset=utf-8');
if E = '.css' then Exit('text/css; charset=utf-8');
if E = '.json' then Exit('application/json; charset=utf-8');
if E = '.svg' then Exit('image/svg+xml');
if E = '.png' then Exit('image/png');
if E = '.jpg' then Exit('image/jpeg');
if E = '.jpeg' then Exit('image/jpeg');
if E = '.gif' then Exit('image/gif');
if E = '.ico' then Exit('image/x-icon');
if E = '.woff' then Exit('font/woff');
if E = '.woff2' then Exit('font/woff2');
Result := 'application/octet-stream';
end;
function FindResourceFor(const AUrlPath: string; out AResName: string): Boolean;
var
I: Integer;
LPath: string;
begin
LPath := AUrlPath;
if (LPath = '') or (LPath = '/') then LPath := '/index.html';
for I := 0 to EMBEDDED_ASSET_COUNT - 1 do
if SameText(EMBEDDED_ASSETS[I].UrlPath, LPath) then
begin
AResName := EMBEDDED_ASSETS[I].ResName;
Exit(True);
end;
Result := False;
end;
function TryServeEmbedded(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo): Boolean;
var
LResName, LExt: string;
LStream: TResourceStream;
LMS: TMemoryStream;
begin
Result := False;
if not SameText(ARequest.Command, 'GET') then Exit;
if not FindResourceFor(ARequest.Document, LResName) then Exit;
if FindResource(HInstance, PChar(LResName), RT_RCDATA) = 0 then Exit;
LExt := ExtractFileExt(ARequest.Document);
if (LExt = '') and ((ARequest.Document = '') or (ARequest.Document = '/')) then
LExt := '.html';
AResponse.ContentType := MimeTypeFor(LExt);
LStream := TResourceStream.Create(HInstance, LResName, RT_RCDATA);
try
// Copy into a TMemoryStream so Indy can own and free it after the response.
LMS := TMemoryStream.Create;
LMS.CopyFrom(LStream, 0);
LMS.Position := 0;
AResponse.ContentStream := LMS;
AResponse.FreeContentStream := True;
finally
LStream.Free;
end;
AResponse.ResponseNo := 200;
Result := True;
end;
end.
delphi-backend/Source/PM.HTTPServer.pas
+209
View File
@@ -0,0 +1,209 @@
unit PM.HTTPServer;
{
Indy TIdHTTPServer wrapper.
- Binds 127.0.0.1 ONLY (hardcoded — never expose on LAN)
- Sets security headers (CSP, HSTS, CORS localhost)
- Handles OPTIONS preflight
- Dispatches to PM.Router; 404 if no match
}
interface
uses
System.SysUtils, System.Classes, System.IOUtils,
IdHTTPServer, IdContext, IdCustomHTTPServer, IdSocketHandle,
PM.Router, PM.JSON, PM.Database, PM.StaticFiles, PM.EmbeddedAssets;
type
TLogProc = reference to procedure(const AMsg: string);
TPMHTTPServer = class
private
FServer: TIdHTTPServer;
FOnLog: TLogProc;
procedure HandleCommand(AContext: TIdContext;
ARequest: TIdHTTPRequestInfo; AResponse: TIdHTTPResponseInfo);
procedure HandleCommandOther(AContext: TIdContext;
ARequest: TIdHTTPRequestInfo; AResponse: TIdHTTPResponseInfo);
procedure HandleParseAuthentication(AContext: TIdContext;
const AAuthType, AAuthData: string;
var VUsername, VPassword: string; var VHandled: Boolean);
procedure HandleException(AContext: TIdContext; AException: Exception);
procedure ApplySecurityHeaders(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo);
procedure Log(const AMsg: string);
function GetActive: Boolean;
public
constructor Create;
destructor Destroy; override;
procedure Start(APort: Integer);
procedure Stop;
property Active: Boolean read GetActive;
property OnLog: TLogProc read FOnLog write FOnLog;
end;
implementation
constructor TPMHTTPServer.Create;
begin
inherited;
FServer := TIdHTTPServer.Create(nil);
FServer.OnCommandGet := HandleCommand;
FServer.OnCommandOther := HandleCommandOther;
// Tell Indy NOT to raise EIdHTTPUnsupportedAuthorisationScheme on 'Bearer'.
// We parse the Authorization header ourselves in PM.Session.
FServer.OnParseAuthentication := HandleParseAuthentication;
// Swallow harmless socket disconnect exceptions (10053 / 10054) — Edge
// Chromium pre-fetches and cancels connections, which is normal but noisy
// under the debugger.
FServer.OnException := HandleException;
end;
procedure TPMHTTPServer.HandleException(AContext: TIdContext;
AException: Exception);
begin
// EIdSocketError with 10053/10054 = client aborted, expected. Log everything
// else.
if (AException.ClassName = 'EIdSocketError')
or (AException.ClassName = 'EIdConnClosedGracefully') then
Exit;
Log('Server exception: ' + AException.ClassName + ' - ' + AException.Message);
end;
procedure TPMHTTPServer.HandleParseAuthentication(AContext: TIdContext;
const AAuthType, AAuthData: string;
var VUsername, VPassword: string; var VHandled: Boolean);
begin
// Accept any scheme silently; we read the raw header ourselves.
VHandled := True;
end;
destructor TPMHTTPServer.Destroy;
begin
Stop;
FServer.Free;
inherited;
end;
function TPMHTTPServer.GetActive: Boolean;
begin
Result := Assigned(FServer) and FServer.Active;
end;
procedure TPMHTTPServer.Log(const AMsg: string);
begin
if Assigned(FOnLog) then FOnLog(AMsg);
end;
procedure TPMHTTPServer.Start(APort: Integer);
var
LBinding: TIdSocketHandle;
LDBPath, LWebRoot: string;
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)), '..\'));
Log('Opening database: ' + LDBPath);
InitDatabase(LDBPath);
Log('Database ready.');
Log('Web root: ' + LWebRoot);
InitStaticServer(LWebRoot);
FServer.Bindings.Clear;
LBinding := FServer.Bindings.Add;
LBinding.IP := '127.0.0.1';
LBinding.Port := APort;
FServer.Active := True;
Log('Server started on http://127.0.0.1:' + IntToStr(APort));
end;
procedure TPMHTTPServer.Stop;
begin
if not Assigned(FServer) then Exit;
if FServer.Active then
begin
FServer.Active := False;
Log('Server stopped.');
end;
end;
procedure TPMHTTPServer.ApplySecurityHeaders(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo);
var
LOrigin: string;
begin
AResponse.CustomHeaders.Values['Strict-Transport-Security'] :=
'max-age=31536000; includeSubDomains';
AResponse.CustomHeaders.Values['Content-Security-Policy'] :=
'default-src ''self''; script-src ''self'' ''unsafe-inline''; ' +
'style-src ''self'' ''unsafe-inline''; connect-src ''self''; ' +
'img-src ''self'' data:; font-src ''self''; form-action ''self''; ' +
'frame-ancestors ''none''; base-uri ''self''; object-src ''none''';
AResponse.CustomHeaders.Values['X-Content-Type-Options'] := 'nosniff';
AResponse.CustomHeaders.Values['Referrer-Policy'] := 'no-referrer';
// CORS — accept only localhost / 127.0.0.1 origins (any port)
LOrigin := ARequest.RawHeaders.Values['Origin'];
if (LOrigin <> '') and (
(Pos('http://localhost', LOrigin) = 1) or
(Pos('http://127.0.0.1', LOrigin) = 1) or
(Pos('https://localhost', LOrigin) = 1) or
(Pos('https://127.0.0.1', LOrigin) = 1)
) then
begin
AResponse.CustomHeaders.Values['Access-Control-Allow-Origin'] := LOrigin;
AResponse.CustomHeaders.Values['Access-Control-Allow-Methods'] :=
'GET, POST, PUT, DELETE, OPTIONS';
AResponse.CustomHeaders.Values['Access-Control-Allow-Headers'] :=
'Content-Type, Authorization, X-CSRF-Token';
end;
end;
procedure TPMHTTPServer.HandleCommand(AContext: TIdContext;
ARequest: TIdHTTPRequestInfo; AResponse: TIdHTTPResponseInfo);
begin
ApplySecurityHeaders(ARequest, AResponse);
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;
TJSONHelper.SendError(AResponse, 404, 'Not found');
except
on E: Exception do
begin
Log('ERROR ' + ARequest.Command + ' ' + ARequest.Document + ' : ' + E.Message);
TJSONHelper.SendError(AResponse, 500, 'Internal server error');
end;
end;
end;
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
try
if not Router.DispatchRequest(ARequest, AResponse) then
TJSONHelper.SendError(AResponse, 404, 'Not found');
except
on E: Exception do
begin
Log('ERROR ' + ARequest.Command + ' ' + ARequest.Document + ' : ' + E.Message);
TJSONHelper.SendError(AResponse, 500, 'Internal server error');
end;
end;
end;
end.
delphi-backend/Source/PM.JSON.pas
+78
View File
@@ -0,0 +1,78 @@
unit PM.JSON;
interface
uses
System.SysUtils, System.Classes, System.JSON, IdCustomHTTPServer;
type
TJSONHelper = class
public
class function ReadBody(ARequest: TIdHTTPRequestInfo): TJSONObject;
class procedure SendJSON(AResponse: TIdHTTPResponseInfo; AObj: TJSONValue;
ACode: Integer = 200; AOwnsObj: Boolean = True);
class procedure SendError(AResponse: TIdHTTPResponseInfo; ACode: Integer;
const AMsg: string);
class procedure SendOK(AResponse: TIdHTTPResponseInfo; const AMessage: string = 'OK');
end;
implementation
class function TJSONHelper.ReadBody(ARequest: TIdHTTPRequestInfo): TJSONObject;
var
S: string;
LSS: TStringStream;
LValue: TJSONValue;
begin
Result := nil;
if ARequest.PostStream = nil then Exit(TJSONObject.Create);
LSS := TStringStream.Create('', TEncoding.UTF8);
try
ARequest.PostStream.Position := 0;
LSS.CopyFrom(ARequest.PostStream);
S := LSS.DataString;
finally
LSS.Free;
end;
if Trim(S) = '' then Exit(TJSONObject.Create);
LValue := TJSONObject.ParseJSONValue(S);
if LValue is TJSONObject then
Result := TJSONObject(LValue)
else
begin
LValue.Free;
Result := TJSONObject.Create;
end;
end;
class procedure TJSONHelper.SendJSON(AResponse: TIdHTTPResponseInfo;
AObj: TJSONValue; ACode: Integer; AOwnsObj: Boolean);
begin
AResponse.ResponseNo := ACode;
AResponse.ContentType := 'application/json; charset=utf-8';
AResponse.CharSet := 'utf-8';
AResponse.ContentText := AObj.ToJSON;
if AOwnsObj then AObj.Free;
end;
class procedure TJSONHelper.SendError(AResponse: TIdHTTPResponseInfo;
ACode: Integer; const AMsg: string);
var
LObj: TJSONObject;
begin
LObj := TJSONObject.Create;
LObj.AddPair('error', AMsg);
SendJSON(AResponse, LObj, ACode);
end;
class procedure TJSONHelper.SendOK(AResponse: TIdHTTPResponseInfo;
const AMessage: string);
var
LObj: TJSONObject;
begin
LObj := TJSONObject.Create;
LObj.AddPair('message', AMessage);
SendJSON(AResponse, LObj);
end;
end.
delphi-backend/Source/PM.RateLimit.pas
+94
View File
@@ -0,0 +1,94 @@
unit PM.RateLimit;
{
Mirrors api.php checkRateLimit / recordAttempt / clearAttempts.
15-minute window. Caller decides the threshold (5 for register, 10 for login).
}
interface
uses
System.SysUtils, FireDAC.Comp.Client, FireDAC.Stan.Param, IdCustomHTTPServer,
PM.Database;
function GetClientIP(ARequest: TIdHTTPRequestInfo): string;
function CheckRateLimit(const AIP: string): Integer;
procedure RecordAttempt(const AIP: string);
procedure ClearAttempts(const AIP: string);
implementation
function GetClientIP(ARequest: TIdHTTPRequestInfo): string;
begin
// api.php trusts X-Forwarded-For (security flaw H1 in audit). Since this
// server is loopback-only and not behind a proxy, prefer the actual peer IP.
Result := ARequest.RemoteIP;
if Result = '' then Result := 'unknown';
end;
function CheckRateLimit(const AIP: string): Integer;
var
LQ: TFDQuery;
begin
Result := 0;
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text :=
'SELECT COUNT(*) AS cnt FROM login_attempts ' +
'WHERE ip = :ip ' +
'AND attempted_at > datetime(''now'', ''-15 minutes'')';
LQ.ParamByName('ip').AsString := AIP;
LQ.Open;
Result := LQ.FieldByName('cnt').AsInteger;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
end;
procedure RecordAttempt(const AIP: string);
var
LQ: TFDQuery;
begin
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text := 'INSERT INTO login_attempts (ip) VALUES (:ip)';
LQ.ParamByName('ip').AsString := AIP;
LQ.ExecSQL;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
end;
procedure ClearAttempts(const AIP: string);
var
LQ: TFDQuery;
begin
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text := 'DELETE FROM login_attempts WHERE ip = :ip';
LQ.ParamByName('ip').AsString := AIP;
LQ.ExecSQL;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
end;
end.
delphi-backend/Source/PM.Router.pas
+104
View File
@@ -0,0 +1,104 @@
unit PM.Router;
{
URL dispatcher. Mirrors the switch(true) pattern of api.php.
Each handler unit registers its routes here. The Router itself owns no state.
}
interface
uses
System.SysUtils, System.Classes, System.Generics.Collections,
System.RegularExpressions,
IdCustomHTTPServer;
type
TRouteParams = TArray<string>;
TRouteHandler = reference to procedure(
ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo;
const AParams: TRouteParams);
TRoute = record
Method: string;
Pattern: string; // regex; ^ and $ added automatically
Regex: TRegEx;
Handler: TRouteHandler;
end;
TPMRouter = class
private
FRoutes: TList<TRoute>;
public
constructor Create;
destructor Destroy; override;
procedure Register(const AMethod, APattern: string;
const AHandler: TRouteHandler);
function DispatchRequest(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo): Boolean;
end;
var
Router: TPMRouter;
implementation
constructor TPMRouter.Create;
begin
inherited;
FRoutes := TList<TRoute>.Create;
end;
destructor TPMRouter.Destroy;
begin
FRoutes.Free;
inherited;
end;
procedure TPMRouter.Register(const AMethod, APattern: string;
const AHandler: TRouteHandler);
var
R: TRoute;
begin
R.Method := UpperCase(AMethod);
R.Pattern := APattern;
R.Regex := TRegEx.Create('^' + APattern + '$');
R.Handler := AHandler;
FRoutes.Add(R);
end;
function TPMRouter.DispatchRequest(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo): Boolean;
var
LRoute: TRoute;
LMatch: TMatch;
LParams: TRouteParams;
I: Integer;
LMethod, LPath: string;
begin
Result := False;
LMethod := UpperCase(ARequest.Command);
LPath := ARequest.Document;
for LRoute in FRoutes do
begin
if LRoute.Method <> LMethod then Continue;
LMatch := LRoute.Regex.Match(LPath);
if LMatch.Success then
begin
SetLength(LParams, LMatch.Groups.Count - 1);
for I := 1 to LMatch.Groups.Count - 1 do
LParams[I - 1] := LMatch.Groups[I].Value;
LRoute.Handler(ARequest, AResponse, LParams);
Exit(True);
end;
end;
end;
initialization
Router := TPMRouter.Create;
finalization
Router.Free;
end.
delphi-backend/Source/PM.Session.pas
+219
View File
@@ -0,0 +1,219 @@
unit PM.Session;
{
Session lookup + CSRF validation.
- Authenticate: read Bearer token from Authorization header, SHA256 it,
look up sessions.token_hash. Reject if missing/expired. Returns userId.
On failure, writes 401 + JSON error and raises ESessionRejected so the
handler aborts cleanly.
- RequireCSRF: for non-GET methods, validate X-CSRF-Token header against
the user's latest session csrf_token (constant-time compare).
}
interface
uses
System.SysUtils, System.Classes, System.StrUtils,
FireDAC.Comp.Client, FireDAC.Stan.Param,
IdCustomHTTPServer,
PM.Database, PM.Crypto, PM.JSON;
type
ESessionRejected = class(Exception);
function Authenticate(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo): Integer;
procedure RequireCSRF(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; AUserId: Integer);
function CreateSession(AUserId: Integer; out AToken, ACSRFToken: string): Boolean;
procedure DeleteSessionByTokenHash(const ATokenHash: string);
procedure DeleteAllUserSessions(AUserId: Integer);
implementation
uses
System.DateUtils;
function ExtractBearerToken(ARequest: TIdHTTPRequestInfo): string;
var
LAuth: string;
begin
LAuth := ARequest.RawHeaders.Values['Authorization'];
if LAuth.StartsWith('Bearer ', True) then
Result := Copy(LAuth, 8, MaxInt)
else
Result := '';
end;
function Authenticate(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo): Integer;
var
LToken, LTokenHash: string;
LQ: TFDQuery;
LExpires: TDateTime;
begin
Result := 0;
LToken := ExtractBearerToken(ARequest);
if LToken = '' then
begin
TJSONHelper.SendError(AResponse, 401, 'No token');
raise ESessionRejected.Create('no token');
end;
LTokenHash := SHA256Hex(LToken);
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text :=
'SELECT user_id, expires_at FROM sessions WHERE token_hash = :th';
LQ.ParamByName('th').AsString := LTokenHash;
LQ.Open;
if LQ.IsEmpty then
begin
TJSONHelper.SendError(AResponse, 401, 'Invalid session');
raise ESessionRejected.Create('invalid session');
end;
Result := LQ.FieldByName('user_id').AsInteger;
// Read as TDateTime directly — FireDAC parses SQLite DATETIME columns
// internally; using AsString would round-trip through system locale.
LExpires := LQ.FieldByName('expires_at').AsDateTime;
finally
LQ.Free;
end;
if (LExpires <> 0) and (LExpires < Now) then
begin
DeleteSessionByTokenHash(LTokenHash);
TJSONHelper.SendError(AResponse, 401, 'Session expired');
raise ESessionRejected.Create('expired');
end;
finally
DB.Unlock;
end;
end;
procedure RequireCSRF(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo; AUserId: Integer);
var
LSubmitted, LStored: string;
LQ: TFDQuery;
begin
if SameText(ARequest.Command, 'GET') then Exit;
LSubmitted := ARequest.RawHeaders.Values['X-CSRF-Token'];
if LSubmitted = '' then
begin
TJSONHelper.SendError(AResponse, 403, 'Missing CSRF token');
raise ESessionRejected.Create('missing csrf');
end;
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text :=
'SELECT csrf_token FROM sessions ' +
'WHERE user_id = :uid AND expires_at > datetime(''now'') ' +
'ORDER BY created_at DESC LIMIT 1';
LQ.ParamByName('uid').AsInteger := AUserId;
LQ.Open;
if LQ.IsEmpty then
begin
TJSONHelper.SendError(AResponse, 403, 'Invalid CSRF token');
raise ESessionRejected.Create('no session');
end;
LStored := LQ.FieldByName('csrf_token').AsString;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
if not ConstantTimeEquals(LStored, LSubmitted) then
begin
TJSONHelper.SendError(AResponse, 403, 'Invalid CSRF token');
raise ESessionRejected.Create('csrf mismatch');
end;
end;
function CreateSession(AUserId: Integer; out AToken, ACSRFToken: string): Boolean;
var
LQ: TFDQuery;
LTokenHash, LExpires: string;
begin
AToken := RandomHex(32);
ACSRFToken := RandomHex(32);
LTokenHash := SHA256Hex(AToken);
// YYYY-MM-DD HH:NN:SS, +24h, server local time (api.php uses date() = local)
LExpires := FormatDateTime('yyyy-mm-dd hh:nn:ss', IncHour(Now, 24));
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text :=
'INSERT INTO sessions (user_id, token_hash, csrf_token, expires_at) ' +
'VALUES (:uid, :th, :csrf, :exp)';
LQ.ParamByName('uid').AsInteger := AUserId;
LQ.ParamByName('th').AsString := LTokenHash;
LQ.ParamByName('csrf').AsString := ACSRFToken;
LQ.ParamByName('exp').AsString := LExpires;
LQ.ExecSQL;
Result := True;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
end;
procedure DeleteSessionByTokenHash(const ATokenHash: string);
var
LQ: TFDQuery;
begin
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text := 'DELETE FROM sessions WHERE token_hash = :th';
LQ.ParamByName('th').AsString := ATokenHash;
LQ.ExecSQL;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
end;
procedure DeleteAllUserSessions(AUserId: Integer);
var
LQ: TFDQuery;
begin
DB.Lock;
try
LQ := TFDQuery.Create(nil);
try
LQ.Connection := DB.Connection;
LQ.SQL.Text := 'DELETE FROM sessions WHERE user_id = :uid';
LQ.ParamByName('uid').AsInteger := AUserId;
LQ.ExecSQL;
finally
LQ.Free;
end;
finally
DB.Unlock;
end;
end;
end.
delphi-backend/Source/PM.StaticFiles.pas
+137
View File
@@ -0,0 +1,137 @@
unit PM.StaticFiles;
{
Static file server with directory-traversal protection.
Serves Z:\password-manager\ (index.html, js/, css/) from the loopback server,
so the embedded TTMSFNCWebBrowser can navigate to http://127.0.0.1:PORT/index.html
and the password-manager UI runs entirely inside the Delphi exe.
Same pattern as DeskInsight's Forms/UAIWorkbench.HTTPServer.pas Monaco server.
}
interface
uses
System.SysUtils, System.Classes, System.IOUtils, System.StrUtils,
IdCustomHTTPServer;
type
TStaticFileServer = class
private
FRootDir: string;
function ResolveSafePath(const ARequestPath: string; out AFullPath: string): Boolean;
function MimeTypeFor(const AExt: string): string;
public
constructor Create(const ARootDir: string);
function TryServe(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo): Boolean;
property RootDir: string read FRootDir;
end;
var
StaticServer: TStaticFileServer;
procedure InitStaticServer(const ARootDir: string);
procedure DoneStaticServer;
implementation
constructor TStaticFileServer.Create(const ARootDir: string);
begin
inherited Create;
FRootDir := TPath.GetFullPath(IncludeTrailingPathDelimiter(ARootDir));
end;
function TStaticFileServer.ResolveSafePath(const ARequestPath: string;
out AFullPath: string): Boolean;
var
LRelative, LCandidate: string;
begin
Result := False;
AFullPath := '';
LRelative := ARequestPath;
// Normalize: '/' or '' -> index.html
if (LRelative = '') or (LRelative = '/') then
LRelative := '/index.html';
// Strip leading slash, convert URL separators to OS separators
if (Length(LRelative) > 0) and (LRelative[1] = '/') then
Delete(LRelative, 1, 1);
LRelative := StringReplace(LRelative, '/', PathDelim, [rfReplaceAll]);
// Reject obvious traversal attempts (defense in depth — TPath.GetFullPath
// resolves '..' but rejecting up front gives a clean 404)
if (Pos('..', LRelative) > 0) or (Pos(':', LRelative) > 0) then Exit;
LCandidate := TPath.GetFullPath(TPath.Combine(FRootDir, LRelative));
// Critical check: the resolved path MUST be under FRootDir
if not LCandidate.StartsWith(FRootDir, True) then Exit;
if not TFile.Exists(LCandidate) then Exit;
AFullPath := LCandidate;
Result := True;
end;
function TStaticFileServer.MimeTypeFor(const AExt: string): string;
var
LExt: string;
begin
LExt := LowerCase(AExt);
if (LExt = '.html') or (LExt = '.htm') then Exit('text/html; charset=utf-8');
if LExt = '.js' then Exit('application/javascript; charset=utf-8');
if LExt = '.mjs' then Exit('application/javascript; charset=utf-8');
if LExt = '.css' then Exit('text/css; charset=utf-8');
if LExt = '.json' then Exit('application/json; charset=utf-8');
if LExt = '.svg' then Exit('image/svg+xml');
if LExt = '.png' then Exit('image/png');
if LExt = '.jpg' then Exit('image/jpeg');
if LExt = '.jpeg' then Exit('image/jpeg');
if LExt = '.gif' then Exit('image/gif');
if LExt = '.webp' then Exit('image/webp');
if LExt = '.ico' then Exit('image/x-icon');
if LExt = '.woff' then Exit('font/woff');
if LExt = '.woff2' then Exit('font/woff2');
if LExt = '.ttf' then Exit('font/ttf');
if LExt = '.map' then Exit('application/json');
if LExt = '.txt' then Exit('text/plain; charset=utf-8');
Result := 'application/octet-stream';
end;
function TStaticFileServer.TryServe(ARequest: TIdHTTPRequestInfo;
AResponse: TIdHTTPResponseInfo): Boolean;
var
LFullPath, LExt: string;
LFS: TFileStream;
begin
Result := False;
if not SameText(ARequest.Command, 'GET') then Exit;
if not ResolveSafePath(ARequest.Document, LFullPath) then Exit;
LExt := ExtractFileExt(LFullPath);
AResponse.ContentType := MimeTypeFor(LExt);
// Stream the file — Indy will set Content-Length and free the stream.
LFS := TFileStream.Create(LFullPath, fmOpenRead or fmShareDenyWrite);
AResponse.ContentStream := LFS;
AResponse.FreeContentStream := True;
AResponse.ResponseNo := 200;
Result := True;
end;
procedure InitStaticServer(const ARootDir: string);
begin
if StaticServer = nil then
StaticServer := TStaticFileServer.Create(ARootDir);
end;
procedure DoneStaticServer;
begin
FreeAndNil(StaticServer);
end;
initialization
finalization
DoneStaticServer;
end.
delphi-backend/UMainForm.fmx
+133
View File
@@ -0,0 +1,133 @@
object MainForm: TMainForm
Left = 0
Top = 0
Caption = 'Password Manager - Delphi Backend'
ClientHeight = 720
ClientWidth = 1100
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
OnCreate = FormCreate
OnDestroy = FormDestroy
OnCloseQuery = FormCloseQuery
DesignerMasterStyle = 0
object PanelTop: TPanel
Align = Top
Size.Width = 1100.000000000000000000
Size.Height = 56.000000000000000000
Size.PlatformDefault = False
TabOrder = 0
object lblPort: TLabel
Position.X = 16.000000000000000000
Position.Y = 18.000000000000000000
Size.Width = 40.000000000000000000
Size.Height = 20.000000000000000000
Size.PlatformDefault = False
TextSettings.Trimming = None
Text = 'Port:'
TabOrder = 0
end
object edtPort: TEdit
Touch.InteractiveGestures = [LongTap, DoubleTap]
TabOrder = 1
Text = '8765'
Position.X = 56.000000000000000000
Position.Y = 14.000000000000000000
Size.Width = 80.000000000000000000
Size.Height = 24.000000000000000000
Size.PlatformDefault = False
end
object btnStart: TButton
Position.X = 152.000000000000000000
Position.Y = 14.000000000000000000
Size.Width = 80.000000000000000000
Size.Height = 24.000000000000000000
Size.PlatformDefault = False
TabOrder = 2
Text = 'Start'
TextSettings.Trimming = None
OnClick = btnStartClick
end
object btnStop: TButton
Position.X = 240.000000000000000000
Position.Y = 14.000000000000000000
Size.Width = 80.000000000000000000
Size.Height = 24.000000000000000000
Size.PlatformDefault = False
TabOrder = 3
Text = 'Stop'
TextSettings.Trimming = None
OnClick = btnStopClick
end
object btnReload: TButton
Position.X = 328.000000000000000000
Position.Y = 14.000000000000000000
Size.Width = 80.000000000000000000
Size.Height = 24.000000000000000000
Size.PlatformDefault = False
TabOrder = 4
Text = 'Reload'
TextSettings.Trimming = None
OnClick = btnReloadClick
end
object btnToggleLog: TButton
Position.X = 416.000000000000000000
Position.Y = 14.000000000000000000
Size.Width = 90.000000000000000000
Size.Height = 24.000000000000000000
Size.PlatformDefault = False
TabOrder = 5
Text = 'Hide log'
TextSettings.Trimming = None
OnClick = btnToggleLogClick
end
object lblStatus: TLabel
Position.X = 520.000000000000000000
Position.Y = 18.000000000000000000
Size.Width = 560.000000000000000000
Size.Height = 20.000000000000000000
Size.PlatformDefault = False
TextSettings.Trimming = None
Text = 'Stopped'
TabOrder = 6
end
end
object PanelLog: TPanel
Align = Bottom
Position.Y = 564.000000000000000000
Size.Width = 1100.000000000000000000
Size.Height = 156.000000000000000000
Size.PlatformDefault = False
TabOrder = 1
object Memo: TMemo
Touch.InteractiveGestures = [Pan, LongTap, DoubleTap]
DataDetectorTypes = []
ReadOnly = True
TextSettings.Font.Family = 'Consolas'
Align = Client
Size.Width = 1100.000000000000000000
Size.Height = 156.000000000000000000
Size.PlatformDefault = False
TabOrder = 0
Viewport.Width = 1096.000000000000000000
Viewport.Height = 152.000000000000000000
end
end
object Splitter: TSplitter
Align = Bottom
Cursor = crVSplit
MinSize = 20.000000000000000000
Position.Y = 558.000000000000000000
Size.Width = 1100.000000000000000000
Size.Height = 6.000000000000000000
Size.PlatformDefault = False
end
object WebBrowser: TTMSFNCWebBrowser
Align = Client
Size.Width = 1100.000000000000000000
Size.Height = 502.000000000000000000
Size.PlatformDefault = False
TabOrder = 3
DesigntimeEnabled = False
end
end
delphi-backend/UMainForm.pas
+325
View File
@@ -0,0 +1,325 @@
unit UMainForm;
interface
uses
System.SysUtils, System.Classes, System.UITypes, System.NetEncoding,
FMX.Forms, FMX.Controls, FMX.Controls.Presentation, FMX.StdCtrls,
FMX.Memo, FMX.Memo.Types, FMX.ScrollBox, FMX.Edit, FMX.Layouts, FMX.Types,
FMX.Dialogs,
FMX.TMSFNCTypes, FMX.TMSFNCUtils, FMX.TMSFNCGraphics, FMX.TMSFNCGraphicsTypes,
FMX.TMSFNCCustomControl, FMX.TMSFNCWebBrowser,
PM.HTTPServer, PM.Bridge;
type
TMainForm = class(TForm)
PanelTop: TPanel;
btnStart: TButton;
btnStop: TButton;
lblStatus: TLabel;
edtPort: TEdit;
lblPort: TLabel;
btnToggleLog: TButton;
btnReload: TButton;
PanelLog: TPanel;
Memo: TMemo;
Splitter: TSplitter;
WebBrowser: TTMSFNCWebBrowser;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure btnStartClick(Sender: TObject);
procedure btnStopClick(Sender: TObject);
procedure btnToggleLogClick(Sender: TObject);
procedure btnReloadClick(Sender: TObject);
private
FServer: TPMHTTPServer;
FBridge: TPMBridge;
FPendingURL: string;
FNavTimer: TTimer;
FNavAttempts: Integer;
FQuitting: Boolean; // set when user picks "Quit" in tray menu — bypasses
// FormCloseQuery's minimize-to-tray intercept.
procedure LogLine(const AMsg: string);
procedure UpdateButtons;
procedure NavigateToVault;
procedure NavTimerTick(Sender: TObject);
// JS↔Delphi bridge
procedure WebBrowserBeforeNavigate(Sender: TObject;
var Params: TTMSFNCCustomWebBrowserBeforeNavigateParams);
procedure HandleBridgeCommand(const ACmd, AParams: string);
procedure BridgeSystemLock;
procedure BridgeTrayRestore;
procedure BridgeLockRequest;
procedure BridgeQuit;
end;
var
MainForm: TMainForm;
implementation
{$R *.fmx}
procedure TMainForm.FormCreate(Sender: TObject);
begin
FServer := TPMHTTPServer.Create;
FServer.OnLog := LogLine;
FBridge := TPMBridge.Create(Self);
FBridge.OnSystemLock := BridgeSystemLock;
FBridge.OnTrayRestore := BridgeTrayRestore;
FBridge.OnLockRequest := BridgeLockRequest;
FBridge.OnQuit := BridgeQuit;
// Wire the cmd:// bridge before any navigation happens.
WebBrowser.OnBeforeNavigate := WebBrowserBeforeNavigate;
// Delayed-Navigate timer: TTMSFNCWebBrowser (WebView2 backend) ignores
// Navigate() calls until Edge Chromium finishes its async init (~1-2s).
// We wait 1.5 s after Start, then issue a SINGLE Navigate — no retry loop
// (retrying caused the loaded page to reload every interval, making icons
// flash). If Edge needed longer than 1.5 s, user clicks Reload.
FNavTimer := TTimer.Create(Self);
FNavTimer.Interval := 1500;
FNavTimer.Enabled := False;
FNavTimer.OnTimer := NavTimerTick;
UpdateButtons;
LogLine('Password Manager - Delphi backend ready.');
LogLine('Click Start to launch server + embedded web vault.');
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
FBridge.Free;
FServer.Free;
end;
procedure TMainForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
// The tray-menu "Quit" handler sets FQuitting before triggering close,
// so we bypass the minimize-to-tray intercept in that case.
if FQuitting then Exit;
// Otherwise: minimize to tray on close instead of quitting, so the vault
// stays available without the dev-panel being visible.
// When the server is stopped, allow normal close — there's no vault to
// keep alive in the background.
if FServer.Active then
begin
CanClose := False;
FBridge.MinimizeToTray;
LogLine('Minimized to tray. Click the tray icon to restore.');
end;
end;
procedure TMainForm.LogLine(const AMsg: string);
begin
// Synchronize handles both cases: if already on main thread, runs inline;
// otherwise marshals. Avoids overload resolution issues with TThread.Queue.
TThread.Synchronize(nil,
procedure
begin
Memo.Lines.Add(FormatDateTime('hh:nn:ss', Now) + ' ' + AMsg);
Memo.GoToTextEnd;
end);
end;
procedure TMainForm.UpdateButtons;
begin
btnStart.Enabled := not FServer.Active;
btnStop.Enabled := FServer.Active;
btnReload.Enabled := FServer.Active;
edtPort.Enabled := not FServer.Active;
if FServer.Active then
lblStatus.Text := 'Running on http://127.0.0.1:' + edtPort.Text
else
lblStatus.Text := 'Stopped';
end;
procedure TMainForm.NavigateToVault;
begin
FPendingURL := 'http://127.0.0.1:' + edtPort.Text + '/index.html';
LogLine('Will navigate embedded browser in ~1.5s to: ' + FPendingURL);
// Schedule a single Navigate after Edge has had time to initialize.
FNavTimer.Enabled := False; // restart timer if already running
FNavTimer.Enabled := True;
end;
procedure TMainForm.NavTimerTick(Sender: TObject);
begin
FNavTimer.Enabled := False; // one-shot
if FPendingURL = '' then Exit;
LogLine('Navigating to: ' + FPendingURL);
WebBrowser.Navigate(FPendingURL);
FPendingURL := '';
end;
procedure TMainForm.btnStartClick(Sender: TObject);
var
LPort: Integer;
begin
LPort := StrToIntDef(edtPort.Text, 8765);
try
FServer.Start(LPort);
UpdateButtons;
NavigateToVault;
except
on E: Exception do
begin
LogLine('ERROR starting server: ' + E.Message);
MessageDlg('Failed to start: ' + E.Message,
TMsgDlgType.mtError, [TMsgDlgBtn.mbOK], 0);
end;
end;
end;
procedure TMainForm.btnStopClick(Sender: TObject);
begin
FServer.Stop;
UpdateButtons;
FPendingURL := '';
FNavTimer.Enabled := False;
WebBrowser.Navigate('about:blank');
end;
procedure TMainForm.btnReloadClick(Sender: TObject);
begin
if FServer.Active then NavigateToVault;
end;
procedure TMainForm.btnToggleLogClick(Sender: TObject);
begin
PanelLog.Visible := not PanelLog.Visible;
Splitter.Visible := PanelLog.Visible;
if PanelLog.Visible then
btnToggleLog.Text := 'Hide log'
else
btnToggleLog.Text := 'Show log';
end;
// ---------------------------------------------------------------------------
// JS↔Delphi bridge
// ---------------------------------------------------------------------------
procedure TMainForm.WebBrowserBeforeNavigate(Sender: TObject;
var Params: TTMSFNCCustomWebBrowserBeforeNavigateParams);
var
URL, Cmd, ParamStr: string;
P: Integer;
begin
URL := Params.URL;
if not URL.StartsWith('cmd://') then Exit;
Params.Cancel := True;
URL := URL.Substring(6); // strip 'cmd://'
P := Pos('?', URL);
if P > 0 then
begin
Cmd := Copy(URL, 1, P - 1);
ParamStr := Copy(URL, P + 1, MaxInt);
end
else
begin
Cmd := URL;
ParamStr := '';
end;
// Defer to avoid WebView2 re-entrance issues.
TThread.ForceQueue(nil,
procedure
begin
HandleBridgeCommand(Cmd, ParamStr);
end);
end;
procedure TMainForm.HandleBridgeCommand(const ACmd, AParams: string);
function GetParam(const AKey: string): string;
var
Parts: TArray<string>;
Part, K, V: string;
EqPos: Integer;
begin
Result := '';
Parts := AParams.Split(['&']);
for Part in Parts do
begin
EqPos := Pos('=', Part);
if EqPos > 0 then
begin
K := Copy(Part, 1, EqPos - 1);
V := Copy(Part, EqPos + 1, MaxInt);
if SameText(K, AKey) then
begin
Result := TNetEncoding.URL.Decode(V);
Exit;
end;
end;
end;
end;
var
LText: string;
LClearMs: Integer;
begin
if ACmd = 'clipboard/copy' then
begin
LText := GetParam('text');
LClearMs := StrToIntDef(GetParam('clear'), 30000);
FBridge.SecureClipboard.SetText(LText, LClearMs);
LogLine(Format('Secure clipboard set (auto-clear in %ds)', [LClearMs div 1000]));
end
else if ACmd = 'clipboard/clear' then
begin
FBridge.SecureClipboard.Clear;
LogLine('Clipboard cleared by JS request');
end
else
LogLine('Bridge: unknown command "' + ACmd + '"');
end;
procedure TMainForm.BridgeSystemLock;
begin
// Windows session locked — lock the vault in the JS layer immediately.
LogLine('Windows session locked — locking vault');
WebBrowser.ExecuteJavaScript('if(typeof lockVault==="function")lockVault()');
end;
procedure TMainForm.BridgeTrayRestore;
begin
FBridge.RestoreFromTray;
// Notify the JS layer: the UI may want to reset the auto-lock timer,
// refresh state, or show a "welcome back" toast.
WebBrowser.ExecuteJavaScript(
'if(window.Bridge&&typeof Bridge.onTrayRestore==="function")Bridge.onTrayRestore()');
LogLine('Restored from tray');
end;
procedure TMainForm.BridgeLockRequest;
begin
// User picked "Lock vault" from the tray menu. Trigger lockVault() in
// JS — same path as the WTS_SESSION_LOCK auto-lock.
LogLine('Lock requested from tray menu');
WebBrowser.ExecuteJavaScript('if(typeof lockVault==="function")lockVault()');
end;
procedure TMainForm.BridgeQuit;
begin
// Re-entry guard: if Quit was already requested, ignore further calls.
if FQuitting then Exit;
LogLine('>>> BridgeQuit invoked (Quit from tray menu)');
FQuitting := True;
// Restore the form first so the tray icon goes away and FormDestroy
// executes from a normal (non-hidden) state. RestoreFromTray also
// deletes the tray icon.
FBridge.RestoreFromTray;
Application.Terminate;
end;
end.
delphi-backend/assets/BuildAssets.cmd
+21
View File
@@ -0,0 +1,21 @@
@echo off
REM Wrapper around BuildAssets.ps1 — captures stdout+stderr to build.log
REM so Delphi's pre-build event can call this without worrying about
REM cmd.exe '&' escape rules.
REM
REM Usage in Delphi pre-build event:
REM "Z:\password-manager\delphi-backend\assets\BuildAssets.cmd"
set "SCRIPT_DIR=%~dp0"
set "LOG=%SCRIPT_DIR%build.log"
echo === BuildAssets.cmd at %DATE% %TIME% === > "%LOG%"
echo Calling PowerShell... >> "%LOG%"
powershell -NoProfile -ExecutionPolicy Bypass -File "%SCRIPT_DIR%BuildAssets.ps1" >> "%LOG%" 2>&1
set RC=%ERRORLEVEL%
echo. >> "%LOG%"
echo Exit code: %RC% >> "%LOG%"
exit /b %RC%
delphi-backend/assets/BuildAssets.ps1
+135
View File
@@ -0,0 +1,135 @@
# BuildAssets.ps1
# Generates assets.rc + assets.res containing the static web assets
# (index.html, js/*, css/*) so they can be linked into PMServer.exe as
# Win32 RCDATA resources.
#
# Workflow:
# 1. Edit Z:\password-manager\index.html / js\app.js / css\style.css
# 2. Run this script (or set it as pre-build event in Delphi)
# 3. Build PMServer.dpr in Delphi
# 4. Run - exe is autonomous, no external files needed at runtime
#
# Resource naming: URL path '/js/app.js' -> resource 'JS_APP_JS'
# - strip leading '/'
# - replace '/' '\' '.' '-' with '_'
# - uppercase
[CmdletBinding()]
param(
[string] $WebRoot = '',
[string] $OutRC = '',
[string] $OutRES = '',
[string] $OutInc = ''
)
$ErrorActionPreference = 'Stop'
# Resolve $PSScriptRoot — may be empty depending on invocation context.
# Fallback to the script's own file path.
$ScriptDir = $PSScriptRoot
if (-not $ScriptDir) { $ScriptDir = Split-Path -Parent $MyInvocation.MyCommand.Definition }
if (-not $ScriptDir) { $ScriptDir = (Get-Location).Path }
# Apply param defaults now that we have a valid script dir
if (-not $WebRoot) { $WebRoot = Join-Path $ScriptDir '..\..' }
if (-not $OutRC) { $OutRC = Join-Path $ScriptDir 'assets.rc' }
if (-not $OutRES) { $OutRES = Join-Path $ScriptDir 'assets.res' }
if (-not $OutInc) { $OutInc = Join-Path $ScriptDir 'assets.inc' }
# All output goes to stdout/stderr. When invoked via BuildAssets.cmd the
# wrapper captures both streams into build.log; when run interactively
# everything shows in the terminal.
function Log { param([string] $msg) Write-Host $msg }
try {
$WebRoot = (Resolve-Path $WebRoot).Path
Log "Web root: $WebRoot"
# Whitelist patterns (relative to WebRoot). Add more here when needed.
# Use exact paths (not wildcards) to avoid embedding *-legacy.* backups.
$patterns = @(
'index.html',
'js\app.js',
'css\style.css'
)
# Discover files
$files = @()
foreach ($p in $patterns) {
$found = Get-ChildItem -Path (Join-Path $WebRoot $p) -File -ErrorAction SilentlyContinue
foreach ($f in $found) {
$rel = $f.FullName.Substring($WebRoot.Length).TrimStart('\','/')
$files += [pscustomobject]@{
FullPath = $f.FullName
Relative = $rel
UrlPath = '/' + ($rel -replace '\\','/')
ResName = ($rel -replace '[\\/\.\-]','_').ToUpperInvariant()
}
}
}
if ($files.Count -eq 0) {
throw "No assets found under $WebRoot. Check the patterns."
}
Log "Embedding $($files.Count) file(s):"
$files | ForEach-Object { Log (" " + $_.UrlPath + " -> " + $_.ResName) }
# --- Generate assets.rc -------------------------------------------------------
$rc = New-Object System.Text.StringBuilder
[void]$rc.AppendLine('// Auto-generated by BuildAssets.ps1 - do not edit by hand.')
[void]$rc.AppendLine('#pragma code_page(65001)')
[void]$rc.AppendLine('')
foreach ($f in $files) {
# brcc32 accepts forward slashes; backslashes need to be doubled in C strings
$rcPath = $f.FullPath -replace '\\','\\'
[void]$rc.AppendLine("$($f.ResName) RCDATA `"$rcPath`"")
}
[System.IO.File]::WriteAllText($OutRC, $rc.ToString(), [System.Text.Encoding]::ASCII)
Log "Wrote $OutRC"
# --- Generate assets.inc (Pascal include with manifest) -----------------------
# Compile-time mapping URL -> resource name, consumed by PM.EmbeddedAssets.pas.
$nl = [Environment]::NewLine
$inc = New-Object System.Text.StringBuilder
[void]$inc.Append('// Auto-generated by BuildAssets.ps1 - do not edit by hand.' + $nl)
[void]$inc.Append('const' + $nl)
[void]$inc.Append(' EMBEDDED_ASSET_COUNT = ' + $files.Count + ';' + $nl)
[void]$inc.Append(' EMBEDDED_ASSETS: array[0..EMBEDDED_ASSET_COUNT-1] of TEmbeddedAsset = (' + $nl)
for ($i = 0; $i -lt $files.Count; $i++) {
$f = $files[$i]
if ($i -eq $files.Count - 1) { $sep = '' } else { $sep = ',' }
$line = " (UrlPath: '" + $f.UrlPath + "'; ResName: '" + $f.ResName + "')" + $sep + $nl
[void]$inc.Append($line)
}
[void]$inc.Append(' );' + $nl)
[System.IO.File]::WriteAllText($OutInc, $inc.ToString(), [System.Text.Encoding]::UTF8)
Log "Wrote $OutInc"
# --- Compile to .res via brcc32 ----------------------------------------------
$brcc = $null
if ($env:BDS) {
$candidate = Join-Path $env:BDS 'bin\brcc32.exe'
if (Test-Path $candidate) { $brcc = $candidate }
}
if (-not $brcc) {
$cmd = Get-Command brcc32.exe -ErrorAction SilentlyContinue
if ($cmd) { $brcc = $cmd.Source }
}
if (-not $brcc) {
throw "brcc32.exe not found. Set the BDS environment variable to your Delphi install root, or add brcc32.exe to PATH."
}
Log "Using $brcc"
& $brcc -32 -fo "$OutRES" "$OutRC"
if ($LASTEXITCODE -ne 0) { throw "brcc32 failed with exit code $LASTEXITCODE" }
Log "Wrote $OutRES"
Log "OK"
} catch {
Log "FATAL: $($_.Exception.Message)"
Log "Stack: $($_.ScriptStackTrace)"
exit 1
}
delphi-backend/assets/assets.inc
+8
View File
@@ -0,0 +1,8 @@
// Auto-generated by BuildAssets.ps1 - do not edit by hand.
const
EMBEDDED_ASSET_COUNT = 3;
EMBEDDED_ASSETS: array[0..EMBEDDED_ASSET_COUNT-1] of TEmbeddedAsset = (
(UrlPath: '/index.html'; ResName: 'INDEX_HTML'),
(UrlPath: '/js/app.js'; ResName: 'JS_APP_JS'),
(UrlPath: '/css/style.css'; ResName: 'CSS_STYLE_CSS')
);
delphi-backend/assets/assets.rc
+6
View File
@@ -0,0 +1,6 @@
// Auto-generated by BuildAssets.ps1 - do not edit by hand.
#pragma code_page(65001)
INDEX_HTML RCDATA "Z:\\password-manager\\index.html"
JS_APP_JS RCDATA "Z:\\password-manager\\js\\app.js"
CSS_STYLE_CSS RCDATA "Z:\\password-manager\\css\\style.css"
delphi-backend/assets/assets.res
BIN
View File
Binary file not shown.
js/app.js
+2150 -1457
View File
File diff suppressed because it is too large Load Diff