unit XData.Web.Connection;

{$I XData.inc}
{$IF PAS2JS_FULLVERSION >= 20000}
  {$DEFINE JSASYNC}
{$ENDIF}

interface

uses
  Types, Classes, SysUtils, Web, JS,
  XData.Web.Request, XData.Web.Response,
  XData.Model.Classes;

type
  TXDataWebConnection = class;
  TXDataWebConnectionDesignData = class;

// Later refactor this to THttpEngine + THttpClient
  THttpResponseProc = reference to procedure(Response: IHttpResponse);
  THttpErrorProc = reference to procedure;
  THttpRequestProc = reference to procedure(Request: IHttpRequest);

  TXDataWebConnectionRequest = class
  strict private
    FRequest: IHttpRequest;
    FConnection: TXDataWebConnection;
    FRequestProc: THttpRequestProc;
    FAsync: Boolean;
  strict protected
    property Connection: TXDataWebConnection read FConnection;
  public
    constructor Create(AConnection: TXDataWebConnection; ARequest: IHttpRequest); reintroduce;
    property Request: IHttpRequest read FRequest;
    property RequestProc: THttpRequestProc read FRequestProc write FRequestProc;
    property Async: Boolean read FAsync write FAsync;
  end;

  TXDataWebConnectionResponse = class
  strict private
    FRequest: IHttpRequest;
    FResponse: IHttpResponse;
    FConnection: TXDataWebConnection;
    FSuccessProc: THttpResponseProc;
    FAsync: Boolean;
  strict protected
    property Connection: TXDataWebConnection read FConnection;
  public
    constructor Create(AConnection: TXDataWebConnection; ARequest: IHttpRequest;
      AResponse: IHttpResponse); reintroduce;
    property Request: IHttpRequest read FRequest;
    property Response: IHttpResponse read FResponse write FResponse;
    property SuccessProc: THttpResponseProc read FSuccessProc write FSuccessProc;
    property Async: Boolean read FAsync write FAsync;
  end;

  TXDataWebConnectionError = class
  strict private
    FResponse: IHttpResponse;
    FConnection: TXDataWebConnection;
    FErrorMessage: string;
    FRequestUrl: string;
  strict protected
    property Connection: TXDataWebConnection read FConnection;
  public
    constructor Create(AConnection: TXDataWebConnection; AResponse: IHttpResponse;
      ARequestUrl: string; AErrorMessage: string); reintroduce;
    property Response: IHttpResponse read FResponse;
    property ErrorMessage: string read FErrorMessage;
    property RequestUrl: string read FRequestUrl;
  end;

  EXDataWebConnectionException = class(Exception)
  strict private
    FError: TXDataWebConnectionError;
  public
    constructor Create(AError: TXDataWebConnectionError);
    property Error: TXDataWebConnectionError read FError;
  end;

  TXDataWebConnectionRequestEvent = procedure(Args: TXDataWebConnectionRequest) of object;
  TXDataWebConnectionResponseEvent = procedure(Args: TXDataWebConnectionResponse) of object;
  TXDataWebConnectionErrorEvent = procedure(Error: TXDataWebConnectionError) of object;
  TXDataWebConnectionErrorProc = reference to procedure(Error: TXDataWebConnectionError);
  TXDataWebConnectionConnectProc = reference to procedure;

  TXDataWebConnection = class(TComponent)
  private
    FURL: string;
    FModel: TXDataModel;
    FOnConnect: TNotifyEvent;
    FStreamedConnected: Boolean;
    FOnRequest: TXDataWebConnectionRequestEvent;
    FOnResponse: TXDataWebConnectionResponseEvent;
    FOnError: TXDataWebConnectionErrorEvent;
    FDesignData: TXDataWebConnectionDesignData;
    function GetConnected: Boolean;
    procedure SetConnected(const Value: Boolean);
    function IsDesignDataStored: Boolean;
    procedure SetDesignData(const Value: TXDataWebConnectionDesignData);
    procedure DoError(Response: IHttpResponse; RequestUrl: string; ErrorMessage: string;
      ErrorProc: TXDataWebConnectionErrorProc);
    procedure SetURL(const Value: string);
  protected
    procedure DoConnect(ConnectProc: TXDataWebConnectionConnectProc;
      ErrorProc: TXDataWebConnectionErrorProc); virtual;
    procedure DoDisconnect; virtual;
  public
    procedure LoadModel; deprecated;
    procedure SendRequest(Request: IHttpRequest; SuccessProc: THttpResponseProc; ErrorProc: THttpErrorProc = nil);
    {$IFDEF JSASYNC}
    function SendRequestAsync(Request: IHttpRequest): IHttpResponse; async;
    {$ENDIF}
    function AbsoluteUrl(const RelativeUrl: string): string;
    property Model: TXDataModel read FModel;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Open(ConnectProc: TXDataWebConnectionConnectProc = nil; ErrorProc: TXDataWebConnectionErrorProc = nil);
    {$IFDEF JSASYNC}
    function OpenAsync: JSValue; async;
    {$ENDIF}
    procedure Close;
    procedure Loaded; override;
  published
    property URL: string read FURL write SetURL;
    property DesignData: TXDataWebConnectionDesignData read FDesignData write SetDesignData stored IsDesignDataStored;
    property Connected: Boolean read GetConnected write SetConnected default False;
    property OnConnect: TNotifyEvent read FOnConnect write FOnConnect;
    property OnError: TXDataWebConnectionErrorEvent read FOnError write FOnError;
    property OnRequest: TXDataWebConnectionRequestEvent read FOnRequest write FOnRequest;
    property OnResponse: TXDataWebConnectionResponseEvent read FOnResponse write FOnResponse;
  end;

  TXDataWebConnectionDesignData = class(TPersistent)
  private
    FHeaders: TStrings;
    FPersist: Boolean;
    function IsStored: Boolean;
    procedure SetHeaders(const Value: TStrings);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property Headers: TStrings read FHeaders write SetHeaders stored IsStored;
    property Persist: Boolean read FPersist write FPersist stored IsStored;
  end;

