unit Sparkle.HttpServer.Response;

interface

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

type
  THttpServerResponse = class;

  EHttpResponseException = class(Exception)
  end;

  THttpRawResponseStream = class;
  THttpServerResponseStream = class;

  IHttpResponseBodyWriter = interface
  ['{DF111BDE-124C-4F70-8E32-7811D5E77C76}']
    function Stream: TStream;
    procedure Flush;
  end;

  THttpOnHeadersProc = TProc<THttpServerResponse>;

  THttpServerResponse = class
  private
    FStatusCode: Integer;
    FStatusReason: string;
    FHeaders: THttpHeaders;
    FRawWriter: IHttpResponseBodyWriter;
    FContent: THttpServerResponseStream;
    FClosed: boolean;
    FProtocol: string;
    FKeepAlive: boolean;
    FHeadersSent: boolean;
    FMinChunkSize: integer;
    FOnHeadersProc: THttpOnHeadersProc;
    procedure SetStatusCode(const Value: integer);
    procedure UpdateDefaultReason;
    function GetContentEncoding: string;
    procedure SetContentEncoding(const Value: string);
    function GetContentType: string;
    procedure SetContentType(const Value: string);
    procedure SendHeaders;
    function GetMajorVersion: integer;
    function GetMinorVersion: integer;
    function GetChunked: boolean;
    procedure SetChunked(const Value: boolean);
    function GetContent: TStream;
    procedure SetContentLength(const Value: Int64);
    function GetContentLength: Int64;
  protected
    function CreateRawWriter: IHttpResponseBodyWriter; virtual;
    procedure EndResponse; virtual; abstract;
    procedure SendResponse; virtual; abstract;
    function SendBody(const PBuf: Pointer; const BufferSize: Integer): Integer; virtual; abstract;
  strict protected
    property MajorVersion: integer read GetMajorVersion;
    property MinorVersion: integer read GetMinorVersion;
    property KeepAlive: boolean read FKeepAlive write FKeepAlive;
  public
    constructor Create;
    destructor Destroy; override;
    property StatusCode: integer read FStatusCode write SetStatusCode;
    property Headers: THttpHeaders read FHeaders;
    property Content: TStream read GetContent;
    property Closed: boolean read FClosed;
  public
    procedure Close; overload;
    procedure Close(AContent: TBytes); overload;
    property Chunked: boolean read GetChunked write SetChunked;
    property ContentLength: Int64 read GetContentLength write SetContentLength;
    property ContentEncoding: string read GetContentEncoding write SetContentEncoding;
    property ContentType: string read GetContentType write SetContentType;
    property HeadersSent: boolean read FHeadersSent;
    property StatusReason: string read FStatusReason write FStatusReason;
    property Protocol: string read FProtocol write FProtocol;
    property MinChunkSize: integer read FMinChunkSize write FMinChunkSize;
  public
    { members used mostly in middleware classes }
    procedure OnHeaders(Proc: THttpOnHeadersProc);
    property RawWriter: IHttpResponseBodyWriter read FRawWriter write FRawWriter;
  end;

  THttpRawResponseStream = class(TStream)
  strict private
    {$IFDEF AUTOREFCOUNT}[Weak]{$ENDIF}
    FResponse: THttpServerResponse;
    FStreamSize: Int64;
    FChunkCache: TMemoryStream;
  protected
    // SendBuffer sends the raw buffer data to the client, without any change
    function SendBuffer(Buffer: Pointer; BufLen: Longint): Longint;

    // InternalWrite sends the buffer to the client, creating chunk headers
    // if needed. Even if Count is zero, data might be sent, because there might be
    // cached data for chunked response
    function InternalWrite(Buffer: Pointer; Count: Longint): Longint;
  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;
    constructor Create(AResponse: THttpServerResponse);
    destructor Destroy; override;
    procedure Flush;
  end;

  THttpRawResponseBodyWriter = class(TInterfacedObject, IHttpResponseBodyWriter)
  strict private
    FStream: THttpRawResponseStream;
  public
    constructor Create(AResponse: THttpServerResponse);
    destructor Destroy; override;
    function Stream: TStream;
    procedure Flush;
  end;

  THttpServerResponseStream = class(TStream)
  strict private
    {$IFDEF AUTOREFCOUNT}[Weak]{$ENDIF}FResponse: THttpServerResponse;
    FStreamSize: Int64;
  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;
    constructor Create(AResponse: THttpServerResponse);
    destructor Destroy; override;
  end;

