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

Merge branch 'feature_injector'

Browse Source
This commit is contained in:
Daniele Teti 2024-04-04 14:30:08 +02:00
commit 5dfb0b9a50
40 changed files with 3470 additions and 383 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
ideexpert/DMVC.Expert.CodeGen.Templates.pas
View File

@ -120,13 +120,16 @@ resourcestring
' end);' + sLineBreak +
'' + sLineBreak +
' WebRequestHandlerProc.MaxConnections := dotEnv.Env(''dmvc.handler.max_connections'', 1024);' + sLineBreak +
'' + sLineBreak +
' if dotEnv.Env(''dmvc.profiler.enabled'', false) then' + sLineBreak +
' begin' + sLineBreak +
' Profiler.ProfileLogger := Log;' + sLineBreak +
' Profiler.WarningThreshold := dotEnv.Env(''dmvc.profiler.warning_threshold'', 2000);' + sLineBreak +
' end;' + sLineBreak +
'' + sLineBreak +
'' + sLineBreak +
'' + sLineBreak +
'{$IF CompilerVersion >= 34}' + sLineBreak +
' if dotEnv.Env(''dmvc.profiler.enabled'', false) then' + sLineBreak +
' begin' + sLineBreak +
' Profiler.ProfileLogger := Log;' + sLineBreak +
' Profiler.WarningThreshold := dotEnv.Env(''dmvc.profiler.warning_threshold'', 2000);' + sLineBreak +
' end;' + sLineBreak +
'{$ENDIF}' + sLineBreak +
'' + sLineBreak +
' RunServer(dotEnv.Env(''dmvc.server.port'', %1:d));' + sLineBreak +
' except' + sLineBreak +
' on E: Exception do' + sLineBreak +

3
packages/d120/dmvcframeworkRT.dpk
View File

@ -116,7 +116,8 @@ contains
MVCFramework.DotEnv in '..\..\sources\MVCFramework.DotEnv.pas',
MVCFramework.Serializer.URLEncoded in '..\..\sources\MVCFramework.Serializer.URLEncoded.pas',
MVCFramework.Signal in '..\..\sources\MVCFramework.Signal.pas',
MVCFramework.Serializer.Text in '..\..\sources\MVCFramework.Serializer.Text.pas';
MVCFramework.Serializer.Text in '..\..\sources\MVCFramework.Serializer.Text.pas',
MVCFramework.Container in '..\..\sources\MVCFramework.Container.pas';
end.

1
packages/d120/dmvcframeworkRT.dproj
View File

@ -208,6 +208,7 @@
<DCCReference Include="..\..\sources\MVCFramework.Serializer.URLEncoded.pas"/>
<DCCReference Include="..\..\sources\MVCFramework.Signal.pas"/>
<DCCReference Include="..\..\sources\MVCFramework.Serializer.Text.pas"/>
<DCCReference Include="..\..\sources\MVCFramework.Container.pas"/>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>

9
samples/activerecord_showcase/MainFormU.dfm
View File

@ -319,6 +319,15 @@ object MainForm: TMainForm
TabOrder = 31
OnClick = btnCRUDWithOptionsClick
end
object btnTransaction: TButton
Left = 144
Top = 602
Width = 121
Height = 35
Caption = 'TransactionContext'
TabOrder = 32
OnClick = btnTransactionClick
end
object FDConnection1: TFDConnection
Left = 312
Top = 40

67
samples/activerecord_showcase/MainFormU.pas
View File

@ -27,6 +27,8 @@ uses
FireDAC.Comp.Client,
MVCFramework.Nullables,
MVCFramework.ActiveRecord,
MVCFramework.Logger,
System.Generics.Collections, System.Diagnostics;
type
@ -64,6 +66,7 @@ type
btnObjectVersion: TButton;
btnCustomTable: TButton;
btnCRUDWithOptions: TButton;
btnTransaction: TButton;
procedure btnCRUDClick(Sender: TObject);
procedure btnInheritanceClick(Sender: TObject);
procedure btnMultiThreadingClick(Sender: TObject);
@ -98,9 +101,11 @@ type
procedure btnObjectVersionClick(Sender: TObject);
procedure btnCustomTableClick(Sender: TObject);
procedure btnCRUDWithOptionsClick(Sender: TObject);
procedure btnTransactionClick(Sender: TObject);
private
procedure Log(const Value: string);
procedure LoadCustomers(const HowManyCustomers: Integer = 50);
procedure ExecutedInTransaction;
public
{ Public declarations }
end;
@ -1896,6 +1901,54 @@ begin
end;
end;
procedure TMainForm.btnTransactionClick(Sender: TObject);
begin
Log('# TransactionContext');
// Test 1
// try
// begin var Ctx := TMVCActiveRecord.UseTransactionContext;
// TMVCActiveRecord.GetByPK<TCustomer>(-1); // will raise EMVCActiveRecordNotFound
// end;
// except
// on E: Exception do
// begin
// Log(Format('#1 - TransactionContext caught %s (automatic rollback)', [E.ClassName]));
// end;
// end;
// Test 2
// try
// begin var Ctx := TMVCActiveRecord.UseTransactionContext;
// var S := Ctx; // will raise EMVCActiveRecordTransactionContext
// end;
// except
// on E: Exception do
// begin
// Log(Format('#2 - TransactionContext caught %s (automatic rollback)', [E.ClassName]));
// end;
// end;
// Test 3
// begin var Ctx := TMVCActiveRecord.UseTransactionContext;
// var lCustomer := TCustomer.Create;
// try
// lCustomer.CompanyName := 'Transaction Inc.';
// lCustomer.LastContact := Now();
// lCustomer.Insert;
// finally
// lCustomer.Free;
// end;
// Log('#3 - TransactionContext automatically committed changes (because no exceptions have been raised within the TransactionContext)');
// end;
// Test 4
ExecutedInTransaction;
end;
procedure TMainForm.btnReadOnlyFieldsClick(Sender: TObject);
var
lCustomer: TCustomerWithReadOnlyFields;
@ -2126,6 +2179,20 @@ begin
end;
end;
procedure TMainForm.ExecutedInTransaction;
begin
var tx := TMVCActiveRecord.UseTransactionContext;
var lCustomer := TCustomer.Create;
try
lCustomer.CompanyName := 'Transaction Inc.';
lCustomer.LastContact := Now();
lCustomer.Insert;
finally
lCustomer.Free;
end;
Log('#4 - TransactionContext automatically committed changes (because no exceptions have been raised within the TransactionContext)');
end;
procedure TMainForm.btnObjectVersionClick(Sender: TObject);
begin
var lID: NullableInt64;

57
samples/articles_crud_server/BusinessObjects.pas
View File

@ -3,46 +3,51 @@ unit BusinessObjects;
interface
uses
MVCFramework.Serializer.Commons, MVCFramework.Nullables;
MVCFramework.Serializer.Commons, MVCFramework.Nullables,
MVCFramework.ActiveRecord;
type
TBaseBO = class
TBaseBO = class(TMVCActiveRecord)
private
[MVCTableField('ID', [foPrimaryKey])]
FID: Integer;
procedure SetID(const Value: Integer);
public
procedure CheckInsert; virtual;
procedure CheckUpdate; virtual;
procedure CheckDelete; virtual;
property ID: Integer read FID write SetID;
end;
[MVCNameCase(ncLowerCase)]
[MVCTable('ARTICOLI')]
[MVCNamedSQLQuery(
'search_by_text',
'SELECT * FROM ARTICOLI WHERE DESCRIZIONE CONTAINING ? ORDER BY ID')
]
TArticle = class(TBaseBO)
private
FPrice: Currency;
[MVCTableField('CODICE')]
FCode: string;
[MVCTableField('DESCRIZIONE')]
FDescription: String;
[MVCTableField('PREZZO')]
FPrice: Currency;
[MVCTableField('UPDATED_AT')]
FUpdatedAt: TDateTime;
[MVCTableField('CREATED_AT')]
FCreatedAt: TDateTime;
procedure SetCode(const Value: string);
procedure SetDescription(const Value: String);
procedure SetPrice(const Value: Currency);
procedure SetCreatedAt(const Value: TDateTime);
procedure SetUpdatedAt(const Value: TDateTime);
protected
procedure OnBeforeInsertOrUpdate; override;
procedure OnBeforeUpdate; override;
procedure OnBeforeDelete; override;
public
procedure CheckInsert; override;
procedure CheckUpdate; override;
procedure CheckDelete; override;
[MVCColumn('CODICE')]
property Code: string read FCode write SetCode;
[MVCColumn('DESCRIZIONE')]
property Description: String read FDescription write SetDescription;
[MVCColumn('PREZZO')]
property Price: Currency read FPrice write SetPrice;
[MVCColumn('CREATED_AT')]
property CreatedAt: TDateTime read FCreatedAt write SetCreatedAt;
[MVCColumn('UPDATED_AT')]
property UpdatedAt: TDateTime read FUpdatedAt write SetUpdatedAt;
end;
@ -53,46 +58,28 @@ uses
{ TBaseBO }
procedure TBaseBO.CheckDelete;
begin
end;
procedure TBaseBO.CheckInsert;
begin
end;
procedure TBaseBO.CheckUpdate;
begin
end;
procedure TBaseBO.SetID(const Value: Integer);
begin
FID := Value;
end;
{ TArticolo }
procedure TArticle.CheckDelete;
procedure TArticle.OnBeforeDelete;
begin
inherited;
if Price <= 5 then
raise Exception.Create('Cannot delete an article with a price below 5 euros (yes, it is a silly check)');
end;
procedure TArticle.CheckInsert;
procedure TArticle.OnBeforeInsertOrUpdate;
begin
inherited;
if not TRegEx.IsMatch(Code, '^C[0-9]{2,4}') then
raise Exception.Create('Article code must be in the format "CXX or CXXX or CXXXX"');
end;
procedure TArticle.CheckUpdate;
procedure TArticle.OnBeforeUpdate;
begin
inherited;
CheckInsert;
if Price <= 2 then
raise Exception.Create('We cannot sell so low cost pizzas!');
end;

3
samples/articles_crud_server/Commons.pas
View File

@ -10,6 +10,9 @@ type
end;
const
CON_DEF_NAME = 'MyConnX';
implementation
end.

149
samples/articles_crud_server/Controllers.Articles.pas
View File

@ -3,37 +3,42 @@ unit Controllers.Articles;
interface
uses
mvcframework,
mvcframework.Commons,
mvcframework.Serializer.Commons,
MVCFramework,
MVCFramework.Commons,
System.Generics.Collections,
Controllers.Base, BusinessObjects;
Controllers.Base,
BusinessObjects,
Services;
type
[MVCDoc('Resource that manages articles CRUD')]
[MVCPath('/articles')]
TArticlesController = class(TBaseController)
private
fArticlesService: IArticlesService;
public
[MVCInject]
constructor Create(ArticlesService: IArticlesService); reintroduce;
[MVCDoc('Returns the list of articles')]
[MVCPath]
[MVCHTTPMethod([httpGET])]
procedure GetArticles;
function GetArticles: IMVCResponse;
[MVCDoc('Returns the list of articles')]
[MVCPath('/searches')]
[MVCHTTPMethod([httpGET])]
procedure GetArticlesByDescription(const [MVCFromQueryString('q', '')] Search: String);
function GetArticlesByDescription(const [MVCFromQueryString('q', '')] Search: String): IMVCResponse;
[MVCDoc('Returns the article with the specified id')]
[MVCPath('/meta')]
[MVCHTTPMethod([httpGET])]
procedure GetArticleMeta;
function GetArticleMeta: IMVCResponse;
[MVCDoc('Returns the article with the specified id')]
[MVCPath('/($id)')]
[MVCHTTPMethod([httpGET])]
procedure GetArticleByID(id: Integer);
function GetArticleByID(id: Integer): IMVCResponse;
[MVCDoc('Deletes the article with the specified id')]
[MVCPath('/($id)')]
@ -43,17 +48,17 @@ type
[MVCDoc('Updates the article with the specified id and return "200: OK"')]
[MVCPath('/($id)')]
[MVCHTTPMethod([httpPUT])]
procedure UpdateArticleByID(const [MVCFromBody] Article: TArticle; const id: Integer);
function UpdateArticleByID(const [MVCFromBody] Article: TArticle; const id: Integer): IMVCResponse;
[MVCDoc('Creates a new article and returns "201: Created"')]
[MVCPath]
[MVCHTTPMethod([httpPOST])]
procedure CreateArticle(const [MVCFromBody] Article: TArticle);
function CreateArticle(const [MVCFromBody] Article: TArticle): IMVCResponse;
[MVCDoc('Creates new articles from a list and returns "201: Created"')]
[MVCPath('/bulk')]
[MVCHTTPMethod([httpPOST])]
procedure CreateArticles(const [MVCFromBody] ArticleList: TObjectList<TArticle>);
function CreateArticles(const [MVCFromBody] ArticleList: TObjectList<TArticle>): IMVCResponse;
end;
implementation
@ -61,116 +66,70 @@ implementation
{ TArticlesController }
uses
Services,
Commons,
mvcframework.Serializer.Intf,
System.SysUtils;
procedure TArticlesController.CreateArticle(const Article: TArticle);
constructor TArticlesController.Create(ArticlesService: IArticlesService);
begin
GetArticlesService.Add(Article);
inherited Create;
fArticlesService := ArticlesService;
end;
function TArticlesController.CreateArticle(const Article: TArticle): IMVCResponse;
begin
fArticlesService.Add(Article);
Render201Created('/articles/' + Article.id.ToString, 'Article Created');
end;
procedure TArticlesController.CreateArticles(const ArticleList: TObjectList<TArticle>);
var
lArticle: TArticle;
function TArticlesController.CreateArticles(const ArticleList: TObjectList<TArticle>): IMVCResponse;
begin
GetArticlesService.StartTransaction;
try
for lArticle in ArticleList do
begin
GetArticlesService.Add(lArticle);
end;
GetArticlesService.Commit;
except
GetArticlesService.Rollback;
raise;
end;
Render(201, 'Articles Created');
fArticlesService.CreateArticles(ArticleList);
Result := MVCResponseBuilder.StatusCode(HTTP_STATUS.Created).Build;
end;
procedure TArticlesController.DeleteArticleByID(id: Integer);
var
Article: TArticle;
begin
GetArticlesService.StartTransaction;
try
Article := GetArticlesService.GetByID(id);
try
GetArticlesService.Delete(Article);
finally
Article.Free;
end;
GetArticlesService.Commit;
except
GetArticlesService.Rollback;
raise;
end;
fArticlesService.Delete(fArticlesService.GetByID(id));
end;
procedure TArticlesController.GetArticles;
function TArticlesController.GetArticles: IMVCResponse;
begin
Render(ObjectDict().Add('data', GetArticlesService.GetAll));
Result := MVCResponseBuilder
.StatusCode(HTTP_STATUS.OK)
.Body(fArticlesService.GetAll)
.Build;
end;
procedure TArticlesController.GetArticlesByDescription(const Search: String);
var
lDict: IMVCObjectDictionary;
function TArticlesController.GetArticlesByDescription(const Search: String): IMVCResponse;
begin
try
if Search = '' then
begin
lDict := ObjectDict().Add('data', GetArticlesService.GetAll);
end
else
begin
lDict := ObjectDict().Add('data', GetArticlesService.GetArticles(Search));
end;
Render(lDict);
except
on E: EServiceException do
begin
raise EMVCException.Create(E.Message, '', 0, 404);
end
else
raise;
end;
Result := MVCResponseBuilder
.StatusCode(HTTP_STATUS.OK)
.Body(fArticlesService.GetArticles(Search))
.Build;
end;
procedure TArticlesController.UpdateArticleByID(const Article: TArticle; const id: Integer);
function TArticlesController.UpdateArticleByID(const Article: TArticle; const id: Integer): IMVCResponse;
begin
Article.id := id;
GetArticlesService.Update(Article);
Render(200, 'Article Updated');
fArticlesService.Update(Article);
Result := MVCResponseBuilder
.StatusCode(HTTP_STATUS.OK)
.Build;
end;
procedure TArticlesController.GetArticleByID(id: Integer);
function TArticlesController.GetArticleByID(id: Integer): IMVCResponse;
begin
try
Render(ObjectDict().Add('data', GetArticlesService.GetByID(id)));
except
on E: EServiceException do
begin
raise EMVCException.Create(E.Message, '', 0, 404);
end
else
raise;
end;
Result := MVCResponseBuilder
.StatusCode(HTTP_STATUS.OK)
.Body(fArticlesService.GetByID(id))
.Build;
end;
procedure TArticlesController.GetArticleMeta;
function TArticlesController.GetArticleMeta: IMVCResponse;
begin
try
Render(ObjectDict().Add('data', GetArticlesService.GetMeta));
except
on E: EServiceException do
begin
raise EMVCException.Create(E.Message, '', 0, 404);
end
else
raise;
end;
Result := MVCResponseBuilder
.StatusCode(HTTP_STATUS.OK)
.Body(fArticlesService.GetMeta)
.Build;
end;
end.

