-
-
Notifications
You must be signed in to change notification settings - Fork 324
/
SynRestVCL.pas
847 lines (786 loc) · 29.6 KB
/
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
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
/// 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) 2018 Arnaud Bouchez
Synopse Informatique - https://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) 2018
the Initial Developer. All Rights Reserved.
Contributor(s):
- Esteban Martin (EMartin)
- houdw2006
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.
- Added that blob field updates they are made with AddJSONEscapeString.
- bug fix when updating accentuated string fields.
- bug fix with datetime fields
- bug fix with length string fields
- fixed Delphi XE3 compilation issue with PSExecuteStatement declaration (by houdw2006)
- added sftSessionUserID to SQLFIELDTYPETODBFIELDTYPE and SQLFieldTypeToVCLDB
}
{$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);
/// URI signature event
TOnGetURISignature = procedure(Sender: TObject; var aURI: string) of object;
/// 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;
fOnGetURISignature: TOnGetURISignature;
fParams: TParams;
fProvider: TDataSetProvider;
fRoot: RawUTF8;
fSQLModel: TSQLModel;
fTableName: RawUTF8;
fURI: TURI;
function BindParams(const aStatement: RawUTF8): RawUTF8;
function BuildURI(const aURI: SockString): SockString;
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;
/// event to get URI signature
property OnGetURISignature: TOnGetURISignature write fOnGetURISignature;
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;
const DefaultDataType: TSQLDBFieldType = SynCommons.ftUTF8; const DefaultFieldSize: Integer = 255): 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
SynCommons.ftInt64, // sftSessionUserID
SynCommons.ftDate, // sftDateTimeMS
SynCommons.ftInt64, // sftUnixTime
SynCommons.ftInt64); // sftUnixMSTime
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.ftDateTime, // 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
DB.ftLargeInt, // sftSessionUserID
DB.ftDateTime, // sftDateTime
DB.ftLargeInt, // sftUnixTime
DB.ftLargeInt); // sftUnixMSTime
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;
const DefaultDataType: TSQLDBFieldType = SynCommons.ftUTF8; const DefaultFieldSize: Integer = 255): cardinal;
var F, FMax, FieldSize, NullRowSize: integer;
StartPos: cardinal;
Null: TSQLDBProxyStatementColumns;
W: TFileBufferWriter;
ColTypes: TSQLDBFieldTypeDynArray;
FieldType: TSQLDBFieldType;
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));
FieldType := SQLFIELDTYPETODBFIELDTYPE[aTable.FieldType(F)];
if (FieldType = SynCommons.ftUnknown) and (DefaultDataType <> SynCommons.ftUnknown) then
FieldType := DefaultDataType;
ColTypes[F] := FieldType;
FieldSize := aTable.FieldLengthMax(F);
if (FieldSize = 0) and (FieldType = DefaultDataType) and (DefaultFieldSize <> 0) then
FieldSize := DefaultFieldSize;
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.BuildURI(const aURI: SockString): SockString;
var
lTmpURI: string;
begin
lTmpURI := aURI;
if Assigned(fOnGetURISignature) then
fOnGetURISignature(Self, lTmpURI);
Result := FormatUTF8('%%' , [fBaseURL, lTmpURI]);
if fURI.Https and (Result[5] <> 's') then
System.Insert('s', Result, 5);
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;
lErrMsg: RawUTF8;
lURI: RawUTF8;
begin
Result := '';
lStatement := BindParams(aStatement);
if (lStatement <> '') then
lStatement := '?' + lStatement;
lURI := BuildURI(fRoot + fTableName + lStatement);
Result := TWinHTTP.Get(lURI);
if (Result = '') then
raise ESynException.CreateUTF8('Cannot get response (timeout?) from %', [lURI]);
if (Result <> '') then
begin
lResp.InitJSON(Result);
if (lResp.Kind = dvUndefined) then
raise ESynException.CreateUTF8('Invalid JSON response' + sLineBreak + '%' + sLineBreak + 'from' + sLineBreak + '%',
[Result, lURI]);
if (lResp.Kind = dvObject) then
if (lResp.GetValueIndex('errorCode') > -1) then
if (lResp.GetValueIndex('errorText') > -1) then
begin
lErrMsg := AnyAnsiToUTF8(lResp.Value['errorText']);
raise ESynException.CreateUTF8('Error' + sLineBreak + '%' + sLineBreak + 'from' + sLineBreak + '%',
[lResp.Value['errorText'], lURI]);
end
else if (lResp.GetValueIndex('error') > -1) then
begin
lErrMsg := AnyAnsiToUTF8(lResp.Value['error']);
raise ESynException.CreateUTF8('Error' + sLineBreak + '%' + sLineBreak + 'from' + sLineBreak + '%', [lErrMsg, lURI]);
end;
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, Result]);
// 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, Result]);
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;
lOldSize: Int64;
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
begin
lOldSize := lFieldDef.Size; // DB.pas.TFieldDef.SetDataType change the size
lFieldDef.DataType := SQLFieldTypeToVCLDB[lFields.Items[F].SQLFieldType];
end;
if (lFields.Items[F].FieldWidth > 0) and (lFieldDef.Size < lFields.Items[F].FieldWidth) then
lFieldDef.Size := lFields.Items[F].FieldWidth
else if (lOldSize > 0) and (lFieldDef.Size > 0) and (lOldSize <> lFieldDef.Size) then
lFieldDef.Size := lOldSize;
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): Integer;
var DS: TDataSet;
begin
DS := nil;
result := PSExecuteStatement(ASQL,AParams,DS);
DS.Free;
end;
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.SetFieldVariant(lJSON.Names[I], 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.AddOrUpdateValue(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;
lBlob: TSQLRawBlob;
begin
lFieldValues := TStringList.Create;
try
ExtractStrings([','], [], PChar(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]));
if (aParams[I].DataType <> ftBlob) then
begin
if (TVarData(aParams[I].Value).VType = varString) then
AddVariant(StringToUTF8(aParams[I].Value))
else
AddVariant(aParams[I].Value);
end
else
begin
Add('"');
lBlob := BlobToTSQLRawBlob(PUTF8Char(aParams[I].AsBlob));
AddJSONEscapeString(lBlob);
Add('"');
end;
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
lURI := FormatUTF8('%/%', [fSQLModel.Root, StringToUTF8(PSGetTableName)]);
lOccasion := GetSQLOccasion(aSQL);
case lOccasion of
soDelete:
begin
lID := aParams[0].Value;
lURI := lURI + '/' + lID;
lResult := TWinHTTP.Delete(BuildURI(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(BuildURI(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').Value;
lURI := lURI + '/' + lID;
lResult := TWinHTTP.Put(BuildURI(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.