implementation

uses
  Sparkle.Utils;

{ THttpServerResponse }

procedure THttpServerResponse.Close(AContent: TBytes);
var
//  TotalWritten: Int64;
  BytesToWrite: Int64;
begin
  BytesToWrite := Length(AContent);
  if not HeadersSent and not Chunked then
    ContentLength := BytesToWrite;

  // Let's remove the loop for now, there is a risk it gets in an infinite loop
//  TotalWritten := 0;
//  repeat
//  TotalWritten := TotalWritten + Content.Write(AContent[TotalWritten], BytesToWrite - TotalWritten);
//  until TotalWritten >= BytesToWrite;

  Content.Write(AContent[0], BytesToWrite);
  Close;
end;

procedure THttpServerResponse.Close;
begin
  RawWriter.Flush;

  if not HeadersSent then
  begin
    if (ContentLength = -1) then
      ContentLength := 0;
    SendHeaders;
  end
  else
    EndResponse;
  FClosed := true;
end;

constructor THttpServerResponse.Create;
begin
  FHeaders := THttpHeaders.Create;
  FHeadersSent := false;
  FClosed := false;
  FKeepAlive := true;
  FMinChunkSize := 16384; //16k chunk size
  FOnHeadersProc :=
    procedure(Resp: THttpServerResponse)
    begin
    end;
  FRawWriter := THttpRawResponseBodyWriter.Create(Self);
  Protocol := 'HTTP/1.1';
end;

function THttpServerResponse.CreateRawWriter: IHttpResponseBodyWriter;
begin
  Result := THttpRawResponseBodyWriter.Create(Self);
end;

destructor THttpServerResponse.Destroy;
begin
  FHeaders.Free;
  FContent.Free;
  inherited;
end;

function THttpServerResponse.GetChunked: boolean;
begin
  Result := SameText(Headers.Get('transfer-encoding'), 'chunked');
end;

function THttpServerResponse.GetContent: TStream;
begin
  if FContent = nil then
    FContent := THttpServerResponseStream.Create(Self);
  Result := FContent;
end;

function THttpServerResponse.GetContentEncoding: string;
begin
  Result := Headers.Get('content-encoding');
end;

function THttpServerResponse.GetContentLength: Int64;
begin
  if not TryStrToInt64(Headers.Get('content-length'), Result) then
    Result := -1;
end;

function THttpServerResponse.GetContentType: string;
begin
  Result := Headers.Get('content-type');
end;

function THttpServerResponse.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 THttpServerResponse.GetMinorVersion: integer;
begin
  if Protocol = 'HTTP/1.1' then
    Result := 1
  else
  if Protocol = 'HTTP/1.0' then
    Result := 0
  else
    Result := -1;
end;

procedure THttpServerResponse.OnHeaders(Proc: THttpOnHeadersProc);
var
  PreviousProc: THttpOnHeadersProc;
  UnsafeSelf: Pointer;
begin
  PreviousProc := FOnHeadersProc;
  UnsafeSelf := Self;
  FOnHeadersProc := procedure(Resp: THttpServerResponse)
    begin
      Proc(THttpServerResponse(UnsafeSelf));
      PreviousProc(THttpServerResponse(UnsafeSelf));
    end
end;