implementation

uses
  Bcl.Utils,
  XData.Model.Deserializer;

procedure InternalSendRequest(Req: IHttpRequest; SuccessProc: THttpResponseProc;
  ErrorProc: THttpErrorProc = nil);
var
  Xhr: TJSXmlHttpRequest;

  procedure XhrLoad;
  var
    Resp: IHttpResponse;
  begin
    Resp := TXhrHttpResponse.Create(Xhr);
    if Assigned(SuccessProc) then
      SuccessProc(Resp);
  end;

  procedure XhrError;
  begin
    if Assigned(ErrorProc) then
      ErrorProc();
  end;

var
  HeaderNames: TStringDynArray;
  I: Integer;
begin
  Xhr := TJSXMLHttpRequest.new;
  Xhr.open(Req.Method, Req.Uri, True);
  HeaderNames := Req.Headers.HeaderNames;
  for I := 0 to Length(HeaderNames) - 1 do
    Xhr.setRequestHeader(HeaderNames[I], Req.Headers.Get(HeaderNames[I]));

  Xhr.addEventListener('load', @XhrLoad);
  Xhr.addEventListener('error', @XhrError);
  Xhr.addEventListener('timeout', @XhrError);
  if Req.Timeout > 0 then
    Xhr.timeout := Req.Timeout;
  if not Js.IsNull(Req.Content) then
    Xhr.send(Req.Content)
  else
    Xhr.send;
end;

//{$IFDEF JSASYNC}
//function InternalSendRequestAsync(Req: IHttpRequest): IHttpResponse; async;
//var
//  Promise: TJSPromise;
//begin
//  Promise := TJSPromise.new(
//    procedure(resolve, reject: TJSPromiseResolver)
//    begin
//      InternalSendRequest(
//        Req,
//        procedure(Response: IHttpResponse)
//        begin
//          resolve(Response);
//        end,
//        procedure
//        begin
//          reject(Exception.Create('Request error: ' + Req.Uri));
//        end
//      );
//    end
//  );
//  Exit(Promise);
//end;
//{$ENDIF}

{ TXDataWebConnection }

function TXDataWebConnection.AbsoluteUrl(const RelativeUrl: string): string;
begin
  Result := TBclUtils.CombineUrlFast(Self.URL, RelativeUrl);
end;

procedure TXDataWebConnection.Close;
begin
  SetConnected(False);
end;

constructor TXDataWebConnection.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDesignData := TXDataWebConnectionDesignData.Create;
end;

destructor TXDataWebConnection.Destroy;
begin
  FDesignData.Free;
  FModel.Free;
  inherited;
end;

