SynRestClientDataset - access the Delphi TClientDataset by the mORMot RESTful way

ReadMe.md

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.

===========================================================

Modified by Dewen HOU (houdw2006) 2016-06-10

I enjoy the RESTful way to access the background database. After some discussion with EMartin in the forum of Synopse, I made some modification to TSynRestDataset and intended for a more mORMot way.

A RESTful instance (fRestClient: TSQLRest) is injected into classes TSynRestDataSet and TSynRestSQLDataSet, and which is used to handle all the background data CRUD.

The URI root is associated with the Data Model, and the IP and Port of the remote RESTful server are associated with the RestClient. The TSQLModel is not needed anymore because the TSynRestDataset can get the TSQLModel instance from the RestClient.

Access the background data by calling Service is not supported in this modification anymore, as I think according to the Single Responsibility Principle, this could be done by another class.

Now, the CommandText of TSynRestDataSet, which is inherrited from TClientDataset, is in the Normal SQL statement, as shown in the following code snippet:

			procedure TForm1.FormCreate(Sender: TObject);
			var
			  I: Integer;
			begin
			  fImageLoader := TImageLoader.Create;	// used to load image from blob fields

			  fServer := 'LocalHost';
			  fPort := '8080';
			  fRoot := 'root';
			  fSQLModel := CreateSampleModel(fRoot);
			  fRestClient := TSQLHttpClient.Create(fServer, fPort, fSQLModel);
			
			  SynRestDataset := TSynRestDataset.Create(Nil);
			  SynRestDataset.RestClient := fRestClient;
			  SynRestDataset.CommandText := 'SELECT * FROM BioLife '
			      + 'ORDER BY Species_No ';
			
			  // WHERE and/or ORDER BY clauses, and Parameters can be used as well.
			  //SynRestDataset.CommandText := 'SELECT * FROM BioLife '
			  //    + 'WHERE Species_No < :Species_No '
			  //    + 'ORDER BY Species_No ';
			  //SynRestDataset.Params.ParamByName('SPecies_No').Value := 100;
			  SynRestDataset.AfterScroll := DoOnAfterScroll;
			  SynRestDataset.Open;
			
			  DataSource1.DataSet := SynRestDataset;
			  // show the first record image
			  DoOnAfterScroll(Nil);
			  // hide blob and ID fields in the grid
			  for I := 0 to DBGrid1.Columns.Count-1 do
			  begin
			    if (DBGrid1.Columns[I].Field.DataType = DB.ftBlob) then
			      DBGrid1.Columns[I].Visible := False
			    else if (DBGrid1.Columns[I].Field.FieldName = 'ID') then  // Hide the ID column
			      DBGrid1.Columns[I].Visible := False;
			  end;
			end;

For the convinient of loading image into the TImage component, I have implemented a helpler class TImageLoader in unit ImageLoader.pas, which can be used to load JPeg, Png, Gif, Bmp image from the stream into TPicture object under XE8.

Ffactwin.dfm

