mORMot and Open Source friends
Check-in [3587eefc22]
Not logged in

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

Overview
Comment:{1604} added TSynRestDataset third-party contribution by EMartin
  • features an editable dataset connected through URL
  • we would take a look at this nice piece of code, and eventually integrate it to the framework
  • in the meanwhile, we integrated it as third-party sample - feedback is welcome!
  • Thanks a lot, Esteban, for sharing!
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 3587eefc22a49b51cd2df5a8e53d8ca9ea1aee28
User & Date: ab 2015-07-06 17:33:46
Context
2015-07-07
06:57
{1605} introducing TDDDSocketThreadSettings.ConfigurationRestMethod() and function ClassFieldNamesAllProps() check-in: 2a0325f8a9 user: ab tags: trunk
2015-07-06
17:33
{1604} added TSynRestDataset third-party contribution by EMartin
  • features an editable dataset connected through URL
  • we would take a look at this nice piece of code, and eventually integrate it to the framework
  • in the meanwhile, we integrated it as third-party sample - feedback is welcome!
  • Thanks a lot, Esteban, for sharing!
check-in: 3587eefc22 user: ab tags: trunk
17:15
{1603} fixed sample 17 check-in: bd47a55b71 user: ab tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Added SQLite3/Samples/ThirdPartyDemos/EMartin/TSynRestDataset/ReadMe.md.


























































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
TSynRestDataset
===============

By *EMartin* (Esteban Martin).


# Presentation

Migrating from *RemObjects* to *mORMot* I had to implement a GUI functionality that *RemObjects* has, an editable dataset connected through URL (RO version 3 use SOAP and other components adapters, etc.).

My implementation is basic and the most probably is not the best, but works for me, the same use RESTful URL for get and update data, also get data from a *mORMot* interface based services returning a *mORMot* JSON array but cannot update because the table not exists.

In this folder there are two units: `SynRestVCL.pas` and `SynRestMidasVCL.pas`, both have some duplicated code from its counterpart (`SynDBVCL.pas` and `SynDBMidasVCL.pas`) and the others, but the rest are modifications with use of RESTful instead of the `TSQLDBConnection` (this require the database client installed in the client machine).

A `TSQLModel` is required because the `TSynRestDataset` get the fields definition column type and size from this. Also is used from the `TSQLRecord` the defined validations (I used `InternalDefineModel`) and the `ComputeFieldsBeforeWrite` (I used this for default values).

This was developed with Delphi 7 on Windows 7 and probably (almost sure) is not cross platform.

If this serves for others may be the best option will be that *ab* integrate this in the framework and make this code more *mORMot*. Meanwhile I will update on the google drive.
I hope this is helpful to someone.

# Example 1: from a table

    // defining the table
    TSQLRecordTest = class(TSQLRecord)
    private
      fDecimal: Double;
      fNumber: Double;
      fTestID: Integer;
      fText: RawUTF8;
      fDateTime: TDateTime;
    protected
      class procedure InternalDefineModel(Props: TSQLRecordProperties); override;
    public
      procedure ComputeFieldsBeforeWrite(aRest: TSQLRest; aOccasion: TSQLEvent); override;
    published
      property Test_ID: Integer read fTestID write fTestID;
      property Text: RawUTF8 index 255 read fText write fText;
      property Date_Time: TDateTime read fDateTime write fDateTime;
      property Number: Double read fNumber write fNumber;
      property Decimal_: Double read fDecimal write fDecimal;
    end;

    ...

    { TSQLRecordTest }

    procedure TSQLRecordTest.ComputeFieldsBeforeWrite(aRest: TSQLRest; aOccasion: TSQLEvent);
    begin
      inherited;
      fDateTime := Now;
    end;

    class procedure TSQLRecordTest.InternalDefineModel(Props: TSQLRecordProperties);
    begin
      AddFilterNotVoidText(['Text']);
      AddFilterOrValidate('Text', TSynValidateNonNull.Create);
    end;

    // client
    type
      TForm3 = class(TForm)
        DBGrid1: TDBGrid;
        DBNavigator1: TDBNavigator;
        btnOpen: TButton;
        edtURL: TEdit;
        dsRest: TDataSource;
        procedure FormCreate(Sender: TObject);
        procedure btnOpenClick(Sender: TObject);
        procedure DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
      private
        { Private declarations }
        fRestDS: TSynRestDataset;
      public
        { Public declarations }
      end;

    ...

    procedure TForm3.FormCreate(Sender: TObject);
    begin
      fRestDS := TSynRestDataset.Create(Self);
      fRestDS.Dataset.SQLModel := TSQLModel.Create([TSQLRecordTest], 'root');
      dsRest.Dataset := fRestDS;
    end;

    procedure TForm3.btnOpenClick(Sender: TObject);
    begin
      fRestDS.Close;
      fRestDS.CommandText := edtURL.Text; // edtURL.Text = 'http://localhost:8888/root/Test/select=*
      fRestDS.Open;
      // you can filter by
      // where: fRestDS.CommandText := edtURL.Text; // edtURL.Text = 'http://localhost:8888/root/Test/select=*&where=CONDITION
      // fRestDS.Open;
      // named parameter: fRestDS.CommandText := edtURL.Text; // edtURL.Text = 'http://localhost:8888/root/Test/select=*&where=:PARAMNAME
      // fRestDS.Params.ParamByName('PARAMNAME').Value := XXX
      // fRestDS.Open;
    end;

    procedure TForm3.DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
    begin
      if (Button = nbPost) then
        fRestDS.ApplyUpdates(0);
    end;

# Example 2: from a service

     // defining the table, the service name and operation name are required
    TSQLRecordServiceName_OperationName = class(TSQLRecord)
    private
      fText: RawUTF8;
    published
      property Text: RawUTF8 index 255 read fText write fText;
    end;

    ...

    // server (the implementation)

    TServiceName =class(TInterfacedObjectWithCustomCreate, IServiceName)
    public
      ...
      // this function can also be function OperationName(const aParamName: RawUTF8): RawUTF8;
      function OperationName(const aParamName: RawUTF8; out aData: RawUTF8): Integer;
      ...
    end;

    ...

    function TServiceName.OperationName(const aParamName: RawUTF8; out aData: RawUTF8): Integer;
    begin
       Result := OK;
       aData := '[{"text":"test"},{"text":"test1"}]';    
    end;

    ...

    // client
    type
      TForm3 = class(TForm)
        DBGrid1: TDBGrid;
        DBNavigator1: TDBNavigator;
        btnOpen: TButton;
        edtURL: TEdit;
        dsRest: TDataSource;
        procedure FormCreate(Sender: TObject);
        procedure btnOpenClick(Sender: TObject);
        procedure DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
      private
        { Private declarations }
        fRestDS: TSynRestDataset;
      public
        { Public declarations }
      end;

    ...

    procedure TForm3.FormCreate(Sender: TObject);
    begin
      fRestDS := TSynRestDataset.Create(Self);
      fRestDS.Dataset.SQLModel := TSQLModel.Create([TSQLRecordServiceName_OperationName], 'root');
      dsRest.Dataset := fRestDS;
    end;

    procedure TForm3.btnOpenClick(Sender: TObject);
    begin
      fRestDS.Close;
      fRestDS.CommandText := edtURL.Text; // edtURL.Text = 'http://localhost:8888/root/ServiceName.OperationName?aParamName=XXX
      fRestDS.Open;
      // you can filter by named parameter:
      // fRestDS.CommandText := edtURL.Text; // 'http://localhost:8888/root/ServiceName.OperationName?aParamName=:aParamName
      // fRestDS.Params.ParamByName('aParamName').Value := XXX
      // fRestDS.Open;
    end;

    procedure TForm3.DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
    begin
      if (Button = nbPost) then
        fRestDS.ApplyUpdates(0); // raise an error "Cannot update data from a service"
    end;


