delphimvcframework/sources/MVCFramework.RESTClient.pas

unit MVCFramework.RESTClient;

interface

uses
  Classes,
  IdBaseComponent,
  IdComponent,
  IdTCPConnection,
  IdTCPClient,
  IdHTTP,
  idURI,
  DBXJSON,
  IdMultipartFormData,
  System.SysUtils;

type
  TArrayOfString = array of string;
  THttpCommand = (httpGET, httpPOST, httpPUT, httpDELETE);

  IRESTResponse = interface
    function BodyAsString: string;
    function BodyAsJsonObject: TJSONObject;
    function ResponseCode: Word;
    function ResponseText: string;
    function Headers: TStringlist;
    function Body: TStringStream;
    procedure SetResponseCode(AResponseCode: Word);
    procedure SetResponseText(AResponseText: string);
    procedure SetHeaders(AHeaders: TStrings);
  end;

  TRESTResponse = class(TInterfacedObject, IRESTResponse)
  private
    FBody            : TStringStream;
    FResponseCode    : Word;
    FResponseText    : string;
    FHeaders         : TStringlist;
    FBodyAsJSONObject: TJSONObject;

  public
    function BodyAsString: string;
    function BodyAsJsonObject: TJSONObject;
    function ResponseCode: Word;
    function ResponseText: string;
    function Headers: TStringlist;
    function Body: TStringStream;

    procedure SetResponseCode(AResponseCode: Word);
    procedure SetResponseText(AResponseText: string);
    procedure SetHeaders(AHeaders: TStrings);

    constructor Create; virtual;
    destructor Destroy; override;
  end;

  TRESTClient = class(TInterfacedObject)
  private
    FServerName         : string;
    FServerPort         : Word;
    FBodyParams         : TStringlist;
    FQueryStringParams  : TStringlist;
    FAccept             : string;
    FRawBody            : TStringStream;
    FHTTP               : TIdHTTP;
    FContentType        : string;
    FLastSessionID      : string;
    FNextRequestIsAsynch: Boolean;
    FAsychProc          : TProc<IRESTResponse, Exception>;
    FPrimaryThread      : TThread;
    FMultiPartFormData  : TIdMultiPartFormDataStream;
    function EncodeQueryStringParams(const AQueryStringParams: TStrings;
      IncludeQuestionMark: Boolean = true): string;
    procedure SetBodyParams(const Value: TStringlist);
    procedure SetQueryStringParams(const Value: TStringlist);
    procedure SetAccept(const Value: string);
    procedure SetContentType(const Value: string);
    function GetSessionID: string;
    procedure SetSessionID(const Value: string);
    function GetBodyParams: TStringlist;
    function GetQueryStringParams: TStringlist;
    function GetRawBody: TStringStream;
    procedure SetReadTimeout(const Value: Integer);
    function GetReadTimeout: Integer;
    procedure StartAsynchRequestJSONBody(AHTTPMethod: THttpCommand;
      AUrl: string; AJSONValue: TJSONValue; AOwnsJSONBody: Boolean);
    procedure StartAsynchRequest(AHTTPMethod: THttpCommand; AUrl: string);
    procedure SetConnectionTimeout(const Value: Integer);
    function GetConnectionTimeout: Integer;
    procedure SetRequestHeaders(const Value: TStringlist);

  strict protected
    FRequestHeaders: TStringlist;

  protected
    procedure HandleCookies;
    function EncodeResourceParams(AResourceParams: array of string): string;
    function HttpCommandToString(const AHttpCommand: THttpCommand): string;
    function SendHTTPCommand(const ACommand: THttpCommand;
      const AAccept, AContentType, AUrl: string; ABodyParams: TStrings)
      : IRESTResponse;
    function SendHTTPCommandJSONBody(const ACommand: THttpCommand;
      const AAccept, AContentType, AUrl: string; AJSONValue: TJSONValue)
      : IRESTResponse;
    procedure HandleRequestCookies;
    function GetMultipartFormData: TIdMultiPartFormDataStream;

  public
    constructor Create(const AServerName: string;
      AServerPort: Word = 80); virtual;
    destructor Destroy; override;

    function AddFile(const FieldName, FileName: string; const ContentType: string = '')
      : TRESTClient;

    function Asynch(AProc: TProc<IRESTResponse, Exception>): TRESTClient;
    function ClearAllParams: TRESTClient;
    function ResetSession: TRESTClient;
    function Accept(const AcceptHeader: string): TRESTClient; overload;
    function Accept: string; overload;

    function ContentType(const ContentTypeHeader: string): TRESTClient;
      overload;
    function ContentType: string; overload;
    // requests
    function doGET(AResource: string; AResourceParams: array of string)
      : IRESTResponse;
    function doPOST(AResource: string; AResourceParams: array of string)
      : IRESTResponse; overload;
    function doPOST(AResource: string; AResourceParams: array of string;
      AJSONValue: TJSONValue; AOwnsJSONBody: Boolean = true)
      : IRESTResponse; overload;
    function doPUT(AResource: string; AResourceParams: array of string)
      : IRESTResponse; overload;
    function doPUT(AResource: string; AResourceParams: array of string;
      AJSONValue: TJSONValue; AOwnsJSONBody: Boolean = true)
      : IRESTResponse; overload;
    function doDELETE(AResource: string; AResourceParams: array of string)
      : IRESTResponse;
    property BodyParams: TStringlist read GetBodyParams write SetBodyParams;
    property RawBody: TStringStream read GetRawBody;
    property QueryStringParams: TStringlist read GetQueryStringParams
      write SetQueryStringParams;
    property SessionID: string read GetSessionID write SetSessionID;
    property ReadTimeout: Integer read GetReadTimeout write SetReadTimeout;
    property ConnectionTimeout: Integer read GetConnectionTimeout
      write SetConnectionTimeout;
    property RequestHeaders: TStringlist read FRequestHeaders write SetRequestHeaders;
  end;