40
samples/articles_crud_server/Controllers.Base.pas
View File

@ -3,19 +3,10 @@ unit Controllers.Base;
interface
uses
MVCFramework, MVCFramework.Commons, Services, MainDM;
MVCFramework, MVCFramework.Commons, Services;
type
TBaseController = class abstract(TMVCController)
strict private
FDM: TdmMain;
FArticlesService: TArticlesService;
function GetDataModule: TdmMain;
strict protected
function GetArticlesService: TArticlesService;
public
destructor Destroy; override;
end;
[MVCPath('/private')]
@ -23,7 +14,7 @@ type
public
[MVCPath('/articles')]
[MVCHTTPMethods([httpDELETE])]
procedure DeleteAllArticles;
procedure DeleteAllArticles(ArticlesService: IArticlesService);
end;
implementation
@ -31,34 +22,11 @@ implementation
uses
System.SysUtils;
{ TBaseController }
destructor TBaseController.Destroy;
begin
FArticlesService.Free;
FDM.Free;
inherited;
end;
function TBaseController.GetArticlesService: TArticlesService;
begin
if not Assigned(FArticlesService) then
FArticlesService := TArticlesService.Create(GetDataModule);
Result := FArticlesService;
end;
function TBaseController.GetDataModule: TdmMain;
begin
if not Assigned(FDM) then
FDM := TdmMain.Create(nil);
Result := FDM;
end;
{ TPrivateController }
procedure TPrivateController.DeleteAllArticles;
procedure TPrivateController.DeleteAllArticles(ArticlesService: IArticlesService);
begin
GetArticlesService.DeleteAllArticles();
ArticlesService.DeleteAllArticles();
end;
end.

225
samples/articles_crud_server/FDConnectionConfigU.pas Normal file
View File

@ -0,0 +1,225 @@
unit FDConnectionConfigU;
interface
procedure CreateFirebirdPrivateConnDef(AIsPooled: boolean);
procedure CreateInterbasePrivateConnDef(AIsPooled: boolean);
procedure CreateMySQLPrivateConnDef(AIsPooled: boolean);
procedure CreateMSSQLServerPrivateConnDef(AIsPooled: boolean);
procedure CreatePostgresqlPrivateConnDef(AIsPooled: boolean);
procedure CreateSqlitePrivateConnDef(AIsPooled: boolean);
implementation
uses
MVCFramework.Commons,
System.Classes,
System.IOUtils,
FireDAC.Comp.Client,
FireDAC.Moni.Base,
FireDAC.Moni.FlatFile,
FireDAC.Stan.Intf
, Commons;
var
gFlatFileMonitor: TFDMoniFlatFileClientLink = nil;
procedure CreateMySQLPrivateConnDef(AIsPooled: boolean);
var
LParams: TStringList;
begin
{
docker run --detach --env MARIADB_USER=example-user --env MARIADB_PASSWORD=my_cool_secret --env MARIADB_ROOT_PASSWORD=root -p 3306:3306 mariadb:latest
}
LParams := TStringList.Create;
try
LParams.Add('Database=activerecorddb');
LParams.Add('Protocol=TCPIP');
LParams.Add('Server=localhost');
LParams.Add('User_Name=root');
LParams.Add('Password=root');
LParams.Add('TinyIntFormat=Boolean'); { it's the default }
LParams.Add('CharacterSet=utf8mb4'); // not utf8!!
LParams.Add('MonitorBy=FlatFile');
if AIsPooled then
begin
LParams.Add('Pooled=True');
LParams.Add('POOL_MaximumItems=100');
end
else
begin
LParams.Add('Pooled=False');
end;
FDManager.AddConnectionDef(CON_DEF_NAME, 'MySQL', LParams);
finally
LParams.Free;
end;
end;
procedure CreateMSSQLServerPrivateConnDef(AIsPooled: boolean);
var
LParams: TStringList;
begin
{
docker run -e "ACCEPT_EULA=Y" -e "SA_PASSWORD=!SA_password!" -p 1433:1433 -d mcr.microsoft.com/mssql/server:2019-latest
}
// [ACTIVERECORDB_SQLSERVER]
// Database=activerecorddb
// OSAuthent=Yes
// Server=DANIELETETI\SQLEXPRESS
// DriverID=MSSQL
//
LParams := TStringList.Create;
try
LParams.Add('Database=activerecorddb');
LParams.Add('OSAuthent=Yes');
LParams.Add('Server=DANIELETETI\SQLEXPRESS');
if AIsPooled then
begin
LParams.Add('Pooled=True');
LParams.Add('POOL_MaximumItems=100');
end
else
begin
LParams.Add('Pooled=False');
end;
FDManager.AddConnectionDef(CON_DEF_NAME, 'MSSQL', LParams);
finally
LParams.Free;
end;
end;
procedure CreateFirebirdPrivateConnDef(AIsPooled: boolean);
var
LParams: TStringList;
begin
LParams := TStringList.Create;
try
LParams.Add('Database=' + dotEnv.Env('database.path'));
LParams.Add('Protocol=TCPIP');
LParams.Add('Server=localhost');
LParams.Add('User_Name=sysdba');
LParams.Add('Password=masterkey');
LParams.Add('CharacterSet=UTF8');
if AIsPooled then
begin
LParams.Add('Pooled=True');
LParams.Add('POOL_MaximumItems=100');
end
else
begin
LParams.Add('Pooled=False');
end;
FDManager.AddConnectionDef(CON_DEF_NAME, 'FB', LParams);
finally
LParams.Free;
end;
end;
procedure CreateInterbasePrivateConnDef(AIsPooled: boolean);
var
LParams: TStringList;
begin
LParams := TStringList.Create;
try
LParams.Add('Database=' + TPath.GetFullPath(TPath.Combine('..\..',
'data\ACTIVERECORDDB.IB')));
LParams.Add('Protocol=TCPIP');
LParams.Add('Server=localhost');
LParams.Add('User_Name=sysdba');
LParams.Add('Password=masterkey');
LParams.Add('CharacterSet=UTF8');
if AIsPooled then
begin
LParams.Add('Pooled=True');
LParams.Add('POOL_MaximumItems=100');
end
else
begin
LParams.Add('Pooled=False');
end;
FDManager.AddConnectionDef(CON_DEF_NAME, 'IB', LParams);
finally
LParams.Free;
end;
end;
procedure CreatePostgresqlPrivateConnDef(AIsPooled: boolean);
var
LParams: TStringList;
begin
LParams := TStringList.Create;
try
LParams.Add('Database=activerecorddb');
LParams.Add('Protocol=TCPIP');
LParams.Add('Server=localhost');
LParams.Add('User_Name=postgres');
LParams.Add('Password=postgres');
// LParams.Add('MonitorBy=FlatFile');
// https://quality.embarcadero.com/browse/RSP-19755?jql=text%20~%20%22firedac%20guid%22
LParams.Add('GUIDEndian=Big');
if AIsPooled then
begin
LParams.Add('Pooled=True');
LParams.Add('POOL_MaximumItems=100');
end
else
begin
LParams.Add('Pooled=False');
end;
FDManager.AddConnectionDef(CON_DEF_NAME, 'PG', LParams);
finally
LParams.Free;
end;
end;
procedure CreateSqlitePrivateConnDef(AIsPooled: boolean);
var
LParams: TStringList;
lFName: string;
begin
LParams := TStringList.Create;
try
lFName := TPath.Combine(TPath.GetDirectoryName(ParamStr(0)),
'..\..\data\activerecorddb.db');
LParams.Add('Database=' + lFName);
LParams.Add('StringFormat=Unicode');
if AIsPooled then
begin
LParams.Add('Pooled=True');
LParams.Add('POOL_MaximumItems=100');
end
else
begin
LParams.Add('Pooled=False');
end;
FDManager.AddConnectionDef(CON_DEF_NAME, 'SQLite', LParams);
finally
LParams.Free;
end;
end;
initialization
gFlatFileMonitor := TFDMoniFlatFileClientLink.Create(nil);
gFlatFileMonitor.FileColumns := [tiRefNo, tiTime, tiThreadID, tiClassName, tiObjID, tiMsgText];
gFlatFileMonitor.EventKinds := [
ekVendor, ekConnConnect, ekLiveCycle, ekError, ekConnTransact,
ekCmdPrepare, ekCmdExecute, ekCmdDataIn, ekCmdDataOut];
gFlatFileMonitor.ShowTraces := False;
gFlatFileMonitor.FileAppend := False;
gFlatFileMonitor.FileName := TPath.ChangeExtension(ParamStr(0), '.trace.log');
gFlatFileMonitor.Tracing := True;
finalization
gFlatFileMonitor.Free;
end.

11
samples/articles_crud_server/MainDM.pas
View File

@ -23,10 +23,10 @@ uses
FireDAC.DApt,
FireDAC.Comp.DataSet,
FireDAC.Phys.FBDef,
FireDAC.VCLUI.Wait;
FireDAC.VCLUI.Wait, Services;
type
TdmMain = class(TDataModule)
TdmMain = class(TDataModule, IArticlesDataModule)
Connection: TFDConnection;
dsArticles: TFDQuery;
updArticles: TFDUpdateSQL;
@ -34,7 +34,9 @@ type
private
{ Private declarations }
public
constructor Create;
function SearchProducts(const SearchText: string): TDataSet;
end;
implementation
@ -52,6 +54,11 @@ begin
Connection.Params.Values['Database'] := dotEnv.Env('database.path');
end;
constructor TdmMain.Create;
begin
inherited Create(nil);
end;
function TdmMain.SearchProducts(const SearchText: string): TDataSet;
begin
Result := TFDMemTable.Create(nil);

121
samples/articles_crud_server/Services.pas
View File

@ -5,23 +5,24 @@ interface
uses
System.Generics.Collections,
BusinessObjects,
MainDM,
System.SysUtils,
Commons, JsonDataObjects;
type
TServiceBase = class abstract
strict protected
FDM: TdmMain;
public
constructor Create(AdmMain: TdmMain); virtual;
procedure Commit;
procedure Rollback;
procedure StartTransaction;
IArticlesService = interface
['{D6843E17-1B98-435C-9EBC-8E76DCEF9A3B}']
function GetAll: TObjectList<TArticle>;
function GetArticles(const aTextSearch: string): TObjectList<TArticle>;
function GetByID(const AID: Integer): TArticle;
procedure Delete(AArticolo: TArticle);
procedure DeleteAllArticles;
procedure Add(AArticolo: TArticle);
procedure CreateArticles(const ArticleList: TObjectList<TArticle>);
procedure Update(AArticolo: TArticle);
function GetMeta: TJSONObject;
end;
TArticlesService = class(TServiceBase)
TArticlesService = class(TInterfacedObject, IArticlesService)
public
function GetAll: TObjectList<TArticle>;
function GetArticles(const aTextSearch: string): TObjectList<TArticle>;
@ -29,6 +30,7 @@ type
procedure Delete(AArticolo: TArticle);
procedure DeleteAllArticles;
procedure Add(AArticolo: TArticle);
procedure CreateArticles(const ArticleList: TObjectList<TArticle>);
procedure Update(AArticolo: TArticle);
function GetMeta: TJSONObject;
end;
@ -36,112 +38,71 @@ type
implementation
uses
FireDAC.Stan.Option,
FireDAC.Comp.Client,
FireDAC.Stan.Param,
MVCFramework.ActiveRecord,
MVCFramework.FireDAC.Utils,
MVCFramework.DataSet.Utils,
MVCFramework.Serializer.Commons;
MVCFramework.Serializer.Commons, Data.DB;
{ TArticoliService }
procedure TArticlesService.Add(AArticolo: TArticle);
var
Cmd: TFDCustomCommand;
begin
AArticolo.CheckInsert;
Cmd := FDM.updArticles.Commands[arInsert];
TFireDACUtils.ObjectToParameters(Cmd.Params, AArticolo, 'NEW_');
Cmd.Execute;
AArticolo.ID := Cmd.ParamByName('ID').AsInteger;
AArticolo.Insert;
end;
procedure TArticlesService.CreateArticles(const ArticleList: TObjectList<TArticle>);
begin
var Ctx := TMVCActiveRecord.UseTransactionContext;
for var lArticle in ArticleList do
begin
Add(lArticle);
end;
end;
procedure TArticlesService.Delete(AArticolo: TArticle);
var
Cmd: TFDCustomCommand;
begin
AArticolo.CheckDelete;
Cmd := FDM.updArticles.Commands[arDelete];
TFireDACUtils.ObjectToParameters(Cmd.Params, AArticolo, 'OLD_');
Cmd.Execute;
AArticolo.Delete();
end;
procedure TArticlesService.DeleteAllArticles;
begin
FDM.Connection.ExecSQL('delete from articoli');
TMVCActiveRecord.DeleteAll(TArticle);
end;
function TArticlesService.GetAll: TObjectList<TArticle>;
begin
FDM.dsArticles.Open('SELECT * FROM ARTICOLI ORDER BY ID', []);
Result := FDM.dsArticles.AsObjectList<TArticle>;
FDM.dsArticles.Close;
Result := TMVCActiveRecord.SelectRQL<TArticle>('sort(+id)', 1000);
end;
function TArticlesService.GetArticles(
const aTextSearch: string): TObjectList<TArticle>;
begin
FDM.dsArticles.Open('SELECT * FROM ARTICOLI WHERE DESCRIZIONE CONTAINING ? ORDER BY ID', [aTextSearch]);
try
Result := FDM.dsArticles.AsObjectList<TArticle>()
finally
FDM.dsArticles.Close;
end;
if aTextSearch.Trim.IsEmpty then
Result := GetAll
else
Result := TMVCActiveRecord.SelectByNamedQuery<TArticle>('search_by_text',[aTextSearch],[ftString]);
end;
function TArticlesService.GetByID(const AID: Integer): TArticle;
begin
FDM.dsArticles.Open('SELECT * FROM ARTICOLI WHERE ID = :ID', [AID]);
try
if not FDM.dsArticles.Eof then
Result := FDM.dsArticles.AsObject<TArticle>
else
raise EServiceException.Create('Article not found');
finally
FDM.dsArticles.Close;
end;
Result := TMVCActiveRecord.GetByPK<TArticle>(AID);
end;
function TArticlesService.GetMeta: TJSONObject;
begin
FDM.dsArticles.Open('SELECT ID, CODICE as CODE, DESCRIZIONE as DESCRIPTION, PREZZO as PRICE, CREATED_AT as CREATEDAT, UPDATED_AT as UPDATEDAT FROM ARTICOLI WHERE TRUE = FALSE');
Result := FDM.dsArticles.MetadataAsJSONObject();
var lDS := TMVCActiveRecord.SelectDataSet('SELECT ID, CODICE as CODE, DESCRIZIONE as DESCRIPTION, PREZZO as PRICE, CREATED_AT as CREATEDAT, UPDATED_AT as UPDATEDAT FROM ARTICOLI WHERE TRUE = FALSE',[]);
try
Result := lDS.MetadataAsJSONObject()
finally
lDS.Free;
end;
end;
procedure TArticlesService.Update(AArticolo: TArticle);
var
Cmd: TFDCustomCommand;
begin
AArticolo.CheckUpdate;
Cmd := FDM.updArticles.Commands[arUpdate];
TFireDACUtils.ObjectToParameters(Cmd.Params, AArticolo, 'NEW_');
Cmd.ParamByName('OLD_ID').AsInteger := AArticolo.ID;
Cmd.Execute;
if Cmd.RowsAffected <> 1 then
raise Exception.Create('Article not found');
end;
{ TServiceBase }
procedure TServiceBase.Commit;
begin
FDM.Connection.Commit;
end;
constructor TServiceBase.Create(AdmMain: TdmMain);
begin
inherited Create;
FDM := AdmMain;
end;
procedure TServiceBase.Rollback;
begin
FDM.Connection.Rollback;
end;
procedure TServiceBase.StartTransaction;
begin
FDM.Connection.StartTransaction;
AArticolo.Update();
end;
end.

10
samples/articles_crud_server/WebModuleUnit1.pas
View File

@ -2,7 +2,8 @@ unit WebModuleUnit1;
interface
uses System.SysUtils, System.Classes, Web.HTTPApp, mvcframework;
uses System.SysUtils, System.Classes, Web.HTTPApp, mvcframework, FireDAC.Phys.FBDef, FireDAC.Stan.Intf, FireDAC.Phys,
FireDAC.Phys.IBBase, FireDAC.Phys.FB;
type
TWebModule1 = class(TWebModule)
@ -23,10 +24,13 @@ implementation
uses
Controllers.Articles,
MVCFramework.Middleware.CORS,
MVCFramework.Middleware.ActiveRecord,
MVCFramework.Middleware.Compression,
MVCFramework.Middleware.Trace,
MVCFramework.SQLGenerators.Firebird,
MVCFramework.Commons,
Controllers.Base;
Controllers.Base,
Commons;
{$R *.dfm}
@ -45,6 +49,8 @@ begin
{$ENDIF}
FEngine.AddMiddleware(TCORSMiddleware.Create);
FEngine.AddMiddleware(TMVCCompressionMiddleware.Create(256));
FEngine.AddMiddleware(TMVCActiveRecordMiddleware.Create(CON_DEF_NAME));
// FEngine.AddMiddleware(TMVCTraceMiddleware.Create);
end;

11
samples/articles_crud_server/articles_crud_server.dpr
View File

@ -10,6 +10,7 @@ uses
MVCFramework.Commons,
MVCFramework.Signal,
MVCFramework.Logger,
MVCFramework.Container,
MVCFramework.dotEnv,
Web.WebReq,
Web.WebBroker,
@ -18,10 +19,10 @@ uses
Controllers.Articles in 'Controllers.Articles.pas',
Services in 'Services.pas',
BusinessObjects in 'BusinessObjects.pas',
MainDM in 'MainDM.pas' {dmMain: TDataModule},
Commons in 'Commons.pas',
MVCFramework.ActiveRecord in '..\..\sources\MVCFramework.ActiveRecord.pas',
MVCFramework.Serializer.JsonDataObjects in '..\..\sources\MVCFramework.Serializer.JsonDataObjects.pas';
MVCFramework.Serializer.JsonDataObjects in '..\..\sources\MVCFramework.Serializer.JsonDataObjects.pas',
FDConnectionConfigU in 'FDConnectionConfigU.pas';
{$R *.res}
@ -68,6 +69,12 @@ begin
.Build(); //uses the executable folder to look for .env* files
end);
CreateFirebirdPrivateConnDef(True);
DefaultMVCServiceContainer
.RegisterType(TArticlesService, IArticlesService, '', TRegistrationType.SingletonPerRequest)
.Build;
WebRequestHandlerProc.MaxConnections := dotEnv.Env('dmvc.handler.max_connections', 1024);
RunServer(dotEnv.Env('dmvc.server.port', 8080));
except

