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

Merge branch 'master' of https://github.com/danieleteti/delphimvcframework

Browse Source
This commit is contained in:
Pedro 2019-02-25 08:51:35 -03:00
commit 506a187418
12 changed files with 493 additions and 289 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
README.md
View File

@ -76,8 +76,11 @@ Congratulations to Daniele Teti and all the staff for the excellent work!" -- Ma
- New! `TMVCActiveRecord.DeleteRQL` deletes records using an `RQL` expression as `where` clause. - New! `TMVCActiveRecord.DeleteRQL` deletes records using an `RQL` expression as `where` clause.
- New! Microsoft SQLServer Support in ActiveRecord and RQL (thanks to one of the biggest Delphi based company in Italy which heavily uses DMVCFramework) - New! Microsoft SQLServer Support in ActiveRecord and RQL (thanks to one of the biggest Delphi based company in Italy which heavily uses DMVCFramework)
- Improved! `ActiveRecordShowCase` sample is much better now. - Improved! `ActiveRecordShowCase` sample is much better now.
- Improved! In case of unhandled exception `TMVCEngine` is compliant with the default response content-type (usually it did would reply using `text/plain`).
- Fix! [issue184](https://github.com/danieleteti/delphimvcframework/issues/184).
- New Installation procedure! Just open the project group, build all and install the design-time package (which is `dmvcframeworkDT`) - New Installation procedure! Just open the project group, build all and install the design-time package (which is `dmvcframeworkDT`)
|Delphi Version|Project Group| |Delphi Version|Project Group|
|---|---| |---|---|
|Delphi 10.3 Rio| `packages\d103\dmvcframework_group.groupproj`| |Delphi 10.3 Rio| `packages\d103\dmvcframework_group.groupproj`|

3
samples/CustomAuth/AuthHandlerU.pas
View File

@ -51,6 +51,9 @@ type
implementation implementation
uses
System.SysUtils;
{ TCustomAuth } { TCustomAuth }
procedure TCustomAuth.OnAuthentication(const AContext: TWebContext; const UserName: string; const Password: string; procedure TCustomAuth.OnAuthentication(const AContext: TWebContext; const UserName: string; const Password: string;

2
samples/CustomAuth/CustomAuthClient.dproj
View File

@ -1,7 +1,7 @@
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup> <PropertyGroup>
<ProjectGuid>{B42B1969-7408-4E0A-8624-A48DADE46556}</ProjectGuid> <ProjectGuid>{B42B1969-7408-4E0A-8624-A48DADE46556}</ProjectGuid>
<ProjectVersion>18.5</ProjectVersion> <ProjectVersion>18.6</ProjectVersion>
<FrameworkType>VCL</FrameworkType> <FrameworkType>VCL</FrameworkType>
<MainSource>CustomAuthClient.dpr</MainSource> <MainSource>CustomAuthClient.dpr</MainSource>
<Base>True</Base> <Base>True</Base>

2
samples/CustomAuth/CustomAuthServer.dproj
View File

@ -1,7 +1,7 @@
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup> <PropertyGroup>
<ProjectGuid>{0293A1B2-2793-41CE-9099-8B24A46AA8CF}</ProjectGuid> <ProjectGuid>{0293A1B2-2793-41CE-9099-8B24A46AA8CF}</ProjectGuid>
<ProjectVersion>18.5</ProjectVersion> <ProjectVersion>18.6</ProjectVersion>
<FrameworkType>VCL</FrameworkType> <FrameworkType>VCL</FrameworkType>
<MainSource>CustomAuthServer.dpr</MainSource> <MainSource>CustomAuthServer.dpr</MainSource>
<Base>True</Base> <Base>True</Base>

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

@ -611,12 +611,17 @@ begin
ChildObject := AValue.AsObject; ChildObject := AValue.AsObject;
if Assigned(ChildObject) then if Assigned(ChildObject) then
begin begin
ChildList := TDuckTypedList.Wrap(ChildObject); if ChildObject is TDataSet then
if TMVCSerializerHelper.AttributeExists<MVCListOfAttribute>(ACustomAttributes, ChildListOfAtt) then JsonArrayToDataSet(AJsonObject.A[AName], ChildObject as TDataSet, AIgnored, ncLowerCase)
JsonArrayToList(AJsonObject.A[AName], ChildList, ChildListOfAtt.Value, AType, AIgnored)
else else
raise EMVCDeserializationException.CreateFmt begin
('You can not deserialize a list %s without the attribute MVCListClassTypeAttribute.', [AName]); ChildList := TDuckTypedList.Wrap(ChildObject);
if TMVCSerializerHelper.AttributeExists<MVCListOfAttribute>(ACustomAttributes, ChildListOfAtt) then
JsonArrayToList(AJsonObject.A[AName], ChildList, ChildListOfAtt.Value, AType, AIgnored)
else
raise EMVCDeserializationException.CreateFmt
('You can not deserialize a list %s without the attribute MVCListClassTypeAttribute.', [AName]);
end;
end; end;
end; end;
end; end;

530
sources/MVCFramework.pas
View File

@ -57,7 +57,8 @@ uses
// MVCFramework.Serializer.JSON, // MVCFramework.Serializer.JSON,
{$IFDEF WEBAPACHEHTTP} {$IFDEF WEBAPACHEHTTP}
Web.ApacheHTTP, // Apache Support since XE6 http://docwiki.embarcadero.com/Libraries/XE6/de/Web.ApacheHTTP Web.ApacheHTTP,
// Apache Support since XE6 http://docwiki.embarcadero.com/Libraries/XE6/de/Web.ApacheHTTP
{$ENDIF} {$ENDIF}
@ -340,7 +341,8 @@ type
procedure Flush; virtual; procedure Flush; virtual;
procedure BindToSession(const ASessionId: string); procedure BindToSession(const ASessionId: string);
function SendSessionCookie(const AContext: TWebContext): string; function SendSessionCookie(const AContext: TWebContext): string;
function AddSessionToTheSessionList(const ASessionType, ASessionId: string; const ASessionTimeout: Integer): TWebSession; function AddSessionToTheSessionList(const ASessionType, ASessionId: string; const ASessionTimeout: Integer)
: TWebSession;
public public
constructor Create(const ARequest: TWebRequest; const AResponse: TWebResponse; const AConfig: TMVCConfig; constructor Create(const ARequest: TWebRequest; const AResponse: TWebResponse; const AConfig: TMVCConfig;
const ASerializers: TDictionary<string, IMVCSerializer>); const ASerializers: TDictionary<string, IMVCSerializer>);
@ -388,8 +390,7 @@ type
IMVCRenderer = interface IMVCRenderer = interface
['{2FF6DAC8-2F19-4C78-B9EC-A86296847D39}'] ['{2FF6DAC8-2F19-4C78-B9EC-A86296847D39}']
procedure Render(const AContent: string); procedure Render(const AContent: string); overload;
overload;
procedure Render(const AObject: TObject); overload; procedure Render(const AObject: TObject); overload;
procedure Render(const AObject: TObject; const AOwns: Boolean); overload; procedure Render(const AObject: TObject; const AOwns: Boolean); overload;
procedure Render(const AObject: TObject; const AOwns: Boolean; const AType: TMVCSerializationType); overload; procedure Render(const AObject: TObject; const AOwns: Boolean; const AType: TMVCSerializationType); overload;
@ -397,15 +398,18 @@ type
procedure Render(const ACollection: IMVCList; const AType: TMVCSerializationType); overload; procedure Render(const ACollection: IMVCList; const AType: TMVCSerializationType); overload;
procedure Render(const ADataSet: TDataSet); overload; procedure Render(const ADataSet: TDataSet); overload;
procedure Render(const ADataSet: TDataSet; const AOwns: Boolean); overload; procedure Render(const ADataSet: TDataSet; const AOwns: Boolean); overload;
procedure Render(const ADataSet: TDataSet; const AOwns: Boolean; const ASerializationType: TMVCDatasetSerializationType); overload; procedure Render(const ADataSet: TDataSet; const AOwns: Boolean;
const ASerializationType: TMVCDatasetSerializationType); overload;
procedure Render(const ADataSet: TDataSet; const AOwns: Boolean; const AIgnoredFields: TMVCIgnoredList; procedure Render(const ADataSet: TDataSet; const AOwns: Boolean; const AIgnoredFields: TMVCIgnoredList;
const ASerializationType: TMVCDatasetSerializationType); overload; const ASerializationType: TMVCDatasetSerializationType); overload;
procedure Render(const ADataSet: TDataSet; const AOwns: Boolean; const AIgnoredFields: TMVCIgnoredList; const ANameCase: TMVCNameCase; procedure Render(const ADataSet: TDataSet; const AOwns: Boolean; const AIgnoredFields: TMVCIgnoredList;
const ASerializationType: TMVCDatasetSerializationType); overload; const ANameCase: TMVCNameCase; const ASerializationType: TMVCDatasetSerializationType); overload;
procedure Render(const ATextWriter: TTextWriter; const AOwns: Boolean = True); overload; procedure Render(const ATextWriter: TTextWriter; const AOwns: Boolean = True); overload;
procedure Render(const AStream: TStream; const AOwns: Boolean = True); overload; procedure Render(const AStream: TStream; const AOwns: Boolean = True); overload;
procedure Render(const AErrorCode: Integer; const AErrorMessage: string; const AErrorClassName: string = ''); overload; procedure Render(const AErrorCode: Integer; const AErrorMessage: string;
procedure Render(const AException: Exception; AExceptionItems: TList<string> = nil; const AOwns: Boolean = True); overload; const AErrorClassName: string = ''); overload;
procedure Render(const AException: Exception; AExceptionItems: TList<string> = nil;
const AOwns: Boolean = True); overload;
procedure Render(const AResponse: TMVCResponse; const AOwns: Boolean = True); overload; procedure Render(const AResponse: TMVCResponse; const AOwns: Boolean = True); overload;
// SSE Support // SSE Support
procedure RenderSSE(const EventID: string; const EventData: string; EventName: string = ''; procedure RenderSSE(const EventID: string; const EventData: string; EventName: string = '';
@ -424,11 +428,12 @@ type
IMVCAuthenticationHandler = interface IMVCAuthenticationHandler = interface
['{19B580EA-8A47-4364-A302-EEF3C6207A9F}'] ['{19B580EA-8A47-4364-A302-EEF3C6207A9F}']
procedure OnRequest(const AContext: TWebContext; const AControllerQualifiedClassName, AActionName: string; var AAuthenticationRequired: Boolean); procedure OnRequest(const AContext: TWebContext; const AControllerQualifiedClassName, AActionName: string;
procedure OnAuthentication(const AContext: TWebContext; const AUserName, APassword: string; AUserRoles: TList<string>; var AIsValid: Boolean; var AAuthenticationRequired: Boolean);
const ASessionData: TDictionary<string, string>); procedure OnAuthentication(const AContext: TWebContext; const AUserName, APassword: string;
procedure OnAuthorization(const AContext: TWebContext; AUserRoles: TList<string>; const AControllerQualifiedClassName: string; const AActionName: string; AUserRoles: TList<string>; var AIsValid: Boolean; const ASessionData: TDictionary<string, string>);
var AIsAuthorized: Boolean); procedure OnAuthorization(const AContext: TWebContext; AUserRoles: TList<string>;
const AControllerQualifiedClassName: string; const AActionName: string; var AIsAuthorized: Boolean);
end; end;
TMVCRenderer = class(TMVCBase) TMVCRenderer = class(TMVCBase)
@ -456,21 +461,24 @@ type
procedure Render(const AObject: TObject; const AOwns: Boolean; const AType: TMVCSerializationType); overload; procedure Render(const AObject: TObject; const AOwns: Boolean; const AType: TMVCSerializationType); overload;
procedure Render<T: class>(const ACollection: TObjectList<T>); overload; procedure Render<T: class>(const ACollection: TObjectList<T>); overload;
procedure Render<T: class>(const ACollection: TObjectList<T>; const AOwns: Boolean); overload; procedure Render<T: class>(const ACollection: TObjectList<T>; const AOwns: Boolean); overload;
procedure Render<T: class>(const ACollection: TObjectList<T>; const AOwns: Boolean; const AType: TMVCSerializationType); overload; procedure Render<T: class>(const ACollection: TObjectList<T>; const AOwns: Boolean;
const AType: TMVCSerializationType); overload;
procedure Render(const ACollection: IMVCList); overload; procedure Render(const ACollection: IMVCList); overload;
procedure Render(const ACollection: IMVCList; const AType: TMVCSerializationType); overload; procedure Render(const ACollection: IMVCList; const AType: TMVCSerializationType); overload;
procedure Render(const ADataSet: TDataSet); overload; procedure Render(const ADataSet: TDataSet); overload;
procedure Render(const ADataSet: TDataSet; const AOwns: Boolean); overload; procedure Render(const ADataSet: TDataSet; const AOwns: Boolean); overload;
procedure Render(const ADataSet: TDataSet; const AOwns: Boolean; const ASerializationType: TMVCDatasetSerializationType); overload; procedure Render(const ADataSet: TDataSet; const AOwns: Boolean;
const ASerializationType: TMVCDatasetSerializationType); overload;
procedure Render(const ADataSet: TDataSet; const AOwns: Boolean; const AIgnoredFields: TMVCIgnoredList; procedure Render(const ADataSet: TDataSet; const AOwns: Boolean; const AIgnoredFields: TMVCIgnoredList;
const ASerializationType: TMVCDatasetSerializationType); overload; const ASerializationType: TMVCDatasetSerializationType); overload;
procedure Render(const ADataSet: TDataSet; const AOwns: Boolean; const AIgnoredFields: TMVCIgnoredList; const ANameCase: TMVCNameCase; procedure Render(const ADataSet: TDataSet; const AOwns: Boolean; const AIgnoredFields: TMVCIgnoredList;
const ASerializationType: TMVCDatasetSerializationType); overload; const ANameCase: TMVCNameCase; const ASerializationType: TMVCDatasetSerializationType); overload;
procedure Render(const ATextWriter: TTextWriter; const AOwns: Boolean = True); overload; procedure Render(const ATextWriter: TTextWriter; const AOwns: Boolean = True); overload;
procedure Render(const AStream: TStream; const AOwns: Boolean = True); overload; procedure Render(const AStream: TStream; const AOwns: Boolean = True); overload;
procedure Render(const AErrorCode: Integer; const AErrorMessage: string; const AErrorClassName: string = ''; procedure Render(const AErrorCode: Integer; const AErrorMessage: string; const AErrorClassName: string = '';
const ADataObject: TObject = nil); overload; const ADataObject: TObject = nil); overload;
procedure Render(const AException: Exception; AExceptionItems: TList<string> = nil; const AOwns: Boolean = True); overload; procedure Render(const AException: Exception; AExceptionItems: TList<string> = nil;
const AOwns: Boolean = True); overload;
procedure Render(const AResponse: TMVCResponse; const AOwns: Boolean = True); overload; procedure Render(const AResponse: TMVCResponse; const AOwns: Boolean = True); overload;
// SSE Support // SSE Support
procedure RenderSSE(const EventID: string; const EventData: string; EventName: string = ''; procedure RenderSSE(const EventID: string; const EventData: string; EventName: string = '';
@ -551,7 +559,8 @@ type
protected protected
{ protected declarations } { protected declarations }
public public
constructor Create(const AClazz: TMVCControllerClazz; const ACreateAction: TMVCControllerCreateAction; const AURLSegment: string = ''); constructor Create(const AClazz: TMVCControllerClazz; const ACreateAction: TMVCControllerCreateAction;
const AURLSegment: string = '');
property Clazz: TMVCControllerClazz read FClazz; property Clazz: TMVCControllerClazz read FClazz;
property CreateAction: TMVCControllerCreateAction read FCreateAction; property CreateAction: TMVCControllerCreateAction read FCreateAction;
property URLSegment: string read FURLSegment; property URLSegment: string read FURLSegment;
@ -586,8 +595,8 @@ type
/// <param name="AControllerQualifiedClassName">Qualified classname of the matching controller.</param> /// <param name="AControllerQualifiedClassName">Qualified classname of the matching controller.</param>
/// <param name="AActionName">Method name of the matching controller method.</param> /// <param name="AActionName">Method name of the matching controller method.</param>
/// <param name="AHandled">If set to True the Request would finished. Response must be set by the implementor. Default value is False.</param> /// <param name="AHandled">If set to True the Request would finished. Response must be set by the implementor. Default value is False.</param>
procedure OnBeforeControllerAction(AContext: TWebContext; const AControllerQualifiedClassName: string; const AActionName: string; procedure OnBeforeControllerAction(AContext: TWebContext; const AControllerQualifiedClassName: string;
var AHandled: Boolean); const AActionName: string; var AHandled: Boolean);
/// <summary> /// <summary>
/// Procedure is called after the specific controller method was called. /// Procedure is called after the specific controller method was called.
/// It is still possible to cancel or to completly modifiy the request. /// It is still possible to cancel or to completly modifiy the request.
@ -600,7 +609,8 @@ type
TMVCEngine = class(TComponent) TMVCEngine = class(TComponent)
private const private const
ALLOWED_TYPED_ACTION_PARAMETERS_TYPES = 'Integer, Int64, Single, Double, Extended, Boolean, TDate, TTime, TDateTime and String'; ALLOWED_TYPED_ACTION_PARAMETERS_TYPES =
'Integer, Int64, Single, Double, Extended, Boolean, TDate, TTime, TDateTime and String';
private private
FViewEngineClass: TMVCViewEngineClass; FViewEngineClass: TMVCViewEngineClass;
FWebModule: TWebModule; FWebModule: TWebModule;
@ -624,14 +634,18 @@ type
procedure LoadSystemControllers; virtual; procedure LoadSystemControllers; virtual;
procedure FixUpWebModule; procedure FixUpWebModule;
procedure ExecuteBeforeRoutingMiddleware(const AContext: TWebContext; var AHandled: Boolean); procedure ExecuteBeforeRoutingMiddleware(const AContext: TWebContext; var AHandled: Boolean);
procedure ExecuteBeforeControllerActionMiddleware(const AContext: TWebContext; const AControllerQualifiedClassName: string; procedure ExecuteBeforeControllerActionMiddleware(const AContext: TWebContext;
const AActionName: string; var AHandled: Boolean); const AControllerQualifiedClassName: string; const AActionName: string; var AHandled: Boolean);
procedure ExecuteAfterControllerActionMiddleware(const AContext: TWebContext; const AActionName: string; const AHandled: Boolean); procedure ExecuteAfterControllerActionMiddleware(const AContext: TWebContext; const AActionName: string;
const AHandled: Boolean);
procedure DefineDefaultResponseHeaders(const AContext: TWebContext); procedure DefineDefaultResponseHeaders(const AContext: TWebContext);
procedure OnBeforeDispatch(ASender: TObject; ARequest: TWebRequest; AResponse: TWebResponse; var AHandled: Boolean); virtual; procedure OnBeforeDispatch(ASender: TObject; ARequest: TWebRequest; AResponse: TWebResponse;
procedure ResponseErrorPage(const AException: Exception; const ARequest: TWebRequest; const AResponse: TWebResponse); virtual; var AHandled: Boolean); virtual;
function ExecuteAction(const ASender: TObject; const ARequest: TWebRequest; const AResponse: TWebResponse): Boolean; virtual; procedure ResponseErrorPage(const AException: Exception; const ARequest: TWebRequest;
const AResponse: TWebResponse); virtual;
function ExecuteAction(const ASender: TObject; const ARequest: TWebRequest; const AResponse: TWebResponse)
: Boolean; virtual;
public public
class function GetCurrentSession(const ASessionTimeout: Integer; const ASessionId: string; class function GetCurrentSession(const ASessionTimeout: Integer; const ASessionId: string;
const ARaiseExceptionIfExpired: Boolean = True): TWebSession; static; const ARaiseExceptionIfExpired: Boolean = True): TWebSession; static;
@ -640,23 +654,27 @@ type
class function SendSessionCookie(const AContext: TWebContext; const ASessionId: string): string; overload; static; class function SendSessionCookie(const AContext: TWebContext; const ASessionId: string): string; overload; static;
class procedure ClearSessionCookiesAlreadySet(const ACookies: TCookieCollection); static; class procedure ClearSessionCookiesAlreadySet(const ACookies: TCookieCollection); static;
public public
constructor Create(const AWebModule: TWebModule; const AConfigAction: TProc<TMVCConfig> = nil; const ACustomLogger: ILogWriter = nil); constructor Create(const AWebModule: TWebModule; const AConfigAction: TProc<TMVCConfig> = nil;
reintroduce; const ACustomLogger: ILogWriter = nil); reintroduce;
destructor Destroy; override; destructor Destroy; override;
function GetSessionBySessionId(const ASessionId: string): TWebSession; function GetSessionBySessionId(const ASessionId: string): TWebSession;
function AddSerializer(const AContentType: string; const ASerializer: IMVCSerializer): TMVCEngine; function AddSerializer(const AContentType: string; const ASerializer: IMVCSerializer): TMVCEngine;
function AddMiddleware(const AMiddleware: IMVCMiddleware): TMVCEngine; function AddMiddleware(const AMiddleware: IMVCMiddleware): TMVCEngine;
function AddController(const AControllerClazz: TMVCControllerClazz; const AURLSegment: string = ''): TMVCEngine; overload; function AddController(const AControllerClazz: TMVCControllerClazz; const AURLSegment: string = '')
: TMVCEngine; overload;
function AddController(const AControllerClazz: TMVCControllerClazz; const ACreateAction: TMVCControllerCreateAction; function AddController(const AControllerClazz: TMVCControllerClazz; const ACreateAction: TMVCControllerCreateAction;
const AURLSegment: string = ''): TMVCEngine; overload; const AURLSegment: string = ''): TMVCEngine; overload;
function PublishObject(const AObjectCreatorDelegate: TMVCObjectCreatorDelegate; const AURLSegment: string): TMVCEngine; function PublishObject(const AObjectCreatorDelegate: TMVCObjectCreatorDelegate; const AURLSegment: string)
: TMVCEngine;
function SetViewEngine(const AViewEngineClass: TMVCViewEngineClass): TMVCEngine; function SetViewEngine(const AViewEngineClass: TMVCViewEngineClass): TMVCEngine;
function GetServerSignature(const AContext: TWebContext): string; function GetServerSignature(const AContext: TWebContext): string;
procedure HTTP404(const AContext: TWebContext); procedure HTTP404(const AContext: TWebContext);
procedure HTTP500(const AContext: TWebContext; const AReasonString: string = ''); procedure HTTP500(const AContext: TWebContext; const AReasonString: string = '');
procedure SendRawHTTPStatus(const AContext: TWebContext; const HTTPStatusCode: Integer;
const AReasonString: string);
property ViewEngineClass: TMVCViewEngineClass read GetViewEngineClass; property ViewEngineClass: TMVCViewEngineClass read GetViewEngineClass;
property WebModule: TWebModule read FWebModule; property WebModule: TWebModule read FWebModule;
@ -989,7 +1007,8 @@ begin
Result := FWebRequest.CookieFields.Values[AName]; Result := FWebRequest.CookieFields.Values[AName];
end; end;
constructor TMVCWebRequest.Create(const AWebRequest: TWebRequest; const ASerializers: TDictionary<string, IMVCSerializer>); constructor TMVCWebRequest.Create(const AWebRequest: TWebRequest;
const ASerializers: TDictionary<string, IMVCSerializer>);
begin begin
inherited Create; inherited Create;
FBody := EmptyStr; FBody := EmptyStr;
@ -1313,8 +1332,8 @@ begin
LRoles := string.Join('$$', FRoles.ToArray) LRoles := string.Join('$$', FRoles.ToArray)
else else
LRoles := ''; LRoles := '';
AWebSession[TMVCConstants.CURRENT_USER_SESSION_KEY] := FUserName + '$$' + DateTimeToISOTimeStamp(FLoggedSince) + '$$' + FRealm + AWebSession[TMVCConstants.CURRENT_USER_SESSION_KEY] := FUserName + '$$' + DateTimeToISOTimeStamp(FLoggedSince) + '$$'
'$$' + LRoles; + FRealm + '$$' + LRoles;
end; end;
procedure TUser.SetCustomData(const Value: TMVCCustomData); procedure TUser.SetCustomData(const Value: TMVCCustomData);
@ -1332,7 +1351,8 @@ end;
{ TWebContext } { TWebContext }
function TWebContext.AddSessionToTheSessionList(const ASessionType, ASessionId: string; const ASessionTimeout: Integer): TWebSession; function TWebContext.AddSessionToTheSessionList(const ASessionType, ASessionId: string; const ASessionTimeout: Integer)
: TWebSession;
var var
Session: TWebSession; Session: TWebSession;
begin begin
@ -1473,7 +1493,8 @@ begin
if not Assigned(FWebSession) then if not Assigned(FWebSession) then
begin begin
Id := TMVCEngine.SendSessionCookie(Self); Id := TMVCEngine.SendSessionCookie(Self);
FWebSession := AddSessionToTheSessionList(Config[TMVCConfigKey.SessionType], Id, StrToInt64(Config[TMVCConfigKey.SessionTimeout])); FWebSession := AddSessionToTheSessionList(Config[TMVCConfigKey.SessionType], Id,
StrToInt64(Config[TMVCConfigKey.SessionTimeout]));
FIsSessionStarted := True; FIsSessionStarted := True;
FSessionMustBeClose := False; FSessionMustBeClose := False;
end; end;
@ -1532,8 +1553,8 @@ begin
Result := AddController(AControllerClazz, nil, AURLSegment); Result := AddController(AControllerClazz, nil, AURLSegment);
end; end;
function TMVCEngine.AddController(const AControllerClazz: TMVCControllerClazz; const ACreateAction: TMVCControllerCreateAction; function TMVCEngine.AddController(const AControllerClazz: TMVCControllerClazz;
const AURLSegment: string): TMVCEngine; const ACreateAction: TMVCControllerCreateAction; const AURLSegment: string): TMVCEngine;
begin begin
FControllers.Add(TMVCControllerDelegate.Create(AControllerClazz, ACreateAction, AURLSegment)); FControllers.Add(TMVCControllerDelegate.Create(AControllerClazz, ACreateAction, AURLSegment));
Result := Self; Result := Self;
@ -1604,7 +1625,8 @@ begin
Log.Info('EXIT: Config default values', LOGGERPRO_TAG); Log.Info('EXIT: Config default values', LOGGERPRO_TAG);
end; end;
constructor TMVCEngine.Create(const AWebModule: TWebModule; const AConfigAction: TProc<TMVCConfig>; const ACustomLogger: ILogWriter); constructor TMVCEngine.Create(const AWebModule: TWebModule; const AConfigAction: TProc<TMVCConfig>;
const ACustomLogger: ILogWriter);
begin begin
inherited Create(AWebModule); inherited Create(AWebModule);
FWebModule := AWebModule; FWebModule := AWebModule;
@ -1651,7 +1673,8 @@ begin
inherited Destroy; inherited Destroy;
end; end;
function TMVCEngine.ExecuteAction(const ASender: TObject; const ARequest: TWebRequest; const AResponse: TWebResponse): Boolean; function TMVCEngine.ExecuteAction(const ASender: TObject; const ARequest: TWebRequest;
const AResponse: TWebResponse): Boolean;
var var
LParamsTable: TMVCRequestParamsTable; LParamsTable: TMVCRequestParamsTable;
LContext: TWebContext; LContext: TWebContext;
@ -1667,9 +1690,10 @@ begin
Result := False; Result := False;
ARequest.ReadTotalContent; ARequest.ReadTotalContent;
if ARequest.ContentLength > fConfigCache_MaxRequestSize then if ARequest.ContentLength > FConfigCache_MaxRequestSize then
begin begin
raise EMVCException.CreateFmt('Request size exceeded the max allowed size [%d KiB]', [(FConfigCache_MaxRequestSize div 1024)]); raise EMVCException.CreateFmt('Request size exceeded the max allowed size [%d KiB]',
[(FConfigCache_MaxRequestSize div 1024)]);
end; end;
LParamsTable := TMVCRequestParamsTable.Create; LParamsTable := TMVCRequestParamsTable.Create;
@ -1677,140 +1701,197 @@ begin
LContext := TWebContext.Create(ARequest, AResponse, FConfig, FSerializers); LContext := TWebContext.Create(ARequest, AResponse, FConfig, FSerializers);
try try
DefineDefaultResponseHeaders(LContext); DefineDefaultResponseHeaders(LContext);
if IsStaticFileRequest(ARequest, LFileName) then LHandled := False;
Result := SendStaticFileIfPresent(LContext, LFileName) LRouter := TMVCRouter.Create(FConfig, _MVCGlobalActionParamsCache);
else try // finally
begin LSelectedController := nil;
LHandled := False; try // only for lselectedcontroller
LRouter := TMVCRouter.Create(FConfig, _MVCGlobalActionParamsCache); try // global exception handler
try ExecuteBeforeRoutingMiddleware(LContext, LHandled);
ExecuteBeforeRoutingMiddleware(LContext, LHandled); if not LHandled then
if not LHandled then
begin
if LRouter.ExecuteRouting(ARequest.PathInfo, TMVCRouter.StringMethodToHTTPMetod(ARequest.Method), ARequest.ContentType,
ARequest.Accept, FControllers, FConfig[TMVCConfigKey.DefaultContentType], FConfig[TMVCConfigKey.DefaultContentCharset],
LParamsTable, LResponseContentMediaType, LResponseContentCharset) then
begin begin
try if LRouter.ExecuteRouting(ARequest.PathInfo, TMVCRouter.StringMethodToHTTPMetod(ARequest.Method),
if Assigned(LRouter.ControllerCreateAction) then ARequest.ContentType, ARequest.Accept, FControllers, FConfig[TMVCConfigKey.DefaultContentType],
LSelectedController := LRouter.ControllerCreateAction() FConfig[TMVCConfigKey.DefaultContentCharset], LParamsTable, LResponseContentMediaType,
else LResponseContentCharset) then
LSelectedController := LRouter.ControllerClazz.Create; begin
except try
on Ex: Exception do if Assigned(LRouter.ControllerCreateAction) then
begin LSelectedController := LRouter.ControllerCreateAction()
Log.ErrorFmt('[%s] %s (Custom message: "%s")', [Ex.Classname, Ex.Message, 'Cannot create controller'], else
LOGGERPRO_TAG); LSelectedController := LRouter.ControllerClazz.Create;
HTTP500(LContext, 'Cannot create controller'); except
Result := False; on Ex: Exception do
Exit; begin
Log.ErrorFmt('[%s] %s (Custom message: "%s")',
[Ex.Classname, Ex.Message, 'Cannot create controller'], LOGGERPRO_TAG);
raise EMVCException.Create(HTTP_STATUS.InternalServerError, 'Cannot create controller');
// HTTP500(LContext, 'Cannot create controller');
// Result := False;
// Exit;
end;
end; end;
end;
try
LSelectedController.Engine := Self; LSelectedController.Engine := Self;
LSelectedController.Context := LContext; LSelectedController.Context := LContext;
LSelectedController.ApplicationSession := FApplicationSession; LSelectedController.ApplicationSession := FApplicationSession;
LContext.ParamsTable := LParamsTable; LContext.ParamsTable := LParamsTable;
ExecuteBeforeControllerActionMiddleware(LContext, LRouter.ControllerClazz.QualifiedClassName,
LRouter.MethodToCall.Name, LHandled);
if LHandled then
Exit(True);
LSelectedController.MVCControllerAfterCreate;
try try
ExecuteBeforeControllerActionMiddleware(LContext, LRouter.ControllerClazz.QualifiedClassName, LRouter.MethodToCall.Name, LHandled := False;
LHandled); LSelectedController.ContentType := BuildContentType(LResponseContentMediaType,
if LHandled then LResponseContentCharset);
Exit(True); // LSelectedController.ContentCharset := LResponseContentCharset;
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);
LSelectedController.MVCControllerAfterCreate; LSelectedController.OnBeforeAction(LContext, LRouter.MethodToCall.Name, LHandled);
try
LHandled := False;
LSelectedController.ContentType := BuildContentType(LResponseContentMediaType, LResponseContentCharset);
// LSelectedController.ContentCharset := LResponseContentCharset;
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);
LSelectedController.OnBeforeAction(LContext, LRouter.MethodToCall.Name, LHandled); if not LHandled then
begin
if not LHandled then try
begin LRouter.MethodToCall.Invoke(LSelectedController, LActualParams);
try finally
LRouter.MethodToCall.Invoke(LSelectedController, LActualParams); LSelectedController.OnAfterAction(LContext, LRouter.MethodToCall.Name);
finally
LSelectedController.OnAfterAction(LContext, LRouter.MethodToCall.Name);
end;
end; end;
finally
LSelectedController.MVCControllerBeforeDestroy;
end;
ExecuteAfterControllerActionMiddleware(LContext, LRouter.MethodToCall.Name, LHandled);
except
on E: EMVCSessionExpiredException do
begin
Log.ErrorFmt('[%s] %s (Custom message: "%s")', [E.Classname, E.Message, E.DetailedMessage], LOGGERPRO_TAG);
LContext.SessionStop(False);
LSelectedController.ResponseStatus(E.HTTPErrorCode);
LSelectedController.Render(E);
end;
on E: EMVCException do
begin
Log.ErrorFmt('[%s] %s (Custom message: "%s")', [E.Classname, E.Message, E.DetailedMessage], LOGGERPRO_TAG);
LSelectedController.ResponseStatus(E.HTTPErrorCode);
LSelectedController.Render(E);
end;
on E: EInvalidOp do
begin
Log.ErrorFmt('[%s] %s (Custom message: "%s")', [E.Classname, E.Message, 'Invalid Op'], LOGGERPRO_TAG);
LSelectedController.ResponseStatus(HTTP_STATUS.InternalServerError);
LSelectedController.Render(E);
end;
on Ex: Exception do
begin
Log.ErrorFmt('[%s] %s (Custom message: "%s")', [Ex.Classname, Ex.Message, 'Global Action Exception Handler'],
LOGGERPRO_TAG);
LSelectedController.ResponseStatus(HTTP_STATUS.InternalServerError);
LSelectedController.Render(Ex);
end; end;
finally
LSelectedController.MVCControllerBeforeDestroy;
end; end;
ExecuteAfterControllerActionMiddleware(LContext, LRouter.MethodToCall.Name, LHandled);
// except
// on E: EMVCSessionExpiredException do
// begin
// Log.ErrorFmt('[%s] %s (Custom message: "%s")', [E.Classname, E.Message, E.DetailedMessage], LOGGERPRO_TAG);
// LContext.SessionStop(False);
// LSelectedController.ResponseStatus(E.HTTPErrorCode);
// LSelectedController.Render(E);
// end;
// on E: EMVCException do
// begin
// Log.ErrorFmt('[%s] %s (Custom message: "%s")', [E.Classname, E.Message, E.DetailedMessage], LOGGERPRO_TAG);
// LSelectedController.ResponseStatus(E.HTTPErrorCode);
// LSelectedController.Render(E);
// end;
// on E: EInvalidOp do
// begin
// Log.ErrorFmt('[%s] %s (Custom message: "%s")', [E.Classname, E.Message, 'Invalid Op'], LOGGERPRO_TAG);
// LSelectedController.ResponseStatus(HTTP_STATUS.InternalServerError);
// LSelectedController.Render(E);
// end;
// on Ex: Exception do
// begin
// Log.ErrorFmt('[%s] %s (Custom message: "%s")', [Ex.Classname, Ex.Message, 'Global Action Exception Handler'],
// LOGGERPRO_TAG);
// LSelectedController.ResponseStatus(HTTP_STATUS.InternalServerError);
// LSelectedController.Render(Ex);
// end;
// end;
LContext.Response.ContentType := LSelectedController.ContentType; LContext.Response.ContentType := LSelectedController.ContentType;
Log(TLogLevel.levNormal, ARequest.Method + ':' + ARequest.RawPathInfo + ' -> ' + LRouter.ControllerClazz.QualifiedClassName Log(TLogLevel.levNormal, ARequest.Method + ':' + ARequest.RawPathInfo + ' -> ' +
+ ' - ' + IntToStr(AResponse.StatusCode) + ' ' + AResponse.ReasonString) LRouter.ControllerClazz.QualifiedClassName + ' - ' + IntToStr(AResponse.StatusCode) + ' ' +
finally AResponse.ReasonString)
LSelectedController.Free;
end; end
end else // execute-routing
else
begin
if Config[TMVCConfigKey.AllowUnhandledAction] = 'false' then
begin begin
if not Config[TMVCConfigKey.FallbackResource].IsEmpty then if Config[TMVCConfigKey.AllowUnhandledAction] = 'false' then
begin begin
if (LContext.Request.PathInfo = '/') or (LContext.Request.PathInfo = '') then // useful for SPA if not Config[TMVCConfigKey.FallbackResource].IsEmpty then
Result := SendStaticFileIfPresent(LContext, TPath.Combine(Config[TMVCConfigKey.DocumentRoot], begin
Config[TMVCConfigKey.FallbackResource])); if (LContext.Request.PathInfo = '/') or (LContext.Request.PathInfo = '') then // useful for SPA
end; Result := SendStaticFileIfPresent(LContext, TPath.Combine(Config[TMVCConfigKey.DocumentRoot],
if not Result then Config[TMVCConfigKey.FallbackResource]));
begin end;
HTTP404(LContext); if (not Result) and (IsStaticFileRequest(ARequest, LFileName)) then
Log(TLogLevel.levNormal, ARequest.Method + ':' + ARequest.RawPathInfo + ' -> NO ACTION ' + ' - ' + begin
IntToStr(AResponse.StatusCode) + ' ' + AResponse.ReasonString); Result := SendStaticFileIfPresent(LContext, LFileName);
end; end;
if not Result then
begin
// HTTP404(LContext);
Log(TLogLevel.levNormal, ARequest.Method + ':' + ARequest.RawPathInfo + ' -> NO ACTION ' + ' - ' +
IntToStr(AResponse.StatusCode) + ' ' + AResponse.ReasonString);
raise EMVCException.Create(HTTP_STATUS.NotFound, 'Not Found');
end;
end
else
LContext.Response.FlushOnDestroy := False;
end; // end-execute-routing
end; // if not handled by beforerouting
except
on E: EMVCSessionExpiredException do
begin
Log.ErrorFmt('[%s] %s (Custom message: "%s")', [E.Classname, E.Message, E.DetailedMessage],
LOGGERPRO_TAG);
LContext.SessionStop(False);
LSelectedController.ResponseStatus(E.HTTPErrorCode);
LSelectedController.Render(E);
end;
on E: EMVCException do
begin
Log.ErrorFmt('[%s] %s (Custom message: "%s")', [E.Classname, E.Message, E.DetailedMessage],
LOGGERPRO_TAG);
if Assigned(LSelectedController) then
begin
LSelectedController.ResponseStatus(E.HTTPErrorCode);
LSelectedController.Render(E);
end end
else else
LContext.Response.FlushOnDestroy := False; begin
SendRawHTTPStatus(LContext, E.HTTPErrorCode, Format('[%s] %s', [E.Classname, E.Message]));
end;
end;
on E: EInvalidOp do
begin
Log.ErrorFmt('[%s] %s (Custom message: "%s")', [E.Classname, E.Message, 'Invalid Op'], LOGGERPRO_TAG);
if Assigned(LSelectedController) then
begin
LSelectedController.ResponseStatus(HTTP_STATUS.InternalServerError);
LSelectedController.Render(E);
end
else
begin
SendRawHTTPStatus(LContext, HTTP_STATUS.InternalServerError,
Format('[%s] %s', [E.Classname, E.Message]));
end;
end;
on E: Exception do
begin
Log.ErrorFmt('[%s] %s (Custom message: "%s")',
[E.Classname, E.Message, 'Global Action Exception Handler'], LOGGERPRO_TAG);
if Assigned(LSelectedController) then
begin
LSelectedController.ResponseStatus(HTTP_STATUS.InternalServerError);
LSelectedController.Render(E);
end
else
begin
SendRawHTTPStatus(LContext, HTTP_STATUS.InternalServerError,
Format('[%s] %s', [E.Classname, E.Message]));
end;
end; end;
end; end;
finally finally
LRouter.Free; FreeAndNil(LSelectedController);
end; end;
finally
LRouter.Free;
end; end;
finally finally
LContext.Free; LContext.Free;
@ -1829,8 +1910,8 @@ begin
FMiddlewares[I].OnAfterControllerAction(AContext, AActionName, AHandled); FMiddlewares[I].OnAfterControllerAction(AContext, AActionName, AHandled);
end; end;
procedure TMVCEngine.ExecuteBeforeControllerActionMiddleware(const AContext: TWebContext; const AControllerQualifiedClassName: string; procedure TMVCEngine.ExecuteBeforeControllerActionMiddleware(const AContext: TWebContext;
const AActionName: string; var AHandled: Boolean); const AControllerQualifiedClassName: string; const AActionName: string; var AHandled: Boolean);
var var
Middleware: IMVCMiddleware; Middleware: IMVCMiddleware;
begin begin
@ -1863,8 +1944,8 @@ begin
Result := TIdURI.URLDecode(Result); Result := TIdURI.URLDecode(Result);
end; end;
procedure TMVCEngine.FillActualParamsForAction(const AContext: TWebContext; const AActionFormalParams: TArray<TRttiParameter>; procedure TMVCEngine.FillActualParamsForAction(const AContext: TWebContext;
const AActionName: string; var AActualParams: TArray<TValue>); const AActionFormalParams: TArray<TRttiParameter>; const AActionName: string; var AActualParams: TArray<TValue>);
var var
ParamName: string; ParamName: string;
I: Integer; I: Integer;
@ -1883,7 +1964,8 @@ begin
ParamName := AActionFormalParams[I].Name; ParamName := AActionFormalParams[I].Name;
if not AContext.Request.SegmentParam(ParamName, StrValue) then if not AContext.Request.SegmentParam(ParamName, StrValue) then
raise EMVCException.CreateFmt('Invalid parameter %s for action %s (Hint: Here parameters names are case-sensitive)', raise EMVCException.CreateFmt
('Invalid parameter %s for action %s (Hint: Here parameters names are case-sensitive)',
[ParamName, AActionName]); [ParamName, AActionName]);
case AActionFormalParams[I].ParamType.TypeKind of case AActionFormalParams[I].ParamType.TypeKind of
@ -1920,7 +2002,8 @@ begin
except except
on E: Exception do on E: Exception do
begin begin
raise EMVCException.CreateFmt('Invalid TDateTime value for param [%s][%s]', [AActionFormalParams[I].Name, E.Message]); raise EMVCException.CreateFmt('Invalid TDateTime value for param [%s][%s]',
[AActionFormalParams[I].Name, E.Message]);
end; end;
end; end;
end end
@ -1949,16 +2032,17 @@ begin
AActualParams[I] := False AActualParams[I] := False
else else
raise EMVCException.CreateFmt raise EMVCException.CreateFmt
('Invalid boolean value for parameter %s. Boolean parameters accepts only "true"/"false" or "1"/"0".', [ParamName]); ('Invalid boolean value for parameter %s. Boolean parameters accepts only "true"/"false" or "1"/"0".',
[ParamName]);
end end
else else
raise EMVCException.CreateFmt('Invalid type for parameter %s. Allowed types are ' + ALLOWED_TYPED_ACTION_PARAMETERS_TYPES, raise EMVCException.CreateFmt('Invalid type for parameter %s. Allowed types are ' +
[ParamName]); ALLOWED_TYPED_ACTION_PARAMETERS_TYPES, [ParamName]);
end; end;
else else
begin begin
raise EMVCException.CreateFmt('Invalid type for parameter %s. Allowed types are ' + ALLOWED_TYPED_ACTION_PARAMETERS_TYPES, raise EMVCException.CreateFmt('Invalid type for parameter %s. Allowed types are ' +
[ParamName]); ALLOWED_TYPED_ACTION_PARAMETERS_TYPES, [ParamName]);
end; end;
end; end;
end; end;
@ -2029,14 +2113,16 @@ end;
function TMVCEngine.GetViewEngineClass: TMVCViewEngineClass; function TMVCEngine.GetViewEngineClass: TMVCViewEngineClass;
begin begin
if FViewEngineClass = nil then if FViewEngineClass = nil then
raise EMVCConfigException.Create('No View Engine configured. [HINT: Use TMVCEngine.SetViewEngine() to set a valid view engine]'); raise EMVCConfigException.Create
('No View Engine configured. [HINT: Use TMVCEngine.SetViewEngine() to set a valid view engine]');
Result := FViewEngineClass; Result := FViewEngineClass;
end; end;
procedure TMVCEngine.HTTP404(const AContext: TWebContext); procedure TMVCEngine.HTTP404(const AContext: TWebContext);
begin begin
AContext.Response.SetStatusCode(HTTP_STATUS.NotFound); AContext.Response.SetStatusCode(HTTP_STATUS.NotFound);
AContext.Response.SetContentType(BuildContentType(TMVCMediaType.TEXT_PLAIN, AContext.Config[TMVCConfigKey.DefaultContentCharset])); AContext.Response.SetContentType(BuildContentType(TMVCMediaType.TEXT_PLAIN,
AContext.Config[TMVCConfigKey.DefaultContentCharset]));
AContext.Response.SetReasonString('Not Found'); AContext.Response.SetReasonString('Not Found');
AContext.Response.SetContent('Not Found' + sLineBreak + GetServerSignature(AContext)); AContext.Response.SetContent('Not Found' + sLineBreak + GetServerSignature(AContext));
end; end;
@ -2044,9 +2130,42 @@ end;
procedure TMVCEngine.HTTP500(const AContext: TWebContext; const AReasonString: string); procedure TMVCEngine.HTTP500(const AContext: TWebContext; const AReasonString: string);
begin begin
AContext.Response.SetStatusCode(HTTP_STATUS.InternalServerError); AContext.Response.SetStatusCode(HTTP_STATUS.InternalServerError);
AContext.Response.SetContentType(BuildContentType(TMVCMediaType.TEXT_PLAIN, AContext.Config[TMVCConfigKey.DefaultContentCharset])); AContext.Response.SetContentType(BuildContentType(TMVCMediaType.TEXT_PLAIN,
AContext.Config[TMVCConfigKey.DefaultContentCharset]));
AContext.Response.SetReasonString('Internal server error'); AContext.Response.SetReasonString('Internal server error');
AContext.Response.SetContent('Internal server error' + sLineBreak + GetServerSignature(AContext) + ': ' + AReasonString); AContext.Response.SetContent('Internal server error' + sLineBreak + GetServerSignature(AContext) + ': ' +
AReasonString);
end;
procedure TMVCEngine.SendRawHTTPStatus(const AContext: TWebContext; const HTTPStatusCode: Integer;
const AReasonString: string);
var
lSer: IMVCSerializer;
lError: TMVCErrorResponse;
begin
AContext.Response.SetStatusCode(HTTPStatusCode);
AContext.Response.SetReasonString(AReasonString);
if Serializers.TryGetValue(AContext.Config[TMVCConfigKey.DefaultContentType], lSer) then
begin
lError := TMVCErrorResponse.Create;
try
lError.Classname := '';
lError.StatusCode := HTTPStatusCode;
lError.Message := AReasonString;
AContext.Response.SetContent(lSer.SerializeObject(lError));
finally
lError.Free;
end;
AContext.Response.SetContentType(AContext.Config[TMVCConfigKey.DefaultContentType]);
end
else
begin
AContext.Response.SetContentType(BuildContentType(TMVCMediaType.TEXT_PLAIN,
AContext.Config[TMVCConfigKey.DefaultContentCharset]));
AContext.Response.SetContent(GetServerSignature(AContext) + sLineBreak + 'HTTP ' + HTTPStatusCode.ToString + ': ' +
AReasonString);
end;
end; end;
function TMVCEngine.IsStaticFileRequest(const ARequest: TWebRequest; out AFileName: string): Boolean; function TMVCEngine.IsStaticFileRequest(const ARequest: TWebRequest; out AFileName: string): Boolean;
@ -2062,7 +2181,8 @@ begin
Log(TLogLevel.levNormal, 'EXIT: LoadSystemControllers'); Log(TLogLevel.levNormal, 'EXIT: LoadSystemControllers');
end; end;
procedure TMVCEngine.OnBeforeDispatch(ASender: TObject; ARequest: TWebRequest; AResponse: TWebResponse; var AHandled: Boolean); procedure TMVCEngine.OnBeforeDispatch(ASender: TObject; ARequest: TWebRequest; AResponse: TWebResponse;
var AHandled: Boolean);
begin begin
AHandled := False; AHandled := False;
{ there is a bug in WebBroker Linux on 10.2.1 tokyo } { there is a bug in WebBroker Linux on 10.2.1 tokyo }
@ -2087,9 +2207,8 @@ begin
end; end;
end; end;
function TMVCEngine.PublishObject( function TMVCEngine.PublishObject(const AObjectCreatorDelegate: TMVCObjectCreatorDelegate; const AURLSegment: string)
const AObjectCreatorDelegate: TMVCObjectCreatorDelegate; : TMVCEngine;
const AURLSegment: string): TMVCEngine;
begin begin
Result := AddController(TMVCJSONRPCPublisher, Result := AddController(TMVCJSONRPCPublisher,
function: TMVCController function: TMVCController
@ -2116,15 +2235,16 @@ begin
end; end;
end; end;
procedure TMVCEngine.ResponseErrorPage(const AException: Exception; const ARequest: TWebRequest; const AResponse: TWebResponse); procedure TMVCEngine.ResponseErrorPage(const AException: Exception; const ARequest: TWebRequest;
const AResponse: TWebResponse);
begin begin
AResponse.SetCustomHeader('x-mvc-error', AException.Classname + ': ' + AException.Message); AResponse.SetCustomHeader('x-mvc-error', AException.Classname + ': ' + AException.Message);
AResponse.StatusCode := HTTP_STATUS.OK; AResponse.StatusCode := HTTP_STATUS.OK;
begin begin
AResponse.ContentType := TMVCMediaType.TEXT_PLAIN; AResponse.ContentType := TMVCMediaType.TEXT_PLAIN;
AResponse.Content := Config[TMVCConfigKey.ServerName] + ' ERROR:' + sLineBreak + 'Exception raised of class: ' + AException.Classname + AResponse.Content := Config[TMVCConfigKey.ServerName] + ' ERROR:' + sLineBreak + 'Exception raised of class: ' +
sLineBreak + '***********************************************' + sLineBreak + AException.Message + sLineBreak + AException.Classname + sLineBreak + '***********************************************' + sLineBreak +
'***********************************************'; AException.Message + sLineBreak + '***********************************************';
end; end;
end; end;
@ -2132,13 +2252,15 @@ class function TMVCEngine.SendSessionCookie(const AContext: TWebContext): string
var var
SId: string; SId: string;
begin begin
SId := StringReplace(StringReplace(StringReplace(GUIDToString(TGUID.NewGuid), '}', '', []), '{', '', []), '-', '', [rfReplaceAll]); SId := StringReplace(StringReplace(StringReplace(GUIDToString(TGUID.NewGuid), '}', '', []), '{', '', []), '-', '',
[rfReplaceAll]);
Result := SendSessionCookie(AContext, SId); Result := SendSessionCookie(AContext, SId);
end; end;
procedure TMVCEngine.SaveCacheConfigValues; procedure TMVCEngine.SaveCacheConfigValues;
begin begin
FConfigCache_MaxRequestSize := StrToInt64Def(Config[TMVCConfigKey.MaxRequestSize], TMVCConstants.DEFAULT_MAX_REQUEST_SIZE); FConfigCache_MaxRequestSize := StrToInt64Def(Config[TMVCConfigKey.MaxRequestSize],
TMVCConstants.DEFAULT_MAX_REQUEST_SIZE);
end; end;
class function TMVCEngine.SendSessionCookie(const AContext: TWebContext; const ASessionId: string): string; class function TMVCEngine.SendSessionCookie(const AContext: TWebContext; const ASessionId: string): string;
@ -2240,8 +2362,8 @@ end;
{ TMVCControllerDelegate } { TMVCControllerDelegate }
constructor TMVCControllerDelegate.Create(const AClazz: TMVCControllerClazz; const ACreateAction: TMVCControllerCreateAction; constructor TMVCControllerDelegate.Create(const AClazz: TMVCControllerClazz;
const AURLSegment: string = ''); const ACreateAction: TMVCControllerCreateAction; const AURLSegment: string = '');
begin begin
inherited Create; inherited Create;
FClazz := AClazz; FClazz := AClazz;
@ -2256,7 +2378,8 @@ begin
Result := TPath.GetExtension(AStaticFileName).ToLower = '.' + AConfig[TMVCConfigKey.DefaultViewFileExtension].ToLower; Result := TPath.GetExtension(AStaticFileName).ToLower = '.' + AConfig[TMVCConfigKey.DefaultViewFileExtension].ToLower;
end; end;
class function TMVCStaticContents.IsStaticFile(const AViewPath, AWebRequestPath: string; out ARealFileName: string): Boolean; class function TMVCStaticContents.IsStaticFile(const AViewPath, AWebRequestPath: string;
out ARealFileName: string): Boolean;
var var
FileName: string; FileName: string;
begin begin
@ -2332,6 +2455,11 @@ end;
function TMVCRenderer.GetContentType: string; function TMVCRenderer.GetContentType: string;
begin begin
Result := GetContext.Response.ContentType; Result := GetContext.Response.ContentType;
if Result.Trim.IsEmpty then
begin
GetContext.Response.ContentType := FContext.FConfig[MVCFramework.Commons.TMVCConfigKey.DefaultContentType];
Result := GetContentType;
end;
end; end;
function TMVCRenderer.GetContext: TWebContext; function TMVCRenderer.GetContext: TWebContext;
@ -2577,7 +2705,8 @@ begin
SendStream(AStream, AOwns); SendStream(AStream, AOwns);
end; end;
procedure TMVCRenderer.Render(const AErrorCode: Integer; const AErrorMessage, AErrorClassName: string; const ADataObject: TObject); procedure TMVCRenderer.Render(const AErrorCode: Integer; const AErrorMessage, AErrorClassName: string;
const ADataObject: TObject);
var var
R: TMVCErrorResponse; R: TMVCErrorResponse;
begin begin
@ -2599,7 +2728,7 @@ begin
end; end;
procedure TMVCRenderer.Render(const ADataSet: TDataSet; const AOwns: Boolean; const AIgnoredFields: TMVCIgnoredList; procedure TMVCRenderer.Render(const ADataSet: TDataSet; const AOwns: Boolean; const AIgnoredFields: TMVCIgnoredList;
const ANameCase: TMVCNameCase; const ASerializationType: TMVCDatasetSerializationType); const ANameCase: TMVCNameCase; const ASerializationType: TMVCDatasetSerializationType);
begin begin
if Assigned(ADataSet) then if Assigned(ADataSet) then
begin begin
@ -2617,7 +2746,8 @@ begin
raise EMVCException.Create('Can not render an empty dataset.'); raise EMVCException.Create('Can not render an empty dataset.');
end; end;
procedure TMVCRenderer.Render<T>(const ACollection: TObjectList<T>; const AOwns: Boolean; const AType: TMVCSerializationType); procedure TMVCRenderer.Render<T>(const ACollection: TObjectList<T>; const AOwns: Boolean;
const AType: TMVCSerializationType);
begin begin
if Assigned(ACollection) then if Assigned(ACollection) then
begin begin
@ -2745,10 +2875,12 @@ begin
begin begin
SetContentType(TMVCMediaType.TEXT_HTML); SetContentType(TMVCMediaType.TEXT_HTML);
ResponseStream.Clear; ResponseStream.Clear;
ResponseStream.Append('<html><head><style>pre { color: #000000; background-color: #d0d0d0; }</style></head><body>') ResponseStream.Append
.Append('<h1>' + Config[TMVCConfigKey.ServerName] + ': Error Raised</h1>').AppendFormat('<pre>HTTP Return Code: %d' + sLineBreak, ('<html><head><style>pre { color: #000000; background-color: #d0d0d0; }</style></head><body>')
[GetContext.Response.StatusCode]).AppendFormat('HTTP Reason Text: "%s"</pre>', [GetContext.Response.ReasonString]) .Append('<h1>' + Config[TMVCConfigKey.ServerName] + ': Error Raised</h1>')
.Append('<h3><pre>').AppendFormat('Exception Class Name : %s' + sLineBreak, [AException.Classname]) .AppendFormat('<pre>HTTP Return Code: %d' + sLineBreak, [GetContext.Response.StatusCode])
.AppendFormat('HTTP Reason Text: "%s"</pre>', [GetContext.Response.ReasonString]).Append('<h3><pre>')
.AppendFormat('Exception Class Name : %s' + sLineBreak, [AException.Classname])
.AppendFormat('Exception Message : %s' + sLineBreak, [AException.Message]).Append('</pre></h3>'); .AppendFormat('Exception Message : %s' + sLineBreak, [AException.Message]).Append('</pre></h3>');
if Assigned(AExceptionItems) and (AExceptionItems.Count > 0) then if Assigned(AExceptionItems) and (AExceptionItems.Count > 0) then
begin begin
@ -2758,7 +2890,7 @@ begin
ResponseStream.Append('</pre><h2>'); ResponseStream.Append('</pre><h2>');
end end
else else
ResponseStream.AppendLine('<pre>No other informations available</pre>'); ResponseStream.AppendLine('<pre>No other information available</pre>');
ResponseStream.Append('</body></html>'); ResponseStream.Append('</body></html>');
RenderResponseStream; RenderResponseStream;
end end
@ -2822,12 +2954,13 @@ begin
end; end;
procedure TMVCRenderer.Render(const ADataSet: TDataSet; const AOwns: Boolean; const AIgnoredFields: TMVCIgnoredList; procedure TMVCRenderer.Render(const ADataSet: TDataSet; const AOwns: Boolean; const AIgnoredFields: TMVCIgnoredList;
const ASerializationType: TMVCDatasetSerializationType); const ASerializationType: TMVCDatasetSerializationType);
begin begin
Render(ADataSet, AOwns, AIgnoredFields, ncLowerCase, ASerializationType); Render(ADataSet, AOwns, AIgnoredFields, ncLowerCase, ASerializationType);
end; end;
procedure TMVCRenderer.Render(const ADataSet: TDataSet; const AOwns: Boolean; const ASerializationType: TMVCDatasetSerializationType); procedure TMVCRenderer.Render(const ADataSet: TDataSet; const AOwns: Boolean;
const ASerializationType: TMVCDatasetSerializationType);
begin begin
Render(ADataSet, AOwns, [], ASerializationType); Render(ADataSet, AOwns, [], ASerializationType);
end; end;
@ -2859,8 +2992,9 @@ end;
{ TMVCBaseView } { TMVCBaseView }
constructor TMVCBaseViewEngine.Create(const AEngine: TMVCEngine; const AWebContext: TWebContext; const AViewModel: TMVCViewDataObject; constructor TMVCBaseViewEngine.Create(const AEngine: TMVCEngine; const AWebContext: TWebContext;
const AViewDataSets: TObjectDictionary<string, TDataSet>; const AContentType: string); const AViewModel: TMVCViewDataObject; const AViewDataSets: TObjectDictionary<string, TDataSet>;
const AContentType: string);
begin begin
inherited Create; inherited Create;
Engine := AEngine; Engine := AEngine;
@ -2893,11 +3027,12 @@ begin
if DirectoryExists(Config[TMVCConfigKey.ViewPath]) then if DirectoryExists(Config[TMVCConfigKey.ViewPath]) then
F := ExpandFileName(IncludeTrailingPathDelimiter(Config.Value[TMVCConfigKey.ViewPath]) + FileName) F := ExpandFileName(IncludeTrailingPathDelimiter(Config.Value[TMVCConfigKey.ViewPath]) + FileName)
else else
F := ExpandFileName(IncludeTrailingPathDelimiter(GetApplicationFileNamePath + Config.Value[TMVCConfigKey.ViewPath]) + FileName); F := ExpandFileName(IncludeTrailingPathDelimiter(GetApplicationFileNamePath + Config.Value[TMVCConfigKey.ViewPath])
+ FileName);
if not TFile.Exists(F) then if not TFile.Exists(F) then
FileName := ExpandFileName(IncludeTrailingPathDelimiter(GetApplicationFileNamePath + Config.Value[TMVCConfigKey.DocumentRoot]) FileName := ExpandFileName(IncludeTrailingPathDelimiter(GetApplicationFileNamePath +
+ FileName) Config.Value[TMVCConfigKey.DocumentRoot]) + FileName)
else else
FileName := F; FileName := F;
@ -2918,4 +3053,3 @@ finalization
FreeAndNil(_MVCGlobalActionParamsCache); FreeAndNil(_MVCGlobalActionParamsCache);
end. end.

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

@ -1,16 +1,19 @@
program DMVCFrameworkTests; program DMVCFrameworkTests;
{$IFNDEF TESTINSIGHT} {$IFNDEF TESTINSIGHT}
{$IFNDEF GUI_TESTRUNNER}
{$APPTYPE CONSOLE} {$APPTYPE CONSOLE}
{$ENDIF}{$STRONGLINKTYPES ON} {$ENDIF}{$ENDIF}{$STRONGLINKTYPES ON}
uses uses
System.SysUtils, System.SysUtils,
{$IFDEF TESTINSIGHT} {$IFDEF GUI_TESTRUNNER}
TestInsight.DUnitX, Vcl.Forms,
{$ENDIF } DUnitX.Loggers.GUI.Vcl,
{$ENDIF}
{$IFDEF CONSOLE_TESTRUNNER}
DUnitX.Loggers.Console, DUnitX.Loggers.Console,
// DUnitX.Loggers.GUIX, {$ENDIF}
DUnitX.Loggers.Xml.NUnit, DUnitX.Loggers.Xml.NUnit,
DUnitX.TestFramework, DUnitX.TestFramework,
FrameworkTestsU in 'FrameworkTestsU.pas', FrameworkTestsU in 'FrameworkTestsU.pas',
@ -19,9 +22,10 @@ uses
BOs in 'BOs.pas', BOs in 'BOs.pas',
TestServerControllerU in '..\TestServer\TestServerControllerU.pas', TestServerControllerU in '..\TestServer\TestServerControllerU.pas',
RESTAdapterTestsU in 'RESTAdapterTestsU.pas', RESTAdapterTestsU in 'RESTAdapterTestsU.pas',
MVCFramework.Tests.WebModule2 in '..\StandaloneServer\MVCFramework.Tests.WebModule2.pas' {TestWebModule2: TWebModule}, MVCFramework.Tests.WebModule2
in '..\StandaloneServer\MVCFramework.Tests.WebModule2.pas' {TestWebModule2: TWebModule} ,
MVCFramework.Tests.StandaloneServer in '..\StandaloneServer\MVCFramework.Tests.StandaloneServer.pas', MVCFramework.Tests.StandaloneServer in '..\StandaloneServer\MVCFramework.Tests.StandaloneServer.pas',
MVCFramework.Tests.WebModule1 in '..\RESTClient\MVCFramework.Tests.WebModule1.pas' {TestWebModule1: TWebModule}, MVCFramework.Tests.WebModule1 in '..\RESTClient\MVCFramework.Tests.WebModule1.pas' {TestWebModule1: TWebModule} ,
MVCFramework.Tests.RESTClient in '..\RESTClient\MVCFramework.Tests.RESTClient.pas', MVCFramework.Tests.RESTClient in '..\RESTClient\MVCFramework.Tests.RESTClient.pas',
MVCFramework.Tests.AppController in '..\RESTClient\MVCFramework.Tests.AppController.pas', MVCFramework.Tests.AppController in '..\RESTClient\MVCFramework.Tests.AppController.pas',
BusinessObjectsU in '..\..\..\samples\commons\BusinessObjectsU.pas', BusinessObjectsU in '..\..\..\samples\commons\BusinessObjectsU.pas',
@ -34,51 +38,67 @@ uses
MVCFramework.Serializer.JsonDataObjects in '..\..\..\sources\MVCFramework.Serializer.JsonDataObjects.pas'; MVCFramework.Serializer.JsonDataObjects in '..\..\..\sources\MVCFramework.Serializer.JsonDataObjects.pas';
{$R *.RES} {$R *.RES}
{$IFDEF CONSOLE_TESTRUNNER}
procedure MainConsole();
var var
runner : ITestRunner; runner: ITestRunner;
results : IRunResults; results: IRunResults;
logger : ITestLogger; logger: ITestLogger;
nunitLogger : ITestLogger; nunitLogger: ITestLogger;
begin begin
ReportMemoryLeaksOnShutdown := True;
{$IFDEF TESTINSIGHT}
TestInsight.DUnitX.RunRegisteredTests;
exit;
{$ENDIF}
try try
//Check command line options, will exit if invalid // Check command line options, will exit if invalid
TDUnitX.CheckCommandLine; TDUnitX.CheckCommandLine;
//Create the test runner // Create the test runner
runner := TDUnitX.CreateRunner; runner := TDUnitX.CreateRunner;
//Tell the runner to use RTTI to find Fixtures // Tell the runner to use RTTI to find Fixtures
runner.UseRTTI := True; runner.UseRTTI := True;
//tell the runner how we will log things // tell the runner how we will log things
//Log to the console window // Log to the console window
logger := TDUnitXConsoleLogger.Create(true); logger := TDUnitXConsoleLogger.Create(True);
runner.AddLogger(logger); runner.AddLogger(logger);
//Generate an NUnit compatible XML File // Generate an NUnit compatible XML File
nunitLogger := TDUnitXXMLNUnitFileLogger.Create(TDUnitX.Options.XMLOutputFile); // nunitLogger := TDUnitXXMLNUnitFileLogger.Create(TDUnitX.Options.XMLOutputFile);
runner.AddLogger(nunitLogger); // runner.AddLogger(nunitLogger);
runner.FailsOnNoAsserts := False; //When true, Assertions must be made during tests; runner.FailsOnNoAsserts := False; // When true, Assertions must be made during tests;
//Run tests // Run tests
results := runner.Execute; results := runner.Execute;
if not results.AllPassed then if not results.AllPassed then
System.ExitCode := EXIT_ERRORS; System.ExitCode := EXIT_ERRORS;
{$IFNDEF CI} {$IFNDEF CI}
//We don't want this happening when running under CI. // We don't want this happening when running under CI.
if TDUnitX.Options.ExitBehavior = TDUnitXExitBehavior.Pause then if TDUnitX.Options.ExitBehavior = TDUnitXExitBehavior.Pause then
begin begin
System.Write('Done.. press <Enter> key to quit.'); System.Write('Done.. press <Enter> key to quit.');
System.Readln; System.Readln;
end; end;
{$ENDIF} {$ENDIF}
except except
on E: Exception do on E: Exception do
System.Writeln(E.ClassName, ': ', E.Message); System.Writeln(E.ClassName, ': ', E.Message);
end; end;
end;
{$ENDIF}
{$IFDEF GUI_TESTRUNNER}
procedure MainGUI;
begin
Application.Initialize;
Application.CreateForm(TGUIVCLTestRunner, GUIVCLTestRunner);
Application.Run;
end;
{$ENDIF}
begin
ReportMemoryLeaksOnShutdown := True;
{$IFDEF CONSOLE_TESTRUNNER}
MainConsole();
{$ENDIF}
{$IFDEF GUI_TESTRUNNER}
MainGUI();
{$ENDIF}
end. end.

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

@ -1,10 +1,10 @@
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup> <PropertyGroup>
<ProjectGuid>{0582DE6A-D716-46D3-8CBD-84AD73A4B536}</ProjectGuid> <ProjectGuid>{0582DE6A-D716-46D3-8CBD-84AD73A4B536}</ProjectGuid>
<ProjectVersion>18.5</ProjectVersion> <ProjectVersion>18.6</ProjectVersion>
<FrameworkType>VCL</FrameworkType> <FrameworkType>VCL</FrameworkType>
<Base>True</Base> <Base>True</Base>
<Config Condition="'$(Config)'==''">Debug</Config> <Config Condition="'$(Config)'==''">GUI</Config>
<Platform Condition="'$(Platform)'==''">Win32</Platform> <Platform Condition="'$(Platform)'==''">Win32</Platform>
<TargetedPlatforms>1</TargetedPlatforms> <TargetedPlatforms>1</TargetedPlatforms>
<AppType>Console</AppType> <AppType>Console</AppType>
@ -34,7 +34,35 @@
<Cfg_1>true</Cfg_1> <Cfg_1>true</Cfg_1>
<Base>true</Base> <Base>true</Base>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='USE_MESSAGING' or '$(Cfg_3)'!=''"> <PropertyGroup Condition="'$(Config)'=='CONSOLE' or '$(Cfg_4)'!=''">
<Cfg_4>true</Cfg_4>
<CfgParent>Cfg_1</CfgParent>
<Cfg_1>true</Cfg_1>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_4)'=='true') or '$(Cfg_4_Win32)'!=''">
<Cfg_4_Win32>true</Cfg_4_Win32>
<CfgParent>Cfg_4</CfgParent>
<Cfg_4>true</Cfg_4>
<Cfg_1>true</Cfg_1>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='CI' or '$(Cfg_5)'!=''">
<Cfg_5>true</Cfg_5>
<CfgParent>Cfg_4</CfgParent>
<Cfg_4>true</Cfg_4>
<Cfg_1>true</Cfg_1>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_5)'=='true') or '$(Cfg_5_Win32)'!=''">
<Cfg_5_Win32>true</Cfg_5_Win32>
<CfgParent>Cfg_5</CfgParent>
<Cfg_5>true</Cfg_5>
<Cfg_4>true</Cfg_4>
<Cfg_1>true</Cfg_1>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='GUI' or '$(Cfg_3)'!=''">
<Cfg_3>true</Cfg_3> <Cfg_3>true</Cfg_3>
<CfgParent>Cfg_1</CfgParent> <CfgParent>Cfg_1</CfgParent>
<Cfg_1>true</Cfg_1> <Cfg_1>true</Cfg_1>
@ -47,12 +75,6 @@
<Cfg_1>true</Cfg_1> <Cfg_1>true</Cfg_1>
<Base>true</Base> <Base>true</Base>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='SERVER_ON_LINUX' or '$(Cfg_4)'!=''">
<Cfg_4>true</Cfg_4>
<CfgParent>Cfg_1</CfgParent>
<Cfg_1>true</Cfg_1>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_2)'!=''"> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_2)'!=''">
<Cfg_2>true</Cfg_2> <Cfg_2>true</Cfg_2>
<CfgParent>Base</CfgParent> <CfgParent>Base</CfgParent>
@ -73,7 +95,6 @@
<Icns_MainIcns>$(BDS)\bin\delphi_PROJECTICNS.icns</Icns_MainIcns> <Icns_MainIcns>$(BDS)\bin\delphi_PROJECTICNS.icns</Icns_MainIcns>
<SanitizedProjectName>DMVCFrameworkTests</SanitizedProjectName> <SanitizedProjectName>DMVCFrameworkTests</SanitizedProjectName>
<DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace)</DCC_Namespace> <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace)</DCC_Namespace>
<DCC_Define>_CONSOLE_TESTRUNNER;TESTINSIGHT;$(DCC_Define)</DCC_Define>
<DCC_UnitSearchPath>$(BDS)\Source\DUnit\src;..\..\..\sources;..\..\..\lib\delphistompclient;..\..\..\lib\dmustache;..\..\..\lib\loggerpro;$(DCC_UnitSearchPath)</DCC_UnitSearchPath> <DCC_UnitSearchPath>$(BDS)\Source\DUnit\src;..\..\..\sources;..\..\..\lib\delphistompclient;..\..\..\lib\dmustache;..\..\..\lib\loggerpro;$(DCC_UnitSearchPath)</DCC_UnitSearchPath>
<DCC_DcuOutput>.\$(Platform)\$(Config)\dcu</DCC_DcuOutput> <DCC_DcuOutput>.\$(Platform)\$(Config)\dcu</DCC_DcuOutput>
<DCC_ExeOutput>.\$(Platform)\$(Config)</DCC_ExeOutput> <DCC_ExeOutput>.\$(Platform)\$(Config)</DCC_ExeOutput>
@ -106,17 +127,26 @@
<VerInfo_Locale>1033</VerInfo_Locale> <VerInfo_Locale>1033</VerInfo_Locale>
<DCC_MapFile>3</DCC_MapFile> <DCC_MapFile>3</DCC_MapFile>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Cfg_3)'!=''"> <PropertyGroup Condition="'$(Cfg_4)'!=''">
<VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> <DCC_Define>CONSOLE_TESTRUNNER;$(DCC_Define)</DCC_Define>
<VerInfo_Locale>1040</VerInfo_Locale>
<DCC_Define>USE_MESSAGING;$(DCC_Define)</DCC_Define>
<Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Cfg_3_Win32)'!=''"> <PropertyGroup Condition="'$(Cfg_4_Win32)'!=''">
<VerInfo_Locale>1033</VerInfo_Locale>
<AppEnableRuntimeThemes>true</AppEnableRuntimeThemes> <AppEnableRuntimeThemes>true</AppEnableRuntimeThemes>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Cfg_4)'!=''"> <PropertyGroup Condition="'$(Cfg_5_Win32)'!=''">
<DCC_Define>LINUX_SERVER;$(DCC_Define)</DCC_Define> <DCC_Define>CI;$(DCC_Define)</DCC_Define>
<VerInfo_Locale>1033</VerInfo_Locale>
<AppEnableRuntimeThemes>true</AppEnableRuntimeThemes>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_3)'!=''">
<DCC_UnitSearchPath>$(BDS)\source\DunitX;$(DCC_UnitSearchPath)</DCC_UnitSearchPath>
<DCC_Define>_CONSOLE_TESTRUNNER;GUI_TESTRUNNER;$(DCC_Define)</DCC_Define>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_3_Win32)'!=''">
<DCC_Define>GUI_TESTRUNNER;$(DCC_Define)</DCC_Define>
<VerInfo_Locale>1033</VerInfo_Locale>
<AppEnableRuntimeThemes>true</AppEnableRuntimeThemes>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2)'!=''"> <PropertyGroup Condition="'$(Cfg_2)'!=''">
<VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys>
@ -141,13 +171,11 @@
<DCCReference Include="RESTAdapterTestsU.pas"/> <DCCReference Include="RESTAdapterTestsU.pas"/>
<DCCReference Include="..\StandaloneServer\MVCFramework.Tests.WebModule2.pas"> <DCCReference Include="..\StandaloneServer\MVCFramework.Tests.WebModule2.pas">
<Form>TestWebModule2</Form> <Form>TestWebModule2</Form>
<FormType>dfm</FormType>
<DesignClass>TWebModule</DesignClass> <DesignClass>TWebModule</DesignClass>
</DCCReference> </DCCReference>
<DCCReference Include="..\StandaloneServer\MVCFramework.Tests.StandaloneServer.pas"/> <DCCReference Include="..\StandaloneServer\MVCFramework.Tests.StandaloneServer.pas"/>
<DCCReference Include="..\RESTClient\MVCFramework.Tests.WebModule1.pas"> <DCCReference Include="..\RESTClient\MVCFramework.Tests.WebModule1.pas">
<Form>TestWebModule1</Form> <Form>TestWebModule1</Form>
<FormType>dfm</FormType>
<DesignClass>TWebModule</DesignClass> <DesignClass>TWebModule</DesignClass>
</DCCReference> </DCCReference>
<DCCReference Include="..\RESTClient\MVCFramework.Tests.RESTClient.pas"/> <DCCReference Include="..\RESTClient\MVCFramework.Tests.RESTClient.pas"/>
@ -160,10 +188,14 @@
<DCCReference Include="..\..\..\sources\MVCFramework.JSONRPC.pas"/> <DCCReference Include="..\..\..\sources\MVCFramework.JSONRPC.pas"/>
<DCCReference Include="..\..\..\samples\commons\RandomUtilsU.pas"/> <DCCReference Include="..\..\..\samples\commons\RandomUtilsU.pas"/>
<DCCReference Include="..\..\..\sources\MVCFramework.Serializer.JsonDataObjects.pas"/> <DCCReference Include="..\..\..\sources\MVCFramework.Serializer.JsonDataObjects.pas"/>
<BuildConfiguration Include="CI">
<Key>Cfg_5</Key>
<CfgParent>Cfg_4</CfgParent>
</BuildConfiguration>
<BuildConfiguration Include="Base"> <BuildConfiguration Include="Base">
<Key>Base</Key> <Key>Base</Key>
</BuildConfiguration> </BuildConfiguration>
<BuildConfiguration Include="SERVER_ON_LINUX"> <BuildConfiguration Include="CONSOLE">
<Key>Cfg_4</Key> <Key>Cfg_4</Key>
<CfgParent>Cfg_1</CfgParent> <CfgParent>Cfg_1</CfgParent>
</BuildConfiguration> </BuildConfiguration>
@ -171,14 +203,14 @@
<Key>Cfg_2</Key> <Key>Cfg_2</Key>
<CfgParent>Base</CfgParent> <CfgParent>Base</CfgParent>
</BuildConfiguration> </BuildConfiguration>
<BuildConfiguration Include="USE_MESSAGING">
<Key>Cfg_3</Key>
<CfgParent>Cfg_1</CfgParent>
</BuildConfiguration>
<BuildConfiguration Include="Debug"> <BuildConfiguration Include="Debug">
<Key>Cfg_1</Key> <Key>Cfg_1</Key>
<CfgParent>Base</CfgParent> <CfgParent>Base</CfgParent>
</BuildConfiguration> </BuildConfiguration>
<BuildConfiguration Include="GUI">
<Key>Cfg_3</Key>
<CfgParent>Cfg_1</CfgParent>
</BuildConfiguration>
</ItemGroup> </ItemGroup>
<ProjectExtensions> <ProjectExtensions>
<Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.Personality>Delphi.Personality.12</Borland.Personality>
@ -239,7 +271,8 @@
<Source Name="MainSource">DMVCFrameworkTests.dpr</Source> <Source Name="MainSource">DMVCFrameworkTests.dpr</Source>
</Source> </Source>
<Excluded_Packages> <Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\DataExplorerDBXPluginEnt260.bpl">DBExpress Enterprise Data Explorer Integration</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcboffice2k260.bpl">Embarcadero C++Builder Office 2000 Servers Package</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\bcbofficexp260.bpl">Embarcadero C++Builder Office XP Servers Package</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\dcloffice2k260.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dcloffice2k260.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\dclofficexp260.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dclofficexp260.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages>
</Excluded_Packages> </Excluded_Packages>

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

