* JSON-RPC using Invoke

packages/fcl-web/examples/jsonrpc/rtti/README.md

@@ -0,0 +1,10 @@
+# JSON-RPC demo
+
+The rttirpc.lpg project group allows you to comppile the 3 programs:
+
+* **demorpcrtti.lpi** The RPC server. This project must be compiled and run
+  before the other 2 (client) projects can be run.
+
+* **jsonrpcclient.lpi** A bare-bones client.
+
+* **rpcclient.lpi** A client using the TFPRPCClient class.

packages/fcl-web/examples/jsonrpc/rtti/demorpcrtti.lpr

@@ -0,0 +1,17 @@
+program demorpcrtti;
+
+{$mode objfpc}{$H+}
+{$if not defined(CPU386) and not defined(WIN64)}
+{$define useffi}
+{$endif}
+
+uses
+  fphttpapp, rpcapi, dmRPC {$ifdef useffi}, ffi.manager	{$endif}, myapi;
+
+begin
+  Application.Title:='FPC JSON-RPC using RTTI';
+  Application.Port:=8080;
+  Application.Initialize;
+  Application.Run;
+end.
+

packages/fcl-web/examples/jsonrpc/rtti/dmrpc.lfm

@@ -0,0 +1,14 @@
+object RPCModule: TRPCModule
+  OldCreateOrder = False
+  DispatchOptions = [jdoSearchRegistry, jdoSearchOwner, jdoJSONRPC1, jdoJSONRPC2, jdoRequireClass, jdoNotifications, jdoAllowAPI, jdoCacheAPI]
+  CORS.Enabled = False
+  CORS.Options = [coAllowCredentials, coEmptyDomainToOrigin]
+  CORS.AllowedMethods = 'GET, PUT, POST, OPTIONS, HEAD'
+  CORS.AllowedOrigins = '*'
+  CORS.AllowedHeaders = 'x-requested-with, content-type, authorization'
+  CORS.MaxAge = 0
+  Height = 150
+  HorizontalOffset = 509
+  VerticalOffset = 204
+  Width = 150
+end

packages/fcl-web/examples/jsonrpc/rtti/dmrpc.pp

@@ -0,0 +1,28 @@
+unit dmRPC;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, HTTPDefs, websession, jsonparser, fpHTTP, fpWeb, fpjsonrpc, webjsonrpc;
+
+type
+  TRPCModule = class(TJSONRPCModule)
+  private
+
+  public
+
+  end;
+
+var
+  RPCModule: TRPCModule;
+
+implementation
+
+{$R *.lfm}
+
+initialization
+  TRPCModule.RegisterModule('RPC');
+end.
+

packages/fcl-web/examples/jsonrpc/rtti/jsonrpcclient.pp

