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,
  Winapi.Windows,
  IdHTTPServer, IdContext, IdCustomHTTPServer, IdSocketHandle, IdTCPConnection,
  PM.Router, PM.JSON, PM.Database, PM.StaticFiles, PM.EmbeddedAssets,
  PM.Crypto, PM.ProcessLockdown, PM.Session;

type
  TLogProc = reference to procedure(const AMsg: string);

  TPMHTTPServer = class
  private
    FServer: TIdHTTPServer;
    FOnLog: TLogProc;
    FAccessToken: string;
    FRequireAccessToken: Boolean;
    FRequireProcessCheck: Boolean;
    FBoundPort: Integer;
    procedure HandleCommand(AContext: TIdContext;
      ARequest: TIdHTTPRequestInfo; AResponse: TIdHTTPResponseInfo);
    procedure HandleCommandOther(AContext: TIdContext;
      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;
    function ValidateAccessToken(ARequest: TIdHTTPRequestInfo;
      AResponse: TIdHTTPResponseInfo): Boolean;
    function ValidateConnectingProcess(AContext: TIdContext;
      AResponse: TIdHTTPResponseInfo): Boolean;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Start(APort: Integer; SameFolder: Boolean;
      ARequireAccessToken: Boolean = True;
      ARequireProcessCheck: Boolean = True);
    procedure Stop;
    property Active: Boolean read GetActive;
    property OnLog: TLogProc read FOnLog write FOnLog;
    property AccessToken: string read FAccessToken;
    property RequireAccessToken: Boolean read FRequireAccessToken;
    property RequireProcessCheck: Boolean read FRequireProcessCheck;
    property BoundPort: Integer read FBoundPort;
  end;

implementation

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; SameFolder: Boolean;
  ARequireAccessToken: Boolean; ARequireProcessCheck: Boolean);
const
  EphemeralPortMin = 49152;
  EphemeralPortMax = 65535;
  // Trois essais : le port demande, puis deux replis. Au-dela, ce n'est plus
  // un port occupe mais une pile reseau qui ne veut pas de nous, et insister
  // ne ferait que retarder le message d'erreur.
  BindAttempts = 3;

  /// Un port ephemere tire du generateur cryptographique de Windows.
  ///
  /// PAS Random() : Randomize n'est appele nulle part dans ce programme, donc
  /// Random rend la MEME suite a chaque lancement - le port "aleatoire" de
  /// `port=0` etait en realite le meme tous les jours, ce qui vide de son sens
  /// l'aleatoire cense compliquer un balayage exterieur. RandomBytes passe par
  /// BCryptGenRandom, deja utilise pour le jeton d'acces.
  function PickEphemeralPort: Integer;
  var
    LRaw: TBytes;
  begin
    LRaw := PM.Crypto.RandomBytes(2);
    Result := EphemeralPortMin +
      ((LRaw[0] shl 8 or LRaw[1]) mod (EphemeralPortMax - EphemeralPortMin + 1));
  end;

var
  LBinding: TIdSocketHandle;
  LDBPath, LWebRoot, LResolvedPort: string;
  LRequestedPort, LAttempt: Integer;
begin
  if FServer.Active then Exit;

  FRequireAccessToken  := ARequireAccessToken;
  FRequireProcessCheck := ARequireProcessCheck;
  if FRequireAccessToken then
    FAccessToken := PM.Crypto.RandomHex(32)
  else
    FAccessToken := '';

  LRequestedPort := APort;
  if LRequestedPort = 0 then
    LRequestedPort := PickEphemeralPort;

  var pathParent := '..\';
  if SameFolder then
    pathParent := '';
  LDBPath  := TPath.GetFullPath(TPath.Combine(ExtractFilePath(ParamStr(0)), pathParent+'vault.db'));
  LWebRoot := TPath.GetFullPath(TPath.Combine(ExtractFilePath(ParamStr(0)), pathParent));
  Log('Opening database: ' + LDBPath);
  InitDatabase(LDBPath);
  Log('Database ready.');
  Log('Web root: ' + LWebRoot);
  InitStaticServer(LWebRoot);

  // SE LIER EST LE TEST, ET IL N'Y EN A PAS D'AUTRE QUI VAILLE.
  //
  // On pourrait sonder le port avant, pour voir si quelqu'un repond. Ce serait
  // a la fois plus faible et plus fragile : un service qui ecoute sans repondre
  // passerait inapercu, et le port peut etre pris entre le sondage et le lien.
  // Tenter le lien tranche pour de bon, sans course.
  //
  // Le PREMIER essai honore le port demande - celui de config.txt, que
  // l'utilisateur a peut-etre choisi expres. Les suivants prennent un port
  // ephemere, exactement ce que fait un lancement sans port configure. Et on le
  // DIT a chaque fois : un serveur qui deplace son port en silence est pire
  // qu'un serveur qui refuse de demarrer, parce que rien n'explique ensuite
  // pourquoi une adresse notee quelque part ne repond plus.
  for LAttempt := 1 to BindAttempts do
  begin
    FServer.Bindings.Clear;
    LBinding := FServer.Bindings.Add;
    LBinding.IP := '127.0.0.1';
    LBinding.Port := LRequestedPort;
    try
      FServer.Active := True;
      Break;
    except
      on E: Exception do
      begin
        FServer.Active := False;   // Indy peut laisser le lien a moitie ouvert
        Log(Format('Port %d unavailable: %s', [LRequestedPort, E.Message]));
        // Le dernier echec remonte tel quel : l'appelant sait deja l'afficher.
        if LAttempt = BindAttempts then raise;
        LRequestedPort := PickEphemeralPort;
        Log(Format('  falling back to port %d (attempt %d of %d)',
          [LRequestedPort, LAttempt + 1, BindAttempts]));
      end;
    end;
  end;
  FBoundPort := LRequestedPort;
  LResolvedPort := IntToStr(FBoundPort);
  Log(Format('Server started on http://127.0.0.1:%s  (token:%s  process_check:%s)',
    [LResolvedPort,
     BoolToStr(FRequireAccessToken, True),
     BoolToStr(FRequireProcessCheck, True)]));
