mORMot and Open Source friends
Check-in [7b4dd9f2d3]
Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
SHA1:7b4dd9f2d3e6d36e3e173c041947f1d52c146858
Date: 2014-01-07 11:02:41
User: abouchez
Comment:
  • TSQLRestRoutingREST will now recognize several URI schemes: /root/Calculator.Add + body, /root/Calculator.Add?+%5B+1%2C2+%5D, or even root/Calculator.Add?n1=1&n2=2 - and /root/Calculator/Add as a valid alternative to default /root/Calculator.Add, if needed * added TServiceMethodArgument.AddJSON/AddValueJSON/AddDefaultJSON methods
Tags And Properties
Context
2014-01-07
14:43
[39036dba97] reverted ticket [73da2c17b1] about Accept-Encoding header in THttpApiServer (user: abouchez, tags: trunk)
11:02
[7b4dd9f2d3]
  • TSQLRestRoutingREST will now recognize several URI schemes: /root/Calculator.Add + body, /root/Calculator.Add?+%5B+1%2C2+%5D, or even root/Calculator.Add?n1=1&n2=2 - and /root/Calculator/Add as a valid alternative to default /root/Calculator.Add, if needed * added TServiceMethodArgument.AddJSON/AddValueJSON/AddDefaultJSON methods
(user: abouchez, tags: trunk)
10:55
[21e882fef4] added optional default value parameter to TSynNameValue.Value() method (user: abouchez, tags: trunk)
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to SQLite3/Documentation/Synopse SQLite3 Framework.pro.

7272
7273
7274
7275
7276
7277
7278
7279
7280
7281
7282
7283
7284
7285
7286
7287
7288

7289
7290
7291
7292
7293
7294
7295
7296
7297
7298
7299
7300
7301
7302

7303













7304
7305
7306
7307
7308
7309
7310
:   Request format
As stated above, there are several available modes of routing, defined by a given {\f1\fs20 class}, inheriting from {\f1\fs20 TSQLRestServerURIContext}:
\graph HierTSQLRestServerURIContext Routing via TSQLRestServerURIContext classes hierarchy
\TSQLRestRoutingJSON_RPC\TSQLRestServerURIContext
\TSQLRestRoutingREST\TSQLRestServerURIContext
\
The corresponding description may be:
|%20%40%40
||\b {\f1\fs20 TSQLRestRoutingREST}|{\f1\fs20 TSQLRestRoutingJSON_RPC}\b0
|Description|URI-based layout|@*JSON-RPC@ mode
|Default|Yes|No
|URI scheme|/Model/Interface.Method[/ClientDrivenID]|/Model/Interface
|Body content|JSON array of parameters|{\f1\fs20 \{"method":"{\i MethodName}","params":[...][,"id":{\i ClientDrivenID}]\}}
|Security|RESTful @*authentication@ for each method|RESTful authentication for the whole service (interface)
|Speed|10% faster|10% slower
|%
The routing to be used is defined globally in the {\f1\fs20 TSQLRest.ServiceRouting} property, and should match on both client and server side, of course. Never assign the abstract {\f1\fs20 TSQLRestServerURIContext} to this property.

In the default {\f1\fs20 TSQLRestRoutingREST} mode, both service and operation (i.e. interface and method) are identified within the URI. And the message body is a standard JSON array of the supplied parameters (i.e. all {\f1\fs20 const} and {\f1\fs20 var} parameters).
Here is typical request for {\f1\fs20 ICalculator.Add}:
$ POST /root/Calculator.Add
$ (...)
$ [1,2]
Here we use a {\f1\fs20 POST} verb, but the framework will also allow {\f1\fs20 GET}, if needed (e.g. from a ). The pure Delphi client implementation will use only {\f1\fs20 POST}.
For a {\f1\fs20 sicClientDriven} mode service, the needed instance ID is appended to the URI:
$ POST /root/ComplexNumber.Add/1234
$ (...)
$ [20,30]
Here, {\f1\fs20 1234} is the identifier of the server-side instance ID, which is used to track the instance life-time, in {\f1\fs20 sicClientDriven} mode.
One benefit of using URI is that it will be more secure in our RESTful authentication scheme - see @18@: each method (and even any client driven session ID) will be signed properly.
In this {\f1\fs20 TSQLRestRoutingREST} mode, the server is also able to retrieve the parameters from the URI, if the message body is left void. This is not used from a Delphi client (since it will be more complex and therefore slower), but it can be used for a client, if needed:
$ POST root/Calculator.Add?+%5B+1%2C2+%5D

In the above line, {\f1\fs20 +%5B+1%2C2+%5D} will be decoded as {\f1\fs20 [1,2]} on the server side. In conjunction with the use of a {\f1\fs20 GET} verb, it may be more suitable for a remote @*AJAX@ connection.













If {\f1\fs20 TSQLRestRoutingJSON_RPC} mode is used, the URI will define the interface, and then the method name will be inlined with parameters, e.g.
$ POST /root/Calculator
$ (...)
$ {"method":"Add","params":[1,2],"id":0}
Here, the {\f1\fs20 "id"} field can be not set (and even not existing), since it has no purpose in {\f1\fs20 sicShared} mode.
For a {\f1\fs20 sicClientDriven} mode service:
$ POST /root/ComplexNumber







|

|

|
|
|


|
>





|




|
<


>

>
>
>
>
>
>
>
>
>
>
>
>
>







7272
7273
7274
7275
7276
7277
7278
7279
7280
7281
7282
7283
7284
7285
7286
7287
7288
7289
7290
7291
7292
7293
7294
7295
7296
7297
7298
7299
7300

7301
7302
7303
7304
7305
7306
7307
7308
7309
7310
7311
7312
7313
7314
7315
7316
7317
7318
7319
7320
7321
7322
7323
7324
:   Request format
As stated above, there are several available modes of routing, defined by a given {\f1\fs20 class}, inheriting from {\f1\fs20 TSQLRestServerURIContext}:
\graph HierTSQLRestServerURIContext Routing via TSQLRestServerURIContext classes hierarchy
\TSQLRestRoutingJSON_RPC\TSQLRestServerURIContext
\TSQLRestRoutingREST\TSQLRestServerURIContext
\
The corresponding description may be:
|%20%57%33
||\b {\f1\fs20 TSQLRestRoutingREST}|{\f1\fs20 TSQLRestRoutingJSON_RPC}\b0
|Description|@*REST@ful mode|@*JSON-RPC@ mode
|Default|Yes|No
|URI scheme|{\f1\fs20 /Model/Interface.Method[/ClientDrivenID]}\line or {\f1\fs20 /Model/Interface/Method[/ClientDrivenID]}\line + optional URI-encoded params|{\f1\fs20 /Model/Interface}
|Body content|JSON array of parameters\line or void if parameters were encoded at URI|{\f1\fs20 \{"method":"{\i MethodName}",\line  "params":[...]\line [,"id":{\i ClientDrivenID}]\}}
|Security|RESTful @*authentication@ for each method\line or for the whole service (interface)|RESTful authentication for the whole service (interface)
|Speed|10% faster|10% slower
|%
The routing to be used is defined globally in the {\f1\fs20 TSQLRest.ServiceRouting} property, and should match on both client and server side, of course. Of course, you should {\i never} assign the abstract {\f1\fs20 TSQLRestServerURIContext} to this property.
:    REST mode
In the default {\f1\fs20 TSQLRestRoutingREST} mode, both service and operation (i.e. interface and method) are identified within the URI. And the message body is a standard JSON array of the supplied parameters (i.e. all {\f1\fs20 const} and {\f1\fs20 var} parameters).
Here is typical request for {\f1\fs20 ICalculator.Add}:
$ POST /root/Calculator.Add
$ (...)
$ [1,2]
Here we use a {\f1\fs20 POST} verb, but the framework will also allows other methods like {\f1\fs20 GET}, if needed (e.g. from a regular browser). The pure Delphi client implementation will use only {\f1\fs20 POST}.
For a {\f1\fs20 sicClientDriven} mode service, the needed instance ID is appended to the URI:
$ POST /root/ComplexNumber.Add/1234
$ (...)
$ [20,30]
Here, {\f1\fs20 1234} is the identifier of the server-side instance ID, which is used to track the instance life-time, in {\f1\fs20 sicClientDriven} mode.  One benefit of transmitting the Client Session ID within the URI is that it will be more secure in our RESTful authentication scheme - see @18@: each method (and even any client driven session ID) will be signed properly.

In this {\f1\fs20 TSQLRestRoutingREST} mode, the server is also able to retrieve the parameters from the URI, if the message body is left void. This is not used from a Delphi client (since it will be more complex and therefore slower), but it can be used for a client, if needed:
$ POST root/Calculator.Add?+%5B+1%2C2+%5D
$ GET root/Calculator.Add?+%5B+1%2C2+%5D
In the above line, {\f1\fs20 +%5B+1%2C2+%5D} will be decoded as {\f1\fs20 [1,2]} on the server side. In conjunction with the use of a {\f1\fs20 GET} verb, it may be more suitable for a remote @*AJAX@ connection.
As an alternative, you can encode and name the parameters at URI level, in a regular HTML fashion:
$ GET root/Calculator.Add?n1=1&n2=2
Since parameters are named, they can be in any order. And if any parameter is missing, it will be replaced by its default value (e.g. {\f1\fs20 0} for a number or {\f1\fs20 ''} for a {\f1\fs20 string}).
This may be pretty convenient for simple services, consummed from any kind of client.
Note that there is a known size limitation when passing some data with the URI over HTTP. Official RFC 2616 standard advices to limit the URI size to 255 characters, whereas in practice, it sounds safe to transmit up to 2048 characters within the URI. If you want to get rid of this limitation, just use the default transmission of a JSON array as request body.
As an alternative, the URI can be written as {\f1\fs20 /RootName/InterfaceName/MethodName}. It may be more RESTful-compliant, depending on your client policies. The following URIs will therefore be equivalent to the previous requests:
$ POST /root/Calculator/Add
$ POST /root/ComplexNumber/Add/1234
$ POST root/Calculator/Add?+%5B+1%2C2+%5D
$ GET root/Calculator/Add?+%5B+1%2C2+%5D
$ GET root/Calculator/Add?n1=1&n2=2
From a Delphi client, the {\f1\fs20 /RootName/InterfaceName.MethodName} scheme will always be used.
:    JSON-RPC
If {\f1\fs20 TSQLRestRoutingJSON_RPC} mode is used, the URI will define the interface, and then the method name will be inlined with parameters, e.g.
$ POST /root/Calculator
$ (...)
$ {"method":"Add","params":[1,2],"id":0}
Here, the {\f1\fs20 "id"} field can be not set (and even not existing), since it has no purpose in {\f1\fs20 sicShared} mode.
For a {\f1\fs20 sicClientDriven} mode service:
$ POST /root/ComplexNumber

Changes to SQLite3/mORMot.pas.

685
686
687
688
689
690
691




692
693
694
695
696
697
698
...
712
713
714
715
716
717
718

719
720
721
722
723
724
725
....
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
....
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
....
3723
3724
3725
3726
3727
3728
3729




3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743





3744
3745
3746
3747
3748
3749
3750
....
6371
6372
6373
6374
6375
6376
6377
6378









6379
6380
6381
6382
6383
6384
6385
....
6423
6424
6425
6426
6427
6428
6429




6430
6431
6432
6433
6434
6435
6436
....
6443
6444
6445
6446
6447
6448
6449
6450
6451
6452

