Delphi/delphimvcframework
1
0
Fork 0
mirror of https://github.com/danieleteti/delphimvcframework.git synced 2024-11-15 15:55:54 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'upstream/master' into new_restclient

Browse Source
This commit is contained in:
João Antônio Duarte 2020-08-13 19:43:57 -03:00
commit fdb7ad30a3
41 changed files with 1422 additions and 367 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

114
README.md
View File

@ -1,8 +1,6 @@
![](https://img.shields.io/badge/current%20dmvcframework%20version-3.2.0--boron-blue?style=for-the-badge)
![DelphiMVCFramework Logo](docs/dmvcframework_logofacebook.png)
![](https://img.shields.io/badge/next%20dmvcframework%20version-3.2.1--carbon-red)![GitHub All Releases](https://img.shields.io/github/downloads/danieleteti/delphimvcframework/total?label=releases%20download)
![](https://img.shields.io/badge/We%20are%20working%20on%20dmvcframework%20new%20version-3.2.1--carbon-red)![GitHub All Releases](https://img.shields.io/github/downloads/danieleteti/delphimvcframework/total?label=releases%20download)
# DelphiMVCFramework 3.2.0-boron is [here](https://github.com/danieleteti/delphimvcframework/releases/tag/v3_2_0_boron)!
@ -385,7 +383,117 @@ Congratulations to Daniele Teti and all the staff for the excellent work!" -- Ma
- Fixed! [issue388](https://github.com/danieleteti/delphimvcframework/issues/388)
- Fixed! Has been patched a serious security bug affecting deployment configurations which uses internal WebServer to serve static files (do not affect all Apache, IIS or proxied deployments). Thanks to **Stephan Munz** to have discovered it. *Update to dmvcframework-3.2-RC5+ is required for all such kind of deployments.*
## Changes in upcoming version (3.2.1-carbon)
### Bug Fixes and Improvements
- [docExpansion parameter for Swagger](https://github.com/danieleteti/delphimvcframework/issues/408)
- New `Context: TWebContext` parameter in JSON-RPC Hooks
```delphi
{ Called before any actual routing }
procedure OnBeforeRoutingHook(const Context: TWebContext; const JSON: TJsonObject);
{ Called after routing and before the actual remote method invocation }
procedure OnBeforeCallHook(const Context: TWebContext; const JSON: TJsonObject);
{ Called after actual remote method invocation, even if the method raised an exception }
procedure OnAfterCallHook(const Context: TWebContext; const JSON: TJsonObject);
```
- When a JSON-RPC Request returns a `System.Boolean` the `result` will be a JSON `true` or `false` and no `1` or `0` as it was in the `3.2.0-boron`.
- `IMVCJSONRPCExecutor.ExecuteNotification` returns a `IJSONRPCResponse`. In case of error response contains information about the error, in case of successful execution the response is a [Null Object](https://en.wikipedia.org/wiki/Null_object_pattern).
- Added `foReadOnly` and `foWriteOnly` as field options in `MVCTableField` attribute (used by `TMVCActiveRecord`). Currently available field options are:
- *foPrimaryKey* { it's the primary key of the mapped table }
- *foAutoGenerated* { not written, read - similar to foReadOnly but is reloaded after insert and update }
- *foTransient* { never stored nor read - managed only at run-time }
- *foReadOnly* { not written, read }
- *foWriteOnly* { written, not read }
Now it is possible to declare entities like the followings (or with any other combinations):
```delphi
[MVCNameCase(ncLowerCase)]
[MVCTable('articles')]
TArticleWithWriteOnlyFields = class(TCustomEntity)
private
[MVCTableField('ID', [foPrimaryKey, foAutoGenerated])]
fID: NullableInt32;
[MVCTableField('description', [foWriteOnly])]
fDescription: string;
[MVCTableField('price', [foWriteOnly])]
fPrice: Integer;
public
property ID: NullableInt32 read fID write fID;
property Description: string read fDescription write fDescription;
property Price: Integer read fPrice write fPrice;
end;
[MVCNameCase(ncLowerCase)]
[MVCTable('articles')]
TArticleWithReadOnlyFields = class(TCustomEntity)
private
[MVCTableField('ID', [foPrimaryKey, foReadOnly])]
fID: NullableInt32;
[MVCTableField('code', [foTransient])]
fCode: NullableString;
[MVCTableField('description', [foReadOnly])]
fDescrizione: string;
[MVCTableField('price', [foReadOnly])]
fPrice: Currency;
public
property ID: NullableInt32 read fID write fID;
property Code: NullableString read fCode write fCode;
property Description: string read fDescription write fDescription;
property Price: Currency read fPrice write fPrice;
end;
```
- Added the ability to deserialize an object starting from an arbitrary node in the JSON (or other format) present in the request body.
```delphi
procedure TBooksController.CreateBook;
var
lBook: TBook;
begin
//this call deserialize a TBook instance
//starting from the 'book' node of
//the request body
lBook := Context.Request.BodyAs<TBook>('book');
try
lBook.Insert;
Render201Created('/api/books/' + lBook.ID.ToString);
finally
lBook.Free;
end;
end;
```
- Improved the primary key type handling for manual handling in MVCActiveRecord.
```delphi
procedure TMyBaseEntity.OnBeforeInsert;
begin
inherited;
//regardless the name of the PK field
//the following code fills the PK with a GUID
//Inheriting the other entities from this, all
//will inherit this behavior.
SetPK(TValue.From<NullableString>(TGUID.NewGuid.ToString));
//if the PK was a simple string, the code
//should be like the following
//SetPK(TGUID.NewGuid.ToString);
end;
```
- Improved `activerecord_showcase` sample.
## Roadmap
DelphiMVCFramework roadmap is always updated as-soon-as the features planned are implemented. Check the roadmap [here](roadmap.md).
## Trainings, consultancy or custom development service

25
contributors.txt
View File

@ -1,25 +0,0 @@
Daniele Teti
Role : Founder, Lead Developer
email : d.teti@bittime.it
blog : www.danieleteti.it
company : www.bittimeprofessionals.it
country : ITALY
Daniele Spinetti
Role : Expert, Senior Developer
email : d.spinetti@bittime.it
blog : www.danielespinetti.it
company : www.bittimeprofessionals.it
country : ITALY
Nick Hodges
Role : Expert, Senior Developer
blog : www.nickhodges.com, www.codingindelphi.com/blog/
company : www.embarcadero.com
country : USA
Ezequiel Juliano Müller
Role : Expert, Senior Developer
email : ezequieljuliano@gmail.com
blog : www.ezequieljuliano.com.br
country : BRAZIL

4
roadmap.md
View File

@ -10,7 +10,7 @@ As we are in the detailed planning stages for these features, we will share addi
- (DONE) Implement Strongly Typed Actions
- (DONE) Implement Custom Authentication and Authorization Middleware
- (DONE) Use a middleware to implement response compression for console type projects
- (INITIAL)Implement Swagger support (we need a good self contained YAML parser/generator...)
- (DONE)Implement Swagger support
- (DONE) Linux support
- (DONE) Update Mapper framework to make it extensible and configurable
- The default mapper interface will be the same as the current version so that no breaking changes happened
@ -25,7 +25,7 @@ As we are in the detailed planning stages for these features, we will share addi
- New samples with specific web related use cases:
- WebWorkers
- (DONE) Angular2+
- React
- (DONE) React
- (DONE) Create "Custom Authentication and Authorization" demo
- (CANCELED) Complete the [DevGuide](https://danieleteti.gitbooks.io/delphimvcframework/content/) on gitbooks
- Improve the session mechanism to allows more flexibility

62
samples/activerecord_showcase/EntitiesU.pas
View File

@ -46,9 +46,9 @@ type
[MVCTable('articles')]
TArticle = class(TCustomEntity)
private
[MVCTableField('ID')]
[MVCTableField('ID', [foPrimaryKey, foAutoGenerated])]
fID: NullableInt32;
[MVCTableField('code')]
[MVCTableField('code', [foTransient])]
fCodice: NullableString;
[MVCTableField('description')]
fDescrizione: string;
@ -63,6 +63,41 @@ type
property Price: Currency read fPrezzo write fPrezzo;
end;
[MVCNameCase(ncLowerCase)]
[MVCTable('articles')]
TArticleWithWriteOnlyFields = class(TCustomEntity)
private
[MVCTableField('ID', [foPrimaryKey, foAutoGenerated, foReadOnly])]
fID: NullableInt32;
[MVCTableField('description', [foWriteOnly])]
fDescrizione: string;
[MVCTableField('price', [foWriteOnly])]
fPrice: Integer;
public
property ID: NullableInt32 read fID write fID;
property Description: string read fDescrizione write fDescrizione;
property Price: Integer read fPrice write fPrice;
end;
[MVCNameCase(ncLowerCase)]
[MVCTable('articles')]
TArticleWithReadOnlyFields = class(TCustomEntity)
private
[MVCTableField('ID', [foPrimaryKey, foReadOnly])]
fID: NullableInt32;
[MVCTableField('code', [foTransient])]
fCodice: NullableString;
[MVCTableField('description', [foReadOnly])]
fDescrizione: string;
[MVCTableField('price', [foReadOnly])]
fPrezzo: Currency;
public
property ID: NullableInt32 read fID write fID;
property Code: NullableString read fCodice write fCodice;
property Description: string read fDescrizione write fDescrizione;
property Price: Currency read fPrezzo write fPrezzo;
end;
TOrder = class;
[MVCNameCase(ncLowerCase)]
@ -108,7 +143,6 @@ type
fID: Integer;
[MVCTableField('code', [foTransient])]
fCode: string;
[MVCTableField('', [foTransient])]
fFormattedCode: string;
[MVCTableField('description')]
fCompanyName: string;
@ -238,6 +272,12 @@ type
property Note: string read fNote write fNote;
end;
[MVCTable('customers_with_code')]
TCustomerPlainWithClientPK = class(TCustomerWithCode)
protected
procedure OnBeforeInsert; override;
end;
[MVCNameCase(ncLowerCase)]
[MVCTable('orders')]
TOrder = class(TCustomEntity)
@ -350,7 +390,7 @@ type
implementation
uses
System.SysUtils, Data.DB, MVCFramework.Logger;
System.SysUtils, Data.DB, MVCFramework.Logger, System.Rtti;
constructor TArticle.Create;
begin
@ -459,7 +499,7 @@ end;
constructor TNullablesTest.Create;
begin
inherited Create;
// ff_blob := TMemoryStream.Create;
ff_blob := TMemoryStream.Create;
end;
destructor TNullablesTest.Destroy;
@ -476,4 +516,16 @@ begin
Log.Info(ClassName + ' | ' + SQL, 'sql_trace');
end;
{ TCustomerPlainWithClientPK }
procedure TCustomerPlainWithClientPK.OnBeforeInsert;
begin
inherited;
SetPK(TValue.From<NullableString>(TGUID.NewGuid.ToString
.Replace('{', '')
.Replace('-', '')
.Replace('}', '')
.Substring(0, 20)));
end;
end.

25
samples/activerecord_showcase/MainFormU.dfm
View File

@ -2,7 +2,7 @@ object MainForm: TMainForm
Left = 0
Top = 0
Caption = 'TMVCActiveRecord - ShowCase'
ClientHeight = 587
ClientHeight = 640
ClientWidth = 635
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
@ -15,7 +15,7 @@ object MainForm: TMainForm
OnShow = FormShow
DesignSize = (
635
587)
640)
PixelsPerInch = 96
TextHeight = 13
object btnCRUD: TButton
@ -40,7 +40,7 @@ object MainForm: TMainForm
Left = 135
Top = 8
Width = 492
Height = 571
Height = 624
Anchors = [akLeft, akTop, akRight, akBottom]
Ctl3D = True
DoubleBuffered = True
@ -57,6 +57,7 @@ object MainForm: TMainForm
TabOrder = 2
WantReturns = False
WordWrap = False
ExplicitHeight = 571
end
object btnRelations: TButton
Left = 8
@ -158,6 +159,24 @@ object MainForm: TMainForm
TabOrder = 13
OnClick = btnCountWithRQLClick
end
object btnReadAndWriteOnly: TButton
Left = 8
Top = 523
Width = 121
Height = 33
Caption = 'R/O, R/W'
TabOrder = 14
OnClick = btnReadAndWriteOnlyClick
end
object btnClientGeneratedPK: TButton
Left = 8
Top = 562
Width = 121
Height = 33
Caption = 'Client Generated PKs'
TabOrder = 15
OnClick = btnClientGeneratedPKClick
end
object FDConnection1: TFDConnection
Left = 176
Top = 56

92
samples/activerecord_showcase/MainFormU.pas
View File

@ -42,6 +42,8 @@ type
btnCRUDWithStringPKs: TButton;
btnWithSpaces: TButton;
btnCountWithRQL: TButton;
btnReadAndWriteOnly: TButton;
btnClientGeneratedPK: TButton;
procedure btnCRUDClick(Sender: TObject);
procedure btnInheritanceClick(Sender: TObject);
procedure btnMultiThreadingClick(Sender: TObject);
@ -58,6 +60,8 @@ type
procedure btnCRUDWithStringPKsClick(Sender: TObject);
procedure btnWithSpacesClick(Sender: TObject);
procedure btnCountWithRQLClick(Sender: TObject);
procedure btnReadAndWriteOnlyClick(Sender: TObject);
procedure btnClientGeneratedPKClick(Sender: TObject);
private
procedure Log(const Value: string);
procedure LoadCustomers;
@ -88,6 +92,19 @@ const
CompanySuffix: array [0 .. 5] of string = ('Corp.', 'Inc.', 'Ltd.', 'Srl', 'SPA', 'doo');
Stuff: array [0 .. 4] of string = ('Burger', 'GAS', 'Motors', 'House', 'Boats');
procedure TMainForm.btnClientGeneratedPKClick(Sender: TObject);
var
lCustomer: TCustomerPlainWithClientPK;
begin
Log('** OnBeforeInsert and SetPK');
lCustomer := TCustomerPlainWithClientPK.Create();
try
lCustomer.Store;
finally
lCustomer.Free;
end;
end;
procedure TMainForm.btnCountWithRQLClick(Sender: TObject);
var
lRQL: string;
@ -137,7 +154,7 @@ begin
Log('There are ' + TMVCActiveRecord.Count<TCustomer>().ToString + ' row/s for entity ' + TCustomer.ClassName);
lCustomer := TCustomer.Create;
try
Log('Entity ' + TCustomer.ClassName + ' is mapped to table ' + lCustomer.TableName);
Log('Entity ' + TCustomer.ClassName + ' is mapped to table ' + lCustomer.TableName);
lCustomer.CompanyName := 'Google Inc.';
lCustomer.City := 'Montain View, CA';
lCustomer.Note := 'Hello there!';
@ -449,7 +466,12 @@ begin
lTest.f_int2 := 2;
lTest.f_int4 := 4;
lTest.f_int8 := 8;
lTest.f_blob := TStringStream.Create('Hello World');
with TStreamWriter.Create(lTest.f_blob) do
try
write('Hello World');
finally
Free;
end;
lTest.Insert;
Log('Inserting nulls');
finally
@ -474,8 +496,7 @@ begin
lTest.f_int2 := lTest.f_int2.Value + 2;
lTest.f_int4 := lTest.f_int4.Value + 4;
lTest.f_int8 := lTest.f_int8.Value + 8;
lTest.f_blob.Free;
lTest.f_blob := nil;
lTest.f_blob.Size := 0;
lTest.Update;
finally
lTest.Free;
@ -494,7 +515,7 @@ begin
Assert(not lTest.f_float4.HasValue);
Assert(not lTest.f_float8.HasValue);
Assert(not lTest.f_bool.HasValue);
Assert(not Assigned(lTest.f_blob), 'Blob contains a value when should not');
Assert(lTest.f_blob.Size = 0, 'Blob contains a value when should not');
TMVCActiveRecord.DeleteRQL(TNullablesTest, 'eq(f_int2,4)');
finally
lTest.Free;
@ -572,6 +593,65 @@ begin
end;
procedure TMainForm.btnReadAndWriteOnlyClick(Sender: TObject);
var
lArtWO, lArtWO2: TArticleWithWriteOnlyFields;
lArtRO: TArticleWithReadOnlyFields;
lID: NullableInt32;
lArt: TArticle;
begin
lArtWO := TArticleWithWriteOnlyFields.Create();
try
lArtWO.Description := 'Description1';
lArtWO.Price := 12;
lArtWO.Insert;
Log('Stored TArticleWithWriteOnlyFields');
lID := lArtWO.ID;
lArt := TMVCActiveRecord.GetByPK<TArticle>(lID);
try
Assert(lArtWO.Description = lArt.Description);
Assert(lArtWO.Price = lArt.Price);
Log('Check Stored version of TArticleWithWriteOnlyFields');
Log('Reading data using TArticleWithReadOnlyFields');
lArtRO := TMVCActiveRecord.GetByPK<TArticleWithReadOnlyFields>(lID);
try
Assert(lArtRO.Description = lArt.Description);
Assert(lArtRO.Price = lArt.Price);
Log('Check Read data of TArticleWithWriteOnlyFields using TArticleWithReadOnlyFields');
finally
lArtRO.Free;
end;
Log('Reading data using TArticleWithWriteOnlyFields (???)');
lArtWO2 := TMVCActiveRecord.GetByPK<TArticleWithWriteOnlyFields>(lID);
try
Assert(lArtWO2.ID.ValueOrDefault = lID.ValueOrDefault);
Assert(lArtWO2.Description = '');
Assert(lArtWO2.Price = 0);
finally
lArtWO2.Free;
end;
finally
lArt.Free;
end;
lArtRO := TArticleWithReadOnlyFields.Create();
try
lArtRO.Description := 'Description1';
lArtRO.Price := 12;
ShowMessage('Now an exception will be raised...');
lArtRO.Insert; // exception here :-)
finally
lArtRO.Free;
end;
finally
lArtWO.Free;
end;
end;
procedure TMainForm.btnRelationsClick(Sender: TObject);
var
lCustomer: TCustomerEx;
@ -818,7 +898,7 @@ begin
lCustomer := TCustomerWithTransient.Create;
try
{
'Code' and City will not be persisted because defined as 'transient'
'Code' will not be persisted because defined as 'transient'
}
lCustomer.Code := '1234';
lCustomer.CompanyName := 'Google Inc.';

4
samples/activerecord_showcase/activerecord_showcase.dproj
View File

@ -163,13 +163,13 @@
</Excluded_Packages>
</Delphi.Personality>
<Deployment Version="3">
<DeployFile LocalName="bin\activerecord_showcase.exe" Configuration="BUILD" Class="ProjectOutput">
<DeployFile LocalName="bin\activerecord_showcase.exe" Configuration="Debug" Class="ProjectOutput">
<Platform Name="Win32">
<RemoteName>activerecord_showcase.exe</RemoteName>
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile LocalName="bin\activerecord_showcase.exe" Configuration="Debug" Class="ProjectOutput">
<DeployFile LocalName="bin\activerecord_showcase.exe" Configuration="BUILD" Class="ProjectOutput">
<Platform Name="Win32">
<RemoteName>activerecord_showcase.exe</RemoteName>
<Overwrite>true</Overwrite>

7
samples/authenticationauthorization/AuthenticateAuthorize.dproj
View File

@ -160,8 +160,11 @@
<Source Name="MainSource">AuthenticateAuthorize.dpr</Source>
</Source>
<Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\dcloffice2k170.bpl">Microsoft Office 2000 Beispiele für gekapselte Komponenten für Automatisierungsserver</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\dclofficexp170.bpl">Microsoft Office XP Beispiele für gekapselte Komponenten für Automation Server</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\bcboffice2k260.bpl">Embarcadero C++Builder Office 2000 Servers Package</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\bcbofficexp260.bpl">Embarcadero C++Builder Office XP Servers Package</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\dcloffice2k260.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\dclofficexp260.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages>
<Excluded_Packages Name="C:\Program Files (x86)\FastReports\LibD26\dclfrxtee26.bpl">FastReport 6.0 Tee Components</Excluded_Packages>
</Excluded_Packages>
</Delphi.Personality>
<Deployment Version="3">

15
samples/authenticationauthorization/AuthenticationU.pas
View File

@ -24,9 +24,10 @@ implementation
{ TMVCAuthorization }
procedure TAuthenticationSample.OnAuthentication(const AContext: TWebContext; const UserName: string; const Password: string;
UserRoles: System.Generics.Collections.TList<System.string>;
var IsValid: Boolean; const SessionData: TSessionData);
procedure TAuthenticationSample.OnAuthentication(const AContext: TWebContext; const UserName: string;
const Password: string;
UserRoles: System.Generics.Collections.TList<System.string>;
var IsValid: Boolean; const SessionData: TSessionData);
begin
IsValid := UserName.Equals(Password); // hey!, this is just a demo!!!
if IsValid then
@ -53,9 +54,9 @@ end;
procedure TAuthenticationSample.OnAuthorization
(const AContext: TWebContext; UserRoles
: System.Generics.Collections.TList<System.string>;
const ControllerQualifiedClassName: string; const ActionName: string;
var IsAuthorized: Boolean);
: System.Generics.Collections.TList<System.string>;
const ControllerQualifiedClassName: string; const ActionName: string;
var IsAuthorized: Boolean);
begin
IsAuthorized := False;
if ActionName = 'Logout' then
@ -69,7 +70,7 @@ begin
end;
procedure TAuthenticationSample.OnRequest(const AContext: TWebContext; const ControllerQualifiedClassName: string;
const ActionName: string; var AuthenticationRequired: Boolean);
const ActionName: string; var AuthenticationRequired: Boolean);
begin
AuthenticationRequired := ControllerQualifiedClassName =
'AppControllerU.TAdminController';

4
samples/authenticationauthorization/WebModuleUnit1.pas
View File

@ -49,7 +49,9 @@ begin
.AddMiddleware(TMVCBasicAuthenticationMiddleware.Create(TAuthenticationSample.Create))
.AddMiddleware(TMVCStaticFilesMiddleware.Create(
'/', { StaticFilesPath }
'..\..\www' { DocumentRoot }
'..\..\www', { DocumentRoot }
'index.html',
False { not serving a SPA }
));
end;

BIN
samples/data/activerecorddb.db
View File

Binary file not shown.

33
samples/jsonrpc/MainClientFormU.dfm
View File

@ -2,7 +2,7 @@ object Form10: TForm10
Left = 0
Top = 0
Caption = 'Form10'
ClientHeight = 448
ClientHeight = 484
ClientWidth = 831
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
@ -14,9 +14,28 @@ object Form10: TForm10
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Label2: TLabel
AlignWithMargins = True
Left = 3
Top = 3
Width = 825
Height = 39
Align = alTop
Alignment = taCenter
Caption =
'Please use the demo available in samples\jsonrpc_with_published_' +
'objects\'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -21
Font.Name = 'Tahoma'
Font.Style = []
ParentFont = False
Layout = tlCenter
end
object GroupBox1: TGroupBox
Left = 8
Top = 16
Top = 48
Width = 815
Height = 124
Caption = 'Simple Types'
@ -164,7 +183,7 @@ object Form10: TForm10
end
object GroupBox2: TGroupBox
Left = 8
Top = 146
Top = 178
Width = 489
Height = 159
Caption = 'Returning Objects'
@ -202,7 +221,7 @@ object Form10: TForm10
end
object GroupBox3: TGroupBox
Left = 509
Top = 146
Top = 178
Width = 314
Height = 294
Caption = 'Returning Datasets'
@ -239,7 +258,7 @@ object Form10: TForm10
end
object GroupBox4: TGroupBox
Left = 8
Top = 311
Top = 343
Width = 489
Height = 129
Caption = 'Passing Objects as parameters'
@ -298,7 +317,7 @@ object Form10: TForm10
object DataSource1: TDataSource
DataSet = FDMemTable1
Left = 767
Top = 184
Top = 216
end
object FDMemTable1: TFDMemTable
FetchOptions.AssignedValues = [evMode]
@ -309,7 +328,7 @@ object Form10: TForm10
UpdateOptions.CheckRequired = False
UpdateOptions.AutoCommitUpdates = True
Left = 767
Top = 248
Top = 280
object FDMemTable1Code: TIntegerField
FieldName = 'Code'
end

13
samples/jsonrpc/MainClientFormU.pas
View File

@ -66,6 +66,7 @@ type
btnInvalid2: TButton;
btnNotification: TButton;
btnInvalidMethod: TButton;
Label2: TLabel;
procedure btnSubstractClick(Sender: TObject);
procedure btnReverseStringClick(Sender: TObject);
procedure edtGetCustomersClick(Sender: TObject);
@ -138,25 +139,25 @@ end;
procedure TForm10.btnInvalid1Click(Sender: TObject);
var
lReq: IJSONRPCRequest;
lReq: IJSONRPCNotification;
lResp: IJSONRPCResponse;
begin
lReq := TJSONRPCRequest.Create;
lReq := TJSONRPCNotification.Create;
lReq.Method := 'invalidmethod1';
lReq.Params.Add(1);
lResp := FExecutor.ExecuteRequest(lReq);
lResp := FExecutor.ExecuteNotification(lReq);
ShowMessage(lResp.Error.ErrMessage);
end;
procedure TForm10.btnInvalid2Click(Sender: TObject);
var
lReq: IJSONRPCRequest;
lReq: IJSONRPCNotification;
lResp: IJSONRPCResponse;
begin
lReq := TJSONRPCRequest.Create;
lReq := TJSONRPCNotification.Create;
lReq.Method := 'invalidmethod2';
lReq.Params.Add(1);
lResp := FExecutor.ExecuteRequest(lReq);
lResp := FExecutor.ExecuteNotification(lReq);
ShowMessage(lResp.Error.ErrMessage);
end;

31
samples/jsonrpc_with_published_objects/MainClientFormU.dfm
View File

@ -420,6 +420,37 @@ object MainForm: TMainForm
end
end
end
object TabSheet3: TTabSheet
Caption = 'Hooks Demo'
ImageIndex = 2
object btnDoNothing: TButton
Left = 24
Top = 24
Width = 145
Height = 33
Caption = 'Do Nothing'
TabOrder = 0
OnClick = btnDoNothingClick
end
object btnDoNothingError: TButton
Left = 24
Top = 63
Width = 145
Height = 33
Caption = 'Do Nothing With Errors'
TabOrder = 1
OnClick = btnDoNothingErrorClick
end
object btnNotExistent: TButton
Left = 24
Top = 102
Width = 145
Height = 33
Caption = 'Invalid Method'
TabOrder = 2
OnClick = btnNotExistentClick
end
end
end
object DataSource1: TDataSource
DataSet = FDMemTable1

48
samples/jsonrpc_with_published_objects/MainClientFormU.pas
View File

@ -81,6 +81,10 @@ type
Edit2: TEdit;
btnSubtractWithNamedParams: TButton;
Edit3: TEdit;
TabSheet3: TTabSheet;
btnDoNothing: TButton;
btnDoNothingError: TButton;
btnNotExistent: TButton;
procedure btnSubstractClick(Sender: TObject);
procedure btnReverseStringClick(Sender: TObject);
procedure edtGetCustomersClick(Sender: TObject);
@ -97,9 +101,13 @@ type
procedure btnFloatsTestsClick(Sender: TObject);
procedure btnWithJSONClick(Sender: TObject);
procedure btnSubtractWithNamedParamsClick(Sender: TObject);
procedure btnDoNothingClick(Sender: TObject);
procedure btnNotExistentClick(Sender: TObject);
procedure btnDoNothingErrorClick(Sender: TObject);
private
FExecutor: IMVCJSONRPCExecutor;
FExecutor2: IMVCJSONRPCExecutor;
FExecutor3: IMVCJSONRPCExecutor;
public
{ Public declarations }
end;
@ -121,6 +129,7 @@ uses
{$R *.dfm}
procedure TMainForm.btnAddDayClick(Sender: TObject);
var
lReq: IJSONRPCRequest;
@ -160,6 +169,22 @@ begin
end;
procedure TMainForm.btnDoNothingClick(Sender: TObject);
var
lReq: IJSONRPCNotification;
begin
lReq := TJSONRPCNotification.Create('DoSomething');
FExecutor3.ExecuteNotification(lReq);
end;
procedure TMainForm.btnDoNothingErrorClick(Sender: TObject);
var
lReq: IJSONRPCNotification;
begin
lReq := TJSONRPCNotification.Create('DoSomethingWithError');
FExecutor3.ExecuteNotification(lReq);
end;
procedure TMainForm.btnFloatsTestsClick(Sender: TObject);
var
lReq: IJSONRPCRequest;
@ -209,25 +234,25 @@ end;
procedure TMainForm.btnInvalid1Click(Sender: TObject);
var
lReq: IJSONRPCRequest;
lReq: IJSONRPCNotification;
lResp: IJSONRPCResponse;
begin
lReq := TJSONRPCRequest.Create;
lReq := TJSONRPCNotification.Create;
lReq.Method := 'invalidmethod1';
lReq.Params.Add(1);
lResp := FExecutor.ExecuteRequest(lReq);
lResp := FExecutor.ExecuteNotification(lReq);
ShowMessage(lResp.Error.ErrMessage);
end;
procedure TMainForm.btnInvalid2Click(Sender: TObject);
var
lReq: IJSONRPCRequest;
lReq: IJSONRPCNotification;
lResp: IJSONRPCResponse;
begin
lReq := TJSONRPCRequest.Create;
lReq := TJSONRPCNotification.Create;
lReq.Method := 'invalidmethod2';
lReq.Params.Add(1);
lResp := FExecutor.ExecuteRequest(lReq);
lResp := FExecutor.ExecuteNotification(lReq);
ShowMessage(lResp.Error.ErrMessage);
end;
@ -361,6 +386,14 @@ begin
ShowMessage(lPerson.ToJSON(False));
end;
procedure TMainForm.btnNotExistentClick(Sender: TObject);
var
lReq: IJSONRPCNotification;
begin
lReq := TJSONRPCNotification.Create('blablabla');
FExecutor3.ExecuteNotification(lReq);
end;
procedure TMainForm.edtGetCustomersClick(Sender: TObject);
var
lReq: IJSONRPCRequest;
@ -379,6 +412,8 @@ procedure TMainForm.FormCreate(Sender: TObject);
begin
FExecutor := TMVCJSONRPCExecutor.Create('http://localhost:8080/jsonrpc');
FExecutor2 := TMVCJSONRPCExecutor.Create('http://localhost:8080/rpcdatamodule');
FExecutor3 := TMVCJSONRPCExecutor.Create('http://localhost:8080/jsonrpchooks');
dtNextMonday.Date := Date;
// these are the methods to handle http headers in JSONRPC
@ -389,6 +424,7 @@ begin
FExecutor.ClearHTTPHeaders;
Assert(FExecutor.HTTPHeadersCount = 0);
FExecutor.AddHTTPHeader(TNetHeader.Create('x-token', TGUID.NewGuid.ToString));
PageControl1.ActivePageIndex := 0;
end;
end.

6
samples/jsonrpc_with_published_objects/MainWebModuleU.pas
View File

@ -59,6 +59,12 @@ begin
Result := TdmMain.Create(nil);
end, '/rpcdatamodule');
FMVC.PublishObject(
function: TObject
begin
Result := TMyObjectWithHooks.Create;
end, '/jsonrpchooks');
FMVC.AddMiddleware(TCORSMiddleware.Create());
end;

54
samples/jsonrpc_with_published_objects/MyObjectU.pas
View File

@ -52,10 +52,10 @@ type
function GetCustomersDataset: TFDMemTable;
function GetPeopleDataset: TFDMemTable;
public
procedure OnBeforeCall(const JSONRequest: TJDOJsonObject);
procedure OnBeforeRouting(const JSON: TJDOJsonObject);
procedure OnBeforeSendResponse(
const JSONResponse: TJDOJsonObject);
procedure OnBeforeCall(const Context: TWebContext; const JSONRequest: TJDOJsonObject);
procedure OnBeforeRouting(const Context: TWebContext; const JSON: TJDOJsonObject);
procedure OnAfterCallHook(
const Context: TWebContext; const JSONResponse: TJDOJsonObject);
public
[MVCDoc('You know, returns aValue1 - aValue2')]
function Subtract(Value1, Value2: Integer): Integer;
@ -79,6 +79,17 @@ type
end;
TMyObjectWithHooks = class
public
// hooks
procedure OnBeforeRoutingHook(const Context: TWebContext; const JSON: TJsonObject);
procedure OnBeforeCallHook(const Context: TWebContext; const JSON: TJsonObject);
procedure OnAfterCallHook(const Context: TWebContext; const JSON: TJsonObject);
// dummy method
procedure DoSomething;
procedure DoSomethingWithError;
end;
TUtils = class sealed
class function JSONObjectAs<T: constructor, class>(const JSON: TJsonObject): T;
end;
@ -300,26 +311,53 @@ end;
{ TMyObjectWithHooks }
procedure TMyObject.OnBeforeCall(const JSONRequest: TJDOJsonObject);
procedure TMyObject.OnBeforeCall(const Context: TWebContext; const JSONRequest: TJDOJsonObject);
begin
Log.Info('TMyObjectWithHooks.OnBeforeCall >> ', 'jsonrpc');
Log.Info(JSONRequest.ToJSON(false), 'jsonrpc');
Log.Info('TMyObjectWithHooks.OnBeforeCall << ', 'jsonrpc');
end;
procedure TMyObject.OnBeforeRouting(const JSON: TJDOJsonObject);
procedure TMyObject.OnBeforeRouting(const Context: TWebContext; const JSON: TJDOJsonObject);
begin
Log.Info('TMyObjectWithHooks.OnBeforeRouting >> ', 'jsonrpc');
Log.Info(JSON.ToJSON(false), 'jsonrpc');
Log.Info('TMyObjectWithHooks.OnBeforeRouting << ', 'jsonrpc');
end;
procedure TMyObject.OnBeforeSendResponse(
const JSONResponse: TJDOJsonObject);
procedure TMyObject.OnAfterCallHook(
const Context: TWebContext; const JSONResponse: TJDOJsonObject);
begin
Log.Info('TMyObjectWithHooks.OnBeforeSendResponse >> ', 'jsonrpc');
Log.Info(JSONResponse.ToJSON(false), 'jsonrpc');
Log.Info('TMyObjectWithHooks.OnBeforeSendResponse << ', 'jsonrpc');
end;
{ TMyObjectWithHooks }
procedure TMyObjectWithHooks.DoSomething;
begin
// do nothing
end;
procedure TMyObjectWithHooks.DoSomethingWithError;
begin
raise Exception.Create('Boom');
end;
procedure TMyObjectWithHooks.OnAfterCallHook(const Context: TWebContext; const JSON: TJsonObject);
begin
// do nothing
end;
procedure TMyObjectWithHooks.OnBeforeCallHook(const Context: TWebContext; const JSON: TJsonObject);
begin
// do nothing
end;
procedure TMyObjectWithHooks.OnBeforeRoutingHook(const Context: TWebContext; const JSON: TJsonObject);
begin
// do nothing
end;
end.

12
samples/jsonrpc_with_published_objects/jsonrpcserverwithobjects.dpr
View File

@ -6,6 +6,7 @@ uses
System.SysUtils,
MVCFramework.Logger,
MVCFramework.Commons,
MVCFramework.Console,
MVCFramework.REPLCommandsHandlerU,
Web.ReqMulti,
Web.WebReq,
@ -65,12 +66,17 @@ begin
{ more info about ListenQueue
http://www.indyproject.org/docsite/html/frames.html?frmname=topic&frmfile=TIdCustomTCPServer_ListenQueue.html }
LServer.ListenQueue := 200;
SaveColors;
TextColor(Yellow);
WriteLn('Write "quit" or "exit" to shutdown the server');
RestoreSavedColors;
repeat
if lCmd.IsEmpty then
begin
SaveColors;
TextColor(Green);
Write('-> ');
RestoreSavedColors;
ReadLn(lCmd)
end;
try
@ -85,7 +91,10 @@ begin
end;
THandleCommandResult.Unknown:
begin
SaveColors;
TextColor(Red);
REPLEmit('Unknown command: ' + lCmd);
RestoreSavedColors;
end;
end;
finally
@ -101,6 +110,7 @@ end;
begin
ReportMemoryLeaksOnShutdown := True;
IsMultiThread := True;
TextColor(TConsoleColor.White);
try
if WebRequestHandler <> nil then
WebRequestHandler.WebModuleClass := WebModuleClass;

133
sources/MVCFramework.ActiveRecord.pas
View File

@ -58,7 +58,12 @@ type
end;
TMVCActiveRecordClass = class of TMVCActiveRecord;
TMVCActiveRecordFieldOption = (foPrimaryKey, foAutoGenerated, foTransient);
TMVCActiveRecordFieldOption = (
foPrimaryKey, { it's the primary key of the mapped table }
foAutoGenerated, { not written, read - similar to readonly }
foTransient, { not written, not read }
foReadOnly, { not written, read }
foWriteOnly); { written, not read }
TMVCActiveRecordFieldOptions = set of TMVCActiveRecordFieldOption;
TMVCEntityAction = (eaCreate, eaRetrieve, eaUpdate, eaDelete);
TMVCEntityActions = set of TMVCEntityAction;
@ -81,7 +86,7 @@ type
TFieldInfo = class
public
// TableName: string;
// TableName: string;
FieldName: string;
FieldOptions: TMVCActiveRecordFieldOptions;
DataTypeName: string;
@ -91,11 +96,13 @@ type
TFieldsMap = class(TObjectDictionary<TRTTIField, TFieldInfo>)
private
fNonTransientFieldsCount: Integer;
fWritableFieldsCount: Integer;
fReadableFieldsCount: Integer;
public
constructor Create;
procedure EndUpdates;
property NonTransientFieldsCount: Integer read fNonTransientFieldsCount;
property WritableFieldsCount: Integer read fWritableFieldsCount;
property ReadableFieldsCount: Integer read fWritableFieldsCount;
function GetInfoByFieldName(const FieldName: string): TFieldInfo;
end;
@ -155,7 +162,7 @@ type
function GetPrimaryKeyIsAutogenerated: Boolean;
procedure SetPrimaryKeyIsAutogenerated(const Value: Boolean);
function GetPrimaryKeyFieldType: TFieldType;
procedure SetTableName(const Value: String);
procedure SetTableName(const Value: string);
protected
fRTTIType: TRttiInstanceType;
fProps: TArray<TRTTIField>;
@ -282,7 +289,7 @@ type
procedure AddChildren(const ChildObject: TObject);
procedure RemoveChildren(const ChildObject: TObject);
[MVCDoNotSerialize]
property TableName: String read fTableName write SetTableName;
property TableName: string read fTableName write SetTableName;
[MVCDoNotSerialize]
property PrimaryKeyIsAutogenerated: Boolean read GetPrimaryKeyIsAutogenerated write SetPrimaryKeyIsAutogenerated;
class function GetByPK(const aClass: TMVCActiveRecordClass; const aValue: int64;
@ -452,7 +459,7 @@ type
// end-capabilities
function CreateSQLWhereByRQL(const RQL: string; const Mapping: TMVCFieldsMapping;
const UseArtificialLimit: Boolean = True;
const UseFilterOnly: Boolean = False
const UseFilterOnly: Boolean = false
): string; virtual; abstract;
function CreateSelectSQL(const TableName: string; const Map: TFieldsMap;
const PKFieldName: string; const PKOptions: TMVCActiveRecordFieldOptions): string; virtual; abstract;
@ -603,6 +610,13 @@ begin
lName := aName.ToLower;
lConnKeyName := GetKeyName(lName);
{ If the transaction is not started, initialize TxIsolation as ReadCommitted }
if aConnection.Transaction = nil then
begin
{ needed for Delphi 10.4 Sydney+ }
aConnection.TxOptions.Isolation := TFDTxIsolation.xiReadCommitted;
end;
fMREW.BeginWrite;
try
lConnHolder := TConnHolder.Create;
@ -955,7 +969,7 @@ begin
begin
fPrimaryKeyFieldType := ftLargeInt;
end
else if lPrimaryFieldTypeAsStr.EndsWith('integer') then
else if lPrimaryFieldTypeAsStr.EndsWith('integer') or lPrimaryFieldTypeAsStr.EndsWith('int32') then
begin
fPrimaryKeyFieldType := ftInteger;
end
@ -975,9 +989,8 @@ begin
continue;
end;
{ TODO -oDanieleT -cGeneral : Definire TFieldInfo per tute le info del field }
lFieldInfo := TFieldInfo.Create;
//lFieldInfo.TableName := fTableName;
// lFieldInfo.TableName := fTableName;
lFieldInfo.FieldName := MVCTableFieldAttribute(lAttribute).FieldName;
lFieldInfo.FieldOptions := MVCTableFieldAttribute(lAttribute).FieldOptions;
lFieldInfo.DataTypeName := MVCTableFieldAttribute(lAttribute).DataTypeName;
@ -1010,10 +1023,11 @@ begin
OnValidation(TMVCEntityAction.eaCreate);
OnBeforeInsert;
OnBeforeInsertOrUpdate;
if fMap.NonTransientFieldsCount = 0 then
if fMap.WritableFieldsCount = 0 then
begin
raise EMVCActiveRecord.CreateFmt
('Cannot insert an entity if all fields are transient. Class [%s] mapped on table [%s]', [ClassName, fTableName]);
('Cannot insert an entity if all fields are not writable or transient. Class [%s] mapped on table [%s]',
[ClassName, fTableName]);
end;
if (foAutoGenerated in fPrimaryKeyOptions) then
begin
@ -1049,7 +1063,7 @@ begin
lSQL := Self.SQLGenerator.CreateSelectCount(fTableName);
if not RQL.IsEmpty then
begin
lSQL := lSQL + fSQLGenerator.CreateSQLWhereByRQL(RQL, GetMapping, False, True);
lSQL := lSQL + fSQLGenerator.CreateSQLWhereByRQL(RQL, GetMapping, false, True);
end;
Result := GetScalar(lSQL, []);
end;
@ -1135,19 +1149,24 @@ class function TMVCActiveRecordHelper.GetByPK<T>(const aValue: int64;
const RaiseExceptionIfNotFound: Boolean = True): T;
var
lActiveRecord: TMVCActiveRecord;
lLoaded: Boolean;
begin
Result := T.Create;
lActiveRecord := TMVCActiveRecord(Result);
if not lActiveRecord.LoadByPK(aValue) then
try
lLoaded := lActiveRecord.LoadByPK(aValue);
except
FreeAndNil(Result);
raise;
end;
if not lLoaded then
begin
Result.Free;
FreeAndNil(Result);
if RaiseExceptionIfNotFound then
begin
raise EMVCActiveRecordNotFound.Create('Data not found');
end
else
begin
Result := nil;
end;
end;
end;
@ -2176,23 +2195,14 @@ begin
if fPrimaryKey.GetValue(Self).Kind = tkRecord then
begin
lPKValue := fPrimaryKey.GetValue(Self);
if lPKValue.IsType<NullableInt32> then
if lPKValue.IsType<NullableInt32> and aValue.IsType<NullableInt32>() then
begin
if aValue.IsType<UInt32> then
begin
lPKValue := TValue.From<NullableInt32>(IntToNullableInt(aValue.AsInteger));
end;
//
// if aValue.AsType<NullableInt32>().HasValue then
// begin
// lPKValue := aValue;
// end
// else
// begin
// lPKValue.AsType<NullableInt32>().Clear;
// end;
end
else if lPKValue.IsType<NullableInt64> then
else if lPKValue.IsType<NullableInt64> and aValue.IsType<NullableInt64>() then
begin
if aValue.AsType<NullableInt64>().HasValue then
begin
@ -2203,7 +2213,18 @@ begin
lPKValue.AsType<NullableInt64>().Clear;
end;
end
else if lPKValue.IsType<NullableUInt32> then
else if lPKValue.IsType<NullableString> and aValue.IsType<NullableString>() then
begin
if aValue.AsType<NullableString>().HasValue then
begin
lPKValue := aValue;
end
else
begin
lPKValue.AsType<NullableString>().Clear;
end;
end
else if lPKValue.IsType<NullableUInt32> and aValue.IsType<NullableUInt32>() then
begin
if aValue.AsType<NullableUInt32>().HasValue then
begin
@ -2214,7 +2235,7 @@ begin
lPKValue.AsType<NullableUInt32>().Clear;
end;
end
else if lPKValue.IsType<NullableUInt64> then
else if lPKValue.IsType<NullableUInt64> and aValue.IsType<NullableUInt64>() then
begin
if aValue.AsType<NullableUInt64>().HasValue then
begin
@ -2226,7 +2247,9 @@ begin
end;
end
else
raise EMVCActiveRecord.Create('Invalid type for primary key');
begin
raise EMVCActiveRecord.Create('Invalid type for primary key [HINT] Double check if TypeInfo(PK) is equal to TypeInfo(Value)');
end;
fPrimaryKey.SetValue(Self, lPKValue);
end
else
@ -2247,7 +2270,7 @@ begin
end;
end;
procedure TMVCActiveRecord.SetTableName(const Value: String);
procedure TMVCActiveRecord.SetTableName(const Value: string);
begin
fTableName := Value;
end;
@ -2361,7 +2384,7 @@ begin
OnValidation(TMVCEntityAction.eaUpdate);
OnBeforeUpdate;
OnBeforeInsertOrUpdate;
if fMap.NonTransientFieldsCount = 0 then
if fMap.WritableFieldsCount = 0 then
begin
raise EMVCActiveRecord.CreateFmt
('Cannot update an entity if all fields are transient. Class [%s] mapped on table [%s]', [ClassName, fTableName]);
@ -2378,7 +2401,7 @@ begin
begin
fChildren := TObjectList<TObject>.Create(True);
end;
if not(fChildren.Contains(ChildObject)) and (not (ChildObject = Self)) then
if not(fChildren.Contains(ChildObject)) and (not(ChildObject = Self)) then
begin
fChildren.Add(ChildObject);
end;
@ -2659,7 +2682,14 @@ begin
Result := Copy(Result, 1, Length(Result) - Length(Delimiter));
if not PKFieldName.IsEmpty then
begin
Result := GetFieldNameForSQL(PKFieldName) + ', ' + Result;
if not Result.IsEmpty then
begin
Result := GetFieldNameForSQL(PKFieldName) + ', ' + Result
end
else
begin
Result := GetFieldNameForSQL(PKFieldName)
end;
end;
end;
@ -2744,20 +2774,27 @@ end;
constructor TFieldsMap.Create;
begin
inherited Create([doOwnsValues]);
fNonTransientFieldsCount := 0;
fWritableFieldsCount := -1;
fReadableFieldsCount := -1;
end;
procedure TFieldsMap.EndUpdates;
var
lPair: TPair<TRTTIField, TFieldInfo>;
begin
fNonTransientFieldsCount := 0;
fWritableFieldsCount := 0;
fReadableFieldsCount := 0;
for lPair in Self do
begin
lPair.Value.EndUpdates;
if not(foTransient in lPair.Value.FieldOptions) then
// if not(foTransient in lPair.Value.FieldOptions) then
if lPair.Value.Writeable then
begin
Inc(fNonTransientFieldsCount);
Inc(fWritableFieldsCount);
end;
if lPair.Value.Readable then
begin
Inc(fReadableFieldsCount);
end;
end;
end;
@ -2781,8 +2818,18 @@ end;
procedure TFieldInfo.EndUpdates;
begin
Writeable := (not FieldName.IsEmpty) and (not((foAutoGenerated in FieldOptions) or (foTransient in FieldOptions)));
Readable := not(foTransient in FieldOptions) and (not FieldName.IsEmpty);
if FieldName.IsEmpty then
begin
Writeable := false;
Readable := false;
end
else
begin
// Writeable := (not (foReadOnly in FieldOptions)) and (not((foAutoGenerated in FieldOptions) or (foTransient in FieldOptions)));
Writeable := ((FieldOptions * [foReadOnly, foTransient, foAutoGenerated]) = []);
// Readable := (not (foWriteOnly in FieldOptions)) and (not(foTransient in FieldOptions));
Readable := (FieldOptions * [foWriteOnly, foTransient]) = [];
end;
end;
initialization

102
sources/MVCFramework.JSONRPC.Client.pas
View File

@ -38,7 +38,8 @@ type
IMVCJSONRPCExecutor = interface
['{55415094-9D28-4707-AEC5-5FCF925E82BC}']
function ExecuteRequest(const aJSONRPCRequest: IJSONRPCRequest): IJSONRPCResponse;
procedure ExecuteNotification(const aJSONRPCNotification: IJSONRPCNotification);
function ExecuteNotification(const aJSONRPCNotification: IJSONRPCNotification): IJSONRPCResponse;
function HTTPResponse: IHTTPResponse;
// Http headers handling
procedure AddHTTPHeader(const aNetHeader: TNetHeader);
procedure ClearHTTPHeaders;
@ -56,17 +57,19 @@ type
TMVCJSONRPCExecutor = class(TInterfacedObject, IMVCJSONRPCExecutor)
private
FURL: string;
FHTTP: THTTPClient;
FRaiseExceptionOnError: Boolean;
FHTTPRequestHeaders: TList<TNetHeader>;
fURL: string;
fHTTP: THTTPClient;
fRaiseExceptionOnError: Boolean;
fHTTPRequestHeaders: TList<TNetHeader>;
fHTTPResponse: IHTTPResponse;
fOnReceiveResponse: TProc<IJSONRPCObject, IJSONRPCObject>;
fOnSendCommand: TProc<IJSONRPCObject>;
function GetHTTPRequestHeaders: TList<TNetHeader>;
protected
function HTTPResponse: IHTTPResponse;
function InternalExecute(const aJSONRPCObject: IJSONRPCObject): IJSONRPCResponse;
function ExecuteRequest(const aJSONRPCRequest: IJSONRPCRequest): IJSONRPCResponse;
procedure ExecuteNotification(const aJSONRPCNotification: IJSONRPCNotification);
function ExecuteNotification(const aJSONRPCNotification: IJSONRPCNotification): IJSONRPCResponse;
// Http headers handling
procedure AddHTTPHeader(const aNetHeader: TNetHeader);
procedure ClearHTTPHeaders;
@ -128,26 +131,26 @@ end;
procedure TMVCJSONRPCExecutor.ClearHTTPHeaders;
begin
if Assigned(FHTTPRequestHeaders) then
if Assigned(fHTTPRequestHeaders) then
begin
FHTTPRequestHeaders.Clear;
fHTTPRequestHeaders.Clear;
end;
end;
function TMVCJSONRPCExecutor.ConfigureHTTPClient(
const aConfigProc: TProc<THTTPClient>): IMVCJSONRPCExecutor;
begin
aConfigProc(FHTTP);
aConfigProc(fHTTP);
end;
constructor TMVCJSONRPCExecutor.Create(const aURL: string; const aRaiseExceptionOnError: Boolean = True);
begin
inherited Create;
FRaiseExceptionOnError := aRaiseExceptionOnError;
FURL := aURL;
FHTTP := THTTPClient.Create;
FHTTP.ResponseTimeout := MaxInt;
FHTTPRequestHeaders := nil;
fRaiseExceptionOnError := aRaiseExceptionOnError;
fURL := aURL;
fHTTP := THTTPClient.Create;
fHTTP.ResponseTimeout := MaxInt;
fHTTPRequestHeaders := nil;
SetOnReceiveResponse(nil)
.SetOnReceiveData(nil)
.SetOnNeedClientCertificate(nil)
@ -156,15 +159,24 @@ end;
destructor TMVCJSONRPCExecutor.Destroy;
begin
FHTTP.Free;
FHTTPRequestHeaders.Free;
fHTTP.Free;
fHTTPRequestHeaders.Free;
inherited;
end;
procedure TMVCJSONRPCExecutor.ExecuteNotification(const aJSONRPCNotification: IJSONRPCNotification);
function TMVCJSONRPCExecutor.ExecuteNotification(const aJSONRPCNotification: IJSONRPCNotification): IJSONRPCResponse;
// var
// lResp: IJSONRPCResponse;
begin
if InternalExecute(aJSONRPCNotification as TJSONRPCObject) <> nil then
raise EMVCJSONRPCException.Create('A "notification" cannot returns a response. Use ExecuteRequest instead.');
Result := InternalExecute(aJSONRPCNotification as TJSONRPCObject);
// if Assigned(lResp) then
// begin
//
// end;
// if InternalExecute(aJSONRPCNotification as TJSONRPCObject) <> nil then
// begin
// raise EMVCJSONRPCException.Create('A "notification" cannot returns a response. Use ExecuteRequest instead.');
// end;
end;
function TMVCJSONRPCExecutor.ExecuteRequest(const aJSONRPCRequest: IJSONRPCRequest): IJSONRPCResponse;
@ -174,18 +186,18 @@ end;
function TMVCJSONRPCExecutor.GetHTTPRequestHeaders: TList<TNetHeader>;
begin
if not Assigned(FHTTPRequestHeaders) then
if not Assigned(fHTTPRequestHeaders) then
begin
FHTTPRequestHeaders := TList<TNetHeader>.Create;
fHTTPRequestHeaders := TList<TNetHeader>.Create;
end;
Result := FHTTPRequestHeaders;
Result := fHTTPRequestHeaders;
end;
function TMVCJSONRPCExecutor.HTTPHeadersCount: Integer;
begin
if Assigned(FHTTPRequestHeaders) then
if Assigned(fHTTPRequestHeaders) then
begin
Result := FHTTPRequestHeaders.Count;
Result := fHTTPRequestHeaders.Count;
end
else
begin
@ -201,9 +213,9 @@ var
lCustomHeaders: TNetHeaders;
begin
lCustomHeaders := [];
if Assigned(FHTTPRequestHeaders) then
if Assigned(fHTTPRequestHeaders) then
begin
lCustomHeaders := FHTTPRequestHeaders.ToArray;
lCustomHeaders := fHTTPRequestHeaders.ToArray;
end;
Result := nil;
@ -214,37 +226,49 @@ begin
begin
fOnSendCommand(aJSONRPCObject);
end;
lHttpResp := FHTTP.Post(FURL, lSS, nil, [TNetHeader.Create('content-type', 'application/json;charset=utf8'),
fHTTPResponse := nil;
lHttpResp := fHTTP.Post(fURL, lSS, nil, [TNetHeader.Create('content-type', 'application/json;charset=utf8'),
TNetHeader.Create('accept', 'application/json;charset=utf8')] + lCustomHeaders);
if (lHttpResp.StatusCode <> HTTP_STATUS.NoContent) then
fHTTPResponse := lHttpResp;
if lHttpResp.StatusCode = HTTP_STATUS.NoContent then
begin
lJSONRPCResponse := TJSONRPCNullResponse.Create;
end
else
begin
lJSONRPCResponse := TJSONRPCResponse.Create;
lJSONRPCResponse.AsJSONString := lHttpResp.ContentAsString;
if Assigned(fOnReceiveResponse) then
begin
fOnReceiveResponse(aJSONRPCObject, lJSONRPCResponse);
end;
if Assigned(lJSONRPCResponse.Error) and FRaiseExceptionOnError then
raise EMVCJSONRPCException.CreateFmt('[REMOTE EXCEPTION][%d]: %s',
[lJSONRPCResponse.Error.Code, lJSONRPCResponse.Error.ErrMessage]);
Result := lJSONRPCResponse;
end;
if Assigned(fOnReceiveResponse) then
begin
fOnReceiveResponse(aJSONRPCObject, lJSONRPCResponse);
end;
fHTTPResponse := lHttpResp;
if Assigned(lJSONRPCResponse.Error) and fRaiseExceptionOnError then
raise EMVCJSONRPCException.CreateFmt('[REMOTE EXCEPTION][%d]: %s',
[lJSONRPCResponse.Error.Code, lJSONRPCResponse.Error.ErrMessage]);
Result := lJSONRPCResponse;
finally
lSS.Free;
end;
end;
function TMVCJSONRPCExecutor.HTTPResponse: IHTTPResponse;
begin
Result := fHTTPResponse;
end;
function TMVCJSONRPCExecutor.SetOnNeedClientCertificate(const aOnNeedClientCertificate: TNeedClientCertificateEvent)
: IMVCJSONRPCExecutor;
begin
FHTTP.OnNeedClientCertificate := aOnNeedClientCertificate;
fHTTP.OnNeedClientCertificate := aOnNeedClientCertificate;
Result := Self;
end;
function TMVCJSONRPCExecutor.SetOnReceiveData(
const aOnReceiveData: TReceiveDataEvent): IMVCJSONRPCExecutor;
begin
FHTTP.OnReceiveData := aOnReceiveData;
fHTTP.OnReceiveData := aOnReceiveData;
Result := Self;
end;
@ -265,7 +289,7 @@ end;
function TMVCJSONRPCExecutor.SetOnValidateServerCertificate(const aOnValidateServerCertificate
: TValidateCertificateEvent): IMVCJSONRPCExecutor;
begin
FHTTP.OnValidateServerCertificate := aOnValidateServerCertificate;
fHTTP.OnValidateServerCertificate := aOnValidateServerCertificate;
Result := Self;
end;

314
sources/MVCFramework.JSONRPC.pas
View File

@ -58,9 +58,9 @@ const
const
JSONRPC_HOOKS_ON_BEFORE_ROUTING = 'OnBeforeRoutingHook';
JSONRPC_HOOKS_ON_BEFORE_CALL = 'OnBeforeCallHook';
JSONRPC_HOOKS_ON_BEFORE_SEND_RESPONSE = 'OnBeforeSendResponseHook';
JSONRPC_HOOKS_ON_AFTER_CALL = 'OnAfterCallHook';
JSONRPC_HOOKS_METHOD_NAMES: array [0 .. 2] of string = (JSONRPC_HOOKS_ON_BEFORE_ROUTING,
JSONRPC_HOOKS_ON_BEFORE_CALL, JSONRPC_HOOKS_ON_BEFORE_SEND_RESPONSE);
JSONRPC_HOOKS_ON_BEFORE_CALL, JSONRPC_HOOKS_ON_AFTER_CALL);
{
http://www.jsonrpc.org/historical/json-rpc-over-http.html#response-codes
@ -261,8 +261,8 @@ type
FResult: TValue;
FError: TJSONRPCResponseError;
FID: TValue;
function GetResult: TValue;
protected
function GetResult: TValue;
function GetJSON: TJDOJsonObject; override;
procedure SetJSON(const JSON: TJDOJsonObject); override;
procedure SetID(const Value: TValue);
@ -281,6 +281,29 @@ type
destructor Destroy; override;
end;
TJSONRPCNullResponse = class(TJSONRPCObject, IJSONRPCResponse)
private
FError: TJSONRPCResponseError;
procedure RaiseErrorForNullObject;
protected
function GetJSONString: string; override;
procedure SetJsonString(const Value: string); override;
function GetJSON: TJDOJsonObject; override;
procedure SetJSON(const JSON: TJDOJsonObject); override;
procedure SetID(const Value: TValue);
procedure SetResult(const Value: TValue);
procedure SetError(const Value: TJSONRPCResponseError);
function GetError: TJSONRPCResponseError;
function GetID: TValue;
function GetResult: TValue;
function ResultAsJSONObject: TJDOJsonObject;
function ResultAsJSONArray: TJDOJsonArray;
function IsError: Boolean;
property Result: TValue read GetResult write SetResult;
property Error: TJSONRPCResponseError read GetError write SetError;
property RequestID: TValue read GetID write SetID;
end;
EMVCJSONRPCInvalidVersion = class(Exception)
end;
@ -357,7 +380,7 @@ type
function CanBeRemotelyInvoked(const RTTIMethod: TRTTIMethod): Boolean;
procedure ForEachInvokableMethod(const aProc: TProc<TRTTIMethod>);
procedure TryToCallMethod(const aRTTIType: TRttiType; const MethodName: string;
const Parameter: TJDOJsonObject; const ParameterName: string);
const Parameter: TJDOJsonObject);
public
[MVCPath]
[MVCHTTPMethods([httpPOST])]
@ -984,6 +1007,7 @@ var
lClass: TJSONRPCProxyGeneratorClass;
lGenerator: TJSONRPCProxyGenerator;
lRTTI: TRTTIContext;
lContentType: string;
begin
lLanguage := Context.Request.Params['language'].ToLower;
if lLanguage.IsEmpty then
@ -991,6 +1015,15 @@ begin
lLanguage := 'delphi';
end;
if Context.Request.QueryStringParamExists('content-type') then
begin
lContentType := Context.Request.Params['content-type'];
end
else
begin
lContentType := 'text/plain';
end;
if not Assigned(GProxyGeneratorsRegister) then
begin
raise EMVCJSONRPCException.Create
@ -1013,7 +1046,7 @@ begin
lGenerator.VisitMethod(aRTTIMethod);
end);
lGenerator.EndGeneration();
Context.Response.ContentType := 'text/plain';
Context.Response.ContentType := lContentType;
Render(lGenerator.GetCode);
finally
lRTTI.Free;
@ -1069,7 +1102,11 @@ var
lReqID: TValue;
lJSON: TJDOJsonObject;
lJSONResp: TJDOJsonObject;
lBeforeCallHookHasBeenInvoked: Boolean;
lAfterCallHookHasBeenInvoked: Boolean;
begin
lBeforeCallHookHasBeenInvoked := False;
lAfterCallHookHasBeenInvoked := False;
lRTTIType := nil;
lReqID := TValue.Empty;
SetLength(lParamsToInject, 0);
@ -1079,20 +1116,21 @@ begin
lJSON := StrToJSONObject(Context.Request.Body);
try
if not Assigned(lJSON) then
begin
raise EMVCJSONRPCParseError.Create;
end;
lRTTIType := lRTTI.GetType(fRPCInstance.ClassType);
TryToCallMethod(lRTTIType, JSONRPC_HOOKS_ON_BEFORE_ROUTING, lJSON, 'JSON');
lJSONRPCReq := CreateRequest(lJSON);
lMethod := lJSONRPCReq.Method;
if SameText(lMethod, JSONRPC_HOOKS_ON_BEFORE_ROUTING) or
SameText(lMethod, JSONRPC_HOOKS_ON_BEFORE_CALL) or
SameText(lMethod, JSONRPC_HOOKS_ON_BEFORE_SEND_RESPONSE) then
if IsReservedMethodName(lMethod) then
begin
raise EMVCJSONRPCInvalidRequest.Create
('Requested method name is reserved and cannot be called remotely');
raise EMVCJSONRPCInvalidRequest.CreateFmt
('Requested method name [%s] is reserved and cannot be called remotely', [lMethod]);
end;
TryToCallMethod(lRTTIType, JSONRPC_HOOKS_ON_BEFORE_ROUTING, lJSON);
if lJSONRPCReq.RequestType = TJSONRPCRequestType.Request then
begin
if lJSONRPCReq.RequestID.IsEmpty then
@ -1108,14 +1146,6 @@ begin
if Assigned(lRTTIMethod) then
begin
if not CanBeRemotelyInvoked(lRTTIMethod) then
begin
LogW(Format
('Method "%s" cannot be called. Only public functions or procedures can be called. ',
[lMethod]));
raise EMVCJSONRPCMethodNotFound.Create(lMethod);
end;
if (lJSONRPCReq.RequestType = TJSONRPCRequestType.Request) and
(lRTTIMethod.MethodKind <> mkFunction) then
begin
@ -1130,6 +1160,14 @@ begin
('Cannot call a function using a JSON-RPC notification. [HINT] Use requests for functions and notifications for procedures');
end;
if not CanBeRemotelyInvoked(lRTTIMethod) then
begin
LogW(Format
('Method [%s] cannot remotely invoked. Only public functions or procedures can be called.',
[lMethod]));
raise EMVCJSONRPCMethodNotFound.Create(lMethod);
end;
try
lJSONRPCReq.FillParameters(lJSON, lRTTIMethod);
except
@ -1140,9 +1178,13 @@ begin
end;
end;
lJSONResp := nil;
// try
TryToCallMethod(lRTTIType, JSONRPC_HOOKS_ON_BEFORE_CALL, lJSON);
lBeforeCallHookHasBeenInvoked := True;
try
TryToCallMethod(lRTTIType, JSONRPC_HOOKS_ON_BEFORE_CALL, lJSON, 'JSONRequest');
LogD('[JSON-RPC][CALL][' + CALL_TYPE[lRTTIMethod.MethodKind] + '] ' + lRTTIMethod.Name);
LogD('[JSON-RPC][CALL][' + CALL_TYPE[lRTTIMethod.MethodKind] + '][' + fRPCInstance.ClassName + '.' +
lRTTIMethod.Name + ']');
lRes := lRTTIMethod.Invoke(fRPCInstance, lJSONRPCReq.Params.ToArray);
except
on E: EInvalidCast do
@ -1165,21 +1207,30 @@ begin
lJSONRPCResponse := CreateResponse(lJSONRPCReq.RequestID, lRes);
ResponseStatus(200);
lJSONResp := lJSONRPCResponse.AsJSON;
try
TryToCallMethod(lRTTIType, JSONRPC_HOOKS_ON_BEFORE_SEND_RESPONSE, lJSONResp,
'JSONResponse');
Render(lJSONResp);
except
try
lJSONResp.Free;
except
// do nothing
end;
end;
end;
else
raise EMVCJSONRPCException.Create('Invalid RequestType');
end;
// finally
// if lBeforeCallHookHasBeenInvoked then
// begin
// TryToCallMethod(lRTTIType, JSONRPC_HOOKS_ON_AFTER_CALL, lJSONResp);
// lAfterCallHookHasBeenInvoked := True;
// end;
// if lJSONResp <> nil then
// begin
// try
// Render(lJSONResp);
// except
// try
// lJSONResp.Free;
// except
// // do nothing
// end;
// end;
// end;
// end;
end
else
begin
@ -1187,9 +1238,8 @@ begin
[lMethod, fRPCInstance.QualifiedClassName]));
raise EMVCJSONRPCMethodNotFound.Create(lMethod);
end;
finally
lJSON.Free;
FreeAndNil(lJSON);
end;
except
on E: EMVCJSONRPCErrorResponse do
@ -1218,28 +1268,33 @@ begin
JSONRPC_ERR_SERVER_ERROR_LOWERBOUND .. JSONRPC_ERR_SERVER_ERROR_UPPERBOUND:
ResponseStatus(500);
end;
lJSON := CreateError(lReqID, E.JSONRPCErrorCode, E.Message);
try
TryToCallMethod(lRTTIType, JSONRPC_HOOKS_ON_BEFORE_SEND_RESPONSE, lJSON, 'JSONResponse');
Render(lJSON, False);
finally
lJSON.Free;
end;
lJSONResp := CreateError(lReqID, E.JSONRPCErrorCode, E.Message);
LogE(Format('[JSON-RPC][CLS %s][ERR %d][MSG "%s"]', [E.ClassName, E.JSONRPCErrorCode,
E.Message]));
end;
on Ex: Exception do // use another name for exception variable, otherwise E is nil!!
begin
lJSON := CreateError(lReqID, 0, Ex.Message);
try
TryToCallMethod(lRTTIType, JSONRPC_HOOKS_ON_BEFORE_SEND_RESPONSE, lJSON, 'JSONResponse');
Render(lJSON, False);
finally
lJSON.Free;
end;
lJSONResp := CreateError(lReqID, 0, Ex.Message);
LogE(Format('[JSON-RPC][CLS %s][MSG "%s"]', [Ex.ClassName, Ex.Message]));
end;
end; // except
if lBeforeCallHookHasBeenInvoked and (not lAfterCallHookHasBeenInvoked) then
begin
try
TryToCallMethod(lRTTIType, JSONRPC_HOOKS_ON_AFTER_CALL, lJSONResp);
except
on E: Exception do
begin
FreeAndNil(lJSONResp);
if E is EMVCJSONRPCErrorResponse then
lJSONResp := CreateError(lReqID, EMVCJSONRPCErrorResponse(E).JSONRPCErrorCode, E.Message)
else
lJSONResp := CreateError(lReqID, 0, E.Message);
end;
end;
end;
Render(lJSONResp, True);
finally
lRTTI.Free;
end;
@ -1257,12 +1312,13 @@ begin
end;
procedure TMVCJSONRPCController.TryToCallMethod(const aRTTIType: TRttiType;
const MethodName: string; const Parameter: TJDOJsonObject; const ParameterName: string);
const MethodName: string; const Parameter: TJDOJsonObject);
var
lHookMethod: TRTTIMethod;
lHookParam: TRttiParameter;
lHookParamParamType: string;
lHookParamName: string;
lHookSecondParam: TRttiParameter;
lHookSecondParamType: string;
lHookFirstParam: TRttiParameter;
lHookFirstParamType: string;
begin
if not Assigned(aRTTIType) then
begin
@ -1271,20 +1327,38 @@ begin
lHookMethod := aRTTIType.GetMethod(MethodName);
if Assigned(lHookMethod) then
begin
if (Length(lHookMethod.GetParameters) <> 1) then
if (Length(lHookMethod.GetParameters) <> 2) then
begin
raise EMVCJSONRPCException.CreateFmt('Invalid signature for [%s] Hook method [HINT: procedure '
+ '%s.%s(const %s: TJDOJsonObject)', [MethodName, fRPCInstance.ClassName, MethodName,
ParameterName]);
lHookParam := lHookMethod.GetParameters[0];
lHookParamParamType := lHookParam.ParamType.ToString.ToLower;
lHookParamName := lHookParam.Name.ToLower;
if ((lHookParamParamType <> 'tjdojsonobject') and (lHookParamParamType <> 'tjsonobject')) or
(lHookParam.Flags * [pfConst, pfAddress] <> [pfConst, pfAddress]) or
(lHookParamName <> ParameterName.ToLower) then
+ '%s.%s(const Context: TWebContext; const Value: TJDOJsonObject)',
[MethodName, fRPCInstance.ClassName, MethodName]);
end;
lHookFirstParam := lHookMethod.GetParameters[0];
lHookSecondParam := lHookMethod.GetParameters[1];
lHookFirstParamType := lHookFirstParam.ParamType.ToString.ToLower;
lHookSecondParamType := lHookSecondParam.ParamType.ToString.ToLower;
if (lHookMethod.MethodKind <> mkProcedure) then
raise EMVCJSONRPCException.CreateFmt('Invalid signature for [%s] Hook method [HINT: Hook methods MUST have the following signature "procedure '
+ '%s.%s(const Context: TWebContext; const Value: TJDOJsonObject)"',
[MethodName, fRPCInstance.ClassName, MethodName]);
if ((lHookSecondParamType <> 'tjdojsonobject') and (lHookSecondParamType <> 'tjsonobject')) or
(lHookSecondParam.Flags * [pfConst, pfAddress] <> [pfConst, pfAddress]) then
raise EMVCJSONRPCException.CreateFmt('Invalid signature for [%s] Hook method [HINT: procedure '
+ '%s.%s(const %s: TJDOJsonObject)', [MethodName, fRPCInstance.ClassName, MethodName,
ParameterName]);
lHookMethod.Invoke(fRPCInstance, [Parameter])
+ '%s.%s(const Context: TWebContext; const Value: TJDOJsonObject)',
[MethodName, fRPCInstance.ClassName, MethodName]);
if (lHookFirstParamType <> 'twebcontext') or
(lHookFirstParam.Flags * [pfConst, pfAddress] <> [pfConst, pfAddress]) then
raise EMVCJSONRPCException.CreateFmt('Invalid signature for [%s] Hook method [HINT: procedure '
+ '%s.%s(const Context: TWebContext; const Value: TJDOJsonObject)',
[MethodName, fRPCInstance.ClassName, MethodName]);
LogD('[JSON-RPC][HOOK][' + fRPCInstance.ClassName + '.' + MethodName + ']');
lHookMethod.Invoke(fRPCInstance, [Self.Context, Parameter])
end;
end;
@ -1387,6 +1461,7 @@ end;
constructor TJSONRPCRequest.Create;
begin
inherited Create;
Self.FID := TValue.Empty;
end;
destructor TJSONRPCRequest.Destroy;
@ -1798,24 +1873,32 @@ end;
function TJSONRPCRequest.GetJSON: TJDOJsonObject;
begin
Result := inherited GetJSON;
if not FID.IsEmpty then
begin
if FID.IsType<string> then
try
if not FID.IsEmpty then
begin
Result.S[JSONRPC_ID] := FID.AsString;
end
else if FID.IsType<Int32> then
begin
Result.I[JSONRPC_ID] := FID.AsInteger;
end
else if FID.IsType<Int64> then
begin
Result.I[JSONRPC_ID] := FID.AsInt64;
if FID.IsType<string> then
begin
Result.S[JSONRPC_ID] := FID.AsString;
end
else if FID.IsType<Int32> then
begin
Result.I[JSONRPC_ID] := FID.AsInteger;
end
else if FID.IsType<Int64> then
begin
Result.I[JSONRPC_ID] := FID.AsInt64;
end
else
raise EMVCJSONRPCException.Create('ID can be only Int32, Int64 or String');
end
else
raise EMVCJSONRPCException.Create('ID can be only Int32, Int64 or String');
begin
raise EMVCJSONRPCException.Create('ID cannot be empty in a JSON-RPC request');
end;
except
Result.Free;
raise;
end;
end;
{ TJSONRPCProxyGenerator }
@ -2032,6 +2115,81 @@ begin
fJSONRPCErrorCode := ErrCode;
end;
{ TJSONRPCNullResponse }
function TJSONRPCNullResponse.GetError: TJSONRPCResponseError;
begin
Result := FError;
end;
function TJSONRPCNullResponse.GetID: TValue;
begin
RaiseErrorForNullObject;
end;
function TJSONRPCNullResponse.GetJSON: TJDOJsonObject;
begin
Result := nil;
RaiseErrorForNullObject;
end;
function TJSONRPCNullResponse.GetJSONString: string;
begin
RaiseErrorForNullObject;
end;
function TJSONRPCNullResponse.GetResult: TValue;
begin
RaiseErrorForNullObject;
end;
function TJSONRPCNullResponse.IsError: Boolean;
begin
Result := False;
end;
procedure TJSONRPCNullResponse.RaiseErrorForNullObject;
begin
raise EMVCJSONRPCException.Create('Invalid Call for NULL object');
end;
function TJSONRPCNullResponse.ResultAsJSONArray: TJDOJsonArray;
begin
Result := nil;
RaiseErrorForNullObject;
end;
function TJSONRPCNullResponse.ResultAsJSONObject: TJDOJsonObject;
begin
Result := nil;
RaiseErrorForNullObject;
end;
procedure TJSONRPCNullResponse.SetError(const Value: TJSONRPCResponseError);
begin
FError := Value;
end;
procedure TJSONRPCNullResponse.SetID(const Value: TValue);
begin
RaiseErrorForNullObject;
end;
procedure TJSONRPCNullResponse.SetJSON(const JSON: TJDOJsonObject);
begin
RaiseErrorForNullObject;
end;
procedure TJSONRPCNullResponse.SetJsonString(const Value: string);
begin
RaiseErrorForNullObject;
end;
procedure TJSONRPCNullResponse.SetResult(const Value: TValue);
begin
RaiseErrorForNullObject;
end;
initialization
finalization

77
sources/MVCFramework.JWT.pas
View File

@ -36,21 +36,83 @@ uses
type
{$SCOPEDENUMS ON}
{$SCOPEDENUMS ON}
TJWTCheckableClaim = (ExpirationTime, NotBefore, IssuedAt);
TJWTCheckableClaims = set of TJWTCheckableClaim;
TJWTRegisteredClaimNames = class sealed
public
const
/// <summary>
/// The "iss" (issuer) claim identifies the principal that issued the
/// JWT. The processing of this claim is generally application specific.
/// The "iss" value is a case-sensitive string containing a StringOrURI
/// value. Use of this claim is OPTIONAL.
/// </summary>
Issuer: string = 'iss';
/// <summary>
/// The "sub" (subject) claim identifies the principal that is the
/// subject of the JWT. The claims in a JWT are normally statements
/// about the subject. The subject value MUST either be scoped to be
/// locally unique in the context of the issuer or be globally unique.
/// The processing of this claim is generally application specific. The
/// "sub" value is a case-sensitive string containing a StringOrURI
/// value. Use of this claim is OPTIONAL.
/// </summary>
Subject: string = 'sub';
/// <summary>
/// The "aud" (audience) claim identifies the recipients that the JWT is
/// intended for. Each principal intended to process the JWT MUST
/// identify itself with a value in the audience claim. If the principal
/// processing the claim does not identify itself with a value in the
/// "aud" claim when this claim is present, then the JWT MUST be
/// rejected. In the general case, the "aud" value is an array of case-
/// sensitive strings, each containing a StringOrURI value. In the
/// special case when the JWT has one audience, the "aud" value MAY be a
/// single case-sensitive string containing a StringOrURI value. The
/// interpretation of audience values is generally application specific.
/// Use of this claim is OPTIONAL.
/// </summary>
Audience: string = 'aud';
/// <summary>
/// The "exp" (expiration time) claim identifies the expiration time on
/// or after which the JWT MUST NOT be accepted for processing. The
/// processing of the "exp" claim requires that the current date/time
/// MUST be before the expiration date/time listed in the "exp" claim.
/// Implementers MAY provide for some small leeway, usually no more than
/// a few minutes, to account for clock skew. Its value MUST be a number
/// containing a NumericDate value. Use of this claim is OPTIONAL.
/// </summary>
ExpirationTime: string = 'exp';
/// <summary>
/// The "nbf" (not before) claim identifies the time before which the JWT
/// MUST NOT be accepted for processing. The processing of the "nbf"
/// claim requires that the current date/time MUST be after or equal to
/// the not-before date/time listed in the "nbf" claim. Implementers MAY
/// provide for some small leeway, usually no more than a few minutes, to
/// account for clock skew. Its value MUST be a number containing a
/// NumericDate value. Use of this claim is OPTIONAL.
/// </summary>
NotBefore: string = 'nbf';
/// <summary>
/// The "iat" (issued at) claim identifies the time at which the JWT was
/// issued. This claim can be used to determine the age of the JWT. Its
/// value MUST be a number containing a NumericDate value. Use of this
/// claim is OPTIONAL.
/// </summary>
IssuedAt: string = 'iat';
/// <summary>
/// The "jti" (JWT ID) claim provides a unique identifier for the JWT.
/// The identifier value MUST be assigned in a manner that ensures that
/// there is a negligible probability that the same value will be
/// accidentally assigned to a different data object; if the application
/// uses multiple issuers, collisions MUST be prevented among values
/// produced by different issuers as well. The "jti" claim can be used
/// to prevent the JWT from being replayed. The "jti" value is a case-
/// sensitive string. Use of this claim is OPTIONAL.
/// </summary>
JWT_ID: string = 'jti';
Names: array [0 .. 6] of string = (
'iss',
'sub',
@ -213,7 +275,8 @@ type
/// ExpirationTime will be incremented by LiveValidityWindowInSeconds seconds automatically
/// if the remaining seconds are less than the LiveValidityWindowInSeconds.
/// </summary>
property LiveValidityWindowInSeconds: Cardinal read GetLiveValidityWindowInSeconds write SetLiveValidityWindowInSeconds;
property LiveValidityWindowInSeconds: Cardinal read GetLiveValidityWindowInSeconds
write SetLiveValidityWindowInSeconds;
end;
implementation
@ -478,7 +541,7 @@ begin
try
lPayload := TJDOJSONObject.Create;
try
lHeader.S['alg'] := HMACAlgorithm;
lHeader.S['alg'] := HMACAlgorithm;
lHeader.S['typ'] := 'JWT';
for lRegClaimName in TJWTRegisteredClaimNames.Names do
begin
@ -495,7 +558,7 @@ begin
for lCustomClaimName in FCustomClaims.Keys do
begin
lPayload.S[lCustomClaimName] := FCustomClaims[lCustomClaimName];
lPayload.S[lCustomClaimName] := FCustomClaims[lCustomClaimName];
end;
lHeaderEncoded := URLSafeB64encode(lHeader.ToString, False, IndyTextEncoding_UTF8);
@ -623,8 +686,8 @@ begin
begin
lIsRegistered := False;
lName := lJPayload.Names[I];
lValue := lJPayload.Items[I].Value;
lName := lJPayload.Names[i];
lValue := lJPayload.Items[i].Value;
// if is a registered claim, load it in the proper dictionary...
for j := 0 to high(TJWTRegisteredClaimNames.Names) do

2
sources/MVCFramework.Middleware.Authentication.RoleBasedAuthHandler.pas
View File

@ -94,7 +94,7 @@ type
const AActionName: string; var AHandled: Boolean);
protected
procedure OnBeforeControllerAction(AContext: TWebContext; const AControllerQualifiedClassName: string;
const AActionName: string; var AHandled: Boolean);
const AActionName: string; var AHandled: Boolean); override;
public
constructor Create(const AAuthenticationHandler: IMVCAuthenticationHandler;
const ALoginUrl: string = '/system/users/logged'); override;

59
sources/MVCFramework.Middleware.Authentication.pas
View File

@ -61,12 +61,12 @@ type
const AActionName: string;
const AHandled: Boolean
);
procedure OnAfterRouting(AContext: TWebContext; const AHandled: Boolean);
public
constructor Create(
const AAuthenticationHandler: IMVCAuthenticationHandler;
const ARealm: string = 'DelphiMVCFramework REALM'
); virtual;
procedure OnAfterRouting(AContext: TWebContext; const AHandled: Boolean);
end;
TMVCCustomAuthenticationMiddleware = class(TInterfacedObject, IMVCMiddleware)
@ -84,7 +84,7 @@ type
const AControllerQualifiedClassName: string;
const AActionName: string;
var AHandled: Boolean
);
); virtual;
procedure OnAfterControllerAction(
AContext: TWebContext;
@ -96,7 +96,6 @@ type
const AHandled: Boolean
);
procedure SendResponse(AContext: TWebContext; var AHandled: Boolean; AHttpStatus: Word = HTTP_STATUS.Unauthorized);
procedure DoLogin(AContext: TWebContext; var AHandled: Boolean);
procedure DoLogout(AContext: TWebContext; var AHandled: Boolean);
@ -149,15 +148,18 @@ procedure TMVCBasicAuthenticationMiddleware.OnBeforeControllerAction(
if AContext.Request.ClientPreferHTML then
begin
AContext.Response.ContentType := TMVCMediaType.TEXT_HTML;
AContext.Response.RawWebResponse.Content := Format(CONTENT_HTML_FORMAT, [CONTENT_401_NOT_AUTHORIZED, AContext.Config[TMVCConfigKey.ServerName]]);
AContext.Response.RawWebResponse.Content :=
Format(CONTENT_HTML_FORMAT, [CONTENT_401_NOT_AUTHORIZED, AContext.Config[TMVCConfigKey.ServerName]]);
end
else
begin
AContext.Response.ContentType := TMVCMediaType.TEXT_PLAIN;
AContext.Response.RawWebResponse.Content := CONTENT_401_NOT_AUTHORIZED + sLineBreak + AContext.Config[TMVCConfigKey.ServerName];
AContext.Response.RawWebResponse.Content := CONTENT_401_NOT_AUTHORIZED + sLineBreak + AContext.Config
[TMVCConfigKey.ServerName];
end;
AContext.Response.StatusCode := HTTP_STATUS.Unauthorized;
AContext.Response.SetCustomHeader('WWW-Authenticate', 'Basic realm=' + QuotedStr(FRealm));
AContext.SessionStop(False);
AHandled := True;
end;
@ -167,21 +169,30 @@ procedure TMVCBasicAuthenticationMiddleware.OnBeforeControllerAction(
if AContext.Request.ClientPreferHTML then
begin
AContext.Response.ContentType := TMVCMediaType.TEXT_HTML;
AContext.Response.RawWebResponse.Content := Format(CONTENT_HTML_FORMAT, [CONTENT_403_FORBIDDEN, AContext.Config[TMVCConfigKey.ServerName]]);
AContext.Response.RawWebResponse.Content :=
Format(CONTENT_HTML_FORMAT, [CONTENT_403_FORBIDDEN, AContext.Config[TMVCConfigKey.ServerName]]);
end
else if AContext.Request.ContentMediaType.StartsWith(TMVCMediaType.APPLICATION_JSON) then
begin
AContext.Response.ContentType := TMVCMediaType.APPLICATION_JSON;
AContext.Response.RawWebResponse.Content :=
'{"status":"error", "message":"' + CONTENT_403_FORBIDDEN.Replace('"', '\"') + '"}';
end
else
begin
AContext.Response.ContentType := TMVCMediaType.TEXT_PLAIN;
AContext.Response.RawWebResponse.Content := CONTENT_403_FORBIDDEN + sLineBreak + AContext.Config[TMVCConfigKey.ServerName];
AContext.Response.RawWebResponse.Content := CONTENT_403_FORBIDDEN + sLineBreak + AContext.Config
[TMVCConfigKey.ServerName];
end;
AContext.Response.StatusCode := HTTP_STATUS.Forbidden;
AContext.Response.ReasonString := AContext.Config[TMVCConfigKey.ServerName];
AHandled := True;
end;
var
AuthRequired: Boolean;
IsValid, IsAuthorized: Boolean;
AuthHeader: string;
AuthHeader, Token: string;
AuthPieces: TArray<string>;
RolesList: TList<string>;
SessionData: TSessionData;
@ -199,9 +210,15 @@ begin
if not IsValid then
begin
AuthHeader := AContext.Request.Headers['Authorization'];
AuthHeader := TMVCSerializerHelper.DecodeString(AuthHeader.Remove(0, 'Basic'.Length).Trim);
if AuthHeader.IsEmpty or (not AuthHeader.StartsWith('Basic ', True)) then
begin
SendWWWAuthenticate;
Exit;
end;
Token := AuthHeader.Remove(0, 'Basic '.Length).Trim;
AuthHeader := TMVCSerializerHelper.DecodeString(Token);
AuthPieces := AuthHeader.Split([':']);
if AuthHeader.IsEmpty or (Length(AuthPieces) <> 2) then
if Length(AuthPieces) <> 2 then
begin
SendWWWAuthenticate;
Exit;
@ -211,7 +228,8 @@ begin
try
SessionData := TSessionData.Create;
try
FAuthenticationHandler.OnAuthentication(AContext, AuthPieces[0], AuthPieces[1], RolesList, IsValid, SessionData);
FAuthenticationHandler.OnAuthentication(AContext, AuthPieces[0], AuthPieces[1], RolesList, IsValid,
SessionData);
if IsValid then
begin
AContext.LoggedUser.Roles.AddRange(RolesList);
@ -232,7 +250,8 @@ begin
IsAuthorized := False;
if IsValid then
FAuthenticationHandler.OnAuthorization(AContext, AContext.LoggedUser.Roles, AControllerQualifiedClassName, AActionName, IsAuthorized);
FAuthenticationHandler.OnAuthorization(AContext, AContext.LoggedUser.Roles, AControllerQualifiedClassName,
AActionName, IsAuthorized);
if IsAuthorized then
AHandled := False
@ -241,7 +260,9 @@ begin
if IsValid then
Send403Forbidden
else
begin
SendWWWAuthenticate;
end;
end;
end;
@ -249,7 +270,7 @@ procedure TMVCBasicAuthenticationMiddleware.OnBeforeRouting(
AContext: TWebContext;
var AHandled: Boolean);
begin
// Implement as needed
AHandled := False;
end;
{ TMVCCustomAuthenticationMiddleware }
@ -281,7 +302,8 @@ begin
AHandled := True;
AContext.Response.StatusCode := HTTP_STATUS.BadRequest;
AContext.Response.ContentType := TMVCMediaType.APPLICATION_JSON;
AContext.Response.RawWebResponse.Content := '{"status":"KO", "message":"username and password are mandatory in the body request as json object"}';
AContext.Response.RawWebResponse.Content :=
'{"status":"error", "message":"username and password are mandatory in the body request as json object"}';
Exit;
end;
@ -393,7 +415,8 @@ begin
end;
IsAuthorized := False;
FAuthenticationHandler.OnAuthorization(AContext, AContext.LoggedUser.Roles, AControllerQualifiedClassName, AActionName, IsAuthorized);
FAuthenticationHandler.OnAuthorization(AContext, AContext.LoggedUser.Roles, AControllerQualifiedClassName,
AActionName, IsAuthorized);
if IsAuthorized then
AHandled := False
else
@ -412,7 +435,8 @@ begin
begin
AHandled := False;
if (AContext.Request.HTTPMethod = httpPOST) and (AContext.Request.ContentType.StartsWith(TMVCMediaType.APPLICATION_JSON)) then
if (AContext.Request.HTTPMethod = httpPOST) and
(AContext.Request.ContentType.StartsWith(TMVCMediaType.APPLICATION_JSON)) then
DoLogin(AContext, AHandled);
if (AContext.Request.HTTPMethod = httpDELETE) then
@ -433,7 +457,8 @@ begin
if AContext.Request.ClientPreferHTML then
begin
AContext.Response.ContentType := TMVCMediaType.TEXT_HTML;
AContext.Response.RawWebResponse.Content := Format(CONTENT_HTML_FORMAT, [IntToStr(AHttpStatus), AContext.Config[TMVCConfigKey.ServerName]]);
AContext.Response.RawWebResponse.Content :=
Format(CONTENT_HTML_FORMAT, [IntToStr(AHttpStatus), AContext.Config[TMVCConfigKey.ServerName]]);
end
else
begin

9
sources/MVCFramework.RQL.AST2PostgreSQL.pas
View File

@ -167,7 +167,14 @@ end;
function TRQLPostgreSQLCompiler.RQLLimitToSQL(const aRQLLimit: TRQLLimit): string;
begin
Result := Format(' /*limit*/ LIMIT %d OFFSET %d', [aRQLLimit.Count, aRQLLimit.Start]);
if aRQLLimit.Start = 0 then
begin
Result := Format(' /*limit*/ LIMIT %d', [aRQLLimit.Count]);
end
else
begin
Result := Format(' /*limit*/ LIMIT %d OFFSET %d', [aRQLLimit.Count, aRQLLimit.Start]);
end;
end;
function TRQLPostgreSQLCompiler.RQLLogicOperatorToSQL(const aRQLFIlter: TRQLLogicOperator): string;

11
sources/MVCFramework.Router.pas
View File

@ -221,10 +221,15 @@ begin
LMethods := LRttiType.GetMethods; {do not use GetDeclaredMethods because JSON-RPC rely on this!!}
for LMethod in LMethods do
begin
if (LMethod.MethodKind <> mkProcedure) or LMethod.IsClassMethod then
if LMethod.Visibility <> mvPublic then //2020-08-08
Continue;
if (LMethod.MethodKind <> mkProcedure) {or LMethod.IsClassMethod} then
Continue;
LAttributes := LMethod.GetAttributes;
if Length(LAttributes) = 0 then
Continue;
for LAtt in LAttributes do
begin
if LAtt is MVCPathAttribute then
@ -240,7 +245,7 @@ begin
FControllerClazz := LControllerDelegate.Clazz;
FControllerCreateAction := LControllerDelegate.CreateAction;
LProduceAttribute := GetAttribute<MVCProducesAttribute>(LAttributes);
if Assigned(LProduceAttribute) then
if LProduceAttribute <> nil then
begin
AResponseContentMediaType := LProduceAttribute.Value;
AResponseContentCharset := LProduceAttribute.Charset;
@ -396,7 +401,7 @@ var
FoundOneAttProduces: Boolean;
begin
Result := False;
if AAccept = '*/*' then
if AAccept.Contains('*/*') then //2020-08-08
begin
Exit(True);
end;

1
sources/MVCFramework.SQLGenerators.Firebird.pas
View File

@ -91,6 +91,7 @@ var
lPKInInsert: Boolean;
begin
lPKInInsert := (not PKFieldName.IsEmpty) and (not(TMVCActiveRecordFieldOption.foAutoGenerated in PKOptions));
lPKInInsert := lPKInInsert and (not(TMVCActiveRecordFieldOption.foReadOnly in PKOptions));
lSB := TStringBuilder.Create;
try
lSB.Append('INSERT INTO ' + TableName + '(');

1
sources/MVCFramework.SQLGenerators.Interbase.pas
View File

@ -63,6 +63,7 @@ var
lPKInInsert: Boolean;
begin
lPKInInsert := (not PKFieldName.IsEmpty); // and (not(TMVCActiveRecordFieldOption.foAutoGenerated in PKOptions));
lPKInInsert := lPKInInsert and (not(TMVCActiveRecordFieldOption.foReadOnly in PKOptions));
lSB := TStringBuilder.Create;
try
lSB.Append('INSERT INTO ' + TableName + '(');

1
sources/MVCFramework.SQLGenerators.MSSQL.pas
View File

@ -88,6 +88,7 @@ var
lPKInInsert: Boolean;
begin
lPKInInsert := (not PKFieldName.IsEmpty) and (not(TMVCActiveRecordFieldOption.foAutoGenerated in PKOptions));
lPKInInsert := lPKInInsert and (not(TMVCActiveRecordFieldOption.foReadOnly in PKOptions));
lSB := TStringBuilder.Create;
try
lSB.Append('INSERT INTO ' + TableName + '(');

1
sources/MVCFramework.SQLGenerators.MySQL.pas
View File

@ -88,6 +88,7 @@ var
lPKInInsert: Boolean;
begin
lPKInInsert := (not PKFieldName.IsEmpty) and (not(TMVCActiveRecordFieldOption.foAutoGenerated in PKOptions));
lPKInInsert := lPKInInsert and (not(TMVCActiveRecordFieldOption.foReadOnly in PKOptions));
lSB := TStringBuilder.Create;
try
lSB.Append('INSERT INTO ' + TableName + '(');

6
sources/MVCFramework.SQLGenerators.PostgreSQL.pas
View File

@ -99,6 +99,7 @@ var
lPKInInsert: Boolean;
begin
lPKInInsert := (not PKFieldName.IsEmpty) and (not(TMVCActiveRecordFieldOption.foAutoGenerated in PKOptions));
lPKInInsert := lPKInInsert and (not(TMVCActiveRecordFieldOption.foReadOnly in PKOptions));
lSB := TStringBuilder.Create;
try
lSB.Append('INSERT INTO ' + GetTableNameForSQL(TableName) + ' (');
@ -146,6 +147,11 @@ function TMVCSQLGeneratorPostgreSQL.CreateSelectByPKSQL(
const Map: TFieldsMap; const PKFieldName: string;
const PKOptions: TMVCActiveRecordFieldOptions): string;
begin
if PKFieldName.IsEmpty then
begin
raise EMVCActiveRecord.Create('No primary key provided. [HINT] Define a primary key field adding foPrimaryKey in field options.');
end;
Result := CreateSelectSQL(TableName, Map, PKFieldName, PKOptions) + ' WHERE ' +
GetFieldNameForSQL(PKFieldName) + '= :' + GetParamNameForSQL(PKFieldName); // IntToStr(PrimaryKeyValue);
end;

1
sources/MVCFramework.SQLGenerators.Sqlite.pas
View File

@ -87,6 +87,7 @@ var
lPKInInsert: Boolean;
begin
lPKInInsert := (not PKFieldName.IsEmpty) and (not(TMVCActiveRecordFieldOption.foAutoGenerated in PKOptions));
lPKInInsert := lPKInInsert and (not(TMVCActiveRecordFieldOption.foReadOnly in PKOptions));
lSB := TStringBuilder.Create;
try
lSB.Append('INSERT INTO ' + TableName + ' (');

33
sources/MVCFramework.Serializer.Commons.pas
View File

@ -736,7 +736,7 @@ var
Attrs: TArray<TCustomAttribute>;
Attr: TCustomAttribute;
begin
{ TODO -oDanieleT -cGeneral : in un rendering di una lista, quante volte viene chiamata questa funzione?}
{ TODO -oDanieleT -cGeneral : in un rendering di una lista, quante volte viene chiamata questa funzione? }
{ Tante volte, ma eliminando tutta la logica si guadagnerebbe al massiom il 6% nel caso tipico, forse non vale la pena di aggiungere una cache apposita }
Result := AProperty.Name;
@ -1006,6 +1006,7 @@ var
lInternalStream: TStream;
lSStream: TStringStream;
lValue: TValue;
lStrValue: string;
{$IF not Defined(TokyoOrBetter)}
lFieldValue: string;
{$ENDIF}
@ -1023,7 +1024,35 @@ begin
case AField.DataType of
ftString, ftWideString:
begin
aRTTIField.SetValue(AObject, AField.AsString);
// mysql tinytext is identified as string, but raises an Invalid Class Cast
// so we need to do some more checks...
case aRTTIField.FieldType.TypeKind of
tkString, tkUString:
begin
aRTTIField.SetValue(AObject, AField.AsString);
end;
tkClass: { mysql - maps a tiny field, identified as string, into a TStream }
begin
lInternalStream := aRTTIField.GetValue(AObject).AsObject as TStream;
if lInternalStream = nil then
begin
raise EMVCException.CreateFmt('Property target for %s field is nil. [HINT] Initialize the stream before load data', [AField.FieldName]);
end;
lInternalStream.Size := 0;
lStrValue := AField.AsString;
if not lStrValue.IsEmpty then
begin
lInternalStream.Write(lStrValue, Length(lStrValue));
lInternalStream.Position := 0;
end;
end
else
begin
raise EMVCException.CreateFmt('Unsupported FieldType (%d) for field %s',
[Ord(AField.DataType), AField.FieldName]);
end;
end;
// aRTTIField.SetValue(AObject, AField.AsString);
end;
ftLargeint, ftAutoInc:
begin

3
sources/MVCFramework.Serializer.Intf.pas
View File

@ -118,7 +118,8 @@ type
const ASerializedObject: string;
const AObject: TObject;
const AType: TMVCSerializationType = stDefault;
const AIgnoredAttributes: TMVCIgnoredList = nil
const AIgnoredAttributes: TMVCIgnoredList = nil;
const ARootNode: String = ''
); overload;
procedure DeserializeObject(

37
sources/MVCFramework.Serializer.JsonDataObjects.pas
View File

@ -135,7 +135,8 @@ type
const SerializationAction: TMVCDatasetSerializationAction = nil): string;
procedure DeserializeObject(const ASerializedObject: string; const AObject: TObject;
const AType: TMVCSerializationType = stDefault; const AIgnoredAttributes: TMVCIgnoredList = []); overload;
const AType: TMVCSerializationType = stDefault; const AIgnoredAttributes: TMVCIgnoredList = [];
const ARootNode: string = ''); overload;
procedure DeserializeObject(const ASerializedObject: string; const AObject: IInterface;
const AType: TMVCSerializationType = stDefault; const AIgnoredAttributes: TMVCIgnoredList = []); overload;
@ -194,6 +195,18 @@ uses
MVCFramework.DataSet.Utils,
MVCFramework.Nullables;
function SelectRootNodeOrWholeObject(const RootNode: string; const JSONObject: TJsonObject): TJsonObject; inline;
begin
if RootNode.IsEmpty then
begin
Result := JSONObject
end
else
begin
Result := JSONObject.O[RootNode];
end;
end;
{ TMVCJsonDataObjectsSerializer }
procedure TMVCJsonDataObjectsSerializer.AfterConstruction;
@ -2013,7 +2026,7 @@ end;
procedure TMVCJsonDataObjectsSerializer.DeserializeObject(const ASerializedObject: string;
const AObject: TObject;
const AType: TMVCSerializationType; const AIgnoredAttributes: TMVCIgnoredList);
const AType: TMVCSerializationType; const AIgnoredAttributes: TMVCIgnoredList; const ARootNode: string);
var
JSONObject: TJDOJsonObject;
JsonBase: TJsonBaseObject;
@ -2041,11 +2054,12 @@ begin
try
if GetTypeSerializers.ContainsKey(AObject.ClassInfo) then
begin
GetTypeSerializers.Items[AObject.ClassInfo].DeserializeRoot(JSONObject, AObject, []);
GetTypeSerializers.Items[AObject.ClassInfo].DeserializeRoot(SelectRootNodeOrWholeObject(ARootNode, JSONObject),
AObject, [])
end
else
begin
JsonObjectToObject(JSONObject, AObject, GetSerializationType(AObject, AType), AIgnoredAttributes);
JsonObjectToObject(SelectRootNodeOrWholeObject(ARootNode, JSONObject), AObject, GetSerializationType(AObject, AType), AIgnoredAttributes);
end;
finally
JSONObject.Free;
@ -2097,9 +2111,9 @@ begin
{$IFDEF NEXTGEN}
lTypeName := PChar(Pointer(Value.TypeInfo.Name))
{$ELSE}
lTypeName := String(Value.TypeInfo.Name);
lTypeName := string(Value.TypeInfo.Name);
{$ENDIF}
if (lTypeName = 'TDate') or (lTypeName = 'TDateTime') or (lTypeName = 'TTime') then
if (lTypeName = 'TDate') or (lTypeName = 'TDateTime') or (lTypeName = 'TTime') then
begin
JSON.D[KeyName] := Value.AsExtended;
end
@ -2118,8 +2132,15 @@ begin
end;
tkEnumeration:
begin
Value.TryAsOrdinal(lOrdinalValue);
JSON.I[KeyName] := lOrdinalValue;
if (Value.TypeInfo = System.TypeInfo(Boolean)) then
begin
JSON.B[KeyName] := Value.AsBoolean;
end
else
begin
Value.TryAsOrdinal(lOrdinalValue);
JSON.I[KeyName] := lOrdinalValue;
end;
end;
tkClass, tkInterface:
begin