@@ -0,0 +1,186 @@
+program jsonrpcclient;
+
+{$mode objfpc}{$H+}
+
+{$if not defined(CPU386) and not defined(WIN64)}
+{$define useffi}
+{$endif}
+
+uses
+  SysUtils, Classes, fpjson, jsonparser, jsonscanner, fphttpclient, 
+  rtti, typinfo {$ifdef useffi}, ffi.manager{$endif}, myapi, fpjsonvalue;
+
+type
+  TJsonRpcClient = class(TVirtualInterface)
+  private
+    class var
+    aID : Integer;
+  private
+    fName: String;
+    fBaseUrl: String;
+    procedure HandleInvoke(aMethod: TRttiMethod; const aArgs: TValueArray; out
+      aResult: TValue);
+
+    function DoRequest(aRequest: TJSONData): TJSONData;
+  public
+    constructor Create(aTypeInfo: PTypeInfo; const aBaseUrl: String);
+
+    generic class function GetClientIntf<T: IInterface>(const aBaseUrl: String): T;
+  end;
+
+
+procedure TJsonRpcClient.HandleInvoke(aMethod: TRttiMethod;
+  const aArgs: TValueArray; out aResult: TValue);
+var
+  request, response: TJSONObject;
+  args: specialize TArray<TRttiParameter>;
+  arg: TRttiParameter;
+  varParamCount, argidx, i: LongInt;
+  resobj,argobj: TJSONObject;
+  value: TValue;
+  
+  
+begin
+  VarParamCount:=0;
+  request := TJSONObject.Create;
+  try
+    request.Add('method', aMethod.Name);
+    request.Add('classname', fName);
+    request.Add('jsonrpc','2.0');
+    inc(aID);
+    request.Add('id',aID);
+    { skip Self argument }
+    argidx := 1;
+    argobj := TJSONObject.Create;
+    args := aMethod.GetParameters;
+    for i := 0 to High(args) do begin
+      arg := args[i];
+      if [pfHidden,pfSelf] * arg.Flags <> [] then
+        Continue
+      else if ([pfVar,pfOut] * arg.Flags)<>[] then
+        Inc(VarParamCount);
+      argobj.Add(arg.Name, ValueToJSON(aArgs[argidx], arg.ParamType));
+      Inc(argidx);
+    end;
+    request.Add('params', argobj);
+    aResult:=Default(TValue);
+    response := DoRequest(request) as TJSONObject;
+    try
+      if (VarParamCount=0) then
+        begin    
+        if Assigned(aMethod.ReturnType) then
+          aResult := JSONToValue(response.Elements['result'], aMethod.ReturnType);
+        end
+      else
+        begin  
+        resObj:=response.Objects['result'];
+        if Assigned(aMethod.ReturnType) then
+          aResult := JSONToValue(resObj.Elements['$result'], aMethod.ReturnType);
+        argidx := 1;
+        for i := 0 to High(args) do 
+          begin
+          arg := args[i];
+          if pfHidden in arg.Flags then
+            Continue;
+          if arg.Flags * [pfOut, pfVar] = [] then 
+            begin
+            Inc(argidx);
+            Continue;
+            end;
+          value := JSONToValue(resObj.Elements[arg.Name], arg.ParamType);
+          value.ExtractRawData(aArgs[argidx].GetReferenceToRawData);
+          Inc(argidx);
+          end; 
+      end;
+    finally
+      response.Free;
+    end;
+  finally
+    request.Free;
+  end;
+end;
+
+function TJsonRpcClient.DoRequest(aRequest: TJSONData): TJSONData;
+var
+  client: TFPHTTPClient;
+  ss: TStringStream;
+  parser: TJSONParser;
+  resp: String;
+begin
+  ss := TStringStream.Create(aRequest.AsJSON);
+  try
+    client := TFPHTTPClient.Create(Nil);
+    try
+      client.RequestBody := ss;
+
+      resp := client.Post(fBaseUrl + fName);
+      Writeln('Got response:');
+      Writeln(resp);
+      //parser := TJSONParser.Create(client.Post(fBaseUrl + fName), [joUTF8]);
+      parser := TJSONParser.Create(resp, [joUTF8]);
+      try
+        Result := parser.Parse;
+      finally
+        parser.Free;
+      end;
+    finally
+      client.Free;
+    end;
+  finally
+    ss.Free;
+  end;
+end;
+
+constructor TJsonRpcClient.Create(aTypeInfo: PTypeInfo; const aBaseUrl: String);
+begin
+  inherited Create(aTypeInfo, @HandleInvoke);
+  fBaseUrl := aBaseUrl;
+  if fBaseUrl[Length(fBaseUrl)] <> '/' then
+    fBaseUrl := fBaseUrl + '/';
+  fName := aTypeInfo^.Name;
+end;
+
+generic class function TJsonRpcClient.GetClientIntf<T>(const aBaseUrl: String): T;
+var
+  client: TJsonRpcClient;
+  td: PTypeData;
+begin
+  client := TJsonRpcClient.Create(PTypeInfo(TypeInfo(T)), aBaseUrl);
+  td := GetTypeData(PTypeInfo(TypeInfo(T)));
+  client.QueryInterface(td^.GUID, Result);
+end;
+
+var
+  client: IMyInterface;
+  arr: TStringArray;
+  s: String;
+  res: Boolean;
+begin
+    client := TJsonRpcClient.specialize GetClientIntf<IMyInterface>('http://127.0.0.1:8080/RPC/');
+    try
+      Writeln('===== Testing SayHello');
+      client.SayHello;
+      Writeln('===== Testing DoSum');
+      Writeln(client.DoSum(2, 6));
+      Writeln('===== Testing Split');
+      arr := client.Split('Hello FPC World', ' ');
+      Writeln('Split data:');
+      for s in arr do
+        Writeln(#9, s);
+      Writeln('===== Testing DoVarTest');
+      s := 'Foobar';
+      res := client.DoVarTest(s);
+      Writeln(res, ' ', s);
+      s := 'Test';
+      res := client.DoVarTest(s);
+      Writeln(res, ' ', s);
+//      Writeln('===== Testing Echo');
+//      writeln(Client.Echo(['This','is','Sparta']));
+    finally
+      client := Nil;
+    end;
+  {$ifndef unix}
+  Readln;
+  {$endif}
+end.
+

packages/fcl-web/examples/jsonrpc/rtti/myapi.pp

@@ -0,0 +1,28 @@
+unit myapi;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses sysutils; // for TStringArray
+
+Type
+  { enable RTTI for methods! }
+  {$M+}
+  IMyInterface = interface ['{E4C73198-0831-47B9-944C-E2D7EFAE1C6A}']
+   procedure SayHello;
+   function Echo(args : Array of string) : String;
+   function DoSum(a,b : Integer) : integer;
+   function Split(aLine,aSep : string) : TStringArray;
+   function DoVarTest(var aArg: String): Boolean;
+  end;
+
+  IMyOtherInterface = interface ['{4D52BEE3-F709-44AC-BD31-870CBFF44632}']
+    Function SayHello : string;
+    function Echo(args : TStringArray) : String;
+  end;
+
+implementation
+
+end.
+

packages/fcl-web/examples/jsonrpc/rtti/rpcapi.pp

@@ -0,0 +1,112 @@
+unit rpcapi;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, fprpcrtti, myapi;
+
+Type
+
+  { TIntfImpl }
+
+  TIntfImpl = class(TInterfacedObject, IMyInterface)
+  public
+    procedure SayHello;
+    Function Echo(args : Array of string) : String;
+    function DoSum(a,b : Integer) : integer;
+    function Split(aLine,aSep : string) : TStringArray;
+    function DoVarTest(var aArg: String): Boolean;
+  end;
+
+  { TIntf2Impl }
+
+  TIntf2Impl = class(TInterfacedObject, IMyOtherInterface)
+
+  public
+    function Echo(args: TStringArray): String;
+    function SayHello: string;
+  end;
+
+
+Implementation
+
+{ TIntf2Impl }
+
+function TIntf2Impl.Echo(args: TStringArray): String;
+
+var
+  S : String;
+
+begin
+  Result:='';
+  For S in Args do
+    begin
+    if Result<>'' then
+      Result:=Result+' ';
+    Result:=Result+S;
+    end
+end;
+
+function TIntf2Impl.SayHello: string;
+begin
+  Result:='Hello, World!';
+end;
+
+procedure TIntfImpl.SayHello;
+begin
+  Writeln('Hello, World!');
+end;
+
+function TIntfImpl.Echo(args: array of string): String;
+
+var
+  S : String;
+
+begin
+  Result:='';
+  For S in Args do
+    begin
+    if Result<>'' then
+      Result:=Result+' ';
+    Result:=Result+S;
+    end
+end;
+
+function TIntfImpl.DoSum(a,b : Integer) : integer;
+begin
+  Result := a + b;
+end;
+
+function TIntfImpl.Split(aLine,aSep : string) : TStringArray;
+begin
+  Result := aLine.Split(aSep);
+end;
+
+function TIntfImpl.DoVarTest(var aArg: String): Boolean;
+begin
+  if aArg = 'Test' then begin
+    aArg := 'Foo';
+    Result := True;
+  end else
+    Result := False;
+end;
+
+Function GetMyInterface(Const aName : string) : IInterface;
+
+begin
+  Result:=TIntfImpl.Create as IInterface;
+end;
+
+Function GetMyOtherInterface(Const aName : string) : IInterface;
+
+begin
+  Result:=TIntf2Impl.Create as IInterface;
+end;
+
+initialization
+  RTTIJSONRPCRegistry.Add(TypeInfo(IMyInterface),@GetMyInterface);
+  RTTIJSONRPCRegistry.Add(TypeInfo(IMyOtherInterface),@GetMyOtherInterface,'Service2');
+end.
+

packages/fcl-web/examples/jsonrpc/rtti/rpcclient.lpr

@@ -0,0 +1,69 @@
+program rpcclient;
+
+{$if not defined(CPU386) and not defined(WIN64)}
+{$define useffi}
+{$endif}
+
+uses
+  sysutils, jsonparser, fprpcclient, {$ifdef useffi} ffi.manager,{$endif} myapi;
+
+
+Procedure DoTestRPC(RPC : TFPRPCClient);
+
+var
+  client: IMyInterface;
+  arr: TStringArray;
+  s: String;
+  res: Boolean;
+begin
+  client := RPC as IMyInterface;
+  Writeln('===== Testing SayHello');
+  client.SayHello;
+  Writeln('===== Testing DoSum');
+  Writeln(client.DoSum(2, 6));
+  Writeln('===== Testing Split');
+  arr := client.Split('Hello FPC World', ' ');
+  Writeln('Split data:');
+  for s in arr do
+    Writeln(#9, s);
+  Writeln('===== Testing DoVarTest');
+  s := 'Foobar';
+  res := client.DoVarTest(s);
+  Writeln(res, ' ', s);
+  s := 'Test';
+  res := client.DoVarTest(s);
+  Writeln(res, ' ', s);
+//  Writeln('===== Testing Echo');
+//  writeln(Client.Echo(['This','is','Sparta']));
+end;
+
+Procedure DoTestRPC2(RPC : TFPRPCClient);
+
+var
+  client: IMyOtherInterface;
+begin
+  Client:=RPC.Specialize CreateService<IMyotherInterface>('Service2');
+  Writeln('===== Testing SayHello');
+  Writeln('Sayhello: ',client.SayHello);
+  Writeln('===== Testing DoEcho');
+  Writeln('Sayhello: ',client.Echo(['This','is','Sparta']));
+end;
+
+var
+  aRPCClient : TFPRPCClient;
+
+begin
+  RPCServiceRegistry.Add(TypeInfo(IMyInterface));
+  RPCServiceRegistry.Add(TypeInfo(IMyOtherInterface),'Service2');
+  aRPCClient:=TFPRPCClient.Create(Nil);
+  try
+    aRPCClient.BaseURL:=ParamStr(1);
+    if (aRPCClient.BaseURL='') then
+      aRPCClient.BaseURL:='http://localhost:8080/RPC';
+    DoTestRPC(aRPCClient);
+    DoTestRPC2(aRPCClient);
+  finally
+    aRPCClient.Free;
+  end;
+end.
+

packages/fcl-web/examples/jsonrpc/rtti/rttirpc.lpg

@@ -0,0 +1,22 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectGroup FileVersion="2">
+    <Targets>
+      <Target FileName="rpcclient.lpi">
+        <BuildModes>
+          <Mode Name="Default"/>
+        </BuildModes>
+      </Target>
+      <Target FileName="demorpcrtti.lpi">
+        <BuildModes>
+          <Mode Name="Default"/>
+        </BuildModes>
+      </Target>
+      <Target FileName="jsonrpcclient.lpi">
+        <BuildModes>
+          <Mode Name="Default"/>
+        </BuildModes>
+      </Target>
+    </Targets>
+  </ProjectGroup>
+</CONFIG>

packages/fcl-web/src/jsonrpc/fprpcclient.pp

@@ -0,0 +1,508 @@
+{
+    This file is part of the Free Component Library
+
+    Client-side JSON-RPC functionality using Invoke.
+    Copyright (c) 2022 by Michael Van Canneyt [email protected]
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit fprpcclient;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  TypInfo, Classes, SysUtils, fpjson, fpwebclient, fphttpwebclient, rtti, fpjsonvalue;
+
+Type
+  ERPCClient = Class(Exception);
+  TRttiParameterArray = array of TRttiParameter;
+
+  TFPRPCClient = Class;
+
+  { TFPRPCVirtualInterface }
+
+  TFPRPCVirtualInterface = Class(TVirtualInterface)
+  private
+    FClient: TFPRPCClient;
+    FTypeInfo: PTypeInfo;
+    FClassName : String;
+  Protected
+   procedure HandleInvoke(aMethod: TRttiMethod; const aArgs: TValueArray; out aResult: TValue);
+  Public
+    Constructor Create(aTypeInfo : PTypeInfo; const aClassName : String; aClient : TFPRPCClient);
+    Property Client : TFPRPCClient Read FClient;
+    Property IntfTypeInfo : PTypeInfo Read FTypeInfo;
+  end;
+
+  { TFPRPCClient }
+  TRPCClientOption = (rcoObjectParam,rcoNotifications);
+  TRPCClientOptions = set of TRPCClientOption;
+  TFPRPCClient = Class(TComponent)
+  Private
+    FBaseURL: String;
+    FClient : TAbstractWebClient;
+    FInternalClient : TAbstractWebClient;
+    FOptions: TRPCClientOptions;
+    FRequestID : Int64;
+    function GetClient : TAbstractWebClient;
+  Protected
+    // Override so we can query for all registered types
+    function QueryInterface(constref aIID: TGuid; out aObj): LongInt;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; override;
+    // Create virtual interface. Override this if you want to return something other than TFPRPCVirtualInterface
+    function CreateVirtualInterface(IntfType: TRttiInterfaceType; aName: string): IInterface; virtual;
+    // Encode parameters to method call.
+    function EncodeParams(aMethod: TRttiMethod; const aArgs: TValueArray; out VarParamCount: Integer): TJSONData;
+    // Decode JSON-RPC result to method call result and var/out params.
+    function DecodeResult(Response: TJSONObject; aMethod: TRttiMethod; const aArgs: TValueArray; HaveReturnValues: Boolean): TValue;
+    // Find registered interfacen return instance in aObj. Return true if successful.
+    function DoCreateProxy(constref aIID: TGuid; out aObj): Boolean;
+    function DoCreateProxy(const aName: String; out aObj): Boolean;
+    // Called from TFPRPCVirtualInterface to actuall handle call.
+    procedure HandleInvoke(aClassName : String; aMethod: TRttiMethod; const aArgs: TValueArray; out aResult: TValue); virtual;
+    // Do actual HTTP request.
+    function DoRequest(aRequest : TJSONObject) : TJSONObject; virtual;
+    // Create JSON-RPC request object.
+    function CreateRPCRequest(const aClassName,aMethodName : String; IsNotification : Boolean): TJSONObject; virtual;
+    // Client to do request with. If WebClient is set, that is used. Otherwise fallback using TFPHTTPClient is used.
+    property Client : TAbstractWebClient Read GetClient;
+  Public
+    // Create a service by name. Use QueryInterface on the result to get your actual interface
+    Function CreateService(aName : string) : IInterface;
+    // Create a service by name, directly return the interface.
+    generic Function CreateService<T : IInterface>(aName : string) : T;
+    // Set this to use another webclient other than the default one.
+    Property WebClient : TAbstractWebClient Read FClient Write FClient;
+    // base URL for JSON-RPC requests
+    property BaseURL : String Read FBaseURL Write FBaseURL;
+    // Options.
+    Property Options : TRPCClientOptions Read FOptions Write FOptions;
+  end;
+
+  { TFPRPCServiceRegistry }
+
+  TFPRPCServiceRegistry = class
+  Class var
+    _instance : TFPRPCServiceRegistry;
+  Private
+    Type
+      { TIntfEntry }
+      TIntfEntry = record
+        Name: String;
+        IntfType : TRttiInterfaceType;
+      end;
+    Var
+      FContext : TRTTIContext;
+      fIntfs : Array of TIntfEntry;
+      fIntfCount : Integer;
+  Protected
+  Public
+    class var
+      SizeDelta : Integer;
+
+  Public
+    class constructor Init;
+    class destructor done;
+    constructor create; virtual;
+    procedure Add(aInterfaceInfo : PTypeInfo; const aName : string = '');
+    generic procedure Add <T : IInterface>(const aName : string = '');
+    function Find(const aName: string; out IntfType: TRttiInterfaceType): Boolean;
+    function Find(const aGUID: TGUID; out IntfType: TRttiInterfaceType; out aName : String): Boolean;
+    function Get(const aName: string) : TRttiInterfaceType;
+    function Get(const aGUID: TGUID; out aName : String) : TRttiInterfaceType;
+    class property Instance : TFPRPCServiceRegistry Read _Instance;
+  end;
+
+
+Function RPCServiceRegistry : TFPRPCServiceRegistry;
+
+Resourcestring
+  SErrUnknownServiceName = 'Unknown service name : "%s"';
+  SErrUnknownServiceGUID = 'Unknown service GUID : "%s"';
+  SErrSupportedServiceName = 'Interface does not support service: "%s"';
+  SErrExpectedReturnButNoServerReturn = 'Method "%s" expects return values, but no result was returned';
+
+implementation
+
+function IsGUIDEqual(const guid1, guid2: tguid): boolean;
+  begin
+    IsGUIDEqual:=
+      (guid1.D1=guid2.D1) and
+      (PDWORD(@guid1.D2)^=PDWORD(@guid2.D2)^) and
+      (PDWORD(@guid1.D4[0])^=PDWORD(@guid2.D4[0])^) and
+      (PDWORD(@guid1.D4[4])^=PDWORD(@guid2.D4[4])^);
+  end;
+
+
+Function RPCServiceRegistry : TFPRPCServiceRegistry;
+
+begin
+  Result:=TFPRPCServiceRegistry.Instance;
+end;
+
+{ TFPRPCVirtualInterface }
+
+procedure TFPRPCVirtualInterface.HandleInvoke(aMethod: TRttiMethod; const aArgs: TValueArray; out aResult: TValue);
+begin
+  FClient.HandleInvoke(FClassName,aMethod,aArgs,aResult);
+end;
+
+constructor TFPRPCVirtualInterface.Create(aTypeInfo: PTypeInfo; const aClassName: String; aClient: TFPRPCClient);
+begin
+  inherited Create(aTypeInfo, @HandleInvoke);
+  FTypeInfo:=aTypeInfo;
+  FClient:=aClient;
+  FClassName:=aClassName;
+end;
+
+{ TFPRPCServiceRegistry }
+
+class constructor TFPRPCServiceRegistry.Init;
+begin
+  SizeDelta:=32;
+  _Instance:=TFPRPCServiceRegistry.Create;
+end;
+
+class destructor TFPRPCServiceRegistry.done;
+begin
+  FreeAndNil(_Instance);
+end;
+
+constructor TFPRPCServiceRegistry.create;
+begin
+  SetLength(fIntfs,SizeDelta);
+  fIntfCount:=0;
+end;
+
+procedure TFPRPCServiceRegistry.Add(aInterfaceInfo: PTypeInfo; const aName: string);
+var
+  entry: TIntfEntry;
+
+begin
+  if aName='' then
+    entry.Name:=aInterfaceInfo^.Name
+  else
+    entry.Name:=aName;
+  entry.IntfType := fContext.GetType(aInterfaceInfo) as TRttiInterfaceType;
+  if fIntfCount>=Length(fIntfs) then
+    SetLength(fIntfs,Length(fIntfs)+SizeDelta);
+  fIntfs[fIntfCount]:=entry;
+  Inc(fIntfCount);
+end;
+
+function TFPRPCServiceRegistry.Find(Const aName: string; out IntfType: TRttiInterfaceType): Boolean;
+
+Var
+  Idx : integer;
+  Entry : TIntfEntry;
+
+begin
+  Result:=False;
+  Idx:=fIntfCount-1;
+  While (Idx>=0) and not Result do
+    begin
+    Result:=SameText(fIntfs[Idx].Name,aName);
+    if Result then
+      begin
+      Entry:=fIntfs[Idx];
+      IntfType:=Entry.IntfType;
+      end;
+    Dec(Idx);
+    end;
+end;
+
+function TFPRPCServiceRegistry.Find(const aGUID: TGUID; out IntfType: TRttiInterfaceType; out aName: String): Boolean;
+Var
+  Idx : integer;
+  Entry : TIntfEntry;
+
+begin
+  Result:=False;
+  Idx:=fIntfCount-1;
+  While (Idx>=0) and not Result do
+    begin
+    Result:=IsGUIDEqual(fIntfs[Idx].IntfType.GUID,aGUID);
+    if Result then
+      begin
+      Entry:=fIntfs[Idx];
+      IntfType:=Entry.IntfType;
+      aName:=Entry.Name;
+      end;
+    Dec(Idx);
+    end;
+end;
+
+
+function TFPRPCServiceRegistry.Get(Const aName: string): TRttiInterfaceType;
+begin
+  if not Find(aName,Result) then
+    Raise ERPCClient.CreateFmt(SErrUnknownServiceName ,[aName]);
+end;
+
+function TFPRPCServiceRegistry.Get(const aGUID: TGUID; out aName: String): TRttiInterfaceType;
+begin
+  if not Find(aGuid,Result,aName) then
+    raise ERPCClient.CreateFmt(SErrUnknownServiceGUID, [aGuid.ToString]);
+end;
+
+
+generic procedure TFPRPCServiceRegistry.Add <T>(const aName : string = '');
+begin
+  Add(TypeInfo(T),aName);
+end;
+
+{ TFPRPCClient }
+
+function TFPRPCClient.CreateVirtualInterface(IntfType : TRttiInterfaceType; aName: string) : IInterface;
+
+begin
+  Result:=TFPRPCVirtualInterface.Create(IntfType.Handle,aName,Self) as IInterface
+end;
+
+function TFPRPCClient.DoCreateProxy(constref aIID: TGuid; out aObj): Boolean;
+
+Var
+  IntfType : TRttiInterfaceType;
+  aName : string;
+  aIntf : IInterface;
+begin
+  Result:=RPCServiceRegistry.Find(aIID,IntfType,aName);
+  if Result then
+    begin
+    aIntf:=CreateVirtualInterface(IntfType,aName);
+    Result:=(aIntf.QueryInterface(aIID,aObj)=S_OK);
+    end;
+end;
+
+function TFPRPCClient.DoCreateProxy(const aName: String; out aObj): Boolean;
+
+Var
+  IntfType : TRttiInterfaceType;
+  aIntf : IInterface;
+begin
+  Result:=RPCServiceRegistry.Find(aName,IntfType);
+  if Result then
+    begin
+    aIntf:=CreateVirtualInterface(IntfType,aName);
+    Result:=(aIntf.QueryInterface(IntfType.GUID,aObj)=S_OK);
+    end;
+end;
+
+function TFPRPCClient.QueryInterface(constref aIID: TGuid; out aObj): LongInt;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
+
+
+begin
+  Result:=Inherited QueryInterface(aIID,aObj);
+  if (Result<>S_OK) then
+    begin
+    if DoCreateProxy(aIID,aObj) then
+      Result:=S_OK
+    else
+      Result:=E_NOINTERFACE;
+    end
+end;
+
+function TFPRPCClient.GetClient: TAbstractWebClient;
+begin
+  Result:=FClient;
+  if Result=Nil then
+    begin
+    if FInternalClient=Nil then
+      FInternalClient:=TFPHTTPWebClient.Create(Self);
+    Result:=FInternalClient;
+    end;
+end;
+
+function TFPRPCClient.CreateRPCRequest(const aClassName, aMethodName: String; IsNotification: Boolean): TJSONObject;
+
+begin
+  Result := TJSONObject.Create;
+  try
+    Result.Add('method', aMethodName);
+    Result.Add('classname', aClassName);
+    Result.Add('jsonrpc','2.0');
+    // In case of notification, do not send an ID
+    if Not (IsNotification and (rcoNotifications in Options))  then
+      begin
+      inc(FRequestID);
+      Result.Add('id',FRequestID);
+      end;
+  except
+    Result.Free;
+    Raise;
+  end;
+end;
+
+function TFPRPCClient.CreateService(aName: string): IInterface;
+begin
+  if not DoCreateProxy(aName,Result) then
+    Raise ERPCClient.CreateFmt(SErrUnknownServiceName,[aName]);
+end;
+
+generic function TFPRPCClient.CreateService<T>(aName: string): T;
+
+Var
+  II : IInterface;
+
+begin
+  Result:=Nil;
+  II:=CreateService(aName);
+  if II.QueryInterface(RPCServiceRegistry.Get(aName).GUID,Result)<>S_OK then
+    Raise ERPCClient.CreateFmt(SErrSupportedServiceName,[aName]);
+end;
+
+Function TFPRPCClient.EncodeParams(aMethod: TRttiMethod; const aArgs: TValueArray; out VarParamCount : Integer) : TJSONData;
+
+var
+  UseObj : Boolean;
+  args: TRttiParameterArray;
+  arg: TRttiParameter;
+  I,argIdx: Integer;
+  argVal : TJSONData;
+
+
+begin
+  varParamCount:=0;
+  UseObj:=rcoObjectParam in Options;
+  if UseObj then
+    Result := TJSONObject.Create
+  else
+    Result := TJSONArray.Create;
+  try
+    argIdx:=1;
+    args := aMethod.GetParameters;
+    for I:=0 to length(args)-1 do
+      begin
+      Arg:=args[i];
+      if [pfHidden,pfSelf] * arg.Flags <> [] then
+        Continue
+      else if ([pfVar,pfOut] * arg.Flags)<>[] then
+        Inc(VarParamCount);
+      argVal:=ValueToJSON(aArgs[argidx], arg.ParamType);
+      if UseObj then
+        TJSONObject(Result).Add(arg.Name, argVal)
+      else
+        TJSONArray(Result).Add(argVal);
+      Inc(argidx);
+      end;
+  except
+    Result.Free;
+    Raise;
+  end;
+end;
+
+Function TFPRPCClient.DecodeResult(Response : TJSONObject; aMethod: TRttiMethod; const aArgs: TValueArray; HaveReturnValues : Boolean): TValue;
+
+Var
+  i,argIdx : Integer;
+  args : TRttiParameterArray;
+  arg : TRttiParameter;
+  resobj : TJSONObject;
+  value: TValue;
+
+begin
+  Result:=Default(TValue);
+  if Assigned(aMethod.ReturnType) or HaveReturnValues then
+    if not Assigned(Response) then
+      raise ERPCClient.CreateFmt(SErrExpectedReturnButNoServerReturn,[aMethod.Name]);
+  if Not HaveReturnValues then
+    begin
+    if Assigned(aMethod.ReturnType) then
+      Result := JSONToValue(response.Elements['result'], aMethod.ReturnType);
+    end
+  else
+    begin
+    resObj:=response.Objects['result'];
+    if Assigned(aMethod.ReturnType) then
+      Result := JSONToValue(resObj.Elements['$result'], aMethod.ReturnType);
+    argidx := 1;
+    args:=aMethod.GetParameters;
+    for i := 0 to High(args) do
+      begin
+      arg := Args[i];
+      if pfHidden in arg.Flags then
+        Continue;
+      if arg.Flags * [pfOut, pfVar] = [] then
+        begin
+        Inc(argidx);
+        Continue;
+        end;
+      value := JSONToValue(resObj.Elements[arg.Name], arg.ParamType);
+      value.ExtractRawData(aArgs[argidx].GetReferenceToRawData);
+      Inc(argidx);
+      end;
+    end;
+end;
+
+procedure TFPRPCClient.HandleInvoke(aClassName : String; aMethod: TRttiMethod; const aArgs: TValueArray; out aResult: TValue);
+
+var
+  request, response: TJSONObject;
+  argobj: TJSONData;
+  VarParamCount:Integer;
+
+begin
+  aResult:=Default(TValue);
+  response:=nil;
+  Request:=CreateRPCRequest(aClassName,aMethod.Name,Not Assigned(aMethod.ReturnType));
+  try
+    { skip Self argument }
+    argObj:=EncodeParams(aMethod,aArgs,VarParamCount);
+    request.Add('params', argobj);
+    response := DoRequest(request) as TJSONObject;
+    aResult:=DecodeResult(Response,aMethod,aArgs,VarParamCount>0);
+ finally
+   response.Free;
+   request.Free;
+ end;
+end;
+
+function TFPRPCClient.DoRequest(aRequest: TJSONObject): TJSONObject;
+
+var
+  aClient: TAbstractWebClient;
+  Req : TWebClientRequest;
+  Resp: TWebClientResponse;
+  S : TJSONStringType;
+  Res : TJSONData;
+
+begin
+  Result:=Nil;
+  aClient := GetClient;
+  Resp:=Nil;
+  Req:=aClient.CreateRequest;
+  try
+    S:=aRequest.AsJSON;
+    Writeln('Request : ',S);
+    Req.Content.WriteBuffer(S[1],Length(S));
+    Resp:=aClient.ExecuteRequest('POST',FBaseURL,Req);
+    Writeln('Response : ',Resp.GetContentAsString);
+    // For notification methods, there is no return !
+    if (resp.Content.Size>0) then
+      begin
+      resp.Content.Position:=0;
+      Res:=GetJSON(resp.Content,True);
+      if (Res is TJSONObject) then
+        Result:=Res as TJSONObject
+      else
+        begin
+        Res.Free;
+        Raise ERPCClient.Create('Invalid server response');
+        end;
+      end;
+  finally
+    Req.Free;
+    Resp.Free;
+  end;
+end;
+
+
+end.
+

packages/fcl-web/src/jsonrpc/fprpcrtti.pp

@@ -0,0 +1,298 @@
+{
+    This file is part of the Free Component Library
+
+    Server-side JSON-RPC functionality using Invoke.
+    Copyright (c) 2022 by Michael Van Canneyt [email protected]
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit fprpcrtti;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, fpjson, fpjsonrpc, typinfo, rtti;
+
+Type
+  TRTTIInstanceCreator = Function(const aClassName : string) : IInterface;
+
+  IRPCCallContext = Interface ['{F026AE43-E0E5-4F3D-9878-9B70201E34B0}']
+    Procedure SetRPCCallContext(aCallContext : TJSONRPCCallContext);
+    Function GetRPCCallContext : TJSONRPCCallContext;
+    Property RPCCallContext : TJSONRPCCallContext Read GetRPCCallContext Write SetRPCCallContext;
+  end;
+
+  { TRTTIJSONRPCHandler }
+
+  TRTTIJSONRPCHandler = class(TCustomJSONRPCHandler)
+  Private
+    FIntfType : TRttiInterfaceType;
+    FMethod : TRttiMethod;
+    FCreator : TRTTIInstanceCreator;
+    FRPCClassName: String;
+  protected
+    class function JSONToValue(aData: TJSONData; aType: TRttiType): TValue;
+    class function ValueToJSON(const aValue: TValue; aType: TRttiType): TJSONData;
+    Function CreateInstance : IInterface; virtual;
+    Function DoExecute(Const Params : TJSONData; AContext : TJSONRPCCallContext): TJSONData; override;
+    Property Method : TRttiMethod Read FMethod;
+    Property IntfType : TRttiInterfaceType read FIntfType;
+  Public
+    Procedure SetRequestClassAndMethod(const aClassName,aMethodName : String); override;
+    Property RPCClassName : String Read FRPCClassName;
+  end;
+
+
+  { TRTTIJSONRPCRegistry }
+
+  TRTTIJSONRPCRegistry = class
+  Private
+    type
+      TIntfEntry = record
+        Name : String;
+        GetInstance: TRTTIInstanceCreator;
+        IntfType: TRttiInterfaceType;
+      end;
+    Class var
+      _Instance : TRTTIJSONRPCRegistry;
+  private
+     fIntfs: array of TIntfEntry;
+     fIntfCount: Integer;
+     fContext: TRttiContext;
+  Public
+     class var
+       SizeDelta : Integer;
+  Public
+     class constructor Init;
+     class destructor done;
+     Constructor Create; virtual;
+     Destructor Destroy; override;
+     Procedure Add(P : PTypeInfo; aCreator : TRTTIInstanceCreator; const aName : string = '');
+     generic Procedure Add<T : IInterface>(aCreator : TRTTIInstanceCreator; const aName : string = '');
+     Function Find(const aName : string; out IntfType: TRttiInterfaceType; out aCreator : TRTTIInstanceCreator) : Boolean;
+     Function Get(const aName : string; out IntfType: TRttiInterfaceType; out aCreator : TRTTIInstanceCreator) : Boolean;
+     class property Instance : TRTTIJSONRPCRegistry Read _Instance;
+  end;
+
+function RTTIJSONRPCRegistry : TRTTIJSONRPCRegistry;
+
+implementation
+
+uses fpjsonvalue;
+
+function RTTIJSONRPCRegistry : TRTTIJSONRPCRegistry;
+
+begin
+  Result:=TRTTIJSONRPCRegistry.Instance;
+end;
+
+{ TRTTIJSONRPCRegistry }
+
+class constructor TRTTIJSONRPCRegistry.Init;
+begin
+  SizeDelta:=32;
+  _Instance:=TRTTIJSONRPCRegistry.Create;
+end;
+
+class destructor TRTTIJSONRPCRegistry.done;
+begin
+  _Instance.Free;
+end;
+
+constructor TRTTIJSONRPCRegistry.Create;
+begin
+  SetLength(FIntfs,SizeDelta);
+  FContext:=TRTTIContext.Create;
+  FIntfCount:=0;
+end;
+
+destructor TRTTIJSONRPCRegistry.Destroy;
+begin
+  SetLength(FIntfs,0);
+  inherited Destroy;
+end;
+
+procedure TRTTIJSONRPCRegistry.Add(P: PTypeInfo; aCreator: TRTTIInstanceCreator;const aName : string = '');
+
+var
+  entry: TIntfEntry;
+  aMethod : TRTTIMethod;
+  aParamCount : Integer;
+
+begin
+  if aName='' then
+    entry.Name:=P^.Name
+  else
+    entry.Name:=aName;
+  entry.GetInstance := aCreator;
+  entry.IntfType := fContext.GetType(P) as TRttiInterfaceType;
+  if fIntfCount>=Length(fIntfs) then
+    SetLength(fIntfs,Length(fIntfs)+SizeDelta);
+  fIntfs[fIntfCount]:=entry;
+  Inc(fIntfCount);
+  for aMethod in entry.IntfType.GetDeclaredMethods do
+    begin
+    aParamCount:=Length(aMethod.GetParameters);
+    JSONRPCHandlerManager.RegisterHandler(Entry.Name,aMethod.Name,TRTTIJSONRPCHandler,aParamCount);
+    end;
+end;
+
+generic procedure TRTTIJSONRPCRegistry.Add<T>(aCreator : TRTTIInstanceCreator;const aName : string = '');
+
+begin
+  Add(PTypeInfo(TypeInfo(T)), aCreator, aName);
+end;
+
+function TRTTIJSONRPCRegistry.Find(Const aName: string; out IntfType: TRttiInterfaceType; out aCreator: TRTTIInstanceCreator): Boolean;
+
+Var
+  Idx : integer;
+  Entry : TIntfEntry;
+
+begin
+  Result:=False;
+  Idx:=fIntfCount-1;
+  While (Idx>=0) and not Result do
+    begin
+    Result:=SameText(fIntfs[Idx].Name,aName);
+    if Result then
+      begin
+      Entry:=fIntfs[Idx];
+      IntfType:=Entry.IntfType;
+      aCreator:=Entry.GetInstance;
+      end;
+    Dec(Idx);
+    end;
+end;
+
+function TRTTIJSONRPCRegistry.Get(Const aName: string; out IntfType: TRttiInterfaceType; out aCreator: TRTTIInstanceCreator): Boolean;
+begin
+  Result:=Find(aName,IntfType,aCreator);
+end;
+
+{ TRTTIJSONRPCHandler }
+
+function TRTTIJSONRPCHandler.CreateInstance: IInterface;
+begin
+  Result:=FCreator(FRPCClassName);
+end;
+
+procedure TRTTIJSONRPCHandler.SetRequestClassAndMethod(const aClassName, aMethodName: String);
+
+
+begin
+  FRPCClassName:=aClassName;
+  RPCMethodName:=aMethodName;
+  TRTTIJSONRPCRegistry.Instance.Get(FRPCClassName,FIntfType,FCreator);
+  FMethod:=FIntfType.GetMethod(aMethodName);
+  if FMethod=Nil then
+    Raise EJSONRPC.CreateFmt('unknown method name for class %s: %s',[aClassName,aMethodName]);
+end;
+
+class function TRTTIJSONRPCHandler.ValueToJSON(const aValue: TValue; aType: TRttiType): TJSONData;
+begin
+  result:=fpjsonvalue.ValueToJSON(aValue,aType);
+end;
+
+class function TRTTIJSONRPCHandler.JSONToValue(aData: TJSONData; aType: TRttiType): TValue;
+
+begin
+  result:=fpjsonvalue.JSONToValue(aData,aType);
+end;
+
+
+
+function TRTTIJSONRPCHandler.DoExecute(const Params: TJSONData; AContext: TJSONRPCCallContext): TJSONData;
+
+var
+  margs: specialize TArray<TRttiParameter>;
+  arg: TRttiParameter;
+  args: array of TValue;
+  argidx: SizeInt;
+  resparams,i: LongInt;
+  res, instance: TValue;
+  intf,APIIntf : IUnknown;
+  aVal : TJSONData;
+  oRes : TJSONObject;
+  CC : IRPCCallContext;
+
+
+begin
+  Result:=Nil;
+  ResParams:=0;
+  args:=[];
+  if (Params.JSONType in StructuredJSONTypes) then
+    SetLength(args, Params.Count)
+  else
+    args := Nil;
+  argidx := 0;
+  margs := method.GetParameters;
+  for arg in margs do
+    begin
+    if pfHidden in arg.Flags then
+      Continue
+    else
+      if ([pfVar,pfOut] * arg.Flags)<>[] then
+        Inc(ResParams);
+    if Params.JSONType = jtArray then
+      aVal:=TJSONArray(Params).Items[argIdx]
+    else
+      aVal:=TJSONObject(Params).Elements[arg.Name];
+    args[argidx] := JSONToValue(aVal, arg.ParamType);
+    Inc(argidx);
+    end;
+  intf:=CreateInstance;
+  if (Intf.QueryInterface(IRPCCallContext,CC)=S_OK) then
+    CC.RPCCallContext:=aContext;
+  if Intf.QueryInterface(FIntfType.GUID,APIIntf)<>S_OK then
+    Raise EJSONRPC.CreateFmt('Creator does not support interface %s',[FIntfType.Name]);
+  TValue.Make(@APIIntf, PTypeInfo(FIntfType.Handle), instance);
+
+  res := method.Invoke(instance, args);
+
+  if ResParams=0 then
+    begin
+    if Assigned(method.ReturnType) then
+      Result:=ValueToJSON(res, method.ReturnType)
+    else
+      Result:=TJSONNull.Create;
+    end
+  else
+    begin
+    oRes := TJSONObject.Create;
+    Result:=oRes;
+    try
+      if Assigned(method.ReturnType) then
+        oRes.Add('$result', ValueToJSON(res, method.ReturnType));
+      argidx := 0;
+      for i := 0 to High(margs) do
+        begin
+        arg := margs[i];
+        if pfHidden in arg.Flags then
+          Continue;
+        if arg.Flags * [pfVar, pfOut] = [] then
+          begin
+          Inc(argidx);
+          Continue;
+          end;
+        oRes.Add(arg.Name, ValueToJSON(args[argidx], arg.ParamType));
+        Inc(argidx);
+      end;
+    except
+      Result.Free;
+    end;
+    end;
+  Intf:=nil;
+end;
+
+
+end.
+