6453
6454
6455
6456
6457
6458
6459
6460
....
6594
6595
6596
6597
6598
6599
6600

6601
6602
6603

6604
6605
6606
6607
6608
6609
6610
....
7428
7429
7430
7431
7432
7433
7434
7435

7436
7437
7438
7439
7440
7441
7442
....
7658
7659
7660
7661
7662
7663
7664
7665


7666
7667
7668
7669
7670
7671
7672
.....
24182
24183
24184
24185
24186
24187
24188
24189
24190






24191
24192
24193
24194
24195
24196
24197
.....
24672
24673
24674
24675
24676
24677
24678


24679
24680
24681
24682
24683
24684
24685
.....
24828
24829
24830
24831
24832
24833
24834

24835
24836
24837
24838
24839
24840
24841
24842
24843
24844
24845
24846
24847









24848
24849


24850
24851
24852
24853




24854
24855
24856
24857
24858
24859
24860
24861





24862



































24863
24864
24865
24866
24867
24868
24869
.....
24876
24877
24878
24879
24880
24881
24882
24883
24884
24885
24886
24887
24888
24889
24890
24891
24892
24893
24894
24895
24896
24897
24898
.....
24909
24910
24911
24912
24913
24914
24915
24916
24917
24918
24919
24920
24921
24922
24923
.....
24926
24927
24928
24929
24930
24931
24932










24933
24934
24935
24936
24937
24938
24939
.....
32147
32148
32149
32150
32151
32152
32153
32154
32155
32156
32157
32158
32159
32160
32161
32162
32163
32164
32165
32166
32167
32168
32169
32170
32171
32172
32173
32174
32175
32176
32177
32178
32179
32180
32181
32182
32183
32184
32185
32186
32187
32188
.....
32238
32239
32240
32241
32242
32243
32244
32245
32246
32247
32248
32249
32250
32251
32252
32253
32254
32255
32256
32257
32258
32259
32260
32261
32262
32263
32264
32265
32266
.....
32532
32533
32534
32535
32536
32537
32538

32539
32540
32541
32542
32543
32544
32545
.....
32641
32642
32643
32644
32645
32646
32647
32648
32649
32650
32651
32652
32653
32654
32655
32656
32657
32658
32659
32660
32661
32662
32663
32664
32665
32666
32667
32668
32669
32670
32671
32672
32673
32674
32675
32676
32677
32678
32679
32680
32681
32682
32683
32684
32685
32686
32687
32688
32689
32690
32691
32692
32693
32694
32695
32696
32697
32698
32699
32700
.....
32726
32727
32728
32729
32730
32731
32732
32733
32734
32735
32736
32737
32738
32739
32740
.....
32743
32744
32745
32746
32747
32748
32749


32750
32751
32752
32753
32754
32755
32756
.....
32774
32775
32776
32777
32778
32779
32780
32781
32782




32783
32784
32785
32786
32787
32788
32789
.....
33512
33513
33514
33515
33516
33517
33518
33519
33520
33521
33522
33523
33524
33525
33526
.....
33624
33625
33626
33627
33628
33629
33630
33631
33632
33633
33634
33635
33636
33637
33638
.....
33724
33725
33726
33727
33728
33729
33730
33731
33732
33733
33734
33735
33736
33737
33738
.....
34385
34386
34387
34388
34389
34390
34391
34392
34393
34394
34395
34396
34397
34398
34399
34400
34401
34402
34403
34404


34405
34406

34407
34408

34409

34410
34411
34412
34413
34414

34415
34416




































































34417
34418
34419
34420
34421
34422
34423
.....
34698
34699
34700
34701
34702
34703
34704
34705
34706
34707
34708
34709
34710
34711
34712
.....
34736
34737
34738
34739
34740
34741
34742
34743
34744
34745
34746
34747
34748
34749
34750
34751
34752
34753
34754
34755
34756
34757
34758
34759
34760
34761
34762
    - URI routing for interface-based service is now specified by the two
      TSQLRestRoutingREST and TSQLRestRoutingJSON_RPC classes (inheriting from
      the abstract TSQLRestServerURIContext class) instead of rmJSON and
      rmJSON_RPC enums - it allows any custom URI routing by inheritance
    - BREAKING CHANGE of TJSONWriter.WriteObject() method and ObjectToJSON()
      function: serialization is now defined with TTextWriterWriteObjectOptions
      set - therefore, TJSONSerializerCustomWriter callback signature changed




    - changed RESTful URI to ModelRoot/Table?where=WhereClause to delete members
    - added TSQLRestServer.URIPagingParameters property, to support alternate
      URI parameters sets for request paging (in addition to YUI syntax),
      and an optional "total":... field within the JSON result (calling
      "SELECT count()" may be slow, especially on external databases)
    - deep code refactoring, introducing TSQLPropInfo* classes in order to
      decouple the ORM definitions from the RTTI - will allow definition of
................................................................................
    - interface-based services are now able to work with TObjectList parameters
    - interface-based services will now avoid to transmit the "id":... value
      when ID equals 0
    - interface-based services can now return the result value as JSON object
      instead of JSON array if TServiceFactoryServer.ResultAsJSONObject is set
      (can be usefull e.g. when consuming services from JavaScript)
    - new TSQLRest.Service<T: IInterface> method to retrieve a service instance

    - method-based services are now able to handle "304 Not Modified" optimized
      response to save bandwith, in TSQLRestServerURIContext.Returns/Results
    - added TSQLRestServer.ServiceMethodRegisterPublishedMethods() to allow
      multi-class method-based services (e.g. for implementing MVC model)
    - ServiceContext threadvar will now be available also for optExecInMainThread
    - added TSQLRestClientURI.SessionID property
    - added new TSQLRestClientURI.RetryOnceOnTimeout property
................................................................................
  // - instantiated by the TSQLRestServer.URI() method using its ServicesRouting
  // property
  // - see TSQLRestRoutingREST and TSQLRestRoutingJSON_RPC
  // for overriden methods - NEVER set this abstract TSQLRestServerURIContext
  // class on TSQLRest.ServicesRouting property !
  TSQLRestServerURIContext = class
  protected
    fInput: TRawUTF8DynArray;
    fSessionAccessRights: RawByteString; // session may be deleted meanwhile
    procedure FillInput;
    {$ifdef USEVARIANTS}
    function GetInput(const ParamName: RawUTF8): variant;
    {$endif}
    function GetInputInt(const ParamName: RawUTF8): Int64;
    function GetInputDouble(const ParamName: RawUTF8): Double;
................................................................................
    ID: integer;
    /// the index of the callback published method within the internal class list
    MethodIndex: integer;
    /// the service identified by an interface-based URI
    Service: TServiceFactoryServer;
    /// the method index for an interface-based service
    // - Service member has already be retrieved from URI (so is not nil)
    // - first items are the internal pseudo-methods
    ServiceMethodIndex: integer;
    /// the JSON array of parameters for an the interface-based
    // - Service member has already be retrieved from URI (so is not nil)
    ServiceParameters: PUTF8Char;
    /// force the interface-based service methods to return a JSON object
    // - default behavior is to follow Service.ResultAsJSONObject property value
    // (which own default is to return a more convenient JSON array)