5
samples/articles_crud_server/articles_crud_server.dproj
View File

@ -97,13 +97,10 @@
<DCCReference Include="Controllers.Articles.pas"/>
<DCCReference Include="Services.pas"/>
<DCCReference Include="BusinessObjects.pas"/>
<DCCReference Include="MainDM.pas">
<Form>dmMain</Form>
<DesignClass>TDataModule</DesignClass>
</DCCReference>
<DCCReference Include="Commons.pas"/>
<DCCReference Include="..\..\sources\MVCFramework.ActiveRecord.pas"/>
<DCCReference Include="..\..\sources\MVCFramework.Serializer.JsonDataObjects.pas"/>
<DCCReference Include="FDConnectionConfigU.pas"/>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>

19
samples/articles_crud_vcl_client_api_binder/MainFormU.pas
View File

@ -8,7 +8,7 @@ uses
FireDAC.Stan.Param, FireDAC.Stan.Error, FireDAC.DatS, FireDAC.Phys.Intf,
FireDAC.DApt.Intf, Data.DB, FireDAC.Comp.DataSet, FireDAC.Comp.Client,
Vcl.Grids, Vcl.DBGrids, Vcl.ExtCtrls, Vcl.StdCtrls, MVCFramework.RESTClient.Intf, MVCFramework.RESTClient,
Vcl.DBCtrls, MVCFramework.DataSet.Utils;
Vcl.DBCtrls, MVCFramework.DataSet.Utils, Vcl.Buttons;
type
TMainForm = class(TForm)
@ -38,11 +38,8 @@ type
procedure btnFilterClick(Sender: TObject);
private
fFilter: string;
fLoading: Boolean;
fRESTClient: IMVCRESTClient;
fAPIBinder: TMVCAPIBinder;
{ Private declarations }
procedure ShowError(const AResponse: IMVCRESTResponse);
procedure SetFilter(const Value: string);
public
property Filter: string read fFilter write SetFilter;
@ -102,18 +99,4 @@ begin
EditFilter.Text := Value;
end;
procedure TMainForm.ShowError(const AResponse: IMVCRESTResponse);
begin
if not AResponse.Success then
MessageDlg(
AResponse.StatusCode.ToString + ': ' + AResponse.StatusText + sLineBreak +
'[' + AResponse.Content + ']',
mtError, [mbOK], 0)
else
MessageDlg(
AResponse.StatusCode.ToString + ': ' + AResponse.StatusText + sLineBreak +
AResponse.Content,
mtError, [mbOK], 0);
end;
end.

345
samples/commons/Entities.pas Normal file
View File

@ -0,0 +1,345 @@
unit Entities;
interface
uses
MVCFramework.Serializer.Commons,
MVCFramework.ActiveRecord,
MVCFramework.Nullables,
System.Classes,
System.DateUtils,
MVCFramework,
MVCFramework.Utils,
System.Generics.Collections;
type
[MVCNameCase(ncCamelCase)]
[MVCTable('people')]
[MVCEntityActions([eaCreate, eaRetrieve, eaUpdate, eaDelete])]
TPerson = class(TMVCActiveRecord)
private
[MVCTableField('id', [foPrimaryKey, foAutoGenerated])]
fID: Int64;
[MVCTableField('LAST_NAME')]
fLastName: string;
[MVCTableField('FIRST_NAME')]
fFirstName: string;
[MVCTableField('DOB')]
fDOB: NullableTDate;
[MVCTableField('FULL_NAME')]
fFullName: string;
[MVCTableField('IS_MALE')]
fIsMale: NullableBoolean;
[MVCTableField('NOTE')]
fNote: string;
[MVCTableField('PHOTO')]
fPhoto: TStream;
// transient fields
fAge: NullableInt32;
procedure SetLastName(const Value: string);
procedure SetID(const Value: Int64);
procedure SetFirstName(const Value: string);
procedure SetDOB(const Value: NullableTDate);
function GetFullName: string;
procedure SetIsMale(const Value: NullableBoolean);
procedure SetNote(const Value: string);
protected
procedure OnAfterLoad; override;
procedure OnBeforeInsertOrUpdate; override;
procedure OnValidation(const Action: TMVCEntityAction); override;
procedure OnBeforeInsert; override;
public
constructor Create; override;
destructor Destroy; override;
function GetUniqueString: String;
procedure Assign(ActiveRecord: TMVCActiveRecord); override;
property ID: Int64 read fID write SetID;
[MVCNameAs('person_surname')]
property LastName: string read fLastName write SetLastName;
[MVCNameAs('person_name')]
property FirstName: string read fFirstName write SetFirstName;
property Age: NullableInt32 read fAge;
property DOB: NullableTDate read fDOB write SetDOB;
property FullName: string read GetFullName;
property IsMale: NullableBoolean read fIsMale write SetIsMale;
property Note: string read fNote write SetNote;
property Photo: TStream read fPhoto;
end;
[MVCNameCase(ncLowerCase)]
[MVCTable('phones')]
[MVCEntityActions([eaCreate, eaRetrieve, eaUpdate, eaDelete])]
TPhone = class(TMVCActiveRecord)
private
[MVCTableField('id', [foPrimaryKey, foAutoGenerated])]
fID: Integer;
[MVCTableField('phone_number')]
fPhoneNumber: string;
[MVCTableField('number_type')]
fNumberType: string;
[MVCTableField('id_person')]
fIDPerson: Integer;
protected
procedure OnValidation(const Action: TMVCEntityAction); override;
public
property ID: Integer read fID write fID;
property IDPerson: Integer read fIDPerson write fIDPerson;
property PhoneNumber: string read fPhoneNumber write fPhoneNumber;
property NumberType: string read fNumberType write fNumberType;
end;
[MVCNameCase(ncLowerCase)]
[MVCTable('PEOPLE')]
[MVCEntityActions([eaCreate, eaRetrieve, eaUpdate, eaDelete])]
TContact = class(TPerson)
private
function GetPhones: TObjectList<TPhone>;
public
property Phones: TObjectList<TPhone> read GetPhones;
end;
[MVCNameCase(ncLowerCase)]
[MVCEntityActions([eaRetrieve])]
[MVCNamedSQLQuery('AverageSalary',
'select person_type, coalesce(avg(salary::numeric), 0) average_salary from people ' +
'group by person_type order by 1', TMVCActiveRecordBackEnd.PostgreSQL)]
TSalaryAggregate = class(TMVCActiveRecord)
private
[MVCTableField('average_salary')]
FAverageSalary: Currency;
[MVCTableField('person_type')]
FPersonType: String;
procedure SetAverageSalary(const Value: Currency);
procedure SetPersonType(const Value: String);
public
property PersonType: String read FPersonType write SetPersonType;
property AverageSalary: Currency read FAverageSalary write SetAverageSalary;
end;
[MVCNameCase(ncLowerCase)]
[MVCTable('articles')]
[MVCEntityActions([eaCreate, eaRetrieve, eaUpdate, eaDelete])]
TArticle = class(TMVCActiveRecord)
private
[MVCTableField('id', [foPrimaryKey, foAutoGenerated])]
fID: Int64;
[MVCTableField('price')]
FPrice: UInt32;
[MVCTableField('description')]
FDescription: string;
procedure SetID(const Value: Int64);
procedure SetDescription(const Value: string);
procedure SetPrice(const Value: UInt32);
public
property ID: Int64 read fID write SetID;
property Description: string read FDescription write SetDescription;
property Price: UInt32 read FPrice write SetPrice;
end;
[MVCNameCase(ncLowerCase)]
[MVCTable('customers_with_version')]
TCustomersWithVersion = class(TMVCActiveRecord)
private
[MVCTableField('id', [foPrimaryKey, foAutoGenerated])]
fID: Int64;
[MVCTableField('code')]
fCode: NullableString;
[MVCTableField('description')]
fDescription: NullableString;
[MVCTableField('city')]
fCity: NullableString;
[MVCTableField('note')]
fNote: NullableString;
[MVCTableField('rating')]
fRating: NullableInt32;
[MVCTableField('objversion', [foVersion])]
fObjversion: Integer;
public
property ID: Int64 read fID write fID;
property Code: NullableString read fCode write fCode;
property Description: NullableString read fDescription write fDescription;
property City: NullableString read fCity write fCity;
property Note: NullableString read fNote write fNote;
property Rating: NullableInt32 read fRating write fRating;
property ObjVersion: Integer read fObjversion write fObjversion;
end;
implementation
uses
System.SysUtils;
{ TPersona }
procedure TPerson.Assign(ActiveRecord: TMVCActiveRecord);
begin
if ActiveRecord is TPerson then
begin
var lPerson := TPerson(ActiveRecord);
Self.LastName := lPerson.LastName;
Self.FirstName := lPerson.FirstName;
Self.DOB := lPerson.DOB;
Self.IsMale := lPerson.IsMale;
Self.Note := lPerson.Note;
Self.Photo.Size := 0;
Self.Photo.CopyFrom(lPerson.Photo);
Self.Photo.Position := 0;
end
else
inherited;
end;
constructor TPerson.Create;
begin
inherited;
fPhoto := TMemoryStream.Create;
end;
destructor TPerson.Destroy;
begin
fPhoto.Free;
inherited;
end;
function TPerson.GetFullName: string;
begin
Result := fFullName;
end;
function TPerson.GetUniqueString: String;
begin
Result :=
fID.ToString + '|' +
fFirstName + '|' +
fLastName + '|' +
DateToISODate(fDOB.ValueOrDefault) + '|' +
BoolToStr(fIsMale.ValueOrDefault, True) + '|' +
GetSHA1HashFromStream(fPhoto);
end;
procedure TPerson.OnAfterLoad;
begin
inherited;
if fDOB.HasValue then
begin
fAge := YearsBetween(fDOB, now);
end
else
begin
fAge.Clear;
end;
end;
procedure TPerson.OnBeforeInsert;
begin
inherited;
end;
procedure TPerson.OnBeforeInsertOrUpdate;
begin
inherited;
fLastName := fLastName.ToUpper;
fFirstName := fFirstName.ToUpper;
fFullName := fFirstName + ' ' + fLastName;
end;
procedure TPerson.OnValidation(const Action: TMVCEntityAction);
begin
inherited;
if fLastName.Trim.IsEmpty or fFirstName.Trim.IsEmpty then
raise EMVCActiveRecord.Create
('Validation error. FirstName and LastName are required');
end;
procedure TPerson.SetLastName(const Value: string);
begin
fLastName := Value;
end;
procedure TPerson.SetNote(const Value: string);
begin
fNote := Value;
end;
procedure TPerson.SetDOB(const Value: NullableTDate);
begin
fDOB := Value;
end;
procedure TPerson.SetID(const Value: Int64);
begin
fID := Value;
end;
procedure TPerson.SetIsMale(const Value: NullableBoolean);
begin
fIsMale := Value;
end;
procedure TPerson.SetFirstName(const Value: string);
begin
fFirstName := Value;
end;
{ TArticle }
procedure TArticle.SetDescription(const Value: string);
begin
FDescription := Value;
end;
procedure TArticle.SetID(const Value: Int64);
begin
fID := Value;
end;
procedure TArticle.SetPrice(const Value: UInt32);
begin
FPrice := Value;
end;
{ TPhone }
procedure TPhone.OnValidation(const Action: TMVCEntityAction);
begin
inherited;
if fPhoneNumber.Trim.IsEmpty then
raise EMVCActiveRecord.Create('Phone Number cannot be empty');
end;
{ TContact }
function TContact.GetPhones: TObjectList<TPhone>;
begin
Result := TMVCActiveRecord.SelectRQL<TPhone>('eq(IDPerson, ' +
self.ID.ToString + ')', 100);
end;
{ TSalaryAggregate }
procedure TSalaryAggregate.SetAverageSalary(const Value: Currency);
begin
FAverageSalary := Value;
end;
procedure TSalaryAggregate.SetPersonType(const Value: String);
begin
FPersonType := Value;
end;
initialization
ActiveRecordMappingRegistry.AddEntity('people', TPerson);
ActiveRecordMappingRegistry.AddEntity('salary', TSalaryAggregate);
ActiveRecordMappingRegistry.AddEntity('contacts', TContact);
ActiveRecordMappingRegistry.AddEntity('phones', TPhone);
ActiveRecordMappingRegistry.AddEntity('articles', TArticle);
ActiveRecordMappingRegistry.AddEntity('customers', TCustomersWithVersion);
finalization
end.

