unit Sparkle.HttpSys.Context;

{$I Sparkle.Inc}

interface

{$IFDEF MSWINDOWS}

uses
  Generics.Collections, SysUtils, Classes,
  Sparkle.HttpServer.Context,
  Sparkle.HttpServer.Request,
  Sparkle.HttpServer.Response,
  Sparkle.Http.Headers,
  Sparkle.HttpSys.Api,
  Sparkle.Uri;

type
  THttpSysContext = class;

  THttpSysRequest = class
  strict private
    FContext: THttpSysContext;
    FRequestBuffer: TBytes;
    FReq: PHTTP_REQUEST;
    function GetRawUrl: string;
    function GetHost: string;
    function GetFullUrl: string;
    function GetKnownHeader(HeaderId: HTTP_HEADER_ID): string;
    function IsSecureConnection: boolean;
    function RequestScheme: string;
    function FullUrlFromRawUrl: string;
    function GetMethod: string;
    property Host: string read GetHost;
    property RawUrl: string read GetRawUrl;
  protected
    function GetMajorVersion: integer;
    function GetMinorVersion: integer;
    function GetRemoteIp: string;
  public
    constructor Create(Context: THttpSysContext; RequestBuffer: TBytes);
    destructor Destroy; override;
    procedure FillHeaders(AHeaders: THttpHeaders);
    property Method: string read GetMethod;
    property FullUrl: string read GetFullUrl;
    property MinorVersion: Integer read GetMinorVersion;
    property Context: THttpSysContext read FContext;
    property RemoteIp: string read GetRemoteIp;
    property RawRequest: PHTTP_REQUEST read FReq;
  end;

  THttpSysRequestExtraInfo = class(TInterfacedObject, IHttpRequestExtraInfo)
  private
    FSysRequest: THttpSysRequest;
    function RemoteIp: string;
  public
    constructor Create(ASysRequest: THttpSysRequest);
  end;

  THttpSysResponse = class(THttpServerResponse)
  strict private
    FContext: THttpSysContext;
    FResponse: HTTP_RESPONSE;
    FUnknownHeaders: array of HTTP_UNKNOWN_HEADER;
    procedure UpdateResponseHeaders;
  strict protected
    procedure EndResponse; override;
    procedure SendResponse; override;
    function SendBody(const PBuf: Pointer; const BufferSize: Integer): Integer; override;
    property Context: THttpSysContext read FContext;
  public
    constructor Create(Context: THttpSysContext);
    destructor Destroy; override;
  end;

  THttpSysContext = class(THttpServerContext)
  strict private
    FContextId: HTTP_REQUEST_ID;
    FConnectionId: HTTP_CONNECTION_ID;
    FQueueId: NativeUInt;
    FSysRequest: THttpSysRequest;
    FRequest: THttpServerRequest;
    FResponse: THttpSysResponse;
  strict protected
    function GetRequest: THttpServerRequest; override;
    function GetResponse: THttpServerResponse; override;
  public
    constructor Create(RequestBuffer: TBytes; QueueId: NativeUInt);
    destructor Destroy; override;
    property ContextId: HTTP_REQUEST_ID read FContextId;
    property QueueId: NativeUInt read FQueueId;
    property SysRequest: THttpSysRequest read FSysRequest;
  end;

  THttpSysRequestStream = class(THttpRequestStream)
  strict private
    FRequest: THttpSysRequest;
    FContentLength: Int64;
  protected
    function GetContentLength: Int64; override;
    function ReadBuffer(Buffer: Pointer; Count: Longint): Longint; override;
  public
    constructor Create(ARequest: THttpSysRequest; AContentLength: Int64);
  end;

{$ENDIF}

implementation

{$IFDEF MSWINDOWS}

uses
  Winapi.Windows, Winapi.Winsock,
  Sparkle.Utils,
  Sparkle.Win.Socket;

{ THttpContext }

function AnsiToUnicode(Bytes: PAnsiChar; Count: integer): string;
var
  B: TBytes;
begin
  SetLength(B, Count);
  if Count <> 0 then
    System.Move(Bytes^, B[0], Count);
  Result := TEncoding.Ansi.GetString(B, 0, Count);
end;

//begin
//  Result := TEncoding.ANSI.GetString(TBytes(Bytes), 0, Count);

//    TEncoding.Unicode.GetString(
//      TEncoding.Convert(
//        TEncoding.ANSI,
//        TEncoding.Unicode, TBytes(Bytes), 0, Count)
//    );
//end;

