mirror of
https://gitlab.com/freepascal.org/fpc/pas2js.git
synced 2025-08-22 14:09:09 +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