* RPC Client code generator (also in pas2js)

packages/fcl-web/fpmake.pp

@@ -309,6 +309,7 @@ begin
       begin
       AddUnit('fpjsonrpc');
       end;
+    T:=P.Targets.AddUnit('fprpccodegen.pp');
     T:=P.Targets.AddUnit('fpdispextdirect.pp');
     With T.Dependencies do
       begin

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

@@ -0,0 +1,682 @@
+unit fprpccodegen;
+
+{$mode ObjFPC}
+{$h+}
+interface
+
+uses
+  Classes, SysUtils, fpjson, pascodegen;
+
+type
+
+  { TAPIClientCodeGen }
+  TClientCodeOption = (ccoPreferNativeInt,ccoForceJSValueResult);
+  TClientCodeOptions = set of TClientCodeOption;
+
+  { TAPIMethodParam }
+
+  TAPIMethodParam = Class(TCollectionItem)
+  private
+    FDefaultValue: String;
+    FJSType: TJSONtype;
+    FName: String;
+    FPasName: String;
+    FPasType: String;
+    FRequired: Boolean;
+  Public
+    Procedure Assign(Source : TPersistent); override;
+    Property Name : String Read FName Write FName;
+    Property PasName : String Read FPasName Write FPasName;
+    Property JSType : TJSONtype Read FJSType Write FJSType;
+    Property PasType : String Read FPasType Write FPasType;
+    Property Required : Boolean Read FRequired Write FRequired;
+    Property DefaultValue : String Read FDefaultValue Write FDefaultValue;
+  end;
+
+  { TAPIService }
+
+  { TAPIMethodParams }
+
+  TAPIMethodParams = Class(TCollection)
+  private
+    function GetParam(aIndex : Integer): TAPIMethodParam;
+  Public
+    Constructor Create; overload;
+    Function AddParam : TAPIMethodParam;
+    Property Params [aIndex : Integer] : TAPIMethodParam Read GetParam; default;
+  end;
+
+  { TAPIServiceMethod }
+
+  TAPIServiceMethod = Class(TCollectionItem)
+  private
+    FName: String;
+    FParams: TAPIMethodParams;
+    FPasName: String;
+    FPasReturnType: String;
+    FReturnType: TJSONtype;
+    procedure SetParams(AValue: TAPIMethodParams);
+  Public
+    Constructor Create(aCollection : TCollection) ; override;
+    Destructor Destroy; override;
+    Procedure Assign(Source : TPersistent); override;
+    Property Name : String Read FName Write FName;
+    Property PasName : String Read FPasName Write FPasName;
+    Property ReturnType : TJSONtype Read FReturnType Write FReturnType;
+    Property PasReturnType : String Read FPasReturnType Write FPasReturnType;
+    Property Params : TAPIMethodParams Read FParams Write SetParams;
+  end;
+
+  { TAPIServiceMethods }
+
+  TAPIServiceMethods = Class(TCollection)
+  private
+    function GetMethod(aIndex : Integer): TAPIServiceMethod;
+  Public
+    Constructor Create; overload;
+    Function AddMethod : TAPIserviceMethod;
+    Property Methods [aIndex : Integer] : TAPIServiceMethod Read GetMethod; default;
+  end;
+
+  TAPIService = Class(TCollectionItem)
+  private
+    FMethods: TAPIServiceMethods;
+    FName: String;
+    FPasName: String;
+    procedure SetMethods(AValue: TAPIServiceMethods);
+  Public
+    Constructor Create(aCollection : TCollection) ; override;
+    Destructor Destroy; override;
+    Procedure Assign(aSource : TPersistent); override;
+    Property Methods : TAPIServiceMethods Read FMethods Write SetMethods;
+    Property Name : String Read FName Write FName;
+    Property PasName : String Read FPasName Write FPasName;
+  end;
+
+  { TAPService }
+
+  TAPIServices = Class(TCollection)
+  private
+    function GetAPIService(aIndex : Integer): TAPIService;
+  Public
+    Constructor Create; overload;
+    Function AddService : TAPIservice;
+    Property Service [aIndex : Integer] : TAPIService Read GetAPIService; default;
+  end;
+
+  TAPIClientCodeGen = Class(TPascalCodeGenerator)
+  private
+    FAPI: TJSONObject;
+    FOptions: TClientCodeOptions;
+    FServiceParentClass: String;
+    procedure SetAPI(AValue: TJSONObject);
+  protected
+    // Overrides
+    Function BaseUnits : String; override;
+    function StringToJSType(S: String): TJSONtype;
+    // High-level decl
+    procedure GenerateServiceClassDeclarations(aServices: TAPIServices); virtual;
+    procedure GenerateServiceDeclaration(aService: TAPIService); virtual;
+    procedure GenerateServiceMethodDeclaration(aSvc : TAPIService; aMeth : TAPIServiceMethod); virtual;
+    // High-level impl
+    procedure GenerateServiceClassImplementations(aServices: TAPIServices); virtual;
+    procedure GenerateServiceImplementation(aService: TAPIService); virtual;
+    procedure GenerateServiceMethodImplementation(aSvc : TAPIService; aMeth : TAPIServiceMethod); virtual;
+    procedure GenerateRPCClassNameImplementation(aService: TAPIService); virtual;
+    // Get names. All incoming names are the original names of the API
+    function GetServiceClassName(const aName: string): String; virtual;
+    function GetServiceMethodName(const aClassName, aMethodName: string): String; virtual;
+    function GetServiceMethodParamName(const aClassName, aMethodName, aParamName: string): String; virtual;
+    function GetServiceMethodParamType(const aClassName, aMethodName, aParamName: String; aParamType: TJSONtype): String; virtual;
+    function GetServiceMethodParamDefault(const aClassName, aMethodName, aParamName: string; aParamType : TJSONType): String; virtual;
+    function GetServiceMethodResultHandler(const aClassName, aMethodName: string; aResultType: TJSONType): String; virtual;
+    // Convert JSON to API structures
+    Procedure FillAPIServices(aAPI : TAPIServices); virtual;
+    procedure FillAPIMethod(aSvc: TAPIService; aMeth: TAPIServiceMethod; aJSParams: TJSONArray); virtual;
+    procedure FillAPIMethodParam(aSvc: TAPIService; aMeth: TAPIServiceMethod; aParam: TAPIMethodParam; aJSON: TJSONObject); virtual;
+    procedure FillAPIService(aSvc: TAPIService; aJSService: TJSONArray); virtual;
+  Public
+    Constructor Create(aOwner : TComponent); override;
+    Procedure Execute;
+    Property API : TJSONObject Read FAPI Write SetAPI;
+    Property Options : TClientCodeOptions Read FOptions Write FOptions;
+    Property ServiceParentClass : String Read FServiceParentClass Write FServiceParentClass;
+  end;
+
+implementation
+
+{ TAPIMethodParams }
+
+function TAPIMethodParams.GetParam(aIndex : Integer): TAPIMethodParam;
+begin
+  Result:=TAPIMethodParam(Items[aIndex]);
+end;
+
+constructor TAPIMethodParams.Create;
+begin
+  Inherited Create(TAPIMethodParam);
+end;
+
+function TAPIMethodParams.AddParam: TAPIMethodParam;
+begin
+  Result:=TAPIMethodParam(Add);
+end;
+
+{ TAPIMethodParam }
+
+procedure TAPIMethodParam.Assign(Source: TPersistent);
+
+Var
+  P : TAPIMethodParam absolute Source;
+
+begin
+  if Source is TAPIMethodParam then
+    begin
+    FName:=P.FName;
+    FPasName:=P.FPasName;
+    FPasType:=P.FPasType;
+    FRequired:=P.FRequired;
+    FDefaultValue:=P.FDefaultValue;
+    FJSType:=P.FJSType;
+    end
+  else
+    inherited Assign(Source);
+end;
+
+{ TAPIServiceMethod }
+
+procedure TAPIServiceMethod.SetParams(AValue: TAPIMethodParams);
+begin
+  if FParams=AValue then Exit;
+  FParams.Assign(AValue);
+end;
+
+constructor TAPIServiceMethod.Create(aCollection: TCollection);
+begin
+  inherited Create(aCollection);
+  FParams:=TAPIMethodParams.Create;
+end;
+
+destructor TAPIServiceMethod.Destroy;
+begin
+  FreeAndNil(FParams);
+  Inherited;
+end;
+
+procedure TAPIServiceMethod.Assign(Source: TPersistent);
+
+Var
+  M : TAPIServiceMethod absolute Source;
+
+begin
+  if Source is TAPIServiceMethod then
+    begin
+    FName:=M.FName;
+    FPasName:=M.FPasName;
+    FReturnType:=M.FReturnType;
+    FPasReturnType:=M.FPasReturnType;
+    FParams.Assign(M.Params);
+    end
+  else
+    inherited Assign(Source);
+end;
+
+{ TAPIServiceMethods }
+
+function TAPIServiceMethods.GetMethod(aIndex : Integer): TAPIServiceMethod;
+begin
+  Result:=TAPIServiceMethod(Items[aIndex]);
+end;
+
+constructor TAPIServiceMethods.Create;
+begin
+  Inherited Create(TAPIServiceMethod);
+end;
+
+function TAPIServiceMethods.AddMethod: TAPIserviceMethod;
+begin
+  Result:=Add as TAPIserviceMethod
+end;
+
+{ TAPIService }
+
+procedure TAPIService.SetMethods(AValue: TAPIServiceMethods);
+begin
+  if FMethods=AValue then Exit;
+  FMethods.Assign(AValue);
+end;
+
+constructor TAPIService.Create(aCollection: TCollection);
+begin
+  inherited Create(aCollection);
+  FMethods:=TAPIServiceMethods.Create;
+end;
+
+destructor TAPIService.Destroy;
+begin
+  FreeAndNil(FMethods);
+  Inherited;
+end;
+
+procedure TAPIService.Assign(aSource: TPersistent);
+
+Var
+  svc : TAPIService absolute aSource;
+
+begin
+  if aSource is TAPIService then
+    begin
+    FName:=svc.FName;
+    FPasName:=svc.FPasName;
+    FMethods.Assign(svc.Methods);
+    end
+  else
+    inherited Assign(aSource);
+end;
+
+{ TAPIServices }
+
+function TAPIServices.GetAPIService(aIndex : Integer): TAPIService;
+begin
+  Result:=TAPIService(Items[aIndex])
+end;
+
+constructor TAPIServices.Create;
+begin
+  Inherited Create(TAPIService);
+end;
+
+function TAPIServices.AddService: TAPIservice;
+begin
+  Result:=Add as TAPIservice;
+end;
+
+{ TAPIClientCodeGen }
+
+procedure TAPIClientCodeGen.SetAPI(AValue: TJSONObject);
+begin
+  if FAPI=AValue then Exit;
+  FAPI.Free;
+  FAPI:=AValue;
+end;
+
+procedure TAPIClientCodeGen.GenerateServiceClassDeclarations(aServices: TAPIServices);
+
+Var
+  I : Integer;
+
+begin
+  For I:=0 to aServices.Count-1 do
+    GenerateServiceDeclaration(aServices[i]);
+end;
+
+procedure TAPIClientCodeGen.GenerateServiceClassImplementations(aServices: TAPIServices);
+
+Var
+  I : Integer;
+
+begin
+  For I:=0 to aServices.Count-1 do
+    GenerateServiceImplementation(aServices[i]);
+end;
+
+
+procedure TAPIClientCodeGen.Execute;
+
+Var
+  Services : TAPIServices;
+begin
+  CreateUnitClause;
+  CreateHeader;
+  AddLn('Type');
+  Indent;
+  Services:=TAPIServices.Create;
+  try
+    FillAPIServices(Services);
+    GenerateServiceClassDeclarations(Services);
+    Addln('');
+    Addln('implementation');
+    Addln('');
+    GenerateServiceClassImplementations(Services);
+    Addln('');
+    Addln('end.');
+
+
+  finally
+    Services.Free;
+    Undent;
+  end;
+
+end;
+
+function TAPIClientCodeGen.GetServiceClassName(const aName: string): String;
+
+begin
+  Result:='T'+EscapeKeyWord(aName)+'Service';
+end;
+
+function TAPIClientCodeGen.GetServiceMethodName(const aClassName,
+  aMethodName: string): String;
+
+begin
+  Result:=EscapeKeyWord(aMethodName);
+end;
+
+function TAPIClientCodeGen.GetServiceMethodParamName(const aClassName, aMethodName, aParamName: string): String;
+
+begin
+  Result:=EscapeKeyWord(aParamName);
+end;
+
+function TAPIClientCodeGen.GetServiceMethodParamType(const aClassName,
+  aMethodName, aParamName: String; aParamType: TJSONtype): String;
+
+begin
+  case aParamtype of
+    jtString : Result:='String';
+    jtBoolean : Result:='Boolean';
+    jtNumber : begin
+                 if ccoPreferNativeInt in Options then
+                   Result:='NativeInt'
+                 else
+                   Result:='Double';
+                 end;
+    jtArray : Result:='TJSArray';
+    jtObject : Result:='TJSObject';
+  else
+    Result:='JSValue';
+  end;
+end;
+
+function TAPIClientCodeGen.GetServiceMethodParamDefault(const aClassName, aMethodName, aParamName: string; aParamType : TJSONType): String;
+
+begin
+  case aParamtype of
+    jtString  : Result:='''''';
+    jtBoolean : Result:='False';
+    jtNumber  : begin
+                if ccoPreferNativeInt in Options then
+                  Result:='0'
+                else
+                  Result:='0.0';
+               end;
+    jtArray   : Result:='Nil';
+    jtObject  : Result:='Nil';
+  else
+    Result:='Nil';
+  end;
+end;
+
+function TAPIClientCodeGen.GetServiceMethodResultHandler(const aClassName,
+  aMethodName: string; aResultType: TJSONType): String;
+
+begin
+  {
+  TEmptyResultHandler = reference to procedure;
+  TBooleanResultHandler = reference to procedure (aResult : Boolean);
+  TNativeIntResultHandler = reference to procedure (aResult : NativeInt);
+  TDoubleResultHandler = reference to procedure (aResult : Double);
+  TStringResultHandler = reference to procedure (aResult : String);
+  TArrayResultHandler = reference to procedure (aResult : TJSArray);
+  TObjectResultHandler = reference to procedure (aResult : TJSObject);
+  TJSValueResultHandler = reference to procedure (aResult : JSValue);
+
+  }
+  if ccoForceJSValueResult in options then
+    Result:='TJSValueResultHandler'
+  else
+    case aResultType of
+      jtString  : Result:='TStringResultHandler';
+      jtBoolean : Result:='TBooleanResultHandler';
+      jtNumber  : begin
+                  if ccoPreferNativeInt in Options then
+                    Result:='TNativeIntResultHandler'
+                  else
+                    Result:='TDoubleResultHandler';
+                  end;
+      jtArray   : Result:='TArrayResultHandler';
+      jtObject  : Result:='TObjectResultHandler';
+      jtNull    : Result:='TEmptyResultHandler';
+      jtUnknown : Result:='TJSValueResultHandler';
+    else
+      Result:='TEmptyResultHandler';
+    end;
+end;
+
+procedure TAPIClientCodeGen.FillAPIServices(aAPI: TAPIServices);
+
+Var
+  Actions : TJSONObject;
+  I : Integer;
+  AService : TJSONArray;
+  svc : TAPIService;
+
+begin
+  Actions:=API.Get('actions',TJSONObject(Nil));
+  If Not Assigned(Actions) then
+    exit;
+  For I:=0 to Actions.Count-1 do
+    begin
+    svc:=aAPI.AddService;
+    svc.Name:=Actions.Names[i];
+    svc.PasName:=GetServiceClassName(svc.Name);
+    aService:=Actions.Arrays[svc.Name];
+    FillAPIService(svc,aService);
+    end;
+end;
+
+function TAPIClientCodeGen.StringToJSType(S : String) : TJSONtype;
+
+begin
+  S:=LowerCase(S);
+  Case S of
+    'jtunknown' : Result:=jtUnknown;
+    'jtnumber'  : Result:=jtNumber;
+    'jtstring'  : Result:=jtString;
+    'jtboolean' : Result:=jtBoolean;
+    'jtnull'    : Result:=jtNull;
+    'jtarray'   : Result:=jtArray;
+    'jtobject'  : Result:=jtObject;
+  else
+    Result:=jtUnknown;
+  end;
+end;
+
+procedure TAPIClientCodeGen.FillAPIService(aSvc : TAPIService; aJSService : TJSONArray);
+
+Var
+  I : Integer;
+  aJSON : TJSONObject;
+  aMeth : TAPIServiceMethod;
+  aParams : TJSONArray;
+
+begin
+  For I:=0 to aJSService.Count-1 do
+    begin
+    aJSON:=aJSService.Objects[i];
+    aMeth:=aSvc.Methods.AddMethod;
+    aMeth.Name:=aJSON.Get('name','');
+    aMeth.PasName:=GetServiceMethodName(aSvc.Name,aMeth.Name);
+    aMeth.ReturnType:=StringToJSType(aJSON.Get('resulttype',''));
+    aParams:=aJSON.Get('paramdefs',TJSONarray(Nil));
+    if (aJSON.Get('len',0)>0) and Assigned(aParams) then
+      FillAPIMethod(aSvc,aMeth,aParams);
+    end;
+end;
+
+constructor TAPIClientCodeGen.Create(aOwner: TComponent);
+begin
+  inherited Create(aOwner);
+  FServiceParentClass:='TRPCCustomService';
+end;
+
+procedure TAPIClientCodeGen.FillAPIMethodParam(aSvc : TAPIService; aMeth : TAPIServiceMethod; aParam :TAPIMethodParam; aJSON : TJSONObject);
+
+begin
+  aParam.Name:=aJSON.get('name','');
+  aParam.PasName:=GetServiceMethodParamName(aSvc.Name,aMeth.Name,aParam.Name);
+  aParam.JSType:=StringToJSType(aJSON.Get('type',''));
+  aParam.PasType:=GetServiceMethodParamType(aSvc.Name,aMeth.Name,aParam.Name,aParam.JSType);
+  aParam.Required:=aJSON.Get('required',true);
+  aParam.DefaultValue:=GetServiceMethodParamDefault(aSVC.Name,aMeth.Name,aParam.Name,aParam.JSType);
+end;
+
+procedure TAPIClientCodeGen.FillAPIMethod(aSvc : TAPIService; aMeth : TAPIServiceMethod; aJSParams : TJSONArray);
+
+var
+  I : Integer;
+  aJSON : TJSONObject;
+  aParam : TAPIMethodParam;
+
+begin
+  For I:=0 to aJSParams.Count-1 do
+    begin
+    aJSON:=aJSParams.Objects[i];
+    aParam:=aMeth.Params.AddParam;
+    FillAPIMethodParam(aSvc,aMeth,aParam,aJSON);
+    end;
+end;
+
+procedure TAPIClientCodeGen.GenerateServiceMethodDeclaration(aSvc : TAPIService; aMeth : TAPIServiceMethod);
+
+Var
+  I : Integer;
+  ResType,ParamLine : String;
+  aParam : TAPIMethodParam;
+
+begin
+  resType:=GetServiceMethodResultHandler(aSvc.Name, aMeth.Name, aMeth.ReturnType);
+  ParamLine:='';
+  For I:=0 to aMeth.Params.Count-1 do
+    begin
+    aParam:=aMeth.Params[i];
+    if ParamLine<>'' then
+      ParamLine:=ParamLine+'; ';
+    ParamLine:=ParamLine+aParam.PasName+' : '+aParam.PasType;
+    if (not aParam.Required) and (aParam.DefaultValue<>'') then
+      ParamLine:=ParamLine+' = '+aParam.DefaultValue;
+    end;
+  if ParamLine<>'' then
+    ParamLine:=ParamLine+'; ';
+  ParamLine:=ParamLine+'aOnSuccess : '+ResType+' = Nil; aOnFailure : TRPCFailureCallBack = Nil';
+  AddLn('Function %s (%s) : NativeInt;',[aMeth.PasName,ParamLine]);
+//  For I:=0 to
+end;
+
+procedure TAPIClientCodeGen.GenerateServiceMethodImplementation(aSvc : TAPIService; aMeth : TAPIServiceMethod);
+
+Var
+  I : Integer;
+  ResType,ParamLine : String;
+  aParam : TAPIMethodParam;
+
+begin
+  resType:=GetServiceMethodResultHandler(aSvc.Name, aMeth.Name, aMeth.ReturnType);
+  ParamLine:='';
+  For I:=0 to aMeth.Params.Count-1 do
+    begin
+    aParam:=aMeth.Params[i];
+    if ParamLine<>'' then
+      ParamLine:=ParamLine+'; ';
+    ParamLine:=ParamLine+aParam.PasName+' : '+aParam.PasType;
+    if (not aParam.Required) and (aParam.DefaultValue<>'') then
+      ParamLine:=ParamLine+' = '+aParam.DefaultValue;
+    end;
+  if ParamLine<>'' then
+    ParamLine:=ParamLine+'; ';
+  ParamLine:=ParamLine+'aOnSuccess : '+ResType+' = Nil; aOnFailure : TRPCFailureCallBack = Nil';
+  AddLn('Function %s.%s (%s) : NativeInt;',[aSvc.PasName,aMeth.PasName,ParamLine]);
+  AddLn('');
+  Indent;
+  Addln('Procedure DoSuccess(Sender : TObject; const aResult : JSValue);');
+  AddLn('');
+  Addln('begin');
+  indent;
+    Addln('If Assigned(aOnSuccess) then');
+    Indent;
+      Addln('aOnSuccess(%s(aResult))',[aMeth.PasReturnType]);
+    undent;
+  undent;
+  Addln('end;');
+  Undent;
+  AddLn('');
+  Addln('Var');
+  Indent;
+    Addln('_Params : JSValue;');
+  Undent;
+  AddLn('');
+  Addln('begin');
+  Indent;
+  Addln('StartParams;');
+  For I:=0 to aMeth.Params.Count-1 do
+    begin
+    aParam:=aMeth.Params[i];
+    AddLn('AddParam(''%s'',%s);',[aParam.Name,aParam.PasName]);
+    end;
+  Addln('_Params:=EndParams;');
+  AddLn('Result:=ExecuteRequest(RPCClassName,''%s'',_Params,@DoSuccess,aOnFailure);',[aMeth.Name]);
+  Undent;
+  Addln('end;');
+  AddLn('');
+  AddLn('');
+end;
+
+procedure TAPIClientCodeGen.GenerateServiceDeclaration(aService: TAPIService);
+
+Var
+  I : integer;
+
+begin
+  ClassHeader(aService.PasName);
+  AddLn('%s = Class(TRPCCustomService)',[aService.PasName]);
+  Addln('Protected');
+  Indent;
+    AddLn('Function RPCClassName : string; override;');
+  Undent;
+  Addln('Public');
+  Indent;
+  For I:=0 to aService.Methods.Count-1 do
+    GenerateServiceMethodDeclaration(aService,aService.Methods[i]);
+  Undent;
+  Addln('end;');
+end;
+
+procedure TAPIClientCodeGen.GenerateRPCClassNameImplementation(aService: TAPIService);
+
+begin
+  Addln('Function %s.RPCClassName : string;',[aService.PasName]);
+  Addln('');
+  AddLn('begin');
+  indent;
+  AddLn('Result:=''%s'';',[aService.Name]);
+  undent;
+  Addln('end;');
+  Addln('');
+  Addln('');
+end;
+
+procedure TAPIClientCodeGen.GenerateServiceImplementation(aService: TAPIService);
+
+Var
+  I : integer;
+
+begin
+  ClassHeader(aService.PasName);
+  Addln('');
+  GenerateRPCClassNameImplementation(aService);
+  For I:=0 to aService.Methods.Count-1 do
+    GenerateServiceMethodImplementation(aService,aService.Methods[i]);
+  Addln('');
+end;
+
+
+function TAPIClientCodeGen.BaseUnits: String;
+
+begin
+  Result:='fprpcclient';
+end;
+
+
+
+end.
+