procedure THttpServerResponse.SendHeaders;
begin
  if HeadersSent then Exit;

  FOnHeadersProc(Self);

  { last-minute tuning of headers. This is done automaticaly by Sparkle and
    middleware have no control over this. }

  // First, check if response has no content-length nor is chunked
  // So we must use chunked transfer by default, if http/1.1, or just close connection
  // if http 1.0
  if (ContentLength = -1) and not Chunked then
  begin
    // in case no content length was specified nor chunked response defined,
    // let's do it automatically. If it's http 1.0 or there is no content to be sent,
    // then connection must drop after response is closed.
    // If it's http 1.1 and we have content we can use chunked response
    if (MinorVersion = 0) then
      KeepAlive := false
    else
      Chunked := true;
  end;

  if not KeepAlive then
  begin
    Headers.SetValue('connection', 'close');
  end
  else
  begin
    // if http 1.0 then force keep connection
    if MinorVersion = 0 then
      Headers.SetValue('connection', 'keep-alive');
  end;

  SendResponse;
  FHeadersSent := true;
end;

procedure THttpServerResponse.SetChunked(const Value: boolean);
begin
  if HeadersSent then Exit;

  if Value then
  begin
    Headers.Remove('content-length');
    Headers.SetValue('transfer-encoding', 'chunked');
  end
  else
    Headers.Remove('transfer-encoding');
end;

procedure THttpServerResponse.SetContentEncoding(const Value: string);
begin
  Headers.SetValue('content-encoding', Value);
end;

procedure THttpServerResponse.SetContentLength(const Value: Int64);
begin
  if HeadersSent then Exit;

  if Value >= 0 then
    Headers.SetValue('content-length', IntToStr(Value))
  else
    Headers.Remove('content-length');
end;

procedure THttpServerResponse.SetContentType(const Value: string);
begin
  Headers.SetValue('content-type', Value);
end;

procedure THttpServerResponse.SetStatusCode(const Value: integer);
begin
  FStatusCode := Value;
  UpdateDefaultReason;
end;

procedure THttpServerResponse.UpdateDefaultReason;
begin
  StatusReason := TSparkleUtils.GetStatusReason(StatusCode);
end;

{ THttpServerResponseStream }

constructor THttpRawResponseStream.Create(AResponse: THttpServerResponse);
begin
  inherited Create;
  FResponse := AResponse;
  FChunkCache := TMemoryStream.Create;
end;

destructor THttpRawResponseStream.Destroy;
begin
  FChunkCache.Free;
  inherited;
end;

procedure THttpRawResponseStream.Flush;
const
  // it's a "0" character followed by #13#10 #13#10
  FinalChunkHeader: array[0..4] of Byte = (48, 13, 10, 13, 10);
  LengthFinalChunkHeader = Length(FinalChunkHeader);
begin
  if FResponse.Chunked then
  begin
    // Send data remaining in chunk cache
    InternalWrite(nil, 0);

    // Send final chunk header (empty)
    SendBuffer(@FinalChunkHeader[0], LengthFinalChunkHeader);
  end;
end;

function THttpRawResponseStream.InternalWrite(Buffer: Pointer;
  Count: Longint): Longint;
var
  ChunkBuffer: TBytes;
  PBuf: PByte;
  BufLen: integer;
  ChunkHeader: TBytes;
  ExtraData: integer;
  CachedSize: integer;
