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
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.