constructor THttpSysContext.Create(RequestBuffer: TBytes; QueueId: NativeUInt);
var
  Req: PHTTP_REQUEST;
begin
  FQueueId := QueueId;
  Req := PHTTP_REQUEST(RequestBuffer);
  FContextId := Req^.RequestId;
  FConnectionId := Req^.ConnectionId;
  FSysRequest := THttpSysRequest.Create(Self, RequestBuffer);

  FRequest := THttpServerRequest.Create;
  FRequest.Method := FSysRequest.Method;
  FRequest.RawUri := FSysRequest.FullUrl;
  if FSysRequest.MinorVersion = 0 then
    FRequest.Protocol := 'HTTP/1.0';
  FSysRequest.FillHeaders(FRequest.Headers);
  FRequest.ContentStream := THttpSysRequestStream.Create(FSysRequest, FRequest.ContentLength);
  FRequest.ExtraInfo := THttpSysRequestExtraInfo.Create(FSysRequest);

  FResponse := THttpSysResponse.Create(Self);
end;

destructor THttpSysContext.Destroy;
begin
  FRequest.Free;
  FSysRequest.Free;
  FResponse.Free;
  inherited;
end;

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

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

{ THttpRequest }

constructor THttpSysRequest.Create(Context: THttpSysContext; RequestBuffer: TBytes);
begin
  FContext := Context;
  FRequestBuffer := RequestBuffer;
  FReq := PHTTP_REQUEST(FRequestBuffer);
end;

destructor THttpSysRequest.Destroy;
begin
  inherited;
end;

function THttpSysRequest.FullUrlFromRawUrl: string;
begin
  Result := RawUrl;
  if not TUri.HasScheme(Result) then
  begin
    if (Length(Result) > 0) and (Result[1] <> '/') then
      Result := '/' + Result;

    Result := RequestScheme + '://' + Host + Result;
  end;
end;

function THttpSysRequest.GetFullUrl: string;
begin
  Result := FullUrlFromRawUrl;
end;

function THttpSysRequest.GetHost: string;
begin
  Result := GetKnownHeader(HTTP_HEADER_ID.HttpHeaderHost);
end;

function THttpSysRequest.GetMajorVersion: integer;
begin
  Result := FReq.Version.MajorVersion;
end;

function THttpSysRequest.GetMethod: string;
begin
  if FReq.Verb = HttpVerbUnknown then
    Result := AnsiToUnicode(FReq.pUnknownVerb, FReq.UnknownVerbLength)
  else
    Result := HttpVerbNames[FReq.Verb];
end;

function THttpSysRequest.GetMinorVersion: integer;
begin
  Result := FReq.Version.MinorVersion;
end;

function THttpSysRequest.GetRawUrl: string;
begin
  Result := AnsiToUnicode(FReq.pRawUrl, FReq.RawUrlLength);
end;

function THttpSysRequest.GetRemoteIp: string;
begin
  Result := SockAddrToString(FReq.Address.pRemoteAddress);
end;

function THttpSysRequest.IsSecureConnection: boolean;
begin
  Result := FReq.pSslInfo <> nil;
end;

function THttpSysRequest.GetKnownHeader(HeaderId: HTTP_HEADER_ID): string;
begin
  if FReq.Headers.KnownHeaders[HeaderId].RawValueLength <> 0 then
    Result := AnsiToUnicode(
      FReq.Headers.KnownHeaders[HeaderId].pRawValue,
      FReq.Headers.KnownHeaders[HeaderId].RawValueLength)
  else
    Result := '';
end;

procedure THttpSysRequest.FillHeaders(AHeaders: THttpHeaders);
var
  ReqHeaders: HTTP_REQUEST_HEADERS;
  PUnknown: PHTTP_UNKNOWN_HEADER;
  I: HTTP_HEADER_ID;
  J: integer;
  HeaderName: string;
  HeaderValue: string;
begin
  AHeaders.Clear;
  ReqHeaders := FReq.Headers;

  for I := Low(ReqHeaders.KnownHeaders) to High(ReqHeaders.KnownHeaders) do
  begin
    if ReqHeaders.KnownHeaders[I].RawValueLength > 0 then
    begin
      HeaderValue := GetKnownHeader(I);
      AHeaders.SetValue(HttpRequestHeaderNames[I], HeaderValue);
    end;
  end;

  PUnknown := ReqHeaders.pUnknownHeaders;
  for J := 0 to ReqHeaders.UnknownHeaderCount - 1 do
  begin
    HeaderName := AnsiToUnicode(PUnknown^.pName, PUnknown^.NameLength);
    HeaderValue := AnsiToUnicode(PUnknown^.pRawValue, PUnknown^.RawValueLength);
    AHeaders.SetValue(LowerCase(HeaderName), HeaderValue);
    Inc(PUnknown);
  end;