# Forum Thread

See http://synopse.info/forum/viewtopic.php?id=2712

# License

Feel free to use and/or append to Lib and extend if needed.

Added SQLite3/Samples/ThirdPartyDemos/EMartin/TSynRestDataset/SynRestMidasVCL.pas.






































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
/// fill a VCL TClientDataset from SynRestVCL data access
// - this unit is a part of the freeware Synopse framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit SynRestMidasVCL;

{
    This file is part of Synopse framework.

    Synopse framework. Copyright (C) 2015 Arnaud Bouchez
      Synopse Informatique - http://synopse.info

  *** BEGIN LICENSE BLOCK *****
  Version: MPL 1.1/GPL 2.0/LGPL 2.1

  The contents of this file are subject to the Mozilla Public License Version
  1.1 (the "License"); you may not use this file except in compliance with
  the License. You may obtain a copy of the License at
  http://www.mozilla.org/MPL

  Software distributed under the License is distributed on an "AS IS" basis,
  WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
  for the specific language governing rights and limitations under the License.

  The Original Code is Synopse mORMot framework.

  The Initial Developer of the Original Code is Arnaud Bouchez.

  Portions created by the Initial Developer are Copyright (C) 2015
  the Initial Developer. All Rights Reserved.

  Contributor(s):
  - Esteban Martin

  Alternatively, the contents of this file may be used under the terms of
  either the GNU General Public License Version 2 or later (the "GPL"), or
  the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
  in which case the provisions of the GPL or the LGPL are applicable instead
  of those above. If you wish to allow use of your version of this file only
  under the terms of either the GPL or the LGPL, and not to allow others to
  use your version of this file under the terms of the MPL, indicate your
  decision by deleting the provisions above and replace them with the notice
  and other provisions required by the GPL or the LGPL. If you do not delete
  the provisions above, a recipient may use your version of this file under
  the terms of any one of the MPL, the GPL or the LGPL.

  ***** END LICENSE BLOCK *****

  Version 1.18
  - first public release, corresponding to Synopse mORMot Framework 1.18,
    which is an extraction from former SynRestVCL.pas unit (which is faster
    but read/only)
  - introducing TSynRestDataSet (under Delphi), which allows to apply updates:
    will be used now for overloaded ToClientDataSet() functions result


}

{$I Synopse.inc} // define HASINLINE USETYPEINFO CPU32 CPU64 OWNNORMTOUPPER

interface

uses
  {$ifdef ISDELPHIXE2}System.SysUtils,{$else}SysUtils,{$endif}
  Classes,
{$ifndef DELPHI5OROLDER}
  Variants,
  {$ifndef FPC}
  MidasLib,
  {$endif}
{$endif}
  mORMot,
  mORMotHttpClient,
  SynCommons,
  SynDB, SynRestVCL,
  DB,
  {$ifdef FPC}
  BufDataset
  {$else}
  Contnrs,
  DBClient,
  Provider,
  SqlConst
  {$endif};


{$ifdef FPC} { TODO: duplicated code from SynDBMidasVCL }
type
  /// FPC's pure pascal in-memory buffer is used instead of TClientDataSet
  TClientDataSet = TBufDataset;

  /// wrapper functions will use FPC's pure pascal in-memory buffer
  TSynRestDataSet = TBufDataset;

{$else FPC}
type
  /// A TSynRestDataset, inherited from TCustomClientDataSet, which allows to apply updates on a TWinHTTP connection.
  //  The TSQLModel is required for getting column datatype and size and if the TSQLRecord has defined
  //  InternalDefineModel for validations they will be associated to a TField.OnValidate. Similary if the method
  //  ComputeBeforeWriteFields is overridden this will be used.
  // - typical usage may be for instance:
  // ! ds := TSynRestDataSet.Create(MainForm);
  // ! ds.Dataset.SQLModel := CreateModel; // The SQLModel is required
  // ! ds.CommandText := 'http://host:port/root/TableName?select=*&where=condition&sort=fieldname';
  // ! ds1.Dataset := ds; // assigning the rest dataset to TDatasource that can be associated a TDBGrid for example.
  // ! ds.Open;
  // ! // ... use ds as usual, including modifications
  // ! ds.ApplyUpdates(0);
  //   or using from a service returning a dataset:
  // ! ds := TSynRestDataSet.Create(MainForm);
  // ! ds.Dataset.SQLModel := CreateModel; // The SQLModel is required
  // ! the TSQLRecord associated should be defined with the same structure of the returned array from the service
  // ! ds.CommandText := 'http://host:port/root/ServiceName.Operation?paramname=:paramvalue';
  // ! ds.Params.ParamByName('paramname').Value := 'xyz';
  // ! ds1.Dataset := ds; // assigning the rest dataset to TDatasource that can be associated a TDBGrid for example.
  // ! ds.Open;
  // ! // ... use ds as usual, including modifications
  // ! ds.ApplyUpdates(0);
  TSynRestDataSet = class(TCustomClientDataSet)
  protected
    fDataSet: TSynRestSQLDataset;
    fProvider: TDataSetProvider;
    procedure DoOnFieldValidate(Sender: TField);
    procedure DoOnUpdateError(Sender: TObject; DataSet: TCustomClientDataSet; E: EUpdateError; UpdateKind: TUpdateKind; var Response: TResolverResponse);
    // from TDataSet
    procedure OpenCursor(InfoQuery: Boolean); override;
    {$ifdef ISDELPHI2007ANDUP}
    // from IProviderSupport
    function PSGetCommandText: string; override;
    {$endif}
    procedure SetCommandText(Value: String); override;
    procedure SetFieldValidateFromSQLRecordSynValidate;
  public
    /// initialize the instance
    constructor Create(AOwner: TComponent); override;
    /// initialize the internal TDataSet from a Rest statement result set
    // - Statement will have the form http://host:port/root/tablename or
    //   http://host:port/root/servicename.operationname?paramname=:paramalias
    // examples:
    //   http://host:port/root/tablename?select=XXX or
    //   http://host:port/root/tablename?select=XXX&where=field1=XXX or field2=XXX
    //   http://host:port/root/service.operation?param=:param
    procedure From(Statement: RawUTF8; MaxRowCount: cardinal=0);
    procedure FetchParams;
  published
    property CommandText;
    property Active;
    property Aggregates;
    property AggregatesActive;
    property AutoCalcFields;
    property Constraints;
    property DisableStringTrim;
    property FileName;
    property Filter;
    property Filtered;
    property FilterOptions;
    property FieldDefs;
    property IndexDefs;
    property IndexFieldNames;
    property IndexName;
    property FetchOnDemand;
    property MasterFields;
    property MasterSource;
    property ObjectView;
    property PacketRecords;
    property Params;
    property ReadOnly;
    property StoreDefs;
    property BeforeOpen;
    property AfterOpen;
    property BeforeClose;
    property AfterClose;
    property BeforeInsert;
    property AfterInsert;
    property BeforeEdit;
    property AfterEdit;
    property BeforePost;
    property AfterPost;
    property BeforeCancel;
    property AfterCancel;
    property BeforeDelete;
    property AfterDelete;
    property BeforeScroll;
    property AfterScroll;
    property BeforeRefresh;
    property AfterRefresh;
    property OnCalcFields;
    property OnDeleteError;
    property OnEditError;
    property OnFilterRecord;
    property OnNewRecord;
    property OnPostError;
    property OnReconcileError;
    property BeforeApplyUpdates;
    property AfterApplyUpdates;
    property BeforeGetRecords;
    property AfterGetRecords;
    property BeforeRowRequest;
    property AfterRowRequest;
    property BeforeExecute;
    property AfterExecute;
    property BeforeGetParams;
    property AfterGetParams;
    /// the associated SynRestVCL TDataSet, used to retrieve and update data
    property DataSet: TSynRestSQLDataSet read fDataSet;
  end;