object Form1: TForm1
  Left = 341
  Top = 83
  BorderIcons = [biSystemMenu, biMinimize]
  BorderStyle = bsSingle
  Caption = 'FISH FACTS'
  ClientHeight = 615
  ClientWidth = 542
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clBlack
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  ShowHint = True
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object DBLabel1: TDBText
    Left = 8
    Top = 230
    Width = 121
    Height = 24
    Alignment = taCenter
    DataField = 'Common_Name'
    DataSource = DataSource1
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clGreen
    Font.Height = -19
    Font.Name = 'MS Serif'
    Font.Style = [fsBold, fsItalic]
    ParentFont = False
  end
  object Panel1: TPanel
    Left = 8
    Top = 8
    Width = 211
    Height = 216
    Hint = 'Scroll grid below to see other fish'
    ParentShowHint = False
    ShowHint = True
    TabOrder = 0
    object img: TImage
      Left = 1
      Top = 1
      Width = 209
      Height = 214
      Align = alClient
      Stretch = True
    end
  end
  object Panel3: TPanel
    Left = 311
    Top = 8
    Width = 223
    Height = 211
    BevelOuter = bvLowered
    TabOrder = 1
    object DBMemo1: TDBMemo
      Left = 1
      Top = 1
      Width = 221
      Height = 209
      Align = alClient
      BorderStyle = bsNone
      Color = clSilver
      Ctl3D = False
      DataField = 'Notes'
      DataSource = DataSource1
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clBlack
      Font.Height = -11
      Font.Name = 'MS Sans Serif'
      Font.Style = []
      ParentCtl3D = False
      ParentFont = False
      ScrollBars = ssVertical
      TabOrder = 0
    end
  end
  object Panel4: TPanel
    Left = 0
    Top = 256
    Width = 542
    Height = 359
    Align = alBottom
    BevelInner = bvRaised
    BorderStyle = bsSingle
    ParentShowHint = False
    ShowHint = True
    TabOrder = 2
    object DBGrid1: TDBGrid
      Left = 2
      Top = 2
      Width = 534
      Height = 326
      Hint = 'Scroll up/down to see other fish!'
      Align = alClient
      DataSource = DataSource1
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clWindowText
      Font.Height = -11
      Font.Name = 'MS Sans Serif'
      Font.Style = []
      ParentFont = False
      TabOrder = 0
      TitleFont.Charset = DEFAULT_CHARSET
      TitleFont.Color = clBlack
      TitleFont.Height = -11
      TitleFont.Name = 'MS Sans Serif'
      TitleFont.Style = []
    end
    object dbnvgr1: TDBNavigator
      Left = 2
      Top = 328
      Width = 534
      Height = 25
      DataSource = DataSource1
      Align = alBottom
      TabOrder = 1
      OnClick = dbnvgr1Click
    end
  end
  object btnUpload: TButton
    Left = 135
    Top = 230
    Width = 75
    Height = 19
    Caption = 'Upload'
    TabOrder = 3
    OnClick = btnUploadClick
  end
  object pnl1: TPanel
    Left = 309
    Top = 224
    Width = 225
    Height = 22
    TabOrder = 4
    object lbl1: TLabel
      Left = 7
      Top = 4
      Width = 56
      Height = 13
      Caption = 'About the'
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clBlue
      Font.Height = -11
      Font.Name = 'MS Sans Serif'
      Font.Style = [fsBold]
      ParentFont = False
    end
    object dbtxtCommon_Name: TDBText
      Left = 91
      Top = 4
      Width = 115
      Height = 13
      AutoSize = True
      DataField = 'Common_Name'
      DataSource = DataSource1
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clBlue
      Font.Height = -11
      Font.Name = 'MS Sans Serif'
      Font.Style = [fsBold]
      ParentFont = False
    end
  end
  object DataSource1: TDataSource
    Left = 19
    Top = 193
  end
  object dlgOpenPic1: TOpenPictureDialog
    Filter = 
      'All (*.png;*.jpg;*.jpeg;*.gif;*.cur;*.pcx;*.ani;*.jpg;*.jpeg;*.b' +
      'mp;*.ico;*.emf;*.wmf)|*.png;*.jpg;*.jpeg;*.gif;*.cur;*.pcx;*.ani' +
      ';*.jpg;*.jpeg;*.bmp;*.ico;*.emf;*.wmf|JPEG Image File (*.jpg)|*.' +
      'jpg|JPEG Image File (*.jpeg)|*.jpeg|CompuServe GIF Image (*.gif)' +
      '|*.gif|Cursor files (*.cur)|*.cur|PCX Image (*.pcx)|*.pcx|ANI Im' +
      'age (*.ani)|*.ani|JPEG Image File (*.jpg)|*.jpg|JPEG Image File ' +
      '(*.jpeg)|*.jpeg|Bitmaps (*.bmp)|*.bmp|Icons (*.ico)|*.ico|Enhanc' +
      'ed Metafiles (*.emf)|*.emf|Metafiles (*.wmf)|*.wmf|PNG Image Fil' +
      'e (*.png)|*.png'
    Options = [ofHideReadOnly, ofFileMustExist, ofEnableSizing]
    Title = 'Fish Image'
    Left = 238
    Top = 40
  end
