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

3.1.1-beryllium-RC5

Browse Source
This commit is contained in:
Daniele Teti 2019-05-09 20:53:52 +02:00
parent f1ff9fa94c
commit 6a664d608c
12 changed files with 609 additions and 351 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
samples/commons/BusinessObjectsU.pas
View File

@ -104,7 +104,7 @@ type
procedure SetContactLast(const Value: string);
procedure SetName(const Value: string);
public
property name: string read FName write SetName;
property Name: string read FName write SetName;
[MVCDoNotSerialize]
property ContactFirst: string read FContactFirst write SetContactFirst;
[MVCDoNotSerialize]

79
samples/renders/RenderSampleControllerU.pas
View File

@ -48,14 +48,16 @@ type
procedure GetPerson_AsText(const ID: Integer);
[MVCHTTPMethod([httpGET])]
[MVCPath('/customers/hateoas')]
[MVCProduces('application/json')]
procedure GetCustomers_AsDataSet_HATEOAS;
[MVCPath('/customers/simple')]
procedure GetCustomers_AsDataSet;
[MVCHTTPMethod([httpGET])]
[MVCPath('/customers')]
[MVCProduces('application/json')]
procedure GetCustomers_AsDataSet;
procedure GetCustomersAsDataSetWithRefLinks;
[MVCHTTPMethod([httpGET])]
[MVCPath('/customers/($ID)')]
procedure GetCustomer_AsDataSetRecord(const ID: Integer);
[MVCHTTPMethod([httpGET])]
[MVCPath('/customers/metadata')]
@ -253,7 +255,7 @@ begin
on disk and how to retrieve it. }
Context.Response.ContentType := TMVCMediaType.APPLICATION_JSON;
Context.Response.StatusCode := HTTP_STATUS.OK;
Render(Dict(['filename', 'ref'], [lOutputFileName, '/files/' + lOutputFileName]));
Render(StrDict(['filename', 'ref'], [lOutputFileName, '/files/' + lOutputFileName]));
end;
procedure TRenderSampleController.GetBinaryData(const filename: string);
@ -338,7 +340,7 @@ begin
end;
end;
procedure TRenderSampleController.GetCustomers_AsDataSet_HATEOAS;
procedure TRenderSampleController.GetCustomersAsDataSetWithRefLinks;
var
lDM: TMyDataModule;
begin
@ -346,11 +348,42 @@ begin
try
lDM.qryCustomers.Open;
Render(lDM.qryCustomers, False,
procedure(const DS: TDataset; const Links: TMVCStringDictionary)
procedure(const DS: TDataset; const Links: IMVCLinks)
begin
Links[HATEOAS.HREF] := '/customers/' + DS.FieldByName('cust_no').AsString;
Links[HATEOAS.REL] := 'self';
Links[HATEOAS._TYPE] := 'application/json';
Links.AddRefLink
.Add(HATEOAS.HREF, '/customers/' + DS.FieldByName('cust_no').AsString)
.Add(HATEOAS.REL, 'self')
.Add(HATEOAS._TYPE, 'application/json');
Links.AddRefLink
.Add(HATEOAS.HREF, '/customers/' + DS.FieldByName('cust_no').AsString + '/orders')
.Add(HATEOAS.REL, 'orders')
.Add(HATEOAS._TYPE, 'application/json');
end);
finally
lDM.Free;
end;
end;
procedure TRenderSampleController.GetCustomer_AsDataSetRecord(
const ID: Integer);
var
lDM: TMyDataModule;
begin
lDM := TMyDataModule.Create(nil);
try
lDM.qryCustomers.Open('SELECT * FROM CUSTOMER WHERE CUST_NO = ?', [ID]);
Render(lDM.qryCustomers, False, [], dstSingleRecord,
procedure(const DS: TDataset; const Links: IMVCLinks)
begin
Links.AddRefLink
.Add(HATEOAS.HREF, '/customers')
.Add(HATEOAS.REL, 'customers')
.Add(HATEOAS._TYPE, TMVCMediaType.APPLICATION_JSON);
Links.AddRefLink
.Add(HATEOAS.HREF, '/customers/' + DS.FieldByName('cust_no').AsString)
.Add(HATEOAS.REL, 'self')
.Add(HATEOAS._TYPE, TMVCMediaType.APPLICATION_JSON);
end);
finally
lDM.Free;
@ -574,12 +607,13 @@ begin
{$ENDREGION}
Render<TPerson>(People, True,
procedure(const APerson: TPerson; const Dict: TMVCStringDictionary)
procedure(const APerson: TPerson; const Links: IMVCLinks)
begin
Dict[HATEOAS.HREF] := '/people/' + APerson.ID.ToString;
Dict[HATEOAS.REL] := 'self';
Dict[HATEOAS._TYPE] := 'application/json';
Dict['title'] := 'Details for ' + APerson.FullName;
Links.AddRefLink
.Add(HATEOAS.HREF, '/people/' + APerson.ID.ToString)
.Add(HATEOAS.REL, 'self')
.Add(HATEOAS._TYPE, 'application/json')
.Add('title', 'Details for ' + APerson.FullName);
end);
end;
@ -595,11 +629,16 @@ begin
lPerson.DOB := EncodeDate(1979, 11, 4);
lPerson.Married := True;
Render(lPerson, False,
procedure(const AObject: TObject; const Links: TMVCStringDictionary)
procedure(const AObject: TObject; const Links: IMVCLinks)
begin
Links[HATEOAS.HREF] := '/people/' + TPerson(AObject).ID.ToString;
Links[HATEOAS.REL] := 'self';
Links[HATEOAS._TYPE] := TMVCMediaType.APPLICATION_JSON;
Links.AddRefLink
.Add(HATEOAS.HREF, '/people/' + TPerson(AObject).ID.ToString)
.Add(HATEOAS.REL, 'self')
.Add(HATEOAS._TYPE, TMVCMediaType.APPLICATION_JSON);
Links.AddRefLink
.Add(HATEOAS.HREF, '/people')
.Add(HATEOAS.REL, 'people')
.Add(HATEOAS._TYPE, TMVCMediaType.APPLICATION_JSON);
end);
finally
lPerson.Free;

96
sources/MVCFramework.ActiveRecord.pas
View File