function StringsToArrayOfString(const AStrings: TStrings): TArrayOfString;

implementation

{ TRSF }

// type
// THackedIdHTTP = class(TIdHTTP)
// public
// procedure Delete(AURL: string; AResponseContent: TIdStream);
// end;

function StringsToArrayOfString(const AStrings: TStrings): TArrayOfString;

var
  i: Integer;
begin
  SetLength(Result, AStrings.Count);
  if AStrings.Count = 0 then
    Exit;
  for i := 0 to AStrings.Count - 1 do
    Result[i] := AStrings[i];
end;

function TRESTClient.Accept(const AcceptHeader: string): TRESTClient;
begin
  SetAccept(AcceptHeader);
  Result := Self;
end;

function TRESTClient.Accept: string;
begin
  Result := FAccept;
end;

function TRESTClient.AddFile(const FieldName, FileName,
  ContentType: string): TRESTClient;
begin
  GetMultipartFormData.AddFile(FieldName, FileName, ContentType);
end;

function TRESTClient.Asynch(AProc: TProc<IRESTResponse, Exception>)
  : TRESTClient;
begin
  FNextRequestIsAsynch := true;
  FAsychProc := AProc;
  Result := Self;
end;

function TRESTClient.ClearAllParams: TRESTClient;
begin
  if Assigned(FRawBody) then
  begin
    FRawBody.Size := 0;
    FRawBody.Position := 0;
  end;
  if Assigned(FBodyParams) then
    FBodyParams.Clear;
  if Assigned(FQueryStringParams) then
    FQueryStringParams.Clear;
  Result := Self;
  FNextRequestIsAsynch := False;
  FAsychProc := nil;
end;

function TRESTClient.ContentType: string;
begin
  Result := FContentType;
end;

function TRESTClient.ContentType(const ContentTypeHeader: string): TRESTClient;
begin
  SetContentType(ContentTypeHeader);
  Result := Self;
end;

constructor TRESTClient.Create(const AServerName: string; AServerPort: Word);
begin
  inherited Create;
  FPrimaryThread := TThread.CurrentThread;
  FServerName := AServerName;
  FServerPort := AServerPort;
  FBodyParams := nil; // TStringlist.Create;
  FQueryStringParams := nil; // TStringlist.Create;
  FRawBody := nil; // TStringStream.Create('');
  FAccept := 'application/json';
  FContentType := 'application/json; charset=utf-8';
  FRequestHeaders := TStringlist.Create;

  FHTTP := TIdHTTP.Create(nil);
  FHTTP.ReadTimeout := 20000;
  // FHTTP.AllowCookies := true;
end;

