ewsdr/WinFirewall.pas

unit WinFirewall;

{
  WinFirewall.pas — управление правилами Windows Firewall для HPSDR-приложения.

  Логика работы:
    1. Сначала пробуем добавить все недостающие правила через COM без elevation.
       Если программа запущена с правами администратора — всё добавится сразу.
    2. Если COM не удался (нет прав) — собираем ВСЕ недостающие правила в одну
       batch-команду и вызываем UAC elevation ОДИН РАЗ.

  Создаёт до 4 правил (каждое проверяется по имени, дубли не добавляются):
    "<AppName> UDP In"   — входящий  UDP (HPSDR Protocol 2)
    "<AppName> UDP Out"  — исходящий UDP (HPSDR Protocol 2)
    "<AppName> TCP In"   — входящий  TCP (WebSocket/HTTP сервер)
    "<AppName> TCP Out"  — исходящий TCP (WebSocket/HTTP сервер)
}

{$mode objfpc}{$H+}

interface

uses SysUtils;

function  FirewallRuleExists(const RuleName: string): Boolean;
procedure FirewallEnsureAllowed(const ExePath, AppName: string);

implementation

{$IFDEF WINDOWS}
uses
  Windows, ComObj, ActiveX, Variants, ShellAPI;

const
  PROGID_NETFW_POLICY2    = 'HNetCfg.FwPolicy2';
  PROGID_NETFW_RULE       = 'HNetCfg.FWRule';
  NET_FW_RULE_DIR_IN      = 1;
  NET_FW_RULE_DIR_OUT     = 2;
  NET_FW_IP_PROTOCOL_TCP  = 6;
  NET_FW_IP_PROTOCOL_UDP  = 17;
  NET_FW_ACTION_ALLOW     = 1;
  FW_PROFILE_ALL          = Integer($7FFFFFFF);
  SEE_MASK_NOCLOSEPROCESS = DWORD($00000040);
  SEE_MASK_FLAG_NO_UI     = DWORD($00000400);

{ ── Проверка наличия правила через COM ───────────────────────────────────── }

function FirewallRuleExists(const RuleName: string): Boolean;
var
  FwPolicy2: OleVariant;
  FwRules:   OleVariant;
  FwRule:    OleVariant;
  Enum:      IEnumVariant;
  fetched:   LongWord;
  v:         OleVariant;
begin
  Result := False;
  try
    CoInitialize(nil);
    try
      FwPolicy2 := CreateOleObject(PROGID_NETFW_POLICY2);
      FwRules   := FwPolicy2.Rules;
      Enum      := IEnumVariant(IUnknown(FwRules._NewEnum));
      if Enum = nil then Exit;
      while Enum.Next(1, v, fetched) = S_OK do
      begin
        if fetched = 0 then Break;
        try
          FwRule := v;
          if CompareText(string(FwRule.Name), RuleName) = 0 then
          begin
            Result := True;
            Break;
          end;
        except
        end;
        v := Unassigned;
      end;
    finally
      CoUninitialize;
    end;
  except
    Result := False;
  end;
end;

{ ── Добавление одного правила через COM (без elevation) ───────────────────── }

function TryAddRuleCOM(const ExePath, RuleName: string;
  Protocol, Direction: Integer; const Description: string): Boolean;
var
  FwPolicy2: OleVariant;
  FwRules:   OleVariant;
  FwRule:    OleVariant;
begin
  Result := False;
  try
    CoInitialize(nil);
    try
      FwPolicy2 := CreateOleObject(PROGID_NETFW_POLICY2);
      FwRules   := FwPolicy2.Rules;
      FwRule    := CreateOleObject(PROGID_NETFW_RULE);

      FwRule.Name        := RuleName;
      FwRule.Description := Description;
      FwRule.Protocol    := Protocol;
      FwRule.Direction   := Direction;
      FwRule.Action      := NET_FW_ACTION_ALLOW;
      FwRule.Profiles    := FW_PROFILE_ALL;
      FwRule.Enabled     := True;

      // ApplicationName только для входящих — для исходящих netsh dir=out
      // тоже не принимает program= на ряде версий Windows, поэтому
      // ограничиваем по приложению только In-правила
      if Direction = NET_FW_RULE_DIR_IN then
        FwRule.ApplicationName := ExePath;

      FwRules.Add(FwRule);
      Result := True;
    finally
      CoUninitialize;
    end;
  except
    Result := False;
  end;
end;

{ ── Elevation: добавляем ВСЕ недостающие правила ОДНИМ вызовом UAC ─────────
  Параметр Cmd — готовая batch-строка с несколькими netsh-командами,
  разделёнными через &&. Запускается cmd.exe /C "..." через runas.          }

procedure RunElevated(const Cmd: AnsiString);
var
  SEI:      TShellExecuteInfoA;
  FileBuf:  array[0..15]   of AnsiChar;
  VerbBuf:  array[0..7]    of AnsiChar;
  ParamBuf: array[0..4095] of AnsiChar;