................................................................................
  // $ (...)
  // $ [1,2]
  // or, for a sicClientDriven mode service:
  // $ POST /root/ComplexNumber.Add/1234
  // $ (...)
  // $ [20,30]
  // in this case, the sent content will be a JSON array of [parameters...]




  // (one benefit of using URI is that it will be more secured in our RESTful
  // authentication scheme: each method and even client driven session will
  // be signed properly)
  TSQLRestRoutingREST = class(TSQLRestServerURIContext)
  protected
    /// retrieve interface-based SOA with URI RESTful routing
    // - should set Service member (and possibly ServiceMethodIndex)
    // - this overriden implementation expects an URI encoded with
    // '/Model/Interface.Method[/ClientDrivenID]' for this class, and
    // will set ServiceMethodIndex for next ExecuteSOAByInterface method call
    procedure URIDecodeSOAByInterface; override;
    /// direct launch of an interface-based service with URI RESTful routing
    // - this overriden implementation expects parameters to be sent as JSON
    // array body (Delphi/AJAX way) or optionally with URI decoding (HTML way)





    procedure ExecuteSOAByInterface; override;
  public
    /// at Client Side, compute URI accoring to the RESTful routing scheme
    // - e.g. on input uri='root/Calculator', method='Add', params='1,2' and
    // clientDrivenID='1234' -> on output uri='root/Calculator.Add/1234' and
    // sent='[1,2]'
    class procedure ClientSideInvoke(var uri: RawUTF8;
................................................................................
    // - for smdConst argument, contains -1 (no need to a local var: the value
    // will be on the stack only)
    IndexVar: integer;
    /// serialize the argument into the TServiceContainer.Contract JSON format
    // - non standard types (e.g. clas, enumerate, dynamic array or record)
    // are identified by their type identifier - so contract does not extend
    // up to the content of such high-level structures
    function SerializeToContract: RawUTF8;









  end;

  /// describe a service provider method arguments
  TServiceMethodArgumentDynArray = array of TServiceMethodArgument;

  /// possible service provider method options, e.g. about logging or execution
  // - see TServiceMethodOptions for a description of each available option
................................................................................
    /// describe expected method arguments
    // - Args[0] always is smvSelf
    // - if method is a function, an additional smdResult argument is appended
    Args: TServiceMethodArgumentDynArray;
    /// the index of the result pseudo-argument in Args[]
    // - is -1 if the method is defined as a (not a function)
    ArgsResultIndex: integer;




    /// the index of the first var / out / result argument in Args[]
    ArgsOutFirst: integer;
    /// the index of the last var / out / result argument in Args[]
    ArgsOutLast: integer;
    /// the number of const / var parameters in Args[]
    // - i.e. the number of elements in the input JSON array
    ArgsInputValuesCount: cardinal;
................................................................................
    /// needed CPU stack size (in bytes) for all arguments
    // - under x64, does not include the backup space for the four registers
    ArgsSizeInStack: cardinal;
    /// contains all used kind of arguments
    ArgsUsed: TServiceMethodValueTypes;
    /// contains the count of variables for all used kind of arguments
    ArgsUsedCount: array[TServiceMethodValueVar] of integer;
    /// method index in the original interface
    // - our custom methods start at index 3 (RESERVED_VTABLE_SLOTS), since
    // QueryInterface, _AddRef, and _Release are always defined by default

    MethodIndex: integer;
    /// execute the corresponding method of a given TInterfacedObject instance
    // - will retrieve a JSON array of parameters from Par
    // - will append a JSON array of results in Res, or set an Error message, or
    // a JSON object (with parameter names) in Res if ResultAsJSONObject is set
    function InternalExecute(Instances: array of pointer; Par: PUTF8Char;
      Res: TTextWriter; var aHead: RawUTF8; Options: TServiceMethodOptions;
      ResultAsJSONObject: boolean): boolean;
................................................................................
    function CheckMethodIndex(const aMethodName: RawUTF8): integer; overload;
    /// find the index of a particular method in internal Methods[] list
    // - won't find the default AddRef/Release/QueryInterface methods
    // - will raise an EInterfaceFactoryException if the method is not known
    function CheckMethodIndex(aMethodName: PUTF8Char): integer; overload;
    /// the declared internal methods
    // - list does not contain default AddRef/Release/QueryInterface methods

    property Methods: TServiceMethodDynArray read fMethods;
    /// the number of internal methods
    // - does not include the default AddRef/Release/QueryInterface methods

    property MethodsCount: cardinal read fMethodsCount;
    /// the registered Interface low-level Delphi RTTI type
    property InterfaceTypeInfo: PTypeInfo read fInterfaceTypeInfo;
    /// the registered Interface GUID
    property InterfaceIID: TGUID read fInterfaceIID;
  end;

................................................................................
    /// get an implementation Inst.Instance for the given Inst.InstanceID
    // - is called by ExecuteMethod() in sicClientDrive mode
    // - returns true for successfull {"method":"_free_".. call (aMethodIndex=-1)
    // - otherwise, fill Inst.Instance with the matching implementation (or nil)
    function InternalInstanceRetrieve(var Inst: TServiceFactoryServerInstance;
      aMethodIndex: integer): boolean;
    /// call a given method of this service provider
    // - Ctxt.ServiceMethodIndex should be the index in Methods[]

    // - Ctxt.ServiceMethodIndex=-1, then it will free/release corresponding aInstanceID
    // (is called  e.g. from {"method":"_free_", "params":[], "id":1234} )
    // - Ctxt.ServiceParameters is e.g. '[1,2]' i.e. a true JSON array, which
    // will contain the incoming parameters in the same exact order than the
    // corresponding implemented interface method
    // - Ctxt.ID is an optional number, to be used in case of sicClientDriven
    // kind of Instance creation to identify the corresponding client session
................................................................................
  /// used to lookup one method in a global list of interface-based services
  TServiceContainerInterfaceMethod = record
    /// one 'service.method' item, as set at URI
    // - e.g.'Calculator.Add','Calculator.Multiply'...
    InterfaceDotMethodName: RawUTF8;
    /// the associated service provider
    InterfaceService: TServiceFactory;
    /// the index of the method in InterfaceService.fInterface.Methods[]


    InterfaceMethodIndex: integer;
  end;

  /// pointer to one method lookup in a global list of interface-based services
  PServiceContainerInterfaceMethod = ^TServiceContainerInterfaceMethod;

  /// used to store all methods in a global list of interface-based services
................................................................................
    Parameters := @URI[i+1];
    if Parameters^ in ['0'..'9'] then // "ModelRoot/TableName/ID/BlobFieldName"
      ID := GetNextItemCardinal(Parameters,'/') else
      ID := -1; // URI like "ModelRoot/TableName/MethodName"
    if (Parameters<>nil) and (Parameters^<>#0) then begin
      P := PosChar(Parameters,'?');
      if P=nil then
        URIBlobFieldName := Parameters else
        SetString(URIBlobFieldName,PAnsiChar(Parameters),P-Parameters);






    end;
    SetLength(URI,i-1);
    j := PosEx(RawUTF8('?'),Call^.url,1);
    if j>0 then // '?select=...&where=...' or '?where=...'
      Parameters := @Call^.url[j+1] else
      Parameters := nil;
  end else begin
................................................................................
  end;
end;

procedure TSQLRestServerURIContext.FillInput;
var n,max: integer;
    P: PUTF8Char;
begin


  P := Parameters;
  n := 0;
  max := 0;
  repeat
    if n>=max then begin
      inc(max,16);
      SetLength(fInput,max);
................................................................................
    AddJSONEscape(pointer(ErrorMsg));
    AddShort('"'#13#10'}');
    SetText(Call.OutBody);
  finally
    Free;
  end;
end;


{ TSQLRestRoutingREST }

procedure TSQLRestRoutingREST.URIDecodeSOAByInterface;
var i: integer;
begin
  if (Table=nil) and (MethodIndex<0) and (URI<>'') and (Server.Services<>nil) then begin
    //  URI as '/Model/Interface.Method[/ClientDrivenID]'
    i := Server.Services.fListInterfaceMethods.FindHashed(URI);
    if i>=0 then // no specific message: it may be a valid request
      with Server.Services.fListInterfaceMethod[i] do begin
        Service := TServiceFactoryServer(InterfaceService);
        ServiceMethodIndex := InterfaceMethodIndex;









      end;
    end;


end;

procedure TSQLRestRoutingREST.ExecuteSOAByInterface;
var JSON: RawUTF8;




begin // here Ctxt.Service and ServiceMethodIndex are set
  if (Server.Services=nil) or (Service=nil) then
    raise EServiceException.Create('Invalid call');
  //  URI as '/Model/Interface.Method[/ClientDrivenID]'
  if Call.InBody<>'' then
    // either parameters were sent as JSON array (the Delphi/AJAX way)
    ServiceParameters := pointer(Call.InBody) else begin
    // or parameters were URI-encoded (the HTML way)





    JSON := UrlDecode(Parameters);



































    ServiceParameters := pointer(JSON);
  end;
  if ID<0 then
    ID := 0; // InternalExecuteSOAByInterface expects ID=ClientDrivenID
  // now Service, ServiceParameters, ServiceMethodIndex are set
  InternalExecuteSOAByInterface;
end;
................................................................................
    uri := uri+'.'+method;
  sent := '['+params+']'; // we may also encode them within the URI
end;


{ TSQLRestRoutingJSON_RPC }

class procedure TSQLRestRoutingJSON_RPC.ClientSideInvoke(var uri: RawUTF8;
  const method, params, clientDrivenID: RawUTF8; out sent: RawUTF8);
begin
  sent := '{"method":"'+method+'","params":['+params;
  if clientDrivenID='' then
    sent := sent+']}' else
    sent := sent+'],"id":'+clientDrivenID+'}';
end;

procedure TSQLRestRoutingJSON_RPC.URIDecodeSOAByInterface;
var i: integer;
begin
  if (Table=nil) and (MethodIndex<0) and (URI<>'') and (Server.Services<>nil) then begin
    //  URI as '/Model/Interface'
    i := Server.Services.fList.IndexOf(URI);
    if i>=0 then // identified as a valid JSON-RPC service
................................................................................
    raise EServiceException.Create('Invalid call');
  JSON := Call.InBody; // in-place parsing -> private copy
  JSONDecode(JSON,['method','params','id'],Values,True);
  if Values[0]=nil then // Method name required
    exit;
  method := Values[0];
  ServiceParameters := Values[1];
  ID := GetCardinal(Values[2]); // ID=ClientDrivenID in InternalExecuteSOAByInterface 
  ServiceMethodIndex := Service.fInterface.FindMethodIndex(method);
  if ServiceMethodIndex>=0 then
    inc(ServiceMethodIndex,length(SERVICE_PSEUDO_METHOD)) else begin
    for internal := low(TServiceInternalMethod) to high(TServiceInternalMethod) do
      if IdemPropNameU(method,SERVICE_PSEUDO_METHOD[internal]) then begin
        ServiceMethodIndex := ord(internal);
        break;
................................................................................
      Error('Unknown method');
      exit;
    end;
  end;
  // now Service, ServiceParameters, ServiceMethodIndex are set
  InternalExecuteSOAByInterface;
end;











function TSQLRestServer.ServiceRegister(
  aImplementationClass: TInterfacedClass; const aInterfaces: array of PTypeInfo;
  aInstanceCreation: TServiceInstanceImplementation): TServiceFactoryServer;
begin
  result := nil;
  if (self=nil) or (aImplementationClass=nil) or (high(aInterfaces)<0) then
................................................................................
    result := NOERROR;
  end else
  if GetInterface(IID,Obj) then
    result := NOERROR else
    result := E_NOINTERFACE;
end;

procedure ValueAdd(ValueType: TServiceMethodValueType; WR: TTextWriter; V: Pointer;
  SizeInStorage: integer);
begin
  case ValueType of
  smvBoolean:   WR.AddString(JSON_BOOLEAN[PBoolean(V)^]);
  smvEnum..smvInt64:
  case SizeInStorage of
    1: WR.Add(PByte(V)^);
    2: WR.Add(PWord(V)^);
    4: if ValueType=smvInteger then
         WR.Add(PInteger(V)^) else
         WR.AddU(PCardinal(V)^);
    8: WR.Add(PInt64(V)^);
  end;
  smvDouble, smvDateTime: WR.Add(PDouble(V)^);
  smvCurrency:   WR.AddCurr64(PInt64(V));
  smvRawUTF8:    WR.AddJSONEscape(PPointer(V)^);
  smvRawJSON:    WR.AddNoJSONEscape(PPointer(V)^);
  smvString:     {$ifdef UNICODE}
                 WR.AddJSONEscapeW(pointer(PString(V)^));
                 {$else}
                 WR.AddJSONEscapeAnsiString(PString(V)^);
                 {$endif}
  smvWideString: WR.AddJSONEscapeW(PPointer(V)^);
  smvObject:     WR.WriteObject(PPointer(V)^,[]);
  end;
end;

procedure IgnoreComma(var P: PUTF8Char);
begin
  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);
  if P^=',' then inc(P);
end;

function TInterfacedObjectFake.FakeCall(var aCall: TFakeCallStack): Int64;
................................................................................
        V := @I64s[IndexVar]; // for results in CPU
      end;
      if vPassedByReference in ValueKindAsm then
        V := PPointer(V)^;
      if ValueType=smvDynArray then
        DynArrays[IndexVar].Init(TypeInfo,V^);
      Value[arg] := V;
      if ValueDirection in [smdConst, smdVar] then begin
        if vIsString in ValueKindAsm then
          Params.Add('"');
        case ValueType of
        smvRecord:   Params.AddRecordJSON(V^,TypeInfo);
        {$ifdef USEVARIANTS}
        smvVariant:  Params.AddVariantJSON(PVariant(V)^,twJSONEscape);
        {$endif}
        smvDynArray: Params.AddDynArrayJSON(DynArrays[IndexVar]);
        else ValueAdd(ValueType,Params,V,SizeInStorage);
        end;
        if vIsString in ValueKindAsm then
          Params.Add('"',',') else
          Params.Add(',');
      end;
    end;
    Params.CancelLastComma;
    // call remote server or stub implementation
    if method^.ArgsResultIsServiceCustomAnswer then
      ServiceCustomAnswerPoint := Value[method^.ArgsResultIndex] else
      ServiceCustomAnswerPoint := nil;
    if not fInvoke(method^,Params.Text,@ResArray,@Error,@fClientDrivenID,
................................................................................
  aNotifyDestroy: TOnFakeInstanceDestroy): TInterfacedObject;
begin
  result := TInterfacedObjectFake.Create(self,aInvoke,aNotifyDestroy);
end;

constructor TInterfaceFactory.Create(aInterface: PTypeInfo);
var m,a,reg: integer;

{$ifdef CPU64}
    resultIsRDX: boolean;
{$else}
    offs: integer;
{$endif}
begin
  fInterfaceTypeInfo := aInterface;
................................................................................
      if InStackOffset>=0 then begin
        dec(offs,SizeInStack);
        InStackOffset := offs;
      end;
    assert(offs=0);
    {$endif}
  end;
  with TTextWriter.CreateOwnedStream do
  try
    // compute the default result as a JSON array containing all methods
    for m := 0 to fMethodsCount-1 do
    with fMethods[m] do begin
      CancelAll;
      Add('[');
      for a := ArgsOutFirst to ArgsOutLast do
      with Args[a] do
      if ValueDirection in [smdVar,smdOut,smdResult] then
      case ValueType of
      smvBoolean:  AddShort('false,');
      smvObject:   AddShort('null,'); // may raise an error on the client side
      smvDynArray: AddShort('[],');
      smvRecord:   begin
        AddVoidRecordJSON(TypeInfo);
        Add(',');
      end;
      {$ifdef USEVARIANTS}
      smvVariant:  AddShort('null,');
      {$endif}
      else
        if vIsString in ValueKindAsm then
          AddShort('"",') else
          AddShort('0,');
      end;
      CancelLastComma;
      Add(']');
      SetText(DefaultResult);
    end;
    // compute the method contract as a JSON object
    CancelAll;
    Add('[');
    for m := 0 to fMethodsCount-1 do
    with fMethods[m] do begin
      Add('{"method":"%","arguments":[',[URI]);
      for a := 0 to High(Args) do
        AddString(Args[a].SerializeToContract);
      CancelLastComma;
      AddShort(']},');
    end;
    CancelLastComma;
    Add(']');
    SetText(fContract);
  finally
    Free;
  end;
end;

procedure TInterfaceFactory.AddMethodsFromTypeInfo(aInterface: PTypeInfo);
var P: Pointer absolute aInterface;
    PB: PByte absolute aInterface;
    PI: PInterfaceTypeData absolute P;
................................................................................
    exit; // no RTTI or no method at this level of interface
  inc(PW);
  for i := fMethodsCount to fMethodsCount+n-1 do begin
    // retrieve method name, and add to the methods list (with hashing)
    SetString(aURI,PAnsiChar(@PS^[1]),ord(PS^[0]));
    with PServiceMethod(fMethod.AddUniqueName(aURI,
      '%s.%s method: duplicated name',[fInterfaceTypeInfo^.Name,aURI]))^ do begin
      MethodIndex := i+RESERVED_VTABLE_SLOTS;
      PS := @PS^[ord(PS^[0])+1];
      Kind := PME^.Kind;
      if PME^.CC<>ccRegister then
        raise EInterfaceFactoryException.CreateFmt(
          '%s.%s method shall use register calling convention',
          [fInterfaceTypeInfo^.Name,URI]);
      // retrieve method call arguments
................................................................................
      if Kind=mkFunction then
        SetLength(Args,n+1) else
        SetLength(Args,n);
      if length(Args)>MAX_METHOD_ARGS then
        raise EInterfaceFactoryException.CreateFmt(
          '%s.%s method has too many parameters: %d>%d',
          [fInterfaceTypeInfo^.Name,URI,Length(Args),MAX_METHOD_ARGS]);


      ArgsOutFirst := -1;
      ArgsOutLast := -2;
      for j := 0 to n-1 do
      with Args[j] do begin
        f := PF^;
        inc(PF);
        if pfVar in f then
................................................................................
        TypeInfo := PP^^;
        inc(PP);
        {$ifdef ISDELPHIXE}
        inc(PB,PW^); // skip custom attributes
        {$endif}
        if j=0 then
          ValueType := smvSelf else begin
          if ValueDirection<>smdOut then
            inc(ArgsInputValuesCount);




          ValueType := TypeInfoToMethodValueType(TypeInfo);
          case ValueType of
          smvNone: begin
            case TypeInfo^.Kind of
            tkClass: begin
              C := TypeInfo^.ClassType^.ClassType;
              if C.InheritsFrom(TList) then
................................................................................
  const aParams: RawUTF8; aResult, aErrorMsg: PRawUTF8;
  aClientDrivenID: PCardinal; aServiceCustomAnswer: PServiceCustomAnswer): boolean;
var ndx: cardinal;
    rule: integer;
    ExecutesCtxt: TOnInterfaceStubExecuteParamsAbstract;
    Log: TInterfaceStubLog;
begin
  ndx := aMethod.MethodIndex-RESERVED_VTABLE_SLOTS;
  if ndx>=fInterface.MethodsCount then
    result := false else
    with fRules[ndx] do begin
      inc(MethodPassCount);
      rule := FindStrongRuleIndex(aParams);
      if rule<0 then begin
        rule := FindRuleIndex(aParams);
................................................................................
      Log := Pointer(fLogs);
      if asmndx<RESERVED_VTABLE_SLOTS then
        for i := 1 to fLogCount do begin
          Log^.AddAsText(WR,aScope);
          inc(Log);
        end else
        for i := 1 to fLogCount do begin
          if Log^.Method^.MethodIndex=asmndx then
            if (aParams='') or (Log^.Params=aParams) then
              Log^.AddAsText(WR,aScope);
          inc(Log);
        end;
      WR.CancelLastComma;
      WR.SetText(result);
    finally
................................................................................
begin
  asmndx := fInterface.CheckMethodIndex(aMethodName)+RESERVED_VTABLE_SLOTS;
  if aParams='' then
    c := fRules[asmndx-RESERVED_VTABLE_SLOTS].MethodPassCount else begin
    c := 0;
    for i := 0 to fLogCount-1 do
      with fLogs[i] do
      if (Method.MethodIndex=asmndx) and (Params=aParams) then
        inc(c);
  end;
  IntCheckCount(asmndx-RESERVED_VTABLE_SLOTS,c,aOperator,aCount);
end;


procedure TInterfaceMockSpy.Verify(const aTrace: RawUTF8;
................................................................................
  result := self;
end;


{ TServiceMethodArgument }

const
  CONST_METHODDIRTOJSON: array[TServiceMethodValueDirection] of RawUTF8 = (
    // convert into generic in/out direction (assume result is out)
    'in','both','out','out');

  // AnsiString (Delphi <2009) is handled with care (may loose data otherwise)
  CONST_METHODTYPETOJSON: array[TServiceMethodValueType] of RawUTF8 = (
    '??','self','boolean', '', '','integer','cardinal','int64',
    'double','datetime','currency','utf8',
    {$ifdef UNICODE}'utf8'{$else}''{$endif},'utf8','',
    {$ifdef USEVARIANTS}'variant',{$endif}'','json','');

function TServiceMethodArgument.SerializeToContract: RawUTF8;
begin


  result := '{"argument":"'+RawUTF8(ParamName^)+'","direction":"'+
    CONST_METHODDIRTOJSON[ValueDirection]+'","type":"';

  {$ifndef UNICODE}
  if ValueType=smvString then // will specify the Ansi code page for no data loss

    result := result+'ansi'+Int32ToUTF8(CurrentAnsiConvert.CodePage) else

  {$endif}
  if CONST_METHODTYPETOJSON[ValueType]='' then
    result := result+ShortStringToAnsi7String(TypeInfo^.Name) else
    result := result+CONST_METHODTYPETOJSON[ValueType];
  result := result+'"},';

end;






































































{$ifndef LVCL}

{ TInterfacedCollection }

constructor TInterfacedCollection.Create;
begin
................................................................................
        if RegisterIdent=0 then
          move(Value^,Stack[InStackOffset],SizeInStack) else
          r.Regs[RegisterIdent] := PPtrInt(Value)^;
    end;
    // 3. execute the method
    for i := 0 to high(Instances) do begin
      r.Regs[REG_FIRST] := PtrInt(Instances[i]);
      r.method := PPtrIntArray(PPointer(Instances[i])^)^[MethodIndex];
      if ArgsResultIndex>=0 then
      with Args[ArgsResultIndex] do begin
        r.resKind := ValueType;
        if ValueVar=smvv64 then
          Values[ArgsResultIndex] := @r.res64;
      end else
        r.resKind := smvNone;
................................................................................
        end;
      // 4.2 write the '{"result":[...' array or object
      for a := ArgsOutFirst to ArgsOutLast do
      with Args[a] do
      if ValueDirection in [smdVar,smdOut,smdResult] then begin
        if ResultAsJSONObject then
          Res.AddPropName(ParamName^);
        if vIsString in ValueKindAsm then
          Res.Add('"');
        case ValueType of
        smvRecord:   Res.AddRecordJSON(Values[a]^,TypeInfo);
        {$ifdef USEVARIANTS}
        smvVariant:  Res.AddVariantJSON(PVariant(Values[a])^,twJSONEscape);
        {$endif}
        smvDynArray: Res.AddDynArrayJSON(DynArrays[IndexVar].Wrapper);
        else ValueAdd(ValueType,Res,Values[a],SizeInStorage);
        end;
        if vIsString in ValueKindAsm then
          Res.Add('"',',') else
          Res.Add(',');
      end;
      Res.CancelLastComma;
    end;
    Result := true;
  finally // manual release memory for Records[], Objects[] and DynArrays[]
    for i := 0 to ArgsUsedCount[smvvObject]-1 do
      Objects[i].Free;







>
>
>
>







 







>







 







|







 







|







 







>
>
>
>
|
|
<









|
|
>
>
>
>
>







 







|
>
>
>
>
>
>
>
>
>







 







>
>
>
>







 







|


>
|







 







>



>







 







|
>







 







|
>
>







 







|

>
>
>
>
>
>







 







>
>







 







>







|





>
>
>
>
>
>
>
>
>
|
|
>
>




>
>
>
>








>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







<
<
<
<
<
<
<
<
<







 







|







 







>
>
>
>
>
>
>
>
>
>







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







|
|
<
<
<
<
<
<
<
<
<
<
<
<
<







 







>







 







|




|
|

|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|


|
|


|

|
|
|

|
|
|

|







 







|







 







>
>







 







|

>
>
>
>







 







|







 







|







 







|







 







|




|





|

>
>
|
|
>
|
|
>
|
>


|
|
<
>


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|







 







|
<
<
<
<
<
<
<
<
<
<
<
<







685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
...
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
....
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
....
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
....
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740

3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
....
6384
6385
6386
6387
6388
6389
6390
6391
6392
6393
6394
6395
6396
6397
6398
6399
6400
6401
6402
6403
6404
6405
6406
6407
....
6445
6446
6447
6448
6449
6450
6451
6452
6453
6454
6455
6456
6457
6458
6459
6460
6461
6462
....
6469
6470
6471
6472
6473
6474
6475
6476
6477
6478
6479
6480
6481
6482
6483
6484
6485
6486
6487
....
6621
6622
6623
6624
6625
6626
6627
6628
6629
6630
6631
6632
6633
6634
6635
6636
6637
6638
6639
....
7457
7458
7459
7460
7461
7462
7463
7464
7465
7466
7467
7468
7469
7470
7471
7472
....
7688
7689
7690
7691
7692
7693
7694
7695
7696
7697
7698
7699
7700
7701
7702
7703
7704
.....
24214
24215
24216
24217
24218
24219
24220
24221
24222
24223
24224
24225
24226
24227
24228
24229
24230
24231
24232
24233
24234
24235
.....
24710
24711
24712
24713
24714
24715
24716
24717
24718
24719
24720
24721
24722
24723
24724
24725
.....
24868
24869
24870
24871
24872
24873
24874
24875
24876
24877
24878
24879
24880
24881
24882
24883
24884
24885
24886
24887
24888
24889
24890
24891
24892
24893
24894
24895
24896
24897
24898
24899
24900
24901
24902
24903
24904
24905
24906
24907
24908
24909
24910
24911
24912
24913
24914
24915
24916
24917
24918
24919
24920
24921
24922
24923
24924
24925
24926
24927
24928
24929
24930
24931
24932
24933
24934
24935
24936
24937
24938
24939
24940
24941
24942
24943
24944
24945
24946
24947
24948
24949
24950
24951
24952
24953
24954
24955
24956
24957
24958
24959
24960
24961
24962
24963
24964
24965
.....
24972
24973
24974
24975
24976
24977
24978









24979
24980
24981
24982
24983
24984
24985
.....
24996
24997
24998
24999
25000
25001
25002
25003
25004
25005
25006
25007
25008
25009
25010
.....
25013
25014
25015
25016
25017
25018
25019
25020
25021
25022
25023
25024
25025
25026
25027
25028
25029
25030
25031
25032
25033
25034
25035
25036
.....
32244
32245
32246
32247
32248
32249
32250




























32251
32252
32253
32254
32255
32256
32257
.....
32307
32308
32309
32310
32311
32312
32313
32314
32315













32316
32317
32318
32319
32320
32321
32322
.....
32588
32589
32590
32591
32592
32593
32594
32595
32596
32597
32598
32599
32600
32601
32602
.....
32698
32699
32700
32701
32702
32703
32704
32705
32706
32707
32708
32709
32710
32711
32712
32713
32714
32715















32716
32717
32718
32719
32720
32721
32722
32723
32724
32725
32726
32727
32728
32729
32730
32731
32732
32733
32734
32735
32736
32737
32738
32739
32740
32741
32742
.....
32768
32769
32770
32771
32772
32773
32774
32775
32776
32777
32778
32779
32780
32781
32782
.....
32785
32786
32787
32788
32789
32790
32791
32792
32793
32794
32795
32796
32797
32798
32799
32800
.....
32818
32819
32820
32821
32822
32823
32824
32825
32826
32827
32828
32829
32830
32831
32832
32833
32834
32835
32836
32837
.....
33560
33561
33562
33563
33564
33565
33566
33567
33568
33569
33570
33571
33572
33573
33574
.....
33672
33673
33674
33675
33676
33677
33678
33679
33680
33681
33682
33683
33684
33685
33686
.....
33772
33773
33774
33775
33776
33777
33778
33779
33780
33781
33782
33783
33784
33785
33786
.....
34433
34434
34435
34436
34437
34438
34439
34440
34441
34442
34443
34444
34445
34446
34447
34448
34449
34450
34451
34452
34453
34454
34455
34456
34457
34458
34459
34460
34461
34462
34463
34464
34465
34466

34467
34468
34469
34470
34471
34472
34473
34474
34475
34476
34477
34478
34479
34480
34481
34482
34483
34484
34485
34486
34487
34488
34489
34490
34491
34492
34493
34494
34495
34496
34497
34498
34499
34500
34501
34502
34503
34504
34505
34506
34507
34508
34509
34510
34511
34512
34513
34514
34515
34516
34517
34518
34519
34520
34521
34522
34523
34524
34525
34526
34527
34528
34529
34530
34531
34532
34533
34534
34535
34536
34537
34538
34539
34540
34541
34542
34543
34544
.....
34819
34820
34821
34822
34823
34824
34825
34826
34827
34828
34829
34830
34831
34832
34833
.....
34857
34858
34859
34860
34861
34862
34863
34864












34865
34866
34867
34868
34869
34870
34871
    - URI routing for interface-based service is now specified by the two
      TSQLRestRoutingREST and TSQLRestRoutingJSON_RPC classes (inheriting from
      the abstract TSQLRestServerURIContext class) instead of rmJSON and
      rmJSON_RPC enums - it allows any custom URI routing by inheritance
    - BREAKING CHANGE of TJSONWriter.WriteObject() method and ObjectToJSON()
      function: serialization is now defined with TTextWriterWriteObjectOptions
      set - therefore, TJSONSerializerCustomWriter callback signature changed
    - TSQLRestRoutingREST will now recognize several URI schemes:
      /root/Calculator.Add + body, /root/Calculator.Add?+%5B+1%2C2+%5D,
      or even root/Calculator.Add?n1=1&n2=2 - and /root/Calculator/Add as a
      valid alternative to default /root/Calculator.Add, if needed
    - changed RESTful URI to ModelRoot/Table?where=WhereClause to delete members
    - added TSQLRestServer.URIPagingParameters property, to support alternate
      URI parameters sets for request paging (in addition to YUI syntax),
      and an optional "total":... field within the JSON result (calling
      "SELECT count()" may be slow, especially on external databases)
    - deep code refactoring, introducing TSQLPropInfo* classes in order to
      decouple the ORM definitions from the RTTI - will allow definition of
................................................................................
    - interface-based services are now able to work with TObjectList parameters
    - interface-based services will now avoid to transmit the "id":... value
      when ID equals 0
    - interface-based services can now return the result value as JSON object
      instead of JSON array if TServiceFactoryServer.ResultAsJSONObject is set
      (can be usefull e.g. when consuming services from JavaScript)
    - new TSQLRest.Service<T: IInterface> method to retrieve a service instance
    - added TServiceMethodArgument.AddJSON/AddValueJSON/AddDefaultJSON methods
    - method-based services are now able to handle "304 Not Modified" optimized
      response to save bandwith, in TSQLRestServerURIContext.Returns/Results
    - added TSQLRestServer.ServiceMethodRegisterPublishedMethods() to allow
      multi-class method-based services (e.g. for implementing MVC model)
    - ServiceContext threadvar will now be available also for optExecInMainThread
    - added TSQLRestClientURI.SessionID property
    - added new TSQLRestClientURI.RetryOnceOnTimeout property
................................................................................
  // - instantiated by the TSQLRestServer.URI() method using its ServicesRouting
  // property
  // - see TSQLRestRoutingREST and TSQLRestRoutingJSON_RPC
  // for overriden methods - NEVER set this abstract TSQLRestServerURIContext
  // class on TSQLRest.ServicesRouting property !
  TSQLRestServerURIContext = class
  protected
    fInput: TRawUTF8DynArray; // even items are parameter names, odd are values
    fSessionAccessRights: RawByteString; // session may be deleted meanwhile
    procedure FillInput;
    {$ifdef USEVARIANTS}
    function GetInput(const ParamName: RawUTF8): variant;
    {$endif}
    function GetInputInt(const ParamName: RawUTF8): Int64;
    function GetInputDouble(const ParamName: RawUTF8): Double;
................................................................................
    ID: integer;
    /// the index of the callback published method within the internal class list
    MethodIndex: integer;
    /// the service identified by an interface-based URI
    Service: TServiceFactoryServer;
    /// the method index for an interface-based service
    // - Service member has already be retrieved from URI (so is not nil)
    // - 0..2 are the internal _free_/_contract_/_signature_ pseudo-methods
    ServiceMethodIndex: integer;
    /// the JSON array of parameters for an the interface-based
    // - Service member has already be retrieved from URI (so is not nil)
    ServiceParameters: PUTF8Char;
    /// force the interface-based service methods to return a JSON object
    // - default behavior is to follow Service.ResultAsJSONObject property value
    // (which own default is to return a more convenient JSON array)
................................................................................
  // $ (...)
  // $ [1,2]
  // or, for a sicClientDriven mode service:
  // $ POST /root/ComplexNumber.Add/1234
  // $ (...)
  // $ [20,30]
  // in this case, the sent content will be a JSON array of [parameters...]
  // - as an alternative, input parameters may be encoded at URI level (with
  // a size limit depending on the HTTP routers, whereas there is no such
  // limitation when they are transmitted as message body)
  // - one benefit of having .../ClientDrivenID encoded at URI is that it will
  // be more secured in our RESTful authentication scheme: each method and even
  // client driven session will be signed individualy

  TSQLRestRoutingREST = class(TSQLRestServerURIContext)
  protected
    /// retrieve interface-based SOA with URI RESTful routing
    // - should set Service member (and possibly ServiceMethodIndex)
    // - this overriden implementation expects an URI encoded with
    // '/Model/Interface.Method[/ClientDrivenID]' for this class, and
    // will set ServiceMethodIndex for next ExecuteSOAByInterface method call
    procedure URIDecodeSOAByInterface; override;
    /// direct launch of an interface-based service with URI RESTful routing
    // - this overriden implementation expects parameters to be sent as one JSON
    // array body (Delphi/AJAX way) or optionally with URI decoding (HTML way):
    // ! function TServiceCalculator.Add(n1, n2: integer): integer;
    // would accept such requests:
    // !  URL='root/Calculator.Add' and InBody='[ 1,2 ]'
    // !  URL='root/Calculator.Add?+%5B+1%2C2+%5D' // decoded as ' [ 1,2 ]'
    // !  URL='root/Calculator.Add?n1=1&n2=2'      // in any order, even missing
    procedure ExecuteSOAByInterface; override;
  public
    /// at Client Side, compute URI accoring to the RESTful routing scheme
    // - e.g. on input uri='root/Calculator', method='Add', params='1,2' and
    // clientDrivenID='1234' -> on output uri='root/Calculator.Add/1234' and
    // sent='[1,2]'
    class procedure ClientSideInvoke(var uri: RawUTF8;
................................................................................
    // - for smdConst argument, contains -1 (no need to a local var: the value
    // will be on the stack only)
    IndexVar: integer;
    /// serialize the argument into the TServiceContainer.Contract JSON format
    // - non standard types (e.g. clas, enumerate, dynamic array or record)
    // are identified by their type identifier - so contract does not extend
    // up to the content of such high-level structures
    procedure SerializeToContract(WR: TTextWriter);
    /// append the JSON value corresponding to this argument
    // - includes a pending ','
    procedure AddJSON(WR: TTextWriter; V: pointer);
    /// append the JSON value corresponding to this argument, from its text value
    // - includes a pending ','
    procedure AddValueJSON(WR: TTextWriter; const Value: RawUTF8);
    /// append the default JSON value corresponding to this argument
    // - includes a pending ','
    procedure AddDefaultJSON(WR: TTextWriter);
  end;

  /// describe a service provider method arguments
  TServiceMethodArgumentDynArray = array of TServiceMethodArgument;

  /// possible service provider method options, e.g. about logging or execution
  // - see TServiceMethodOptions for a description of each available option
................................................................................
    /// describe expected method arguments
    // - Args[0] always is smvSelf
    // - if method is a function, an additional smdResult argument is appended
    Args: TServiceMethodArgumentDynArray;
    /// the index of the result pseudo-argument in Args[]
    // - is -1 if the method is defined as a (not a function)
    ArgsResultIndex: integer;
    /// the index of the first const / var argument in Args[]
    ArgsInFirst: integer;
    /// the index of the last const / var argument in Args[]
    ArgsInLast: integer;
    /// the index of the first var / out / result argument in Args[]
    ArgsOutFirst: integer;
    /// the index of the last var / out / result argument in Args[]
    ArgsOutLast: integer;
    /// the number of const / var parameters in Args[]
    // - i.e. the number of elements in the input JSON array
    ArgsInputValuesCount: cardinal;
................................................................................
    /// needed CPU stack size (in bytes) for all arguments
    // - under x64, does not include the backup space for the four registers
    ArgsSizeInStack: cardinal;
    /// contains all used kind of arguments
    ArgsUsed: TServiceMethodValueTypes;
    /// contains the count of variables for all used kind of arguments
    ArgsUsedCount: array[TServiceMethodValueVar] of integer;
    /// method index in the original (non emulated) interface
    // - our custom methods start at index 3 (RESERVED_VTABLE_SLOTS), since
    // QueryInterface, _AddRef, and _Release are always defined by default
    // - so it maps TServiceFactory.Interface.Methods[ExecutionMethodIndex-3]
    ExecutionMethodIndex: integer;
    /// execute the corresponding method of a given TInterfacedObject instance
    // - will retrieve a JSON array of parameters from Par
    // - will append a JSON array of results in Res, or set an Error message, or
    // a JSON object (with parameter names) in Res if ResultAsJSONObject is set
    function InternalExecute(Instances: array of pointer; Par: PUTF8Char;
      Res: TTextWriter; var aHead: RawUTF8; Options: TServiceMethodOptions;
      ResultAsJSONObject: boolean): boolean;
................................................................................
    function CheckMethodIndex(const aMethodName: RawUTF8): integer; overload;
    /// find the index of a particular method in internal Methods[] list
    // - won't find the default AddRef/Release/QueryInterface methods
    // - will raise an EInterfaceFactoryException if the method is not known
    function CheckMethodIndex(aMethodName: PUTF8Char): integer; overload;
    /// the declared internal methods
    // - list does not contain default AddRef/Release/QueryInterface methods
    // - nor the _free_/_contract_/_signature_ pseudo-methods
    property Methods: TServiceMethodDynArray read fMethods;
    /// the number of internal methods
    // - does not include the default AddRef/Release/QueryInterface methods
    // - nor the _free_/_contract_/_signature_ pseudo-methods
    property MethodsCount: cardinal read fMethodsCount;
    /// the registered Interface low-level Delphi RTTI type
    property InterfaceTypeInfo: PTypeInfo read fInterfaceTypeInfo;
    /// the registered Interface GUID
    property InterfaceIID: TGUID read fInterfaceIID;
  end;

................................................................................
    /// get an implementation Inst.Instance for the given Inst.InstanceID
    // - is called by ExecuteMethod() in sicClientDrive mode
    // - returns true for successfull {"method":"_free_".. call (aMethodIndex=-1)
    // - otherwise, fill Inst.Instance with the matching implementation (or nil)
    function InternalInstanceRetrieve(var Inst: TServiceFactoryServerInstance;
      aMethodIndex: integer): boolean;
    /// call a given method of this service provider
    // - here Ctxt.ServiceMethodIndex should be the index in fInterface.Methods[]
    // (i.e. excluding _free_/_contract_/_signature_ pseudo-methods)
    // - Ctxt.ServiceMethodIndex=-1, then it will free/release corresponding aInstanceID
    // (is called  e.g. from {"method":"_free_", "params":[], "id":1234} )
    // - Ctxt.ServiceParameters is e.g. '[1,2]' i.e. a true JSON array, which
    // will contain the incoming parameters in the same exact order than the
    // corresponding implemented interface method
    // - Ctxt.ID is an optional number, to be used in case of sicClientDriven
    // kind of Instance creation to identify the corresponding client session
................................................................................
  /// used to lookup one method in a global list of interface-based services
  TServiceContainerInterfaceMethod = record
    /// one 'service.method' item, as set at URI
    // - e.g.'Calculator.Add','Calculator.Multiply'...
    InterfaceDotMethodName: RawUTF8;
    /// the associated service provider
    InterfaceService: TServiceFactory;
    /// the index of the method for the given service
    // - 0..2 indicates _free_/_contract_/_signature_ pseudo-methods
    // - then points to InterfaceService.Interface.Methods[InterfaceMethodIndex-3]
    InterfaceMethodIndex: integer;
  end;

  /// pointer to one method lookup in a global list of interface-based services
  PServiceContainerInterfaceMethod = ^TServiceContainerInterfaceMethod;

  /// used to store all methods in a global list of interface-based services
................................................................................
    Parameters := @URI[i+1];
    if Parameters^ in ['0'..'9'] then // "ModelRoot/TableName/ID/BlobFieldName"
      ID := GetNextItemCardinal(Parameters,'/') else
      ID := -1; // URI like "ModelRoot/TableName/MethodName"
    if (Parameters<>nil) and (Parameters^<>#0) then begin
      P := PosChar(Parameters,'?');
      if P=nil then
        URIBlobFieldName := Parameters else begin
        SetString(URIBlobFieldName,PAnsiChar(Parameters),P-Parameters);
        j := PosEx('/',URIBlobFieldName);
        if j>0 then begin // handle "ModelRoot/TableName/BlobFieldName/ID"
          ID := GetCardinalDef(pointer(PtrInt(URIBlobFieldName)+j),cardinal(-1));
          SetLength(URIBlobFieldName,j-1);
        end;
      end;
    end;
    SetLength(URI,i-1);
    j := PosEx(RawUTF8('?'),Call^.url,1);
    if j>0 then // '?select=...&where=...' or '?where=...'
      Parameters := @Call^.url[j+1] else
      Parameters := nil;
  end else begin
................................................................................
  end;
end;

procedure TSQLRestServerURIContext.FillInput;
var n,max: integer;
    P: PUTF8Char;
begin
  if fInput<>nil then
    exit; // only do it once
  P := Parameters;
  n := 0;
  max := 0;
  repeat
    if n>=max then begin
      inc(max,16);
      SetLength(fInput,max);
................................................................................
    AddJSONEscape(pointer(ErrorMsg));
    AddShort('"'#13#10'}');
    SetText(Call.OutBody);
  finally
    Free;
  end;
end;


{ TSQLRestRoutingREST }

procedure TSQLRestRoutingREST.URIDecodeSOAByInterface;
var i: integer;
begin
  if (Table=nil) and (MethodIndex<0) and (URI<>'') and (Server.Services<>nil) then begin
    // check URI as '/Model/Interface.Method[/ClientDrivenID]'
    i := Server.Services.fListInterfaceMethods.FindHashed(URI);
    if i>=0 then // no specific message: it may be a valid request
      with Server.Services.fListInterfaceMethod[i] do begin
        Service := TServiceFactoryServer(InterfaceService);
        ServiceMethodIndex := InterfaceMethodIndex;
      end else begin
        // check URI as '/Model/Interface/Method[/ClientDrivenID]''
        i := Server.Services.fList.IndexOf(URI);
        if i>=0 then begin // identified as a valid JSON-RPC service
          Service := TServiceFactoryServer(Server.Services.fList.Objects[i]);
          ServiceMethodIndex := Service.InterfaceFactory.FindMethodIndex(URIBlobFieldName);
          if ServiceMethodIndex<0 then
            Service := nil else begin
            inc(ServiceMethodIndex,length(SERVICE_PSEUDO_METHOD));
          end;
        end;
      end;
  end;
end;

procedure TSQLRestRoutingREST.ExecuteSOAByInterface;
var JSON: RawUTF8;
    Par: PUTF8Char;
    meth,a,i,i1: Integer;
    WR: TTextWriter;
    argDone: boolean;
begin // here Ctxt.Service and ServiceMethodIndex are set
  if (Server.Services=nil) or (Service=nil) then
    raise EServiceException.Create('Invalid call');
  //  URI as '/Model/Interface.Method[/ClientDrivenID]'
  if Call.InBody<>'' then
    // either parameters were sent as JSON array (the Delphi/AJAX way)
    ServiceParameters := pointer(Call.InBody) else begin
    // or parameters were URI-encoded (the HTML way)
    Par := Parameters;
    if Par<>nil then
      while Par^='+' do inc(Par); // ignore trailing spaces
    if IdemPChar(Par,'%5B') then
      // either as JSON array (input is e.g. '+%5B...' for ' [...')
      JSON := UrlDecode(Parameters) else begin
      // either as a list of parameters (input is 'Param1=Value1&Param2=Value2...')
      FillInput; // fInput[0]='Param1',fInput[1]='Value1',fInput[2]='Param2'...
      if fInput<>nil then begin
        meth := ServiceMethodIndex-length(SERVICE_PSEUDO_METHOD);
        if cardinal(meth)<Service.InterfaceFactory.MethodsCount then begin
          WR := TTextWriter.CreateOwnedStream;
          try // convert URI parameters into the expected ordered JSON array
            WR.Add('[');
            with Service.InterfaceFactory.fMethods[meth] do begin
              i1 := 0;
              for a := ArgsInFirst to ArgsInLast do
              with Args[a] do
              if ValueDirection<>smdOut then begin
                argDone := false;
                for i := i1 to high(fInput)shr 1 do // search argument in URI 
                  if IdemPropName(ParamName^,pointer(fInput[i*2]),length(fInput[i*2])) then begin
                    AddValueJSON(WR,fInput[i*2+1]); // will add "" if needed
                    if i=i1 then
                      inc(i1); // optimistic in-order search, but allow any order
                    argDone := true;
                    break;
                  end;
                if not argDone then
                  AddDefaultJSON(WR); // allow missing argument
              end;
            end;
            WR.CancelLastComma;
            WR.Add(']');
            WR.SetText(JSON);
          finally
            WR.Free;
          end;
        end;
      end;
    end;
    ServiceParameters := pointer(JSON);
  end;
  if ID<0 then
    ID := 0; // InternalExecuteSOAByInterface expects ID=ClientDrivenID
  // now Service, ServiceParameters, ServiceMethodIndex are set
  InternalExecuteSOAByInterface;
end;
................................................................................
    uri := uri+'.'+method;
  sent := '['+params+']'; // we may also encode them within the URI
end;


{ TSQLRestRoutingJSON_RPC }










procedure TSQLRestRoutingJSON_RPC.URIDecodeSOAByInterface;
var i: integer;
begin
  if (Table=nil) and (MethodIndex<0) and (URI<>'') and (Server.Services<>nil) then begin
    //  URI as '/Model/Interface'
    i := Server.Services.fList.IndexOf(URI);
    if i>=0 then // identified as a valid JSON-RPC service
................................................................................
    raise EServiceException.Create('Invalid call');
  JSON := Call.InBody; // in-place parsing -> private copy
  JSONDecode(JSON,['method','params','id'],Values,True);
  if Values[0]=nil then // Method name required
    exit;
  method := Values[0];
  ServiceParameters := Values[1];
  ID := GetCardinal(Values[2]); // ID=ClientDrivenID in InternalExecuteSOAByInterface
  ServiceMethodIndex := Service.fInterface.FindMethodIndex(method);
  if ServiceMethodIndex>=0 then
    inc(ServiceMethodIndex,length(SERVICE_PSEUDO_METHOD)) else begin
    for internal := low(TServiceInternalMethod) to high(TServiceInternalMethod) do
      if IdemPropNameU(method,SERVICE_PSEUDO_METHOD[internal]) then begin
        ServiceMethodIndex := ord(internal);
        break;
................................................................................
      Error('Unknown method');
      exit;
    end;
  end;
  // now Service, ServiceParameters, ServiceMethodIndex are set
  InternalExecuteSOAByInterface;
end;

class procedure TSQLRestRoutingJSON_RPC.ClientSideInvoke(var uri: RawUTF8;
  const method, params, clientDrivenID: RawUTF8; out sent: RawUTF8);
begin
  sent := '{"method":"'+method+'","params":['+params;
  if clientDrivenID='' then
    sent := sent+']}' else
    sent := sent+'],"id":'+clientDrivenID+'}';
end;


function TSQLRestServer.ServiceRegister(
  aImplementationClass: TInterfacedClass; const aInterfaces: array of PTypeInfo;
  aInstanceCreation: TServiceInstanceImplementation): TServiceFactoryServer;
begin
  result := nil;
  if (self=nil) or (aImplementationClass=nil) or (high(aInterfaces)<0) then
................................................................................
    result := NOERROR;
  end else
  if GetInterface(IID,Obj) then
    result := NOERROR else
    result := E_NOINTERFACE;
end;





























procedure IgnoreComma(var P: PUTF8Char);
begin
  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);
  if P^=',' then inc(P);
end;

function TInterfacedObjectFake.FakeCall(var aCall: TFakeCallStack): Int64;
................................................................................
        V := @I64s[IndexVar]; // for results in CPU
      end;
      if vPassedByReference in ValueKindAsm then
        V := PPointer(V)^;
      if ValueType=smvDynArray then
        DynArrays[IndexVar].Init(TypeInfo,V^);
      Value[arg] := V;
      if ValueDirection in [smdConst,smdVar] then
        AddJSON(Params,V); 













    end;
    Params.CancelLastComma;
    // call remote server or stub implementation
    if method^.ArgsResultIsServiceCustomAnswer then
      ServiceCustomAnswerPoint := Value[method^.ArgsResultIndex] else
      ServiceCustomAnswerPoint := nil;
    if not fInvoke(method^,Params.Text,@ResArray,@Error,@fClientDrivenID,
................................................................................
  aNotifyDestroy: TOnFakeInstanceDestroy): TInterfacedObject;
begin
  result := TInterfacedObjectFake.Create(self,aInvoke,aNotifyDestroy);
end;

constructor TInterfaceFactory.Create(aInterface: PTypeInfo);
var m,a,reg: integer;
    WR: TTextWriter;
{$ifdef CPU64}
    resultIsRDX: boolean;
{$else}
    offs: integer;
{$endif}
begin
  fInterfaceTypeInfo := aInterface;
................................................................................
      if InStackOffset>=0 then begin
        dec(offs,SizeInStack);
        InStackOffset := offs;
      end;
    assert(offs=0);
    {$endif}
  end;
  WR := TTextWriter.CreateOwnedStream;
  try
    // compute the default result as a JSON array containing all methods
    for m := 0 to fMethodsCount-1 do
    with fMethods[m] do begin
      WR.CancelAll;
      WR.Add('[');
      for a := ArgsOutFirst to ArgsOutLast do
        with Args[a] do
        if ValueDirection in [smdVar,smdOut,smdResult] then
          AddDefaultJSON(WR);















      WR.CancelLastComma;
      WR.Add(']');
      WR.SetText(DefaultResult);
    end;
    // compute the method contract as a JSON object
    WR.CancelAll;
    WR.Add('[');
    for m := 0 to fMethodsCount-1 do
    with fMethods[m] do begin
      WR.Add('{"method":"%","arguments":[',[URI]);
      for a := 0 to High(Args) do
        Args[a].SerializeToContract(WR);
      WR.CancelLastComma;
      WR.AddShort(']},');
    end;
    WR.CancelLastComma;
    WR.Add(']');
    WR.SetText(fContract);
  finally
    WR.Free;
  end;
end;

procedure TInterfaceFactory.AddMethodsFromTypeInfo(aInterface: PTypeInfo);
var P: Pointer absolute aInterface;
    PB: PByte absolute aInterface;
    PI: PInterfaceTypeData absolute P;
................................................................................
    exit; // no RTTI or no method at this level of interface
  inc(PW);
  for i := fMethodsCount to fMethodsCount+n-1 do begin
    // retrieve method name, and add to the methods list (with hashing)
    SetString(aURI,PAnsiChar(@PS^[1]),ord(PS^[0]));
    with PServiceMethod(fMethod.AddUniqueName(aURI,
      '%s.%s method: duplicated name',[fInterfaceTypeInfo^.Name,aURI]))^ do begin
      ExecutionMethodIndex := i+RESERVED_VTABLE_SLOTS;
      PS := @PS^[ord(PS^[0])+1];
      Kind := PME^.Kind;
      if PME^.CC<>ccRegister then
        raise EInterfaceFactoryException.CreateFmt(
          '%s.%s method shall use register calling convention',
          [fInterfaceTypeInfo^.Name,URI]);
      // retrieve method call arguments
................................................................................
      if Kind=mkFunction then
        SetLength(Args,n+1) else
        SetLength(Args,n);
      if length(Args)>MAX_METHOD_ARGS then
        raise EInterfaceFactoryException.CreateFmt(
          '%s.%s method has too many parameters: %d>%d',
          [fInterfaceTypeInfo^.Name,URI,Length(Args),MAX_METHOD_ARGS]);
      ArgsInFirst := -1;
      ArgsInLast := -2;
      ArgsOutFirst := -1;
      ArgsOutLast := -2;
      for j := 0 to n-1 do
      with Args[j] do begin
        f := PF^;
        inc(PF);
        if pfVar in f then
................................................................................
        TypeInfo := PP^^;
        inc(PP);
        {$ifdef ISDELPHIXE}
        inc(PB,PW^); // skip custom attributes
        {$endif}
        if j=0 then
          ValueType := smvSelf else begin
          if ValueDirection<>smdOut then begin
            inc(ArgsInputValuesCount);
            if ArgsInFirst<0 then
              ArgsInFirst := j;
            ArgsInLast := j;
          end;
          ValueType := TypeInfoToMethodValueType(TypeInfo);
          case ValueType of
          smvNone: begin
            case TypeInfo^.Kind of
            tkClass: begin
              C := TypeInfo^.ClassType^.ClassType;
              if C.InheritsFrom(TList) then
................................................................................
  const aParams: RawUTF8; aResult, aErrorMsg: PRawUTF8;
  aClientDrivenID: PCardinal; aServiceCustomAnswer: PServiceCustomAnswer): boolean;
var ndx: cardinal;
    rule: integer;
    ExecutesCtxt: TOnInterfaceStubExecuteParamsAbstract;
    Log: TInterfaceStubLog;
begin
  ndx := aMethod.ExecutionMethodIndex-RESERVED_VTABLE_SLOTS;
  if ndx>=fInterface.MethodsCount then
    result := false else
    with fRules[ndx] do begin
      inc(MethodPassCount);
      rule := FindStrongRuleIndex(aParams);
      if rule<0 then begin
        rule := FindRuleIndex(aParams);
................................................................................
      Log := Pointer(fLogs);
      if asmndx<RESERVED_VTABLE_SLOTS then
        for i := 1 to fLogCount do begin
          Log^.AddAsText(WR,aScope);
          inc(Log);
        end else
        for i := 1 to fLogCount do begin
          if Log^.Method^.ExecutionMethodIndex=asmndx then
            if (aParams='') or (Log^.Params=aParams) then
              Log^.AddAsText(WR,aScope);
          inc(Log);
        end;
      WR.CancelLastComma;
      WR.SetText(result);
    finally
................................................................................
begin
  asmndx := fInterface.CheckMethodIndex(aMethodName)+RESERVED_VTABLE_SLOTS;
  if aParams='' then
    c := fRules[asmndx-RESERVED_VTABLE_SLOTS].MethodPassCount else begin
    c := 0;
    for i := 0 to fLogCount-1 do
      with fLogs[i] do
      if (Method.ExecutionMethodIndex=asmndx) and (Params=aParams) then
        inc(c);
  end;
  IntCheckCount(asmndx-RESERVED_VTABLE_SLOTS,c,aOperator,aCount);
end;


procedure TInterfaceMockSpy.Verify(const aTrace: RawUTF8;
................................................................................
  result := self;
end;


{ TServiceMethodArgument }

const
  CONST_METHODDIRTOJSON: array[TServiceMethodValueDirection] of string[4] = (
    // convert into generic in/out direction (assume result is out)
    'in','both','out','out');

  // AnsiString (Delphi <2009) is handled with care (may loose data otherwise)
  CONST_METHODTYPETOJSON: array[TServiceMethodValueType] of string[8] = (
    '??','self','boolean', '', '','integer','cardinal','int64',
    'double','datetime','currency','utf8',
    {$ifdef UNICODE}'utf8'{$else}''{$endif},'utf8','',
    {$ifdef USEVARIANTS}'variant',{$endif}'','json','');

procedure TServiceMethodArgument.SerializeToContract(WR: TTextWriter);
begin
  WR.AddShort('{"argument":"');
  WR.AddShort(ParamName^);
  WR.AddShort('","direction":"');
  WR.AddShort(CONST_METHODDIRTOJSON[ValueDirection]);
  WR.AddShort('","type":"');
  {$ifndef UNICODE} // should specify the Ansi code page for no data loss
  if ValueType=smvString then begin
    WR.AddShort('ansi');
    WR.AddU(CurrentAnsiConvert.CodePage);
  end else
  {$endif}
  if CONST_METHODTYPETOJSON[ValueType]='' then
    WR.AddShort(TypeInfo^.Name) else
    WR.AddShort(CONST_METHODTYPETOJSON[ValueType]);

  WR.AddShort('"},');
end;

procedure TServiceMethodArgument.AddJSON(WR: TTextWriter; V: pointer);
begin
  if vIsString in ValueKindAsm then
    WR.Add('"');
  case ValueType of
  smvBoolean:   WR.AddString(JSON_BOOLEAN[PBoolean(V)^]);
  smvEnum..smvInt64:
  case SizeInStorage of
    1: WR.Add(PByte(V)^);
    2: WR.Add(PWord(V)^);
    4: if ValueType=smvInteger then
         WR.Add(PInteger(V)^) else
         WR.AddU(PCardinal(V)^);
    8: WR.Add(PInt64(V)^);
  end;
  smvDouble, smvDateTime: WR.Add(PDouble(V)^);
  smvCurrency:   WR.AddCurr64(PInt64(V));
  smvRawUTF8:    WR.AddJSONEscape(PPointer(V)^);
  smvRawJSON:    WR.AddNoJSONEscape(PPointer(V)^);
  smvString:     {$ifdef UNICODE}
                 WR.AddJSONEscapeW(pointer(PString(V)^));
                 {$else}
                 WR.AddJSONEscapeAnsiString(PString(V)^);
                 {$endif}
  smvWideString: WR.AddJSONEscapeW(PPointer(V)^);
  smvObject:     WR.WriteObject(PPointer(V)^,[]);
  smvRecord:     WR.AddRecordJSON(V^,TypeInfo);
  {$ifdef USEVARIANTS}
  smvVariant:    WR.AddVariantJSON(PVariant(V)^,twJSONEscape);
  {$endif}
  smvDynArray:   WR.AddDynArrayJSON(TypeInfo,V^);
  end;
  if vIsString in ValueKindAsm then
    WR.AddShort('",') else
    WR.Add(',');
end;

procedure TServiceMethodArgument.AddValueJSON(WR: TTextWriter; const Value: RawUTF8);
begin
  if vIsString in ValueKindAsm then begin
    WR.Add('"');
    WR.AddJSONEscape(pointer(Value),length(Value));
    WR.AddShort('",');
  end else begin
    WR.AddString(Value);
    WR.Add(',');
  end;
end;

procedure TServiceMethodArgument.AddDefaultJSON(WR: TTextWriter);
begin
  case ValueType of
  smvBoolean:  WR.AddShort('false,');
  smvObject:   WR.AddShort('null,'); // may raise an error on the client side
  smvDynArray: WR.AddShort('[],');
  smvRecord:   begin
    WR.AddVoidRecordJSON(TypeInfo);
    WR.Add(',');
  end;
  {$ifdef USEVARIANTS}
  smvVariant: WR.AddShort('null,');
  {$endif}
  else
    if vIsString in ValueKindAsm then
      WR.AddShort('"",') else
      WR.AddShort('0,');
  end;
end;

{$ifndef LVCL}

{ TInterfacedCollection }

constructor TInterfacedCollection.Create;
begin
................................................................................
        if RegisterIdent=0 then
          move(Value^,Stack[InStackOffset],SizeInStack) else
          r.Regs[RegisterIdent] := PPtrInt(Value)^;
    end;
    // 3. execute the method
    for i := 0 to high(Instances) do begin
      r.Regs[REG_FIRST] := PtrInt(Instances[i]);
      r.method := PPtrIntArray(PPointer(Instances[i])^)^[ExecutionMethodIndex];
      if ArgsResultIndex>=0 then
      with Args[ArgsResultIndex] do begin
        r.resKind := ValueType;
        if ValueVar=smvv64 then
          Values[ArgsResultIndex] := @r.res64;
      end else
        r.resKind := smvNone;
................................................................................
        end;
      // 4.2 write the '{"result":[...' array or object
      for a := ArgsOutFirst to ArgsOutLast do
      with Args[a] do
      if ValueDirection in [smdVar,smdOut,smdResult] then begin
        if ResultAsJSONObject then
          Res.AddPropName(ParamName^);
        AddJSON(Res,Values[a]);












      end;
      Res.CancelLastComma;
    end;
    Result := true;
  finally // manual release memory for Records[], Objects[] and DynArrays[]
    for i := 0 to ArgsUsedCount[smvvObject]-1 do
      Objects[i].Free;

Changes to SQLite3/mORMotSelfTests.pas.

149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
...
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
{$ifndef FPC}
    TTestLowLevelTypes,
{$ifndef DELPHI5OROLDER}
    TTestBigTable,
{$endif}
{$ifndef LVCL}
    TTestSynopsePDF, // PDF uses SynGDIPlus or Jpeg.pas
{$endif} 
{$endif}
    TTestCryptographicRoutines, TTestCompression
   ]);
end;

{$ifdef FPC}
type // mORMot.pas unit doesn't compile with FPC yet
................................................................................
  AddCase([TTestFileBased,
    TTestFileBasedMemoryMap,
    TTestFileBasedWAL,
    TTestMemoryBased,
    TTestBasicClasses,
    TTestClientServerAccess]);
  // *)
  AddCase([TTestServiceOrientedArchitecture]);
  AddCase([TTestExternalDatabase]);
  AddCase([TTestMultiThreadProcess]);
  //exit; // *)
end;
{$endif DELPHI5OROLDER}
{$endif FPC}








|







 







|







149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
...
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
{$ifndef FPC}
    TTestLowLevelTypes,
{$ifndef DELPHI5OROLDER}
    TTestBigTable,
{$endif}
{$ifndef LVCL}
    TTestSynopsePDF, // PDF uses SynGDIPlus or Jpeg.pas
{$endif}
{$endif}
    TTestCryptographicRoutines, TTestCompression
   ]);