{$endif FPC}

/// Convert JSON array to REST TClientDataset
// - the dataset is created inside this function
function JSONToSynRestDataset(const aJSON: RawUTF8; const aSQLModel: TSQLModel): TSynRestDataset;

implementation

uses
  Dialogs;

type
  TSynRestSQLDatasetHack = class(TSynRestSQLDataset);
  TSynValidateRestHack = class(TSynValidateRest);

{$ifndef FPC}

function JSONToSynRestDataset(const aJSON: RawUTF8; const aSQLModel: TSQLModel): TSynRestDataset;
var
  lSQLTableJSON: TSQLTableJSON;
  lData: TRawByteStringStream;
begin
  Result := Nil;
  if (aJSON = '') then
    Exit;
  lSQLTableJSON := TSQLTableJSON.Create('', aJSON);
  lSQLTableJSON.Step;
  lData := TRawByteStringStream.Create('');
  try
    JSONToBinary(lSQLTableJSON, lData);
    Result := TSynRestDataset.Create(Nil);
    Result.Dataset.SQLModel := aSQLModel;
    Result.DataSet.From(lData.DataString);
  finally
    FreeAndNil(lData);
    FreeAndNil(lSQLTableJSON);
  end;
end;

{ TSynRestDataSet }

constructor TSynRestDataSet.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fProvider := TDataSetProvider.Create(Self);
  fProvider.Name := 'InternalProvider';                 { Do not localize }
  fProvider.SetSubComponent(True);
  fProvider.Options := fProvider.Options+[poAllowCommandText];
  fProvider.OnUpdateError := DoOnUpdateError;
  SetProvider(fProvider);
  fDataSet := TSynRestSQLDataSet.Create(Self);
  fDataSet.Name := 'InternalDataSet';                   { Do not localize }
  fDataSet.SetSubComponent(True);
  fProvider.DataSet := fDataSet;
end;

procedure TSynRestDataSet.DoOnFieldValidate(Sender: TField);
var
  lRec: TSQLRecord;
  F: Integer; // fields
  V: Integer; // validations
  Validate: TSynValidate;
  Value: RawUTF8;
  lErrMsg: string;
  lFields: TSQLPropInfoList;
  lwasTSynValidateRest: boolean;
  ValidateRest: TSynValidateRest absolute Validate;
begin
  lRec := TSynRestSQLDatasetHack(fDataset).GetSQLRecordClass.Create;
  try
    lFields := lRec.RecordProps.Fields;
    F := lFields.IndexByName(Sender.FieldName);
    // the field has not validation
    if (Length(lRec.RecordProps.Filters[F]) = 0) then
      Exit;

    if not (lFields.List[F].SQLFieldType in COPIABLE_FIELDS) then
      Exit;

    lRec.SetFieldValue(Sender.FieldName, PUTF8Char(VariantToUTF8(Sender.Value)));
    for V := 0 to Length(lRec.RecordProps.Filters[F])-1 do begin
      Validate := TSynValidate(lRec.RecordProps.Filters[F,V]);
      if Validate.InheritsFrom(TSynValidate) then begin
        Value := Sender.Value;
        lwasTSynValidateRest := Validate.InheritsFrom(TSynValidateRest);
        if lwasTSynValidateRest then begin // set additional parameters
            TSynValidateRestHack(ValidateRest).fProcessRec := lRec;
            TSynValidateRestHack(ValidateRest).fProcessRest := Nil; // no Rest for the moment
          end;
          try
            if not Validate.Process(F,Value,lErrMsg) then begin
              if lErrMsg='' then
                // no custom message -> show a default message
                lErrMsg := format(sValidationFailed,[GetCaptionFromClass(Validate.ClassType)])
              else
                raise ESQLRestException.CreateUTF8('Error % on field "%"', [lErrMsg, Sender.DisplayName]);
            end;
          finally
            if lwasTSynValidateRest then begin // reset additional parameters
              TSynValidateRestHack(ValidateRest).fProcessRec := nil;
              TSynValidateRestHack(ValidateRest).fProcessRest := nil;
            end;
          end;
        end;
    end;
  finally
    lRec.Free;
  end;
end;

procedure TSynRestDataSet.DoOnUpdateError(Sender: TObject; DataSet: TCustomClientDataSet; E: EUpdateError;
                                             UpdateKind: TUpdateKind; var Response: TResolverResponse);
begin
  Response := rrAbort;
  MessageDlg(E.OriginalException.Message, mtError, [mbOK], 0);