begin
  StrPCopy(FileBuf,  'cmd.exe');
  StrPCopy(VerbBuf,  'runas');
  StrPCopy(ParamBuf, Cmd);

  FillChar(SEI, SizeOf(SEI), 0);
  SEI.cbSize       := SizeOf(SEI);
  SEI.fMask        := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_NO_UI;
  SEI.lpVerb       := @VerbBuf[0];
  SEI.lpFile       := @FileBuf[0];
  SEI.lpParameters := @ParamBuf[0];
  SEI.nShow        := SW_HIDE;

  if ShellExecuteExA(@SEI) and (SEI.hProcess <> 0) then
  begin
    WaitForSingleObject(SEI.hProcess, 15000);
    CloseHandle(SEI.hProcess);
  end;
end;

function NetshAddRule(const RuleName, ExePath, Proto, Dir: string): string;
begin
  // Строит одну netsh-команду для добавления правила.
  // program= добавляем только для входящих (dir=in), для dir=out не указываем —
  // Windows Firewall для Out-правил program= игнорирует или отклоняет.
  Result := 'netsh advfirewall firewall add rule' +
    ' name="'    + RuleName + '"' +
    ' dir='      + Dir +
    ' action=allow' +
    ' protocol=' + Proto +
    ' enable=yes profile=any';
  if Dir = 'in' then
    Result := Result + ' program="' + ExePath + '"';
end;

{ ── Основная точка входа ─────────────────────────────────────────────────── }

procedure FirewallEnsureAllowed(const ExePath, AppName: string);
type
  TRuleInfo = record
    Name:     string;
    Proto:    Integer;
    Dir:      Integer;
    Desc:     string;
    ProtoStr: string;
    DirStr:   string;
  end;
const
  RULE_COUNT = 4;
var
  Rules:       array[0..RULE_COUNT-1] of TRuleInfo;
  i:           Integer;
  NeedElevate: Boolean;
  BatchCmd:    AnsiString;
  Sep:         AnsiString;
begin
  // Описываем все 4 правила
  Rules[0].Name     := AppName + ' UDP In';
  Rules[0].Proto    := NET_FW_IP_PROTOCOL_UDP;
  Rules[0].Dir      := NET_FW_RULE_DIR_IN;
  Rules[0].Desc     := 'HPSDR Protocol 2 UDP inbound';
  Rules[0].ProtoStr := 'udp';
  Rules[0].DirStr   := 'in';

  Rules[1].Name     := AppName + ' UDP Out';
  Rules[1].Proto    := NET_FW_IP_PROTOCOL_UDP;
  Rules[1].Dir      := NET_FW_RULE_DIR_OUT;
  Rules[1].Desc     := 'HPSDR Protocol 2 UDP outbound';
  Rules[1].ProtoStr := 'udp';
  Rules[1].DirStr   := 'out';

  Rules[2].Name     := AppName + ' TCP In';
  Rules[2].Proto    := NET_FW_IP_PROTOCOL_TCP;
  Rules[2].Dir      := NET_FW_RULE_DIR_IN;
  Rules[2].Desc     := 'HPSDR WebSocket/HTTP server TCP inbound';
  Rules[2].ProtoStr := 'tcp';
  Rules[2].DirStr   := 'in';

  Rules[3].Name     := AppName + ' TCP Out';
  Rules[3].Proto    := NET_FW_IP_PROTOCOL_TCP;
  Rules[3].Dir      := NET_FW_RULE_DIR_OUT;
  Rules[3].Desc     := 'HPSDR WebSocket/HTTP server TCP outbound';
  Rules[3].ProtoStr := 'tcp';
  Rules[3].DirStr   := 'out';

  // Шаг 1: пробуем добавить через COM без elevation.
  // Если запущены с правами админа — всё добавится здесь, UAC не понадобится.
  NeedElevate := False;
  for i := 0 to RULE_COUNT - 1 do
  begin
    if FirewallRuleExists(Rules[i].Name) then Continue;
    if not TryAddRuleCOM(ExePath, Rules[i].Name,
                         Rules[i].Proto, Rules[i].Dir, Rules[i].Desc) then
      NeedElevate := True;  // COM не удался — запомним, соберём batch
  end;

  if not NeedElevate then Exit;

  // Шаг 2: COM не удался (нет прав). Собираем ВСЕ недостающие правила
  // в одну batch-строку и поднимаем UAC ровно ОДИН РАЗ.
  BatchCmd := '/C ';
  Sep      := '';
  for i := 0 to RULE_COUNT - 1 do
  begin
    if FirewallRuleExists(Rules[i].Name) then Continue;
    BatchCmd := BatchCmd + Sep +
      AnsiString(NetshAddRule(Rules[i].Name, ExePath,
                              Rules[i].ProtoStr, Rules[i].DirStr));
    Sep := ' && ';
  end;

  if BatchCmd <> '/C ' then
    RunElevated(BatchCmd);
end;

{$ELSE}

{ ── Заглушки для Linux / macOS ───────────────────────────────────────────── }

function FirewallRuleExists(const RuleName: string): Boolean;
begin
  Result := True;
end;

procedure FirewallEnsureAllowed(const ExePath, AppName: string);
begin
end;

{$ENDIF}

end.