end;

{$ifdef FPC}
type // mORMot.pas unit doesn't compile with FPC yet
................................................................................
  AddCase([TTestFileBased,
    TTestFileBasedMemoryMap,
    TTestFileBasedWAL,
    TTestMemoryBased,
    TTestBasicClasses,
    TTestClientServerAccess]);
  // *)
  AddCase([TTestServiceOrientedArchitecture]); // (*
  AddCase([TTestExternalDatabase]);
  AddCase([TTestMultiThreadProcess]);
  //exit; // *)
end;
{$endif DELPHI5OROLDER}
{$endif FPC}

Changes to SynSelfTests.pas.

8024
8025
8026
8027
8028
8029
8030
8031
8032
8033
8034

8035
8036
8037
8038
8039
8040












8041
8042
8043
8044
8045
8046
8047
8048



8049
8050
8051
8052
8053
8054
8055
....
8137
8138
8139
8140
8141
8142
8143
8144
8145

8146
8147
8148

8149
8150
8151
8152
8153
8154
8155
8156
    exit;
{$endif}
  Test(Inst);
  Test(Inst);
end;

procedure TTestServiceOrientedArchitecture.ServiceInitialization;
  function Ask(Method, Params: RawUTF8; ExpectedResult: cardinal): RawUTF8;
  var resp,data: RawUTF8;
  begin
    Params := ' [ '+Params+' ]';

    if fClient.Server.ServicesRouting=TSQLRestRoutingREST then begin
      SetString(data,PAnsiChar(pointer(Params)),length(Params)); // =UniqueString
      Check(fClient.URI('root/calculator.'+Method,'POST',@resp,nil,@Params).Lo=ExpectedResult);
      if ExpectedResult=200 then begin
        Check(fClient.URI('root/CALCulator.'+Method+'?'+UrlEncode(data),'POST',@data).Lo=ExpectedResult);
        Check(data=resp,'optional URI-encoded-inlined parameters use');












      end;
    end else
    if fClient.Server.ServicesRouting=TSQLRestRoutingJSON_RPC then begin
      data := '{"method":"'+Method+'", "params":'+Params+'}';
      Check(fClient.URI('root/calculator','POST',@resp,nil,@data).Lo=ExpectedResult);
    end else
      assert(false);
    result := JSONDecode(resp,'result',nil,true);



  end;