end

Ffactwin.pas

unit Ffactwin;

{ This application shows how to display TSynRestDataset style memo and graphic
 fields in a form.

 - This application use TImage for display the image from Project19Server.db3.
 - Originally Implemented by EMartin
 - Modified by HOUDW2006 2016-05-09
}

interface

uses
  SysUtils, Windows, Messages, Classes, Graphics, Controls,
  Forms, StdCtrls, DBCtrls, DBGrids, DB, Buttons, ExtCtrls,
  SynRestMidasVCL, DBClient,
  SynCommons, mORMot, mORMotHttpClient,
  OleCtrls, Dialogs, ExtDlgs,
  SynGdiPlus, Grids, SampleData, ImageLoader;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    DBMemo1: TDBMemo;
    DataSource1: TDataSource;
    DBGrid1: TDBGrid;
    dbnvgr1: TDBNavigator;
    btnUpload: TButton;
    dlgOpenPic1: TOpenPictureDialog;
    img: TImage;
    DBLabel1: TDBText;
    pnl1: TPanel;
    lbl1: TLabel;
    dbtxtCommon_Name: TDBText;
    procedure FormCreate(Sender: TObject);
    procedure dbnvgr1Click(Sender: TObject; Button: TNavigateBtn);
    procedure btnUploadClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    fImageLoader: TImageLoader;
    fServer, fPort, fRoot: RawUTF8;
    fSQLModel: TSQLModel;
    fRestClient: TSQLRest;
    SynRestDataset: TSynRestDataset;

    procedure DoOnAfterScroll(Dataset: TDataset);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
  I: Integer;
begin
  fImageLoader := TImageLoader.Create;	// used to load image from blob fields

  fServer := 'LocalHost';
  fPort := '8080';
  fRoot := 'root';
  fSQLModel := CreateSampleModel(fRoot);
  fRestClient := TSQLHttpClient.Create(fServer, fPort, fSQLModel);

  SynRestDataset := TSynRestDataset.Create(Nil);
  SynRestDataset.RestClient := fRestClient;
  SynRestDataset.CommandText := 'SELECT * FROM BioLife '
      + 'ORDER BY Species_No ';

  // WHERE and/or ORDER BY clauses, and Parameters can be used as well.
  //SynRestDataset.CommandText := 'SELECT * FROM BioLife '
  //    + 'WHERE Species_No < :Species_No '
  //    + 'ORDER BY Species_No ';
  //SynRestDataset.Params.ParamByName('SPecies_No').Value := 100;
  SynRestDataset.AfterScroll := DoOnAfterScroll;
  SynRestDataset.Open;

  DataSource1.DataSet := SynRestDataset;
  // show the first record image
  DoOnAfterScroll(Nil);
  // hide blob and ID fields in the grid
  for I := 0 to DBGrid1.Columns.Count-1 do
  begin
    if (DBGrid1.Columns[I].Field.DataType = DB.ftBlob) then
      DBGrid1.Columns[I].Visible := False
    else if (DBGrid1.Columns[I].Field.FieldName = 'ID') then  // Hide the ID column
      DBGrid1.Columns[I].Visible := False;
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FreeAndNil(fImageLoader);
  FreeAndNil(SynRestDataset);
  FreeAndNil(fRestClient);
  FreeAndNil(fSQLModel);
end;