@ -195,7 +195,7 @@ type
/// <summary>
/// Called before execute sql
/// </summary>
procedure OnBeforeExecuteSQL(var SQL:String); virtual;
procedure OnBeforeExecuteSQL(var SQL: String); virtual;
/// <summary>
/// Called after insert or update the object to the database
@ -248,8 +248,10 @@ type
class function All<T: TMVCActiveRecord, constructor>: TObjectList<T>; overload;
class function All(const aClass: TMVCActiveRecordClass): TObjectList<TMVCActiveRecord>; overload;
class function DeleteAll(const aClass: TMVCActiveRecordClass): int64; overload;
function Count: int64; overload;
function Count(const RQL: String = ''): int64; overload;
class function Count<T: TMVCActiveRecord>(const RQL: String = ''): int64; overload;
class function Count<T: TMVCActiveRecord>: int64; overload;
class function Count(const aClass: TMVCActiveRecordClass; const RQL: String = ''): int64; overload;
class function Count(const aClass: TMVCActiveRecordClass): int64; overload;
class function SelectDataSet(const SQL: string; const Params: array of Variant): TDataSet;
class function CurrentConnection: TFDConnection;
@ -284,7 +286,9 @@ type
IMVCActiveRecordConnections = interface
['{7B87473C-1784-489F-A838-925E7DDD0DE2}']
procedure AddConnection(const aName: string; const aConnection: TFDConnection; const Owns: Boolean = false);
procedure AddDefaultConnection(const aConnection: TFDConnection; const Owns: Boolean = false);
procedure RemoveConnection(const aName: string);
procedure RemoveDefaultConnection;
procedure SetCurrent(const aName: string);
function GetCurrent: TFDConnection;
function GetCurrentBackend: string;
@ -308,7 +312,9 @@ type
constructor Create; virtual;
destructor Destroy; override;
procedure AddConnection(const aName: string; const aConnection: TFDConnection; const aOwns: Boolean = false);
procedure AddDefaultConnection(const aConnection: TFDConnection; const aOwns: Boolean = false);
procedure RemoveConnection(const aName: string);
procedure RemoveDefaultConnection;
procedure SetCurrent(const aName: string);
function GetCurrent: TFDConnection;
function GetByName(const aName: string): TFDConnection;
@ -481,6 +487,12 @@ begin
end;
end;
procedure TMVCConnectionsRepository.AddDefaultConnection(
const aConnection: TFDConnection; const aOwns: Boolean);
begin
AddConnection('default', aConnection, aOwns);
end;
constructor TMVCConnectionsRepository.Create;
begin
inherited;
@ -570,6 +582,11 @@ begin
end;
end;
procedure TMVCConnectionsRepository.RemoveDefaultConnection;
begin
RemoveConnection('default');
end;
procedure TMVCConnectionsRepository.SetCurrent(const aName: string);
var
lName: string;
@ -638,7 +655,7 @@ var
lPar: TFDParam;
lPair: TPair<TRttiField, string>;
lValue: TValue;
lSQL : String;
lSQL: String;
begin
lQry := TFDQuery.Create(nil);
try
@ -725,7 +742,7 @@ var
begin
lQry := TFDQuery.Create(nil);
try
lQry.FetchOptions.Unidirectional := False; //True;
lQry.FetchOptions.Unidirectional := false; // True;
if Connection = nil then
begin
lQry.Connection := ActiveRecordConnectionsRegistry.GetCurrent;
@ -959,26 +976,43 @@ begin
raise EMVCActiveRecord.CreateFmt('Action not allowed on "%s"', [ClassName]);
end;
class function TMVCActiveRecord.Count(const aClass: TMVCActiveRecordClass): int64;
class function TMVCActiveRecord.Count(const aClass: TMVCActiveRecordClass; const RQL: String): int64;
var
lAR: TMVCActiveRecord;
begin
lAR := aClass.Create;
try
Result := lAR.Count;
Result := lAR.Count(RQL);
finally
lAR.Free;
end;
end;
function TMVCActiveRecord.Count: int64;
class function TMVCActiveRecord.Count(const aClass: TMVCActiveRecordClass): int64;
begin
Result := GetScalar(Self.SQLGenerator.CreateSelectCount(fTableName), []);
Result := TMVCActiveRecord.Count(aClass, '');
end;
function TMVCActiveRecord.Count(const RQL: String = ''): int64;
var
lSQL: string;
begin
lSQL := Self.SQLGenerator.CreateSelectCount(fTableName);
if not RQL.IsEmpty then
begin
lSQL := lSQL + fSQLGenerator.CreateSQLWhereByRQL(RQL, GetMapping, false);
end;
Result := GetScalar(lSQL, []);
end;
class function TMVCActiveRecord.Count<T>(const RQL: String = ''): int64;
begin
Result := TMVCActiveRecord.Count(TMVCActiveRecordClass(T), RQL);
end;
class function TMVCActiveRecord.Count<T>: int64;
begin
Result := Count(TMVCActiveRecordClass(T));
Result := Count<T>('');
end;
class function TMVCActiveRecord.CurrentConnection: TFDConnection;
@ -1141,11 +1175,11 @@ var
lStream: TStream;
lName: String;
begin
{$IFDEF NEXTGEN}
lName := aValue.TypeInfo.NameFld.ToString;
{$ELSE}
lName := String(aValue.TypeInfo.Name);
{$ENDIF}
{$IFDEF NEXTGEN}
lName := aValue.TypeInfo.NameFld.ToString;
{$ELSE}
lName := String(aValue.TypeInfo.Name);
{$ENDIF}
case aValue.TypeInfo.Kind of
// tkUnknown:
// begin
@ -1200,22 +1234,24 @@ begin
end;
tkFloat:
begin
if lName = 'TDate' then
if lName = 'TDate' then
begin
aParam.AsDate := Trunc(aValue.AsExtended);
end
else if lName = 'TDateTime' then
begin
aParam.AsDateTime := aValue.AsExtended;
end
else if lName = 'Currency' then
begin
aParam.AsCurrency := aValue.AsCurrency;
end
else
begin
aParam.AsFloat := aValue.AsExtended;
end;
if lName = 'TDateTime' then
begin
aParam.AsDateTime := aValue.AsExtended;
end
else
if lName = 'Currency' then
begin
aParam.AsCurrency := aValue.AsCurrency;
end
else
begin
aParam.AsFloat := aValue.AsExtended;
end;
end;
tkClass:
begin
@ -1449,7 +1485,7 @@ begin
// do nothing
end;
procedure TMVCActiveRecord.OnBeforeExecuteSQL(var SQL:String);
procedure TMVCActiveRecord.OnBeforeExecuteSQL(var SQL: String);
begin
// do nothing
end;
@ -1859,7 +1895,7 @@ function TMVCSQLGenerator.GetRQLParser: TRQL2SQL;
begin
if fRQL2SQL = nil then
begin
fRQL2SQL := TRQL2SQL.Create;//(20);
fRQL2SQL := TRQL2SQL.Create; // (20);
end;
Result := fRQL2SQL;
end;
@ -1886,8 +1922,8 @@ destructor TMVCConnectionsRepository.TConnHolder.Destroy;
begin
if OwnsConnection then
Begin
if Connection.connected then
Connection.connected := False;
if Connection.Connected then
Connection.Connected := false;
FreeAndNil(Connection);
End;
inherited;

107
sources/MVCFramework.Commons.pas
View File

@ -387,6 +387,43 @@ type
property Items[const Key: string]: string read GetItems write SetItems; default;
end;
TMVCStringDictionaryList = class(TObjectList<TMVCStringDictionary>)
public
constructor Create;
end;
IMVCLinkItem = interface
['{8BC70061-0DD0-4D0A-B135-F83A5C86629B}']
function Add(const PropName: String; const PropValue: String): IMVCLinkItem;
end;
IMVCLinks = interface
['{8A116BED-9A10-4885-AD4B-DF38A7F0D7DF}']
function AddRefLink: IMVCLinkItem;
function Clear: IMVCLinks;
function LinksData: TMVCStringDictionaryList;
end;
TMVCLinks = class(TInterfacedObject, IMVCLinks)
private
fData: TMVCStringDictionaryList;
protected
function AddRefLink: IMVCLinkItem;
function Clear: IMVCLinks;
public
constructor Create; virtual;
destructor Destroy; override;
function LinksData: TMVCStringDictionaryList;
end;
TMVCDecoratorObject = class(TInterfacedObject, IMVCLinkItem)
private
fData: TMVCStringDictionary;
public
constructor Create(const aData: TMVCStringDictionary);
function Add(const PropName: String; const PropValue: String): IMVCLinkItem;
end;
{ This type is thread safe }
TMVCStringObjectDictionary<T: class> = class
private
@ -486,8 +523,8 @@ procedure SplitContentMediaTypeAndCharset(const aContentType: string; var aConte
var aContentCharSet: string);
function BuildContentType(const aContentMediaType: string; const aContentCharSet: string): string;
function Dict: TMVCStringDictionary; overload;
function Dict(const aKeys: array of string; const aValues: array of string)
function StrDict: TMVCStringDictionary; overload;
function StrDict(const aKeys: array of string; const aValues: array of string)
: TMVCStringDictionary; overload;
const
@ -1027,12 +1064,12 @@ begin
Self.WriteBuffer(UFTStr[Low(UFTStr)], Length(UFTStr));
end;
function Dict: TMVCStringDictionary; overload;
function StrDict: TMVCStringDictionary; overload;
begin
Result := TMVCStringDictionary.Create;
end;
function Dict(const aKeys: array of string; const aValues: array of string)
function StrDict(const aKeys: array of string; const aValues: array of string)
: TMVCStringDictionary; overload;
var
I: Integer;
@ -1042,13 +1079,73 @@ begin
raise EMVCException.CreateFmt('Dict error. Got %d keys but %d values',
[Length(aKeys), Length(aValues)]);
end;
Result := Dict();
Result := StrDict();
for I := Low(aKeys) to High(aKeys) do
begin
Result.Add(aKeys[I], aValues[I]);
end;
end;
{ TMVCDecorator }
function TMVCLinks.AddRefLink: IMVCLinkItem;
begin
if not Assigned(fData) then
begin
fData := TMVCStringDictionaryList.Create;
end;
Result := TMVCDecoratorObject.Create(fData[fData.Add(TMVCStringDictionary.Create)]);
end;
function TMVCLinks.Clear: IMVCLinks;
begin
if Assigned(fData) then
begin
fData.Clear;
end;
Result := Self;
end;
constructor TMVCLinks.Create;
begin
inherited Create;
fData := nil;
end;
function TMVCLinks.LinksData: TMVCStringDictionaryList;
begin
Result := fData;
end;
destructor TMVCLinks.Destroy;
begin
FreeAndNil(fData);
inherited;
end;
{ TMVCDecoratorObject }
function TMVCDecoratorObject.Add(const PropName,
PropValue: String): IMVCLinkItem;
begin
fData.Items[PropName] := PropValue;
Result := Self;
end;
constructor TMVCDecoratorObject.Create(const aData: TMVCStringDictionary);
begin
inherited Create;
fData := aData;
end;
{ TMVCNamedPairList }
constructor TMVCStringDictionaryList.Create;
begin
inherited Create(True);
end;
initialization
gLock := TObject.Create;

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