42
samples/functional_actions_showcase/ControllerU.pas
View File

@ -82,6 +82,11 @@ type
function GetMVCResponseWithObjectDictionary: IMVCResponse;
[MVCPath('/mvcresponse/message/builder/headers')]
function GetMVCResponseSimpleBuilderWithHeaders: IMVCResponse;
[MVCPath('/mvcresponse/message/builder/nobody')]
function GetMVCResponseNoBody: IMVCResponse;
// Standard Responses
[MVCPath('/mvcresponse/ok')]
function GetOKResponse: IMVCResponse;
end;
implementation
@ -132,6 +137,15 @@ end;
function TMyController.GetMVCResponseNoBody: IMVCResponse;
begin
Result := MVCResponseBuilder
.StatusCode(HTTP_STATUS.OK)
.Header('header1', 'Hello World')
.Header('header2', 'foo bar')
.Build;
end;
function TMyController.GetMVCResponseSimple: IMVCResponse;
begin
Result := MVCResponseBuilder
@ -152,10 +166,7 @@ end;
function TMyController.GetMVCResponseWithData: IMVCResponse;
begin
Result := MVCResponseBuilder
.StatusCode(HTTP_STATUS.OK)
.Body(TPerson.Create('Daniele','Teti', 99))
.Build;
Result := OKResponse(TPerson.Create('Daniele','Teti', 99));
end;
function TMyController.GetMVCResponseWithDataAndMessage: IMVCResponse;
@ -191,22 +202,21 @@ end;
function TMyController.GetMVCResponseWithObjectList: IMVCResponse;
begin
Result := MVCResponseBuilder
.StatusCode(HTTP_STATUS.OK)
.Body(TObjectList<TPerson>.Create([
TPerson.Create('Daniele','Teti', 99),
TPerson.Create('Peter','Parker', 25),
TPerson.Create('Bruce','Banner', 45)
])
).Build;
Result := OKResponse(TObjectList<TPerson>.Create([
TPerson.Create('Daniele','Teti', 99),
TPerson.Create('Peter','Parker', 25),
TPerson.Create('Bruce','Banner', 45)
]));
end;
function TMyController.GetOKResponse: IMVCResponse;
begin
Result := OKResponse;
end;
function TMyController.GetMVCResponseWithJSON: IMVCResponse;
begin
Result := MVCResponseBuilder
.StatusCode(HTTP_STATUS.OK)
.Body(StrToJSONObject('{"name":"Daniele","surname":"Teti"}'))
.Build;
Result := OKResponse(StrToJSONObject('{"name":"Daniele","surname":"Teti"}'));
end;
function TMyController.GetSingleObject: TPerson;

116
samples/services_injection/MainControllerU.pas Normal file
View File

@ -0,0 +1,116 @@
unit MainControllerU;
interface
uses
MVCFramework, MVCFramework.Commons, MVCFramework.Serializer.Commons,
System.Generics.Collections, Services.InterfacesU,
Entities, MVCFramework.Container;
type
[MVCPath('/api')]
TMyController = class(TMVCController)
private
fPeopleService: IPeopleService;
public
[MVCInject]
constructor Create(const PeopleService: IPeopleService); reintroduce;
[MVCPath('/people')]
[MVCHTTPMethod([httpGET])]
function GetPeople: TObjectList<TPerson>;
[MVCPath('/people2')]
[MVCHTTPMethod([httpGET])]
function GetPeople2([MVCInject] OtherPeopleService: IPeopleService): TObjectList<TPerson>;
[MVCPath('/people/($ID)')]
[MVCHTTPMethod([httpGET])]
function GetPerson(ID: Integer): TPerson;
[MVCPath('/people')]
[MVCHTTPMethod([httpPOST])]
function CreatePerson([MVCFromBody] Person: TPerson): IMVCResponse;
[MVCPath('/people/($ID)')]
[MVCHTTPMethod([httpPUT])]
function UpdatePerson(ID: Integer; [MVCFromBody] Person: TPerson): IMVCResponse;
[MVCPath('/people/($ID)')]
[MVCHTTPMethod([httpDELETE])]
function DeletePerson(ID: Integer): IMVCResponse;
end;
implementation
uses
System.SysUtils, MVCFramework.Logger, System.StrUtils;
//Sample CRUD Actions for a "People" entity
function TMyController.GetPeople: TObjectList<TPerson>;
begin
Result := fPeopleService.GetAll;
end;
function TMyController.GetPeople2(OtherPeopleService: IPeopleService): TObjectList<TPerson>;
begin
LogI('PeopleService in GetPeople2: ' + IntToHex(NativeUInt(Pointer(OtherPeopleService))));
Result := OtherPeopleService.GetAll;
end;
function TMyController.GetPerson(ID: Integer): TPerson;
var
lPeople: TObjectList<TPerson>;
begin
lPeople := GetPeople;
try
Result := lPeople.ExtractAt(ID mod lPeople.Count);
finally
lPeople.Free;
end;
end;
//constructor TMyController.Create;
//begin
// inherited Create;
//end;
constructor TMyController.Create(const PeopleService: IPeopleService);
begin
inherited Create;
Assert(PeopleService <> nil, 'PeopleService not injected');
fPeopleService := PeopleService;
LogI('PeopleService in constructor: ' + IntToHex(NativeUInt(Pointer(PeopleService))));
end;
function TMyController.CreatePerson([MVCFromBody] Person: TPerson): IMVCResponse;
begin
LogI('Created ' + Person.FirstName + ' ' + Person.LastName);
Result := MVCResponseBuilder
.StatusCode(HTTP_STATUS.Created)
.Body('Person created')
.Build;
end;
function TMyController.UpdatePerson(ID: Integer; [MVCFromBody] Person: TPerson): IMVCResponse;
begin
LogI('Updated ' + Person.FirstName + ' ' + Person.LastName);
Result := MVCResponseBuilder
.StatusCode(HTTP_STATUS.NoContent)
.Build;
end;
function TMyController.DeletePerson(ID: Integer): IMVCResponse;
begin
LogI('Deleted person with id ' + ID.ToString);
Result := MVCResponseBuilder
.StatusCode(HTTP_STATUS.NoContent)
.Build;
end;
end.

40
samples/services_injection/Services.ConnectionU.pas Normal file
View File

@ -0,0 +1,40 @@
unit Services.ConnectionU;
interface
uses Services.InterfacesU;
type
TConnectionService = class(TInterfacedObject, IConnectionService)
protected
function GetConnectionName: string;
public
constructor Create; virtual;
destructor Destroy; override;
end;
implementation
uses
MVCFramework.Logger, System.SysUtils;
{ TConnectionService }
constructor TConnectionService.Create;
begin
inherited;
LogI('Service ' + ClassName + ' created [' + IntToHex(NativeUInt(Pointer(Self))) + ']');
end;
destructor TConnectionService.Destroy;
begin
LogI('Service ' + ClassName + ' destroyed [' + IntToHex(NativeUInt(Pointer(Self))) + ']');
inherited;
end;
function TConnectionService.GetConnectionName: string;
begin
Result := 'MyDemoConnection';
end;
end.

21
samples/services_injection/Services.InterfacesU.pas Normal file
View File

@ -0,0 +1,21 @@
unit Services.InterfacesU;
interface
uses Entities, System.Generics.Collections;
type
IPeopleService = interface
['{347532A0-1B28-40C3-A2E9-51DF62365FE7}']
function GetAll: TObjectList<TPerson>;
end;
IConnectionService = interface
['{146C21A5-07E8-456D-8E6D-A72820BD17AA}']
function GetConnectionName: String;
end;
implementation
end.

51
samples/services_injection/Services.PeopleU.pas Normal file
View File

@ -0,0 +1,51 @@
unit Services.PeopleU;
interface
uses
System.Generics.Collections, Entities, Services.InterfacesU, MVCFramework.Logger,
MVCFramework, MVCFramework.Container;
type
TPeopleService = class(TInterfacedObject, IPeopleService)
private
fConnService: IConnectionService;
public
[MVCInject]
constructor Create(ConnectionService: IConnectionService); virtual;
destructor Destroy; override;
function GetAll: TObjectList<TPerson>;
end;
implementation
uses
System.SysUtils {IntToHex};
{ TPeopleService }
constructor TPeopleService.Create(ConnectionService: IConnectionService);
begin
inherited Create;
fConnService := ConnectionService;
LogI('Service ' + ClassName + ' created [' + IntToHex(NativeUInt(Pointer(Self))) + ']');
end;
destructor TPeopleService.Destroy;
begin
LogI('Service ' + ClassName + ' destroyed [' + IntToHex(NativeUInt(Pointer(Self))) + ']');
inherited;
end;
function TPeopleService.GetAll: TObjectList<TPerson>;
begin
Result := TObjectList<TPerson>.Create;
Result.AddRange([
TPerson.Create,
TPerson.Create,
TPerson.Create,
TPerson.Create
]);
end;
end.

21
samples/services_injection/Services.RegistrationU.pas Normal file
View File

@ -0,0 +1,21 @@
unit Services.RegistrationU;
interface
uses
MVCFramework.Container;
procedure RegisterServices(Container: IMVCServiceContainer);
implementation
uses
Services.PeopleU, Services.InterfacesU, Services.ConnectionU;
procedure RegisterServices(Container: IMVCServiceContainer);
begin
Container.RegisterType(TPeopleService, IPeopleService);
Container.RegisterType(TConnectionService, IConnectionService, '', TRegistrationType.SingletonPerRequest)
end;
end.

7
samples/services_injection/WebModuleU.dfm Normal file
View File

@ -0,0 +1,7 @@
object MyWebModule: TMyWebModule
OnCreate = WebModuleCreate
OnDestroy = WebModuleDestroy
Actions = <>
Height = 230
Width = 415
end

125
samples/services_injection/WebModuleU.pas Normal file
View File

@ -0,0 +1,125 @@
unit WebModuleU;
interface
uses
System.SysUtils,
System.Classes,
Web.HTTPApp,
MVCFramework, Services.PeopleU, Services.InterfacesU;
type
TMyWebModule = class(TWebModule)
procedure WebModuleCreate(Sender: TObject);
procedure WebModuleDestroy(Sender: TObject);
private
FMVC: TMVCEngine;
public
{ Public declarations }
end;
var
WebModuleClass: TComponentClass = TMyWebModule;
implementation
{$R *.dfm}
uses
MainControllerU,
System.IOUtils,
MVCFramework.SQLGenerators.PostgreSQL,
MVCFramework.Commons,
MVCFramework.Middleware.ActiveRecord,
MVCFramework.Middleware.StaticFiles,
MVCFramework.Middleware.Analytics,
MVCFramework.Middleware.Trace,
MVCFramework.Middleware.CORS,
MVCFramework.Middleware.ETag,
MVCFramework.Middleware.Compression;
procedure TMyWebModule.WebModuleCreate(Sender: TObject);
begin
FMVC := TMVCEngine.Create(Self,
procedure(Config: TMVCConfig)
begin
Config.dotEnv := dotEnv;
// session timeout (0 means session cookie)
Config[TMVCConfigKey.SessionTimeout] := dotEnv.Env('dmvc.session_timeout', '0');
//default content-type
Config[TMVCConfigKey.DefaultContentType] := dotEnv.Env('dmvc.default.content_type', TMVCConstants.DEFAULT_CONTENT_TYPE);
//default content charset
Config[TMVCConfigKey.DefaultContentCharset] := dotEnv.Env('dmvc.default.content_charset', TMVCConstants.DEFAULT_CONTENT_CHARSET);
//unhandled actions are permitted?
Config[TMVCConfigKey.AllowUnhandledAction] := dotEnv.Env('dmvc.allow_unhandled_actions', 'false');
//enables or not system controllers loading (available only from localhost requests)
Config[TMVCConfigKey.LoadSystemControllers] := dotEnv.Env('dmvc.load_system_controllers', 'true');
//default view file extension
Config[TMVCConfigKey.DefaultViewFileExtension] := dotEnv.Env('dmvc.default.view_file_extension', 'html');
//view path
Config[TMVCConfigKey.ViewPath] := dotEnv.Env('dmvc.view_path', 'templates');
//use cache for server side views (use "false" in debug and "true" in production for faster performances
Config[TMVCConfigKey.ViewCache] := dotEnv.Env('dmvc.view_cache', 'false');
//Max Record Count for automatic Entities CRUD
Config[TMVCConfigKey.MaxEntitiesRecordCount] := dotEnv.Env('dmvc.max_entities_record_count', IntToStr(TMVCConstants.MAX_RECORD_COUNT));
//Enable Server Signature in response
Config[TMVCConfigKey.ExposeServerSignature] := dotEnv.Env('dmvc.expose_server_signature', 'false');
//Enable X-Powered-By Header in response
Config[TMVCConfigKey.ExposeXPoweredBy] := dotEnv.Env('dmvc.expose_x_powered_by', 'true');
// Max request size in bytes
Config[TMVCConfigKey.MaxRequestSize] := dotEnv.Env('dmvc.max_request_size', IntToStr(TMVCConstants.DEFAULT_MAX_REQUEST_SIZE));
end);
FMVC.AddController(TMyController);
// Analytics middleware generates a csv log, useful to do traffic analysis
//FMVC.AddMiddleware(TMVCAnalyticsMiddleware.Create(GetAnalyticsDefaultLogger));
// The folder mapped as documentroot for TMVCStaticFilesMiddleware must exists!
//FMVC.AddMiddleware(TMVCStaticFilesMiddleware.Create('/static', TPath.Combine(ExtractFilePath(GetModuleName(HInstance)), 'www')));
// Trace middlewares produces a much detailed log for debug purposes
//FMVC.AddMiddleware(TMVCTraceMiddleware.Create);
// CORS middleware handles... well, CORS
//FMVC.AddMiddleware(TMVCCORSMiddleware.Create);
// Simplifies TMVCActiveRecord connection definition
FMVC.AddMiddleware(TMVCActiveRecordMiddleware.Create(
dotEnv.Env('firedac.connection_definition_name', 'activerecorddb'),
dotEnv.Env('firedac.connection_definitions_filename', '')
));
// Compression middleware must be the last in the chain, just before the ETag, if present.
//FMVC.AddMiddleware(TMVCCompressionMiddleware.Create);
// ETag middleware must be the latest in the chain
//FMVC.AddMiddleware(TMVCETagMiddleware.Create);
{
FMVC.OnWebContextCreate(
procedure(const Context: TWebContext)
begin
// Initialize services to make them accessibile from Context
// Context.CustomIntfObject := TMyService.Create;
end);
FMVC.OnWebContextDestroy(
procedure(const Context: TWebContext)
begin
//Cleanup services, if needed
end);
}
end;
procedure TMyWebModule.WebModuleDestroy(Sender: TObject);
begin
FMVC.Free;
end;
end.

97
samples/services_injection/services_injection.dpr Normal file
View File