procedure TForm1.dbnvgr1Click(Sender: TObject; Button: TNavigateBtn);
begin
  case Button of
    nbDelete, nbPost:
      SynRestDataset.ApplyUpdates(0);
  end;
end;

procedure TForm1.btnUploadClick(Sender: TObject);
var
  fID: Integer;
  fStream: TMemoryStream;
begin
  fStream := TMemoryStream.Create;
  try
    if dlgOpenPic1.Execute then
    begin
      fStream.LoadFromFile(dlgOpenPic1.FileName);
      fStream.Position := 0;
      fID := SynRestDataset.FieldByName('ID').AsInteger;
      SynRestDataset.RestClient.UpdateBlob(TSQLBiolife, fID, 'Graphic', fStream);

      fImageLoader.LoadImage(img.Picture, fStream);
    end;
  finally
    fStream.Free;
  end;
end;

procedure TForm1.DoOnAfterScroll(Dataset: TDataset);
var
  fID: TID;
  fBlobData: TSQLRawBlob;
begin
  fID := SynRestDataset.FieldByName('ID').AsInteger;
  if (SynRestDataset.RestClient.RetrieveBlob(TSQLBiolife, fID, 'Graphic', fBlobData)) then
  begin
    fImageLoader.LoadImage(img.Picture, fBlobData);
  end;
end;

end.

ImageLoader.pas

unit ImageLoader;

// Image Loader: a helpler class for loading Image from stream into TPicture.
// Implemented by Dewen HOU (HOUDW2006) and it is open source.

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

interface

uses
  Classes, ExtCtrls, SysUtils,
  Graphics,
  {$ifdef ISDELPHIXE2}
  vcl.Imaging.jpeg, vcl.Imaging.pngImage, Vcl.Imaging.GIFImg,
  {$ELSE}
  jpeg,
  {$ENDIF}
  SynCommons, mORMot;  // TSQLRawBlob

type
  TImageType = (itNone=0, itBmp, itJpg, itPng, itGif,
    itPcx, itTiff, itRas, itPsd, itSgi);

  TImageLoader = class(TObject)
  private
    aBmp: TBitmap;
    aJpg: TJPEGImage;
    {$ifdef ISDELPHIXE2}
    aGif: TGifImage;
    aPng: TPngImage;
    {$ENDIF}
  protected
    function GuessImageType(aStream: TStream): TImageType;
    function TryLoadGraphic(aImage: TPicture; aStream: TStream; aGraphic: TGraphic): Boolean;

    function TryLoadBmp(aImage: TPicture; aStream: TStream): Boolean;
    function TryLoadJpg(aImage: TPicture; aStream: TStream): Boolean;
    {$ifdef ISDELPHIXE2}
    function TryLoadGif(aImage: TPicture; aStream: TStream): Boolean;
    function TryLoadPng(aImage: TPicture; aStream: TStream): Boolean;
    {$ENDIF}
  public
    constructor Create;
    destructor Destroy; override;

    function LoadImage(aImage: TPicture; aStream: TStream): Boolean; overload;
    function LoadImage(aImage: TPicture; const aBlobData: TSQLRawBlob): Boolean; overload;
  end;

implementation

{ TImageLoader }

constructor TImageLoader.Create;
begin
  inherited;

  aBmp := TBitmap.Create;
  aJpg := TJPEGImage.Create;
  {$ifdef ISDELPHIXE2}
  aGif := TGifImage.Create;
  aPng := TPngImage.Create;
  {$ENDIF}
end;

destructor TImageLoader.Destroy;
begin
  aBmp.Free;
  aJpg.Free;
  {$ifdef ISDELPHIXE2}
  aGif.Free;
  aPng.Free;
  {$ENDIF}

  inherited;
end;

function TImageLoader.GuessImageType(aStream: TStream): TImageType;
var
  Buffer: Word;