end;

procedure TSynRestDataSet.From(Statement: RawUTF8; MaxRowCount: cardinal);
begin
  fDataSet.From(Statement);
  fDataSet.CommandText := ''; // ensure no SQL execution
  Open;
  fDataSet.CommandText := UTF8ToString(Statement); // assign it AFTER Open
end;

procedure TSynRestDataSet.FetchParams;
begin
  if not HasAppServer and Assigned(FProvider) then
    SetProvider(FProvider);
  inherited FetchParams;
end;

procedure TSynRestDataSet.OpenCursor(InfoQuery: Boolean);
begin
  if Assigned(fProvider) then
    SetProvider(fProvider);
  if fProvider.DataSet=self then
    raise ESQLDBException.Create(SCircularProvider);
  inherited OpenCursor(InfoQuery);
  SetFieldValidateFromSQLRecordSynValidate;
end;

{$ifdef ISDELPHI2007ANDUP}
function TSynRestDataSet.PSGetCommandText: string;
{$ifdef ISDELPHIXE3}
var IP: IProviderSupportNG;
begin
  if Supports(fDataSet, IProviderSupportNG, IP) then
{$else}
var IP: IProviderSupport;
begin
  if Supports(fDataSet, IProviderSupport, IP) then
{$endif}
    result := IP.PSGetCommandText else
    result := CommandText;
end;
{$endif ISDELPHI2007ANDUP}

procedure TSynRestDataSet.SetCommandText(Value: String);
begin
  TSynRestSQLDatasetHack(fDataset).SetCommandText(Value);
  inherited SetCommandText(fDataset.CommandText);
  // with this TSynRestSQLDataset can bind param values
  TSynRestSQLDatasetHack(fDataset).fParams := Params;
  if (Name = '') then
    Name := 'rds' + StringReplaceChars(TSynRestSQLDatasetHack(fDataset).fTableName, '.', '_');
end;

procedure TSynRestDataSet.SetFieldValidateFromSQLRecordSynValidate;
var
  F: Integer; // dataset fields
  V: Integer; // validation fields
  lProps: TSQLRecordProperties;
begin
  // if not TSQLRecord associated, nothing to do
  if (TSynRestSQLDatasetHack(fDataset).GetTableName = '') then
    Exit;
  lProps := TSynRestSQLDatasetHack(fDataset).GetSQLRecordClass.RecordProps;
  // if there isn't filters, bye
  if (Length(lProps.Filters) = 0) then
    Exit;
  for F := 0 to Fields.Count-1 do
  begin
    V := lProps.Fields.IndexByName(Fields[F].FieldName);
    if (V > -1) then
    begin
      if (Length(lProps.Filters[V]) > 0) then
        Fields[F].OnValidate := DoOnFieldValidate;
    end;
  end;
end;

{$endif FPC}

end.


Added SQLite3/Samples/ThirdPartyDemos/EMartin/TSynRestDataset/SynRestVCL.pas.












































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
/// fill a VCL TClientDataset from SynVirtualDataset data access
// - this unit is a part of the freeware Synopse framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit SynRestVCL;

{
    This file is part of Synopse framework.

    Synopse framework. Copyright (C) 2015 Arnaud Bouchez
      Synopse Informatique - http://synopse.info

  *** BEGIN LICENSE BLOCK *****
  Version: MPL 1.1/GPL 2.0/LGPL 2.1

  The contents of this file are subject to the Mozilla Public License Version
  1.1 (the "License"); you may not use this file except in compliance with
  the License. You may obtain a copy of the License at
  http://www.mozilla.org/MPL

  Software distributed under the License is distributed on an "AS IS" basis,
  WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
  for the specific language governing rights and limitations under the License.

  The Original Code is Synopse mORMot framework.

  The Initial Developer of the Original Code is Arnaud Bouchez.

  Portions created by the Initial Developer are Copyright (C) 2015
  the Initial Developer. All Rights Reserved.

  Contributor(s):
  - Esteban Martin (EMartin)

  Alternatively, the contents of this file may be used under the terms of
  either the GNU General Public License Version 2 or later (the "GPL"), or
  the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
  in which case the provisions of the GPL or the LGPL are applicable instead
  of those above. If you wish to allow use of your version of this file only
  under the terms of either the GPL or the LGPL, and not to allow others to
  use your version of this file under the terms of the MPL, indicate your
  decision by deleting the provisions above and replace them with the notice
  and other provisions required by the GPL or the LGPL. If you do not delete
  the provisions above, a recipient may use your version of this file under
  the terms of any one of the MPL, the GPL or the LGPL.

  ***** END LICENSE BLOCK *****

  Version 1.18
  - first public release, corresponding to Synopse mORMot Framework 1.18,
    which is an extraction from former SynDBVCL.pas unit.

}

{$I Synopse.inc} // define HASINLINE USETYPEINFO CPU32 CPU64 OWNNORMTOUPPER

interface

uses
  {$ifdef ISDELPHIXE2}System.SysUtils,{$else}SysUtils,{$endif}
  Classes,
{$ifndef DELPHI5OROLDER}
  Variants,
  {$ifndef FPC}
  MidasLib,
  {$endif}
{$endif}
  mORMot,
  mORMotHttpClient,
  SynCrtSock, // remover una vez implementado TSQLHttpClient
  SynCommons,
  SynDB, SynDBVCL,
  DB,
  {$ifdef FPC}
  BufDataset
  {$else}
  Contnrs,
  DBClient,
  Provider,
  SqlConst
  {$endif};