@ -0,0 +1,97 @@
program services_injection;
{$APPTYPE CONSOLE}
uses
System.SysUtils,
MVCFramework,
MVCFramework.Logger,
MVCFramework.DotEnv,
MVCFramework.Commons,
MVCFramework.Signal,
Web.ReqMulti,
Web.WebReq,
Web.WebBroker,
IdContext,
IdHTTPWebBrokerBridge,
MainControllerU in 'MainControllerU.pas',
WebModuleU in 'WebModuleU.pas' {MyWebModule: TWebModule},
Services.PeopleU in 'Services.PeopleU.pas',
Services.InterfacesU in 'Services.InterfacesU.pas',
Entities in '..\commons\Entities.pas',
MVCFramework.Router in '..\..\sources\MVCFramework.Router.pas',
MVCFramework.Container in '..\..\sources\MVCFramework.Container.pas',
Services.ConnectionU in 'Services.ConnectionU.pas',
Services.RegistrationU in 'Services.RegistrationU.pas';
{$R *.res}
procedure RunServer(APort: Integer);
var
LServer: TIdHTTPWebBrokerBridge;
begin
LServer := TIdHTTPWebBrokerBridge.Create(nil);
try
LServer.OnParseAuthentication := TMVCParseAuthentication.OnParseAuthentication;
LServer.DefaultPort := APort;
LServer.KeepAlive := True;
LServer.MaxConnections := dotEnv.Env('dmvc.webbroker.max_connections', 0);
LServer.ListenQueue := dotEnv.Env('dmvc.indy.listen_queue', 500);
LServer.Active := True;
LogI('Listening on port ' + APort.ToString);
LogI('Application started. Press Ctrl+C to shut down.');
WaitForTerminationSignal;
EnterInShutdownState;
LServer.Active := False;
finally
LServer.Free;
end;
end;
begin
{ Enable ReportMemoryLeaksOnShutdown during debug }
ReportMemoryLeaksOnShutdown := True;
IsMultiThread := True;
// DMVCFramework Specific Configuration
// When MVCSerializeNulls = True empty nullables and nil are serialized as json null.
// When MVCSerializeNulls = False empty nullables and nil are not serialized at all.
MVCSerializeNulls := True;
UseConsoleLogger := True;
LogI('** DMVCFramework Server ** build ' + DMVCFRAMEWORK_VERSION);
try
dotEnvConfigure(
function: IMVCDotEnv
begin
Result := NewDotEnv
.UseStrategy(TMVCDotEnvPriority.FileThenEnv)
.UseLogger(procedure(LogItem: String)
begin
LogD('dotEnv: ' + LogItem);
end)
.Build();
end);
RegisterServices(DefaultMVCServiceContainer);
DefaultMVCServiceContainer.Build;
if dotEnv.Env('dmvc.profiler.enabled', false) then
begin
Profiler.ProfileLogger := Log;
Profiler.WarningThreshold := dotEnv.Env('dmvc.profiler.warning_threshold', 2000);
end;
if WebRequestHandler <> nil then
WebRequestHandler.WebModuleClass := WebModuleClass;
WebRequestHandlerProc.MaxConnections := dotEnv.Env('dmvc.handler.max_connections', 1024);
RunServer(dotEnv.Env('dmvc.server.port', 8080));
except
on E: Exception do
LogF(E.ClassName + ': ' + E.Message);
end;
end.

1034
samples/services_injection/services_injection.dproj Normal file
View File

File diff suppressed because it is too large Load Diff

64
sources/MVCFramework.ActiveRecord.pas
View File