end;

function THttpSysRequest.RequestScheme: string;
begin
  if IsSecureConnection then
    result := 'https'
  else
    result := 'http';
end;

{ THttpResponse }

constructor THttpSysResponse.Create(Context: THttpSysContext);
begin
  inherited Create;
  FContext := Context;
end;

destructor THttpSysResponse.Destroy;
begin
  inherited;
end;

procedure THttpSysResponse.EndResponse;
var
  Flags, BytesSent: Cardinal;
begin
  Flags := 0;
  if not KeepAlive then
    Flags := Flags + HTTP_SEND_RESPONSE_FLAG_DISCONNECT;
  BytesSent := 0;
  HttpCheck(HttpSendResponseEntityBody(Context.QueueId, Context.ContextId, Flags,
    0, nil, BytesSent));
end;

function THttpSysResponse.SendBody(const PBuf: Pointer; const BufferSize: Integer): Integer;
var
  Chunk: HTTP_DATA_CHUNK;
  Flags: integer;
  BytesSent: Cardinal;
begin
  Flags := 0;
//  if (FResponse.FLengthMode <> THttpSysResponse.TLengthMode.ContentLength)
//    or (FContentSize + BufferSize < FResponse.ContentLength) then
//    Flags := Flags or HTTP_SEND_RESPONSE_FLAG_MORE_DATA;
  Flags := Flags or HTTP_SEND_RESPONSE_FLAG_MORE_DATA;
  Flags := Flags or HTTP_SEND_RESPONSE_FLAG_BUFFER_DATA;

  Chunk.DataChunkType := HttpDataChunkFromMemory;
  Chunk.BufferLength := BufferSize;
  Chunk.pBuffer := PBuf;
  BytesSent := 0;
  HttpCheck(HttpSendResponseEntityBody(Context.QueueId, Context.ContextId, Flags,
    1, @Chunk, BytesSent));
  Result := BytesSent;
end;

procedure THttpSysResponse.SendResponse;
var
  BytesSent: Cardinal;
  Flags: integer;
  AReason: AnsiString;
begin
  FResponse.StatusCode := Self.StatusCode;
  AReason := AnsiString(Self.StatusReason);
  FResponse.pReason := PAnsiChar(AReason);
  FResponse.ReasonLength := Length(AReason);
  FResponse.Version.MajorVersion := Context.Request.MajorVersion;
  FResponse.Version.MinorVersion := Context.Request.MinorVersion;

  Flags := 0;
  if (ContentLength <> 0) and (Context.Request.MethodType <> THttpMethod.Head) then
    Flags := Flags or HTTP_SEND_RESPONSE_FLAG_MORE_DATA
  else
    if not KeepAlive then
      Flags := Flags or HTTP_SEND_RESPONSE_FLAG_DISCONNECT;

  UpdateResponseHeaders;
  FResponse.EntityChunkCount := 0;
  FResponse.pEntityChunks := nil;
  BytesSent := 0;
  HttpCheck(HttpSendHttpResponse(Context.QueueId, Context.ContextId, Flags,
    @FResponse, nil, BytesSent));
end;