destructor TRESTClient.Destroy;
begin
  FreeAndNil(FBodyParams);
  FreeAndNil(FQueryStringParams);
  FreeAndNil(FRawBody);
  FreeAndNil(FRequestHeaders);
  FreeAndNil(FMultiPartFormData);
  FHTTP.Free;
  inherited;
end;

function TRESTClient.doDELETE(AResource: string;
  AResourceParams: array of string): IRESTResponse;
var
  url: string;
begin
  url := 'http://' + FServerName + ':' + inttostr(FServerPort) + AResource +
    EncodeResourceParams(AResourceParams) + EncodeQueryStringParams
    (FQueryStringParams);

  if FNextRequestIsAsynch then
  begin
    Result := nil;
    StartAsynchRequest(httpDELETE, url);
  end
  else
  begin
    Result := SendHTTPCommand(httpDELETE, FAccept, FContentType, url, nil);
    ClearAllParams;
  end;
end;

procedure TRESTClient.StartAsynchRequest(AHTTPMethod: THttpCommand;
  AUrl: string);
var
  th: TThread;
begin
  th := TThread.CreateAnonymousThread(
    procedure
    var
      R: IRESTResponse;
    begin
      try
        R := SendHTTPCommand(AHTTPMethod, FAccept, FContentType, AUrl,
          FBodyParams);
        TMonitor.Enter(TObject(R));
        try
          FAsychProc(R, nil);
          ClearAllParams;
        finally
          TMonitor.Exit(TObject(R));
        end;
      except
        on E: Exception do
        begin
          FAsychProc(nil, E);
        end;
      end;
    end);
  th.Start;
end;

procedure TRESTClient.StartAsynchRequestJSONBody(AHTTPMethod: THttpCommand;
  AUrl: string; AJSONValue: TJSONValue; AOwnsJSONBody: Boolean);
var
  th: TThread;
begin
  th := TThread.CreateAnonymousThread(
    procedure
    var
      R: IRESTResponse;
    begin
      try
        R := SendHTTPCommandJSONBody(AHTTPMethod, FAccept, FContentType, AUrl,
          AJSONValue);
        if AOwnsJSONBody then
          FreeAndNil(AJSONValue);
        TMonitor.Enter(TObject(R));
        try
          FAsychProc(R, nil);
          ClearAllParams;
        finally
          TMonitor.Exit(TObject(R));
        end;
      except
        on E: Exception do
        begin
          FAsychProc(nil, E);
        end;
      end;
    end);
  th.Start;
end;

function TRESTClient.doGET(AResource: string; AResourceParams: array of string)
  : IRESTResponse;
var
  url: string;
begin
  url := 'http://' + FServerName + ':' + inttostr(FServerPort) + AResource +
    EncodeResourceParams(AResourceParams) + EncodeQueryStringParams
    (FQueryStringParams);

  if FNextRequestIsAsynch then
  begin
    Result := nil;
    StartAsynchRequest(httpGET, url);
  end
  else
  begin
    Result := SendHTTPCommand(httpGET, FAccept, FContentType, url, nil);
    ClearAllParams;
  end;
end;

function TRESTClient.doPOST(AResource: string; AResourceParams: array of string)
  : IRESTResponse;
var
  s: string;
begin
  try
    Result := SendHTTPCommand(httpPOST, FAccept, FContentType,
      'http://' + FServerName + ':' + inttostr(FServerPort) + AResource +
      EncodeResourceParams(AResourceParams) + EncodeQueryStringParams
      (FQueryStringParams), FBodyParams);
  except
    on E: EIdHTTPProtocolException do
    begin
      s := E.Message;
    end;
  end;
  ClearAllParams;
end;

function TRESTClient.doPOST(AResource: string; AResourceParams: array of string;
  AJSONValue: TJSONValue; AOwnsJSONBody: Boolean): IRESTResponse;
var
  url: string;
begin
  url := 'http://' + FServerName + ':' + inttostr(FServerPort) + AResource +
    EncodeResourceParams(AResourceParams) + EncodeQueryStringParams
    (FQueryStringParams);

  if FNextRequestIsAsynch then
  begin
    Result := nil;
    StartAsynchRequestJSONBody(httpPOST, url, AJSONValue, AOwnsJSONBody);
  end
  else
  begin
    try
      Result := SendHTTPCommandJSONBody(httpPOST, FAccept, FContentType, url,
        AJSONValue);
      ClearAllParams;
    finally
      if AOwnsJSONBody then
        FreeAndNil(AJSONValue);
    end;
  end;