type
  /// generic Exception type
  ESQLRestException = class(ESynException);

  /// a TDataSet which allows to apply updates on a Restful connection
  // - typical usage may be for instance:
  // ! ds := TSynRestDataSet.Create(MainForm);
  // ! ds.Dataset.SQLModel := CreateModel; // The SQLModel is required
  // ! ds.CommandText := 'http://host:port/root/TableName?select=*&where=condition&sort=fieldname';
  // ! ds1.Dataset := ds; // assigning the rest dataset to TDatasource that can be associated a TDBGrid for example.
  // ! ds.Open;
  // ! // ... use ds as usual, including modifications
  // ! ds.ApplyUpdates(0);
  //   or using from a service returning a dataset:
  // ! ds := TSynRestDataSet.Create(MainForm);
  // ! ds.Dataset.SQLModel := CreateModel; // The SQLModel is required
  // ! the TSQLRecord associated should be defined with the same structure of the returned array from the service
  // ! ds.CommandText := 'http://host:port/root/ServiceName.Operation?paramname=:paramvalue';
  // ! ds.Params.ParamByName('paramname').Value := 'xyz';
  // ! ds1.Dataset := ds; // assigning the rest dataset to TDatasource that can be associated a TDBGrid for example.
  // ! ds.Open;
  // ! // ... use ds as usual, including modifications
  // ! ds.ApplyUpdates(0);
  TSynRestSQLDataSet = class(TSynBinaryDataSet)
  protected
    fBaseURL: RawUTF8;
    fCommandText: string;
    fDataSet: TSynBinaryDataSet;
    fParams: TParams;
    fProvider: TDataSetProvider;
    fRoot: RawUTF8;
    fSQLModel: TSQLModel;
    fTableName: RawUTF8;
    fURI: TURI;
    function BindParams(const aStatement: RawUTF8): RawUTF8;
    function GetSQLRecordClass: TSQLRecordClass;
    function GetTableName: string;
    // get the data
    procedure InternalInitFieldDefs; override;
    function InternalFrom(const aStatement: RawUTF8): RawByteString;
    procedure InternalOpen; override;
    procedure InternalClose; override;
    function IsTableFromService: Boolean;
    procedure ParseCommandText;
    // IProvider implementation
    procedure PSSetCommandText(const ACommandText: string); override;
    function PSGetTableName: string; override;
    function PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean; override;
    function PSIsSQLBased: Boolean; override;
    function PSIsSQLSupported: Boolean; override;
    {$ifdef ISDELPHIXE3}
    function PSExecuteStatement(const ASQL: string; AParams: TParams): Integer; overload; override;
    function PSExecuteStatement(const ASQL: string; AParams: TParams; var ResultSet: TDataSet): Integer; overload; override;
    {$else}
    function PSExecuteStatement(const ASQL: string; AParams: TParams; ResultSet: Pointer=nil): Integer; overload; override;
    {$endif}
    procedure SetCommandText(const Value: string);
  public
    /// the associated Model, if not defined an exception is raised.
    property SQLModel: TSQLModel read fSQLModel write fSQLModel;
  published
    /// the GET RESTful URI
    // - Statement will have the form http://host:port/root/tablename or
    //   http://host:port/root/servicename.operationname?paramname=:paramalias
    // examples:
    //   http://host:port/root/tablename?select=XXX or
    //   http://host:port/root/tablename?select=XXX&where=field1=XXX or field2=XXX
    //   http://host:port/root/service.operation?param=:param
    // if :param is used then before open assign the value: ds.Params.ParamByName('param').value := XXX
    property CommandText: string read fCommandText write fCommandText;
    /// the associated SynDB TDataSet, used to retrieve and update data
    property DataSet: TSynBinaryDataSet read fDataSet;
  end;

// JSON columns to binary from a TSQLTableJSON, is not ideal because this code is a almost repeated code.
procedure JSONColumnsToBinary(const aTable: TSQLTableJSON; W: TFileBufferWriter;
  const Null: TSQLDBProxyStatementColumns;
  const ColTypes: TSQLDBFieldTypeDynArray);
// convert to binary from a TSQLTableJSON, is not ideal because this code is a almost repeated code.
function JSONToBinary(const aTable: TSQLTableJSON; Dest: TStream; MaxRowCount: cardinal=0; DataRowPosition: PCardinalDynArray=nil): cardinal;

implementation

uses
  DBCommon,
  SynVirtualDataset;

const
  FETCHALLTOBINARY_MAGIC = 1;

  SQLFIELDTYPETODBFIELDTYPE: array[TSQLFieldType] of TSQLDBFieldType =
    (SynCommons.ftUnknown,   // sftUnknown
     SynCommons.ftUTF8,      // sftAnsiText
     SynCommons.ftUTF8,      // sftUTF8Text
     SynCommons.ftInt64,     // sftEnumerate
     SynCommons.ftInt64,     // sftSet
     SynCommons.ftInt64,     // sftInteger
     SynCommons.ftInt64,     // sftID = TSQLRecord(aID)
     SynCommons.ftInt64,     // sftRecord = TRecordReference
     SynCommons.ftInt64,     // sftBoolean
     SynCommons.ftDouble,    // sftFloat
     SynCommons.ftDate,      // sftDateTime
     SynCommons.ftInt64,     // sftTimeLog
     SynCommons.ftCurrency,  // sftCurrency
     SynCommons.ftUTF8,      // sftObject
{$ifndef NOVARIANTS}
     SynCommons.ftUTF8,      // sftVariant
     SynCommons.ftUTF8,      // sftNullable
{$endif}
     SynCommons.ftBlob,      // sftBlob
     SynCommons.ftBlob,      // sftBlobDynArray
     SynCommons.ftBlob,      // sftBlobCustom
     SynCommons.ftUTF8,      // sftUTF8Custom
     SynCommons.ftUnknown,   // sftMany
     SynCommons.ftInt64,     // sftModTime
     SynCommons.ftInt64,     // sftCreateTime
     SynCommons.ftInt64,     // sftTID
     SynCommons.ftInt64);    // sftRecordVersion = TRecordVersion

  SQLFieldTypeToVCLDB: array[TSQLFieldType] of TFieldType =
    (DB.ftUnknown,           // sftUnknown
     DB.ftString,            // sftAnsiText
     DB.ftString,            // sftUTF8Text
     DB.ftLargeInt,          // sftEnumerate
     DB.ftLargeInt,          // sftSet
     DB.ftLargeInt,          // sftInteger
     DB.ftLargeInt,          // sftID = TSQLRecord(aID)
     DB.ftLargeInt,          // sftRecord = TRecordReference
     DB.ftLargeInt,          // sftBoolean
     DB.ftFloat,             // sftFloat
     DB.ftDate,              // sftDateTime
     DB.ftLargeInt,          // sftTimeLog
     DB.ftCurrency,          // sftCurrency
     DB.ftString,            // sftObject
{$ifndef NOVARIANTS}
     DB.ftString,            // sftVariant
     DB.ftString,            // sftNullable
{$endif}
     DB.ftBlob,              // sftBlob
     DB.ftBlob,              // sftBlobDynArray
     DB.ftBlob,              // sftBlobCustom
     DB.ftString,            // sftUTF8Custom
     DB.ftUnknown,           // sftMany
     DB.ftLargeInt,          // sftModTime
     DB.ftLargeInt,          // sftCreateTime
     DB.ftLargeInt,          // sftTID
     DB.ftLargeInt);         // sftRecordVersion = TRecordVersion

  VCLDBFieldTypeSQLDB: array[0..23] of TSQLFieldType =
    (sftUnknown,        // ftUnknown
     sftAnsiText,       //  ftString
     sftUTF8Text,       // ftString
     sftEnumerate,      // ftInteger
     sftSet,            // ftInteger
     sftInteger,        // ftInteger
     sftID,             // ftLargeInt = TSQLRecord(aID)
     sftRecord,         // ftLargeInt
     sftBoolean,        // ftBoolean
     sftFloat,          // ftFloat
     sftDateTime,       // ftDate
     sftTimeLog,        // ftLargeInt
     sftCurrency,       // ftCurrency
     sftObject,         // ftString
{$ifndef NOVARIANTS}
     sftVariant,        // ftString
{$endif}
     sftBlob,           // ftBlob
     sftBlob,           // ftBlob
     sftBlob,           // ftBlob
     sftUTF8Custom,     // ftString
     sftMany,           // ftUnknown
     sftModTime,        // ftLargeInt
     sftCreateTime,     // ftLargeInt
     sftID,             // ftLargeInt
     sftRecordVersion); // ftLargeInt = TRecordVersion