var S: TServiceFactory;
    i: integer;
    rout: integer;
const
  ROUTING: array[0..1] of TSQLRestServerURIContextClass =
    (TSQLRestRoutingREST,TSQLRestRoutingJSON_RPC);
................................................................................
  Check(fClient.Server.ServiceRegister(TServiceUserGroupSession,[TypeInfo(ITestUser)],sicPerUser)<>nil);
  Check(fClient.Server.ServiceRegister(TServiceUserGroupSession,[TypeInfo(ITestGroup)],sicPerGroup)<>nil);
  Check(fClient.Server.ServiceRegister(TServicePerThread,[TypeInfo(ITestPerThread)],sicPerThread)<>nil);
  // JSON-level access
  for rout := low(ROUTING) to high(ROUTING) do begin
    fClient.ServicesRouting := ROUTING[rout];
    fClient.Server.ServicesRouting := ROUTING[rout];
    Check(Ask('None','1,2',400)='');
    CheckMatchAny(Ask('Add','1,2',200),['[3]','{"Result":3}']);

    CheckMatchAny(Ask('Multiply','2,3',200),['[6]','{"Result":6}']);
    CheckMatchAny(Ask('Subtract','23,20',200),['[3]','{"Result":3}']);
    CheckMatchAny(Ask('ToText','777,"abc"',200),['["777"]','{"Result":"777"}']); // "abc" for var parameter

    CheckMatchAny(Ask('ToTextFunc','777',200),['["777"]','{"Result":"777"}']);
  end;
  fClient.ServicesRouting := TSQLRestRoutingREST; // back to default
  fClient.Server.ServicesRouting := TSQLRestRoutingREST; 