@ -41,10 +41,8 @@ const
{$ENDIF} {$ENDIF}
type type
[TestFixture]
TBaseServerTest = class(TObject) TBaseServerTest = class(TObject)
protected protected
RESTClient: TRESTClient; RESTClient: TRESTClient;
@ -59,11 +57,12 @@ type
end; end;
[TestFixture]
TServerTest = class(TBaseServerTest) TServerTest = class(TBaseServerTest)
public public
[Test] [Test]
[TestCase('/fault', '/fault')] [TestCase('request url /fault', '/fault')]
[TestCase('/fault2', '/fault2')] [TestCase('request url /fault2', '/fault2')]
procedure TestControllerWithExceptionInCreate(const URLSegment: string); procedure TestControllerWithExceptionInCreate(const URLSegment: string);
[Test] [Test]
@ -73,12 +72,12 @@ type
[Test] [Test]
[TestCase('1', ' à,è')] [TestCase('1', ' à,è')]
[TestCase('2', 'é,ù,ò')] [TestCase('2', 'é,ù,ò')]
[TestCase('2', 'ì,@,[')] [TestCase('3', 'ì,@,[')]
[TestCase('2', '],{,}')] [TestCase('4', '],{,}')]
[TestCase('2', '(,),\')] [TestCase('5', '(,),\')]
[TestCase('2', '=,;,&')] [TestCase('6', '=,;,&')]
[TestCase('2', '#,.,_')] [TestCase('7', '#,.,_')]
[TestCase('2', '%, , ')] [TestCase('8', '%, , ')]
procedure TestReqWithURLMappedParams(const par1, par2, par3: string); procedure TestReqWithURLMappedParams(const par1, par2, par3: string);
[Test] [Test]
procedure TestPOSTWithParamsAndJSONBody; procedure TestPOSTWithParamsAndJSONBody;
@ -473,15 +472,16 @@ begin
Assert.areEqual('johndoe', LRes.BodyAsString); Assert.areEqual('johndoe', LRes.BodyAsString);
end; end;
procedure TServerTest.TestControllerWithExceptionInCreate( procedure TServerTest.TestControllerWithExceptionInCreate(const URLSegment: string);
const URLSegment: string);
var var
res: IRESTResponse; res: IRESTResponse;
begin begin
res := RESTClient.doGET(URLSegment, []); res := RESTClient.doGET(URLSegment, []);
Assert.areEqual(HTTP_STATUS.InternalServerError, res.ResponseCode); Assert.areEqual(HTTP_STATUS.InternalServerError, res.ResponseCode);
Assert.Contains(res.ContentType, 'text/plain', true, 'Is not a text/plain in case of error'); //Assert.Contains(res.ContentType, 'text/plain', true, 'Is not a text/plain in case of error');
Assert.Contains(res.ContentType, 'application/json', true, 'Is not a application/json in case of error');
Assert.Contains(res.BodyAsString, 'Cannot create controller', true, 'Exception message in body is not correct'); Assert.Contains(res.BodyAsString, 'Cannot create controller', true, 'Exception message in body is not correct');
//Assert.Contains(res.BodyAsString, 'Cannot create controller', true, 'Exception message in body is not correct');
end; end;
procedure TServerTest.TestCookies; procedure TServerTest.TestCookies;
@ -733,12 +733,10 @@ var
lCompType: string; lCompType: string;
j: Integer; j: Integer;
const const
CompressionTypes: array [1 .. 9] of string = CompressionTypes: array [1 .. 9] of string = ('deflate', 'gzip', 'deflate,gzip', 'gzip,deflate', 'gzip,invalid',
('deflate', 'gzip', 'deflate,gzip', 'gzip,deflate', 'deflate,notvalid', 'notvalid,gzip', 'invalid', '');
'gzip,invalid', 'deflate,notvalid', 'notvalid,gzip', 'invalid', ''); CompressionTypeResult: array [1 .. 9] of string = ('deflate', 'gzip', 'deflate', 'gzip', 'gzip', 'deflate',
CompressionTypeResult: array [1 .. 9] of string = 'gzip', '', '');
('deflate', 'gzip', 'deflate', 'gzip',
'gzip', 'deflate', 'gzip', '', '');
begin begin
j := 1; j := 1;
for lCompType in CompressionTypes do for lCompType in CompressionTypes do
@ -1330,7 +1328,7 @@ begin
lRPCResp := FExecutor2.ExecuteRequest(lReq); lRPCResp := FExecutor2.ExecuteRequest(lReq);
LRes := lRPCResp.Result.AsType<TDateTime>(); LRes := lRPCResp.Result.AsType<TDateTime>();
DecodeDateTime(LRes, lYear, lMonth, lDay, lHour, lMinute, lSecond, lMillisecond); DecodeDateTime(LRes, lYear, lMonth, lDay, lHour, lMinute, lSecond, lMillisecond);
Assert.AreEqual(2000, lYear); Assert.areEqual(2000, lYear);
end; end;
procedure TJSONRPCServerTest.TestRequestWithoutParams; procedure TJSONRPCServerTest.TestRequestWithoutParams;

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

@ -1,7 +1,7 @@
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup> <PropertyGroup>
<ProjectGuid>{FAC8B4A9-B614-46ED-BF18-D718EC2E7F3E}</ProjectGuid> <ProjectGuid>{FAC8B4A9-B614-46ED-BF18-D718EC2E7F3E}</ProjectGuid>
<ProjectVersion>18.5</ProjectVersion> <ProjectVersion>18.6</ProjectVersion>
<FrameworkType>None</FrameworkType> <FrameworkType>None</FrameworkType>
<MainSource>TestServer.dpr</MainSource> <MainSource>TestServer.dpr</MainSource>
<Base>True</Base> <Base>True</Base>

8
unittests/serializer/jsondataobjects/MVCFramework.Tests.Serializer.JsonDataObjects.pas
View File

@ -770,8 +770,16 @@ begin
Dm.EntityAsIsId.AsLargeInt := 2; Dm.EntityAsIsId.AsLargeInt := 2;
Dm.EntityAsIsName.AsString := 'Ezequiel Juliano Müller'; Dm.EntityAsIsName.AsString := 'Ezequiel Juliano Müller';
Dm.EntityAsIs.Post; Dm.EntityAsIs.Post;
//serialize dataset
S := FSerializer.SerializeDataSet(Dm.EntityAsIs); S := FSerializer.SerializeDataSet(Dm.EntityAsIs);
Assert.areEqual(JSON_LIST, S, 'json list'); Assert.areEqual(JSON_LIST, S, 'json list');
//serialize dataset as object
S := FSerializer.SerializeObject(Dm.EntityAsIs);
Assert.areEqual(JSON_LIST, S, 'json list');
finally finally
Dm.Free; Dm.Free;
end; end;

10
unittests/serializer/jsondataobjects/TestSerializerJsonDataObjects.dproj
View File

@ -1,10 +1,10 @@
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup> <PropertyGroup>
<ProjectGuid>{DE94B0A5-DA22-4941-9AE1-FB2BBDCD4F7E}</ProjectGuid> <ProjectGuid>{DE94B0A5-DA22-4941-9AE1-FB2BBDCD4F7E}</ProjectGuid>
<ProjectVersion>18.5</ProjectVersion> <ProjectVersion>18.6</ProjectVersion>
<FrameworkType>None</FrameworkType> <FrameworkType>None</FrameworkType>
<Base>True</Base> <Base>True</Base>
<Config Condition="'$(Config)'==''">CI</Config> <Config Condition="'$(Config)'==''">Debug</Config>
<Platform Condition="'$(Platform)'==''">Win32</Platform> <Platform Condition="'$(Platform)'==''">Win32</Platform>
<TargetedPlatforms>1</TargetedPlatforms> <TargetedPlatforms>1</TargetedPlatforms>
<AppType>Console</AppType> <AppType>Console</AppType>
@ -48,7 +48,7 @@
<PropertyGroup Condition="'$(Base)'!=''"> <PropertyGroup Condition="'$(Base)'!=''">
<SanitizedProjectName>TestSerializerJsonDataObjects</SanitizedProjectName> <SanitizedProjectName>TestSerializerJsonDataObjects</SanitizedProjectName>
<DCC_Namespace>System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace)</DCC_Namespace> <DCC_Namespace>System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace)</DCC_Namespace>
<DCC_Define>_CONSOLE_TESTRUNNER;TESTINSIGHT;$(DCC_Define)</DCC_Define> <DCC_Define>CONSOLE_TESTRUNNER;_TESTINSIGHT;$(DCC_Define)</DCC_Define>
<VerInfo_Locale>1046</VerInfo_Locale> <VerInfo_Locale>1046</VerInfo_Locale>
<DCC_DcpOutput>.\$(Platform)\$(Config)\dcp</DCC_DcpOutput> <DCC_DcpOutput>.\$(Platform)\$(Config)\dcp</DCC_DcpOutput>
<DCC_UnitSearchPath>$(BDS)\Source\DUnit\src;..\..\..\sources;..\..\..\lib\loggerpro;..\..\..\lib\dmustache;..\..\..\lib\delphistompclient;..\..\..\lib\jsondataobjects\Source;$(DCC_UnitSearchPath)</DCC_UnitSearchPath> <DCC_UnitSearchPath>$(BDS)\Source\DUnit\src;..\..\..\sources;..\..\..\lib\loggerpro;..\..\..\lib\dmustache;..\..\..\lib\delphistompclient;..\..\..\lib\jsondataobjects\Source;$(DCC_UnitSearchPath)</DCC_UnitSearchPath>
@ -122,11 +122,11 @@
<BorlandProject> <BorlandProject>
<Delphi.Personality> <Delphi.Personality>
<Excluded_Packages> <Excluded_Packages>
<Excluded_Packages Name="C:\Users\Public\Documents\Embarcadero\Studio\20.0\Bpl\LockBoxFMXDD250.bpl">TurboPack LockBox Delphi FMX designtime package</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\DataExplorerDBXPluginEnt260.bpl">DBExpress Enterprise Data Explorer Integration</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\DataExplorerDBXPluginEnt260.bpl">DBExpress Enterprise Data Explorer Integration</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\bcboffice2k260.bpl">Embarcadero C++Builder Office 2000 Servers Package</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\bcbofficexp260.bpl">Embarcadero C++Builder Office XP Servers Package</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\dcloffice2k260.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dcloffice2k260.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\dclofficexp260.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dclofficexp260.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages>
<Excluded_Packages Name="C:\Program Files (x86)\FastReports\LibD26\dclfrxtee26.bpl">FastReport 6.0 Tee Components</Excluded_Packages>
</Excluded_Packages> </Excluded_Packages>
<Source> <Source>
<Source Name="MainSource">TestSerializerJsonDataObjects.dpr</Source> <Source Name="MainSource">TestSerializerJsonDataObjects.dpr</Source>