end;

procedure TPMHTTPServer.Stop;
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';
  // Content-Security-Policy — tightened May 2026:
  //   - script-src: removed 'unsafe-inline'. No <script> tags inline in the
  //     served HTML — only external js/app.js. Real XSS defense.
  //   - style-src: KEPT 'unsafe-inline' because index.html has inline
  //     style="" attributes and app.js sets element.style.cssText
  //     extensively. Refactoring that to use CSS classes would be a
  //     separate cleanup pass. Style injection alone cannot execute code,
  //     so the risk is bounded to visual manipulation / data exfil via
  //     CSS selectors (low impact in a single-user loopback app).
  //   - connect-src: 'self' + api.pwnedpasswords.com to allow the HIBP
  //     range API. Only the SHA-1[0..5] prefix ever leaves the machine.
  AResponse.CustomHeaders.Values['Content-Security-Policy'] :=
    'default-src ''self''; ' +
    'script-src ''self''; ' +
    'style-src ''self'' ''unsafe-inline''; ' +
    'connect-src ''self'' https://api.pwnedpasswords.com; ' +
    '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;

function TPMHTTPServer.ValidateConnectingProcess(AContext: TIdContext;
  AResponse: TIdHTTPResponseInfo): Boolean;
var
  Binding: TIdSocketHandle;
  ConnectingPid: DWORD;
begin
  if not FRequireProcessCheck then Exit(True);
  Result := False;

  Binding := AContext.Binding;
  if Binding = nil then
  begin
    AResponse.ResponseNo := 404;
    AResponse.ContentText := '';
    Exit;
  end;

  ConnectingPid := GetPidOfTcpConnection(Word(Binding.PeerPort), Word(Binding.Port));
  if (ConnectingPid <> 0) and IsDescendantOfCurrentProcess(ConnectingPid) then
    Exit(True);

  Log(Format('Rejected request from foreign PID %d (%s %s)',
    [ConnectingPid, AContext.Connection.Socket.Binding.PeerIP, '']));
  AResponse.ResponseNo := 404;
  AResponse.ContentText := '';
end;

function TPMHTTPServer.ValidateAccessToken(ARequest: TIdHTTPRequestInfo;
  AResponse: TIdHTTPResponseInfo): Boolean;
const
  CookieName       = 'pm_token';
  QueryParamName   = 'pmt';
  SetCookieHeader  = 'Set-Cookie';
var
  CookieHeader, QueryToken: string;
begin
  if not FRequireAccessToken then Exit(True);

  CookieHeader := ARequest.RawHeaders.Values['Cookie'];
  if (CookieHeader <> '') and
     (Pos(CookieName + '=' + FAccessToken, CookieHeader) > 0) then
    Exit(True);

  QueryToken := ARequest.Params.Values[QueryParamName];
  if QueryToken = FAccessToken then
  begin
    AResponse.CustomHeaders.AddValue(SetCookieHeader,
      CookieName + '=' + FAccessToken +
      '; Path=/; HttpOnly; SameSite=Strict');
    Exit(True);
  end;

  AResponse.ResponseNo  := 404;
  AResponse.ContentText := '';
  Result := False;
end;

procedure TPMHTTPServer.HandleCommand(AContext: TIdContext;
  ARequest: TIdHTTPRequestInfo; AResponse: TIdHTTPResponseInfo);
begin
  ApplySecurityHeaders(ARequest, AResponse);
  if not ValidateConnectingProcess(AContext, AResponse) then Exit;
  if not ValidateAccessToken(ARequest, AResponse) then Exit;
  try
    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
    // Authenticate/RequireCSRF already wrote the 401 — don't overwrite it
    // with a 500. Any handler that doesn't wrap Authenticate lands here.
    on ESessionRejected do Exit;
    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);
  if SameText(ARequest.Command, 'OPTIONS') then
  begin
    AResponse.ResponseNo := 204;
    AResponse.ContentText := '';
    Exit;
  end;
  if not ValidateConnectingProcess(AContext, AResponse) then Exit;
  if not ValidateAccessToken(ARequest, AResponse) then Exit;
  try
    if not Router.DispatchRequest(ARequest, AResponse) then
      TJSONHelper.SendError(AResponse, 404, 'Not found');
  except
    on ESessionRejected do Exit;   // 401 already sent — keep it, don't 500
    on E: Exception do
    begin
      Log('ERROR ' + ARequest.Command + ' ' + ARequest.Document + ' : ' + E.Message);
      TJSONHelper.SendError(AResponse, 500, 'Internal server error');
    end;
  end;
end;

end.