Files
Password-Manager/delphi-backend/Handlers/PM.Handler.Folders.pas
T
Zaki 506aee7e6f feat: Delphi backend + JS↔Delphi bridge (clipboard, tray, auto-lock)
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.
2026-05-22 23:47:57 +01:00

201 lines
4.8 KiB
ObjectPascal

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.