source upload
This commit is contained in:
Razor12911
@@ -0,0 +1,23 @@
|
||||
#------------------------------------------------------------------------------
|
||||
VERSION = BWS.01
|
||||
#------------------------------------------------------------------------------
|
||||
!ifndef ROOT
|
||||
ROOT = $(MAKEDIR)\..
|
||||
!endif
|
||||
#------------------------------------------------------------------------------
|
||||
MAKE = $(ROOT)\bin\make.exe -$(MAKEFLAGS) -f$**
|
||||
DCC = $(ROOT)\bin\dcc32.exe $**
|
||||
BRCC = $(ROOT)\bin\brcc32.exe $**
|
||||
#------------------------------------------------------------------------------
|
||||
PROJECTS = Server.exe FishFactSyn.exe
|
||||
#------------------------------------------------------------------------------
|
||||
default: $(PROJECTS)
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
Server.exe: Server.dpr
|
||||
$(DCC)
|
||||
|
||||
FishFactSyn.exe: FishFactSyn\FishFactSyn.dpr
|
||||
$(DCC)
|
||||
|
||||
|
||||
@@ -0,0 +1,186 @@
|
||||
object Form1: TForm1
|
||||
Left = 341
|
||||
Top = 83
|
||||
BorderIcons = [biSystemMenu, biMinimize]
|
||||
BorderStyle = bsSingle
|
||||
Caption = 'FISH FACTS'
|
||||
ClientHeight = 584
|
||||
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
|
||||
PixelsPerInch = 96
|
||||
TextHeight = 13
|
||||
object Panel1: TPanel
|
||||
Left = 6
|
||||
Top = 8
|
||||
Width = 299
|
||||
Height = 249
|
||||
Hint = 'Scroll grid below to see other fish'
|
||||
ParentShowHint = False
|
||||
ShowHint = True
|
||||
TabOrder = 0
|
||||
object DBLabel1: TDBText
|
||||
Left = 4
|
||||
Top = 220
|
||||
Width = 249
|
||||
Height = 24
|
||||
DataField = 'Common_Name'
|
||||
DataSource = DataSource1
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clRed
|
||||
Font.Height = -19
|
||||
Font.Name = 'MS Serif'
|
||||
Font.Style = [fsBold, fsItalic]
|
||||
ParentFont = False
|
||||
end
|
||||
object img: TImage
|
||||
Left = 8
|
||||
Top = 8
|
||||
Width = 281
|
||||
Height = 201
|
||||
end
|
||||
object btnUpload: TButton
|
||||
Left = 212
|
||||
Top = 216
|
||||
Width = 75
|
||||
Height = 25
|
||||
Caption = 'Upload'
|
||||
Enabled = False
|
||||
TabOrder = 0
|
||||
OnClick = btnUploadClick
|
||||
end
|
||||
end
|
||||
object Panel2: TPanel
|
||||
Left = 310
|
||||
Top = 8
|
||||
Width = 225
|
||||
Height = 22
|
||||
TabOrder = 1
|
||||
object Label1: 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 DBLabel2: TDBText
|
||||
Left = 67
|
||||
Top = 4
|
||||
Width = 56
|
||||
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 Panel3: TPanel
|
||||
Left = 312
|
||||
Top = 32
|
||||
Width = 223
|
||||
Height = 187
|
||||
BevelOuter = bvLowered
|
||||
TabOrder = 2
|
||||
object DBMemo1: TDBMemo
|
||||
Left = 3
|
||||
Top = 2
|
||||
Width = 217
|
||||
Height = 183
|
||||
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 = 260
|
||||
Width = 542
|
||||
Height = 324
|
||||
Align = alBottom
|
||||
BevelInner = bvRaised
|
||||
BorderStyle = bsSingle
|
||||
ParentShowHint = False
|
||||
ShowHint = True
|
||||
TabOrder = 3
|
||||
object DBGrid1: TDBGrid
|
||||
Left = 2
|
||||
Top = 12
|
||||
Width = 534
|
||||
Height = 281
|
||||
Hint = 'Scroll up/down to see other fish!'
|
||||
Align = alBottom
|
||||
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 = 293
|
||||
Width = 534
|
||||
Height = 25
|
||||
DataSource = DataSource1
|
||||
Align = alBottom
|
||||
TabOrder = 1
|
||||
OnClick = dbnvgr1Click
|
||||
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 = 174
|
||||
Top = 224
|
||||
end
|
||||
end
|
||||
@@ -0,0 +1,99 @@
|
||||
unit Ffactwin;
|
||||
|
||||
{ This application shows how to display TSynRestDataset style memo and graphic
|
||||
fields in a form.
|
||||
|
||||
- This application use TWebBrowser for display the image from Project19Server.db3.
|
||||
- Removed display of image because is need convert the Project19Server.db3 field image to base64 or any suggest.
|
||||
- fixed memory leak (by houdw2006)
|
||||
}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Windows, Messages, Classes, Graphics, Controls,
|
||||
Forms, StdCtrls, DBCtrls, DBGrids, DB, Buttons, Grids, ExtCtrls,
|
||||
SynRestMidasVCL, DBClient,
|
||||
SynCommons, mORMot, OleCtrls, Dialogs, ExtDlgs,
|
||||
SynGdiPlus;
|
||||
|
||||
type
|
||||
TForm1 = class(TForm)
|
||||
Panel1: TPanel;
|
||||
Label1: TLabel;
|
||||
DBLabel1: TDBText;
|
||||
DBMemo1: TDBMemo;
|
||||
DataSource1: TDataSource;
|
||||
DBGrid1: TDBGrid;
|
||||
dbnvgr1: TDBNavigator;
|
||||
btnUpload: TButton;
|
||||
dlgOpenPic1: TOpenPictureDialog;
|
||||
img: TImage;
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure dbnvgr1Click(Sender: TObject; Button: TNavigateBtn);
|
||||
procedure btnUploadClick(Sender: TObject);
|
||||
procedure FormDestroy(Sender: TObject);
|
||||
private
|
||||
{ Private declarations }
|
||||
procedure DoOnAfterScroll(Dataset: TDataset);
|
||||
public
|
||||
{ Public declarations }
|
||||
SynRestDataset: TSynRestDataset;
|
||||
end;
|
||||
|
||||
var
|
||||
Form1: TForm1;
|
||||
|
||||
implementation
|
||||
|
||||
{$R *.dfm}
|
||||
|
||||
uses SampleData;
|
||||
|
||||
procedure TForm1.FormCreate(Sender: TObject);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
SynRestDataset := TSynRestDataset.Create(Nil);
|
||||
SynRestDataset.DataSet.SQLModel := TSQLModel.Create([TSQLBioLife]);
|
||||
SynRestDataset.CommandText := 'http://LocalHost:8080/root/BioLife?select=Species_No,Category,Common_Name,Species_Name,Length_cm,Length_in,Graphic,Notes,Som&sort=Species_No';
|
||||
SynRestDataset.Open;
|
||||
SynRestDataset.AfterScroll := DoOnAfterScroll;
|
||||
DataSource1.DataSet := SynRestDataset;
|
||||
// show the first record image
|
||||
DoOnAfterScroll(Nil);
|
||||
// hide blob fields in the grid
|
||||
for I := 0 to DBGrid1.Columns.Count-1 do
|
||||
if (DBGrid1.Columns[I].Field.DataType = DB.ftBlob) then
|
||||
DBGrid1.Columns[I].Visible := False;
|
||||
end;
|
||||
|
||||
procedure TForm1.dbnvgr1Click(Sender: TObject; Button: TNavigateBtn);
|
||||
begin
|
||||
case Button of
|
||||
nbDelete, nbPost: SynRestDataset.ApplyUpdates(0);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.btnUploadClick(Sender: TObject);
|
||||
begin
|
||||
// I don't know as encode this :(
|
||||
if not (SynRestDataset.State in [dsEdit, dsInsert]) then
|
||||
SynRestDataset.Edit;
|
||||
if dlgOpenPic1.Execute then
|
||||
TBlobField(SynRestDataset.FieldByName('Graphic')).LoadFromFile(dlgOpenPic1.FileName);
|
||||
end;
|
||||
|
||||
procedure TForm1.DoOnAfterScroll(Dataset: TDataset);
|
||||
begin
|
||||
//img.Picture :=
|
||||
end;
|
||||
|
||||
procedure TForm1.FormDestroy(Sender: TObject);
|
||||
begin
|
||||
SynRestDataset.Dataset.SQLModel.Free;
|
||||
SynRestDataset.Dataset.SQLModel := nil;
|
||||
FreeAndNil(SynRestDataset);
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,17 @@
|
||||
program FishFactSyn;
|
||||
|
||||
uses
|
||||
{$I SynDprUses.inc} // use FastMM4 on older Delphi, or set FPC threads
|
||||
Forms,
|
||||
Ffactwin in 'Ffactwin.pas' {Form1},
|
||||
SynRestVCL in '..\SynRestVCL.pas',
|
||||
SynRestMidasVCL in '..\SynRestMidasVCL.pas',
|
||||
SampleData in '..\SampleData.pas';
|
||||
|
||||
{$R *.RES}
|
||||
|
||||
begin
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TForm1, Form1);
|
||||
Application.Run;
|
||||
end.
|
||||
@@ -0,0 +1,189 @@
|
||||
TSynRestDataset
|
||||
===============
|
||||
|
||||
By *EMartin* (Esteban Martin).
|
||||
|
||||
|
||||
# Presentation
|
||||
|
||||
Migrating from *RemObjects* to *mORMot* I had to implement a GUI functionality that *RemObjects* has, an editable dataset connected through URL (RO version 3 use SOAP and other components adapters, etc.).
|
||||
|
||||
My implementation is basic and the most probably is not the best, but works for me, the same use RESTful URL for get and update data, also get data from a *mORMot* interface based services returning a *mORMot* JSON array but cannot update because the table not exists.
|
||||
|
||||
In this folder there are two units: `SynRestVCL.pas` and `SynRestMidasVCL.pas`, both have some duplicated code from its counterpart (`SynDBVCL.pas` and `SynDBMidasVCL.pas`) and the others, but the rest are modifications with use of RESTful instead of the `TSQLDBConnection` (this require the database client installed in the client machine).
|
||||
|
||||
A `TSQLModel` is required because the `TSynRestDataset` get the fields definition column type and size from this. Also is used from the `TSQLRecord` the defined validations (I used `InternalDefineModel`) and the `ComputeFieldsBeforeWrite` (I used this for default values).
|
||||
|
||||
This was developed with Delphi 7 on Windows 7 and probably (almost sure) is not cross platform.
|
||||
|
||||
If this serves for others may be the best option will be that *ab* integrate this in the framework and make this code more *mORMot*. Meanwhile I will update on the google drive.
|
||||
I hope this is helpful to someone.
|
||||
|
||||
# Example 1: from a table
|
||||
|
||||
// defining the table
|
||||
TSQLRecordTest = class(TSQLRecord)
|
||||
private
|
||||
fDecimal: Double;
|
||||
fNumber: Double;
|
||||
fTestID: Integer;
|
||||
fText: RawUTF8;
|
||||
fDateTime: TDateTime;
|
||||
protected
|
||||
class procedure InternalDefineModel(Props: TSQLRecordProperties); override;
|
||||
public
|
||||
procedure ComputeFieldsBeforeWrite(aRest: TSQLRest; aOccasion: TSQLEvent); override;
|
||||
published
|
||||
property Test_ID: Integer read fTestID write fTestID;
|
||||
property Text: RawUTF8 index 255 read fText write fText;
|
||||
property Date_Time: TDateTime read fDateTime write fDateTime;
|
||||
property Number: Double read fNumber write fNumber;
|
||||
property Decimal_: Double read fDecimal write fDecimal;
|
||||
end;
|
||||
|
||||
...
|
||||
|
||||
{ TSQLRecordTest }
|
||||
|
||||
procedure TSQLRecordTest.ComputeFieldsBeforeWrite(aRest: TSQLRest; aOccasion: TSQLEvent);
|
||||
begin
|
||||
inherited;
|
||||
fDateTime := Now;
|
||||
end;
|
||||
|
||||
class procedure TSQLRecordTest.InternalDefineModel(Props: TSQLRecordProperties);
|
||||
begin
|
||||
AddFilterNotVoidText(['Text']);
|
||||
AddFilterOrValidate('Text', TSynValidateNonNull.Create);
|
||||
end;
|
||||
|
||||
// client
|
||||
type
|
||||
TForm3 = class(TForm)
|
||||
DBGrid1: TDBGrid;
|
||||
DBNavigator1: TDBNavigator;
|
||||
btnOpen: TButton;
|
||||
edtURL: TEdit;
|
||||
dsRest: TDataSource;
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure btnOpenClick(Sender: TObject);
|
||||
procedure DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
|
||||
private
|
||||
{ Private declarations }
|
||||
fRestDS: TSynRestDataset;
|
||||
public
|
||||
{ Public declarations }
|
||||
end;
|
||||
|
||||
...
|
||||
|
||||
procedure TForm3.FormCreate(Sender: TObject);
|
||||
begin
|
||||
fRestDS := TSynRestDataset.Create(Self);
|
||||
fRestDS.Dataset.SQLModel := TSQLModel.Create([TSQLRecordTest], 'root');
|
||||
dsRest.Dataset := fRestDS;
|
||||
end;
|
||||
|
||||
procedure TForm3.btnOpenClick(Sender: TObject);
|
||||
begin
|
||||
fRestDS.Close;
|
||||
fRestDS.CommandText := edtURL.Text; // edtURL.Text = 'http://localhost:8888/root/Test/select=*
|
||||
fRestDS.Open;
|
||||
// you can filter by
|
||||
// where: fRestDS.CommandText := edtURL.Text; // edtURL.Text = 'http://localhost:8888/root/Test/select=*&where=CONDITION
|
||||
// fRestDS.Open;
|
||||
// named parameter: fRestDS.CommandText := edtURL.Text; // edtURL.Text = 'http://localhost:8888/root/Test/select=*&where=:PARAMNAME
|
||||
// fRestDS.Params.ParamByName('PARAMNAME').Value := XXX
|
||||
// fRestDS.Open;
|
||||
end;
|
||||
|
||||
procedure TForm3.DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
|
||||
begin
|
||||
if (Button = nbPost) then
|
||||
fRestDS.ApplyUpdates(0);
|
||||
end;
|
||||
|
||||
# Example 2: from a service
|
||||
|
||||
// defining the table, the service name and operation name are required
|
||||
TSQLRecordServiceName_OperationName = class(TSQLRecord)
|
||||
private
|
||||
fText: RawUTF8;
|
||||
published
|
||||
property Text: RawUTF8 index 255 read fText write fText;
|
||||
end;
|
||||
|
||||
...
|
||||
|
||||
// server (the implementation)
|
||||
|
||||
TServiceName =class(TInterfacedObjectWithCustomCreate, IServiceName)
|
||||
public
|
||||
...
|
||||
// this function can also be function OperationName(const aParamName: RawUTF8): RawUTF8;
|
||||
function OperationName(const aParamName: RawUTF8; out aData: RawUTF8): Integer;
|
||||
...
|
||||
end;
|
||||
|
||||
...
|
||||
|
||||
function TServiceName.OperationName(const aParamName: RawUTF8; out aData: RawUTF8): Integer;
|
||||
begin
|
||||
Result := OK;
|
||||
aData := '[{"text":"test"},{"text":"test1"}]';
|
||||
end;
|
||||
|
||||
...
|
||||
|
||||
// client
|
||||
type
|
||||
TForm3 = class(TForm)
|
||||
DBGrid1: TDBGrid;
|
||||
DBNavigator1: TDBNavigator;
|
||||
btnOpen: TButton;
|
||||
edtURL: TEdit;
|
||||
dsRest: TDataSource;
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure btnOpenClick(Sender: TObject);
|
||||
procedure DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
|
||||
private
|
||||
{ Private declarations }
|
||||
fRestDS: TSynRestDataset;
|
||||
public
|
||||
{ Public declarations }
|
||||
end;
|
||||
|
||||
...
|
||||
|
||||
procedure TForm3.FormCreate(Sender: TObject);
|
||||
begin
|
||||
fRestDS := TSynRestDataset.Create(Self);
|
||||
fRestDS.Dataset.SQLModel := TSQLModel.Create([TSQLRecordServiceName_OperationName], 'root');
|
||||
dsRest.Dataset := fRestDS;
|
||||
end;
|
||||
|
||||
procedure TForm3.btnOpenClick(Sender: TObject);
|
||||
begin
|
||||
fRestDS.Close;
|
||||
fRestDS.CommandText := edtURL.Text; // edtURL.Text = 'http://localhost:8888/root/ServiceName.OperationName?aParamName=XXX
|
||||
fRestDS.Open;
|
||||
// you can filter by named parameter:
|
||||
// fRestDS.CommandText := edtURL.Text; // 'http://localhost:8888/root/ServiceName.OperationName?aParamName=:aParamName
|
||||
// fRestDS.Params.ParamByName('aParamName').Value := XXX
|
||||
// fRestDS.Open;
|
||||
end;
|
||||
|
||||
procedure TForm3.DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
|
||||
begin
|
||||
if (Button = nbPost) then
|
||||
fRestDS.ApplyUpdates(0); // raise an error "Cannot update data from a service"
|
||||
end;
|
||||
|
||||
|
||||
# Forum Thread
|
||||
|
||||
See http://synopse.info/forum/viewtopic.php?id=2712
|
||||
|
||||
# License
|
||||
|
||||
Feel free to use and/or append to Lib and extend if needed.
|
||||
@@ -0,0 +1,51 @@
|
||||
/// 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: TSQLRawBlob;
|
||||
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: TSQLRawBlob 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: TSQLModel;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
function CreateSampleModel: TSQLModel;
|
||||
begin
|
||||
result := TSQLModel.Create([TSQLBioLife]);
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,59 @@
|
||||
{
|
||||
Synopse mORMot framework
|
||||
|
||||
Sample 04 - HTTP Client-Server
|
||||
purpose of this sample is to show HTTP Client/Server SQLite3 database usage:
|
||||
|
||||
- a TSQLSampleRecord class is defined in shared unit SampleData.pas
|
||||
- this sample uses two projects, Project04Client.dpr and Project04Server.dpr
|
||||
- a SQLite3 server is initialized in Project04Server
|
||||
- the CreateMissingTables method will create all necessary tables in the
|
||||
SQLite3 database
|
||||
- one or more client instances can be run in Project04Client
|
||||
- the purpose of the Client form in Unit1.pas is to add a record to the
|
||||
database; the Time field is filled with the current date and time
|
||||
- the 'Find a previous message' button show how to perform a basic query
|
||||
- since the framework use UTF-8 encoding, we use some basic functions for
|
||||
fast conversion to/from the User Interface; in real applications,
|
||||
you should better use our SQLite3i18n unit and the corresponding
|
||||
TLanguageFile.StringToUTF8() and TLanguageFile.UTF8ToString() methods
|
||||
- note that you didn't need to write any SQL statement, only define a
|
||||
class and call some methods; even the query was made very easy (just an
|
||||
obvious WHERE clause to write)
|
||||
- thanks to the true object oriented modelling of the framework, the same
|
||||
exact Unit1 is used for both static in-memory database engine, or
|
||||
with SQLite3 database storage, in local mode or in Client/Server mode:
|
||||
only the TForm1.Database object creation instance was modified
|
||||
- in order to register the URL for the http.sys server, you have to run
|
||||
this program once as administrator, or call Project04ServerRegister first
|
||||
- look at the tiny size of the EXE (even with SQLite3 engine embedded), less
|
||||
than 400KB for the server, and 80KB for the client, with LVCL :)
|
||||
|
||||
|
||||
Version 1.0 - February 07, 2010
|
||||
|
||||
Version 1.16
|
||||
- added authentication to the remote process
|
||||
|
||||
Version 1.18
|
||||
- added Project04ServerRegister.dpr program
|
||||
|
||||
}
|
||||
|
||||
program Server;
|
||||
|
||||
uses
|
||||
{$I SynDprUses.inc} // use FastMM4 on older Delphi, or set FPC threads
|
||||
Forms,
|
||||
SysUtils,
|
||||
fMain in 'fMain.pas' {frmMain},
|
||||
SampleData in 'SampleData.pas';
|
||||
|
||||
{$R *.res}
|
||||
|
||||
begin
|
||||
SetCurrentDir(ExtractFilePath(ParamStr(0)));
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TfrmMain, frmMain);
|
||||
Application.Run;
|
||||
end.
|
||||
@@ -0,0 +1,433 @@
|
||||
/// 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) 2020 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) 2020
|
||||
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
|
||||
- fix memory leak adding TSynRestDataset.destroy (by houdw2006)
|
||||
|
||||
}
|
||||
|
||||
{$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,
|
||||
SynCommons,
|
||||
SynTable,
|
||||
SynDB,
|
||||
SynRestVCL,
|
||||
DB,
|
||||
{$ifdef FPC}
|
||||
BufDataset
|
||||
{$else}
|
||||
Contnrs,
|
||||
DBClient,
|
||||
Provider,
|
||||
SqlConst
|
||||
{$endif};
|
||||
|
||||
|
||||
{$ifdef FPC} { TODO: duplicated code from SynDBMidasVCL }
|
||||
type
|
||||
/// FPC's pure pascal in-memory buffer is used instead of TClientDataSet
|
||||
TClientDataSet = TBufDataset;
|
||||
|
||||
/// wrapper functions will use FPC's pure pascal in-memory buffer
|
||||
TSynRestDataSet = TBufDataset;
|
||||
|
||||
{$else FPC}
|
||||
type
|
||||
/// A TSynRestDataset, inherited from TCustomClientDataSet, which allows to apply updates on a TWinHTTP connection.
|
||||
// The TSQLModel is required for getting column datatype and size and if the TSQLRecord has defined
|
||||
// InternalDefineModel for validations they will be associated to a TField.OnValidate. Similary if the method
|
||||
// ComputeBeforeWriteFields is overridden this will be used.
|
||||
// - typical usage may be for instance:
|
||||
// ! ds := TSynRestDataSet.Create(MainForm);
|
||||
// ! ds.Dataset.SQLModel := CreateModel; // The SQLModel is required
|
||||
// ! ds.CommandText := 'http://host:port/root/TableName?select=*&where=condition&sort=fieldname';
|
||||
// ! ds1.Dataset := ds; // assigning the rest dataset to TDatasource that can be associated a TDBGrid for example.
|
||||
// ! ds.Open;
|
||||
// ! // ... use ds as usual, including modifications
|
||||
// ! ds.ApplyUpdates(0);
|
||||
// or using from a service returning a dataset:
|
||||
// ! ds := TSynRestDataSet.Create(MainForm);
|
||||
// ! ds.Dataset.SQLModel := CreateModel; // The SQLModel is required
|
||||
// ! the TSQLRecord associated should be defined with the same structure of the returned array from the service
|
||||
// ! ds.CommandText := 'http://host:port/root/ServiceName.Operation?paramname=:paramvalue';
|
||||
// ! ds.Params.ParamByName('paramname').Value := 'xyz';
|
||||
// ! ds1.Dataset := ds; // assigning the rest dataset to TDatasource that can be associated a TDBGrid for example.
|
||||
// ! ds.Open;
|
||||
// ! // ... use ds as usual, including modifications
|
||||
// ! ds.ApplyUpdates(0);
|
||||
TSynRestDataSet = class(TCustomClientDataSet)
|
||||
protected
|
||||
fDataSet: TSynRestSQLDataset;
|
||||
fProvider: TDataSetProvider;
|
||||
procedure DoOnFieldValidate(Sender: TField);
|
||||
procedure DoOnUpdateError(Sender: TObject; DataSet: TCustomClientDataSet; E: EUpdateError; UpdateKind: TUpdateKind; var Response: TResolverResponse);
|
||||
// from TDataSet
|
||||
procedure OpenCursor(InfoQuery: Boolean); override;
|
||||
{$ifdef ISDELPHI2007ANDUP}
|
||||
// from IProviderSupport
|
||||
function PSGetCommandText: string; override;
|
||||
{$endif}
|
||||
{$IFNDEF NEXTGEN}
|
||||
{$ifdef ISDELPHIXE}
|
||||
procedure SetCommandText(Value: WideString); override;
|
||||
{$else ISDELPHIXE}
|
||||
procedure SetCommandText(Value: String); override;
|
||||
{$endif ISDELPHIXE}
|
||||
{$ELSE}
|
||||
procedure SetCommandText(Value: String); override;
|
||||
{$ENDIF !NEXTGEN}
|
||||
procedure SetFieldValidateFromSQLRecordSynValidate;
|
||||
public
|
||||
/// initialize the instance
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
/// destroy the instance
|
||||
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;
|
||||
published
|
||||
property CommandText;
|
||||
property Active;
|
||||
property Aggregates;
|
||||
property AggregatesActive;
|
||||
property AutoCalcFields;
|
||||
property Constraints;
|
||||
property DisableStringTrim;
|
||||
property FileName;
|
||||
property Filter;
|
||||
property Filtered;
|
||||
property FilterOptions;
|
||||
property FieldDefs;
|
||||
property IndexDefs;
|
||||
property IndexFieldNames;
|
||||
property IndexName;
|
||||
property FetchOnDemand;
|
||||
property MasterFields;
|
||||
property MasterSource;
|
||||
property ObjectView;
|
||||
property PacketRecords;
|
||||
property Params;
|
||||
property ReadOnly;
|
||||
property StoreDefs;
|
||||
property BeforeOpen;
|
||||
property AfterOpen;
|
||||
property BeforeClose;
|
||||
property AfterClose;
|
||||
property BeforeInsert;
|
||||
property AfterInsert;
|
||||
property BeforeEdit;
|
||||
property AfterEdit;
|
||||
property BeforePost;
|
||||
property AfterPost;
|
||||
property BeforeCancel;
|
||||
property AfterCancel;
|
||||
property BeforeDelete;
|
||||
property AfterDelete;
|
||||
property BeforeScroll;
|
||||
property AfterScroll;
|
||||
property BeforeRefresh;
|
||||
property AfterRefresh;
|
||||
property OnCalcFields;
|
||||
property OnDeleteError;
|
||||
property OnEditError;
|
||||
property OnFilterRecord;
|
||||
property OnNewRecord;
|
||||
property OnPostError;
|
||||
property OnReconcileError;
|
||||
property BeforeApplyUpdates;
|
||||
property AfterApplyUpdates;
|
||||
property BeforeGetRecords;
|
||||
property AfterGetRecords;
|
||||
property BeforeRowRequest;
|
||||
property AfterRowRequest;
|
||||
property BeforeExecute;
|
||||
property AfterExecute;
|
||||
property BeforeGetParams;
|
||||
property AfterGetParams;
|
||||
/// the associated SynRestVCL TDataSet, used to retrieve and update data
|
||||
property DataSet: TSynRestSQLDataSet read fDataSet;
|
||||
end;
|
||||
|
||||
{$endif FPC}
|
||||
|
||||
/// Convert JSON array to REST TClientDataset
|
||||
// - the dataset is created inside this function
|
||||
function JSONToSynRestDataset(const aJSON: RawUTF8; const aSQLModel: TSQLModel): TSynRestDataset;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
Dialogs;
|
||||
|
||||
type
|
||||
TSynRestSQLDatasetHack = class(TSynRestSQLDataset);
|
||||
TSynValidateRestHack = class(TSynValidateRest);
|
||||
|
||||
{$ifndef FPC}
|
||||
|
||||
function JSONToSynRestDataset(const aJSON: RawUTF8; const aSQLModel: TSQLModel): TSynRestDataset;
|
||||
var
|
||||
lSQLTableJSON: TSQLTableJSON;
|
||||
lData: TRawByteStringStream;
|
||||
begin
|
||||
Result := Nil;
|
||||
if (aJSON = '') then
|
||||
Exit;
|
||||
lSQLTableJSON := TSQLTableJSON.Create('', aJSON);
|
||||
lData := TRawByteStringStream.Create('');
|
||||
try
|
||||
JSONToBinary(lSQLTableJSON, lData);
|
||||
Result := TSynRestDataset.Create(Nil);
|
||||
Result.Dataset.SQLModel := aSQLModel;
|
||||
Result.DataSet.From(lData.DataString);
|
||||
finally
|
||||
FreeAndNil(lData);
|
||||
FreeAndNil(lSQLTableJSON);
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TSynRestDataSet }
|
||||
|
||||
constructor TSynRestDataSet.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
fProvider := TDataSetProvider.Create(Self);
|
||||
fProvider.Name := 'InternalProvider'; { Do not localize }
|
||||
fProvider.SetSubComponent(True);
|
||||
fProvider.Options := fProvider.Options+[poAllowCommandText];
|
||||
fProvider.OnUpdateError := DoOnUpdateError;
|
||||
SetProvider(fProvider);
|
||||
fDataSet := TSynRestSQLDataSet.Create(Self);
|
||||
fDataSet.Name := 'InternalDataSet'; { Do not localize }
|
||||
fDataSet.SetSubComponent(True);
|
||||
fProvider.DataSet := fDataSet;
|
||||
end;
|
||||
|
||||
destructor TSynRestDataSet.Destroy;
|
||||
begin
|
||||
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(Sender.FieldName);
|
||||
// the field has not validation
|
||||
if (Length(lRec.RecordProps.Filters[F]) = 0) then
|
||||
Exit;
|
||||
|
||||
if not (lFields.List[F].SQLFieldType in COPIABLE_FIELDS) then
|
||||
Exit;
|
||||
|
||||
lRec.SetFieldValue(Sender.FieldName, PUTF8Char(VariantToUTF8(Sender.Value)));
|
||||
for V := 0 to Length(lRec.RecordProps.Filters[F])-1 do begin
|
||||
Validate := TSynValidate(lRec.RecordProps.Filters[F,V]);
|
||||
if Validate.InheritsFrom(TSynValidate) then begin
|
||||
Value := Sender.Value;
|
||||
lwasTSynValidateRest := Validate.InheritsFrom(TSynValidateRest);
|
||||
if lwasTSynValidateRest then begin // set additional parameters
|
||||
TSynValidateRestHack(ValidateRest).fProcessRec := lRec;
|
||||
TSynValidateRestHack(ValidateRest).fProcessRest := Nil; // no Rest for the moment
|
||||
end;
|
||||
try
|
||||
if not Validate.Process(F,Value,lErrMsg) then begin
|
||||
if lErrMsg='' then
|
||||
// no custom message -> show a default message
|
||||
lErrMsg := format(sValidationFailed,[GetCaptionFromClass(Validate.ClassType)])
|
||||
else
|
||||
raise ESQLRestException.CreateUTF8('Error % on field "%"', [lErrMsg, Sender.DisplayName]);
|
||||
end;
|
||||
finally
|
||||
if lwasTSynValidateRest then begin // reset additional parameters
|
||||
TSynValidateRestHack(ValidateRest).fProcessRec := nil;
|
||||
TSynValidateRestHack(ValidateRest).fProcessRest := nil;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
lRec.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSynRestDataSet.DoOnUpdateError(Sender: TObject; DataSet: TCustomClientDataSet; E: EUpdateError;
|
||||
UpdateKind: TUpdateKind; var Response: TResolverResponse);
|
||||
begin
|
||||
Response := rrAbort;
|
||||
MessageDlg(E.OriginalException.Message, mtError, [mbOK], 0);
|
||||
end;
|
||||
|
||||
procedure TSynRestDataSet.From(Statement: RawUTF8; MaxRowCount: cardinal);
|
||||
begin
|
||||
fDataSet.From(Statement);
|
||||
fDataSet.CommandText := ''; // ensure no SQL execution
|
||||
Open;
|
||||
fDataSet.CommandText := UTF8ToString(Statement); // assign it AFTER Open
|
||||
end;
|
||||
|
||||
procedure TSynRestDataSet.FetchParams;
|
||||
begin
|
||||
if not HasAppServer and Assigned(FProvider) then
|
||||
SetProvider(FProvider);
|
||||
inherited FetchParams;
|
||||
end;
|
||||
|
||||
procedure TSynRestDataSet.OpenCursor(InfoQuery: Boolean);
|
||||
begin
|
||||
if Assigned(fProvider) then
|
||||
SetProvider(fProvider);
|
||||
if fProvider.DataSet=self then
|
||||
raise ESQLDBException.Create(SCircularProvider);
|
||||
inherited OpenCursor(InfoQuery);
|
||||
SetFieldValidateFromSQLRecordSynValidate;
|
||||
end;
|
||||
|
||||
{$ifdef ISDELPHI2007ANDUP}
|
||||
function TSynRestDataSet.PSGetCommandText: string;
|
||||
{$ifdef ISDELPHIXE3}
|
||||
var IP: IProviderSupportNG;
|
||||
begin
|
||||
if Supports(fDataSet, IProviderSupportNG, IP) then
|
||||
{$else}
|
||||
var IP: IProviderSupport;
|
||||
begin
|
||||
if Supports(fDataSet, IProviderSupport, IP) then
|
||||
{$endif}
|
||||
result := IP.PSGetCommandText else
|
||||
result := CommandText;
|
||||
end;
|
||||
{$endif ISDELPHI2007ANDUP}
|
||||
|
||||
{$IFNDEF NEXTGEN}
|
||||
{$ifdef ISDELPHIXE}
|
||||
procedure TSynRestDataSet.SetCommandText(Value: WideString);
|
||||
{$else ISDELPHIXE}
|
||||
procedure TSynRestDataSet.SetCommandText(Value: String);
|
||||
{$endif ISDELPHIXE}
|
||||
{$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(Fields[F].FieldName);
|
||||
if (V > -1) then
|
||||
begin
|
||||
if (Length(lProps.Filters[V]) > 0) then
|
||||
Fields[F].OnValidate := DoOnFieldValidate;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{$endif FPC}
|
||||
|
||||
end.
|
||||
|
||||
|
||||
@@ -0,0 +1,845 @@
|
||||
/// 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) 2020 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) 2020
|
||||
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.
|
||||
|
||||
|
||||
@@ -0,0 +1,48 @@
|
||||
object frmMain: TfrmMain
|
||||
Left = 198
|
||||
Top = 124
|
||||
Width = 418
|
||||
Height = 240
|
||||
Caption = 'SynRestDataset Demo'
|
||||
Color = clBtnFace
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -13
|
||||
Font.Name = 'Tahoma'
|
||||
Font.Style = []
|
||||
OldCreateOrder = False
|
||||
OnCreate = FormCreate
|
||||
OnDestroy = FormDestroy
|
||||
OnShow = FormShow
|
||||
PixelsPerInch = 96
|
||||
TextHeight = 16
|
||||
object Label1: TLabel
|
||||
Left = 40
|
||||
Top = 16
|
||||
Width = 297
|
||||
Height = 33
|
||||
AutoSize = False
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clTeal
|
||||
Font.Height = -16
|
||||
Font.Name = 'Tahoma'
|
||||
Font.Style = [fsBold]
|
||||
ParentFont = False
|
||||
end
|
||||
object Label2: TLabel
|
||||
Left = 56
|
||||
Top = 72
|
||||
Width = 145
|
||||
Height = 16
|
||||
Caption = 'HTTP Server is running...'
|
||||
end
|
||||
object Button1: TButton
|
||||
Left = 88
|
||||
Top = 120
|
||||
Width = 75
|
||||
Height = 25
|
||||
Caption = 'Quit'
|
||||
TabOrder = 0
|
||||
OnClick = Button1Click
|
||||
end
|
||||
end
|
||||
@@ -0,0 +1,67 @@
|
||||
unit fMain;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$ifdef MSWINDOWS}
|
||||
Windows,
|
||||
Messages,
|
||||
{$endif}
|
||||
SysUtils, Variants, Classes, Graphics, Controls, Forms,
|
||||
Dialogs, StdCtrls,
|
||||
SynCommons, mORMot, mORMotSQLite3, SynSQLite3Static,
|
||||
mORMotHttpServer, SampleData;
|
||||
|
||||
type
|
||||
TfrmMain = class(TForm)
|
||||
Label1: TLabel;
|
||||
Button1: TButton;
|
||||
Label2: TLabel;
|
||||
procedure Button1Click(Sender: TObject);
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure FormDestroy(Sender: TObject);
|
||||
procedure FormShow(Sender: TObject);
|
||||
private
|
||||
public
|
||||
Model: TSQLModel;
|
||||
DB: TSQLRestServerDB;
|
||||
Server: TSQLHttpServer;
|
||||
end;
|
||||
|
||||
var
|
||||
frmMain: TfrmMain;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
mORMotDB;
|
||||
|
||||
{$R *.dfm}
|
||||
|
||||
procedure TfrmMain.Button1Click(Sender: TObject);
|
||||
begin
|
||||
Close;
|
||||
end;
|
||||
|
||||
procedure TfrmMain.FormCreate(Sender: TObject);
|
||||
begin
|
||||
Model := CreateSampleModel;
|
||||
DB := TSQLRestServerDB.Create(Model, 'Project19Server.db3', False);
|
||||
DB.CreateMissingTables;
|
||||
Server := TSQLHttpServer.Create('8080',[DB],'+',HTTP_DEFAULT_MODE);
|
||||
Server.AccessControlAllowOrigin := '*'; // allow cross-site AJAX queries
|
||||
end;
|
||||
|
||||
procedure TfrmMain.FormDestroy(Sender: TObject);
|
||||
begin
|
||||
Server.Free;
|
||||
DB.Free;
|
||||
Model.Free;
|
||||
end;
|
||||
|
||||
procedure TfrmMain.FormShow(Sender: TObject);
|
||||
begin
|
||||
Label1.Caption := Caption;
|
||||
end;
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user