begin
  Result := itNone;

  if aStream.Size >= 2 then
  try
    // guess the Image type from the first 2 bytes of image header
    aStream.Position := 0;
    aStream.ReadBuffer(Buffer, 2);
    case Buffer of
      $4D42: Result := itBmp;
      $D8FF: Result := itJpg;
      $4947: Result := itGif;
      $5089: Result := itPng;
      $4949: Result := itTiff;
      $050A: Result := itPcx;
      $4238: Result := itPsd;
      $A659: Result := itRas;
      $DA01: Result := itSgi;
    end;
  finally
    aStream.Position := 0;  // restore the position of stream
  end;
end;

function TImageLoader.LoadImage(aImage: TPicture; const aBlobData: TSQLRawBlob): Boolean;
var
  fStream: TMemoryStream;
begin
  fStream := TMemoryStream.Create;
  try
    fStream.Write(Pointer(aBlobData)^, Length(aBlobData));

    Result := LoadImage(aImage, fStream);
  finally
    fStream.Free;
  end;
end;

function TImageLoader.LoadImage(aImage: TPicture; aStream: TStream): Boolean;
begin
  if Assigned(aImage.Graphic) then
    aImage.Graphic := nil;

  case GuessImageType(aStream) of
    itBmp: Result := TryLoadBmp(aImage, aStream);
    itJpg: Result := TryLoadJpg(aImage, aStream);
    {$ifdef ISDELPHIXE2}
    itGif: Result := TryLoadGif(aImage, aStream);
    itPng: Result := TryLoadPng(aImage, aStream);
    {$ENDIF}
    else Result := False;
  end;
end;

function TImageLoader.TryLoadBmp(aImage: TPicture; aStream: TStream): Boolean;
begin
  Result := TryLoadGraphic(aImage, aStream, aBmp);
end;

function TImageLoader.TryLoadJpg(aImage: TPicture; aStream: TStream): Boolean;
begin
  Result := TryLoadGraphic(aImage, aStream, aJpg);
end;

{$ifdef ISDELPHIXE2}
function TImageLoader.TryLoadGif(aImage: TPicture; aStream: TStream): Boolean;
begin
  Result := TryLoadGraphic(aImage, aStream, aGif);
end;

function TImageLoader.TryLoadPng(aImage: TPicture; aStream: TStream): Boolean;
begin
  Result := TryLoadGraphic(aImage, aStream, aPng);
end;
{$ENDIF}

function TImageLoader.TryLoadGraphic(aImage: TPicture; aStream: TStream;
  aGraphic: TGraphic): Boolean;
begin
  Result := True;
  try
    aStream.Position := 0;
    aGraphic.LoadFromStream(aStream);
    aImage.Assign(aGraphic);
  except on E: Exception  do
    Result := False;
  end;
end;

end.

SampleData.pas

/// it's a good practice to put all data definition into a stand-alone unit
// - this unit will be shared between client and server
unit SampleData;

interface

uses
  SynCommons,
  mORMot;

type
  /// here we declare the class containing the data
  // - it just has to inherits from TSQLRecord, and the published
  // properties will be used for the ORM (and all SQL creation)
  // - the beginning of the class name must be 'TSQL' for proper table naming
  // in client/server environnment
  TSQLBiolife = class(TSQLRecord)
  private
    fSpecies_No: Integer;
    fCategory: RawUTF8;
    fCommon_Name: RawUTF8;
    fSpecies_Name: RawUTF8;
    fLength_cm: double;
    fLength_in: double;
    fNotes: RawUTF8;
    fGraphic: TSQLRawBlob;
    fSom: TSQLRawBlob;
  published
    property Species_No: Integer read fSpecies_No write fSpecies_No;
    property Category: RawUTF8 index 15 read fCategory write fCategory;
    property Common_Name: RawUTF8 index 30 read fCommon_Name write fCommon_Name;
    property Species_Name: RawUTF8 index 40 read fSpecies_Name write fSpecies_Name;
    property Length_cm: Double read fLength_Cm write fLength_Cm;
    property Length_In: Double read fLength_In write fLength_In;
    property Notes: RawUTF8 read fNotes write fNotes;
    property Graphic: TSQLRawBlob read fGraphic write fGraphic;
    property Som: TSQLRawBlob read fSom write fSom;
  end;