procedure TXDataWebConnection.DoConnect(ConnectProc: TXDataWebConnectionConnectProc = nil;
  ErrorProc: TXDataWebConnectionErrorProc = nil);
var
  ModelUrl: string;

  procedure OnSuccess(Resp: IHttpResponse);
  var
    LocalModel: TXDataModel;
  begin
    if Resp.StatusCode = 200 then
    begin
      LocalModel := TXDataModel.Create;
      try
        TXDataModelDeserializer.Deserialize(LocalModel, Resp.ContentAsText);
        FModel := LocalModel;
      except
        LocalModel.Free;
        raise;
      end;

      // Connect callback
      if Assigned(ConnectProc) then
        ConnectProc()
      else
      if Assigned(FOnConnect) then
        FOnConnect(Self);
    end
    else
      DoError(Resp, ModelUrl,
        Format('Error %d. Could not connect retrieve XData model from %s', [Resp.StatusCode, ModelUrl]),
        ErrorProc
      );
  end;

  procedure LocalError;
  var
    Resp: IHttpResponse;
  begin
    Resp := TDummyHttpResponse.Create;
    DoError(Resp, ModelUrl, 'Error connecting to XData server', ErrorProc);
  end;

var
  Req: IHttpRequest;
  I: Integer;
begin
  // DoDisconnect
  FModel.Free;
  FModel := nil;

  ModelUrl := TBclUtils.CombineUrlFast(Self.URL, '$model');

  Req := THttpRequest.Create(ModelUrl);
  for I := 0 to DesignData.Headers.Count - 1 do
    if DesignData.Headers.Names[I] <> '' then
      Req.Headers.SetValue(DesignData.Headers.Names[I], DesignData.Headers.ValueFromIndex[I]);

  SendRequest(Req, @OnSuccess, @LocalError);
end;

procedure TXDataWebConnection.DoDisconnect;
begin
  FModel.Free;
  FModel := nil;
end;

procedure TXDataWebConnection.DoError(Response: IHttpResponse;
  RequestUrl: string; ErrorMessage: string; ErrorProc: TXDataWebConnectionErrorProc);
var
  Error: TXDataWebConnectionError;
begin
  Error := TXDataWebConnectionError.Create(Self, Response, RequestUrl, ErrorMessage);
  if Assigned(ErrorProc) then
    ErrorProc(Error)
  else
  if Assigned(FOnError) then
    FOnError(Error)
  else
    raise Exception.Create('XDataConnectionError: ' + ErrorMessage);
end;

function TXDataWebConnection.GetConnected: Boolean;
begin
  Result := Assigned(FModel);
end;

function TXDataWebConnection.IsDesignDataStored: Boolean;
begin
  Result := FDesignData.Persist;
end;

procedure TXDataWebConnection.Loaded;
begin
  inherited Loaded;
  if FStreamedConnected then SetConnected(True);
end;

procedure TXDataWebConnection.LoadModel;
begin
  DoConnect(nil, nil);
end;

procedure TXDataWebConnection.Open(ConnectProc: TXDataWebConnectionConnectProc = nil; ErrorProc: TXDataWebConnectionErrorProc = nil);
begin
  if not Connected then
    DoConnect(ConnectProc, ErrorProc);
end;

{$IFDEF JSASYNC}
function TXDataWebConnection.OpenAsync: JSValue; async;
begin
  Result := TJSPromise.new(
    procedure(resolve, reject: TJSPromiseResolver)
    begin
      DoConnect(
        procedure
        begin
          if Assigned(FOnConnect) then
            FOnConnect(Self);
          resolve(nil);
        end,
        procedure(Error: TXDataWebConnectionError)
        begin
          reject(EXDataWebConnectionException.Create(Error));
        end
      );
    end
  );
end;
{$ENDIF}

procedure TXDataWebConnection.SendRequest(Request: IHttpRequest;
  SuccessProc: THttpResponseProc; ErrorProc: THttpErrorProc);

  procedure LocalSuccess(Response: IHttpResponse);
  var
    ResponseArgs: TXDataWebConnectionResponse;
    Async: Boolean;
  begin
    Async := False;
    if Assigned(FOnResponse) then
    begin
      ResponseArgs := TXDataWebConnectionResponse.Create(Self, Request, Response);
      try
        ResponseArgs.SuccessProc :=
          procedure(Response: IHttpResponse)
          begin
            SuccessProc(Response);
          end;
        FOnResponse(ResponseArgs);
        Async := ResponseArgs.Async;
        if not Async then
          Response := ResponseArgs.Response;
      finally
        if not Async then
          ResponseArgs.Free;
      end;
    end;
    if not Async then
      SuccessProc(Response);
  end;