{$ifndef FPC}


procedure JSONColumnsToBinary(const aTable: TSQLTableJSON; W: TFileBufferWriter;
  const Null: TSQLDBProxyStatementColumns; const ColTypes: TSQLDBFieldTypeDynArray);
var F: integer;
    VDouble: double;
    VCurrency: currency absolute VDouble;
    VDateTime: TDateTime absolute VDouble;
    colType: TSQLDBFieldType;
begin
  for F := 0 to length(ColTypes)-1 do
    if not (F in Null) then begin
      colType := ColTypes[F];
      if colType<ftInt64 then begin // ftUnknown,ftNull
        colType := SQLFIELDTYPETODBFIELDTYPE[aTable.FieldType(F)]; // per-row column type (SQLite3 only)
        W.Write1(ord(colType));
      end;
      case colType of
      ftInt64:
      begin
        W.WriteVarInt64(aTable.FieldAsInteger(F));
      end;
      ftDouble: begin
        VDouble := aTable.FieldAsFloat(F);
        W.Write(@VDouble,sizeof(VDouble));
      end;
      SynCommons.ftCurrency: begin
        VCurrency := aTable.Field(F);
        W.Write(@VCurrency,sizeof(VCurrency));
      end;
      SynCommons.ftDate: begin
        VDateTime := aTable.Field(F);
        W.Write(@VDateTime,sizeof(VDateTime));
      end;
      SynCommons.ftUTF8:
      begin
        W.Write(aTable.FieldBuffer(F));
      end;
      SynCommons.ftBlob:
      begin
        W.Write(aTable.FieldBuffer(F));
      end;
      else
      raise ESQLDBException.CreateUTF8('JSONColumnsToBinary: Invalid ColumnType(%)=%',
        [aTable.Get(0, F),ord(colType)]);
    end;
  end;
end;

function JSONToBinary(const aTable: TSQLTableJSON; Dest: TStream; MaxRowCount: cardinal=0; DataRowPosition: PCardinalDynArray=nil): cardinal;
var F, FMax, FieldSize, NullRowSize: integer;
    StartPos: cardinal;
    Null: TSQLDBProxyStatementColumns;
    W: TFileBufferWriter;
    ColTypes: TSQLDBFieldTypeDynArray;
begin
  FillChar(Null,sizeof(Null),0);
  result := 0;
  W := TFileBufferWriter.Create(Dest);
  try
    W.WriteVarUInt32(FETCHALLTOBINARY_MAGIC);
    FMax := aTable.FieldCount;
    W.WriteVarUInt32(FMax);
    if FMax>0 then begin
      // write column description
      SetLength(ColTypes,FMax);
      dec(FMax);
      for F := 0 to FMax do begin
        W.Write(aTable.Get(0, F));
        ColTypes[F] := SQLFIELDTYPETODBFIELDTYPE[aTable.FieldType(F)];
        FieldSize := aTable.FieldLengthMax(F);
        W.Write1(ord(ColTypes[F]));
        W.WriteVarUInt32(FieldSize);
      end;
      // initialize null handling
      NullRowSize := (FMax shr 3)+1;
      if NullRowSize>sizeof(Null) then
        raise ESQLDBException.CreateUTF8(
          'JSONToBinary: too many columns', []);
      // save all data rows
      StartPos := W.TotalWritten;
      if aTable.Step or (aTable.RowCount=1) then // Need step first or error is raised in Table.Field function.
      repeat
        // save row position in DataRowPosition[] (if any)
        if DataRowPosition<>nil then begin
          if Length(DataRowPosition^)<=integer(result) then
            SetLength(DataRowPosition^,result+result shr 3+256);
          DataRowPosition^[result] := W.TotalWritten-StartPos;
        end;
        // first write null columns flags
        if NullRowSize>0 then begin
          FillChar(Null,NullRowSize,0);
          NullRowSize := 0;
        end;
        for F := 0 to FMax do
        begin
          if VarIsNull(aTable.Field(F)) then begin
            include(Null,F);
            NullRowSize := (F shr 3)+1;
          end;
        end;
        W.WriteVarUInt32(NullRowSize);
        if NullRowSize>0 then
          W.Write(@Null,NullRowSize);
        // then write data values
        JSONColumnsToBinary(aTable, W,Null,ColTypes);
        inc(result);
        if (MaxRowCount>0) and (result>=MaxRowCount) then
          break;
      until not aTable.Step;
    end;
    W.Write(@result,SizeOf(result)); // fixed size at the end for row count
    W.Flush;
  finally
    W.Free;
  end;
end;

{ TSynRestSQLDataSet }

function TSynRestSQLDataSet.BindParams(const aStatement: RawUTF8): RawUTF8;
var
  I: Integer;
  lParamName: string;
begin
  Result := aStatement;
  if (Pos(':', aStatement) = 0) and (fParams.Count = 0) then
    Exit;
  if ((Pos(':', aStatement) = 0) and (fParams.Count > 0)) or ((Pos(':', aStatement) > 0) and (fParams.Count = 0)) then
    raise ESQLRestException.CreateUTF8('Statement parameters (%) not match with Params (Count=%) property',
      [aStatement, fParams.Count]);
  for I := 0 to fParams.Count-1 do
  begin
    lParamName := ':' + fParams[I].Name;
    Result := StringReplace(Result, lParamName, fParams[I].AsString, [rfIgnoreCase]);
  end;
  // remove space before and after &
  Result := StringReplaceAll(Result, ' & ', '&');
end;

function TSynRestSQLDataSet.GetSQLRecordClass: TSQLRecordClass;
begin
  Result := fSQLModel.Table[GetTableName];
  if not Assigned(Result) then
    raise ESQLRestException.CreateUTF8('Table % not registered in SQL Model', [GetTableName]);
end;

function TSynRestSQLDataSet.GetTableName: string;
var
  I: Integer;
begin
  if not IsTableFromService then
    Result := PSGetTableName
  else
  begin
    Result := fTableName;
    for I := 1 to Length(Result) do
      if (Result[I] = '.') then
      begin
        Result[I] := '_';  // change only the firs found
        Break;
      end;
  end;