@ -26,6 +26,7 @@ unit MVCFramework.ActiveRecord;
{$I dmvcframework.inc}
interface
uses
@ -61,10 +62,23 @@ type
EMVCActiveRecordVersionedItemNotFound = class(EMVCActiveRecordNotFound)
end;
EMVCActiveRecordTransactionContext = class(EMVCActiveRecord)
end;
TMVCActiveRecordClass = class of TMVCActiveRecord;
TMVCActiveRecord = class;
{$IF Defined(CUSTOM_MANAGED_RECORDS)}
TMVCTransactionContext = record
private
fConnection: TFDConnection;
public
class operator Finalize(var Dest: TMVCTransactionContext);
class operator Assign (var Dest: TMVCTransactionContext; const [ref] Src: TMVCTransactionContext);
constructor Create(Dummy: Integer); overload;
end;
{$ENDIF}
TMVCActiveRecordFieldOption = (
/// <summary>
@ -588,6 +602,9 @@ type
class function All<T: TMVCActiveRecord, constructor>: TObjectList<T>; overload;
class function DeleteRQL<T: TMVCActiveRecord>(const RQL: string = ''): Int64; overload;
class function Count<T: TMVCActiveRecord>(const RQL: string = ''): Int64; overload;
{$IF Defined(CUSTOM_MANAGED_RECORDS)}
class function UseTransactionContext: TMVCTransactionContext;
{$ENDIF}
{ Where }
class function Where<T: TMVCActiveRecord, constructor>(const SQLWhere: string;
@ -1780,7 +1797,8 @@ begin
if not lFound then
begin
if RaiseExceptionIfNotFound then
raise EMVCActiveRecordNotFound.Create('No data found')
raise EMVCActiveRecordNotFound.CreateFmt('No data found for key [Entity: %s][PK: %s]',
[aActiveRecord.ClassName, aActiveRecord.fTableMap.fPrimaryKeyFieldName])
else
FreeAndNil(Result);
end;
@ -2216,6 +2234,13 @@ begin
end;
end;
{$IF Defined(CUSTOM_MANAGED_RECORDS)}
class function TMVCActiveRecordHelper.UseTransactionContext: TMVCTransactionContext;
begin
Result := TMVCTransactionContext.Create(0);
end;
{$ENDIF}
class function TMVCActiveRecordHelper.TryGetRQLQuery<T>(
const QueryName: String; out NamedRQLQuery: TRQLQueryWithName): Boolean;
var
@ -4759,6 +4784,43 @@ begin
Create(True);
end;
{ TMVCTransactionContext }
{$IF Defined(CUSTOM_MANAGED_RECORDS)}
constructor TMVCTransactionContext.Create(Dummy: Integer);
begin
fConnection := nil;
end;
class operator TMVCTransactionContext.Assign(var Dest: TMVCTransactionContext; const [ref] Src: TMVCTransactionContext);
begin
if Assigned(Src.fConnection) then
begin
Dest.fConnection := nil;
raise EMVCActiveRecordTransactionContext.Create('Transaction Context cannot be copied nor passed by value');
end;
Dest.fConnection := TMVCActiveRecord.CurrentConnection;
Dest.fConnection.StartTransaction;
end;
class operator TMVCTransactionContext.Finalize(var Dest: TMVCTransactionContext);
begin
if Dest.fConnection <> nil then
begin
if ExceptAddr <> nil then
begin
Dest.fConnection.Rollback;
end
else
begin
Dest.fConnection.Commit;
end;
end;
end;
{$ENDIF}
initialization
gConnectionsLock := TObject.Create;

12
sources/MVCFramework.Commons.pas
View File

@ -43,7 +43,7 @@ uses
System.Generics.Collections,
MVCFramework.DuckTyping,
JsonDataObjects,
MVCFramework.DotEnv;
MVCFramework.DotEnv, MVCFramework.Container;
{$I dmvcframeworkbuildconsts.inc}
@ -564,6 +564,7 @@ type
constructor Create;
destructor Destroy; override;
procedure Freeze;
function Frozen: Boolean;
function Keys: TArray<string>;
function ToString: string; override;
procedure SaveToFile(const AFileName: string);
@ -766,7 +767,6 @@ type
function dotEnv: IMVCDotEnv; overload;
procedure dotEnvConfigure(const dotEnvDelegate: TFunc<IMVCDotEnv>);
implementation
uses
@ -780,11 +780,11 @@ uses
var
GlobalAppName, GlobalAppPath, GlobalAppExe: string;
var
GdotEnv: IMVCDotEnv = nil;
GdotEnvDelegate: TFunc<IMVCDotEnv> = nil;
function URLEncode(const Value: string): string; overload;
begin
{$IF defined(BERLINORBETTER)}
@ -1060,6 +1060,11 @@ begin
FFreezed := True;
end;
function TMVCConfig.Frozen: Boolean;
begin
Result := FFreezed;
end;
function TMVCConfig.GetValue(const AIndex: string): string;
begin
if FConfig.ContainsKey(AIndex) then
@ -1761,6 +1766,7 @@ begin
Result := ReasonStringByHTTPStatusCode(HTTPStatusCode);
end;
procedure dotEnvConfigure(const dotEnvDelegate: TFunc<IMVCDotEnv>);
begin
if GdotEnv <> nil then

366
sources/MVCFramework.Container.pas Normal file
View File

@ -0,0 +1,366 @@
unit MVCFramework.Container;
interface
uses
System.Generics.Collections, System.Rtti, System.SysUtils, System.TypInfo;
type
{$SCOPEDENUMS ON}
TRegistrationType = (Transient, Singleton, SingletonPerRequest);
TClassOfInterfacedObject = class of TInterfacedObject;
IMVCServiceContainerResolver = interface
['{2C920EC2-001F-40BE-9911-43A65077CADD}']
function Resolve(const aTypeInfo: PTypeInfo; const aName: string = ''): IInterface; overload;
end;
IMVCServiceContainer = interface
['{1BB3F4A8-DDA1-4526-981C-A0BF877CFFD5}']
function RegisterType(const aImplementation: TClassOfInterfacedObject; const aInterface: TGUID; const aName : string = ''; const aRegType: TRegistrationType = TRegistrationType.Transient): IMVCServiceContainer; overload;
procedure Build();
end;
EMVCContainerError = class(Exception) end;
EMVCContainerErrorUnknownService = class(EMVCContainerError) end;
EMVCContainerErrorInterfaceNotSupported = class(EMVCContainerError) end;
EMVCContainerErrorUnknownConstructor = class(EMVCContainerError) end;
function DefaultMVCServiceContainer: IMVCServiceContainer;
function NewMVCServiceContainer: IMVCServiceContainer;
function NewServiceContainerResolver: IMVCServiceContainerResolver; overload;
function NewServiceContainerResolver(Container: IMVCServiceContainer): IMVCServiceContainerResolver; overload;
implementation
uses
MVCFramework.Rtti.Utils, MVCFramework;
type
IMVCServiceInternalResolver = interface
['{81527509-BA94-48C1-A030-E26F1FC9BFF5}']
function Resolve(const ServiceContainerResolver: IMVCServiceContainerResolver; const aTypeInfo: PTypeInfo; const aName: string = ''): IInterface;
function ResolveEx(const ServiceContainerResolver: IMVCServiceContainerResolver; const aTypeInfo: PTypeInfo; const aName: string; out ServiceKey: String; out RegType: TRegistrationType): IInterface; overload;
end;
TRegistration = class
public
Intf: TGUID;
Clazz: TClassOfInterfacedObject;
RttiType: TRttiType;
Instance: IInterface;
RegistrationType: TRegistrationType;
end;
TMVCServiceContainer = class(TInterfacedObject, IMVCServiceContainer, IMVCServiceInternalResolver)
private
fBuilt: Boolean;
fRegistry: TObjectDictionary<string, TRegistration>;
function CreateServiceWithDependencies(
const ServiceContainerResolver: IMVCServiceContainerResolver;
const ServiceClass: TClassOfInterfacedObject;
const ConstructorMethod: TRttiMethod): TInterfacedObject;
protected
class function GetKey(const aGUID: TGUID; const aName: String): String;
constructor Create; virtual;
destructor Destroy; override;
public
function RegisterType(const aImplementation: TClassOfInterfacedObject; const aInterface: TGUID; const aName : string = ''; const aRegType: TRegistrationType = TRegistrationType.Transient): IMVCServiceContainer; overload;
function Resolve(const ServiceContainerResolver: IMVCServiceContainerResolver; const aTypeInfo: PTypeInfo; const aName: string = ''): IInterface; overload;
function ResolveEx(const ServiceContainerResolver: IMVCServiceContainerResolver; const aTypeInfo: PTypeInfo; const aName: string; out ServiceKey: String; out RegType: TRegistrationType): IInterface; overload;
procedure Build();
end;
TMVCServiceContainerAdapter = class(TInterfacedObject, IMVCServiceContainerResolver)
private
fCachedServices: TDictionary<String, IInterface>;
fContainer: IMVCServiceInternalResolver;
protected
function Resolve(const aTypeInfo: PTypeInfo; const aName: string = ''): IInterface; overload;
public
constructor Create(Container: IMVCServiceContainer);
destructor Destroy; override;
end;
var
gDefaultMVCServiceContainer: IMVCServiceContainer = nil;
gLock: TObject = nil;
{ TMVCServiceContainer }
function TMVCServiceContainer.CreateServiceWithDependencies(
const ServiceContainerResolver: IMVCServiceContainerResolver;
const ServiceClass: TClassOfInterfacedObject;
const ConstructorMethod: TRttiMethod): TInterfacedObject;
var
lActionFormalParams: TArray<TRttiParameter>;
lActualParams: TArray<TValue>;
I: Integer;
lIntf, lOutIntf: IInterface;
begin
if ConstructorMethod <> nil then
begin
lActionFormalParams := ConstructorMethod.GetParameters;
SetLength(lActualParams, Length(lActionFormalParams));
if Length(lActionFormalParams) > 0 then
begin
for I := 0 to Length(lActionFormalParams) - 1 do
begin
if ServiceContainerResolver = nil then
lIntf := Resolve(nil, lActionFormalParams[I].ParamType.Handle)
else
lIntf := ServiceContainerResolver.Resolve(lActionFormalParams[I].ParamType.Handle);
if not Supports(lIntf, lActionFormalParams[I].ParamType.Handle.TypeData.GUID, lOutIntf) then
begin
raise EMVCContainerError.CreateFmt('Cannot inject parameter %s: %s into constructor of %s', [
lActionFormalParams[I].name,
lActionFormalParams[I].ParamType.ToString,
ServiceClass.ClassName
]);
end;
TValue.Make(@lOutIntf, lActionFormalParams[I].ParamType.Handle, lActualParams[I]);
end;
end;
Result := TInterfacedObject(ConstructorMethod.Invoke(ServiceClass, lActualParams).AsObject);
end
else
begin
Result := TInterfacedObject(TRttiUtils.CreateObject(ServiceClass.QualifiedClassName));
end;
end;
constructor TMVCServiceContainer.Create;
begin
inherited;
fRegistry := TObjectDictionary<String, TRegistration>.Create([doOwnsValues]);
fBuilt := False;
end;
destructor TMVCServiceContainer.Destroy;
begin
fRegistry.Free;
inherited;
end;
class function TMVCServiceContainer.GetKey(const aGUID: TGUID; const aName: String): String;
begin
Result := aGUID.ToString + '_' + aName;
end;
function TMVCServiceContainer.RegisterType(const aImplementation: TClassOfInterfacedObject; const aInterface: TGUID;
const aName: string; const aRegType: TRegistrationType): IMVCServiceContainer;
var
lReg: TRegistration;
begin
if fBuilt then
begin
raise EMVCContainerError.Create('Cannot register new service if the container has been already built');
end;
if Supports(aImplementation, aInterface) then
begin
lReg := TRegistration.Create;
lReg.Clazz := aImplementation;
lReg.RttiType := TRttiUtils.GlContext.GetType(lReg.Clazz);
lReg.RegistrationType := aRegType;
if not fRegistry.TryAdd(GetKey(aInterface, aName), lReg) then
begin
raise EMVCContainerError.CreateFmt('Cannot register duplicated service "%s"',[GetKey(aInterface, aName)]);
end;
end
else
begin
raise EMVCContainerErrorUnknownService.CreateFmt('"%s" doesn''t supports requested interface', [aImplementation.QualifiedClassName]);
end;
Result := Self;
end;
function TMVCServiceContainer.Resolve(const ServiceContainerResolver: IMVCServiceContainerResolver; const aTypeInfo: PTypeInfo; const aName: string): IInterface;
var
lReg: TRegistration;
lTypeInfo: PTypeInfo;
lType: TRttiType;
lService: TObject;
begin
if not fBuilt then
begin
raise EMVCContainerError.Create('Container has not been built');
end;
lTypeInfo := aTypeInfo;
if not fRegistry.TryGetValue(GetKey(lTypeInfo.TypeData.GUID, aName), lReg) then
begin
raise EMVCContainerErrorUnknownService.CreateFmt('Unknown service "%s" with name "%s"', [lTypeInfo.Name, aName])
end;
lType := lReg.RttiType;
case lReg.RegistrationType of
TRegistrationType.Transient, TRegistrationType.SingletonPerRequest:
begin
lService := CreateServiceWithDependencies(ServiceContainerResolver, lReg.Clazz, TRttiUtils.GetFirstDeclaredConstructor(lType));
Supports(lService, lTypeInfo.TypeData.GUID, Result);
end;
TRegistrationType.Singleton:
begin
if lReg.Instance = nil then
begin
TMonitor.Enter(Self);
try
if lReg.Instance = nil then
begin
lService := CreateServiceWithDependencies(ServiceContainerResolver, lReg.Clazz, TRttiUtils.GetFirstDeclaredConstructor(lType));
Supports(lService, lTypeInfo.TypeData.GUID, lReg.Instance)
end;
finally
TMonitor.Exit(Self)
end;
end;
Supports(lReg.Instance, lTypeInfo.TypeData.GUID, Result);
end;
else
raise EMVCContainerError.Create('Unsupported RegistrationType');
end;
end;
function TMVCServiceContainer.ResolveEx(const ServiceContainerResolver: IMVCServiceContainerResolver; const aTypeInfo: PTypeInfo; const aName: string;
out ServiceKey: String; out RegType: TRegistrationType): IInterface;
var
lReg: TRegistration;
lTypeInfo: PTypeInfo;
lType: TRttiType;
lService: TObject;
lServiceKey: string;
begin
if not fBuilt then
begin
raise EMVCContainerError.Create('Container has not been built');
end;
lTypeInfo := aTypeInfo;
lServiceKey := GetKey(lTypeInfo.TypeData.GUID, aName);
if not fRegistry.TryGetValue(lServiceKey, lReg) then
begin
raise EMVCContainerErrorUnknownService.CreateFmt('Unknown service "%s" with name "%s"', [lTypeInfo.Name, aName])
end;
lType := lReg.RttiType;
RegType := lReg.RegistrationType;
ServiceKey := lServiceKey;
case lReg.RegistrationType of
TRegistrationType.Transient, TRegistrationType.SingletonPerRequest:
begin
lService := CreateServiceWithDependencies(ServiceContainerResolver, lReg.Clazz, TRttiUtils.GetFirstDeclaredConstructor(lType));
Supports(lService, lTypeInfo.TypeData.GUID, Result);
{rtSingletonPerRequest is destroyed by the adapter owned by Context}
end;
TRegistrationType.Singleton:
begin
if lReg.Instance = nil then
begin
TMonitor.Enter(Self);
try
if lReg.Instance = nil then
begin
lService := CreateServiceWithDependencies(ServiceContainerResolver, lReg.Clazz, TRttiUtils.GetFirstDeclaredConstructor(lType));
Supports(lService, lTypeInfo.TypeData.GUID, lReg.Instance)
end;
finally
TMonitor.Exit(Self)
end;
end;
Supports(lReg.Instance, lTypeInfo.TypeData.GUID, Result);
end;
else
raise EMVCContainerError.Create('Unsupported RegistrationType');
end;
end;
procedure TMVCServiceContainer.Build;
begin
fBuilt := True;
end;
function DefaultMVCServiceContainer: IMVCServiceContainer;
begin
if gDefaultMVCServiceContainer = nil then
begin
TMonitor.Enter(gLock);
try
if gDefaultMVCServiceContainer = nil then
begin
gDefaultMVCServiceContainer := TMVCServiceContainer.Create;
end;
finally
TMonitor.Exit(gLock);
end;
end;
Result := gDefaultMVCServiceContainer;
end;
function NewMVCServiceContainer: IMVCServiceContainer;
begin
Result := TMVCServiceContainer.Create;
end;
{ TMVCServiceContainerAdapter }
constructor TMVCServiceContainerAdapter.Create(Container: IMVCServiceContainer);
begin
inherited Create;
fCachedServices := TDictionary<String, IInterface>.Create;
fContainer := Container as IMVCServiceInternalResolver;
end;
destructor TMVCServiceContainerAdapter.Destroy;
begin
fCachedServices.Free;
inherited;
end;
function TMVCServiceContainerAdapter.Resolve(const aTypeInfo: PTypeInfo; const aName: string): IInterface;
var
lKey: string;
lIntf: IInterface;
lRegType: TRegistrationType;
begin
lKey := TMVCServiceContainer.GetKey(aTypeInfo.TypeData.GUID, aName);
if fCachedServices.TryGetValue(lKey, lIntf) then
begin
Supports(lIntf, aTypeInfo.TypeData.GUID, Result);
end
else
begin
Result := fContainer.ResolveEx(Self, aTypeInfo, aName, lKey, lRegType);
if lRegType = TRegistrationType.SingletonPerRequest then
begin
fCachedServices.Add(lKey, Result);
end;
end;
end;
function NewServiceContainerResolver: IMVCServiceContainerResolver;
begin
Result := TMVCServiceContainerAdapter.Create(DefaultMVCServiceContainer);
end;
function NewServiceContainerResolver(Container: IMVCServiceContainer) : IMVCServiceContainerResolver;
begin
Result := TMVCServiceContainerAdapter.Create(Container);
end;
initialization
gLock := TObject.Create;
finalization
gLock.Free;
end.

2
sources/MVCFramework.RQL.Parser.pas
View File

@ -315,7 +315,7 @@ begin
end;
if lMsg.Trim.IsEmpty then
lMsg := '<EOF>';
raise ERQLException.CreateFmt('[Error] %s (column %d - found %s)', [message, fCurIdx, lMsg]);
raise ERQLException.CreateFmt('[Error] %s (column %d - found %s)', [message, fCurIdx, lMsg]) at AddressOfReturnAddress;
end;
procedure TRQL2SQL.Execute(

15
sources/MVCFramework.Router.pas
View File

@ -58,6 +58,7 @@ type
FMethodToCall: TRttiMethod;
FControllerClazz: TMVCControllerClazz;
FControllerCreateAction: TMVCControllerCreateAction;
FControllerInjectableConstructor: TRttiMethod;
FActionParamsCache: TMVCStringObjectDictionary<TMVCActionParamCacheItem>;
function GetAttribute<T: TCustomAttribute>(const AAttributes: TArray<TCustomAttribute>): T;
function GetFirstMediaType(const AContentType: string): string;
@ -106,13 +107,14 @@ type
property MethodToCall: TRttiMethod read FMethodToCall;
property ControllerClazz: TMVCControllerClazz read FControllerClazz;
property ControllerCreateAction: TMVCControllerCreateAction read FControllerCreateAction;
property ControllerInjectableConstructor: TRttiMethod read FControllerInjectableConstructor;
end;
implementation
uses
System.TypInfo,
System.NetEncoding;
System.NetEncoding, MVCFramework.Rtti.Utils, MVCFramework.Container;
{ TMVCRouter }
@ -160,6 +162,8 @@ var
LProduceAttribute: MVCProducesAttribute;
lURLSegment: string;
LItem: String;
lConstructors: TArray<TRttiMethod>;
lConstructor: TRttiMethod;
// JUST FOR DEBUG
// lMethodCompatible: Boolean;
// lContentTypeCompatible: Boolean;
@ -268,6 +272,15 @@ begin
FMethodToCall := LMethod;
FControllerClazz := LControllerDelegate.Clazz;
FControllerCreateAction := LControllerDelegate.CreateAction;
FControllerInjectableConstructor := nil;
// select the constructor with the most mumber of parameters
if not Assigned(FControllerCreateAction) then
begin
FControllerInjectableConstructor := TRttiUtils.GetConstructorWithAttribute<MVCInjectAttribute>(LRttiType);
end;
// end - select the constructor with the most mumber of parameters
LProduceAttribute := GetAttribute<MVCProducesAttribute>(LAttributes);
if LProduceAttribute <> nil then
begin

40
sources/MVCFramework.Rtti.Utils.pas
View File

@ -34,7 +34,7 @@ uses
System.Rtti,
System.Generics.Collections,
System.SysUtils,
Data.DB;
Data.DB, MVCFramework.Logger;
type
@ -90,6 +90,8 @@ type
class function FindType(AQualifiedName: string): TRttiType;
class function GetGUID<T>: TGUID;
class function GetArrayContainedRTTIType(const RTTIType: TRttiType): TRttiType;
class function GetConstructorWithAttribute<T:TCustomAttribute>(const RTTIType: TRttiType): TRttiMethod;
class function GetFirstDeclaredConstructor(const RTTIType: TRttiType): TRttiMethod;
end;
{$IF not defined(BERLINORBETTER)}
@ -105,7 +107,7 @@ implementation
uses
MVCFramework.DuckTyping,
MVCFramework.Serializer.Commons;
MVCFramework.Serializer.Commons, MVCFramework.Commons;
class function TRttiUtils.MethodCall(AObject: TObject; AMethodName: string; AParameters: array of TValue;
ARaiseExceptionIfNotFound: Boolean): TValue;
@ -180,6 +182,40 @@ begin
end;
end;
class function TRttiUtils.GetConstructorWithAttribute<T>(const RTTIType: TRttiType): TRttiMethod;
var
lConstructors: TArray<TRttiMethod>;
lConstructor: TRttiMethod;
begin
Result := nil;
lConstructors := RttiType.GetMethods('Create');
for lConstructor in lConstructors do
begin
if lConstructor.HasAttribute<T> then
begin
Result := lConstructor;
break; { the first wins }
end;
end;
end;
class function TRttiUtils.GetFirstDeclaredConstructor(const RTTIType: TRttiType): TRttiMethod;
var
lConstructors: TArray<TRttiMethod>;
lConstructor: TRttiMethod;
begin
Result := nil;
lConstructors := RttiType.GetDeclaredMethods;
for lConstructor in lConstructors do
begin
if lConstructor.IsConstructor and (lConstructor.Visibility = TMembervisibility.mvPublic) then
begin
Result := lConstructor;
Break;
end;
end;
end;
class function TRttiUtils.GetField(AObject: TObject; const APropertyName: string): TValue;
var
Field: TRttiField;

369
sources/MVCFramework.pas
View File

@ -54,6 +54,7 @@ uses
MVCFramework.Session,
MVCFramework.DuckTyping,
MVCFramework.Logger,
MVCFramework.Container,
MVCFramework.ApplicationSession,
MVCFramework.Serializer.Intf,
@ -337,6 +338,14 @@ type
end;
MVCInjectAttribute = class(TCustomAttribute)
private
fServiceName: String;
public
constructor Create(ServiceName: String = '');
property ServiceName: String read fServiceName;
end;
// test
// TMVCHackHTTPAppRequest = class(TIdHTTPAppRequest)
// private
@ -522,16 +531,17 @@ type
TWebContext = class
private
FRequest: TMVCWebRequest;
FResponse: TMVCWebResponse;
FConfig: TMVCConfig;
FSerializers: TDictionary<string, IMVCSerializer>;
FIsSessionStarted: Boolean;
FSessionMustBeClose: Boolean;
FLoggedUser: TUser;
FWebSession: TMVCWebSession;
FData: TMVCStringDictionary;
fRequest: TMVCWebRequest;
fResponse: TMVCWebResponse;
fConfig: TMVCConfig;
fSerializers: TDictionary<string, IMVCSerializer>;
fIsSessionStarted: Boolean;
fSessionMustBeClose: Boolean;
fLoggedUser: TUser;
fWebSession: TMVCWebSession;
fData: TMVCStringDictionary;
fIntfObject: IInterface;
fServiceContainerResolver: IMVCServiceContainerResolver;
function GetWebSession: TMVCWebSession;
function GetLoggedUser: TUser;
function GetParamsTable: TMVCRequestParamsTable;
@ -548,7 +558,7 @@ type
const ASessionTimeout: Integer): TMVCWebSession;
function GetData: TMVCStringDictionary;
public
constructor Create(const ARequest: TWebRequest; const AResponse: TWebResponse;
constructor Create(const AServiceContainerResolver: IMVCServiceContainerResolver; const ARequest: TWebRequest; const AResponse: TWebResponse;
const AConfig: TMVCConfig; const ASerializers: TDictionary<string, IMVCSerializer>);
destructor Destroy; override;
@ -570,6 +580,7 @@ type
property CustomIntfObject: IInterface read GetIntfObject write SetIntfObject;
property ParamsTable: TMVCRequestParamsTable read GetParamsTable write SetParamsTable;
property ActionQualifiedName: String read fActionQualifiedName;
property ServiceContainerResolver: IMVCServiceContainerResolver read fServiceContainerResolver;
end;
TMVCJSONRPCExceptionErrorInfo = record
@ -664,12 +675,37 @@ type
var AIsAuthorized: Boolean);
end;
// std responses
IMVCResponse = interface
['{9DFEC741-EE38-4AC9-9C2C-9EA0D15D08D5}']
function GetData: TObject;
function GetMessage: string;
function GetStatusCode: Integer;
function GetHeaders: TStringList;
procedure SetData(const Value: TObject);
procedure SetMessage(const Value: string);
procedure SetHeaders(const Headers: TStringList);
procedure SetObjectDictionary(const Value: IMVCObjectDictionary);
function GetObjectDictionary: IMVCObjectDictionary;
procedure SetStatusCode(const Value: Integer);
function GetIgnoredList: TMVCIgnoredList;
function HasHeaders: Boolean;
function HasBody: Boolean;
property StatusCode: Integer read GetStatusCode write SetStatusCode;
property Message: string read GetMessage write SetMessage;
property Data: TObject read GetData write SetData;
property ObjectDictionary: IMVCObjectDictionary read GetObjectDictionary write SetObjectDictionary;
property Headers: TStringList read GetHeaders write SetHeaders;
end;
TMVCRenderer = class(TMVCBase)
protected
FContext: TWebContext;
FContentCharset: string;
FResponseStream: TStringBuilder;
function ToMVCList(const AObject: TObject; AOwnsObject: Boolean = False): IMVCList;
function StatusCodeResponseWithOptionalBody(const StatusCode: Word; const Body: TObject): IMVCResponse;
public { this must be public because of entity processors }
function GetContentType: string;
function GetStatusCode: Integer;
@ -679,6 +715,9 @@ type
procedure Redirect(const AUrl: string); virtual;
procedure ResponseStatus(const AStatusCode: Integer; const AReasonString: string = ''); virtual;
class procedure InternalRenderMVCResponse(const Controller: TMVCRenderer; const MVCResponse: TMVCResponse);
////////////////////////////////////////////////////////////////////////////
///
/// <summary>
/// HTTP Status 201 indicates that as a result of HTTP POST request, one or more new resources have been successfully created on server.
/// The response may contain URI in Location header field in HTTP headers list, which can have reference to the newly created resource. Also, response payload also may include an entity containing a list of resource characteristics and location(s) from which the user or user agent can choose the one most appropriate.
@ -688,7 +727,36 @@ type
/// https://restfulapi.net/http-status-201-created/
/// </remarks>
procedure Render201Created(const Location: string = '';
const Reason: string = ''); virtual;
const Reason: string = ''); virtual; deprecated;
//Response Result
{
BadRequestResult
ConflictResult
NoContentResult
NotFoundResult
OkResult
UnauthorizedResult
UnprocessableEntityResult
UnsupportedMediaTypeResult
ConflictResult
InternalServerErrorResult
}
function OKResponse(const Body: TObject): IMVCResponse; overload;
function OKResponse: IMVCResponse; overload;
function NotFoundResponse(const Body: TObject): IMVCResponse; overload;
function NotFoundResponse: IMVCResponse; overload;
function NoContentResponse: IMVCResponse;
function UnauthorizedResponse: IMVCResponse;
function BadRequestResponse: IMVCResponse; overload;
function BadRequestResponse(const Error: TObject): IMVCResponse; overload;
function CreatedResponse(const Location: string = ''; const Body: TObject = nil): IMVCResponse;
function AcceptedResponse(const Location: string = ''; const Body: TObject = nil): IMVCResponse;
function ConflictResult: IMVCResponse;
function InternalServerErrorResponse: IMVCResponse;
/// <summary>
/// Allow a server to accept a request for some other process (perhaps a batch-oriented process that is only run once per day) without requiring that the user agent’s connection to the server persist until the process is completed.
/// The entity returned with this response SHOULD describe the request’s current status and point to (or embed) a status monitor that can provide the user with (or without) an estimate of when the request will be fulfilled.
@ -697,13 +765,18 @@ type
/// https://restfulapi.net/http-status-202-accepted/
/// </remarks>
procedure Render202Accepted(const HREF: string; const ID: string;
const Reason: string = 'Accepted'); virtual;
const Reason: string = 'Accepted'); virtual; deprecated;
/// <summary>
/// HTTP Status 204 (No Content) indicates that the server has successfully fulfilled the request and that there is no content to send in the response payload body. The server might want to return updated meta information in the form of entity-headers, which if present SHOULD be applied to current document’s active view if any.
/// The 204 response MUST NOT include a message-body and thus is always terminated by the first empty line after the header fields.
/// </summary>
procedure Render204NoContent(const Location: string = '';
const Reason: string = ''); virtual;
const Reason: string = ''); virtual; deprecated;
////////////////////////////////////////////////////////////////////////////
function Serializer: IMVCSerializer; overload;
function Serializer(const AContentType: string;
const ARaiseExceptionIfNotExists: Boolean = True): IMVCSerializer; overload;
@ -962,22 +1035,22 @@ type
ALLOWED_TYPED_ACTION_PARAMETERS_TYPES =
'Integer, Int64, Single, Double, Extended, Boolean, TDate, TTime, TDateTime, String and TGUID';
private
FViewEngineClass: TMVCViewEngineClass;
FWebModule: TWebModule;
FConfig: TMVCConfig;
FConfigCache_MaxRequestSize: Int64;
FConfigCache_ExposeServerSignature: Boolean;
FConfigCache_ServerSignature: string;
FConfigCache_ExposeXPoweredBy: Boolean;
FConfigCache_DefaultContentType: String;
FConfigCache_DefaultContentCharset: String;
FConfigCache_PathPrefix: String;
FSerializers: TDictionary<string, IMVCSerializer>;
FMiddlewares: TList<IMVCMiddleware>;
FControllers: TObjectList<TMVCControllerDelegate>;
FApplicationSession: TWebApplicationSession;
FSavedOnBeforeDispatch: THTTPMethodEvent;
FOnException: TMVCExceptionHandlerProc;
fViewEngineClass: TMVCViewEngineClass;
fWebModule: TWebModule;
fConfig: TMVCConfig;
fConfigCache_MaxRequestSize: Int64;
fConfigCache_ExposeServerSignature: Boolean;
fConfigCache_ServerSignature: string;
fConfigCache_ExposeXPoweredBy: Boolean;
fConfigCache_DefaultContentType: String;
fConfigCache_DefaultContentCharset: String;
fConfigCache_PathPrefix: String;
fSerializers: TDictionary<string, IMVCSerializer>;
fMiddlewares: TList<IMVCMiddleware>;
fControllers: TObjectList<TMVCControllerDelegate>;
fApplicationSession: TWebApplicationSession;
fSavedOnBeforeDispatch: THTTPMethodEvent;
fOnException: TMVCExceptionHandlerProc;
fOnRouterLog: TMVCRouterLogHandlerProc;
fWebContextCreateEvent: TWebContextCreateEvent;
fWebContextDestroyEvent: TWebContextDestroyEvent;
@ -988,6 +1061,9 @@ type
function GetViewEngineClass: TMVCViewEngineClass;
procedure HandleDefaultValueForInjectedParameter(var InjectedParamValue: String;
const InjectableParamAttribute: MVCInjectableParamAttribute);
// procedure FillActualParamsForConstructor(
// const AActionFormalParams: TArray<TRttiParameter>;
// var AActualParams: TArray<TValue>);
protected
procedure DoWebContextCreateEvent(const AContext: TWebContext); inline;
procedure DoWebContextDestroyEvent(const AContext: TWebContext); inline;
@ -1014,6 +1090,10 @@ type
const AResponse: TWebResponse); virtual;
function ExecuteAction(const ASender: TObject; const ARequest: TWebRequest;
const AResponse: TWebResponse): Boolean; virtual;
function CreateControllerWithDependencies(
const Context: TWebContext;
const ControllerClass: TMVCControllerClazz;
const ConstructorMethod: TRttiMethod): TMVCController;
public
class function GetCurrentSession(const ASessionId: string;
const ARaiseExceptionIfExpired: Boolean = True): TMVCWebSession; static;
@ -1054,7 +1134,6 @@ type
property ViewEngineClass: TMVCViewEngineClass read GetViewEngineClass;
property WebModule: TWebModule read FWebModule;
property Config: TMVCConfig read FConfig;
//property Serializers: TDictionary<string, IMVCSerializer> read FSerializers;
property Middlewares: TList<IMVCMiddleware> read FMiddlewares;
property Controllers: TObjectList<TMVCControllerDelegate> read FControllers;
property ApplicationSession: TWebApplicationSession read FApplicationSession
@ -1074,29 +1153,6 @@ type
end;
// std responses
IMVCResponse = interface
['{9DFEC741-EE38-4AC9-9C2C-9EA0D15D08D5}']
function GetData: TObject;
function GetMessage: string;
function GetStatusCode: Integer;
function GetHeaders: TStringList;
procedure SetData(const Value: TObject);
procedure SetMessage(const Value: string);
procedure SetHeaders(const Headers: TStringList);
procedure SetObjectDictionary(const Value: IMVCObjectDictionary);
function GetObjectDictionary: IMVCObjectDictionary;
procedure SetStatusCode(const Value: Integer);
function GetIgnoredList: TMVCIgnoredList;
function HasHeaders: Boolean;
function HasBody: Boolean;
property StatusCode: Integer read GetStatusCode write SetStatusCode;
property Message: string read GetMessage write SetMessage;
property Data: TObject read GetData write SetData;
property ObjectDictionary: IMVCObjectDictionary read GetObjectDictionary write SetObjectDictionary;
property Headers: TStringList read GetHeaders write SetHeaders;
end;
TMVCBaseResponse = class abstract (TInterfacedObject, IMVCResponse)
protected
@ -2102,10 +2158,11 @@ begin
raise EMVCException.Create('Session already bounded for this request');
end;
constructor TWebContext.Create(const ARequest: TWebRequest; const AResponse: TWebResponse;
constructor TWebContext.Create(const AServiceContainerResolver: IMVCServiceContainerResolver; const ARequest: TWebRequest; const AResponse: TWebResponse;
const AConfig: TMVCConfig; const ASerializers: TDictionary<string, IMVCSerializer>);
begin
inherited Create;
FServiceContainerResolver := AServiceContainerResolver;
FIsSessionStarted := False;
FSessionMustBeClose := False;
FWebSession := nil;
@ -2506,6 +2563,65 @@ begin
LoadSystemControllers;
end;
//procedure TMVCEngine.FillActualParamsForConstructor(
// const AActionFormalParams: TArray<TRttiParameter>;
// var AActualParams: TArray<TValue>);
//var
// lParamName: string;
// I: Integer;
// lIntf, lOutIntf: IInterface;
//begin
// SetLength(AActualParams, Length(AActionFormalParams));
// for I := 0 to Length(AActionFormalParams) - 1 do
// begin
// lParamName := AActionFormalParams[I].name;
// lIntf := fServiceContainer.Resolve(AActionFormalParams[I].ParamType.Handle);
// if not Supports(lIntf, AActionFormalParams[I].ParamType.Handle.TypeData.GUID, lOutIntf) then
// begin
// raise EMVCException.Create('Cannot inject ' + AActionFormalParams[I].Name + ' into constructor ' + );
// end;
// TValue.Make(@lOutIntf, AActionFormalParams[I].ParamType.Handle, AActualParams[I]);
// end;
//end;
//
function TMVCEngine.CreateControllerWithDependencies(
const Context: TWebContext;
const ControllerClass: TMVCControllerClazz;
const ConstructorMethod: TRttiMethod): TMVCController;
var
lActionFormalParams: TArray<TRttiParameter>;
lActualParams: TArray<TValue>;
I: Integer;
lIntf, lOutIntf: IInterface;
lInjectAttribute: MVCInjectAttribute;
lServiceName: string;
begin
lActionFormalParams := ConstructorMethod.GetParameters;
SetLength(lActualParams, Length(lActionFormalParams));
if Length(lActionFormalParams) > 0 then
begin
for I := 0 to Length(lActionFormalParams) - 1 do
begin
lServiceName := '';
lInjectAttribute := lActionFormalParams[I].GetAttribute<MVCInjectAttribute>;
if lInjectAttribute <> nil then
begin
lServiceName := lInjectAttribute.ServiceName;
end;
if (lActionFormalParams[I].ParamType.TypeKind <> tkInterface) then
begin
raise EMVCException.CreateFmt('Parameter "%s" is not an interface type', [lActionFormalParams[i].ToString]);
end;
lIntf := Context.ServiceContainerResolver.Resolve(lActionFormalParams[I].ParamType.Handle, lServiceName);
Supports(lIntf, lActionFormalParams[I].ParamType.Handle.TypeData.GUID, lOutIntf);
TValue.Make(@lOutIntf, lActionFormalParams[I].ParamType.Handle, lActualParams[I]);
end;
end;
Result := TMVCController(ConstructorMethod.Invoke(ControllerClass, lActualParams).AsObject);
end;
function TMVCEngine.CustomExceptionHandling(const Ex: Exception;
const ASelectedController: TMVCController; const AContext: TWebContext): Boolean;
begin
@ -2528,10 +2644,10 @@ end;
destructor TMVCEngine.Destroy;
begin
FConfig.Free;
FSerializers.Free;
FMiddlewares.Free;
FControllers.Free;
fConfig.Free;
fSerializers.Free;
fMiddlewares.Free;
fControllers.Free;
inherited Destroy;
end;
@ -2591,7 +2707,7 @@ begin
{$ENDIF}
lParamsTable := TMVCRequestParamsTable.Create;
try
lContext := TWebContext.Create(ARequest, AResponse, FConfig, FSerializers);
lContext := TWebContext.Create(NewServiceContainerResolver, ARequest, AResponse, FConfig, FSerializers);
try
DefineDefaultResponseHeaders(lContext);
DoWebContextCreateEvent(lContext);
@ -2612,17 +2728,28 @@ begin
lResponseContentCharset) then
begin
try
if Assigned(lRouter.ControllerCreateAction) then
lSelectedController := lRouter.ControllerCreateAction()
if lRouter.ControllerCreateAction <> nil then
begin
lSelectedController := lRouter.ControllerCreateAction();
end
else if lRouter.ControllerInjectableConstructor <> nil then
begin
lSelectedController := CreateControllerWithDependencies(
lContext,
lRouter.ControllerClazz,
lRouter.ControllerInjectableConstructor);
end
else
begin
lSelectedController := lRouter.ControllerClazz.Create;
end;
except
on Ex: Exception do
begin
Log.ErrorFmt('[%s] %s [PathInfo "%s"] (Custom message: "%s")',
[Ex.Classname, Ex.Message, GetRequestShortDescription(ARequest), 'Cannot create controller'], LOGGERPRO_TAG);
raise EMVCException.Create(http_status.InternalServerError,
'Cannot create controller');
'Cannot create controller (see log for more info)');
end;
end;
lRouterMethodToCallName := lRouter.MethodToCall.Name;
@ -2984,11 +3111,13 @@ var
lFromContentFieldAttribute: MVCFromContentFieldAttribute;
lFromHeaderAttribute: MVCFromHeaderAttribute;
lFromCookieAttribute: MVCFromCookieAttribute;
lInjectAttribute: MVCInjectAttribute;
lAttributeInjectedParamCount: Integer;
lInjectedParamValue: string;
lInjectedMultiParamValue: TArray<String>;
lList: IMVCList;
lItemClass: TClass;
lIntf, lOutIntf: IInterface;
begin
ABodyParameter := nil;
lAttributeInjectedParamCount := 0;
@ -3066,11 +3195,19 @@ begin
HandleDefaultValueForInjectedParameter(lInjectedParamValue, lFromCookieAttribute);
AActualParams[I] := GetActualParam(AActionFormalParams[I], lInjectedParamValue);
end
else if TRttiUtils.HasAttribute<MVCInjectAttribute>(AActionFormalParams[I],
lInjectAttribute) then
begin
Inc(lAttributeInjectedParamCount, 1);
lIntf := AContext.ServiceContainerResolver.Resolve(AActionFormalParams[I].ParamType.Handle, lInjectAttribute.ServiceName);
Supports(lIntf, AActionFormalParams[I].ParamType.Handle.TypeData.GUID, lOutIntf);
TValue.Make(@lOutIntf, AActionFormalParams[I].ParamType.Handle, AActualParams[I]);
end
else
begin
raise EMVCException.Create(http_status.InternalServerError,
'Unknown custom attribute on action parameter: ' + AActionFormalParams[I].name +
'. [HINT: Allowed attributes are MVCFromBody, MVCFromQueryString, MVCFromHeader, MVCFromCookie]');
'. [HINT: Allowed attributes are MVCFromBody, MVCFromQueryString, MVCFromHeader, MVCFromCookie, MVCInject]');
end;
Continue;
end;
@ -3804,6 +3941,55 @@ begin
'Hint: Messaging extensions require a valid clientid. Did you call /messages/clients/YOUR_CLIENT_ID ?');
end;
function TMVCRenderer.BadRequestResponse: IMVCResponse;
begin
Result := StatusCodeResponseWithOptionalBody(HTTP_STATUS.BadRequest, nil);
end;
function TMVCRenderer.AcceptedResponse(const Location: string;
const Body: TObject): IMVCResponse;
var
lRespBuilder: IMVCResponseBuilder;
begin
lRespBuilder := MVCResponseBuilder;
if not Location.IsEmpty then
begin
lRespBuilder.Header('location', Location)
end;
if Assigned(Body) then
begin
lRespBuilder.Body(Body, True);
end;
Result := lRespBuilder.StatusCode(HTTP_STATUS.Accepted).Build;
end;
function TMVCRenderer.BadRequestResponse(const Error: TObject): IMVCResponse;
begin
Result := StatusCodeResponseWithOptionalBody(HTTP_STATUS.BadRequest, Error);
end;
function TMVCRenderer.ConflictResult: IMVCResponse;
begin
Result := StatusCodeResponseWithOptionalBody(HTTP_STATUS.Conflict, nil);
end;
function TMVCRenderer.CreatedResponse(const Location: string;
const Body: TObject): IMVCResponse;
var
lRespBuilder: IMVCResponseBuilder;
begin
lRespBuilder := MVCResponseBuilder;
if not Location.IsEmpty then
begin
lRespBuilder.Header('location', Location)
end;
if Assigned(Body) then
begin
lRespBuilder.Body(Body, True);
end;
Result := lRespBuilder.StatusCode(HTTP_STATUS.Created).Build;
end;
function TMVCRenderer.GetContentType: string;
begin
Result := GetContext.Response.ContentType.Trim;
@ -3892,6 +4078,36 @@ end;
end;
function TMVCRenderer.InternalServerErrorResponse: IMVCResponse;
begin
Result := StatusCodeResponseWithOptionalBody(HTTP_STATUS.InternalServerError, nil);
end;
function TMVCRenderer.NoContentResponse: IMVCResponse;
begin
Result := StatusCodeResponseWithOptionalBody(HTTP_STATUS.NoContent, nil);
end;
function TMVCRenderer.NotFoundResponse: IMVCResponse;
begin
Result := StatusCodeResponseWithOptionalBody(HTTP_STATUS.NotFound, nil);
end;
function TMVCRenderer.NotFoundResponse(const Body: TObject): IMVCResponse;
begin
Result := StatusCodeResponseWithOptionalBody(HTTP_STATUS.NotFound, Body);
end;
function TMVCRenderer.OKResponse: IMVCResponse;
begin
Result := StatusCodeResponseWithOptionalBody(HTTP_STATUS.OK, nil);
end;
function TMVCRenderer.OKResponse(const Body: TObject): IMVCResponse;
begin
Result := StatusCodeResponseWithOptionalBody(HTTP_STATUS.OK, Body);
end;
function TMVCController.GetViewData(const aModelName: string): TValue;
begin
if not FViewModel.TryGetValue(aModelName, Result) then
@ -4176,11 +4392,28 @@ begin
GetContext.Response.StatusCode := AValue;
end;
function TMVCRenderer.StatusCodeResponseWithOptionalBody(const StatusCode: Word; const Body: TObject): IMVCResponse;
begin
if Body = nil then
begin
Result := MVCResponseBuilder.StatusCode(StatusCode).Build;
end
else
begin
Result := MVCResponseBuilder.StatusCode(StatusCode).Body(Body, True).Build;
end;
end;
function TMVCRenderer.ToMVCList(const AObject: TObject; AOwnsObject: Boolean): IMVCList;
begin
Result := MVCFramework.DuckTyping.WrapAsList(AObject, AOwnsObject);
end;
function TMVCRenderer.UnauthorizedResponse: IMVCResponse;
begin
Result := StatusCodeResponseWithOptionalBody(HTTP_STATUS.Unauthorized, nil);
end;
procedure TMVCController.SetETag(const Data: String);
begin
Context.Response.SetCustomHeader('ETag', GetSHA1HashFromString(Data));
@ -4961,6 +5194,16 @@ begin
inherited;
end;
{ MVCInjectAttribute }
{ MVCInjectAttribute }
constructor MVCInjectAttribute.Create(ServiceName: String);
begin
inherited Create;
fServiceName := ServiceName;
end;
initialization
// https://quality.embarcadero.com/browse/RSP-38281