end;

procedure TTestServiceOrientedArchitecture.Security;
  procedure Test(Expected: TSQLFieldTables; const msg: string);







|
|

|
>


|

|
|
>
>
>
>
>
>
>
>
>
>
>
>








>
>
>







 







|
|
>
|
|
<
>
|







8024
8025
8026
8027
8028
8029
8030
8031
8032
8033
8034
8035
8036
8037
8038
8039
8040
8041
8042
8043
8044
8045
8046
8047
8048
8049
8050
8051
8052
8053
8054
8055
8056
8057
8058
8059
8060
8061
8062
8063
8064
8065
8066
8067
8068
8069
8070
8071
....
8153
8154
8155
8156
8157
8158
8159
8160
8161
8162
8163
8164

8165
8166
8167
8168
8169
8170
8171
8172
8173
    exit;
{$endif}
  Test(Inst);
  Test(Inst);
end;

procedure TTestServiceOrientedArchitecture.ServiceInitialization;
  function Ask(Method, Params,ParamsURI: RawUTF8; ExpectedResult: cardinal): RawUTF8;
  var resp,data,uriencoded: RawUTF8;
  begin
    Params := ' [ '+Params+' ]'; // add some ' ' to test real-world values
    uriencoded := '?'+UrlEncode(Params);
    if fClient.Server.ServicesRouting=TSQLRestRoutingREST then begin
      SetString(data,PAnsiChar(pointer(Params)),length(Params)); // =UniqueString
      Check(fClient.URI('root/calculator.'+Method,'POST',@resp,nil,@data).Lo=ExpectedResult);
      if ExpectedResult=200 then begin
        Check(fClient.URI('root/CALCulator.'+Method+uriencoded,'POST',@data).Lo=ExpectedResult);
        Check(data=resp,'alternative URI-encoded-inlined parameters use');
        Check(fClient.URI('root/Calculator.'+Method+'?'+ParamsURI,'GET',@data).Lo=ExpectedResult);
        Check(data=resp,'alternative "param1=value1&param2=value2" URI-encoded scheme');
        SetString(data,PAnsiChar(pointer(Params)),length(Params)); // =UniqueString
        Check(fClient.URI('root/calculator/'+Method,'POST',@data,nil,@data).Lo=ExpectedResult);
        Check(data=resp,'interface/method routing');
        SetString(data,PAnsiChar(pointer(Params)),length(Params)); // =UniqueString
        Check(fClient.URI('root/calculator/'+Method+'/123','POST',@data,nil,@Params).Lo=ExpectedResult);
        Check(data=resp,'interface/method/clientdrivenID routing');
        Check(fClient.URI('root/CALCulator/'+Method+uriencoded,'POST',@data).Lo=ExpectedResult);
        Check(data=resp,'alternative URI-encoded-inlined parameters use');
        Check(fClient.URI('root/Calculator/'+Method+'?'+ParamsURI,'GET',@data).Lo=ExpectedResult);
        Check(data=resp,'alternative "param1=value1&param2=value2" URI-encoded scheme');
      end;
    end else
    if fClient.Server.ServicesRouting=TSQLRestRoutingJSON_RPC then begin
      data := '{"method":"'+Method+'", "params":'+Params+'}';
      Check(fClient.URI('root/calculator','POST',@resp,nil,@data).Lo=ExpectedResult);
    end else
      assert(false);
    result := JSONDecode(resp,'result',nil,true);
    if IdemPChar(Pointer(result),'{"RESULT"') then
      result := JSONDecode(result,'result',nil,false) else
      result := copy(result,2,length(result)-2); // trim '[' + ']'
  end;