end;

function TRESTClient.doPUT(AResource: string; AResourceParams: array of string;
  AJSONValue: TJSONValue; AOwnsJSONBody: Boolean = true): IRESTResponse;
var
  url: string;
begin
  url := 'http://' + FServerName + ':' + inttostr(FServerPort) + AResource +
    EncodeResourceParams(AResourceParams) + EncodeQueryStringParams
    (FQueryStringParams);

  if FNextRequestIsAsynch then
  begin
    Result := nil;
    StartAsynchRequestJSONBody(httpPUT, url, AJSONValue, AOwnsJSONBody);
  end
  else
  begin
    try
      Result := SendHTTPCommandJSONBody(httpPUT, FAccept, FContentType, url,
        AJSONValue);
      ClearAllParams;
    finally
      if AOwnsJSONBody then
        FreeAndNil(AJSONValue);
    end;
  end;
end;

function TRESTClient.doPUT(AResource: string; AResourceParams: array of string)
  : IRESTResponse;
begin
  Result := SendHTTPCommand(httpPUT, FAccept, FContentType,
    'http://' + FServerName + ':' + inttostr(FServerPort) + AResource +
    EncodeResourceParams(AResourceParams) + EncodeQueryStringParams
    (FQueryStringParams), FBodyParams);
  ClearAllParams;
end;

function TRESTClient.EncodeResourceParams(AResourceParams
  : array of string): string;
var
  i: Integer;
begin
  Result := '';
  for i := low(AResourceParams) to high(AResourceParams) do
    Result := Result + '/' + TIdURI.ParamsEncode(AResourceParams[i]);
end;

function TRESTClient.GetBodyParams: TStringlist;
begin
  if not Assigned(FBodyParams) then
    FBodyParams := TStringlist.Create;
  Result := FBodyParams;
end;

function TRESTClient.GetConnectionTimeout: Integer;
begin
  Result := FHTTP.ConnectTimeout;
end;

function TRESTClient.GetMultipartFormData: TIdMultiPartFormDataStream;
begin
  if not Assigned(FMultiPartFormData) then
    FMultiPartFormData := TIdMultiPartFormDataStream.Create;
  Result := FMultiPartFormData;
end;

function TRESTClient.GetQueryStringParams: TStringlist;
begin
  if not Assigned(FQueryStringParams) then
    FQueryStringParams := TStringlist.Create;
  Result := FQueryStringParams;
end;

function TRESTClient.GetRawBody: TStringStream;
begin
  if not Assigned(FRawBody) then
    FRawBody := TStringStream.Create('');
  Result := FRawBody;
end;

function TRESTClient.GetSessionID: string;
begin
  Result := Self.FLastSessionID;
end;

function TRESTClient.GetReadTimeout: Integer;
begin
  Result := FHTTP.ReadTimeout;
end;

function TRESTClient.EncodeQueryStringParams(const AQueryStringParams: TStrings;
  IncludeQuestionMark: Boolean = true): string;
var
  i: Integer;
begin
  Result := '';
  if not Assigned(AQueryStringParams) or (AQueryStringParams.Count = 0) then
    Exit;
  if IncludeQuestionMark then
    Result := '?';

  for i := 0 to AQueryStringParams.Count - 1 do
  begin
    if i > 0 then
      Result := Result + '&';
    Result := Result + AQueryStringParams.Names[i] + '=' +
      TIdURI.ParamsEncode(AQueryStringParams.ValueFromIndex[i]);
  end;
end;

procedure TRESTClient.HandleCookies;
var
  s  : string;
  arr: TArray<string>;
begin
  // Log('Received cookies', FHTTP.Response.RawHeaders.Text);
  for s in FHTTP.Response.RawHeaders do
  begin
    if s.StartsWith('Set-Cookie', true) then
    begin
      arr := s.Split([':'], 2);
      if arr[1].trim.StartsWith('dtsessionid') then
      begin
        arr := arr[1].Split(['='], 2);
        FLastSessionID := TIdURI.URLDecode(arr[1].Split([';'])[0]);
      end;
      Break;
    end;
  end;