4
sources/dmvcframework.inc
View File

@ -100,3 +100,7 @@ DelphiMVCFramework is compatible with Delphi version XE7 or better
{$ENDIF}
{$DEFINE USEFIREDAC}
{$IF Defined(SYDNEYORBETTER)}
{$DEFINE CUSTOM_MANAGED_RECORDS}
{$ENDIF}

47
unittests/general/Several/BOs.pas
View File

@ -676,6 +676,34 @@ type
property BackEndName: String read FBackEndName write SetBackEndName;
end;
// TEST INJECTOR
IMyInterface1 = interface
['{AA4EFC41-F34F-4B50-AC3B-5627D4C48CE2}']
function MyMethod1: String;
end;
IMyInterface2 = interface
['{3FE46150-81CA-4ACD-BA8D-B94D1492B1E6}']
function MyMethod2: String;
end;
IMyInterface3 = interface
['{7A4ECD36-3B81-4C87-85CE-1C3AFBD7718F}']
function MyMethod3: String;
end;
TMyService = class(TInterfacedObject, IMyInterface1, IMyInterface2)
function MyMethod1: String;
function MyMethod2: String;
end;
TMyService2 = class(TInterfacedObject, IMyInterface3)
function MyMethod3: String;
end;
function GetMyObject: TMyObject;
function GetMyObjectWithTValue: TMyObjectWithTValue;
function GetMyObjectWithStream: TMyStreamObject;
@ -1454,6 +1482,25 @@ begin
FBackEndName := Value;
end;
{ TMyService }
function TMyService.MyMethod1: String;
begin
Result := 'TMyService.MyMethod1';
end;
function TMyService.MyMethod2: String;
begin
Result := 'TMyService.MyMethod2';
end;
{ TMyService2 }
function TMyService2.MyMethod3: String;
begin
Result := 'TMyService2.MyMethod3';
end;
initialization
ActiveRecordMappingRegistry.AddEntity('customers', TCustomer);

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

