unit Sparkle.HttpSys.Session;

{$I Sparkle.Inc}

interface

{$IFDEF MSWINDOWS}

uses
  System.Classes, Winapi.Windows, System.SysUtils,
  Sparkle.HttpSys.Context;

type
  EHttpSysSessionException = class(Exception);

  EHttpSysWindowsNotSupported = class(EHttpSysSessionException)
  public
    constructor Create;
  end;

  THttpSysSession = class
  strict private
    FControlSection: TRTLCriticalSection;
    FStarted: boolean;
    FSessionId: UInt64;
    FUrlGroupId: UInt64;
    FQueueID: THandle;
    FUrlPrefixes: TStrings;
    FInitialized: boolean;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Start;
    procedure Stop;
    function GetContext: THttpSysContext;
    property IsListening: boolean read FStarted;
    property UrlPrefixes: TStrings read FUrlPrefixes;
    class procedure ReserveUrlPrefix(const AUrlPrefix: string);
  public
    procedure SetQueueLength(const Value: Cardinal);
    property QueueId: THandle read FQueueId;
    property SessionId: UInt64 read FSessionId;
    property UrlGroupID: UInt64 read FUrlGroupId;
//    class function IsUrlPrefixReserved(const AUrlPrefix: string): boolean;
  end;

{$ENDIF}

implementation

{$IFDEF MSWINDOWS}

uses
  Sparkle.HttpSys.Api;

{ EHttpSysWindowsNotSupported }

constructor EHttpSysWindowsNotSupported.Create;
begin
  inherited Create('Sparkle Http.Sys Server not supported on this operating system.'#13#10 +
    'Minimum supported server: Windows Server 2008.'#13#10 +
    'Minimum supported desktop: Windows Vista.');
end;

{ THttpServerSession }

constructor THttpSysSession.Create;
begin
  InitializeCriticalSection(FControlSection);
  FUrlPrefixes := TStringList.Create;
  if Win32MajorVersion < 6 then
    raise EHttpSysWindowsNotSupported.Create;
  LoadHttpApiLibrary;
  HttpCheck(HttpInitialize(HTTPAPI_VERSION_2, HTTP_INITIALIZE_SERVER));
  FInitialized := true;
end;

destructor THttpSysSession.Destroy;
begin
  FUrlPrefixes.Free;
  Stop;
  if FInitialized then
    HttpCheck(HttpTerminate(HTTP_INITIALIZE_SERVER));
  DeleteCriticalSection(FControlSection);
  inherited;
end;

function THttpSysSession.GetContext: THttpSysContext;
var
  HttpResult: HRESULT;
  RequestID: UInt64;
  RequestBuffer: TBytes;
  BytesRead: Cardinal;
  Done: boolean;
begin
  // MS recomendation: 4K for normal buffers, plus 12K for authentication headers if used
  SetLength(RequestBuffer, 4096);
  RequestId := 0;
  Done := false;
  repeat
    BytesRead := 0;
    HttpResult := HttpReceiveHttpRequest(FQueueID, RequestID, 0,
      PHTTP_REQUEST(RequestBuffer), Length(RequestBuffer), BytesRead, nil);
    if HttpResult = ERROR_MORE_DATA then
    begin
      RequestId := PHTTP_REQUEST(RequestBuffer)^.RequestId;
      SetLength(RequestBuffer, BytesRead);
    end
    else
    if (HttpResult = ERROR_INVALID_PARAMETER) and (RequestId <> 0) then
    begin
      RequestId := 0;
    end
    else
    if (HttpResult = ERROR_CONNECTION_INVALID) and (RequestId <> 0) then
    begin
      RequestId := 0;
    end
    else
      Done := true;
  until Done;

  // Check for operation aborted - this might mean the server was interrupted
  // so we should not raise an exception, but rather return nil
  if HttpResult = ERROR_OPERATION_ABORTED then
    Exit(nil);
  HttpCheck(HttpResult);
  Result := THttpSysContext.Create(RequestBuffer, FQueueId);
end;

class procedure THttpSysSession.ReserveUrlPrefix(const AUrlPrefix: string);
const
  UrlReserveSecDescriptor = 'D:(A;;GA;;;WD)';
var
  UrlAclInfo: HTTP_SERVICE_CONFIG_URLACL_SET;