end;

procedure TRESTClient.HandleRequestCookies;
var
  i: Integer;
begin
  if Assigned(FHTTP.CookieManager) then
    FHTTP.CookieManager.CookieCollection.Clear;
  if not FLastSessionID.trim.IsEmpty then
    FHTTP.Request.CustomHeaders.AddValue('Cookie',
      'dtsessionid=' + FLastSessionID);

  for i := 0 to FRequestHeaders.Count - 1 do
  begin
    FHTTP.Request.CustomHeaders.AddValue(FRequestHeaders.Names[i],
      FRequestHeaders.ValueFromIndex[i]);
  end;
end;

function TRESTClient.HttpCommandToString(const AHttpCommand
  : THttpCommand): string;
begin
  case AHttpCommand of
    httpGET:
      Result := 'GET';
    httpPOST:
      Result := 'POST';
    httpPUT:
      Result := 'PUT';
    httpDELETE:
      Result := 'DELETE';
    else
      raise Exception.Create('Unknown HttpCommand in TRSF.HttpCommandToString');
  end;
end;

function TRESTClient.ResetSession: TRESTClient;
begin
  SessionID := '';
  if Assigned(FHTTP.CookieManager) then
    FHTTP.CookieManager.CookieCollection.Clear;
  FHTTP.Request.RawHeaders.Clear;
  Result := Self;
end;

function TRESTClient.SendHTTPCommand(const ACommand: THttpCommand;
  const AAccept, AContentType, AUrl: string; ABodyParams: TStrings)
  : IRESTResponse;
var
  mp: TIdMultiPartFormDataStream;
begin
  Result := TRESTResponse.Create;
  FHTTP.Request.RawHeaders.Clear;
  FHTTP.Request.CustomHeaders.Clear;
  FHTTP.Request.Accept := AAccept;
  FHTTP.Request.ContentType := AContentType;
  HandleRequestCookies;
  try
    case ACommand of
      httpGET:
        begin
          Result.Body.Position := 0;
          FHTTP.Get(AUrl, Result.Body);
        end;

      httpPOST:
        begin
          if GetMultipartFormData.Size = 0 then
          begin
            Result.Body.Position := 0;
            GetRawBody; // creates the body
            FHTTP.Post(AUrl, FRawBody, Result.Body);
          end
          else
          begin
            FHTTP.Post(AUrl, GetMultipartFormData, Result.Body);
            GetMultipartFormData.Clear;
          end;
        end;

      httpPUT:
        begin
          if GetMultipartFormData.Size <> 0 then { TODO -oDaniele -cGeneral : Rework please!!! }
            raise Exception.Create('Only POST can Send Files');
          Result.Body.Position := 0;
          if Assigned(ABodyParams) and (ABodyParams.Count > 0) then
          begin
            GetRawBody.Size := 0;
            GetRawBody.WriteString(EncodeQueryStringParams(ABodyParams, False));
          end;
          FHTTP.Put(AUrl, FRawBody, Result.Body);
        end;

      httpDELETE:
        begin
          Result.Body.Position := 0;
          FHTTP.Delete(AUrl);
          GetRawBody.Size := 0;
        end;
    end;
  except
    on E: EIdHTTPProtocolException do
    begin
      Result.Body.WriteString(E.ErrorMessage);
    end;
  end;
  HandleCookies;
  Result.SetResponseCode(FHTTP.Response.ResponseCode);
  Result.SetResponseText(FHTTP.Response.ResponseText);
  Result.SetHeaders(FHTTP.Response.RawHeaders);
end;

function TRESTClient.SendHTTPCommandJSONBody(const ACommand: THttpCommand;
  const AAccept, AContentType, AUrl: string; AJSONValue: TJSONValue)
  : IRESTResponse;
