unit Sparkle.HttpSys.Config;

{$I Sparkle.Inc}

interface

{$IFDEF MSWINDOWS}
uses
  Generics.Collections, System.SysUtils, Winapi.Windows,
  Sparkle.HttpSys.Api;

type
  TUrlAclInfo = class
  strict private
    FInfo: PHTTP_SERVICE_CONFIG_URLACL_SET;
  private
    FBuffer: TBytes;
    function GetUrlPrefix: string;
    function GetSecurityDescriptor: string;
  public
    constructor Create(const Buffer: TBytes);
    property UrlPrefix: string read GetUrlPrefix;
    property SecurityDescriptor: string read GetSecurityDescriptor;
    property Buffer: TBytes read FBuffer;
  end;

  TSslCertInfo = class
  strict private
    FInfo: PHTTP_SERVICE_CONFIG_SSL_SET;
  private
    FBuffer: TBytes;
    function GetIp: string;
    function GetPort: integer;
    function GetThumbprintText: string;
    function GetThumbprint: TBytes;
    function GetCertificateStoreName: string;
    function GetAppId: TGUID;
  public
    constructor Create(const Buffer: TBytes);
    property Ip: string read GetIp;
    property Port: integer read GetPort;
    property ThumbprintText: string read GetThumbprintText;
    property Thumbprint: TBytes read GetThumbprint;
    property CertificateStoreName: string read GetCertificateStoreName;
    property AppId: TGUID read GetAppId;
  end;

  TSidType = (Everyone, CurrentUser, LocalService, NetworkService);
  TSidTypes = set of TSidType;

  THttpSysServerConfig = class
  strict private
    const SddlAceTemplate = '(A;;GX;;;%s)';
  strict private
    FReservations: TList<TUrlAclInfo>;
    FListLoaded: boolean;
    FSslList: TList<TSslCertInfo>;
    FSslListLoaded: boolean;
    function GetCurrentUserStringSid: string;
    function NormalizeUrlPrefix(const AUrlPrefix: string): string;
    procedure ListReservations(var Items: TList<TUrlAclInfo>);
    procedure LoadSslList(var Items: TList<TSslCertInfo>);
  private
    function GetReservations: TEnumerable<TUrlAclInfo>;
    function GetSslList: TEnumerable<TSslCertInfo>;
  public
    constructor Create;
    destructor Destroy; override;
    procedure ReserveUrl(const AUrlPrefix, SecurityDescriptor: string); overload;
    procedure ReserveUrl(const AUrlPrefix: string; SidTypes: TSidTypes); overload;
    procedure RemoveUrl(const AUrlPrefix: string);
    function IsUrlReserved(const AUrlPrefix: string): boolean;
    procedure RefreshReservations;

    procedure RemoveSsl(const IpAddress: string; Port: integer);
    procedure AddSslCert(const IpAddress: string; Port: integer;
      CertStore: string; Thumbprint: TBytes; AppId: TGuid);
    procedure RefreshSslCerts;

    property Reservations: TEnumerable<TUrlAclInfo> read GetReservations;
    property SslCerts: TEnumerable<TSslCertInfo> read GetSslList;
  end;

{$ENDIF}

implementation

{$IFDEF MSWINDOWS}

uses
  Winapi.Winsock,
  Sparkle.Win.Socket;

function ConvertSidToStringSid(Sid: PSID; var StringSid: PChar): BOOL; stdcall; external advapi32 name 'ConvertSidToStringSidW';

{ THttpServerConfig }

procedure THttpSysServerConfig.AddSslCert(const IpAddress: string; Port: integer; CertStore: string;
  Thumbprint: TBytes; AppId: TGuid);
var
  Info: HTTP_SERVICE_CONFIG_SSL_SET;
  Addr: TSockAddrIn;
