unit Sparkle.HttpServer.Request;

{$I Sparkle.Inc}

interface

uses
  System.SysUtils, System.Classes,
  Sparkle.Http.Headers,
  Sparkle.Security,
  Sparkle.Uri;

type
  THttpMethod = (Other, Get, Post, Put, Delete, Head, Patch, Options);

  IHttpRequestExtraInfo = interface
  ['{792C0E3C-5C3B-41EB-8E2B-A0CB5D2B16AA}']
    function RemoteIp: string;
  end;

  THttpServerRequest = class
  strict private
    FHeaders: THttpHeaders;
    FMethod: string;
    FRawUri: string;
    FProtocol: string;
    FUri: TUri;
    FContent: TBytes;
    FContentLoaded: boolean;
    FContentStream: TStream;
    FExtraInfo: IHttpRequestExtraInfo;
    FUser: IUserIdentity;
    procedure SetRawUri(const Value: string);
    procedure LoadContent;
    function GetContentLength: Int64;
    function GetContent: TBytes;
    function GetMajorVersion: integer;
    function GetMinorVersion: integer;
    function GetMethodType: THttpMethod;
    function GetUri: TUri;
    function GetRemoteIp: string;
  public
    constructor Create;
    destructor Destroy; override;
  public
    { Helper read-only properties based on core request data }
    property Content: TBytes read GetContent;
    // ContentLength property returns the integer value of content-length header, or -1 if it doesn't exist
    property ContentLength: Int64 read GetContentLength;
    property MethodType: THttpMethod read GetMethodType;
    property MajorVersion: integer read GetMajorVersion;
    property MinorVersion: integer read GetMinorVersion;
    property Uri: TUri read GetUri;
    property RemoteIp: string read GetRemoteIp;
  public
    { Optional modifiable data }
    property Protocol: string read FProtocol write FProtocol;
    property User: IUserIdentity read FUser write FUser;

    // This is temporary workaround, subject to change in future
    property ExtraInfo: IHttpRequestExtraInfo read FExtraInfo write FExtraInfo;
  public
    { The core request data}
    property RawUri: string read FRawUri write SetRawUri;
    property Method: string read FMethod write FMethod;
    property Headers: THttpHeaders read FHeaders;
    property ContentStream: TStream read FContentStream write FContentStream;
  end;

  THttpRequestStream = class(TStream)
  strict private
    FStreamSize: Int64;
  protected
    function GetContentLength: Int64; virtual; abstract;
    function GetSize: Int64; override;
    function ReadBuffer(Buffer: Pointer; Count: Longint): Longint; virtual; abstract;
  public
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
  end;

implementation

const
  Header_ContentLength = 'content-length';

{ THttpServerRequest }

constructor THttpServerRequest.Create;
begin
  FHeaders := THttpHeaders.Create;
  Protocol := 'HTTP/1.1';
end;

destructor THttpServerRequest.Destroy;
begin
  FHeaders.Free;
  FUri.Free;
  FContentStream.Free;
  inherited;
end;

function THttpServerRequest.GetContent: TBytes;
begin
  if not FContentLoaded then
  begin
    LoadContent;
    FContentLoaded := true;
  end;
  Result := FContent;
end;

function THttpServerRequest.GetContentLength: Int64;
begin
  if not TryStrToInt64(Headers.Get(Header_ContentLength), Result) then
    Result := -1;
end;

function THttpServerRequest.GetMajorVersion: integer;
begin
  if Protocol = 'HTTP/1.1' then
    Result := 1
  else
  if Protocol = 'HTTP/1.0' then
    Result := 1
  else
    Result := -1;
end;

function THttpServerRequest.GetMethodType: THttpMethod;
begin
  if Method = 'GET' then
    Result := THttpMethod.Get
  else
  if Method = 'POST' then
    Result := THttpMethod.Post
  else
  if Method = 'PUT' then
    Result := THttpMethod.Put
  else
  if Method = 'DELETE' then
    Result := THttpMethod.Delete
  else
  if Method = 'HEAD' then
    Result := THttpMethod.Head
  else
  if Method = 'PATCH' then
    Result := THttpMethod.Patch
  else
  if Method = 'OPTIONS' then
    Result := THttpMethod.Options
  else
    Result := THttpMethod.Other;
end;

function THttpServerRequest.GetMinorVersion: integer;
begin
  if Protocol = 'HTTP/1.1' then
    Result := 1
  else
  if Protocol = 'HTTP/1.0' then
    Result := 0
  else
    Result := -1;
end;

function THttpServerRequest.GetRemoteIp: string;
begin
  if FExtraInfo <> nil then
    Result := FExtraInfo.RemoteIp
  else
    Result := '';
end;

function THttpServerRequest.GetUri: TUri;
begin
  if FUri = nil then
    FUri := TUri.Create(RawUri);
  Result := FUri;
end;

procedure THttpServerRequest.LoadContent;
const
  TempBufferSize = 4096; //arbitrary initial length for input of unknown length
var
  BufLen: Int64;
  NoContentLength: boolean;

  procedure ReallocContent(NewSize: Int64);
  begin
    if (NewSize > BufLen) then
    begin
      SetLength(FContent, NewSize);
      BufLen := NewSize;
    end;
  end;

var
  TotalRead: Int64;
  BytesRead: Cardinal;
begin
  if (ContentLength = 0) or (ContentStream = nil) then
    Exit;
  NoContentLength := ContentLength = -1;

  if NoContentLength then
    BufLen := TempBufferSize
  else
    BufLen := ContentLength;

  SetLength(FContent, BufLen);
  TotalRead := 0;
  {$IFNDEF DELPHIBERLIN_LVL}
  BytesRead := 0;
  {$ENDIF}
  repeat
    if (BufLen - TotalRead) = 0 then
    begin
      if NoContentLength then
        ReallocContent(BufLen + TempBufferSize) // increase
      else
        break;
    end;
    BytesRead := ContentStream.Read(FContent[TotalRead], BufLen - TotalRead);
    TotalRead := TotalRead + BytesRead;
  until (BytesRead = 0);

  // now do final steps with the bytes received
  if NoContentLength then
    // Realloc memory to the bytesread
    SetLength(FContent, TotalRead);

//    // if not chunked, total bytes received must be exactly equal to
//    // content-length header
//    if TotalRead <> BufLen then
//      WrongSizeError;
end;

procedure THttpServerRequest.SetRawUri(const Value: string);
begin
  FRawUri := Value;
  FreeAndNil(FUri);
end;

{ THttpRequestStream }

function THttpRequestStream.GetSize: Int64;
begin
  Result := GetContentLength;
  if Result = -1 then
    Result := inherited GetSize;
end;

function THttpRequestStream.Read(var Buffer; Count: Longint): Longint;
begin
  if Count = 0 then Exit(0);
  Result := ReadBuffer(@Buffer, Count);
  FStreamSize := FStreamSize + Result;
end;

function THttpRequestStream.Seek(const Offset: Int64;
  Origin: TSeekOrigin): Int64;
begin
  case Origin of
    soBeginning:
      if FStreamSize = Offset then Exit(FStreamSize);
    soCurrent, soEnd:
      if Offset = 0 then
        Exit(FStreamSize);
  end;
  raise EStreamError.Create('Http request stream cannot change position.');
end;

function THttpRequestStream.Write(const Buffer; Count: Longint): Longint;
begin
  Result := 0;
end;

end.