/// an easy way to create a database model for client and server
function CreateSampleModel(HttpRoot: RawUTF8): TSQLModel;


implementation

function CreateSampleModel(HttpRoot: RawUTF8): TSQLModel;
begin
  result := TSQLModel.Create([TSQLBioLife], HttpRoot);
end;

end.

SynRestMidasVCL.pas

/// 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) 2016 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) 2016
  the Initial Developer. All Rights Reserved.

  Contributor(s):
  - Esteban Martin
  - 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 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
  - fixed Delphi XE2 compilation issue with SetCommandText declaration	
  - bug fix skipping first record

}

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

interface

uses
  {$ifdef ISDELPHIXE2}System.SysUtils,{$else}SysUtils,{$endif}
  Classes,
{$ifndef DELPHI5OROLDER}
  Variants,
{$endif}
  mORMot,
  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, Originally implemented by EMartin and modified by houdw2006, which allows to apply updates by the RESTful way.
  //  An instance of TSQLRest 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:
  // ! fRoot := 'root';
  // ! fServer := 'LocalHost';
  // ! fPort := '8080';
  // ! fSQLModel := CreateSampleModel(fRoot);
  // ! fRestClient := TSQLHttpClient.Create(fServer, fPort, fSQLModel);  // an instance of TSQLRest
  // ! ds := TSynRestDataSet.Create(MainForm);
  // ! ds.RestClient := fRestClient; // The RestClient is required for delegating the CRUD operation of ds
  // ! ds.CommandText := 'SELECT * FROM TableName WHERE condition ORDER BY fieldname';
  // - Parameters are supported the usual way in the where condition expression
  // ! 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);
  // ! // ... use ds as usual, including modifications
  // ! ds.ApplyUpdates(0);
  TSynRestDataSet = class(TCustomClientDataSet)
  private
    procedure DoOnBeforeDelete(aDataSet: TDataSet);
    procedure DoOnAfterInsert(aDataSet: TDataSet);
    function GetRestClient: TSQLRest;
    procedure SetRestClient(const Value: TSQLRest);
  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}
    {$IFNDEF NEXTGEN}
    {$ifdef ISDELPHIXE2}
    procedure SetCommandText(Value: WideString); override;
    {$else ISDELPHIXE2}
    procedure SetCommandText(Value: String); override;
    {$endif ISDELPHIXE2}
    {$ELSE}
    procedure SetCommandText(Value: String); override;
    {$ENDIF !NEXTGEN}
    procedure SetFieldValidateFromSQLRecordSynValidate;
  public
    /// initialize the instance
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; 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;

    property RestClient: TSQLRest read GetRestClient write SetRestClient;
  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}