begin
  if not BuildSockAddr4(IpAddress, Port, Addr) then
    raise Exception.CreateFmt('Invalid IP: %s', [IpAddress]);
  Info.KeyDesc.pIpPort := @Addr;

  Info.ParamDesc.SslHashLength := Length(Thumbprint);
  Info.ParamDesc.pSslHash := @Thumbprint[0];
  Info.ParamDesc.AppId := AppId;
  Info.ParamDesc.pSslCertStoreName := PChar(CertStore);
  Info.ParamDesc.DefaultCertCheckMode := 0;
  Info.ParamDesc.DefaultRevocationFreshnessTime := 0;
  Info.ParamDesc.DefaultRevocationUrlRetrievalTimeout := 0;
  Info.ParamDesc.pDefaultSslCtlIdentifier := nil;
  Info.ParamDesc.pDefaultSslCtlStoreName := nil;
  Info.ParamDesc.DefaultFlags := 0;

  HttpCheck(HttpSetServiceConfiguration(0, HttpServiceConfigSSLCertInfo, @Info, SizeOf(Info), nil));
end;

constructor THttpSysServerConfig.Create;
begin
  InitSocketLibrary;
  FReservations := TObjectList<TUrlAclInfo>.Create(true);
  FSslList := TObjectList<TSslCertInfo>.Create(true);
  FListLoaded := false;
  LoadHttpApiLibrary;
  HttpCheck(HttpInitialize(HTTPAPI_VERSION_1, HTTP_INITIALIZE_CONFIG));
end;

destructor THttpSysServerConfig.Destroy;
begin
  FReservations.Free;
  FSslList.Free;
  HttpCheck(HttpTerminate(HTTP_INITIALIZE_CONFIG));
  inherited;
end;

function THttpSysServerConfig.GetCurrentUserStringSid: string;
var
  hToken: THandle;
  Len: Cardinal;
  PUser: PTokenUser;
  Ok: boolean;
  LocalStringSid: PChar;
begin
  Ok := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, true, hToken);
  if not Ok and (GetLastError = ERROR_NO_TOKEN) then
    Ok := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, hToken);
  if not Ok then
    RaiseLastOSError;

  PUser := nil;
  try
    GetTokenInformation(hToken, TokenUser, nil, 0, Len);
    PUser := AllocMem(Len);
    if not GetTokenInformation(hToken, TokenUser, PUser, Len, Len) then
      RaiseLastOSError;
    if not ConvertSidToStringSid(PUser.User.Sid, LocalStringSid) then
      RaiseLastOSError;
    Result := LocalStringSid;
    LocalFree(HLOCAL(LocalStringSid));
  finally
    CloseHandle(hToken);
    if PUser <> nil then
      FreeMem(PUser);
  end;
end;

function THttpSysServerConfig.GetReservations: TEnumerable<TUrlAclInfo>;
begin
  if not FListLoaded then
    ListReservations(FReservations);
  Result := FReservations;
end;

function THttpSysServerConfig.GetSslList: TEnumerable<TSslCertInfo>;
begin
  if not FSslListLoaded then
    LoadSslList(FSslList);
  Result := FSslList;
end;

function THttpSysServerConfig.IsUrlReserved(const AUrlPrefix: string): boolean;
var
  UrlAclInfoQuery: HTTP_SERVICE_CONFIG_URLACL_QUERY;
  Res: HResult;
  BufferLength: Cardinal;
begin
  UrlAclInfoQuery.QueryDesc := HttpServiceConfigQueryExact;
  UrlAclInfoQuery.KeyDesc.pUrlPrefix := PChar(NormalizeUrlPrefix(AUrlPrefix));
  UrlAclInfoQuery.dwToken := 0;
  BufferLength := 0;
  Res := HttpQueryServiceConfiguration(0, HttpServiceConfigUrlAclInfo,
    @UrlAclInfoQuery, SizeOf(UrlAclInfoQuery), nil, 0, BufferLength, nil);
  if Res = ERROR_FILE_NOT_FOUND then
    Exit(false);
  if Res <> ERROR_INSUFFICIENT_BUFFER then
    HttpCheck(Res);
  Result := true;
end;