var
  RequestArgs: TXDataWebConnectionRequest;
  Async: Boolean;
begin
  Async := False;

  if Assigned(FOnRequest) then
  begin
    RequestArgs := TXDataWebConnectionRequest.Create(Self, Request);
    try
      RequestArgs.RequestProc :=
        procedure(Request: IHttpRequest)
        begin
          InternalSendRequest(Request, @LocalSuccess, ErrorProc);
        end;
      FOnRequest(RequestArgs);
      Async := RequestArgs.Async;
    finally
      if not Async then
        RequestArgs.Free;
    end;
  end;
  if not Async then
    InternalSendRequest(Request, @LocalSuccess, ErrorProc);
end;

{$IFDEF JSASYNC}
function TXDataWebConnection.SendRequestAsync(
  Request: IHttpRequest): IHttpResponse;
var
  Promise: TJSPromise;
begin
  Promise := TJSPromise.new(
    procedure(resolve, reject: TJSPromiseResolver)
    begin
      SendRequest(
        Request,
        procedure(Response: IHttpResponse)
        begin
          resolve(Response);
        end,
        procedure
        begin
          reject(Exception.Create('Request error: ' + Request.Uri));
        end
      );
    end
  );
  Exit(Promise);
end;
{$ENDIF}

procedure TXDataWebConnection.SetConnected(const Value: Boolean);
begin
  if (csLoading in ComponentState) and Value then
    FStreamedConnected := True else
  begin
    if Value = GetConnected then Exit;
    if Value then
    begin
      DoConnect(nil, nil);
    end else
    begin
      DoDisconnect;
    end;
  end;
end;

procedure TXDataWebConnection.SetDesignData(
  const Value: TXDataWebConnectionDesignData);
begin
  FDesignData.Assign(Value);
end;

procedure TXDataWebConnection.SetURL(const Value: string);
begin
  if FURL <> Value then
  begin
    FUrl := Value;
    DoDisconnect;
  end;
end;

{ TXDataWebConnectionRequest }

constructor TXDataWebConnectionRequest.Create(AConnection: TXDataWebConnection;
  ARequest: IHttpRequest);
begin
  FConnection := AConnection;
  FRequest := ARequest;
end;

{ TXDataWebConnectionError }

constructor TXDataWebConnectionError.Create(AConnection: TXDataWebConnection;
  AResponse: IHttpResponse; ARequestUrl: string; AErrorMessage: string);
begin
  FConnection := AConnection;
  FResponse := AResponse;
  FErrorMessage := AErrorMessage;
  FRequestUrl := ARequestUrl;
end;

{ TXDataWebConnectionDesignData }

procedure TXDataWebConnectionDesignData.Assign(Source: TPersistent);
begin
  if Source is TXDataWebConnectionDesignData then
  begin
    Persist := TXDataWebConnectionDesignData(Source).Persist;
    Headers := TXDataWebConnectionDesignData(Source).Headers;
  end
  else
    inherited Assign(Source);
end;

constructor TXDataWebConnectionDesignData.Create;
begin
  inherited Create;
  FHeaders := TStringList.Create;
end;

destructor TXDataWebConnectionDesignData.Destroy;
begin
  FHeaders.Free;
  inherited;
end;

function TXDataWebConnectionDesignData.IsStored: Boolean;
begin
  Result := FPersist;
end;

procedure TXDataWebConnectionDesignData.SetHeaders(const Value: TStrings);
begin
  FHeaders.Assign(Value);
end;

{ TXDataWebConnectionResponse }

constructor TXDataWebConnectionResponse.Create(AConnection: TXDataWebConnection;
  ARequest: IHttpRequest; AResponse: IHttpResponse);
begin
  FConnection := AConnection;
  FRequest := ARequest;
  FResponse := AResponse;
end;

{ EXDataWebConnectionException }

constructor EXDataWebConnectionException.Create(
  AError: TXDataWebConnectionError);
begin
  FError := AError;
  inherited CreateFmt('Error connecting to %s', [AError.RequestUrl]);
end;

end.