begin
  LoadHttpApiLibrary;
  HttpCheck(HttpInitialize(HTTPAPI_VERSION_1, HTTP_INITIALIZE_CONFIG));
  try
    UrlAclInfo.KeyDesc.pUrlPrefix := PChar(AUrlPrefix);
    UrlAclInfo.ParamDesc.pStringSecurityDescriptor := UrlReserveSecDescriptor;
    HttpCheck(HttpSetServiceConfiguration(0, HttpServiceConfigUrlAclInfo,
      @UrlAclInfo, SizeOf(UrlAclInfo), nil));
  finally
    HttpCheck(HttpTerminate(HTTP_INITIALIZE_SERVER));
  end;
end;

//class function THttpSysSession.IsUrlPrefixReserved(const AUrlPrefix: string): boolean;
//var
//  Config: THttpApiServerConfig;
//begin
//  Config := THttpApiServerConfig.Create;
//  try
//    Result := Config.IsUrlReserved(AUrlPrefix);
//  finally
//    Config.Free;
//  end;
//end;

procedure THttpSysSession.SetQueueLength(const Value: Cardinal);
begin
  if FQueueID = HTTP_NULL_ID then
    raise EHttpSysSessionException.Create('Cannot set queue length. Server not started.');
  HttpCheck(HttpSetRequestQueueProperty(FQueueID, HttpServerQueueLengthProperty, @Value, SizeOf(Value)));
end;

procedure THttpSysSession.Start;
var
  BindInfo: HTTP_BINDING_INFO;
  UrlPrefix: string;
  HttpResult: HRESULT;
begin
  EnterCriticalSection(FControlSection);
  try
    if IsListening then Exit;
    if UrlPrefixes.Count = 0 then
      raise EHttpSysSessionException.Create('You must specify a least one prefix in UrlPrefixes property.');

    if FSessionId = HTTP_NULL_ID then
      HttpCheck(HttpCreateServerSession(HTTPAPI_VERSION_2, FSessionId));

    if FUrlGroupId = HTTP_NULL_ID then
      HttpCheck(HttpCreateUrlGroup(FSessionId, FUrlGroupId));

    for UrlPrefix in UrlPrefixes do
    begin
      HttpResult := HttpAddUrlToUrlGroup(FUrlGroupId, PChar(UrlPrefix), 0);
      if HttpResult <> NO_ERROR then
        raise EHttpSysSessionException.CreateFmt(
          'Could not add the following Url to the server.'#13#10 +
          'Be sure that you have reserved the Url in Http.Sys with proper permissions.'#13#10#13#10 +
          'Url: %s'#13#10'Error: %s',
          [UrlPrefix, SysErrorMessage(HttpResult)]);
    end;

    if FQueueId = HTTP_NULL_ID then
      HttpCheck(HttpCreateRequestQueue(HTTPAPI_VERSION_2, nil, nil, 0, FQueueId));

    // bind the request queue to the url group
    BindInfo.Flags := HTTP_PROPERTY_FLAG_PRESENT;
    BindInfo.RequestQueueHandle := FQueueId;
    HttpCheck(HttpSetUrlGroupProperty(FUrlGroupId, HttpServerBindingProperty, @BindInfo, SizeOf(BindInfo)));

    FStarted := true;
  finally
    LeaveCriticalSection(FControLSection);
  end;
end;

procedure THttpSysSession.Stop;
var
  BindInfo: HTTP_BINDING_INFO;
begin
  EnterCriticalSection(FControlSection);
  try
    if not IsListening then Exit;
    FStarted := false;

    // unbind the request queue from the url group
    BindInfo.RequestQueueHandle := 0;
    BindInfo.Flags := HTTP_PROPERTY_FLAG_NONE;
    HttpCheck(HttpSetUrlGroupProperty(FUrlGroupId, HttpServerBindingProperty, @BindInfo, SizeOf(BindInfo)));

    HttpCheck(HttpCloseRequestQueue(FQueueId));
    FQueueId := HTTP_NULL_ID;

    HttpCheck(HttpRemoveUrlFromUrlGroup(FUrlGroupId, nil, HTTP_URL_FLAG_REMOVE_ALL));

    HttpCheck(HttpCloseUrlGroup(FUrlGroupId));
    FUrlGroupId := HTTP_NULL_ID;

    HttpCheck(HttpCloseServerSession(FSessionId));
    FSessionId := HTTP_NULL_ID;
  finally
    LeaveCriticalSection(FControlSection);
  end;
end;

{$ENDIF}

end.
