846 lines
28 KiB
ObjectPascal
846 lines
28 KiB
ObjectPascal
/// 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) 2022 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) 2022
|
|
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 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,
|
|
SynTable,
|
|
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;
|
|
Null: pointer; 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 = SynTable.ftUTF8; const DefaultFieldSize: Integer = 255): cardinal;
|
|
|
|
implementation
|
|
|
|
uses
|
|
DBCommon,
|
|
SynVirtualDataset;
|
|
|
|
const
|
|
FETCHALLTOBINARY_MAGIC = 1;
|
|
|
|
SQLFIELDTYPETODBFIELDTYPE: array[TSQLFieldType] of TSQLDBFieldType =
|
|
(SynTable.ftUnknown, // sftUnknown
|
|
SynTable.ftUTF8, // sftAnsiText
|
|
SynTable.ftUTF8, // sftUTF8Text
|
|
SynTable.ftInt64, // sftEnumerate
|
|
SynTable.ftInt64, // sftSet
|
|
SynTable.ftInt64, // sftInteger
|
|
SynTable.ftInt64, // sftID = TSQLRecord(aID)
|
|
SynTable.ftInt64, // sftRecord = TRecordReference
|
|
SynTable.ftInt64, // sftBoolean
|
|
SynTable.ftDouble, // sftFloat
|
|
SynTable.ftDate, // sftDateTime
|
|
SynTable.ftInt64, // sftTimeLog
|
|
SynTable.ftCurrency, // sftCurrency
|
|
SynTable.ftUTF8, // sftObject
|
|
{$ifndef NOVARIANTS}
|
|
SynTable.ftUTF8, // sftVariant
|
|
SynTable.ftUTF8, // sftNullable
|
|
{$endif}
|
|
SynTable.ftBlob, // sftBlob
|
|
SynTable.ftBlob, // sftBlobDynArray
|
|
SynTable.ftBlob, // sftBlobCustom
|
|
SynTable.ftUTF8, // sftUTF8Custom
|
|
SynTable.ftUnknown, // sftMany
|
|
SynTable.ftInt64, // sftModTime
|
|
SynTable.ftInt64, // sftCreateTime
|
|
SynTable.ftInt64, // sftTID
|
|
SynTable.ftInt64, // sftRecordVersion = TRecordVersion
|
|
SynTable.ftInt64, // sftSessionUserID
|
|
SynTable.ftDate, // sftDateTimeMS
|
|
SynTable.ftInt64, // sftUnixTime
|
|
SynTable.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;
|
|
Null: pointer; 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 GetBitPtr(Null,F) 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;
|
|
SynTable.ftCurrency: begin
|
|
VCurrency := aTable.Field(F);
|
|
W.Write(@VCurrency,sizeof(VCurrency));
|
|
end;
|
|
SynTable.ftDate: begin
|
|
VDateTime := aTable.Field(F);
|
|
W.Write(@VDateTime,sizeof(VDateTime));
|
|
end;
|
|
SynTable.ftUTF8:
|
|
begin
|
|
W.Write(aTable.FieldBuffer(F));
|
|
end;
|
|
SynTable.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 = SynTable.ftUTF8; const DefaultFieldSize: Integer = 255): cardinal;
|
|
var F, FMax, FieldSize, NullRowSize: integer;
|
|
StartPos: cardinal;
|
|
Null: TByteDynArray;
|
|
W: TFileBufferWriter;
|
|
ColTypes: TSQLDBFieldTypeDynArray;
|
|
FieldType: TSQLDBFieldType;
|
|
begin
|
|
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 = SynTable.ftUnknown) and (DefaultDataType <> SynTable.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
|
|
SetLength(Null,(FMax shr 3)+1);
|
|
NullRowSize := 0;
|
|
// 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[0],NullRowSize,0);
|
|
NullRowSize := 0;
|
|
end;
|
|
for F := 0 to FMax do
|
|
begin
|
|
if VarIsNull(aTable.Field(F)) then begin
|
|
SetBitPtr(pointer(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.
|
|
|
|
|