var S: TServiceFactory;
    i: integer;
    rout: integer;
const
  ROUTING: array[0..1] of TSQLRestServerURIContextClass =
    (TSQLRestRoutingREST,TSQLRestRoutingJSON_RPC);
................................................................................
  Check(fClient.Server.ServiceRegister(TServiceUserGroupSession,[TypeInfo(ITestUser)],sicPerUser)<>nil);
  Check(fClient.Server.ServiceRegister(TServiceUserGroupSession,[TypeInfo(ITestGroup)],sicPerGroup)<>nil);
  Check(fClient.Server.ServiceRegister(TServicePerThread,[TypeInfo(ITestPerThread)],sicPerThread)<>nil);
  // JSON-level access
  for rout := low(ROUTING) to high(ROUTING) do begin
    fClient.ServicesRouting := ROUTING[rout];
    fClient.Server.ServicesRouting := ROUTING[rout];
    Check(Ask('None','1,2','one=1&two=2',400)='');
    Check(Ask('Add','1,2','n1=1&n2=2',200)='3');
    Check(Ask('Add','1,0','n2=1',200)='1');
    Check(Ask('Multiply','2,3','n1=2&n2=3',200)='6');
    Check(Ask('Subtract','23,20','n2=20&n1=23',200)='3');

    Check(Ask('ToText','777,"abc"','result=abc&value=777',200)='777');
    Check(Ask('ToTextFunc','777','value=777',200)='777');
  end;
  fClient.ServicesRouting := TSQLRestRoutingREST; // back to default
  fClient.Server.ServicesRouting := TSQLRestRoutingREST; 
end;

procedure TTestServiceOrientedArchitecture.Security;
  procedure Test(Expected: TSQLFieldTables; const msg: string);