end;

procedure TSynRestSQLDataSet.InternalClose;
begin
  inherited InternalClose;
  FreeAndNil(fDataAccess);
  fData := '';
end;

function TSynRestSQLDataSet.InternalFrom(const aStatement: RawUTF8): RawByteString;

  procedure UpdateFields(aSQLTableJSON: TSQLTableJSON);
  var
    I, J: Integer;
    lFields: TSQLPropInfoList;
  begin
    lFields := GetSQLRecordClass.RecordProps.Fields;
    for I := 0 to aSQLTableJSON.FieldCount-1 do
    begin
      J := lFields.IndexByName(aSQLTableJSON.Get(0, I));
      if (J > -1) then
        aSQLTableJSON.SetFieldType(I, lFields.Items[J].SQLFieldType, Nil, lFields.Items[J].FieldWidth);
    end;
  end;

var
  lData: TRawByteStringStream;
  lSQLTableJSON: TSQLTableJSON;
  lStatement: RawUTF8;
  lDocVar: TDocVariantData;
  lTmp: RawUTF8;
  lResp: TDocVariantData;
begin
  Result := '';
  lStatement := BindParams(aStatement);
  if (lStatement <> '') then
    lStatement := '?' + lStatement;
  Result := TWinHTTP.Get(fBaseURL + fRoot + fTableName + lStatement);
  if (Result = '') then
    raise ESynException.CreateUTF8('Cannot get response (timeout?) from %', [fBaseURL + fRoot + fTableName + lStatement]);
  if (Result <> '') then
  begin
    lResp.InitJSON(Result);
    if (lResp.Kind = dvUndefined) then
      raise ESynException.CreateUTF8('Invalid JSON response' + sLineBreak + '%' + sLineBreak + 'from' + sLineBreak + '%',
                                     [Result, fBaseURL + fRoot + fTableName + lStatement]);
    if (lResp.Kind = dvObject) then
      if (lResp.GetValueIndex('errorCode') > -1) then
        if (lResp.GetValueIndex('errorText') > -1) then
          raise ESynException.CreateUTF8('Error' + sLineBreak + '%' + sLineBreak + 'from' + sLineBreak + '%',
                                         [lResp.Value['errorText'], fBaseURL + fRoot + fTableName + lStatement])
        else if (lResp.GetValueIndex('error') > -1) then
          raise ESynException.CreateUTF8('Error' + sLineBreak + '%' + sLineBreak + 'from' + sLineBreak + '%', [lResp.Value['error'], fBaseURL + fRoot + fTableName + lStatement]);

    if IsTableFromService then // is the source dataset from a service ?
    begin
      lDocVar.InitJSON(Result);
      lTmp := lDocVar.Values[0];
      lDocVar.Clear;
      lDocVar.InitJSON(lTmp);
      if (lDocVar.Kind <> dvArray) then
        raise ESQLRestException.CreateUTF8('The service % not return an array', [fTableName]);
      // if the array is empty, nothing to return
      Result := lDocVar.Values[0];
      if (Result = '') or (Result = '[]') or (Result = '{}') then
        raise ESQLRestException.CreateUTF8('Service % not return a valid array', [fTableName]);
    end;
    lSQLTableJSON := TSQLTableJSON.CreateFromTables([GetSQLRecordClass], '', Result);
    // update info fields for avoid error conversion in JSONToBinary
    UpdateFields(lSQLTableJSON);
    lData := TRawByteStringStream.Create('');
    try
      JSONToBinary(lSQLTableJSON, lData);
      Result := lData.DataString
    finally
      FreeAndNil(lData);
      FreeAndNil(lSQLTableJSON);
    end;
  end;
end;

procedure TSynRestSQLDataSet.InternalInitFieldDefs;
var F: integer;
    lFields: TSQLPropInfoList;
    lFieldDef: TFieldDef;
begin
  inherited;
  if (GetTableName = '') then // JSON conversion to dataset ?
    Exit;
  // update field definitions from associated TSQLRecordClass of the table
  lFields := GetSQLRecordClass.RecordProps.Fields;
  for F := 0 to lFields.Count-1 do
  begin
    lFieldDef := TFieldDef(TDefCollection(FieldDefs).Find(lFields.Items[F].Name));
    if Assigned(lFieldDef) then
    begin
      if (lFieldDef.DataType <> SQLFieldTypeToVCLDB[lFields.Items[F].SQLFieldType]) then
        lFieldDef.DataType := SQLFieldTypeToVCLDB[lFields.Items[F].SQLFieldType];
      if (lFieldDef.Size < lFields.Items[F].FieldWidth) then
        lFieldDef.Size := lFields.Items[F].FieldWidth;
    end;
  end;
end;

function TSynRestSQLDataSet.IsTableFromService: Boolean;
begin
  Result := (Pos('.', fTableName) > 0);
end;

procedure TSynRestSQLDataSet.InternalOpen;
var
  lData: RawByteString;
begin
  if (fCommandText='') and (not IsTableFromService) then begin
    if fData<>'' then // called e.g. after From() method
      inherited InternalOpen;
    exit;
  end;
  lData := InternalFrom(fCommandText);
  if (lData <> '') then
  begin
    From(lData);
    inherited InternalOpen;
  end;
end;

procedure TSynRestSQLDataSet.ParseCommandText;
var
  lSQL: RawUTF8;
begin
  // it is assumed http://host:port/root/tablename, the rest is optional: ?select=&where=&sort= etc.
  if not fURI.From(fCommandText) then
    raise ESynException.CreateUTF8('Invalid % command text. Must have the format protocol://host:port', [fCommandText]);
  if not fURI.Https then
    fBaseURL := FormatUTF8('http://%:%/', [fURI.Server, fURI.Port])
  else
    fBaseURL := FormatUTF8('https://%:%/', [fURI.Server, fURI.Port]);
  Split(fURI.Address, '/', fRoot, fTableName);
  if (fRoot = '') or (fTableName = '') then
    raise ESynException.CreateUTF8('Invalid % root. Must have the format protocol://host:port/root/tablename', [fCommandText]);
  fRoot := fRoot + '/';
  if (Pos('?', fTableName) > 0) then
    Split(fTableName, '?', fTableName, lSQL);
  if not Assigned(fSQLModel) then
    raise ESQLRestException.CreateUTF8('Error parsing command text. Empty Model.', []);
  fCommandText := lSQL
end;

{$ifdef ISDELPHIXE3}