procedure THttpSysResponse.UpdateResponseHeaders;

  procedure AddSetCookieHeaders(HeaderDef: THttpHeaderInfo);
  var
    StartP, P: PAnsiChar;
    StrLen: Integer;
    Idx: Integer;
  begin
    P := PAnsiChar(HeaderDef.AnsiValue);
    repeat
      StrLen := 0;
      StartP := P;
      while (P^ <> #0) and (P^ <> #10) do
      begin
        Inc(P);
        Inc(StrLen);
      end;

      // Add as unknown header
      if StrLen > 0 then
      begin
        Idx := Length(FUnknownHeaders);
        SetLength(FUnknownHeaders, Idx + 1);
        FUnknownHeaders[Idx].NameLength := Length(HeaderDef.AnsiName);
        FUnknownHeaders[Idx].pName := PAnsiChar(HeaderDef.AnsiName);
        FUnknownHeaders[Idx].RawValueLength := StrLen;
        FUnknownHeaders[Idx].pRawValue := StartP;
      end;
      if P^ = #10 then
        Inc(P);
    until P^ = #0;
  end;

  function IsKnownHeader(const Name: string; out Id: HTTP_HEADER_ID): boolean;
  var
    I: HTTP_HEADER_ID;
  begin
    for I := Low(HttpResponseHeaderNames) to High(HttpResponseHeaderNames) do
      if SameText(HttpResponseHeaderNames[I], Name) then
      begin
        Id := I;
        Exit(true);
      end;
    Result := false;
  end;

var
  HeaderId: HTTP_HEADER_ID;
  HeaderDef: THttpHeaderInfo;
  Idx: Integer;
begin
  SetLength(FUnknownHeaders, 0);

  // Clear headers
  for HeaderId := Low(HTTP_HEADER_ID) to Pred(HttpHeaderResponseMaximum) do
  begin
    FResponse.Headers.KnownHeaders[HeaderId].RawValueLength := 0;
    FResponse.Headers.KnownHeaders[HeaderId].pRawValue := nil;
  end;

  for HeaderDef in Headers.AllHeaders do
  begin
    if IsKnownHeader(HeaderDef.Name, HeaderId) then
    begin
      // Special treatment for Set-Cookie header
      if HeaderId = HttpHeaderSetCookie then
        AddSetCookieHeaders(HeaderDef)
      else
      begin
        if HeaderDef.Value <> '' then
        begin
          FResponse.Headers.KnownHeaders[HeaderId].RawValueLength := Length(HeaderDef.AnsiValue);
          FResponse.Headers.KnownHeaders[HeaderId].pRawValue := PAnsiChar(HeaderDef.AnsiValue);
        end else
        begin
          FResponse.Headers.KnownHeaders[HeaderId].RawValueLength := 0;
          FResponse.Headers.KnownHeaders[HeaderId].pRawValue := nil;
        end;
      end;
    end
    else
    begin
      Idx := Length(FUnknownHeaders);
      SetLength(FUnknownHeaders, Idx + 1);
      FUnknownHeaders[Idx].NameLength := Length(HeaderDef.AnsiName);
      FUnknownHeaders[Idx].pName := PAnsiChar(HeaderDef.AnsiName);
      FUnknownHeaders[Idx].RawValueLength := Length(HeaderDef.AnsiValue);
      FUnknownHeaders[Idx].pRawValue := PAnsiChar(HeaderDef.AnsiValue);
    end;
  end;

  FResponse.Headers.UnknownHeaderCount := Length(FUnknownHeaders);
  if Length(FUnknownHeaders) > 0 then
    FResponse.Headers.pUnknownHeaders := @FUnknownHeaders[0]
  else
    FResponse.Headers.pUnknownHeaders := nil;
end;

{ THttpSysRequestStream }

constructor THttpSysRequestStream.Create(ARequest: THttpSysRequest; AContentLength: Int64);
begin
  inherited Create;
  FRequest := ARequest;
  FContentLength := AContentLength;
end;

function THttpSysRequestStream.GetContentLength: Int64;
begin
  Result := FContentLength;
end;

function THttpSysRequestStream.ReadBuffer(Buffer: Pointer; Count: Integer): Longint;
var
  TotalRead: Int64;
  BytesRead: Cardinal;
  HttpResult: HRESULT;
  PBuf: PByte;
  BufferSize: Integer;
begin
  // receive entity body. If is chunked, keep increasing the buffer
  TotalRead := 0;
  PBuf := PByte(Buffer);
  repeat
    BufferSize := Count - TotalRead;
    BytesRead := 0;
    if BufferSize > 0 then
    begin
      HttpResult := HttpReceiveRequestEntityBody(
        FRequest.Context.QueueId,
        FRequest.Context.ContextId,
        HTTP_RECEIVE_REQUEST_ENTITY_BODY_FLAG_FILL_BUFFER,
        PBuf, Cardinal(BufferSize), BytesRead, nil);
      TotalRead := TotalRead + BytesRead;
      Inc(PBuf, BytesRead);
      if HttpResult = ERROR_HANDLE_EOF then
        break;
      HttpCheck(HttpResult);
    end;
  until (BytesRead = 0);

  Result := TotalRead;
end;

{ THttpSysRequestExtraInfo }

constructor THttpSysRequestExtraInfo.Create(ASysRequest: THttpSysRequest);
begin
  FSysRequest := ASysRequest;
end;

function THttpSysRequestExtraInfo.RemoteIp: string;
begin
  Result := FSysRequest.RemoteIp;
end;

{$ENDIF}

end.