130
sources/MVCFramework.pas
View File

@ -88,7 +88,7 @@ uses
type
TSessionData = TDictionary<String, String>;
TSessionData = TDictionary<string, string>;
TMVCCustomData = TSessionData;
TMVCBaseViewEngine = class;
TMVCViewEngineClass = class of TMVCBaseViewEngine;
@ -348,11 +348,11 @@ type
function ContentParam(const AName: string): string;
function Cookie(const AName: string): string;
function Body: string;
function BodyAs<T: class, constructor>: T;
function BodyAs<T: class, constructor>(const RootNode: string = ''): T;
function BodyAsListOf<T: class, constructor>: TObjectList<T>;
procedure BodyFor<T: class, constructor>(const AObject: T);
procedure BodyForListOf<T: class, constructor>(const AObjectList: TObjectList<T>);
// function HeaderNames: TArray<String>;
// function HeaderNames: TArray<String>;
property RawWebRequest: TWebRequest read FWebRequest;
property ContentMediaType: string read FContentMediaType;
property ContentType: string read FContentType;
@ -606,7 +606,7 @@ type
FContentCharset: string;
FResponseStream: TStringBuilder;
function ToMVCList(const AObject: TObject; AOwnsObject: Boolean = False): IMVCList;
public
public { this must be public because of entity processors }
function GetContentType: string;
function GetStatusCode: Integer;
procedure SetContentType(const AValue: string);
@ -756,16 +756,17 @@ type
property StatusCode: Integer read GetStatusCode write SetStatusCode;
property ViewModelList: TMVCViewDataObject read GetViewModel;
property ViewDataSetList: TMVCViewDataSet read GetViewDataSets;
public
constructor Create; virtual;
destructor Destroy; override;
// procedure PushToView(const AModelName: string; const AModel: string);
procedure PushObjectToView(const aModelName: string; const AModel: TObject); deprecated 'Use "ViewData"';
procedure PushDataSetToView(const aModelName: string; const ADataSet: TDataSet); deprecated 'Use "ViewDataSet"';
property ViewData[const aModelName: string]: TObject read GetViewData write SetViewData;
property ViewDataset[const aDataSetName: string]: TDataSet read GetViewDataset write SetViewDataset;
public
constructor Create; virtual;
destructor Destroy; override;
end;
TMVCControllerClazz = class of TMVCController;
@ -854,7 +855,7 @@ type
FConfig: TMVCConfig;
FConfigCache_MaxRequestSize: Int64;
FConfigCache_ExposeServerSignature: Boolean;
FConfigCache_ServerSignature: String;
FConfigCache_ServerSignature: string;
FConfigCache_ExposeXPoweredBy: Boolean;
FSerializers: TDictionary<string, IMVCSerializer>;
FMiddlewares: TList<IMVCMiddleware>;
@ -1144,7 +1145,7 @@ begin
Result := FBody;
end;
function TMVCWebRequest.BodyAs<T>: T;
function TMVCWebRequest.BodyAs<T>(const RootNode: string): T;
var
Obj: TObject;
lSerializer: IMVCSerializer;
@ -1154,7 +1155,7 @@ begin
begin
Obj := TMVCSerializerHelper.CreateObject(TClass(T).QualifiedClassName);
try
lSerializer.DeserializeObject(Body, Obj);
lSerializer.DeserializeObject(Body, Obj, TMVCSerializationType.stDefault, nil, RootNode);
Result := Obj as T;
except
on E: Exception do
@ -1209,19 +1210,19 @@ begin
end;
end;
//function TMVCWebRequest.HeaderNames: TArray<String>;
//var
// lHeaderList: TIdHeaderList;
// I: Integer;
//begin
// EnsureINDY;
// lHeaderList := THackIdHTTPAppRequest(TMVCIndyWebRequest(Self).RawWebRequest).FRequestInfo.RawHeaders;
// SetLength(Result, lHeaderList.Count);
// for I := 0 to Pred(lHeaderList.Count) do
// begin
// Result[I] := lHeaderList.Names[I];
// end;
//end;
// function TMVCWebRequest.HeaderNames: TArray<String>;
// var
// lHeaderList: TIdHeaderList;
// I: Integer;
// begin
// EnsureINDY;
// lHeaderList := THackIdHTTPAppRequest(TMVCIndyWebRequest(Self).RawWebRequest).FRequestInfo.RawHeaders;
// SetLength(Result, lHeaderList.Count);
// for I := 0 to Pred(lHeaderList.Count) do
// begin
// Result[I] := lHeaderList.Names[I];
// end;
// end;
procedure TMVCWebRequest.BodyForListOf<T>(const AObjectList: TObjectList<T>);
var
@ -1335,7 +1336,7 @@ end;
procedure TMVCWebRequest.EnsureINDY;
begin
if not (Self is TMVCIndyWebRequest) then
if not(Self is TMVCIndyWebRequest) then
begin
raise EMVCException.Create(http_status.InternalServerError, 'Method available only in INDY implementation');
end;
@ -2111,7 +2112,8 @@ begin
if ARequest.ContentLength > FConfigCache_MaxRequestSize then
begin
raise EMVCException.CreateFmt(HTTP_STATUS.RequestEntityTooLarge, 'Request size exceeded the max allowed size [%d KiB] (1)',
raise EMVCException.CreateFmt(http_status.RequestEntityTooLarge,
'Request size exceeded the max allowed size [%d KiB] (1)',
[(FConfigCache_MaxRequestSize div 1024)]);
end;
@ -2121,7 +2123,8 @@ begin
// Double check for malicious content-length header
if ARequest.ContentLength > FConfigCache_MaxRequestSize then
begin
raise EMVCException.CreateFmt(HTTP_STATUS.RequestEntityTooLarge, 'Request size exceeded the max allowed size [%d KiB] (2)',
raise EMVCException.CreateFmt(http_status.RequestEntityTooLarge,
'Request size exceeded the max allowed size [%d KiB] (2)',
[(FConfigCache_MaxRequestSize div 1024)]);
end;
{$ENDIF}
@ -2155,7 +2158,7 @@ begin
begin
Log.ErrorFmt('[%s] %s (Custom message: "%s")',
[Ex.Classname, Ex.Message, 'Cannot create controller'], LOGGERPRO_TAG);
raise EMVCException.Create(HTTP_STATUS.InternalServerError, 'Cannot create controller');
raise EMVCException.Create(http_status.InternalServerError, 'Cannot create controller');
end;
end;
lSelectedController.Engine := Self;
@ -2208,14 +2211,14 @@ begin
begin
if Config[TMVCConfigKey.AllowUnhandledAction] = 'false' then
begin
lContext.Response.StatusCode := HTTP_STATUS.NotFound;
lContext.Response.StatusCode := http_status.NotFound;
lContext.Response.ReasonString := 'Not Found';
fOnRouterLog(lRouter, rlsRouteNotFound, lContext);
raise EMVCException.Create(
lContext.Response.ReasonString,
lContext.Request.HTTPMethodAsString + ' ' + lContext.Request.PathInfo,
0,
HTTP_STATUS.NotFound
http_status.NotFound
);
end
else
@ -2262,12 +2265,12 @@ begin
LOGGERPRO_TAG);
if Assigned(lSelectedController) then
begin
lSelectedController.ResponseStatus(HTTP_STATUS.InternalServerError);
lSelectedController.ResponseStatus(http_status.InternalServerError);
lSelectedController.Render(EIO);
end
else
begin
SendRawHTTPStatus(lContext, HTTP_STATUS.InternalServerError,
SendRawHTTPStatus(lContext, http_status.InternalServerError,
Format('[%s] %s', [EIO.Classname, EIO.Message]), EIO.Classname);
end;
end;
@ -2280,12 +2283,12 @@ begin
[Ex.Classname, Ex.Message, 'Global Action Exception Handler'], LOGGERPRO_TAG);
if Assigned(lSelectedController) then
begin
lSelectedController.ResponseStatus(HTTP_STATUS.InternalServerError);
lSelectedController.ResponseStatus(http_status.InternalServerError);
lSelectedController.Render(Ex);
end
else
begin
SendRawHTTPStatus(lContext, HTTP_STATUS.InternalServerError,
SendRawHTTPStatus(lContext, http_status.InternalServerError,
Format('[%s] %s', [Ex.Classname, Ex.Message]), Ex.Classname);
end;
end;
@ -2303,12 +2306,12 @@ begin
if Assigned(lSelectedController) then
begin
{ middlewares *must* not raise unhandled exceptions }
lSelectedController.ResponseStatus(HTTP_STATUS.InternalServerError);
lSelectedController.ResponseStatus(http_status.InternalServerError);
lSelectedController.Render(Ex);
end
else
begin
SendRawHTTPStatus(lContext, HTTP_STATUS.InternalServerError,
SendRawHTTPStatus(lContext, http_status.InternalServerError,
Format('[%s] %s', [Ex.Classname, Ex.Message]), Ex.Classname);
end;
end;
@ -2402,7 +2405,7 @@ var
lQualifiedName: string;
begin
if AContext.Request.SegmentParamsCount <> Length(AActionFormalParams) then
raise EMVCException.CreateFmt(HTTP_STATUS.BadRequest,
raise EMVCException.CreateFmt(http_status.BadRequest,
'Parameters count mismatch (expected %d actual %d) for action "%s"',
[Length(AActionFormalParams), AContext.Request.SegmentParamsCount, AActionName]);
@ -2413,7 +2416,7 @@ begin
if not AContext.Request.SegmentParam(lParamName, lStrValue) then
raise EMVCException.CreateFmt
(HTTP_STATUS.BadRequest, 'Invalid parameter %s for action %s (Hint: Here parameters names are case-sensitive)',
(http_status.BadRequest, 'Invalid parameter %s for action %s (Hint: Here parameters names are case-sensitive)',
[lParamName, AActionName]);
case AActionFormalParams[I].ParamType.TypeKind of
@ -2423,7 +2426,7 @@ begin
except
on E: Exception do
begin
raise EMVCException.CreateFmt(HTTP_STATUS.BadRequest,
raise EMVCException.CreateFmt(http_status.BadRequest,
'Invalid Integer value for param [%s] - [CLASS: %s][MSG: %s]',
[AActionFormalParams[I].name, E.Classname, E.Message]);
end;
@ -2434,7 +2437,7 @@ begin
except
on E: Exception do
begin
raise EMVCException.CreateFmt(HTTP_STATUS.BadRequest,
raise EMVCException.CreateFmt(http_status.BadRequest,
'Invalid Int64 value for param [%s] - [CLASS: %s][MSG: %s]',
[AActionFormalParams[I].name, E.Classname, E.Message]);
end;
@ -2455,7 +2458,7 @@ begin
except
on E: Exception do
begin
raise EMVCException.CreateFmt(HTTP_STATUS.BadRequest,
raise EMVCException.CreateFmt(http_status.BadRequest,
'Invalid TDate value for param [%s] - [CLASS: %s][MSG: %s]',
[AActionFormalParams[I].name, E.Classname, E.Message]);
end;
@ -2470,7 +2473,7 @@ begin
except
on E: Exception do
begin
raise EMVCException.CreateFmt(HTTP_STATUS.BadRequest,
raise EMVCException.CreateFmt(http_status.BadRequest,
'Invalid TDateTime value for param [%s] - [CLASS: %s][MSG: %s]',
[AActionFormalParams[I].name, E.Classname, E.Message]);
end;
@ -2485,7 +2488,7 @@ begin
except
on E: Exception do
begin
raise EMVCException.CreateFmt(HTTP_STATUS.BadRequest,
raise EMVCException.CreateFmt(http_status.BadRequest,
'Invalid TTime value for param [%s] - [CLASS: %s][MSG: %s]',
[AActionFormalParams[I].name, E.Classname, E.Message]);
end;
@ -2498,7 +2501,7 @@ begin
except
on E: Exception do
begin
raise EMVCException.CreateFmt(HTTP_STATUS.BadRequest,
raise EMVCException.CreateFmt(http_status.BadRequest,
'Invalid Float value for param [%s] - [CLASS: %s][MSG: %s]',
[AActionFormalParams[I].name, E.Classname, E.Message]);
end;
@ -2516,14 +2519,14 @@ begin
else
begin
raise EMVCException.CreateFmt
(HTTP_STATUS.BadRequest,
(http_status.BadRequest,
'Invalid boolean value for parameter %s. Boolean parameters accepts only "true"/"false" or "1"/"0".',
[lParamName]);
end;
end
else
begin
raise EMVCException.CreateFmt(HTTP_STATUS.BadRequest, 'Invalid type for parameter %s. Allowed types are ' +
raise EMVCException.CreateFmt(http_status.BadRequest, 'Invalid type for parameter %s. Allowed types are ' +
ALLOWED_TYPED_ACTION_PARAMETERS_TYPES, [lParamName]);
end;
end;
@ -2543,7 +2546,7 @@ begin
end
else
begin
raise EMVCException.CreateFmt(HTTP_STATUS.BadRequest, 'Invalid type for parameter %s. Allowed types are ' +
raise EMVCException.CreateFmt(http_status.BadRequest, 'Invalid type for parameter %s. Allowed types are ' +
ALLOWED_TYPED_ACTION_PARAMETERS_TYPES, [lParamName]);
end;
end;
@ -2610,7 +2613,7 @@ end;
procedure TMVCEngine.HTTP404(const AContext: TWebContext);
begin
AContext.Response.SetStatusCode(HTTP_STATUS.NotFound);
AContext.Response.SetStatusCode(http_status.NotFound);
AContext.Response.SetContentType(BuildContentType(TMVCMediaType.TEXT_PLAIN,
AContext.Config[TMVCConfigKey.DefaultContentCharset]));
AContext.Response.SetReasonString('Not Found');
@ -2619,7 +2622,7 @@ end;
procedure TMVCEngine.HTTP500(const AContext: TWebContext; const AReasonString: string);
begin
AContext.Response.SetStatusCode(HTTP_STATUS.InternalServerError);
AContext.Response.SetStatusCode(http_status.InternalServerError);
AContext.Response.SetContentType(BuildContentType(TMVCMediaType.TEXT_PLAIN,
AContext.Config[TMVCConfigKey.DefaultContentCharset]));
AContext.Response.SetReasonString('Internal server error');
@ -2680,7 +2683,7 @@ begin
if IsShuttingDown then
begin
AResponse.StatusCode := HTTP_STATUS.ServiceUnavailable;
AResponse.StatusCode := http_status.ServiceUnavailable;
AResponse.ContentType := TMVCMediaType.TEXT_PLAIN;
AResponse.Content := 'Server is shutting down';
AHandled := True;
@ -2695,10 +2698,10 @@ begin
begin
Log.ErrorFmt('[%s] %s', [E.Classname, E.Message], LOGGERPRO_TAG);
AResponse.StatusCode:= HTTP_STATUS.InternalServerError; // default is Internal Server Error
AResponse.StatusCode := http_status.InternalServerError; // default is Internal Server Error
if E is EMVCException then
begin
AResponse.StatusCode:= (E as EMVCException).HttpErrorCode;
AResponse.StatusCode := (E as EMVCException).HTTPErrorCode;
end;
AResponse.Content := E.Message;
@ -2741,7 +2744,7 @@ procedure TMVCEngine.ResponseErrorPage(const AException: Exception; const AReque
const AResponse: TWebResponse);
begin
AResponse.SetCustomHeader('x-mvc-error', AException.Classname + ': ' + AException.Message);
AResponse.StatusCode := HTTP_STATUS.OK;
AResponse.StatusCode := http_status.OK;
begin
AResponse.ContentType := TMVCMediaType.TEXT_PLAIN;
@ -2755,7 +2758,8 @@ class function TMVCEngine.SendSessionCookie(const AContext: TWebContext): string
var
SId: string;
begin
SId := StringReplace(StringReplace(StringReplace(GUIDToString(TGUID.NewGuid), '}', '', []), '{', '', []), '-', '',
SId := StringReplace(StringReplace(StringReplace('DT' + GUIDToString(TGUID.NewGuid), '}', '',
[]), '{', '', []), '-', '',
[rfReplaceAll]);
Result := SendSessionCookie(AContext, SId);
end;
@ -3132,7 +3136,7 @@ begin
begin
raise EMVCException.Create('Cannot send 202 without provide an HREF');
end;
ResponseStatus(HTTP_STATUS.Accepted, Reason);
ResponseStatus(http_status.Accepted, Reason);
Render(TMVCAcceptedResponse.Create(HREF, ID));
end;
@ -3142,10 +3146,10 @@ begin
begin
FContext.Response.CustomHeaders.AddPair('location', Location);
end;
ResponseStatus(HTTP_STATUS.Created, Reason);
{$IF CompilerVersion >= 34}
Render(''); //in 10.4 INDY requires something on the content
{$ENDIF}
ResponseStatus(http_status.Created, Reason);
{$IF CompilerVersion >= 34}
Render(''); // in 10.4 INDY requires something on the content
{$ENDIF}
end;
procedure TMVCRenderer.Render204NoContent(const Location, Reason: string);
@ -3154,7 +3158,7 @@ begin
begin
FContext.Response.CustomHeaders.AddPair('location', Location);
end;
ResponseStatus(HTTP_STATUS.NoContent, Reason);
ResponseStatus(http_status.NoContent, Reason);
end;
procedure TMVCRenderer.ResponseStatus(const AStatusCode: Integer; const AReasonString: string);
@ -3442,7 +3446,7 @@ begin
// setting up the correct SSE headers
SetContentType('text/event-stream');
GetContext.Response.SetCustomHeader('Cache-Control', 'no-cache');
GetContext.Response.StatusCode := HTTP_STATUS.OK;
GetContext.Response.StatusCode := http_status.OK;
// render the response using SSE compliant data format
@ -3509,8 +3513,8 @@ begin
if AException is EMVCException then
ResponseStatus(EMVCException(AException).HTTPErrorCode, AException.Message + ' [' + AException.Classname + ']');
if (GetContext.Response.StatusCode = HTTP_STATUS.OK) then
ResponseStatus(HTTP_STATUS.InternalServerError, AException.Message + ' [' + AException.Classname + ']');
if (GetContext.Response.StatusCode = http_status.OK) then
ResponseStatus(http_status.InternalServerError, AException.Message + ' [' + AException.Classname + ']');
if (not GetContext.Request.IsAjax) and (GetContext.Request.ClientPrefer(TMVCMediaType.TEXT_HTML)) then
begin

30
unittests/general/Several/DMVCFrameworkTests.dpr
View File

@ -5,25 +5,29 @@ program DMVCFrameworkTests;
{$APPTYPE CONSOLE}
{$ENDIF}{$ENDIF}{$STRONGLINKTYPES ON}
uses
System.SysUtils,
{$IFDEF GUI_TESTRUNNER}
{$IFDEF GUI_TESTRUNNER}
Vcl.Forms,
DUnitX.Loggers.GUI.Vcl,
{$ENDIF }
{$IFDEF CONSOLE_TESTRUNNER}
// Fmx.Forms,
// DUNitX.Loggers.GUIX,
{$ENDIF }
{$IFDEF CONSOLE_TESTRUNNER}
DUnitX.Loggers.Console,
{$ENDIF }
DUnitX.Loggers.Xml.NUnit,
{$ENDIF }
// DUnitX.Loggers.Xml.NUnit,
DUnitX.TestFramework,
FrameworkTestsU in 'FrameworkTestsU.pas',
LiveServerTestU in 'LiveServerTestU.pas',
BOs in 'BOs.pas',
TestServerControllerU in '..\TestServer\TestServerControllerU.pas',
RESTAdapterTestsU in 'RESTAdapterTestsU.pas',
MVCFramework.Tests.WebModule2 in '..\StandaloneServer\MVCFramework.Tests.WebModule2.pas' {TestWebModule2: TWebModule},
MVCFramework.Tests.WebModule2
in '..\StandaloneServer\MVCFramework.Tests.WebModule2.pas' {TestWebModule2: TWebModule} ,
MVCFramework.Tests.StandaloneServer in '..\StandaloneServer\MVCFramework.Tests.StandaloneServer.pas',
MVCFramework.Tests.WebModule1 in '..\RESTClient\MVCFramework.Tests.WebModule1.pas' {TestWebModule1: TWebModule},
MVCFramework.Tests.WebModule1 in '..\RESTClient\MVCFramework.Tests.WebModule1.pas' {TestWebModule1: TWebModule} ,
MVCFramework.Tests.RESTClient in '..\RESTClient\MVCFramework.Tests.RESTClient.pas',
MVCFramework.Tests.AppController in '..\RESTClient\MVCFramework.Tests.AppController.pas',
BusinessObjectsU in '..\..\..\samples\commons\BusinessObjectsU.pas',
@ -37,21 +41,24 @@ uses
JsonDataObjects in '..\..\..\sources\JsonDataObjects.pas',
Serializers.JsonDataObjectsTestU in 'Serializers.JsonDataObjectsTestU.pas',
MVCFramework.Tests.Serializer.Entities in '..\..\common\MVCFramework.Tests.Serializer.Entities.pas',
MVCFramework.Tests.Serializer.EntitiesModule in '..\..\common\MVCFramework.Tests.Serializer.EntitiesModule.pas' {EntitiesModule: TDataModule},
MVCFramework.Tests.Serializer.EntitiesModule
in '..\..\common\MVCFramework.Tests.Serializer.EntitiesModule.pas' {EntitiesModule: TDataModule} ,
MVCFramework.Tests.Serializer.Intf in '..\..\common\MVCFramework.Tests.Serializer.Intf.pas',
MVCFramework.Serializer.JsonDataObjects.OptionalCustomTypes in '..\..\..\sources\MVCFramework.Serializer.JsonDataObjects.OptionalCustomTypes.pas',
MVCFramework.Serializer.JsonDataObjects.OptionalCustomTypes
in '..\..\..\sources\MVCFramework.Serializer.JsonDataObjects.OptionalCustomTypes.pas',
ActiveRecordTestsU in 'ActiveRecordTestsU.pas',
TestConstsU in 'TestConstsU.pas';
{$R *.RES}
{$IFDEF CONSOLE_TESTRUNNER}
procedure MainConsole();
var
runner: ITestRunner;
results: IRunResults;
logger: ITestLogger;
// nunitLogger: ITestLogger;
// nunitLogger: ITestLogger;
begin
try
// Check command line options, will exit if invalid
@ -90,14 +97,17 @@ end;
{$ENDIF}
{$IFDEF GUI_TESTRUNNER}
procedure MainGUI;
begin
Application.Initialize;
Application.CreateForm(TGUIVCLTestRunner, GUIVCLTestRunner);
// Application.CreateForm(TGUIXTestRunner, GUIXTestRunner);
Application.Run;
end;
{$ENDIF}
begin
ReportMemoryLeaksOnShutdown := True;
{$IFDEF CONSOLE_TESTRUNNER}

2
unittests/general/Several/DMVCFrameworkTests.dproj
View File

@ -4,7 +4,7 @@
<ProjectVersion>19.0</ProjectVersion>
<FrameworkType>VCL</FrameworkType>
<Base>True</Base>
<Config Condition="'$(Config)'==''">GUI</Config>
<Config Condition="'$(Config)'==''">CONSOLE</Config>
<Platform Condition="'$(Platform)'==''">Win32</Platform>
<TargetedPlatforms>1</TargetedPlatforms>
<AppType>Console</AppType>

159
unittests/general/Several/LiveServerTestU.pas
View File

@ -33,7 +33,6 @@ uses
System.DateUtils,
System.Hash;
type
TBaseServerTest = class(TObject)
@ -224,12 +223,17 @@ type
protected
FExecutor: IMVCJSONRPCExecutor;
FExecutor2: IMVCJSONRPCExecutor;
FExecutor3: IMVCJSONRPCExecutor;
public
[Setup]
procedure Setup;
[Test]
procedure TestRequestWithoutParams;
[Test]
procedure TestNotificationWithoutParams;
[Test]
procedure TestNotificationWhichRaisesError;
[Test]
procedure TestRequestToNotFoundMethod;
[Test]
procedure TestRequestWithParams_I_I_ret_I;
@ -249,6 +253,26 @@ type
procedure TestRequestWithParams_I_I_ret_A;
[Test]
procedure TestRequestWithParams_DT_T_ret_DT;
// hooks tests
[Test]
procedure TestHooks;
[Test]
procedure TestHooksWhenMethodRaisesError;
[Test]
procedure TestHooksWhenOnAfterCallHookRaisesError;
[Test]
procedure TestHooksNotif;
[Test]
procedure TestHooksNotifWhenOnBeforeRoutingHookRaisesError;
[Test]
procedure TestHooksNotifWhenOnBeforeCallHookRaisesError;
[Test]
procedure TestHooksNotifWhenOnAfterCallHookRaisesError;
[Test]
procedure TestHooksWhenOnBeforeCallHookRaisesError;
[Test]
procedure TestHooksWhenOnBeforeRoutingHookRaisesError;
end;
implementation
@ -278,7 +302,7 @@ uses
{$ENDIF}
, TestConstsU;
function GetServer: String;
function GetServer: string;
begin
Result := 'http://' + TEST_SERVER_ADDRESS + ':9999';
end;
@ -1876,6 +1900,123 @@ procedure TJSONRPCServerTest.Setup;
begin
FExecutor := TMVCJSONRPCExecutor.Create('http://' + TEST_SERVER_ADDRESS + ':9999/jsonrpc', false);
FExecutor2 := TMVCJSONRPCExecutor.Create('http://' + TEST_SERVER_ADDRESS + ':9999/jsonrpcclass', false);
FExecutor3 := TMVCJSONRPCExecutor.Create('http://' + TEST_SERVER_ADDRESS + ':9999/jsonrpcclass1', false);
end;
procedure TJSONRPCServerTest.TestHooks;
begin
var lRequest1: IJSONRPCRequest := TJSONRPCRequest.Create(1234, 'request1');
var lResp := FExecutor3.ExecuteRequest(lRequest1);
Assert.areEqual('OnBeforeRoutingHook|OnBeforeCallHook|OnAfterCallHook',
FExecutor3.HTTPResponse.HeaderValue['x-history']);
end;
procedure TJSONRPCServerTest.TestHooksNotif;
begin
var lNotif: IJSONRPCNotification := TJSONRPCNotification.Create('Notif1');
var lResp := FExecutor3.ExecuteNotification(lNotif);
Assert.areEqual('OnBeforeRoutingHook|OnBeforeCallHook|OnAfterCallHook', FExecutor3.HTTPResponse.HeaderValue['x-history']);
Assert.IsFalse(lResp.IsError);
Assert.WillRaise(
procedure
begin
lResp.AsJSONString;
end, EMVCJSONRPCException);
end;
procedure TJSONRPCServerTest.TestHooksNotifWhenOnAfterCallHookRaisesError;
begin
var lNotif: IJSONRPCNotification := TJSONRPCNotification.Create('error_OnAfterCallHook');
var lResp: IJSONRPCResponse := FExecutor3.ExecuteNotification(lNotif);
Assert.areEqual('', FExecutor3.HTTPResponse.HeaderValue['x-history']);
Assert.isTrue(lResp.IsError);
Assert.WillNotRaise(
procedure
begin
lResp.AsJSONString;
end, EMVCJSONRPCException);
end;
procedure TJSONRPCServerTest.TestHooksNotifWhenOnBeforeCallHookRaisesError;
begin
var lNotif: IJSONRPCNotification := TJSONRPCNotification.Create('error_OnBeforeCallHook');
var lResp: IJSONRPCResponse := FExecutor3.ExecuteNotification(lNotif);
Assert.areEqual('', FExecutor3.HTTPResponse.HeaderValue['x-history']);
Assert.isTrue(lResp.IsError);
Assert.WillNotRaise(
procedure
begin
lResp.AsJSONString;
end, EMVCJSONRPCException);
end;
procedure TJSONRPCServerTest.TestHooksNotifWhenOnBeforeRoutingHookRaisesError;
begin
var lNotif: IJSONRPCNotification := TJSONRPCNotification.Create('error_OnBeforeRoutingHook');
var lResp: IJSONRPCResponse := FExecutor3.ExecuteNotification(lNotif);
Assert.areEqual('', FExecutor3.HTTPResponse.HeaderValue['x-history']);
Assert.isTrue(lResp.IsError);
Assert.WillNotRaise(
procedure
begin
lResp.AsJSONString;
end, EMVCJSONRPCException);
end;
procedure TJSONRPCServerTest.TestHooksWhenMethodRaisesError;
begin
var lRequest1: IJSONRPCRequest := TJSONRPCRequest.Create(1234, 'RequestWithError');
var lResp := FExecutor3.ExecuteRequest(lRequest1);
Assert.areEqual('OnBeforeRoutingHook|OnBeforeCallHook|OnAfterCallHook|error',
FExecutor3.HTTPResponse.HeaderValue['x-history']);
Assert.isTrue(lResp.IsError, 'Method raised error but response is not an error');
end;
procedure TJSONRPCServerTest.TestHooksWhenOnAfterCallHookRaisesError;
begin
var lRequest1: IJSONRPCRequest := TJSONRPCRequest.Create(1234, 'error_OnAfterCallHook');
var lResp := FExecutor3.ExecuteRequest(lRequest1);
Assert.isTrue(lResp.IsError, lResp.ToString(true));
Assert.areEqual(lResp.Error.ErrMessage, 'error_OnAfterCallHook');
end;
procedure TJSONRPCServerTest.TestHooksWhenOnBeforeCallHookRaisesError;
begin
var lRequest1: IJSONRPCRequest := TJSONRPCRequest.Create(1234, 'error_OnBeforeCallHook');
var lResp := FExecutor3.ExecuteRequest(lRequest1);
Assert.isTrue(lResp.IsError, lResp.ToString(true));
Assert.areEqual(lResp.Error.ErrMessage, 'error_OnBeforeCallHook');
end;
procedure TJSONRPCServerTest.TestHooksWhenOnBeforeRoutingHookRaisesError;
begin
var lRequest1: IJSONRPCRequest := TJSONRPCRequest.Create(1234, 'error_OnBeforeRoutingHook');
var lResp := FExecutor3.ExecuteRequest(lRequest1);
Assert.isTrue(lResp.IsError, lResp.ToString(true));
Assert.areEqual(lResp.Error.ErrMessage, 'error_OnBeforeRoutingHook');
end;
procedure TJSONRPCServerTest.TestNotificationWhichRaisesError;
var
lReq: IJSONRPCNotification;
begin
lReq := TJSONRPCNotification.Create;
lReq.Method := 'NotifWithError';
var lResp := FExecutor3.ExecuteNotification(lReq);
Assert.IsTrue(lResp.IsError);
Assert.Contains(lResp.Error.ErrMessage, 'BOOM NOTIF');
end;
procedure TJSONRPCServerTest.TestNotificationWithoutParams;
var
lReq: IJSONRPCNotification;
begin
lReq := TJSONRPCNotification.Create;
lReq.Method := 'mynotify';
FExecutor.ExecuteNotification(lReq);
FExecutor2.ExecuteNotification(lReq);
Assert.Pass();
end;
procedure TJSONRPCServerTest.TestRequestToNotFoundMethod;
@ -1978,13 +2119,15 @@ end;
procedure TJSONRPCServerTest.TestRequestWithoutParams;
var
lReq: IJSONRPCNotification;
lReq: IJSONRPCRequest;
lResp: IJSONRPCResponse;
begin
lReq := TJSONRPCNotification.Create;
lReq.Method := 'mynotify';
FExecutor.ExecuteNotification(lReq);
FExecutor2.ExecuteNotification(lReq);
Assert.Pass();
lReq := TJSONRPCRequest.Create;
lReq.Method := 'MyRequest';
lReq.RequestID := 1234;
lResp := FExecutor.ExecuteRequest(lReq);
Assert.isFalse(lResp.IsError);
Assert.isTrue(lResp.Result.AsBoolean);
end;
procedure TJSONRPCServerTest.TestRequestWithParams_I_I_ret_I;

121
unittests/general/TestServer/TestServerControllerJSONRPCU.pas
View File

@ -10,6 +10,7 @@ type
public
function Subtract(Value1, Value2: Int64): Integer;
procedure MyNotify;
function MyRequest: Boolean;
function Add(Value1, Value2, Value3: Int64): TJsonObject;
function GetListFromTo(aFrom, aTo: Int64): TJsonArray;
function MultiplyString(aString: string; Multiplier: Int64): string;
@ -25,6 +26,25 @@ type
function AddTimeToDateTime(aDateTime: TDateTime; aTime: TTime): TDateTime;
end;
TTestJSONRPCHookClass = class(TObject)
private
fJSONReq: TJsonObject;
fHistory: string;
fJSONRPCKind: TJSONRPCRequestType;
public
procedure OnBeforeRoutingHook(const Context: TWebContext; const JSON: TJsonObject);
procedure OnBeforeCallHook(const Context: TWebContext; const JSON: TJsonObject);
procedure OnAfterCallHook(const Context: TWebContext; const JSON: TJsonObject);
function error_OnBeforeRoutingHook: Boolean;
function error_OnBeforeCallHook: Boolean;
function error_OnAfterCallHook: Boolean;
procedure Notif1;
procedure NotifWithError;
function Request1: string;
function RequestWithError: string;
end;
implementation
uses
@ -65,6 +85,11 @@ begin
Self.ClassName;
end;
function TTestJSONRPCController.MyRequest: Boolean;
begin
Result := True;
end;
function TTestJSONRPCController.Subtract(Value1, Value2: Int64): Integer;
begin
Result := Value1 - Value2;
@ -116,4 +141,100 @@ begin
Result := Value1 - Value2;
end;
{ TTestJSONRPCHookClass }
function TTestJSONRPCHookClass.error_OnAfterCallHook: Boolean;
begin
// do nothing
Result := True;
end;
function TTestJSONRPCHookClass.error_OnBeforeCallHook: Boolean;
begin
// do nothing
Result := True;
end;
function TTestJSONRPCHookClass.error_OnBeforeRoutingHook: Boolean;
begin
// do nothing
Result := True;
end;
procedure TTestJSONRPCHookClass.Notif1;
begin
// do nothing
end;
procedure TTestJSONRPCHookClass.NotifWithError;
begin
raise Exception.Create('BOOM NOTIF');
end;
procedure TTestJSONRPCHookClass.OnAfterCallHook(const Context: TWebContext; const JSON: TJsonObject);
begin
try
if SameText(fJSONReq.S['method'], 'error_OnAfterCallHook') then
raise Exception.Create('error_OnAfterCallHook');
fHistory := fHistory + '|OnAfterCallHook';
// do nothing
if fJSONRPCKind = TJSONRPCRequestType.Request then
begin
Assert(Assigned(JSON));
LogD('TTestJSONRPCHookClass.OnAfterCallHook: ' + JSON.ToJSON());
end
else
begin
if Assigned(JSON) then
Assert(JSON.Contains('error'), 'ERROR! Notification has a response but is not an error');
LogD('TTestJSONRPCHookClass.OnAfterCallHook: Param is nil');
end;
if Assigned(JSON) then
if JSON.Contains('error') then
fHistory := fHistory + '|error';
Context.Response.CustomHeaders.Values['x-history'] := fHistory;
finally
FreeAndNil(fJSONReq);
end;
end;
procedure TTestJSONRPCHookClass.OnBeforeCallHook(const Context: TWebContext; const JSON: TJsonObject);
begin
if SameText(JSON.S['method'], 'error_OnBeforeCallHook') then
raise Exception.Create('error_OnBeforeCallHook');
fHistory := fHistory + '|OnBeforeCallHook';
Assert(Assigned(JSON), 'JSON not assigned in OnBeforeCallHook');
LogD('TTestJSONRPCHookClass.OnBeforeCallHook: ' + JSON.ToJSON());
end;
procedure TTestJSONRPCHookClass.OnBeforeRoutingHook(const Context: TWebContext; const JSON: TJsonObject);
begin
fJSONReq := JSON.Clone;
if SameText(JSON.S['method'], 'error_OnBeforeRoutingHook') then
raise Exception.Create('error_OnBeforeRoutingHook');
fHistory := 'OnBeforeRoutingHook';
// do nothing
Assert(Assigned(JSON), 'JSON not assigned in OnBeforeRoutingHook');
LogD('TTestJSONRPCHookClass.OnBeforeRoutingHook: ' + JSON.ToJSON());
if JSON.Contains('id') then
fJSONRPCKind := TJSONRPCRequestType.Request
else
fJSONRPCKind := TJSONRPCRequestType.Notification;
end;
function TTestJSONRPCHookClass.Request1: string;
begin
Result := 'empty';
end;
function TTestJSONRPCHookClass.RequestWithError: string;
begin
raise Exception.Create('BOOM REQUEST');
end;
end.

5
unittests/general/TestServer/WebModuleUnit.pas
View File

@ -92,6 +92,11 @@ begin
begin
Result := TTestJSONRPCClass.Create
end, '/jsonrpcclass')
.PublishObject(
function: TObject
begin
Result := TTestJSONRPCHookClass.Create
end, '/jsonrpcclass1')
.AddController(TTestFaultController) // this will raise an exception
.AddController(TTestFault2Controller,
function: TMVCController