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

Improved JSON-RPC Hooks

Browse Source
This commit is contained in:
Daniele Teti 2020-08-06 17:40:56 +02:00
parent b1c56b6a2c
commit c05cbfffb7
14 changed files with 381 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
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,29 @@ 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).
## 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

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;

4
samples/jsonrpc_with_published_objects/MainClientFormU.dfm
View File

@ -377,10 +377,6 @@ object MainForm: TMainForm
object TabSheet2: TTabSheet
Caption = 'Invoking DataModule Methods'
ImageIndex = 1
ExplicitLeft = 0
ExplicitTop = 0
ExplicitWidth = 0
ExplicitHeight = 0
object GroupBox5: TGroupBox
Left = 11
Top = 18

13
samples/jsonrpc_with_published_objects/MainClientFormU.pas
View File

@ -234,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;
@ -424,6 +424,7 @@ begin
FExecutor.ClearHTTPHeaders;
Assert(FExecutor.HTTPHeadersCount = 0);
FExecutor.AddHTTPHeader(TNetHeader.Create('x-token', TGUID.NewGuid.ToString));
PageControl1.ActivePageIndex := 0;
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;

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

@ -38,7 +38,7 @@ 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);
@ -69,7 +69,7 @@ type
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;
@ -164,10 +164,19 @@ begin
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;
@ -217,22 +226,28 @@ begin
begin
fOnSendCommand(aJSONRPCObject);
end;
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;

139
sources/MVCFramework.JSONRPC.pas
View File

@ -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;
@ -1850,26 +1873,31 @@ 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');
end
else
begin
raise EMVCJSONRPCException.Create('ID cannot be empty in a JSON-RPC request');
begin
raise EMVCJSONRPCException.Create('ID cannot be empty in a JSON-RPC request');
end;
except
Result.Free;
raise;
end;
end;
@ -2087,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

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

@ -2097,9 +2097,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 +2118,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

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>

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

@ -230,6 +230,10 @@ type
[Test]
procedure TestRequestWithoutParams;
[Test]
procedure TestNotificationWithoutParams;
[Test]
procedure TestNotificationWhichRaisesError;
[Test]
procedure TestRequestToNotFoundMethod;
[Test]
procedure TestRequestWithParams_I_I_ret_I;
@ -255,11 +259,19 @@ type
[Test]
procedure TestHooksWhenMethodRaisesError;
[Test]
procedure TestHooksWhenOnBeforeRoutingHookRaisesError;
procedure TestHooksWhenOnAfterCallHookRaisesError;
[Test]
procedure TestHooksNotif;
[Test]
procedure TestHooksNotifWhenOnBeforeRoutingHookRaisesError;
[Test]
procedure TestHooksNotifWhenOnBeforeCallHookRaisesError;
[Test]
procedure TestHooksNotifWhenOnAfterCallHookRaisesError;
[Test]
procedure TestHooksWhenOnBeforeCallHookRaisesError;
[Test]
procedure TestHooksWhenOnAfterCallHookRaisesError;
procedure TestHooksWhenOnBeforeRoutingHookRaisesError;
end;
@ -1894,17 +1906,67 @@ end;
procedure TJSONRPCServerTest.TestHooks;
begin
var lRequest1: IJSONRPCRequest := TJSONRPCRequest.Create(1234, 'request1');
var
lResp := FExecutor3.ExecuteRequest(lRequest1);
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);
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');
@ -1916,7 +1978,6 @@ begin
var lResp := FExecutor3.ExecuteRequest(lRequest1);
Assert.isTrue(lResp.IsError, lResp.ToString(true));
Assert.areEqual(lResp.Error.ErrMessage, 'error_OnAfterCallHook');
end;
procedure TJSONRPCServerTest.TestHooksWhenOnBeforeCallHookRaisesError;
@ -1936,6 +1997,28 @@ begin
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;
var
lReq: IJSONRPCRequest;
@ -2036,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;

12
unittests/general/TestServer/TestServer.dproj
View File

@ -146,12 +146,6 @@
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile LocalName="TestServer" Configuration="CI" Class="ProjectOutput">
<Platform Name="Linux64">
<RemoteName>TestServer</RemoteName>
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile LocalName="bin\www\index.html" Configuration="CI" Class="File">
<Platform Name="Linux64">
<RemoteDir>.\www</RemoteDir>
@ -159,6 +153,12 @@
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile LocalName="TestServer" Configuration="CI" Class="ProjectOutput">
<Platform Name="Linux64">
<RemoteName>TestServer</RemoteName>
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile LocalName="bin\customers.json" Configuration="CI" Class="File">
<Platform Name="Linux64">
<RemoteName>customers.json</RemoteName>

26
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;
@ -39,6 +40,7 @@ type
function error_OnAfterCallHook: Boolean;
procedure Notif1;
procedure NotifWithError;
function Request1: string;
function RequestWithError: string;
end;
@ -83,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;
@ -139,16 +146,19 @@ end;
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;
@ -156,6 +166,11 @@ 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
@ -164,9 +179,6 @@ begin
fHistory := fHistory + '|OnAfterCallHook';
if JSON.Contains('error') then
fHistory := fHistory + '|error';
// do nothing
if fJSONRPCKind = TJSONRPCRequestType.Request then
begin
@ -175,9 +187,13 @@ begin
end
else
begin
Assert(not Assigned(JSON));
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);
@ -218,7 +234,7 @@ end;
function TTestJSONRPCHookClass.RequestWithError: string;
begin
raise Exception.Create('BOOM');
raise Exception.Create('BOOM REQUEST');
end;
end.