{********************************************************************}
{                                                                    }
{ written by TMS Software                                            }
{            copyright (c) 2018                                      }
{            Email : info@tmssoftware.com                            }
{            Web : http://www.tmssoftware.com                        }
{                                                                    }
{ Thanks to Michael Van Canneyt for his contribution on              }
{ Indy and TMS Sparkle integration                                   }
{                                                                    }
{ The source code is given as is. The author is not responsible      }
{ for any possible damage done due to the use of this code.          }
{ The complete source code remains property of the author and may    }
{ not be distributed, published, given or sold in any form as such.  }
{ No parts of the source code can be included in any other component }
{ or application without written authorization of the author.        }
{********************************************************************}

unit Sparkle.Indy.Context;

interface

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

type
  TIndyRequest = class(THttpServerRequest)
  strict private
    FRequest: TIdHTTPRequestInfo;
  private
    function FullUrl(const Host, RawPath, Query: string): string;
  public
    constructor Create(ARequest: TIdHTTPRequestInfo);
    Destructor Destroy; override;
  end;

  TIndyResponse = class(THttpServerResponse)
  strict private
    FResponse: TIdHTTPResponseInfo;
    FStream: TStream;
  strict protected
    procedure EndResponse; override;
    procedure SendResponse; override;
    function SendBody(const PBuf: Pointer; const BufferSize: Integer): Integer; override;
  public
    constructor Create(AResponse: TIdHTTPResponseInfo);
    destructor Destroy; override;
  end;

  TIndyContext = class(THttpServerContext)
  strict private
    FRequest: TIndyRequest;
    FResponse: TIndyResponse;
    FThreadContext: TIDContext;
  strict protected
    function GetRequest: THttpServerRequest; override;
    function GetResponse: THttpServerResponse; override;
  public
    constructor Create(AThread: TIDContext; ARequest: TIdHTTPRequestInfo; AResponse: TIdHTTPResponseInfo);
    destructor Destroy; override;
    property ThreadContext: TIDContext Read FThreadContext;
  end;

implementation

uses
  Sparkle.Uri;

{ TIndyContext }

constructor TIndyContext.Create(AThread: TIDContext;
  ARequest: TIdHTTPRequestInfo; AResponse: TIdHTTPResponseInfo);
begin
  FThreadContext := AThread;
  FRequest := TIndyRequest.Create(ARequest);
  FResponse := TIndyResponse.Create(AResponse);
end;

destructor TIndyContext.Destroy;
begin
  FreeAndNil(FRequest);
  FreeAndNil(FResponse);
  inherited;
end;

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

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

{ TIndyRequestStream }

{ TIndyResponse }

constructor TIndyResponse.Create(AResponse: TIdHTTPResponseInfo);
begin
  inherited Create;
  FResponse := AResponse;
  FStream := TMemoryStream.Create;
  FResponse.FreeContentStream := False;
end;

destructor TIndyResponse.Destroy;
begin
  FreeAndNil(FStream);
  inherited;
end;

procedure TIndyResponse.EndResponse;
begin
  FResponse.WriteContent;
  FStream.Position := 0;
end;

function TIndyResponse.SendBody(const PBuf: Pointer;
  const BufferSize: Integer): Integer;
begin
  if FResponse.ContentStream = nil then
    FResponse.ContentStream := FStream;
  Result := FResponse.ContentStream.Write(PBuf^, BufferSize);
end;

procedure TIndyResponse.SendResponse;
var
  Header: THttpHeaderInfo;
begin
  for Header in Self.Headers.AllHeaders do
    // Indy does a lot of "magic" behind the scenes that we don't want.
    // Not sure if there is a better and most optimized way to do this
    if SameText(Header.Name, 'transfer-encoding') then
      FResponse.TransferEncoding := Header.Value
    else if SameText(Header.Name, 'content-type') then
    begin
      FResponse.ContentType := Header.Value;
      FResponse.CharSet := '';
    end
    else if SameText(Header.Name, 'content-length') then
      FResponse.ContentLength := StrToInt(Header.Value)
    else
      FResponse.CustomHeaders.AddValue(Header.Name, Header.Value);

  FResponse.ResponseNo := StatusCode;
  FResponse.ResponseText := StatusReason;
end;

{ TIndyRequest }

constructor TIndyRequest.Create(ARequest: TIdHTTPRequestInfo);
var
  I: Integer;
begin
  Inherited Create;
  FRequest := ARequest;
  ContentStream := FRequest.PostStream;
  Method := FRequest.Command;

  RawUri := FullUrl(FRequest.Host, FRequest.URI, FRequest.QueryParams);

  // Indy overrides this property
  Tstrings(FRequest.RawHeaders).NameValueSeparator := ':';
  For I := 0 to FRequest.RawHeaders.Count - 1 do
    Headers.AddValue(FRequest.RawHeaders.Names[I],
      FRequest.RawHeaders.ValueFromIndex[I]);
end;

destructor TIndyRequest.Destroy;
begin
  ContentStream := Nil;
  Inherited;
end;

function TIndyRequest.FullUrl(const Host, RawPath, Query: 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;
  if Query <> '' then
    Result := Result + '?' + Query;
end;

end.
