Password-Manager/delphi-backend/Source/PM.HTTPServer.pas

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.