@ -77,7 +77,7 @@ type
TRQLToken = (tkEq, tkLt, tkLe, tkGt, tkGe, tkNe, tkAnd, tkOr, tkSort, tkLimit, { RQL } tkAmpersand, tkEOF,
tkOpenPar, tkClosedPar, tkOpenBracket, tkCloseBracket, tkComma, tkSemicolon, tkPlus, tkMinus, tkDblQuote,
tkQuote, tkSpace, tkContains, tkIn, tkUnknown);
TRQLCustom = class;
TRQLAbstractSyntaxTree = class(TObjectList<TRQLCustom>)
@ -199,10 +199,10 @@ type
constructor Create(const MaxRecordCount: Integer = -1);
destructor Destroy; override;
procedure Execute(
const RQL: string;
out SQL: string;
const RQLCompiler: TRQLCompiler;
const UseLimit: Boolean = true);
const RQL: string;
out SQL: string;
const RQLCompiler: TRQLCompiler;
const UseLimit: Boolean = true);
end;
TRQLCompilerRegistry = class sealed
@ -272,7 +272,7 @@ procedure TRQL2SQL.EatWhiteSpaces;
var
lToken: TRQLToken;
begin
while True do
while true do
begin
SaveCurPos;
lToken := GetToken;
@ -330,7 +330,7 @@ begin
fAST.Insert(0, TRQLWhere.Create);
if GetToken = tkSemicolon then
begin
ParseSortLimit(True);
ParseSortLimit(true);
end;
end
else
@ -500,7 +500,8 @@ begin
fCurrToken := tkLimit;
Exit(fCurrToken);
end;
if (lChar = 'c') and (C(1) = 'o') and (C(2) = 'n') and (C(3) = 't') and (C(4) = 'a') and (C(5) = 'i') and (C(6) = 'n') and (C(7) = 's') then
if (lChar = 'c') and (C(1) = 'o') and (C(2) = 'n') and (C(3) = 't') and (C(4) = 'a') and (C(5) = 'i') and
(C(6) = 'n') and (C(7) = 's') then
begin
Skip(8);
fCurrToken := tkContains;
@ -559,23 +560,24 @@ begin
Error('Expected string value');
if not MatchSymbol('"') then
Error('Unclosed string');
lValueIsString := True;
end
else if (aToken = tkIn) and (lToken = tkOpenBracket) then
begin
if not MatchFieldArrayValue(lFieldValue) then
Error('Expected array value');
if not MatchSymbol(']') then
Error('Unclosed bracket');
lValueIsString := False;
lValueIsString := true;
end
else
begin
BackToLastPos;
if not MatchFieldNumericValue(lFieldValue) then
Error('Expected numeric value');
lValueIsString := False;
end;
if (aToken = tkIn) and (lToken = tkOpenBracket) then
begin
if not MatchFieldArrayValue(lFieldValue) then
Error('Expected array value');
if not MatchSymbol(']') then
Error('Unclosed bracket');
lValueIsString := False;
end
else
begin
BackToLastPos;
if not MatchFieldNumericValue(lFieldValue) then
Error('Expected numeric value');
lValueIsString := False;
end;
EatWhiteSpaces;
if GetToken <> tkClosedPar then
Error('Expected ")"');
@ -593,7 +595,7 @@ var
begin
EatWhiteSpaces;
SaveCurPos;
Result := True;
Result := true;
lTk := GetToken;
case lTk of
tkEq, tkLt, tkLe, tkGt, tkGe, tkNe, tkContains, tkIn:
@ -642,7 +644,7 @@ begin
lRQLLimit := TRQLLimit.Create;
fAST.Add(lRQLLimit);
lRQLLimit.Token := tkLimit;
lRQLLimit.Start := StrToInt64(lStart); //XE7 compat
lRQLLimit.Start := StrToInt64(lStart); // XE7 compat
if fMaxRecordCount > -1 then
begin
lRQLLimit.Count := Min(StrToInt64(lCount), fMaxRecordCount);
@ -651,7 +653,7 @@ begin
begin
lRQLLimit.Count := StrToInt64(lCount);
end;
Result := True;
Result := true;
end;
procedure TRQL2SQL.ParseLogicOperator(const aToken: TRQLToken;
@ -669,7 +671,7 @@ begin
EatWhiteSpaces;
lLogicOp := TRQLLogicOperator.Create(aToken);
aAST.Add(lLogicOp);
while True do
while true do
begin
EatWhiteSpaces;
lToken := GetToken;
@ -702,7 +704,7 @@ var
lFieldName: string;
lSort: TRQLSort;
begin
Result := True;
Result := true;
SaveCurPos;
if GetToken <> tkSort then
begin
@ -716,7 +718,7 @@ begin
fAST.Add(lSort);
lSort.Token := tkSort;
while True do
while true do
begin
EatWhiteSpaces;
lToken := GetToken;
@ -768,8 +770,8 @@ function TRQL2SQL.MatchFieldArrayValue(out lFieldValue: string): Boolean;
var
lChar: Char;
begin
Result := True;
while True do
Result := true;
while true do
begin
lChar := C(0);
// escape chars
@ -807,12 +809,12 @@ function TRQL2SQL.MatchFieldName(out lFieldName: string): Boolean;
var
lChar: Char;
begin
Result := True;
Result := true;
lChar := C(0);
if IsLetter(lChar) then
begin
lFieldName := lChar;
while True do
while true do
begin
Skip(1);
lChar := C(0);
@ -832,11 +834,11 @@ function TRQL2SQL.MatchFieldNumericValue(out lFieldValue: string): Boolean;
var
lChar: Char;
begin
Result := True;
Result := true;
lFieldValue := '';
lChar := C(0);
if CharInSet(lChar, ['+','-']) then
if CharInSet(lChar, ['+', '-']) then
begin
lFieldValue := lChar;
Skip(1);
@ -846,7 +848,7 @@ begin
if IsDigit(lChar) then
begin
lFieldValue := lFieldValue + lChar;
while True do
while true do
begin
Skip(1);
lChar := C(0);
@ -866,8 +868,8 @@ function TRQL2SQL.MatchFieldStringValue(out lFieldValue: string): Boolean;
var
lChar: Char;
begin
Result := True;
while True do
Result := true;
while true do
begin
lChar := C(0);
// escape chars
@ -921,7 +923,7 @@ constructor TRQLLogicOperator.Create(const Token: TRQLToken);
begin
inherited Create;
Self.Token := Token;
fRQLFilter := TObjectList<TRQLCustom>.Create(True);
fRQLFilter := TObjectList<TRQLCustom>.Create(true);
end;
destructor TRQLLogicOperator.Destroy;
@ -1045,14 +1047,15 @@ begin
if lField.InstanceFieldName = lRQLProperty then
Exit(lField.DatabaseFieldName);
end;
raise ERQLException.CreateFmt('Property %s does not exist or is transient and cannot be used in RQL', [RQLPropertyName]);
raise ERQLException.CreateFmt('Property %s does not exist or is transient and cannot be used in RQL',
[RQLPropertyName]);
end;
{ TRQLAbstractSyntaxTree }
constructor TRQLAbstractSyntaxTree.Create;
begin
inherited Create(True);
inherited Create(true);
end;
function TRQLAbstractSyntaxTree.TreeContainsToken(
@ -1064,7 +1067,7 @@ begin
for lItem in Self do
begin
if lItem.Token = aToken then
Exit(True);
Exit(true);
end;
end;

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

@ -59,9 +59,9 @@ type
TMVCIgnoredList = array of string;
TMVCSerializationAction<T: class> = reference to procedure(const AObject: T; const ADictionary: TMVCStringDictionary);
TMVCSerializationAction = reference to procedure(const AObject: TObject; const ADictionary: TMVCStringDictionary);
TMVCDatasetSerializationAction = reference to procedure(const ADataSet: TDataset; const ADictionary: TMVCStringDictionary);
TMVCSerializationAction<T: class> = reference to procedure(const AObject: T; const Links: IMVCLinks);
TMVCSerializationAction = reference to procedure(const AObject: TObject; const Links: IMVCLinks);
TMVCDatasetSerializationAction = reference to procedure(const ADataSet: TDataset; const Links: IMVCLinks);
EMVCSerializationException = class(EMVCException)
end;

1
sources/MVCFramework.Serializer.JsonDataObjects.CustomTypes.pas
View File

@ -210,7 +210,6 @@ procedure TMVCStringDictionarySerializer.SerializeAttribute(const AElementValue:
const ASerializerObject: TObject; const AAttributes: TArray<TCustomAttribute>);
var
lStringDict: TMVCStringDictionary;
// lPair: TPair<string, string>;
lOutObject: TJsonObject;
lJsonDict: TJsonObject;
begin

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

@ -66,9 +66,10 @@ type
public
procedure ObjectToJsonObject(const AObject: TObject; const AJsonObject: TJDOJsonObject;
const AType: TMVCSerializationType; const AIgnoredAttributes: TMVCIgnoredList);
procedure InternalObjectToJsonObject(const AObject: TObject; const AJsonObject: TJDOJsonObject;
const AType: TMVCSerializationType; const AIgnoredAttributes: TMVCIgnoredList;
const ASerializationAction: TMVCSerializationAction; const Dict: TMVCStringDictionary;
procedure InternalObjectToJsonObject(const AObject: TObject;
const AJsonObject: TJDOJsonObject; const AType: TMVCSerializationType;
const AIgnoredAttributes: TMVCIgnoredList;
const ASerializationAction: TMVCSerializationAction; const Links: IMVCLinks;
const Serializer: IMVCTypeSerializer);
procedure ListToJsonArray(const AList: IMVCList; const AJsonArray: TJDOJsonArray;
const AType: TMVCSerializationType; const AIgnoredAttributes: TMVCIgnoredList;
@ -154,7 +155,13 @@ uses
MVCFramework.Logger,
System.SysUtils;
{ TMVCJsonDataObjectsSerializer }
type
TJDOLinks = class(TMVCLinks)
public
procedure FillJSONArray(const AJsonArray: TJsonArray);
end;
{ TMVCJsonDataObjectsSerializer }
procedure TMVCJsonDataObjectsSerializer.AfterConstruction;
var
@ -215,22 +222,24 @@ begin
else
AJsonObject.S[AName] := DateToISODate(AValue.AsExtended);
end
else if (AValue.TypeInfo = System.TypeInfo(TDateTime)) then
begin
if (AValue.AsExtended = 0) then
AJsonObject[AName] := Null
else
AJsonObject.S[AName] := DateTimeToISOTimeStamp(AValue.AsExtended);
end
else if (AValue.TypeInfo = System.TypeInfo(TTime)) then
begin
if (AValue.AsExtended = 0) then
AJsonObject[AName] := Null
else
AJsonObject.S[AName] := TimeToISOTime(AValue.AsExtended);
end
else
AJsonObject.F[AName] := AValue.AsExtended;
if (AValue.TypeInfo = System.TypeInfo(TDateTime)) then
begin
if (AValue.AsExtended = 0) then
AJsonObject[AName] := Null
else
AJsonObject.S[AName] := DateTimeToISOTimeStamp(AValue.AsExtended);
end
else
if (AValue.TypeInfo = System.TypeInfo(TTime)) then
begin
if (AValue.AsExtended = 0) then
AJsonObject[AName] := Null
else
AJsonObject.S[AName] := TimeToISOTime(AValue.AsExtended);
end
else
AJsonObject.F[AName] := AValue.AsExtended;
end;
tkVariant:
@ -298,31 +307,32 @@ begin
begin
AJsonObject.F[AName] := TimeStampToMsecs(AValue.AsType<TTimeStamp>);
end
else if (AValue.TypeInfo = System.TypeInfo(TValue)) then
begin
if TMVCSerializerHelper.AttributeExists<MVCValueAsTypeAttribute>(ACustomAttributes,
ValueTypeAtt) then
else
if (AValue.TypeInfo = System.TypeInfo(TValue)) then
begin
CastValue := AValue.AsType<TValue>;
if CastValue.TryCast(ValueTypeAtt.ValueTypeInfo, CastedValue) then
AttributeToJsonDataValue(AJsonObject, AName, CastedValue, stDefault, [], [])
if TMVCSerializerHelper.AttributeExists<MVCValueAsTypeAttribute>(ACustomAttributes,
ValueTypeAtt) then
begin
CastValue := AValue.AsType<TValue>;
if CastValue.TryCast(ValueTypeAtt.ValueTypeInfo, CastedValue) then
AttributeToJsonDataValue(AJsonObject, AName, CastedValue, stDefault, [], [])
else
raise EMVCSerializationException.CreateFmt
('Cannot serialize %s of TypeKind tkRecord (TValue with MVCValueAsTypeAttribute).',
[AName]);
end
else
raise EMVCSerializationException.CreateFmt
('Cannot serialize %s of TypeKind tkRecord (TValue with MVCValueAsTypeAttribute).',
[AName]);
begin
ChildValue := AValue.AsType<TValue>;
ChildJsonObject := AJsonObject.O[AName];
ChildJsonObject.S['type'] := TMVCSerializerHelper.GetTypeKindAsString
(ChildValue.TypeInfo.Kind);
AttributeToJsonDataValue(ChildJsonObject, 'value', ChildValue, stDefault, [], []);
end;
end
else
begin
ChildValue := AValue.AsType<TValue>;
ChildJsonObject := AJsonObject.O[AName];
ChildJsonObject.S['type'] := TMVCSerializerHelper.GetTypeKindAsString
(ChildValue.TypeInfo.Kind);
AttributeToJsonDataValue(ChildJsonObject, 'value', ChildValue, stDefault, [], []);
end;
end
else
raise EMVCSerializationException.CreateFmt
('Cannot serialize %s of TypeKind tkRecord.', [AName]);
raise EMVCSerializationException.CreateFmt
('Cannot serialize %s of TypeKind tkRecord.', [AName]);
end;
tkSet:
@ -633,18 +643,21 @@ begin
if (AValue.TypeInfo = System.TypeInfo(TDate)) then
AValue := TValue.From<TDate>(ISODateToDate(AJsonObject[AName].Value))
else if (AValue.TypeInfo = System.TypeInfo(TDateTime)) then
AValue := TValue.From<TDateTime>(ISOTimeStampToDateTime(AJsonObject[AName].Value))
else if (AValue.TypeInfo = System.TypeInfo(TTime)) then
AValue := TValue.From<TTime>(ISOTimeToTime(AJsonObject[AName].Value))
else if (AValue.Kind = tkEnumeration) then
TValue.Make(GetEnumValue(AValue.TypeInfo, AJsonObject[AName].Value),
AValue.TypeInfo, AValue)
else
AValue := TValue.From<string>(AJsonObject[AName].Value);
if (AValue.TypeInfo = System.TypeInfo(TDateTime)) then
AValue := TValue.From<TDateTime>(ISOTimeStampToDateTime(AJsonObject[AName].Value))
else
if (AValue.TypeInfo = System.TypeInfo(TTime)) then
AValue := TValue.From<TTime>(ISOTimeToTime(AJsonObject[AName].Value))
else
if (AValue.Kind = tkEnumeration) then
TValue.Make(GetEnumValue(AValue.TypeInfo, AJsonObject[AName].Value),
AValue.TypeInfo, AValue)
else
AValue := TValue.From<string>(AJsonObject[AName].Value);
end;
jdtInt:
@ -901,23 +914,19 @@ procedure TMVCJsonDataObjectsSerializer.ListToJsonArray(const AList: IMVCList;
const ASerializationAction: TMVCSerializationAction);
var
I: Integer;
lDict: TMVCStringDictionary;
lDict: IMVCLinks;
lSer: IMVCTypeSerializer;
begin
if not Assigned(AList) then
raise EMVCSerializationException.Create('List not assigned');
if Assigned(ASerializationAction) then
begin
lDict := TMVCStringDictionary.Create;
try
for I := 0 to Pred(AList.Count) do
begin
lDict.Clear;
InternalObjectToJsonObject(AList.GetItem(I), AJsonArray.AddObject, AType, AIgnoredAttributes,
ASerializationAction, lDict, lSer);
end;
finally
lDict.Free;
lDict := TJDOLinks.Create;
for I := 0 to Pred(AList.Count) do
begin
lDict.Clear;
InternalObjectToJsonObject(AList.GetItem(I), AJsonArray.AddObject, AType, AIgnoredAttributes,
ASerializationAction, lDict, lSer);
end;
end
else
@ -940,7 +949,8 @@ end;
procedure TMVCJsonDataObjectsSerializer.InternalObjectToJsonObject(const AObject: TObject;
const AJsonObject: TJDOJsonObject; const AType: TMVCSerializationType;
const AIgnoredAttributes: TMVCIgnoredList;
const ASerializationAction: TMVCSerializationAction; const Dict: TMVCStringDictionary;
const ASerializationAction: TMVCSerializationAction;
const Links: IMVCLinks;
const Serializer: IMVCTypeSerializer);
var
ObjType: TRttiType;
@ -979,8 +989,8 @@ begin
if Assigned(ASerializationAction) then
begin
ASerializationAction(AObject, Dict);
Serializer.SerializeAttribute(Dict, TMVCConstants.HATEOAS_PROP_NAME, AJsonObject, []);
ASerializationAction(AObject, Links);
TJDOLinks(Links).FillJSONArray(AJsonObject.A[TMVCConstants.HATEOAS_PROP_NAME]);
end;
end;
@ -1009,7 +1019,7 @@ var
JsonArray: TJDOJsonArray;
ObjList: IMVCList;
Obj: TObject;
lLinks: TMVCStringDictionary;
lLinks: IMVCLinks;
lSer: IMVCTypeSerializer;
begin
Result := EmptyStr;
@ -1033,16 +1043,13 @@ begin
('Cannot serialize _links without TMVCStringDictionary custom serializer');
end;
lLinks := TMVCStringDictionary.Create;
try
for Obj in ObjList do
begin
InternalObjectToJsonObject(Obj, JsonArray.AddObject, GetSerializationType(Obj, AType),
AIgnoredAttributes,
ASerializationAction, lLinks, lSer);
end;
finally
lLinks.Free;
lLinks := TJDOLinks.Create;
for Obj in ObjList do
begin
lLinks.Clear;
InternalObjectToJsonObject(Obj, JsonArray.AddObject, GetSerializationType(Obj, AType),
AIgnoredAttributes,
ASerializationAction, lLinks, lSer);
end;
end
else
@ -1069,7 +1076,7 @@ var
JsonArray: TJDOJsonArray;
BookMark: TBookmark;
lNameCase: TMVCNameCase;
lLinks: TMVCStringDictionary;
lLinks: IMVCLinks;
LJObj: TJsonObject;
lDataSetFields: TMVCDataSetFields;
begin
@ -1081,45 +1088,36 @@ begin
lLinks := nil;
if Assigned(ASerializationAction) then
begin
lLinks := TMVCStringDictionary.Create;
lLinks := TJDOLinks.Create;
end;
lDataSetFields := GetDataSetFields(ADataSet, AIgnoredFields, ANameCase);
try
lDataSetFields := GetDataSetFields(ADataSet, AIgnoredFields, ANameCase);
JsonArray := TJDOJsonArray.Create;
try
JsonArray := TJDOJsonArray.Create;
try
BookMark := ADataSet.BookMark;
lNameCase := GetNameCase(ADataSet, ANameCase);
ADataSet.First;
while not ADataSet.Eof do
BookMark := ADataSet.BookMark;
lNameCase := GetNameCase(ADataSet, ANameCase);
ADataSet.First;
while not ADataSet.Eof do
begin
LJObj := JsonArray.AddObject;
DataSetToJsonObject(ADataSet, LJObj, lNameCase, AIgnoredFields, lDataSetFields);
if Assigned(ASerializationAction) then
begin
LJObj := JsonArray.AddObject;
DataSetToJsonObject(ADataSet, LJObj, lNameCase, AIgnoredFields, lDataSetFields);
if Assigned(ASerializationAction) then
begin
lLinks.Clear;
ASerializationAction(ADataSet, lLinks);
TMVCStringDictionarySerializer(fStringDictionarySerializer)
.Serialize(lLinks, LJObj.O['_links']);
end;
ADataSet.Next;
lLinks.Clear;
ASerializationAction(ADataSet, lLinks);
TJDOLinks(lLinks).FillJSONArray(LJObj.A[TMVCConstants.HATEOAS_PROP_NAME]);
end;
Result := JsonArray.ToJSON(True);
finally
JsonArray.Free;
if ADataSet.BookmarkValid(BookMark) then
ADataSet.GotoBookmark(BookMark);
ADataSet.FreeBookmark(BookMark);
ADataSet.Next;
end;
Result := JsonArray.ToJSON(True);
finally
lDataSetFields.Free;
JsonArray.Free;
if ADataSet.BookmarkValid(BookMark) then
ADataSet.GotoBookmark(BookMark);
ADataSet.FreeBookmark(BookMark);
end;
finally
if Assigned(ASerializationAction) then
begin
lLinks.Free;
end;
lDataSetFields.Free;
end;
end;
@ -1130,6 +1128,7 @@ function TMVCJsonDataObjectsSerializer.SerializeDataSetRecord(const ADataSet: TD
var
JsonObject: TJDOJsonObject;
lDataSetFields: TMVCDataSetFields;
lLinks: IMVCLinks;
begin
Result := EmptyStr;
if (not Assigned(ADataSet)) or (ADataSet.IsEmpty) then
@ -1140,6 +1139,12 @@ begin
try
DataSetToJsonObject(ADataSet, JsonObject, GetNameCase(ADataSet, ANameCase), AIgnoredFields,
lDataSetFields);
lLinks := TJDOLinks.Create;
if Assigned(ASerializationAction) then
begin
ASerializationAction(ADataSet, lLinks);
TJDOLinks(lLinks).FillJSONArray(JsonObject.A[TMVCConstants.HATEOAS_PROP_NAME]);
end;
Result := JsonObject.ToJSON(True);
finally
JsonObject.Free;
@ -1154,9 +1159,9 @@ function TMVCJsonDataObjectsSerializer.SerializeObject(const AObject: TObject;
const AIgnoredAttributes: TMVCIgnoredList;
const ASerializationAction: TMVCSerializationAction): string;
var
JsonObject: TJDOJsonObject;
ObjType: TRttiType;
lDict: TMVCStringDictionary;
LJObj: TJDOJsonObject;
lObjType: TRttiType;
lDict: IMVCLinks;
begin
Result := EmptyStr;
@ -1172,41 +1177,37 @@ begin
if AObject is System.JSON.TJsonValue then
Exit(System.JSON.TJsonValue(AObject).ToJSON);
ObjType := GetRttiContext.GetType(AObject.ClassType);
lObjType := GetRttiContext.GetType(AObject.ClassType);
if GetTypeSerializers.ContainsKey(ObjType.Handle) then
if GetTypeSerializers.ContainsKey(lObjType.Handle) then
begin
GetTypeSerializers.Items[ObjType.Handle].SerializeRoot(AObject, TObject(JsonObject), []);
GetTypeSerializers.Items[lObjType.Handle].SerializeRoot(AObject, TObject(LJObj), []);
try
Result := JsonObject.ToJSON(True);
Result := LJObj.ToJSON(True);
finally
JsonObject.Free;
LJObj.Free;
end;
Exit;
end;
JsonObject := TJDOJsonObject.Create;
LJObj := TJDOJsonObject.Create;
try
if Assigned(ASerializationAction) then
begin
lDict := TMVCStringDictionary.Create;
try
InternalObjectToJsonObject(AObject, JsonObject, GetSerializationType(AObject, AType),
AIgnoredAttributes,
ASerializationAction, lDict, fStringDictionarySerializer);
finally
lDict.Free;
end;
lDict := TJDOLinks.Create;
InternalObjectToJsonObject(AObject, LJObj, GetSerializationType(AObject, AType),
AIgnoredAttributes,
ASerializationAction, lDict, fStringDictionarySerializer);
end
else
begin
InternalObjectToJsonObject(AObject, JsonObject, GetSerializationType(AObject, AType),
InternalObjectToJsonObject(AObject, LJObj, GetSerializationType(AObject, AType),
AIgnoredAttributes, nil,
nil, nil);
end;
Result := JsonObject.ToJSON(True);
Result := LJObj.ToJSON(True);
finally
JsonObject.Free;
LJObj.Free;
end;
end;
@ -1384,49 +1385,52 @@ begin
JSON.O[KeyName] := TJDOJsonObject.Create;
JSON.O[KeyName].Assign(TJDOJsonObject(Value.AsObject));
end
else if (lValueAsObj is TJDOJsonArray) or (lValueAsObj is TJsonArray)
{$IFDEF RIOORBETTER} or
{ this is for a bug in delphi103rio }
(lValueAsObj.QualifiedClassName = 'jsondataobjects.tjsonarray') or
{ this is for a bug in delphi103rio }
(lValueAsObj.QualifiedClassName = 'jsondataobjects.tjdojsonarray')
{$ENDIF}
then
begin
JSON.A[KeyName] := TJDOJsonArray.Create;
JSON.A[KeyName].Assign(TJDOJsonArray(Value.AsObject));
end
else if lValueAsObj is TDataSet then
begin
lSer := TMVCJsonDataObjectsSerializer.Create;
try
JSON.A[KeyName] := TJDOJsonArray.Create;
lSer.DataSetToJsonArray(TDataSet(lValueAsObj), JSON.A[KeyName],
TMVCNameCase.ncLowerCase, []);
finally
lSer.Free;
end;
end
else if TDuckTypedList.CanBeWrappedAsList(lValueAsObj, lMVCList) then
begin
lSer := TMVCJsonDataObjectsSerializer.Create;
try
JSON.A[KeyName] := TJDOJsonArray.Create;
lSer.ListToJsonArray(lMVCList, JSON.A[KeyName], TMVCSerializationType.stDefault, nil);
finally
lSer.Free;
end;
end
else
begin
lSer := TMVCJsonDataObjectsSerializer.Create;
try
JSON.O[KeyName] := lSer.SerializeObjectToJSON(lValueAsObj,
TMVCSerializationType.stProperties, [], nil);
finally
lSer.Free;
end;
end;
if (lValueAsObj is TJDOJsonArray) or (lValueAsObj is TJsonArray)
{$IFDEF RIOORBETTER} or
{ this is for a bug in delphi103rio }
(lValueAsObj.QualifiedClassName = 'jsondataobjects.tjsonarray') or
{ this is for a bug in delphi103rio }
(lValueAsObj.QualifiedClassName = 'jsondataobjects.tjdojsonarray')
{$ENDIF}
then
begin
JSON.A[KeyName] := TJDOJsonArray.Create;
JSON.A[KeyName].Assign(TJDOJsonArray(Value.AsObject));
end
else
if lValueAsObj is TDataSet then
begin
lSer := TMVCJsonDataObjectsSerializer.Create;
try
JSON.A[KeyName] := TJDOJsonArray.Create;
lSer.DataSetToJsonArray(TDataSet(lValueAsObj), JSON.A[KeyName],
TMVCNameCase.ncLowerCase, []);
finally
lSer.Free;
end;
end
else
if TDuckTypedList.CanBeWrappedAsList(lValueAsObj, lMVCList) then
begin
lSer := TMVCJsonDataObjectsSerializer.Create;
try
JSON.A[KeyName] := TJDOJsonArray.Create;
lSer.ListToJsonArray(lMVCList, JSON.A[KeyName], TMVCSerializationType.stDefault, nil);
finally
lSer.Free;
end;
end
else
begin
lSer := TMVCJsonDataObjectsSerializer.Create;
try
JSON.O[KeyName] := lSer.SerializeObjectToJSON(lValueAsObj,
TMVCSerializationType.stProperties, [], nil);
finally
lSer.Free;
end;
end;
end;
else
raise EMVCException.Create('Invalid type');
@ -1463,4 +1467,24 @@ begin
end;
end;
procedure MVCStringDictionaryListToJSONArray(const aStringDictionaryList: TMVCStringDictionaryList;
const AJsonArray: TJsonArray);
var
lStringDictionary: TMVCStringDictionary;
begin
if aStringDictionaryList = nil then
Exit;
for lStringDictionary in aStringDictionaryList do
begin
TMVCStringDictionarySerializer.Serialize(lStringDictionary, AJsonArray.AddObject);
end;
end;
{ TJDOLinks }
procedure TJDOLinks.FillJSONArray(const AJsonArray: TJsonArray);
begin
MVCStringDictionaryListToJSONArray(LinksData, AJsonArray);
end;
end.

196
sources/MVCFramework.pas
View File

@ -64,7 +64,7 @@ uses
// Delphi XE4 (all update) and XE5 (with no update) don't contains this unit. Look for the bug in QC
// https://quality.embarcadero.com/browse/RSP-17216
{$IFNDEF MOBILE} //file upload is not supported on mobile
{$IFNDEF MOBILE} // file upload is not supported on mobile
Web.ReqMulti,
{$ENDIF}
Web.HTTPApp,
@ -76,7 +76,8 @@ uses
LoggerPro,
IdGlobal,
IdGlobalProtocols,
IdURI, MVCFramework.Commons;
IdURI,
MVCFramework.Commons;
type
@ -161,7 +162,6 @@ type
end;
TMVCWebRequest = class
private
FWebRequest: TWebRequest;
@ -439,7 +439,8 @@ type
procedure ResponseStatus(const AStatusCode: Integer; const AReasonString: string = '');
// Serializer access
function Serializer: IMVCSerializer; overload;
function Serializer(const AContentType: string; const ARaiseExcpIfNotExists: Boolean = True): IMVCSerializer; overload;
function Serializer(const AContentType: string; const ARaiseExcpIfNotExists: Boolean = True)
: IMVCSerializer; overload;
end;
IMVCAuthenticationHandler = interface
@ -466,17 +467,20 @@ type
procedure Redirect(const AUrl: string); virtual;
procedure ResponseStatus(const AStatusCode: Integer; const AReasonString: string = ''); virtual;
function Serializer: IMVCSerializer; overload;
function Serializer(const AContentType: string; const ARaiseExceptionIfNotExists: Boolean = True): IMVCSerializer; overload;
function Serializer(const AContentType: string; const ARaiseExceptionIfNotExists: Boolean = True)
: IMVCSerializer; overload;
procedure SendStream(const AStream: TStream; const AOwns: Boolean = True; const ARewind: Boolean = False); virtual;
procedure SendFile(const AFileName: string); virtual;
procedure RenderResponseStream; virtual;
function ResponseStream: TStringBuilder;
procedure Render(const AContent: string); overload;
//PODO renders
// PODO renders
procedure Render(const AObject: TObject; const ASerializationAction: TMVCSerializationAction = nil); overload;
procedure Render(const AObject: TObject; const AOwns: Boolean; const ASerializationAction: TMVCSerializationAction = nil); overload;
procedure Render(const AObject: TObject; const AOwns: Boolean; const AType: TMVCSerializationType; const ASerializationAction: TMVCSerializationAction = nil); overload;
//PODOs Collection render
procedure Render(const AObject: TObject; const AOwns: Boolean;
const ASerializationAction: TMVCSerializationAction = nil); overload;
procedure Render(const AObject: TObject; const AOwns: Boolean; const AType: TMVCSerializationType;
const ASerializationAction: TMVCSerializationAction = nil); overload;
// PODOs Collection render
procedure Render<T: class>(const ACollection: TObjectList<T>;
const ASerializationAction: TMVCSerializationAction<T> = nil); overload;
procedure Render<T: class>(const ACollection: TObjectList<T>; const AOwns: Boolean;
@ -492,7 +496,7 @@ type
procedure Render(const AException: Exception; AExceptionItems: TList<string> = nil;
const AOwns: Boolean = True); overload;
procedure Render(const AResponse: TMVCResponse; const AOwns: Boolean = True); overload;
//Dataset support
// Dataset support
procedure Render(
const ADataSet: TDataSet;
const ASerializationAction: TMVCDatasetSerializationAction = nil
@ -646,7 +650,8 @@ type
procedure OnAfterControllerAction(AContext: TWebContext; const AActionName: string; const AHandled: Boolean);
end;
TMVCExceptionHandlerProc = reference to procedure(E: Exception; SelectedController: TMVCController; WebContext: TWebContext; var ExceptionHandled: Boolean);
TMVCExceptionHandlerProc = reference to procedure(E: Exception; SelectedController: TMVCController;
WebContext: TWebContext; var ExceptionHandled: Boolean);
TMVCEngine = class(TComponent)
private const
@ -671,7 +676,8 @@ type
procedure RegisterDefaultsSerializers;
function GetViewEngineClass: TMVCViewEngineClass;
protected
function CustomExceptionHandling(const Ex: Exception; const ASelectedController: TMVCController; const AContext: TWebContext): Boolean;
function CustomExceptionHandling(const Ex: Exception; const ASelectedController: TMVCController;
const AContext: TWebContext): Boolean;
procedure ConfigDefaultValues; virtual;
procedure SaveCacheConfigValues;
procedure LoadSystemControllers; virtual;
@ -798,13 +804,15 @@ type
function IsShuttingDown: Boolean;
procedure EnterInShutdownState;
function CreateResponse(const StatusCode: UInt16; const ReasonString: String; const Message: String = ''): TMVCResponse;
implementation
uses
MVCFramework.Router,
MVCFramework.SysControllers,
MVCFramework.Serializer.JsonDataObjects, MVCFramework.JSONRPC;
MVCFramework.Serializer.JsonDataObjects,
MVCFramework.JSONRPC;
var
_IsShuttingDown: Int64 = 0;
@ -820,6 +828,11 @@ begin
TInterlocked.Add(_IsShuttingDown, 1);
end;
function CreateResponse(const StatusCode: UInt16; const ReasonString: String; const Message: String = ''): TMVCResponse;
begin
Result := TMVCResponse.Create(StatusCode, ReasonString, Message);
end;
{ MVCHTTPMethodsAttribute }
constructor MVCHTTPMethodsAttribute.Create(const AMVCHTTPMethods: TMVCHTTPMethods);
@ -968,7 +981,16 @@ begin
if FSerializers.TryGetValue(ContentMediaType, lSerializer) then
lSerializer.DeserializeObject(Body, AObject)
else
raise EMVCException.CreateFmt('Body ContentType "%s" not supported', [ContentType]);
begin
if ContentType.Trim.IsEmpty then
begin
raise EMVCException.Create('Request ContentType header is empty, cannot deserialize body');
end
else
begin
raise EMVCException.CreateFmt('Body ContentType "%s" not supported', [ContentType]);
end;
end;
end;
procedure TMVCWebRequest.BodyForListOf<T>(const AObjectList: TObjectList<T>);
@ -1443,12 +1465,13 @@ begin
FRequest := TMVCApacheWebRequest.Create(ARequest, ASerializers)
{$IFNDEF LINUX}
else if ARequest is TISAPIRequest then
FRequest := TMVCISAPIWebRequest.Create(ARequest, ASerializers)
else
if ARequest is TISAPIRequest then
FRequest := TMVCISAPIWebRequest.Create(ARequest, ASerializers)
{$ENDIF}
else
raise EMVCException.Create('Unknown request type ' + ARequest.Classname);
else
raise EMVCException.Create('Unknown request type ' + ARequest.Classname);
{$ELSE}
FRequest := TMVCISAPIWebRequest.Create(ARequest, ASerializers)
@ -1755,14 +1778,13 @@ begin
{$IFDEF BERLINORBETTER}
ARequest.ReadTotalContent;
//Double check for malicious content-length header
// Double check for malicious content-length header
if ARequest.ContentLength > FConfigCache_MaxRequestSize then
begin
raise EMVCException.CreateFmt('Request size exceeded the max allowed size [%d KiB] (2)',
[(FConfigCache_MaxRequestSize div 1024)]);
end;
{$ENDIF}
LParamsTable := TMVCRequestParamsTable.Create;
try
LContext := TWebContext.Create(ARequest, AResponse, FConfig, FSerializers);
@ -1777,7 +1799,8 @@ begin
ExecuteBeforeRoutingMiddleware(LContext, LHandled);
if not LHandled then
begin
if LRouter.ExecuteRouting(ARequest.PathInfo, TMVCRouter.StringMethodToHTTPMetod(ARequest.Method),
{TODO -oDanieleT -cGeneral : Allow for HTTP method override}
if LRouter.ExecuteRouting(ARequest.PathInfo, LContext.Request.HTTPMethod,
ARequest.ContentType, ARequest.Accept, FControllers, FConfig[TMVCConfigKey.DefaultContentType],
FConfig[TMVCConfigKey.DefaultContentCharset], LParamsTable, LResponseContentMediaType,
LResponseContentCharset) then
@ -1816,14 +1839,16 @@ begin
LActionFormalParams := LRouter.MethodToCall.GetParameters;
if (Length(LActionFormalParams) = 0) then
SetLength(LActualParams, 0)
else if (Length(LActionFormalParams) = 1) and
(SameText(LActionFormalParams[0].ParamType.QualifiedName, 'MVCFramework.TWebContext')) then
begin
SetLength(LActualParams, 1);
LActualParams[0] := LContext;
end
else
FillActualParamsForAction(LContext, LActionFormalParams, LRouter.MethodToCall.Name, LActualParams);
if (Length(LActionFormalParams) = 1) and
(SameText(LActionFormalParams[0].ParamType.QualifiedName, 'MVCFramework.TWebContext')) then
begin
SetLength(LActualParams, 1);
LActualParams[0] := LContext;
end
else
FillActualParamsForAction(LContext, LActionFormalParams, LRouter.MethodToCall.Name,
LActualParams);
LSelectedController.OnBeforeAction(LContext, LRouter.MethodToCall.Name, LHandled);
@ -1896,7 +1921,8 @@ begin
end
else
begin
SendRawHTTPStatus(LContext, E.HTTPErrorCode, Format('[%s] %s', [E.Classname, E.Message]), E.ClassName);
SendRawHTTPStatus(LContext, E.HTTPErrorCode, Format('[%s] %s', [E.Classname, E.Message]),
E.Classname);
end;
end;
end;
@ -1904,7 +1930,8 @@ begin
begin
if not CustomExceptionHandling(EIO, LSelectedController, LContext) then
begin
Log.ErrorFmt('[%s] %s (Custom message: "%s")', [EIO.Classname, EIO.Message, 'Invalid Op'], LOGGERPRO_TAG);
Log.ErrorFmt('[%s] %s (Custom message: "%s")', [EIO.Classname, EIO.Message, 'Invalid Op'],
LOGGERPRO_TAG);
if Assigned(LSelectedController) then
begin
LSelectedController.ResponseStatus(HTTP_STATUS.InternalServerError);
@ -1931,7 +1958,7 @@ begin
else
begin
SendRawHTTPStatus(LContext, HTTP_STATUS.InternalServerError,
Format('[%s] %s', [Ex.Classname, Ex.Message]), Ex.Classname);
Format('[%s] %s', [Ex.Classname, Ex.Message]), Ex.Classname);
end;
end;
end;
@ -2043,28 +2070,30 @@ begin
raise EMVCException.CreateFmt('Invalid TDate value for param [%s]', [AActionFormalParams[I].Name]);
end;
end
else if lQualifiedName = 'System.TDateTime' then
begin
try
WasDateTime := True;
AActualParams[I] := ISOTimeStampToDateTime(StrValue);
except
on E: Exception do
begin
raise EMVCException.CreateFmt('Invalid TDateTime value for param [%s][%s]',
[AActionFormalParams[I].Name, E.Message]);
else
if lQualifiedName = 'System.TDateTime' then
begin
try
WasDateTime := True;
AActualParams[I] := ISOTimeStampToDateTime(StrValue);
except
on E: Exception do
begin
raise EMVCException.CreateFmt('Invalid TDateTime value for param [%s][%s]',
[AActionFormalParams[I].Name, E.Message]);
end;
end;
end
else
if lQualifiedName = 'System.TTime' then
begin
try
WasDateTime := True;
AActualParams[I] := ISOTimeToTime(StrValue);
except
raise EMVCException.CreateFmt('Invalid TTime value for param [%s]', [AActionFormalParams[I].Name]);
end;
end;
end;
end
else if lQualifiedName = 'System.TTime' then
begin
try
WasDateTime := True;
AActualParams[I] := ISOTimeToTime(StrValue);
except
raise EMVCException.CreateFmt('Invalid TTime value for param [%s]', [AActionFormalParams[I].Name]);
end;
end;
if not WasDateTime then
begin
FormatSettings.DecimalSeparator := '.';
@ -2077,12 +2106,13 @@ begin
begin
if SameText(StrValue, 'true') or SameText(StrValue, '1') then
AActualParams[I] := True
else if SameText(StrValue, 'false') or SameText(StrValue, '0') then
AActualParams[I] := False
else
raise EMVCException.CreateFmt
('Invalid boolean value for parameter %s. Boolean parameters accepts only "true"/"false" or "1"/"0".',
[ParamName]);
if SameText(StrValue, 'false') or SameText(StrValue, '0') then
AActualParams[I] := False
else
raise EMVCException.CreateFmt
('Invalid boolean value for parameter %s. Boolean parameters accepts only "true"/"false" or "1"/"0".',
[ParamName]);
end
else
raise EMVCException.CreateFmt('Invalid type for parameter %s. Allowed types are ' +
@ -2628,7 +2658,8 @@ begin
GetContext.Response.RawWebResponse.SendRedirect(AUrl);
end;
procedure TMVCRenderer.Render(const AObject: TObject; const AOwns: Boolean; const ASerializationAction: TMVCSerializationAction = nil);
procedure TMVCRenderer.Render(const AObject: TObject; const AOwns: Boolean;
const ASerializationAction: TMVCSerializationAction = nil);
begin
Render(AObject, AOwns, stDefault, ASerializationAction);
end;
@ -2766,7 +2797,8 @@ begin
GetViewDataSets.Add(aDataSetName, Value);
end;
procedure TMVCRenderer.Render(const AObject: TObject; const AOwns: Boolean; const AType: TMVCSerializationType; const ASerializationAction: TMVCSerializationAction = nil);
procedure TMVCRenderer.Render(const AObject: TObject; const AOwns: Boolean; const AType: TMVCSerializationType;
const ASerializationAction: TMVCSerializationAction = nil);
begin
try
Render(Serializer(GetContentType).SerializeObject(AObject, AType, [], ASerializationAction));
@ -2804,15 +2836,34 @@ begin
end;
procedure TMVCRenderer.Render(const ADataSet: TDataSet; const AOwns: Boolean; const AIgnoredFields: TMVCIgnoredList;
const ANameCase: TMVCNameCase; const ASerializationType: TMVCDatasetSerializationType; const ASerializationAction: TMVCDatasetSerializationAction);
const ANameCase: TMVCNameCase; const ASerializationType: TMVCDatasetSerializationType;
const ASerializationAction: TMVCDatasetSerializationAction);
begin
if Assigned(ADataSet) then
begin
try
if ASerializationType = dstSingleRecord then
Render(Serializer(GetContentType).SerializeDataSetRecord(ADataSet, AIgnoredFields, ANameCase, ASerializationAction))
case ASerializationType of
dstSingleRecord:
begin
Render(Serializer(GetContentType).SerializeDataSetRecord(ADataSet, AIgnoredFields, ANameCase,
ASerializationAction))
end;
dstAllRecords:
begin
Render(Serializer(GetContentType).SerializeDataSet(ADataSet, AIgnoredFields, ANameCase,
ASerializationAction))
end
else
Render(Serializer(GetContentType).SerializeDataSet(ADataSet, AIgnoredFields, ANameCase, ASerializationAction))
begin
raise EMVCSerializationException.Create('Invalid dataset serialization type');
end;
end;
// if ASerializationType = dstSingleRecord then
// Render(Serializer(GetContentType).SerializeDataSetRecord(ADataSet, AIgnoredFields, ANameCase,
// ASerializationAction))
// else
// Render(Serializer(GetContentType).SerializeDataSet(ADataSet, AIgnoredFields, ANameCase, ASerializationAction))
finally
if AOwns then
ADataSet.Free;
@ -2832,7 +2883,7 @@ begin
try
if Assigned(ASerializationAction) then
begin
lSerializationAction := procedure(const AObject: TObject; const Dict: TMVCStringDictionary)
lSerializationAction := procedure(const AObject: TObject; const Dict: IMVCLinks)
begin
ASerializationAction(T(AObject), Dict);
end;
@ -3037,7 +3088,8 @@ begin
Render(ADataSet, True, ASerializationAction);
end;
procedure TMVCRenderer.Render(const ADataSet: TDataSet; const AOwns: Boolean; const ASerializationAction: TMVCDatasetSerializationAction);
procedure TMVCRenderer.Render(const ADataSet: TDataSet; const AOwns: Boolean;
const ASerializationAction: TMVCDatasetSerializationAction);
begin
Render(ADataSet, AOwns, dstAllRecords, ASerializationAction);
end;
@ -3049,19 +3101,19 @@ end;
procedure TMVCRenderer.Render(
const ADataSet: TDataSet;
const AOwns: Boolean;
const AIgnoredFields: TMVCIgnoredList;
const ASerializationType: TMVCDatasetSerializationType;
const ASerializationAction: TMVCDatasetSerializationAction);
const AOwns: Boolean;
const AIgnoredFields: TMVCIgnoredList;
const ASerializationType: TMVCDatasetSerializationType;
const ASerializationAction: TMVCDatasetSerializationAction);
begin
Render(ADataSet, AOwns, AIgnoredFields, ncLowerCase, ASerializationType, ASerializationAction);
end;
procedure TMVCRenderer.Render(
const ADataSet: TDataSet;
const AOwns: Boolean;
const ASerializationType: TMVCDatasetSerializationType;
const ASerializationAction: TMVCDatasetSerializationAction);
const AOwns: Boolean;
const ASerializationType: TMVCDatasetSerializationType;
const ASerializationAction: TMVCDatasetSerializationAction);
begin
Render(ADataSet, AOwns, [], ASerializationType, ASerializationAction);
end;

2
sources/dmvcframeworkbuildconsts.inc
View File

@ -1,2 +1,2 @@
const
DMVCFRAMEWORK_VERSION = '3.1.1 (beryllium) RC4';
DMVCFRAMEWORK_VERSION = '3.1.1 (beryllium) RC5';

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

@ -29,7 +29,8 @@ interface
uses
DUnitX.TestFramework,
MVCFramework.RESTClient,
MVCFramework.JSONRPC.Client, System.DateUtils;
MVCFramework.JSONRPC.Client,
System.DateUtils;
const
@ -41,6 +42,7 @@ const
{$ENDIF}
type
TBaseServerTest = class(TObject)
@ -698,9 +700,9 @@ begin
try
for I := 0 to lJArr.Count - 1 do
begin
Assert.isFalse(lJArr[I].O[TMVCConstants.HATEOS_PROP_NAME].IsNull, '_links doesn''t exists');
Assert.isFalse(lJArr[I].O[TMVCConstants.HATEOS_PROP_NAME]['x-ref-lastname'].IsNull, '_links.x-ref-lastname doesn''t exists');
Assert.isFalse(lJArr[I].O[TMVCConstants.HATEOS_PROP_NAME]['x-ref-firstname'].IsNull, '_links.x-ref-firstname doesn''t exists');
Assert.isTrue(lJArr[I].A[TMVCConstants.HATEOAS_PROP_NAME].Count = 2, '_links doesn''t exists');
Assert.areEqual(lJArr[I].A[TMVCConstants.HATEOAS_PROP_NAME].O[0].s[HATEOAS.REL], 'test0');
Assert.areEqual(lJArr[I].A[TMVCConstants.HATEOAS_PROP_NAME].O[1].s[HATEOAS.REL], 'test1');
end;
finally
lJArr.Free;

12
unittests/general/TestServer/TestServerControllerU.pas
View File

@ -441,10 +441,16 @@ end;
procedure TTestServerController.TestGetPersonsHateos;
begin
Render<TPerson>(TPerson.GetList, True,
procedure(const Person: TPerson; const Links: TMVCStringDictionary)
procedure(const Person: TPerson; const Links: IMVCLinks)
begin
Links['x-ref-firstname'] := '/api/people/' + Person.FirstName;
Links['x-ref-lastname'] := '/api/people/' + Person.LastName;
Links.AddRefLink
.Add(HATEOAS.HREF, '/api/people/' + Person.ID.ToString)
.Add(HATEOAS.REL, 'test0')
.Add(HATEOAS._TYPE, 'application/json');
Links.AddRefLink
.Add(HATEOAS.HREF, '/api/test/' + Person.ID.ToString)
.Add(HATEOAS.REL, 'test1')
.Add(HATEOAS._TYPE, 'application/json')
end);
end;