procedure THttpSysServerConfig.ListReservations(var Items: TList<TUrlAclInfo>);
var
  UrlAclInfoQuery: HTTP_SERVICE_CONFIG_URLACL_QUERY;
  Res: HResult;
  BufferLength: Cardinal;
  Total: integer;
  Buffer: TBytes;
begin
  Total := 0;
  Items.Clear;
  FListLoaded := true;
  repeat
    UrlAclInfoQuery.QueryDesc := HttpServiceConfigQueryNext;
    UrlAclInfoQuery.KeyDesc.pUrlPrefix := nil;
    UrlAclInfoQuery.dwToken := Total;
    BufferLength := 0;
    Res := HttpQueryServiceConfiguration(0, HttpServiceConfigUrlAclInfo,
      @UrlAclInfoQuery, SizeOf(UrlAclInfoQuery), nil, 0, BufferLength, nil);
    if Res = ERROR_NO_MORE_ITEMS then
      break;
    if Res <> ERROR_INSUFFICIENT_BUFFER then
      HttpCheck(Res);

    SetLength(Buffer, BufferLength);
    HttpCheck(HttpQueryServiceConfiguration(0, HttpServiceConfigUrlAclInfo,
      @UrlAclInfoQuery, SizeOf(UrlAclInfoQuery), @Buffer[0], BufferLength, BufferLength, nil));
    Items.Add(TUrlAclInfo.Create(Buffer));

    Inc(Total);
  until false;
end;

procedure THttpSysServerConfig.LoadSslList(var Items: TList<TSslCertInfo>);
var
  SslQuery: HTTP_SERVICE_CONFIG_SSL_QUERY;
  Res: HResult;
  BufferLength: Cardinal;
  Total: integer;
  Buffer: TBytes;
begin
  Total := 0;
  Items.Clear;
  FListLoaded := true;
  repeat
    SslQuery.QueryDesc := HttpServiceConfigQueryNext;
    SslQuery.KeyDesc.pIpPort := nil;
    SslQuery.dwToken := Total;
    BufferLength := 0;
    Res := HttpQueryServiceConfiguration(0, HttpServiceConfigSSLCertInfo,
      @SslQuery, SizeOf(SslQuery), nil, 0, BufferLength, nil);
    if Res = ERROR_NO_MORE_ITEMS then
      break;
    if Res <> ERROR_INSUFFICIENT_BUFFER then
      HttpCheck(Res);

    SetLength(Buffer, BufferLength);
    HttpCheck(HttpQueryServiceConfiguration(0, HttpServiceConfigSSLCertInfo,
      @SslQuery, SizeOf(SslQuery), @Buffer[0], BufferLength, BufferLength, nil));
    Items.Add(TSslCertInfo.Create(Buffer));

    Inc(Total);
  until false;
end;

function THttpSysServerConfig.NormalizeUrlPrefix(const AUrlPrefix: string): string;
begin
  if AUrlPrefix = '' then Exit('/');
  if AUrlPrefix[Length(AUrlPrefix)] <> '/' then
    Result := AUrlPrefix + '/'
  else
    Result := AUrlPrefix;
end;

procedure THttpSysServerConfig.RefreshReservations;
begin
  ListReservations(FReservations);
end;

procedure THttpSysServerConfig.RefreshSslCerts;
begin
  LoadSslList(FSslList);
end;

procedure THttpSysServerConfig.RemoveSsl(const IpAddress: string; Port: integer);
var
  Info: HTTP_SERVICE_CONFIG_SSL_SET;
  Addr: TSockAddrIn;
begin
  if not BuildSockAddr4(IpAddress, Port, Addr) then
    raise Exception.CreateFmt('Invalid IP: %s', [IpAddress]);
  Info.KeyDesc.pIpPort := @Addr;
  HttpCheck(HttpDeleteServiceConfiguration(0, HttpServiceConfigSSLCertInfo, @Info, SizeOf(Info), nil));
end;

procedure THttpSysServerConfig.RemoveUrl(const AUrlPrefix: string);
var
  Info: HTTP_SERVICE_CONFIG_URLACL_SET;
