mirror of
https://gitlab.com/freepascal.org/fpc/pas2js.git
synced 2025-04-05 11:17:45 +02:00
* RPC Client + RPC Client Code generator
This commit is contained in:
Michaël Van Canneyt
parent
c9bf21a20d
commit
56d3f11fba
84
demo/apiclient/apiclient.lpi
Normal file
84
demo/apiclient/apiclient.lpi
Normal file
@ -0,0 +1,84 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="12"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<SaveClosedFiles Value="False"/>
|
||||
<SaveOnlyProjectUnits Value="True"/>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
<MainUnitHasScaledStatement Value="False"/>
|
||||
<Runnable Value="False"/>
|
||||
<SaveJumpHistory Value="False"/>
|
||||
<SaveFoldState Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<Title Value="apiclient"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<CustomData Count="1">
|
||||
<Item0 Name="PasJSWebBrowserProject" Value="1"/>
|
||||
</CustomData>
|
||||
<BuildModes>
|
||||
<Item Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
<UseFileFilters Value="True"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<FormatVersion Value="2"/>
|
||||
</RunParams>
|
||||
<Units>
|
||||
<Unit>
|
||||
<Filename Value="apiclient.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<Target FileExt=".js">
|
||||
<Filename Value="apiclient"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<UnitOutputDirectory Value="js"/>
|
||||
</SearchPaths>
|
||||
<Parsing>
|
||||
<SyntaxOptions>
|
||||
<AllowLabel Value="False"/>
|
||||
<CPPInline Value="False"/>
|
||||
<UseAnsiStrings Value="False"/>
|
||||
</SyntaxOptions>
|
||||
</Parsing>
|
||||
<CodeGeneration>
|
||||
<TargetOS Value="browser"/>
|
||||
</CodeGeneration>
|
||||
<Linking>
|
||||
<Debugging>
|
||||
<GenerateDebugInfo Value="False"/>
|
||||
<UseLineInfoUnit Value="False"/>
|
||||
</Debugging>
|
||||
</Linking>
|
||||
<Other>
|
||||
<CustomOptions Value="-Jeutf-8 -Jirtl.js -Jc -Jminclude"/>
|
||||
<CompilerPath Value="$(pas2js)"/>
|
||||
</Other>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions>
|
||||
<Item>
|
||||
<Name Value="EAbort"/>
|
||||
</Item>
|
||||
<Item>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item>
|
||||
<Item>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
106
demo/apiclient/apiclient.lpr
Normal file
106
demo/apiclient/apiclient.lpr
Normal file
@ -0,0 +1,106 @@
|
||||
program apiclient;
|
||||
|
||||
{$mode objfpc}
|
||||
|
||||
uses
|
||||
browserapp, JS, Classes, SysUtils, Web, fpjson, fpjsonjs, fprpccodegen;
|
||||
|
||||
type
|
||||
|
||||
{ TMyApplication }
|
||||
|
||||
TMyApplication = class(TBrowserApplication)
|
||||
edtResult : TJSHTMLTextAreaElement;
|
||||
edtURL : TJSHTMLInputElement;
|
||||
edtUnit : TJSHTMLInputElement;
|
||||
cbPreferNativeInt : TJSHTMLInputElement;
|
||||
cbForceJSValueResult : TJSHTMLInputElement;
|
||||
btnGenerate : TJSHTMLButtonElement;
|
||||
procedure BindElements;
|
||||
procedure doRun; override;
|
||||
private
|
||||
function DoGenerateCode(aEvent: TJSMouseEvent): boolean;
|
||||
procedure GenerateAPI(const aJSON: String);
|
||||
end;
|
||||
|
||||
procedure TMyApplication.BindElements;
|
||||
begin
|
||||
edtResult:=TJSHTMLTextAreaElement(GetHTMLElement('edtResult'));
|
||||
edtURL:=TJSHTMLInputElement(GetHTMLElement('edtURL'));
|
||||
edtUnit:=TJSHTMLInputElement(GetHTMLElement('edtUnit'));
|
||||
cbPreferNativeInt:=TJSHTMLInputElement(GetHTMLElement('cbPreferNativeInt'));
|
||||
cbForceJSValueResult:=TJSHTMLInputElement(GetHTMLElement('cbForceJSValueResult'));
|
||||
btnGenerate:=TJSHTMLButtonElement(GetHTMLElement('btnGenerate'));
|
||||
btnGenerate.OnClick:=@DoGenerateCode;
|
||||
end;
|
||||
|
||||
procedure TMyApplication.doRun;
|
||||
|
||||
begin
|
||||
BindElements;
|
||||
Terminate;
|
||||
end;
|
||||
|
||||
Procedure TMyApplication.GenerateAPI(const aJSON: String);
|
||||
|
||||
Var
|
||||
API : TJSONObject;
|
||||
Gen : TAPIClientCodeGen;
|
||||
Opts : TClientCodeOptions;
|
||||
|
||||
begin
|
||||
API:=GetJSON(aJSON) as TJSONObject;
|
||||
Opts:=[];
|
||||
if cbForceJSValueResult.checked then
|
||||
Include(Opts,ccoForceJSValueResult);
|
||||
if cbPreferNativeInt.Checked then
|
||||
Include(Opts,ccoPreferNativeInt);
|
||||
Gen:=TAPIClientCodeGen.Create(Self);
|
||||
try
|
||||
Gen.API:=API;
|
||||
Gen.Options:=Opts;
|
||||
Gen.OutputUnitName:=edtUnit.Value;
|
||||
Gen.Execute;
|
||||
edtResult.value:=Gen.Source.Text;
|
||||
finally
|
||||
Gen.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TMyApplication.DoGenerateCode(aEvent: TJSMouseEvent): boolean;
|
||||
|
||||
procedure GenAPI(Resp : TJSResponse); async;
|
||||
|
||||
begin
|
||||
GenerateAPI(Await(Resp.text()));
|
||||
end;
|
||||
|
||||
function DoOK(aValue: JSValue): JSValue;
|
||||
|
||||
var
|
||||
Resp : TJSResponse absolute aValue;
|
||||
|
||||
begin
|
||||
Result:=undefined;
|
||||
GenAPI(Resp)
|
||||
end;
|
||||
|
||||
function DoFail(aValue: JSValue): JSValue;
|
||||
begin
|
||||
Result:=undefined;
|
||||
window.alert('Failed to fetch API description at URL '+edtURL.value)
|
||||
end;
|
||||
|
||||
begin
|
||||
Result:=True;
|
||||
window.fetch(edtURL.Value,TJSObject.New)._then(@DoOK,@DoFail);
|
||||
end;
|
||||
|
||||
var
|
||||
Application : TMyApplication;
|
||||
|
||||
begin
|
||||
Application:=TMyApplication.Create(nil);
|
||||
Application.Initialize;
|
||||
Application.Run;
|
||||
end.
|
||||
1
demo/apiclient/bulma.min.css
vendored
Normal file
1
demo/apiclient/bulma.min.css
vendored
Normal file
File diff suppressed because one or more lines are too long
76
demo/apiclient/index.html
Normal file
76
demo/apiclient/index.html
Normal file
@ -0,0 +1,76 @@
|
||||
<HTML>
|
||||
<Title>API Code generator</Title>
|
||||
<link href="bulma.min.css" rel="stylesheet">
|
||||
<script src="apiclient.js" type="application/javascript"></script>
|
||||
</body>
|
||||
<nav class="panel">
|
||||
<p class="panel-heading">
|
||||
Settings
|
||||
</p>
|
||||
|
||||
<div class="panel-block">
|
||||
<div class="field">
|
||||
<label class="label">API URL</label>
|
||||
<div class="control">
|
||||
<input id="edtURL" class="input" type="text" placeholder="URL where to reach FPC API">
|
||||
</div>
|
||||
</div>
|
||||
</div>
|
||||
|
||||
<div class="panel-block">
|
||||
<div class="field">
|
||||
<label class="label">Unit name</label>
|
||||
<div class="control">
|
||||
<input id="edtUnit" class="input" type="text" placeholder="Unit name">
|
||||
</div>
|
||||
</div>
|
||||
</div>
|
||||
|
||||
<div class="panel-block">
|
||||
<div class="column">
|
||||
<div class="field">
|
||||
<div class="control">
|
||||
<label class="checkbox">
|
||||
<input id="cbPreferNativeInt" type="checkbox" checked>
|
||||
Prefer NativeInt
|
||||
</label>
|
||||
</div>
|
||||
</div>
|
||||
</div>
|
||||
<div class="column">
|
||||
<div class="field">
|
||||
<div class="control">
|
||||
<label class="checkbox">
|
||||
<input id="cbForceJSValueResult" type="checkbox">
|
||||
Force JSValue result in callbacks
|
||||
</label>
|
||||
</div>
|
||||
</div>
|
||||
</div>
|
||||
</div>
|
||||
<div class="panel-block">
|
||||
<div class="field">
|
||||
<div class="control">
|
||||
<button id="btnGenerate" class="button is-link">Generate unit</button>
|
||||
</div>
|
||||
</div>
|
||||
</div>
|
||||
|
||||
</nav>
|
||||
<nav class="panel">
|
||||
<p class="panel-heading">
|
||||
Generated result
|
||||
</p>
|
||||
<div class="panel-block">
|
||||
<div class="field">
|
||||
<label class="label">Unit source</label>
|
||||
<div class="control">
|
||||
<textarea id="edtResult" class="textarea" placeholder="Unit source" cols="132" rows="25"></textarea>
|
||||
</div>
|
||||
</div>
|
||||
</div>
|
||||
</nav>
|
||||
<script>
|
||||
rtl.run();
|
||||
</script>
|
||||
</HTML>
|
||||
867
packages/fcl-rpc/fprpcclient.pp
Normal file
867
packages/fcl-rpc/fprpcclient.pp
Normal file
@ -0,0 +1,867 @@
|
||||
unit fprpcclient;
|
||||
|
||||
{$mode ObjFPC}
|
||||
{$modeswitch advancedrecords}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, JS;
|
||||
|
||||
Const
|
||||
DefaultJSONRPCversion = '2.0';
|
||||
|
||||
Type
|
||||
ERPCClient = Class(Exception);
|
||||
|
||||
{ TRPCRequestParamsBuilder }
|
||||
|
||||
TRPCRequestParamsBuilder = class
|
||||
Protected
|
||||
Procedure DoAddArg(const aName : String; aValue : JSValue); virtual; abstract;
|
||||
Function DoGetArgs : JSValue; virtual; abstract;
|
||||
Public
|
||||
Procedure AddArg(const aName : string; aValue : NativeInt);
|
||||
Procedure AddArg(const aName : string; aValue : String);
|
||||
Procedure AddArg(const aName : string; aValue : Boolean);
|
||||
Procedure AddArg(const aName : string; aValue : Double);
|
||||
Procedure AddArg(const aName : string; aValue : TJSArray);
|
||||
Procedure AddArg(const aName : string; aValue : TJSObject);
|
||||
end;
|
||||
|
||||
{ TRPCArrayRequestParamsBuilder }
|
||||
|
||||
TRPCArrayRequestParamsBuilder = class (TRPCRequestParamsBuilder)
|
||||
private
|
||||
FParams: TJSArray;
|
||||
Protected
|
||||
Function DoGetArgs : JSValue; override;
|
||||
Procedure DoAddArg(const aName : String; aValue : JSValue); override;
|
||||
Public
|
||||
Constructor Create(aParams : TJSArray);
|
||||
Property Params : TJSArray Read FParams;
|
||||
end;
|
||||
|
||||
{ TRPCObjectRequestParamsBuilder }
|
||||
|
||||
TRPCObjectRequestParamsBuilder = class (TRPCRequestParamsBuilder)
|
||||
private
|
||||
FParams: TJSObject;
|
||||
Protected
|
||||
Procedure DoAddArg(const aName : String; aValue : JSValue); override;
|
||||
Function DoGetArgs : JSValue; override;
|
||||
Public
|
||||
Constructor Create(aParams : TJSObject);
|
||||
Property Params : TJSObject Read FParams;
|
||||
end;
|
||||
|
||||
{ TRPCError }
|
||||
|
||||
TRPCError = record
|
||||
ID : NativeInt;
|
||||
Code : NativeInt;
|
||||
Message : String;
|
||||
ErrorClass : String;
|
||||
Procedure FromValue(Err : JSValue);
|
||||
end;
|
||||
|
||||
{ TRPCResponse }
|
||||
|
||||
TRPCResponse = Record
|
||||
isOK : Boolean;
|
||||
ID : NativeInt;
|
||||
Error : TRPCError;
|
||||
HasError : Boolean;
|
||||
Result : JSValue;
|
||||
Version : String;
|
||||
Procedure FromObject(Obj : TJSObject);
|
||||
end;
|
||||
|
||||
TRPCFailureCallBack = reference to Procedure (Sender : TObject; const aError : TRPCError);
|
||||
TRPCResultCallBack = reference to Procedure (Sender : TObject; const aResult : JSValue);
|
||||
TRPCUnexpectedErrorCallback = Procedure (Sender : TObject; Const aStage : String; E : Exception) of object;
|
||||
|
||||
TRPCOption = (roParamsAsObject,roFullMethodName,roUseBatch,roAutoBatch,roForceArray);
|
||||
TRPCOptions = Set of TRPCOption;
|
||||
|
||||
TRPCRequest = Record
|
||||
IsNotification : Boolean;
|
||||
ClassName : String;
|
||||
MethodName : String;
|
||||
ID : NativeInt;
|
||||
Params : JSValue;
|
||||
OnFailure : TRPCFailureCallBack;
|
||||
OnSuccess : TRPCResultCallBack;
|
||||
end;
|
||||
|
||||
{ TRPCBatch }
|
||||
|
||||
TRPCBatch = Record
|
||||
Requests : Array of TRPCRequest;
|
||||
ID : NativeInt;
|
||||
Function GetRequest(aID : NativeInt; DoRemove : Boolean) : TRPCRequest;
|
||||
end;
|
||||
|
||||
TRPCConfigRequest = procedure (sender : TObject; aConfig : TJSObject) of object;
|
||||
TRPCHeadersRequest = procedure (sender : TObject; aHeaders : TStrings) of object;
|
||||
|
||||
{ TRPCClient }
|
||||
TRPCClient = Class(TComponent)
|
||||
private
|
||||
FBatchTimeout: Integer;
|
||||
FCustomHeaders: TStrings;
|
||||
FJSONRPCversion: String;
|
||||
FOnConfigRequest: TRPCConfigRequest;
|
||||
FOnCustomHeaders: TRPCHeadersRequest;
|
||||
FOnUnexpectedError: TRPCUnexpectedErrorCallback;
|
||||
FOptions: TRPCoptions;
|
||||
FPendingBatches : TJSObject;
|
||||
FURL: String;
|
||||
FBatch : TRPCBatch;
|
||||
FCurrentBatchTimeout : Integer;
|
||||
FRequestID : NativeInt;
|
||||
FBatchID: NativeInt;
|
||||
procedure SetCustomHeaders(AValue: TStrings);
|
||||
procedure SetOptions(AValue: TRPCoptions);
|
||||
procedure SetURL(AValue: String);
|
||||
Protected
|
||||
// Handle unexpected error during callbacks
|
||||
procedure HandleUnexpectedError(const aStage: String; E: Exception);
|
||||
// Find batch with ID equal to aBatch in list of pending batches. If DoRemove, the record is removed from the list.
|
||||
function GetBatch(aBatchID: NativeInt; DoRemove: Boolean): TRPCBatch;
|
||||
// Convert JS value to TRPCError. Calls TRPCError.FromValue
|
||||
function ValueToError(Err: JSValue): TRPCError; virtual;
|
||||
// Convert JS object to TRPResponse. Calls TRPCResponse.FromObject
|
||||
function ResponseFromObject(aObj: TJSObject): TRPCResponse; virtual;
|
||||
// Remove batch from pending batches, calling each OnFailure with aError
|
||||
procedure RemoveFromPending(aBatchID: NativeInt; aError: TRPCError); virtual; overload;
|
||||
// Depending on results, call requests handlers with result/error. Remove batch from pending batches if batch is empty.
|
||||
procedure RemoveFromPending(aBatchID: NativeInt; Res: TJSArray); virtual; overload;
|
||||
// Collect headers for request.
|
||||
procedure GetHeaders(Headers : TStrings); virtual;
|
||||
// Send batch to server
|
||||
procedure DoSendBatch(aBatch: TRPCBatch); virtual;
|
||||
// Configure FETCH request init object
|
||||
procedure ConfigRequest(init: TJSObject); virtual;
|
||||
// Start new request batch. If current batch was not empty, sends it first.
|
||||
Procedure StartRequestBatch; virtual;
|
||||
// Send started request batch. Will stop timer.
|
||||
Procedure SendRequestBatch; virtual;
|
||||
// Add request to current batch. Starts timer if roAutoBatch is in options and the batch is empty.
|
||||
Procedure AddToRequestBatch(aRequest : TRPCRequest); virtual;
|
||||
// Overload for ease of use.
|
||||
Function AddToRequestBatch(aID : NativeInt; const aClassName,aMethodName : String; aParams : JSValue; aOnSuccess : TRPCResultCallBack; aOnFailure: TRPCFailureCallBack) : TRPCRequest; virtual;
|
||||
// perform HTTP request.
|
||||
procedure DoSendHTTPRequest(const aJSON: String; aBatchID : NativeInt); virtual;
|
||||
// For use in service
|
||||
Function DoExecuteRequest(const aClassName,aMethodName : String; aParams : JSValue; aOnSuccess : TRPCResultCallBack = Nil; aOnFailure: TRPCFailureCallBack = nil) : NativeInt;
|
||||
Public
|
||||
Constructor Create(aOwner : TComponent); override;
|
||||
Destructor Destroy; override;
|
||||
// you are responsible for freeing the request params builder.
|
||||
Function CreateRequestParamsBuilder : TRPCRequestParamsBuilder;
|
||||
// Execute a request. Params can be passed as object or array
|
||||
Function ExecuteRequest(const aClassName,aMethodName : String; aParams : TJSArray; aOnSuccess : TRPCResultCallBack = Nil; aOnFailure: TRPCFailureCallBack = nil) : NativeInt;
|
||||
Function ExecuteRequest(const aClassName,aMethodName : String; aParams : TJSObject; aOnSuccess : TRPCResultCallBack = Nil; aOnFailure: TRPCFailureCallBack = nil) : NativeInt;
|
||||
// Close current batch
|
||||
Procedure CloseBatch;
|
||||
Published
|
||||
// URL for RPC server.
|
||||
Property URL : String Read FURL Write SetURL;
|
||||
// Options.
|
||||
Property Options : TRPCoptions Read FOptions Write SetOptions;
|
||||
// If roAutoBatch is in options, this is the timeout between first request and the time the batch is created and sent. Default 100 ms.
|
||||
Property BatchTimeout: Integer Read FBatchTimeout Write FBatchTimeout;
|
||||
// JSON RPC version to send, default: 2.0
|
||||
Property JSONRPCversion : String Read FJSONRPCversion Write FJSONRPCversion;
|
||||
// Custom headers to be sent with each request. NameValueSeparator is colon (:) so add Name:value
|
||||
Property CustomHeaders : TStrings Read FCustomHeaders Write SetCustomHeaders;
|
||||
// Called when configuring a FETCH request
|
||||
Property OnConfigRequest : TRPCConfigRequest Read FOnConfigRequest Write FOnConfigRequest;
|
||||
// Called when collecting headers for a request.
|
||||
Property OnCustomHeaders : TRPCHeadersRequest Read FOnCustomHeaders Write FOnCustomHeaders;
|
||||
// Called when an unexpected error occurs during success/failure callbacks
|
||||
Property OnUnexpectedError : TRPCUnexpectedErrorCallback Read FOnUnexpectedError Write FOnUnexpectedError;
|
||||
end;
|
||||
|
||||
{ TRPCCustomService }
|
||||
|
||||
// Result callback types for all supported types
|
||||
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);
|
||||
|
||||
TRPCCustomService = class(TComponent)
|
||||
private
|
||||
FClient: TRPCClient;
|
||||
FParamBuilder: TRPCRequestParamsBuilder;
|
||||
procedure SetClient(AValue: TRPCClient);
|
||||
protected
|
||||
Procedure AddParam(const aName : string; aValue : NativeInt);
|
||||
Procedure AddParam(const aName : string; aValue : String);
|
||||
Procedure AddParam(const aName : string; aValue : Boolean);
|
||||
Procedure AddParam(const aName : string; aValue : Double);
|
||||
Procedure AddParam(const aName : string; aValue : TJSArray);
|
||||
Procedure AddParam(const aName : string; aValue : TJSObject);
|
||||
Procedure StartParams;
|
||||
Function EndParams : JSValue;
|
||||
Procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
||||
Function RPCClassName : String ; virtual;
|
||||
Function ExecuteRequest(const aClassName,aMethodName : String; aParams : JSValue; aOnSuccess : TRPCResultCallBack = Nil; aOnFailure: TRPCFailureCallBack = nil) : NativeInt;
|
||||
Property ParamBuilder : TRPCRequestParamsBuilder Read FParamBuilder;
|
||||
Published
|
||||
Property RPCClient : TRPCClient Read FClient Write SetClient;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
uses web;
|
||||
|
||||
{ TRPCCustomService }
|
||||
|
||||
procedure TRPCCustomService.SetClient(AValue: TRPCClient);
|
||||
begin
|
||||
if FClient=AValue then Exit;
|
||||
if Assigned(FClient) then
|
||||
FClient.RemoveFreeNotification(Self);
|
||||
FClient:=AValue;
|
||||
if Assigned(FClient) then
|
||||
FClient.FreeNotification(Self);
|
||||
end;
|
||||
|
||||
procedure TRPCCustomService.AddParam(const aName: string; aValue: NativeInt);
|
||||
begin
|
||||
ParamBuilder.AddArg(aName,aValue);
|
||||
end;
|
||||
|
||||
procedure TRPCCustomService.AddParam(const aName: string; aValue: String);
|
||||
begin
|
||||
ParamBuilder.AddArg(aName,aValue);
|
||||
end;
|
||||
|
||||
procedure TRPCCustomService.AddParam(const aName: string; aValue: Boolean);
|
||||
begin
|
||||
ParamBuilder.AddArg(aName,aValue);
|
||||
end;
|
||||
|
||||
procedure TRPCCustomService.AddParam(const aName: string; aValue: Double);
|
||||
begin
|
||||
ParamBuilder.AddArg(aName,aValue);
|
||||
end;
|
||||
|
||||
procedure TRPCCustomService.AddParam(const aName: string; aValue: TJSArray);
|
||||
begin
|
||||
ParamBuilder.AddArg(aName,aValue);
|
||||
end;
|
||||
|
||||
procedure TRPCCustomService.AddParam(const aName: string; aValue: TJSObject);
|
||||
begin
|
||||
ParamBuilder.AddArg(aName,aValue);
|
||||
end;
|
||||
|
||||
procedure TRPCCustomService.StartParams;
|
||||
begin
|
||||
if Assigned(FParamBuilder) then
|
||||
Raise ERPCClient.Create('Parameter building already in progress');
|
||||
if Not Assigned(RPCClient) then
|
||||
Raise ERPCClient.Create('Parameter building cannot be started without RPCClient');
|
||||
FParamBuilder:=RPCClient.CreateRequestParamsBuilder;
|
||||
end;
|
||||
|
||||
function TRPCCustomService.EndParams: JSValue;
|
||||
begin
|
||||
if not Assigned(FParamBuilder) then
|
||||
Raise ERPCClient.Create('No parameter builder was started. Call StartParams first');
|
||||
Result:=ParamBuilder.DoGetArgs;
|
||||
FreeAndNil(FParamBuilder);
|
||||
end;
|
||||
|
||||
procedure TRPCCustomService.Notification(AComponent: TComponent;
|
||||
Operation: TOperation);
|
||||
begin
|
||||
inherited Notification(AComponent, Operation);
|
||||
if Operation=opRemove then
|
||||
if AComponent=FClient then
|
||||
FClient:=Nil;
|
||||
end;
|
||||
|
||||
function TRPCCustomService.RPCClassName: String;
|
||||
begin
|
||||
Result:='';
|
||||
end;
|
||||
|
||||
function TRPCCustomService.ExecuteRequest(const aClassName,
|
||||
aMethodName: String; aParams: JSValue; aOnSuccess: TRPCResultCallBack;
|
||||
aOnFailure: TRPCFailureCallBack): NativeInt;
|
||||
begin
|
||||
if Not Assigned(RPCClient) then
|
||||
Raise ERPCClient.Create('ExecuteRequest cannot be called without RPCClient');
|
||||
Result:=RPCClient.DoExecuteRequest(aClassName,aMethodName,aParams,aOnSuccess,aOnFailure);
|
||||
end;
|
||||
|
||||
{ TRPCBatch }
|
||||
|
||||
function TRPCBatch.GetRequest(aID: NativeInt; DoRemove: Boolean): TRPCRequest;
|
||||
|
||||
Var
|
||||
Len,Idx : Integer;
|
||||
|
||||
begin
|
||||
Idx:=0;
|
||||
Len:=Length(Requests);
|
||||
While (Idx<Len) and (Requests[Idx].ID<>aID) do
|
||||
Inc(Idx);
|
||||
if (Idx<Len) then
|
||||
begin
|
||||
Result:=Requests[Idx];
|
||||
if DoRemove then
|
||||
Delete(Requests,Idx,1);
|
||||
end
|
||||
else
|
||||
Result:=Default(TRPCRequest);
|
||||
end;
|
||||
|
||||
{ TRPCError }
|
||||
|
||||
procedure TRPCError.FromValue(Err: JSValue);
|
||||
Var
|
||||
aErrJS : TJSError absolute Err;
|
||||
aErrEx : Exception absolute Err;
|
||||
aErrObj : TJSObject absolute Err;
|
||||
|
||||
begin
|
||||
Code:=0;
|
||||
if isObject(Err) then
|
||||
begin
|
||||
if Err is TJSError then
|
||||
begin
|
||||
Self.Code:=-2;
|
||||
Self.Message:=aErrJS.Message;
|
||||
if aErrJS.hasOwnProperty('status') and (isNumber(aErrJS['status'])) then
|
||||
Self.Code:=Integer(aErrJS['status']);
|
||||
Self.ErrorClass:='Error';
|
||||
end
|
||||
else if Err is Exception then
|
||||
begin
|
||||
Self.Code:=-3;
|
||||
Self.Message:=aErrEx.Message;
|
||||
Self.ErrorClass:=aErrEx.ClassName;
|
||||
end
|
||||
else // TJSObject
|
||||
begin
|
||||
Self.Code:=-4;
|
||||
if aErrObj.hasOwnProperty('code') and (isNumber(aErrJS['code'])) then
|
||||
Self.Code:=Integer(aErrJS['code']);
|
||||
if aErrJS.hasOwnProperty('message') and (isString(aErrJS['message'])) then
|
||||
Self.Message:=String(aErrJS['message']);
|
||||
Self.ErrorClass:='Object';
|
||||
end
|
||||
end;
|
||||
if Self.Code=0 then
|
||||
begin
|
||||
Self.Code:=-1;
|
||||
Self.Message:='Unknown error';
|
||||
end
|
||||
|
||||
end;
|
||||
|
||||
{ TRPCResponse }
|
||||
|
||||
procedure TRPCResponse.FromObject(Obj: TJSObject);
|
||||
|
||||
|
||||
begin
|
||||
IsOK:=Obj.hasOwnProperty('id') and isNumber(Obj['id']);
|
||||
if ISOK then
|
||||
ID:=NativeInt(Obj['id']);
|
||||
HasError:=Obj.hasOwnProperty('error') and isObject(Obj['error']);
|
||||
if HasError then
|
||||
Error.FromValue(Obj['error'])
|
||||
else
|
||||
begin
|
||||
Result:=Obj['result'];
|
||||
if Obj.hasOwnProperty('jsonrpc') and isString(Obj['jsonrpc']) then
|
||||
Version:=String(Obj['jsonrpc']);
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TRPCRequestParamsBuilder }
|
||||
|
||||
|
||||
procedure TRPCRequestParamsBuilder.AddArg(const aName: string; aValue: NativeInt);
|
||||
begin
|
||||
DoAddArg(aName,aValue);
|
||||
end;
|
||||
|
||||
procedure TRPCRequestParamsBuilder.AddArg(const aName: string; aValue: String);
|
||||
begin
|
||||
DoAddArg(aName,aValue);
|
||||
end;
|
||||
|
||||
procedure TRPCRequestParamsBuilder.AddArg(const aName: string; aValue: Boolean);
|
||||
begin
|
||||
DoAddArg(aName,aValue);
|
||||
end;
|
||||
|
||||
procedure TRPCRequestParamsBuilder.AddArg(const aName: string; aValue: Double);
|
||||
begin
|
||||
DoAddArg(aName,aValue);
|
||||
end;
|
||||
|
||||
procedure TRPCRequestParamsBuilder.AddArg(const aName: string; aValue: TJSArray);
|
||||
begin
|
||||
DoAddArg(aName,aValue);
|
||||
end;
|
||||
|
||||
procedure TRPCRequestParamsBuilder.AddArg(const aName: string; aValue: TJSObject);
|
||||
begin
|
||||
DoAddArg(aName,aValue);
|
||||
end;
|
||||
|
||||
{ TRPCObjectRequestParamsBuilder }
|
||||
|
||||
procedure TRPCObjectRequestParamsBuilder.DoAddArg(const aName: String; aValue: JSValue
|
||||
);
|
||||
begin
|
||||
FParams.Properties[aName]:=aValue;
|
||||
end;
|
||||
|
||||
function TRPCObjectRequestParamsBuilder.DoGetArgs: JSValue;
|
||||
begin
|
||||
Result:=FParams;
|
||||
end;
|
||||
|
||||
constructor TRPCObjectRequestParamsBuilder.Create(aParams: TJSObject);
|
||||
begin
|
||||
FParams:=aParams;
|
||||
end;
|
||||
|
||||
{ TRPCArrayRequestParamsBuilder }
|
||||
|
||||
function TRPCArrayRequestParamsBuilder.DoGetArgs: JSValue;
|
||||
begin
|
||||
Result:=FParams;
|
||||
end;
|
||||
|
||||
procedure TRPCArrayRequestParamsBuilder.DoAddArg(const aName: String; aValue: JSValue
|
||||
);
|
||||
begin
|
||||
FParams.push(aValue);
|
||||
if aName='' then;
|
||||
end;
|
||||
|
||||
constructor TRPCArrayRequestParamsBuilder.Create(aParams: TJSArray);
|
||||
begin
|
||||
FParams:=AParams;
|
||||
end;
|
||||
|
||||
{ TRPCClient }
|
||||
|
||||
procedure TRPCClient.SetOptions(AValue: TRPCoptions);
|
||||
|
||||
begin
|
||||
if FOptions=AValue then Exit;
|
||||
FOptions:=AValue;
|
||||
end;
|
||||
|
||||
procedure TRPCClient.SetURL(AValue: String);
|
||||
begin
|
||||
if FURL=AValue then Exit;
|
||||
FURL:=AValue;
|
||||
end;
|
||||
|
||||
procedure TRPCClient.StartRequestBatch;
|
||||
begin
|
||||
if Length(FBatch.Requests)>0 then
|
||||
SendRequestBatch
|
||||
else
|
||||
begin
|
||||
SetLength(FBatch.Requests,0);
|
||||
Inc(FBatchID);
|
||||
FBatch.ID:=FBatchID;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TRPCClient.CloseBatch;
|
||||
|
||||
begin
|
||||
if FCurrentBatchTimeout>0 then
|
||||
begin
|
||||
window.clearTimeout(FCurrentBatchTimeout);
|
||||
FCurrentBatchTimeout:=0;
|
||||
end;
|
||||
SendRequestBatch;
|
||||
end;
|
||||
|
||||
function TRPCClient.GetBatch(aBatchID: NativeInt; DoRemove: Boolean): TRPCBatch;
|
||||
|
||||
|
||||
Var
|
||||
BID : String;
|
||||
|
||||
begin
|
||||
BID:=IntToStr(aBatchID);
|
||||
if FPendingBatches.hasOwnProperty(BID) then
|
||||
begin
|
||||
Result:=TRPCBatch(FPendingBatches[BID]);
|
||||
if DoRemove then
|
||||
FPendingBatches[BID]:=undefined;
|
||||
end
|
||||
else
|
||||
Result:=Default(TRPCBatch);
|
||||
end;
|
||||
|
||||
function TRPCClient.ResponseFromObject(aObj: TJSObject): TRPCResponse;
|
||||
|
||||
begin
|
||||
Result:=Default(TRPCResponse);
|
||||
Result.FromObject(aObj);
|
||||
end;
|
||||
|
||||
procedure TRPCClient.HandleUnexpectedError(const aStage : String; E : Exception);
|
||||
|
||||
begin
|
||||
if Assigned(FOnUnexpectedError) then
|
||||
FOnUnexpectedError(Self,aStage,E);
|
||||
end;
|
||||
|
||||
procedure TRPCClient.RemoveFromPending(aBatchID : NativeInt; Res: TJSArray);
|
||||
|
||||
var
|
||||
aReq : TRPCRequest;
|
||||
aResp : TRPCResponse;
|
||||
I : Integer;
|
||||
aBatch : TRPCBatch;
|
||||
|
||||
begin
|
||||
aBatch:=GetBatch(aBatchID,False);
|
||||
For I:=0 to Res.Length-1 do
|
||||
if isObject(Res[i]) then
|
||||
begin
|
||||
aResp:=ResponseFromObject(TJSObject(Res[i]));
|
||||
if aResp.IsOK then
|
||||
begin
|
||||
aReq:=aBatch.getRequest(aResp.ID,True);
|
||||
if (aReq.ID=aResp.ID) then
|
||||
if aResp.HasError then
|
||||
begin
|
||||
If Assigned(aReq.OnFailure) then
|
||||
try
|
||||
aReq.OnFailure(Self,aResp.Error);
|
||||
except
|
||||
On E : exception do
|
||||
HandleUnexpectedError('OnFailure',E);
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
If Assigned(aReq.OnSuccess) then
|
||||
try
|
||||
aReq.OnSuccess(Self,aResp.Result);
|
||||
except
|
||||
On E : exception do
|
||||
HandleUnexpectedError('OnSuccess',E);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
// Remove if all requests treated
|
||||
if Length(aBatch.Requests)=0 then
|
||||
aBatch:=GetBatch(aBatchID,True);
|
||||
end;
|
||||
|
||||
procedure TRPCClient.RemoveFromPending(aBatchID : NativeInt; aError : TRPCError);
|
||||
|
||||
Var
|
||||
aBatch : TRPCBatch;
|
||||
aReq : TRPCRequest;
|
||||
|
||||
begin
|
||||
aBatch:=GetBatch(aBatchID,True);
|
||||
For aReq in aBatch.Requests do
|
||||
if Assigned(aReq.OnFailure) then
|
||||
Try
|
||||
aReq.OnFailure(Self,aError);
|
||||
except
|
||||
On E : Exception do
|
||||
HandleUnexpectedError('OnFailure',E);
|
||||
end;
|
||||
SetLength(aBatch.Requests,0);
|
||||
end;
|
||||
|
||||
function TRPCClient.ValueToError(Err: JSValue): TRPCError;
|
||||
|
||||
begin
|
||||
Result:=Default(TRPCError);
|
||||
Result.FromValue(Err);
|
||||
end;
|
||||
|
||||
procedure TRPCClient.DoSendHTTPRequest(const aJSON : String; aBatchID : NativeInt);
|
||||
|
||||
function dofail(aValue: JSValue): JSValue;
|
||||
|
||||
Var
|
||||
Err : TRPCError;
|
||||
|
||||
begin
|
||||
Result:=undefined;
|
||||
Err:=ValueToError(aValue);
|
||||
RemoveFromPending(aBatchID, Err)
|
||||
end;
|
||||
|
||||
function processresponse (J : JSValue) : jsvalue;
|
||||
|
||||
begin
|
||||
Result:=undefined;
|
||||
if isArray(J) then
|
||||
RemoveFromPending(aBatchID,TJSArray(J))
|
||||
else
|
||||
RemoveFromPending(aBatchID,TJSArray.New(J));
|
||||
end;
|
||||
|
||||
|
||||
function doOK(aValue: JSValue): JSValue;
|
||||
|
||||
Var
|
||||
Req : TJSResponse absolute aValue;
|
||||
Err : TRPCError;
|
||||
|
||||
begin
|
||||
Result:=Null;
|
||||
if not Req.ok then
|
||||
begin
|
||||
Err.Code:=Req.status;
|
||||
Err.Message:=Req.statusText;
|
||||
Err.ErrorClass:='HTTP';
|
||||
RemoveFromPending(aBatchID,Err);
|
||||
end
|
||||
else
|
||||
Req.json._then(@processresponse,@DoFail);
|
||||
end;
|
||||
|
||||
|
||||
Var
|
||||
init,Headers : TJSObject;
|
||||
lheaders : TStringList;
|
||||
I : Integer;
|
||||
N,V : String;
|
||||
|
||||
begin
|
||||
init:=New([
|
||||
'method','POST',
|
||||
'cache','no-cache',
|
||||
'body',aJSON
|
||||
]);
|
||||
Headers:=TJSObject.New;
|
||||
lheaders:=TStringList.Create;
|
||||
try
|
||||
GetHeaders(lHeaders);
|
||||
for I:=0 to lHeaders.Count-1 do
|
||||
begin
|
||||
lheaders.GetNameValue(I,N,V);
|
||||
headers[N]:=V;
|
||||
end;
|
||||
init['headers']:=Headers;
|
||||
finally
|
||||
lHeaders.Free;
|
||||
end;
|
||||
ConfigRequest(init);
|
||||
window.fetch(URL,init)._then(@doOK,@dofail);
|
||||
end;
|
||||
|
||||
function TRPCClient.DoExecuteRequest(const aClassName, aMethodName: String;
|
||||
aParams: JSValue; aOnSuccess: TRPCResultCallBack;
|
||||
aOnFailure: TRPCFailureCallBack): NativeInt;
|
||||
begin
|
||||
If isArray(AParams) then
|
||||
Result:=ExecuteRequest(aClassName,aMethodName,TJSArray(aParams),aOnSuccess,aOnFailure)
|
||||
else if isObject(AParams) then
|
||||
Result:=ExecuteRequest(aClassName,aMethodName,TJSObject(aParams),aOnSuccess,aOnFailure)
|
||||
else if Not (isUndefined(AParams) or isNull(aParams)) then
|
||||
Result:=ExecuteRequest(aClassName,aMethodName,TJSArray.New(aParams),aOnSuccess,aOnFailure)
|
||||
else
|
||||
Result:=ExecuteRequest(aClassName,aMethodName,TJSArray.New(),aOnSuccess,aOnFailure)
|
||||
|
||||
end;
|
||||
|
||||
procedure TRPCClient.GetHeaders(Headers: TStrings);
|
||||
|
||||
begin
|
||||
Headers.AddStrings(FCustomHeaders);
|
||||
end;
|
||||
|
||||
procedure TRPCClient.ConfigRequest(init : TJSObject);
|
||||
|
||||
begin
|
||||
if Assigned(FOnConfigRequest) then
|
||||
FOnConfigRequest(Self,init);
|
||||
end;
|
||||
|
||||
procedure TRPCClient.DoSendBatch(aBatch : TRPCBatch);
|
||||
|
||||
Var
|
||||
aRequests : TJSArray;
|
||||
aRequest : TRPCRequest;
|
||||
aSerialized : TJSObject;
|
||||
N : String;
|
||||
aJSON : String;
|
||||
|
||||
begin
|
||||
aRequests:=TJSArray.New;
|
||||
For aRequest in aBatch.Requests do
|
||||
begin
|
||||
aSerialized:=TJSObject.New;
|
||||
if Not aRequest.IsNotification then
|
||||
aSerialized['id']:=aRequest.ID;
|
||||
aSerialized['jsonrpc']:=JSONRPCversion;
|
||||
if Assigned(aRequest.Params) then
|
||||
aSerialized['params']:=aRequest.Params;
|
||||
N:=aRequest.MethodName;
|
||||
if roFullMethodName in FOptions then
|
||||
begin
|
||||
if aRequest.ClassName<>'' then
|
||||
N:=aRequest.ClassName+'.'+N;
|
||||
end
|
||||
else
|
||||
begin
|
||||
if aRequest.ClassName<>'' then
|
||||
aSerialized['class']:=aRequest.ClassName;
|
||||
end;
|
||||
aSerialized['method']:=N;
|
||||
aRequests.Push(aSerialized);
|
||||
end;
|
||||
if (aRequests.Length=1) and not (roForceArray in FOptions) then
|
||||
aJSON:=TJSJSON.stringify(aRequests[0])
|
||||
else
|
||||
aJSON:=TJSJSON.stringify(aRequests);
|
||||
For aRequest in aBatch.Requests do
|
||||
FPendingBatches[IntToStr(aBatch.Id)]:=JSValue(aBatch);
|
||||
try
|
||||
DoSendHTTPRequest(aJSON,aBatch.ID);
|
||||
finally
|
||||
aRequests:=nil;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TRPCClient.SetCustomHeaders(AValue: TStrings);
|
||||
begin
|
||||
if FCustomHeaders=AValue then Exit;
|
||||
FCustomHeaders.Assign(AValue);
|
||||
end;
|
||||
|
||||
|
||||
procedure TRPCClient.SendRequestBatch;
|
||||
|
||||
Var
|
||||
aBatch : TRPCBatch;
|
||||
|
||||
begin
|
||||
aBatch:=FBatch;
|
||||
SetLength(FBatch.Requests,0);
|
||||
FBatch.ID:=0;
|
||||
if (Length(aBatch.Requests)>0) then
|
||||
DoSendBatch(aBatch);
|
||||
if FCurrentBatchTimeout>0 then
|
||||
begin
|
||||
Window.ClearTimeout(FCurrentBatchTimeout);
|
||||
FCurrentBatchTimeout:=0;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TRPCClient.AddToRequestBatch(aRequest: TRPCRequest);
|
||||
|
||||
Var
|
||||
Idx : Integer;
|
||||
|
||||
begin
|
||||
// Send pending, if any..
|
||||
if Not (roUseBatch in Options) then
|
||||
SendRequestBatch;
|
||||
if FBatch.ID=0 then
|
||||
begin
|
||||
Inc(FBatchID);
|
||||
FBatch.ID:=FBatchID;
|
||||
end;
|
||||
Idx:=Length(FBatch.Requests);
|
||||
SetLength(FBatch.Requests,Idx+1);
|
||||
FBatch.Requests[Idx]:=aRequest;
|
||||
if Not (roUseBatch in Options) then
|
||||
SendRequestBatch
|
||||
else
|
||||
if (roAutoBatch in FOptions) and (FCurrentBatchTimeout=0) then
|
||||
FCurrentBatchTimeout:=window.SetTimeout(@SendRequestBatch);
|
||||
end;
|
||||
|
||||
function TRPCClient.AddToRequestBatch(aID: NativeInt; const aClassName,
|
||||
aMethodName: String; aParams: JSValue; aOnSuccess: TRPCResultCallBack;
|
||||
aOnFailure: TRPCFailureCallBack): TRPCRequest;
|
||||
|
||||
begin
|
||||
Result:=Default(TRPCRequest);
|
||||
Result.ID:=aID;
|
||||
Result.ClassName:=aClassName;
|
||||
Result.MethodName:=aMethodName;
|
||||
Result.Params:=aParams;
|
||||
Result.OnFailure:=aOnFailure;
|
||||
Result.OnSuccess:=aOnSuccess;
|
||||
AddToRequestBatch(Result);
|
||||
if not (roUseBatch in Options) then
|
||||
SendRequestBatch;
|
||||
end;
|
||||
|
||||
constructor TRPCClient.Create(aOwner: TComponent);
|
||||
begin
|
||||
inherited Create(aOwner);
|
||||
FPendingBatches:=TJSObject.New;
|
||||
FBatchTimeOut:=100;
|
||||
JSONRPCVersion:=DefaultJSONRPCversion;
|
||||
FCustomHeaders:=TStringList.Create;
|
||||
FCustomHeaders.NameValueSeparator:=':';
|
||||
end;
|
||||
|
||||
destructor TRPCClient.Destroy;
|
||||
begin
|
||||
FreeAndNil(FCustomHeaders);
|
||||
FPendingBatches:=Nil;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TRPCClient.CreateRequestParamsBuilder: TRPCRequestParamsBuilder;
|
||||
begin
|
||||
if roParamsAsObject in Options then
|
||||
Result:=TRPCObjectRequestParamsBuilder.Create(TJSObject.New)
|
||||
else
|
||||
Result:=TRPCArrayRequestParamsBuilder.Create(TJSArray.New);
|
||||
end;
|
||||
|
||||
function TRPCClient.ExecuteRequest(const aClassName, aMethodName: String;
|
||||
aParams: TJSArray; aOnSuccess: TRPCResultCallBack; aOnFailure: TRPCFailureCallBack): NativeInt;
|
||||
|
||||
Var
|
||||
Req : TRPCRequest;
|
||||
|
||||
begin
|
||||
Inc(FRequestID);
|
||||
Req:=AddToRequestBatch(FRequestID,aClassName,aMethodName,aParams,aOnSuccess,aOnFailure);
|
||||
Result:=Req.ID;
|
||||
end;
|
||||
|
||||
function TRPCClient.ExecuteRequest(const aClassName, aMethodName: String;
|
||||
aParams: TJSObject; aOnSuccess: TRPCResultCallBack;
|
||||
aOnFailure: TRPCFailureCallBack): NativeInt;
|
||||
Var
|
||||
Req : TRPCRequest;
|
||||
|
||||
begin
|
||||
Inc(FRequestID);
|
||||
Req:=AddToRequestBatch(FRequestID,aClassName,aMethodName,aParams,aOnSuccess,aOnFailure);
|
||||
Result:=Req.ID;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
682
packages/fcl-rpc/fprpccodegen.pp
Normal file
682
packages/fcl-rpc/fprpccodegen.pp
Normal file
@ -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.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user