begin
  Result := TRESTResponse.Create;
  FHTTP.Request.RawHeaders.Clear;
  FHTTP.Request.CustomHeaders.Clear;
  FHTTP.Request.Accept := AAccept;
  FHTTP.Request.ContentType := AContentType;
  HandleRequestCookies;
  try
    case ACommand of
      httpGET:
        begin
          FHTTP.Get(AUrl, Result.Body);
        end;

      httpPOST:
        begin
          if GetMultipartFormData.Size <> 0 then
            raise Exception.Create('This method cannot send files');

          RawBody.Position := 0;
          if Assigned(AJSONValue) then
          begin
            FRawBody.Size := 0;
            FRawBody.WriteString(UTF8Encode(AJSONValue.ToString));
          end;
          FHTTP.Post(AUrl, FRawBody, Result.Body);
        end;

      httpPUT:
        begin
          RawBody.Position := 0;
          if Assigned(AJSONValue) then
          begin
            FRawBody.Size := 0;
            FRawBody.WriteString(UTF8Encode(AJSONValue.ToString));
          end;
          FHTTP.Put(AUrl, FRawBody, Result.Body);
        end;

      httpDELETE:
        begin
          FHTTP.Delete(AUrl);
          RawBody.Size := 0;
        end;
    end;
  except
    on E: EIdHTTPProtocolException do
    begin
      Result.Body.WriteString(E.ErrorMessage);
    end;
  end;
  HandleCookies;
  Result.SetResponseCode(FHTTP.Response.ResponseCode);
  Result.SetResponseText(FHTTP.Response.ResponseText);
  Result.SetHeaders(FHTTP.Response.RawHeaders);

end;

procedure TRESTClient.SetAccept(const Value: string);
begin
  FAccept := Value;
end;

procedure TRESTClient.SetBodyParams(const Value: TStringlist);
begin
  FBodyParams := Value;
end;

procedure TRESTClient.SetConnectionTimeout(const Value: Integer);
begin
  FHTTP.ConnectTimeout := Value;
end;

procedure TRESTClient.SetContentType(const Value: string);
begin
  FContentType := Value;
end;

procedure TRESTClient.SetQueryStringParams(const Value: TStringlist);
begin
  FQueryStringParams := Value;
end;

procedure TRESTClient.SetSessionID(const Value: string);
begin
  FLastSessionID := Value;
  if Assigned(FHTTP.CookieManager) then
    FHTTP.CookieManager.CookieCollection.Clear;
end;

procedure TRESTClient.SetReadTimeout(const Value: Integer);
begin
  FHTTP.ReadTimeout := Value;
end;

procedure TRESTClient.SetRequestHeaders(const Value: TStringlist);
begin
  FRequestHeaders.Assign(Value);
end;

{ TRESTResponse }

function TRESTResponse.Body: TStringStream;
begin
  Result := FBody;
end;

function TRESTResponse.BodyAsJsonObject: TJSONObject;
var
  V: TJSONValue;
begin
  try
    if not Assigned(FBodyAsJSONObject) then
    begin
      if BodyAsString = '' then
        FBodyAsJSONObject := nil
      else
      begin
        try
          V := TJSONObject.ParseJSONValue(BodyAsString);
          if Assigned(V) then
            FBodyAsJSONObject := V as TJSONObject;
        except
          FBodyAsJSONObject := nil;
        end;
      end;
    end;
    Result := FBodyAsJSONObject;
  except
    on E: Exception do
    begin
      raise;
    end;
  end;
end;

function TRESTResponse.BodyAsString: string;
var
  ss: TStringStream;
begin
  ss := TStringStream.Create('');
  try
    FBody.Position := 0;
    FBody.SaveToStream(ss);
    Result := ss.DataString;
  finally
    ss.Free;
  end;
end;

constructor TRESTResponse.Create;
begin
  inherited;
  FHeaders := TStringlist.Create;
  FBody := TStringStream.Create('', TEncoding.UTF8);
  FBodyAsJSONObject := nil;
end;

destructor TRESTResponse.Destroy;
begin
  FreeAndNil(FBodyAsJSONObject);
  FHeaders.Free;
  FBody.Free;
  inherited;
end;

function TRESTResponse.Headers: TStringlist;
begin
  Result := FHeaders;
end;

function TRESTResponse.ResponseCode: Word;
begin
  Result := FResponseCode;
end;

function TRESTResponse.ResponseText: string;
begin
  Result := FResponseText;
end;

procedure TRESTResponse.SetHeaders(AHeaders: TStrings);
begin
  FHeaders.Assign(AHeaders);
end;

procedure TRESTResponse.SetResponseCode(AResponseCode: Word);
begin
  FResponseCode := AResponseCode;
end;

procedure TRESTResponse.SetResponseText(AResponseText: string);
begin
  FResponseText := AResponseText;
end;

end.