begin
  Info.KeyDesc.pUrlPrefix := PChar(NormalizeUrlPrefix(AUrlPrefix));
  Info.ParamDesc.pStringSecurityDescriptor := nil;
  HttpCheck(HttpDeleteServiceConfiguration(0, HttpServiceConfigUrlAclInfo, @Info, SizeOf(Info), nil));
end;

procedure THttpSysServerConfig.ReserveUrl(const AUrlPrefix: string; SidTypes: TSidTypes);
var
  SecDescriptor: string;
  StringSid: string;
  SidType: TSidType;
begin
  SecDescriptor := 'D:';
  for SidType in SidTypes do
  begin
    case SidType of
      TSidType.Everyone:
        StringSid := 'WD';
      TSidType.CurrentUser:
        StringSid := GetCurrentUserStringSid;
      TSidType.LocalService:
        StringSid := 'LS';
      TSidType.NetworkService:
        StringSid := 'NS';
    end;
    SecDescriptor := SecDescriptor + Format(SddlAceTemplate, [StringSid]);
  end;
  ReserveUrl(AUrlPrefix, SecDescriptor);
end;

procedure THttpSysServerConfig.ReserveUrl(const AUrlPrefix, SecurityDescriptor: string);
var
  UrlAclInfo: HTTP_SERVICE_CONFIG_URLACL_SET;
begin
  UrlAclInfo.KeyDesc.pUrlPrefix := PChar(NormalizeUrlPrefix(AUrlPrefix));
  UrlAclInfo.ParamDesc.pStringSecurityDescriptor := PChar(SecurityDescriptor);
  HttpCheck(HttpSetServiceConfiguration(0, HttpServiceConfigUrlAclInfo,
    @UrlAclInfo, SizeOf(UrlAclInfo), nil));
end;

{ TUrlAclInfo }

constructor TUrlAclInfo.Create(const Buffer: TBytes);
begin
  FBuffer := Buffer;
  FInfo := PHTTP_SERVICE_CONFIG_URLACL_SET(FBuffer);
end;

function TUrlAclInfo.GetSecurityDescriptor: string;
begin
  Result := FInfo.ParamDesc.pStringSecurityDescriptor;
end;

function TUrlAclInfo.GetUrlPrefix: string;
begin
  Result := FInfo.KeyDesc.pUrlPrefix;
end;

{ TSslCertInfo }

constructor TSslCertInfo.Create(const Buffer: TBytes);
begin
  FBuffer := Buffer;
  FInfo := PHTTP_SERVICE_CONFIG_SSL_SET(FBuffer);
end;

function TSslCertInfo.GetAppId: TGUID;
begin
  Result := FInfo.ParamDesc.AppId;
end;

function TSslCertInfo.GetCertificateStoreName: string;
begin
  if FInfo.ParamDesc.pSslCertStoreName = nil then
    Result := 'My'
  else
    Result := FInfo.ParamDesc.pSslCertStoreName;
end;

function TSslCertInfo.GetIp: string;
begin
  Result := SockAddrToString(FInfo.KeyDesc.pIpPort);
end;

function TSslCertInfo.GetPort: integer;
begin
  Result := GetSockAddrPort(FInfo.KeyDesc.pIpPort);
end;

function TSslCertInfo.GetThumbprint: TBytes;
begin
  SetLength(Result, FInfo.ParamDesc.SslHashLength);
  if Length(Result) > 0 then
    System.Move(FInfo.ParamDesc.pSslHash^, Result[0], Length(Result));
end;

function TSslCertInfo.GetThumbprintText: string;
var
  I: integer;
  B: PByte;
begin
  Result := '';
  B := PByte(FInfo.ParamDesc.pSslHash);
  for I := 0 to FInfo.ParamDesc.SslHashLength - 1 do
  begin
    Result := Result + IntToHex(B^, 2);
    Inc(B);
  end;
  Result := Lowercase(Result);
end;

{$ENDIF}

end.