function TSynRestSQLDataSet.PSExecuteStatement(const ASQL: string; AParams: TParams; var ResultSet: TDataSet): Integer;
{$else}
function TSynRestSQLDataSet.PSExecuteStatement(const ASQL: string; AParams: TParams; ResultSet: Pointer): Integer;
{$endif}

  function Compute(const aJSON: SockString; const aOccasion: TSQLOccasion): SockString;
  var
    lRec: TSQLRecord;
    lRecBak: TSQLRecord; // backup for get modifications
    lJSON: TDocVariantData;
    I: Integer;
    lCount: Integer;
    lOccasion: TSQLEvent;
    lVarValue: Variant;
    lVarValueBak: Variant;
  begin
    lRec := GetSQLRecordClass.Create;
    lRecBak := GetSQLRecordClass.Create;
    try
      lJSON.InitJSON(aJSON);
      lCount := lJSON.Count;
      // update record fields
      for I := 0 to lCount-1 do
        lRec.SetFieldValue(lJSON.Names[I], PUTF8Char(VariantToUTF8(lJSON.Values[I])));
      lOccasion := seUpdate;
      if (aOccasion = soInsert) then
        lOccasion := seAdd;
      lRec.ComputeFieldsBeforeWrite(Nil, lOccasion);
      // get modified fields
      for I := 0 to lRec.RecordProps.Fields.Count-1 do
      begin
        lRec.RecordProps.Fields.Items[I].GetVariant(lRec, lVarValue);
        lRecBak.RecordProps.Fields.Items[I].GetVariant(lRecBak, lVarValueBak);
        if (lVarValue <> lVarValueBak) then
          lJSON.Value[lRec.RecordProps.Fields.Items[I].Name] := lVarValue;
      end;
      Result := lJSON.ToJSON;
    finally
      lRec.Free;
      lRecBak.Free;
    end;
  end;

  function ExtractFields(const aSQL, aAfterStr, aBeforeStr: string): string;
  var
    lPosStart: Integer;
    lPosEnd: Integer;
    lSQL: string;
  begin
    lSQL := StringReplace(aSQL, sLineBreak, ' ', [rfReplaceAll]);
    lPosStart := Pos(aAfterStr, lSQL)+Length(aAfterStr);
    lPosEnd   := Pos(aBeforeStr, lSQL);
    Result := Trim(Copy(lSQL, lPosStart, lPosEnd-lPosStart));
  end;

  function SQLFieldsToJSON(const aSQLOccasion: TSQLOccasion; const aSQL, aAfterStr, aBeforeStr: string; aParams: TParams): SockString;
  var
    I: Integer;
    lLastPos: Integer;
    lFieldValues: TStrings;
  begin
    lFieldValues := TStringList.Create;
    try
      ExtractStrings([','], [], PAnsiChar(ExtractFields(aSQL, aAfterStr, aBeforeStr)), lFieldValues);
      lLastPos := 0;
      with TTextWriter.CreateOwnedStream do
      begin
        Add('{');
        for I := 0 to lFieldValues.Count-1 do
        begin
          if (Pos('=', lFieldValues[I]) = 0) then
            lFieldValues[I] := lFieldValues[I] + '=';
          AddFieldName(Trim(lFieldValues.Names[I]));
          AddVariant(aParams[I].Value);
          Add(',');
          lLastPos := I;
        end;
        CancelLastComma;
        Add('}');
        Result := Text;
        Free;
      end;
      lFieldValues.Clear;
      // the first field after the where clause is the ID
      if (aSQLOccasion <> soInsert) then
        aParams[lLastPos+1].Name := 'ID';
    finally
      lFieldValues.Free;
    end;
  end;

  function GetSQLOccasion(const aSQL: string): TSQLOccasion;
  begin
    if IdemPChar(PUTF8Char(UpperCase(aSQL)), 'DELETE') then
      Result := soDelete
    else if IdemPChar(PUTF8Char(UpperCase(aSQL)), 'INSERT') then
      Result := soInsert
    else
      Result := soUpdate;
  end;

var
  lJSON: SockString;
  lOccasion: TSQLOccasion;
  lResult: SockString;
  lURI: SockString;
  lID: string;
begin // only execute writes in current implementation
  Result := -1;
  if IsTableFromService then
    DatabaseError('Cannot apply updates from a service');
  // build the RESTful URL
  if fURI.Https then
    lURI := FormatUTF8('https://%:%/%/%/',
              [fURI.Server, fURI.Port, fSQLModel.Root, StringToUTF8(PSGetTableName)])
  else
    lURI := FormatUTF8('http://%:%/%/%/' ,
              [fURI.Server, fURI.Port, fSQLModel.Root, StringToUTF8(PSGetTableName)]);
  lOccasion := GetSQLOccasion(aSQL);
  case lOccasion of
    soDelete:
    begin
      lID := aParams[0].Value;
      lURI := lURI + lID;
      lResult := TWinHTTP.Delete(lURI, '');
      if (lResult = '') then
        Result := 1;
    end;
    soInsert:
    begin
      lJSON := SQLFieldsToJSON(soInsert, aSQL, '(', ') ', aParams);
      try
        lJSON := Compute(lJSON, soInsert);
      except
        Result := -1;
        lResult := Exception(ExceptObject).Message;
      end;
      lResult := TWinHTTP.Post(lURI, lJSON);
      if (lResult = '') then
        Result := 1;
    end;
    soUpdate:
    begin
      lJSON := SQLFieldsToJSON(soUpdate, aSQL, 'set ', 'where ', aParams);
      try
        lJSON := Compute(lJSON, soUpdate);
      except
        Result := -1;
        lResult := Exception(ExceptObject).Message;
      end;
      lID := aParams.ParamByName('ID').AsString;
      lURI := lURI + lID;
      lResult := TWinHTTP.Put(lURI, lJSON);
      if (lResult = '') then
        Result := 1;
    end
  end;
  if (Result = -1) and (lResult <> '') then
    DatabaseError(lResult);
end;

function TSynRestSQLDataSet.PSGetTableName: string;
begin
  Result := fTableName;
end;

function TSynRestSQLDataSet.PSIsSQLBased: Boolean;
begin
  result := true;
end;

function TSynRestSQLDataSet.PSIsSQLSupported: Boolean;
begin
  result := true;
end;

procedure TSynRestSQLDataSet.PSSetCommandText(const ACommandText: string);
begin
  if (fCommandText <> ACommandText) then
    SetCommandText(ACommandText);
end;

function TSynRestSQLDataSet.PSUpdateRecord(UpdateKind: TUpdateKind;
  Delta: TDataSet): Boolean;
begin
  result := false;
end;

procedure TSynRestSQLDataSet.SetCommandText(const Value: string);
begin
  if (Value <> fCommandtext) then
  begin
    fCommandText := Value;
    ParseCommandText;
  end;
end;

{$endif FPC}

end.


Changes to SynopseCommit.inc.

1
'1.18.1603'
|
1
'1.18.1604'