{ 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.AfterInsert := Self.DoOnAfterInsert;
  Self.BeforeDelete := Self.DoOnBeforeDelete;
  fDataSet.SetSubComponent(True);
  fProvider.DataSet := fDataSet;
end;

destructor TSynRestDataSet.Destroy;
begin
  Self.BeforeDelete := nil;
  fDataSet.AfterInsert := nil;

  fProvider.DataSet := nil;
  FreeAndNil(fDataSet);
  FreeAndNil(fProvider);

  inherited;
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(StringToUTF8(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;

function TSynRestDataSet.GetRestClient: TSQLRest;
begin
  Result := fDataSet.RestClient;
end;

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

procedure TSynRestDataSet.DoOnAfterInsert(aDataSet: TDataSet);
begin
  if not (State in [dsEdit, dsInsert]) then
    Edit;

  FieldByName('ID').AsInteger := TSynRestSQLDatasetHack(aDataSet).InsertedID;
end;

procedure TSynRestDataSet.DoOnBeforeDelete(aDataSet: TDataSet);
begin
  fDataSet.DeletedID := FieldByName('ID').AsInteger;
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}

{$IFNDEF NEXTGEN}
{$ifdef ISDELPHIXE2}
procedure TSynRestDataSet.SetCommandText(Value: WideString);
{$else ISDELPHIXE2}
procedure TSynRestDataSet.SetCommandText(Value: String);
{$endif ISDELPHIXE2}
{$ELSE}
procedure TSynRestDataSet.SetCommandText(Value: String);
{$ENDIF !NEXTGEN}
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(StringToUTF8(Fields[F].FieldName));
    if (V > -1) then
    begin
      if (Length(lProps.Filters[V]) > 0) then
        Fields[F].OnValidate := DoOnFieldValidate;
    end;
  end;
end;

procedure TSynRestDataSet.SetRestClient(const Value: TSQLRest);
begin
  fDataSet.RestClient := Value;
end;

{$endif FPC}

end.

SynRestVCL.pas

/// 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) 2016 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) 2016
  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

}

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

interface

uses
{$ifdef MSWINDOWS}
  Windows,
{$else}
  {$ifdef KYLIX3}
  Types,
  LibC,
  {$endif}
{$endif}
{$ifdef ISDELPHIXE2}System.SysUtils,{$else}SysUtils,{$endif}
  Classes,
{$ifndef DELPHI5OROLDER}
  Variants,
{$endif}
  mORMot,
  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
  TSynRestSQLDataSet = class(TSynBinaryDataSet)
  private
    fRestClient: TSQLRest;

    function Compute(const aJSON: SockString; const aOccasion: TSQLOccasion): SockString;
    function ExtractFields(const aSQL, aAfterStr, aBeforeStr: string): string;
    function SQLFieldsToJSON(const aSQLOccasion: TSQLOccasion; var aFieldNames: RawUTF8;
      const aSQL, aAfterStr, aBeforeStr: string; aParams: TParams): SockString;
    function GetSQLOccasion(const aSQL: string): TSQLOccasion;
  protected
    fInsertedID, fDeletedID: TID;
    fCommandText: string;
    fDataSet: TSynBinaryDataSet;

    fOnGetURISignature: TOnGetURISignature;
    fParams: TParams;
    fProvider: TDataSetProvider;
    fTableName: RawUTF8;
    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;
    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
    property DeletedID: TID read fDeletedID write fDeletedID;
    property InsertedID: TID read fInsertedID;

    /// the associated RestClient must be set, or else access violation is raised.
    property RestClient: TSQLRest read fRestClient write fRestClient;
  published
    // - Statement is the nature SQL statement
    // examples:
    //   SELECT * FROM tableName
    //   SELECT * FROM tableName WHERE whereCondition ORDER BY orderByColumns
    //   SELECT * FROM tableName WHERE whereParam = :param ORDER BY orderByColumns
    // 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

  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

  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.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 TSynRestSQLDataSet.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 TSynRestSQLDataSet.SQLFieldsToJSON(const aSQLOccasion: TSQLOccasion;
  var aFieldNames: RawUTF8;
  const aSQL, aAfterStr, aBeforeStr: string; aParams: TParams): SockString;
var
  I: Integer;
  lLastPos: Integer;
  lFieldValues: TStrings;
  lBlob: TSQLRawBlob;
  aFieldNameWriter: TTextWriter;
begin
  aFieldNames := '';
  lFieldValues := TStringList.Create;
  aFieldNameWriter := TTextWriter.CreateOwnedStream;
  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
          aFieldNameWriter.AddString(Trim(lFieldValues.Names[I]));
          aFieldNameWriter.Add(',');

          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;
    aFieldNameWriter.CancelLastComma;
    aFieldNames := aFieldNameWriter.Text;
    lFieldValues.Clear;
    // the first field after the where clause is the ID
    if (aSQLOccasion <> soInsert) then
      aParams[lLastPos+1].Name := 'ID';
  finally
    aFieldNameWriter.Free;
    lFieldValues.Free;
  end;
end;

function TSynRestSQLDataSet.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;

function TSynRestSQLDataSet.BindParams(const aStatement: RawUTF8): RawUTF8;
var
  I: Integer;
  lParamName: string;
begin
  Result := aStatement;
  if (PosEx(':', aStatement) = 0) and (fParams.Count = 0) then
    Exit;
  if ((PosEx(':', aStatement) = 0) and (fParams.Count > 0)) or ((PosEx(':', 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;
end;

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

function TSynRestSQLDataSet.GetTableName: string;
begin
  Result := PSGetTableName
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;
  lResp: TDocVariantData;
  lErrMsg: RawUTF8;
  lURI: RawUTF8;
begin
  lURI := GetTableName;
  lStatement := BindParams(aStatement);
  Result := fRestClient.ExecuteJson([GetSQLRecordClass], lStatement);
  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;

    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, aFieldWidth: integer;
  aFieldType: TSQLFieldType;
  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
      aFieldWidth := lFields.Items[F].FieldWidth;
      aFieldType := lFields.Items[F].SQLFieldType;

      if (lFieldDef.DataType <> SQLFieldTypeToVCLDB[aFieldType]) then
        lFieldDef.DataType := SQLFieldTypeToVCLDB[aFieldType];
      if (aFieldWidth > 0) and (lFieldDef.Size <> aFieldWidth) then
        lFieldDef.Size := aFieldWidth;
    end;
  end;
end;

procedure TSynRestSQLDataSet.InternalOpen;
var
  lData: RawByteString;
begin
  if (fCommandText='') 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
  temp: RawUTF8;
begin
  // it is assumed that fCommandText is in the nature SQL Statement form. eg. SELECT * FROM tableName [WHERE ...]
  Split(UpperCase(fCommandText), 'FROM', temp, fTableName);
  fTableName := Trim(fTableName);
  Split(fTableName, ' ', fTableName, temp);
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}
var
  lJSON: SockString;
  lOccasion: TSQLOccasion;

  fID: TID;
  fFieldNames: RawUTF8;
  fRec: TSQLRecord;
begin // only execute writes in current implementation
  Result := -1;
  lOccasion := GetSQLOccasion(aSQL);
  case lOccasion of
  soDelete:
    begin
      fID := fDeletedID;  // fDeletedID is set by instance of TSynRestDataSet
      if fRestClient.Delete(GetSQLRecordClass, fID) then
        Result := 1;
    end;
  soInsert:
    begin
      lJSON := SQLFieldsToJSON(soInsert, fFieldNames, aSQL, '(', ') ', aParams);
      fRec := GetSQLRecordClass.CreateFrom(lJSON);
      try
        fInsertedID := fRestClient.Add(fRec, fRec.RecordProps.FieldBitsFromCSV(fFieldNames), True);
        if fInsertedID > 0 then
        begin
          Result := 1;
          AfterInsert(Self);  // Update the ID field in the instance of TSynRestDataSet
        end;
      finally
        fRec.Free;
      end;
    end;
  soUpdate:
    begin
      lJSON := SQLFieldsToJSON(soUpdate, fFieldNames, aSQL, 'set ', 'where ', aParams);
      fRec := GetSQLRecordClass.CreateFrom(lJSON);
      try
        fID := aParams.ParamByName('ID').Value;
        fRec.IDValue := fID;  // fRec.ID is readonly, fRec.IDValue is writable
        if fRestClient.Update(fRec, fRec.RecordProps.FieldBitsFromCSV(fFieldNames)) then
          Result := 1;
      finally
        fRec.Free;
      end;
    end
  end;
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.