unit Sparkle.WebBroker.Context;

{$I Sparkle.inc}

interface

uses
  System.SysUtils, System.Classes,
  Sparkle.Http.Headers,
  Sparkle.HttpServer.Context,
  Sparkle.HttpServer.Request;

type
  TWebBrokerAdapterMode = (Apache, Isapi, Indy);

  IWebBrokerAdapter = interface
  ['{836A1B93-DDA3-4E5F-ACF4-FA706B0D6381}']
    function GetRequestMethod: string;
    function GetRequestUrl: string;
    function GetRequestContent: TBytes;
    function GetRequestHost: string;
    procedure GetRequestHeaders(Headers: THttpHeaders);

    procedure SetResponseContentLength(const Value: Int64);
    procedure SetResponseContentStream(AStream: TStream; AFreeStream: Boolean);
    procedure SetResponseStatusCode(Value: Integer);
    procedure SetResponseReasonString(Value: string);
    procedure SetResponseHeader(const Name, Value: string);
    procedure SetResponseContentType(const Value: string);
    procedure SendResponse;
    function Mode: TWebBrokerAdapterMode;
  end;

  TWebBrokerResponse = class(THttpServerResponse)
  strict private
    FAdapter: IWebBrokerAdapter;
    FStream: TBytesStream;
    procedure SendIsapiResponse;
    procedure SendNormalResponse;
  strict protected
    procedure EndResponse; override;
    procedure SendResponse; override;
    function SendBody(const PBuf: Pointer; const BufferSize: Integer): Integer; override;
  public
    constructor Create(AAdapter: IWebBrokerAdapter);
    destructor Destroy; override;
  end;

  TWebBrokerContext = class(THttpServerContext)
  strict private
    FAdapter: IWebBrokerAdapter;
    FRequest: THttpServerRequest;
    FResponse: THttpServerResponse;
    function FullUrl(const Host, RawPath: string): string;
  strict protected
    function GetRequest: THttpServerRequest; override;
    function GetResponse: THttpServerResponse; override;
  public
    constructor Create(AAdapter: IWebBrokerAdapter);
    destructor Destroy; override;
  end;

  TWebBrokerRequestStream = class(THttpRequestStream)
  strict private
    FAdapter: IWebBrokerAdapter;
    FBytes: TBytes;
    FPosition: Integer;
  protected
    function GetContentLength: Int64; override;
    function ReadBuffer(Buffer: Pointer; Count: Longint): Longint; override;
  public
    constructor Create(AAdapter: IWebBrokerAdapter);
  end;

  EUnsupportedWebBrokerAdapter = class(Exception)
  public
    constructor Create;
  end;

implementation

uses
  Sparkle.Uri;

{ TWebBrokerContext }

constructor TWebBrokerContext.Create(AAdapter: IWebBrokerAdapter);
begin
  FAdapter := AAdapter;
  FRequest := THttpServerRequest.Create;
  FRequest.Method := FAdapter.GetRequestMethod;
  FRequest.RawUri := FullUrl(FAdapter.GetRequestHost, FAdapter.GetRequestUrl);
  FAdapter.GetRequestHeaders(FRequest.Headers);
  FRequest.ContentStream := TWebBrokerRequestStream.Create(FAdapter);
  FResponse := TWebBrokerResponse.Create(FAdapter);
end;

destructor TWebBrokerContext.Destroy;
begin
  FRequest.Free;
  FResponse.Free;
  inherited;
end;

function TWebBrokerContext.FullUrl(const Host, RawPath: string): string;
begin
  Result := RawPath;
  if not TUri.HasScheme(Result) then
  begin
    if (Length(Result) > 0) and (Result[1] <> '/') then
      Result := '/' + Result;

    Result := 'http' {no way to tell https} + '://' + Host + Result;
  end;
end;

function TWebBrokerContext.GetRequest: THttpServerRequest;
begin
  Result := FRequest;
end;

function TWebBrokerContext.GetResponse: THttpServerResponse;
begin
  Result := FResponse;
end;

{ TWebBrokerRequestStream }

constructor TWebBrokerRequestStream.Create(AAdapter: IWebBrokerAdapter);
begin
  FAdapter := AAdapter;
  FBytes := FAdapter.GetRequestContent;
end;

function TWebBrokerRequestStream.GetContentLength: Int64;
begin
  Result := Length(FBytes);
end;

function TWebBrokerRequestStream.ReadBuffer(Buffer: Pointer;
  Count: Longint): Longint;
begin
  Result := Count;
  if (FPosition + Count) > Length(FBytes) then
    Result := Length(FBytes) - FPosition;
  System.Move(FBytes[FPosition], Buffer^, Result);
  Inc(FPosition, Result);
end;

{ TWebBrokerResponse }

constructor TWebBrokerResponse.Create(AAdapter: IWebBrokerAdapter);
begin
  inherited Create;
  FAdapter := AAdapter;
  FStream := TBytesStream.Create;
end;

destructor TWebBrokerResponse.Destroy;
begin
  FStream.Free;
  inherited;
end;

procedure TWebBrokerResponse.EndResponse;
begin
  FAdapter.SetResponseContentLength(FStream.Size);
  FStream.Position := 0;
  FAdapter.SetResponseContentStream(FStream, False);
  FAdapter.SendResponse;
end;

function TWebBrokerResponse.SendBody(const PBuf: Pointer;
  const BufferSize: Integer): Integer;
begin
  Result := FStream.Write(PBuf^, BufferSize);
end;

procedure TWebBrokerResponse.SendIsapiResponse;

  function MustIncludeHeader(const HeaderName: string): Boolean;
  begin
    Result := not (
      SameText(HeaderName, 'content-length') or
      SameText(HeaderName, 'content-type') or
      SameText(HeaderName, 'transfer-encoding')
    );
  end;

var
  Header: THttpHeaderInfo;
begin
  FAdapter.SetResponseStatusCode(Self.StatusCode);
  FAdapter.SetResponseReasonString(Self.StatusReason);

  for Header in Self.Headers.AllHeaders do
    if MustIncludeHeader(Header.Name) then
      FAdapter.SetResponseHeader(Header.Name, Header.Value);
  FAdapter.SetResponseContentType(Self.ContentType);
  Self.Chunked := False;
end;

procedure TWebBrokerResponse.SendNormalResponse;
var
  Header: THttpHeaderInfo;
begin
  FAdapter.SetResponseStatusCode(Self.StatusCode);
  FAdapter.SetResponseReasonString(Self.StatusReason);

  for Header in Self.Headers.AllHeaders do
    FAdapter.SetResponseHeader(Header.Name, Header.Value);
  FAdapter.SetResponseContentType(Self.ContentType);
end;

procedure TWebBrokerResponse.SendResponse;
begin
  case FAdapter.Mode of
    TWebBrokerAdapterMode.Isapi:
      SendIsapiResponse
  else
    SendNormalResponse;
  end;
end;

{ EUnsupportedWebBrokerAdapter }

constructor EUnsupportedWebBrokerAdapter.Create;
begin
  inherited Create('Unsupported Web Broker Adapter');
end;

end.