begin
  if (Count = 0) and (not FResponse.Chunked or (FChunkCache.Size = 0)) then
    Exit(0);

  ExtraData := 0;
  CachedSize := 0;

  // if chunked response, then recreate the buffer to be sent with cached content
  // and chunk headers
  if FResponse.Chunked then
  begin
    CachedSize := FChunkCache.Size;

    // Create chunk header
    ChunkHeader := TEncoding.UTF8.GetBytes((IntToHex(Count + CachedSize, 1) + #13#10));

    // Extra data to be added to buffer: chunk header size plus trailing #13#10 chars
    ExtraData := Length(ChunkHeader) + 2;

    // Set size of buffer to be sent, which includes chunk headers and data in cache
    SetLength(ChunkBuffer, Count + CachedSize + ExtraData);

    // Move chunk header
    System.Move(ChunkHeader[0], ChunkBuffer[0], Length(ChunkHeader));

    // Move cached data if any
    if CachedSize > 0 then
      System.Move(FChunkCache.Memory^, ChunkBuffer[Length(ChunkHeader)], CachedSize);
    FChunkCache.Clear;

    // Move actual data if any
    if Count > 0 then
      System.Move(Buffer^, ChunkBuffer[Length(ChunkHeader) + CachedSize], Count);

    PBuf := @ChunkBuffer[0];
    BufLen := Length(ChunkBuffer);
    ChunkBuffer[BufLen - 2] := 13;
    ChunkBuffer[BufLen - 1] := 10;
  end else
  begin
    // if not chunked response, just send data directly
    PBuf := Buffer;
    BufLen := Count;
  end;

  // Do not consider the extra data added by chunked responses (chunk header and trailing)
  // not cached size (because it was already considered when writing to the cache stream
  Result := SendBuffer(PBuf, BufLen);
  Result := Result - ExtraData - CachedSize;
  if Result < 0 then
    Result := 0;
end;

function THttpRawResponseStream.Read(var Buffer; Count: Longint): Longint;
begin
  Result := 0;
end;

function THttpRawResponseStream.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 response stream cannot change position.');
end;

function THttpRawResponseStream.SendBuffer(Buffer: Pointer;
  BufLen: Longint): Longint;
var
  TotalSent: integer;
  BufferSize: integer;
  BytesSent: Integer;
  PBuf: PByte;
begin
  if BufLen = 0 then Exit(0);

  if not FResponse.HeadersSent then
    FResponse.SendHeaders;

  PBuf := PByte(Buffer);
  // send buffer
  TotalSent := 0;
  repeat
    BufferSize := BufLen - TotalSent;

    // if we decide to change and buffer data for performance, we should consider
    // reducing the buffer size because data is copied to internal buffer before sent to client
    //    if BufferSize > 8192 then
    //      BufferSize := 8192;

    BytesSent := 0;
    if BufferSize > 0 then
    begin
      BytesSent := FResponse.SendBody(PBuf, BufferSize);
      Inc(PBuf, BytesSent);
      TotalSent := TotalSent + integer(BytesSent);
    end;
  until (BytesSent = 0);
  Result := TotalSent;
end;

function THttpRawResponseStream.Write(const Buffer; Count: Longint): Longint;
begin
  if Count = 0 then Exit(0);

  if not FResponse.HeadersSent then
    FResponse.SendHeaders;

  // if response is chunked, then we need to check if the chunk size has reached
  // the minimum size. If it does not, then just save in internal stream and return.
  // Do not send any data until minimum size is reached.
  if FResponse.Chunked and (Count + FChunkCache.Size < FResponse.MinChunkSize) then
    Result := FChunkCache.Write(Buffer, Count)
  else
    Result := InternalWrite(@Buffer, Count);

  FStreamSize := FStreamSize + Result;
end;

{ THttpServerResponseStream }

constructor THttpServerResponseStream.Create(AResponse: THttpServerResponse);
begin
  inherited Create;
  FResponse := AResponse;
end;

destructor THttpServerResponseStream.Destroy;
begin
  inherited;
end;

function THttpServerResponseStream.Read(var Buffer; Count: Longint): Longint;
begin
  Result := 0;
end;

function THttpServerResponseStream.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 response stream cannot change position.');
end;

function THttpServerResponseStream.Write(const Buffer; Count: Longint): Longint;
begin
  if Count = 0 then Exit(0);

  if not FResponse.HeadersSent then
    FResponse.SendHeaders;

  Result := FResponse.RawWriter.Stream.Write(Buffer, Count);

  FStreamSize := FStreamSize + Result;
end;

{ THttpRawResponseBodyWriter }

constructor THttpRawResponseBodyWriter.Create(AResponse: THttpServerResponse);
begin
  FStream := THttpRawResponseStream.Create(AResponse);
end;

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

procedure THttpRawResponseBodyWriter.Flush;
begin
  FStream.Flush;
end;

function THttpRawResponseBodyWriter.Stream: TStream;
begin
  Result := FStream;
end;

end.