@ -76,7 +76,9 @@ uses
IntfObjectPoolTestU in 'IntfObjectPoolTestU.pas',
ObjectPoolTestU in 'ObjectPoolTestU.pas',
MVCFramework.DotEnv.Parser in '..\..\..\sources\MVCFramework.DotEnv.Parser.pas',
MVCFramework.DotEnv in '..\..\..\sources\MVCFramework.DotEnv.pas';
MVCFramework.DotEnv in '..\..\..\sources\MVCFramework.DotEnv.pas',
InjectorTestU in 'InjectorTestU.pas',
MVCFramework.Container in '..\..\..\sources\MVCFramework.Container.pas';
{$R *.RES}

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

@ -274,6 +274,8 @@
<DCCReference Include="ObjectPoolTestU.pas"/>
<DCCReference Include="..\..\..\sources\MVCFramework.DotEnv.Parser.pas"/>
<DCCReference Include="..\..\..\sources\MVCFramework.DotEnv.pas"/>
<DCCReference Include="InjectorTestU.pas"/>
<DCCReference Include="..\..\..\sources\MVCFramework.Container.pas"/>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>
@ -366,6 +368,18 @@
<DeployFile LocalName="$(BDS)\Redist\osx32\libcgunwind.1.0.dylib" Class="DependencyModule"/>
<DeployFile LocalName="Win32\Debug\DMVCFrameworkTests.exe" Configuration="Debug" Class="ProjectOutput"/>
<DeployFile LocalName="Win32\Debug\DMVCFrameworkTests.rsm" Configuration="Debug" Class="DebugSymbols"/>
<DeployFile LocalName="bin32\DMVCFrameworkTests.exe" Configuration="TESTINSIGHT" Class="ProjectOutput">
<Platform Name="Win32">
<RemoteName>DMVCFrameworkTests.exe</RemoteName>
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile LocalName="bin32\DMVCFrameworkTests.rsm" Configuration="TESTINSIGHT" Class="DebugSymbols">
<Platform Name="Win32">
<RemoteName>DMVCFrameworkTests.rsm</RemoteName>
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile LocalName="bin64\DMVCFrameworkTests.exe" Configuration="TESTINSIGHT" Class="ProjectOutput">
<Platform Name="Win64">
<RemoteName>DMVCFrameworkTests.exe</RemoteName>
@ -381,21 +395,9 @@
<DeployFile LocalName="bin\DMVCFrameworkTests.exe" Configuration="CONSOLE" Class="ProjectOutput"/>
<DeployFile LocalName="bin\DMVCFrameworkTests.exe" Configuration="GUI" Class="ProjectOutput"/>
<DeployFile LocalName="bin\DMVCFrameworkTests.exe" Configuration="TESTINSIGHT" Class="ProjectOutput"/>
<DeployFile LocalName="bin\DMVCFrameworkTests.exe" Configuration="TESTINSIGHT" Class="ProjectOutput">
<Platform Name="Win32">
<RemoteName>DMVCFrameworkTests.exe</RemoteName>
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile LocalName="bin\DMVCFrameworkTests.rsm" Configuration="CONSOLE" Class="DebugSymbols"/>
<DeployFile LocalName="bin\DMVCFrameworkTests.rsm" Configuration="GUI" Class="DebugSymbols"/>
<DeployFile LocalName="bin\DMVCFrameworkTests.rsm" Configuration="TESTINSIGHT" Class="DebugSymbols"/>
<DeployFile LocalName="bin\DMVCFrameworkTests.rsm" Configuration="TESTINSIGHT" Class="DebugSymbols">
<Platform Name="Win32">
<RemoteName>DMVCFrameworkTests.rsm</RemoteName>
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployClass Name="AdditionalDebugSymbols">
<Platform Name="OSX32">
<Operation>1</Operation>

3
unittests/general/Several/FrameworkTestsU.pas
View File

@ -288,7 +288,6 @@ type
procedure TestInLineComments;
end;
implementation
{$WARN SYMBOL_DEPRECATED OFF}
@ -2396,6 +2395,8 @@ begin
end;
end;
initialization
TDUnitX.RegisterTestFixture(TTestRouting);

254
unittests/general/Several/InjectorTestU.pas Normal file
View File

@ -0,0 +1,254 @@
// ***************************************************************************
//
// Delphi MVC Framework
//
// Copyright (c) 2010-2024 Daniele Teti and the DMVCFramework Team
//
// https://github.com/danieleteti/delphimvcframework
//
// The Initial Developer of the Original Code is Vivaticket S.p.A. https://www.vivaticket.com/
// The code has been fully donated to the DMVCFramework community without any charge nor rights.
//
// ***************************************************************************
//
// Licensed under the Apache License, Version 2.0 (the "License");
// you may not use this file except in compliance with the License.
// You may obtain a copy of the License at
//
// http://www.apache.org/licenses/LICENSE-2.0
//
// Unless required by applicable law or agreed to in writing, software
// distributed under the License is distributed on an "AS IS" BASIS,
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
// See the License for the specific language governing permissions and
// limitations under the License.
//
// ***************************************************************************
unit InjectorTestU;
interface
uses
DUnitX.TestFramework, MVCFramework.Container,
MVCFramework.Serializer.JsonDataObjects;
type
[TestFixture]
TTestContainer = class
public
[Test]
procedure TestNotBuiltContainer;
[Test]
procedure TestUnknownService;
[Test]
procedure TestTransient;
[Test]
procedure TestSingleton;
[Test]
procedure TestSingletonPerRequest;
[Test]
procedure TestCascadeConstructorInjection;
end;
IServiceA = interface
['{B6C5EAD8-9008-4200-BF33-E3DE5C8A2320}']
end;
IServiceB = interface
['{8418244D-8AEC-4567-A21E-3F4ECD07E227}']
end;
IServiceC = interface
['{A9E5FD77-87FD-4C9C-91BA-79556252DAAD}']
function GetServiceA: IServiceA;
function GetServiceB: IServiceB;
end;
TServiceA = class(TInterfacedObject, IServiceA)
end;
TServiceB = class(TInterfacedObject, IServiceB)
end;
TServiceAB = class(TInterfacedObject, IServiceA, IServiceB)
end;
TServiceC = class(TInterfacedObject, IServiceC)
private
fServiceA: IServiceA;
fServiceB: IServiceB;
protected
function GetServiceA: IServiceA;
function GetServiceB: IServiceB;
public
constructor Create(ServiceA: IServiceA; ServiceB: IServiceB);
end;
implementation
uses
System.Generics.Collections, MVCFramework.IntfObjectPool, System.SysUtils, System.Classes, SyncObjs,
MVCFramework.Serializer.Intf;
{ TTestContainer }
procedure TTestContainer.TestCascadeConstructorInjection;
begin
var lCont := NewMVCServiceContainer;
lCont.RegisterType(TServiceA, IServiceA);
lCont.RegisterType(TServiceB, IServiceB, '', TRegistrationType.SingletonPerRequest);
lCont.RegisterType(TServiceC, IServiceC);
lCont.Build;
// 1° "request"
var lResolver := NewServiceContainerResolver(lCont);
var l0 := lResolver.Resolve(TypeInfo(IServiceC)) as IServiceC;
Assert.IsNotNull(l0.GetServiceA);
Assert.IsNotNull(l0.GetServiceB);
// resolve another "IServiceC" in the same request - ServiceB is rtSingletonPerRequest
var l01 := lResolver.Resolve(TypeInfo(IServiceC)) as IServiceC;
Assert.IsNotNull(l0.GetServiceA);
Assert.IsNotNull(l0.GetServiceB);
Assert.AreNotEqual(l0.GetServiceA, l01.GetServiceA);
Assert.AreEqual(l0.GetServiceB, l01.GetServiceB);
// 2° "request"
lResolver := NewServiceContainerResolver(lCont);
var l1 := lResolver.Resolve(TypeInfo(IServiceC)) as IServiceC;
Assert.IsNotNull(l0.GetServiceA);
Assert.IsNotNull(l0.GetServiceB);
Assert.AreNotEqual(l0.GetServiceA, l1.GetServiceA);
Assert.AreNotEqual(l0.GetServiceB, l1.GetServiceB);
end;
procedure TTestContainer.TestNotBuiltContainer;
begin
var lCont := NewMVCServiceContainer;
lCont.RegisterType(TServiceA, IServiceA);
var lResolver := NewServiceContainerResolver(lCont);
Assert.WillRaise(
procedure
begin
var l0 := lResolver.Resolve(TypeInfo(IServiceA));
end, EMVCContainerError);
end;
procedure TTestContainer.TestSingleton;
begin
var lCont := NewMVCServiceContainer;
lCont.RegisterType(TServiceA, IServiceA, '', TRegistrationType.Singleton);
lCont.RegisterType(TServiceA, IServiceA, 'Svc1', TRegistrationType.Singleton);
lCont.Build;
// 1° Request
var lResolver := NewServiceContainerResolver(lCont);
var l0 := lResolver.Resolve(TypeInfo(IServiceA));
var l1 := lResolver.Resolve(TypeInfo(IServiceA));
Assert.AreEqual(l0, l1);
var l2 := lResolver.Resolve(TypeInfo(IServiceA), 'Svc1');
var l3 := lResolver.Resolve(TypeInfo(IServiceA), 'Svc1');
Assert.AreEqual(l2, l3);
// 2° Request
lResolver := NewServiceContainerResolver(lCont);
var l10 := lResolver.Resolve(TypeInfo(IServiceA));
var l11 := lResolver.Resolve(TypeInfo(IServiceA));
Assert.AreEqual(l10, l11);
Assert.AreEqual(l0, l10);
Assert.AreEqual(l1, l11);
end;
procedure TTestContainer.TestSingletonPerRequest;
begin
var lCont := NewMVCServiceContainer
.RegisterType(TServiceA, IServiceA, '', TRegistrationType.SingletonPerRequest)
.RegisterType(TServiceA, IServiceA, 'Svc1', TRegistrationType.SingletonPerRequest);
lCont.Build;
// 1° "request"
var lResolver := NewServiceContainerResolver(lCont);
var l0 := lResolver.Resolve(TypeInfo(IServiceA));
var l1 := lResolver.Resolve(TypeInfo(IServiceA));
Assert.AreEqual(l0, l1);
var l2 := lResolver.Resolve(TypeInfo(IServiceA), 'Svc1');
var l3 := lResolver.Resolve(TypeInfo(IServiceA), 'Svc1');
Assert.AreEqual(l2, l3);
// 2° "request"
lResolver := NewServiceContainerResolver(lCont);
var l00 := lResolver.Resolve(TypeInfo(IServiceA));
var l10 := lResolver.Resolve(TypeInfo(IServiceA));
Assert.AreEqual(l00, l10);
Assert.AreNotEqual(l0, l00);
Assert.AreNotEqual(l1, l10);
end;
procedure TTestContainer.TestTransient;
begin
var lCont := NewMVCServiceContainer;
lCont.RegisterType(TServiceA, IServiceA);
lCont.RegisterType(TServiceA, IServiceA, 'Svc1');
lCont.Build;
var lResolver := NewServiceContainerResolver(lCont);
var l0 := lResolver.Resolve(TypeInfo(IServiceA));
var l1 := lResolver.Resolve(TypeInfo(IServiceA));
Assert.AreNotEqual(l0, l1);
var l2 := lResolver.Resolve(TypeInfo(IServiceA), 'Svc1');
var l3 := lResolver.Resolve(TypeInfo(IServiceA), 'Svc1');
Assert.AreNotEqual(l2, l3);
end;
procedure TTestContainer.TestUnknownService;
begin
var lCont := NewMVCServiceContainer;
Assert.WillRaise(
procedure
begin
lCont.RegisterType(TServiceA, IServiceB);
end, EMVCContainerErrorUnknownService);
Assert.WillRaise(
procedure
begin
lCont.RegisterType(TMVCJsonDataObjectsSerializer, IServiceB);
end, EMVCContainerErrorUnknownService);
Assert.WillRaise(
procedure
begin
lCont.RegisterType(TServiceA, IMVCSerializer);
end, EMVCContainerErrorUnknownService);
end;
{ TServiceC }
constructor TServiceC.Create(ServiceA: IServiceA; ServiceB: IServiceB);
begin
inherited Create;
fServiceA := ServiceA;
fServiceB := ServiceB;
end;
function TServiceC.GetServiceA: IServiceA;
begin
Result := fServiceA;
end;
function TServiceC.GetServiceB: IServiceB;
begin
Result := fServiceB;
end;
initialization
TDUnitX.RegisterTestFixture(TTestContainer);
end.