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

https://github.com/danieleteti/delphimvcframework/issues/694

Browse Source
This commit is contained in:
Daniele Teti 2023-09-22 09:43:35 +02:00
parent ed9a0cbe0e
commit 0f35452954
8 changed files with 159 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
7ziplistfile.txt
View File

@ -11,3 +11,4 @@
.\samples\**\*.js
.\samples\**\*.css
.\samples\**\myproj*
.\samples\**\*.htmx

17
sources/MVCFramework.ActiveRecordController.pas
View File

@ -241,6 +241,7 @@ var
lARClass: TMVCActiveRecordClass;
lProcessor: IMVCEntityProcessor;
lHandled: Boolean;
lResponse: IMVCResponse;
begin
lProcessor := nil;
if ActiveRecordMappingRegistry.FindProcessorByURLSegment(entityname, lProcessor) then
@ -267,12 +268,20 @@ begin
if lAR.LoadByPK(id) then
begin
Render(ObjectDict(false).Add('data', lAR));
lResponse := MVCResponseBuilder
.StatusCode(HTTP_STATUS.OK)
.Body(ObjectDict(false).Add('data', lAR))
.Build;
end
else
begin
Render(TMVCErrorResponse.Create(http_status.NotFound, entityname.ToLower + ' not found'));
lResponse := MVCResponseBuilder
.StatusCode(HTTP_STATUS.NotFound)
.Body(entityname.ToLower + ' not found')
.Build;
//Render(TMVCErrorResponse.Create(http_status.NotFound, entityname.ToLower + ' not found'));
end;
TMVCRenderer.InternalRenderMVCResponse(Self, TMVCResponse(lResponse));
finally
lAR.Free;
end;
@ -362,7 +371,7 @@ begin
Context.Response.CustomHeaders.Values['X-REF'] := Context.Request.PathInfo + '/' + lAR.GetPK.AsInt64.ToString;
if Context.Request.QueryStringParam('refresh').ToLower = 'true' then
begin
RenderStatusMessage(http_status.Created, entityname.ToLower + ' created', '', lAR);
RenderStatusMessage(http_status.Created, entityname.ToLower + ' created', '', lAR, False);
end
else
begin
@ -411,7 +420,7 @@ begin
Context.Response.CustomHeaders.Values['X-REF'] := Context.Request.PathInfo;
if Context.Request.QueryStringParam('refresh').ToLower = 'true' then
begin
RenderStatusMessage(http_status.OK, entityname.ToLower + ' updated', '', lAR);
RenderStatusMessage(http_status.OK, entityname.ToLower + ' updated', '', lAR, False);
end
else
begin

92
sources/MVCFramework.View.Renderers.Mustache.pas
View File

@ -27,11 +27,11 @@ unit MVCFramework.View.Renderers.Mustache;
{$IFDEF LINUX}
This unit is not compatible with Linux
{$ENDIF}
interface
interface
uses
MVCFramework, System.SysUtils,
MVCFramework.Commons, System.IOUtils, System.Classes, Data.DB;
uses
MVCFramework, System.SysUtils, System.Generics.Collections,
MVCFramework.Commons, System.IOUtils, System.Classes, Data.DB, SynMustache;
type
{ This class implements the mustache view engine for server side views }
@ -39,17 +39,21 @@ type
strict private
procedure PrepareModels;
private
FJSONModel: string;
class var fPartials: TSynMustachePartials;
var FJSONModel: string;
procedure LoadPartials;
public
procedure Execute(const ViewName: string; const OutputStream: TStream);
override;
procedure Execute(const ViewName: string; const OutputStream: TStream); override;
constructor Create(const AEngine: TMVCEngine; const AWebContext: TWebContext;
const AViewModel: TMVCViewDataObject;
const AViewDataSets: TObjectDictionary<string, TDataSet>;
const AContentType: string); override;
class destructor Destroy;
end;
implementation
uses
System.Generics.Collections,
SynMustache,
SynCommons,
JsonDataObjects,
MVCFramework.Serializer.Defaults,
@ -65,42 +69,74 @@ type
TSynMustacheAccess = class(TSynMustache)
end;
var
gPartialsLoaded : Boolean = False;
constructor TMVCMustacheViewEngine.Create(const AEngine: TMVCEngine;
const AWebContext: TWebContext; const AViewModel: TMVCViewDataObject;
const AViewDataSets: TObjectDictionary<string, TDataSet>;
const AContentType: string);
begin
inherited;
LoadPartials;
end;
class destructor TMVCMustacheViewEngine.Destroy;
begin
fPartials.Free;
end;
procedure TMVCMustacheViewEngine.Execute(const ViewName: string; const OutputStream: TStream);
var
I: Integer;
lPartialName: string;
lViewFileName: string;
lViewTemplate: RawUTF8;
lViewEngine: TSynMustache;
lSW: TStreamWriter;
lPartials: TSynMustachePartials;
begin
PrepareModels;
lViewFileName := GetRealFileName(ViewName);
if not FileExists(lViewFileName) then
raise EMVCFrameworkViewException.CreateFmt('View [%s] not found', [ViewName]);
lViewTemplate := StringToUTF8(TFile.ReadAllText(lViewFileName, TEncoding.UTF8));
lViewEngine := TSynMustache.Parse(lViewTemplate);
lSW := TStreamWriter.Create(OutputStream);
lPartials := TSynMustachePartials.Create;
try
for I := 0 to Length(TSynMustacheAccess(lViewEngine).fTags) - 1 do
begin
if TSynMustacheAccess(lViewEngine).fTags[I].Kind = mtPartial then
begin
lPartialName := TSynMustacheAccess(lViewEngine).fTags[I].Value;
lViewFileName := GetRealFileName(lPartialName);
if not FileExists(lViewFileName) then
raise EMVCFrameworkViewException.CreateFmt('Partial View [%s] not found', [lPartialName]);
lViewTemplate := StringToUTF8(TFile.ReadAllText(lViewFileName, TEncoding.UTF8));
lPartials.Add(lPartialName, lViewTemplate);
end;
end;
lSW.Write(UTF8Tostring(lViewEngine.RenderJSON(FJSONModel, lPartials, nil, nil)));
lSW.Write(UTF8Tostring(lViewEngine.RenderJSON(FJSONModel, fPartials, nil, nil)));
finally
lSW.Free;
lPartials.Free;
end;
end;
procedure TMVCMustacheViewEngine.LoadPartials;
var
lViewsExtension: string;
lViewPath: string;
lPartialFileNames: TArray<string>;
I: Integer;
begin
if gPartialsLoaded then
begin
Exit
end
else
begin
TMonitor.Enter(gLock);
try
if not gPartialsLoaded then
begin
lViewsExtension := Config[TMVCConfigKey.DefaultViewFileExtension];
lViewPath := Config[TMVCConfigKey.ViewPath];
lPartialFileNames := TDirectory.GetFiles(lViewPath, '*.' + lViewsExtension);
fPartials := TSynMustachePartials.Create;
for I := 0 to High(lPartialFileNames) do
begin
fPartials.Add(TPath.GetFileNameWithoutExtension(lPartialFileNames[i]), TFile.ReadAllText(lPartialFileNames[i]));
end;
gPartialsLoaded := True;
end;
finally
TMonitor.Exit(gLock);
end;
end;
end;

100
sources/MVCFramework.pas
View File

@ -668,6 +668,7 @@ type
function GetContext: TWebContext;
procedure Redirect(const AUrl: string); virtual;
procedure ResponseStatus(const AStatusCode: Integer; const AReasonString: string = ''); virtual;
class procedure InternalRenderMVCResponse(const Controller: TMVCRenderer; const MVCResponse: TMVCResponse);
/// <summary>
/// HTTP Status 201 indicates that as a result of HTTP POST request, one or more new resources have been successfully created on server.
/// The response may contain URI in Location header field in HTTP headers list, which can have reference to the newly created resource. Also, response payload also may include an entity containing a list of resource characteristics and location(s) from which the user or user agent can choose the one most appropriate.
@ -724,7 +725,8 @@ type
procedure Render(const AStatusCode: Integer; AObject: TObject; const AOwns: Boolean;
const ASerializationAction: TMVCSerializationAction = nil; const AIgnoredFields: TMVCIgnoredList = nil); overload;
procedure Render(const AObject: IInterface;
const ASerializationAction: TMVCSerializationAction = nil); overload;
const ASerializationAction: TMVCSerializationAction = nil;
const AIgnoredFields: TMVCIgnoredList = nil); overload;
procedure Render(const AStatusCode: Integer; const AObject: IInterface;
const ASerializationAction: TMVCSerializationAction = nil); overload;
procedure Render<T: record>(const AStatusCode: Integer; var ARecord: T); overload;
@ -743,7 +745,7 @@ type
procedure Render(const ATextWriter: TTextWriter; const AOwns: Boolean = True); overload;
procedure Render(const AStream: TStream; const AOwns: Boolean = True); overload;
procedure RenderStatusMessage(const AStatusCode: Integer; const AReasonMessage: string = '';
const AErrorClassName: string = ''; const ADataObject: TObject = nil); overload;
const AErrorClassName: string = ''; const ADataObject: TObject = 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;
@ -978,7 +980,6 @@ type
const AResponse: TWebResponse); virtual;
function ExecuteAction(const ASender: TObject; const ARequest: TWebRequest;
const AResponse: TWebResponse): Boolean; virtual;
procedure InternalRenderMVCResponse(const Controller: TMVCController; const MVCResponse: TMVCResponse);
public
class function GetCurrentSession(const ASessionId: string;
const ARaiseExceptionIfExpired: Boolean = True): TMVCWebSession; static;
@ -1094,7 +1095,8 @@ type
fObjectDictionary: IMVCObjectDictionary;
fHeaders: TStringList;
fReasonString: String;
fOwnsData: Boolean;
procedure SetOwnsData(const Value: Boolean);
protected
function GetData: TObject; override;
function GetMessage: string; override;
@ -1108,6 +1110,8 @@ type
procedure SetReasonString(const Value: string); override;
procedure SetHeaders(const Value: TStringList); override;
function GetHeaders: TStringList; override;
//do not expose this property through interface
property OwnsData: Boolean read fOwnsData write SetOwnsData;
protected
function HasHeaders: Boolean; override;
function HasBody: Boolean; override;
@ -1115,7 +1119,7 @@ type
constructor Create; overload; virtual;
constructor Create(const StatusCode: Integer; const Message: String); overload;
destructor Destroy; override;
function GetIgnoredList: TMVCIgnoredList; virtual;
function GetIgnoredList: TMVCIgnoredList; override;
[MVCDoNotSerialize]
property StatusCode: Integer read GetStatusCode write SetStatusCode;
[MVCDoNotSerialize]
@ -1185,7 +1189,7 @@ type
['{10210D72-AFAE-4919-936D-EB08AA16C01C}']
function StatusCode(const StatusCode: Integer): IMVCResponseBuilder;
function Header(const Name: String; const Value: String): IMVCResponseBuilder;
function Body(const Data: TObject): IMVCResponseBuilder; overload;
function Body(const Data: TObject; const Owns: Boolean = True): IMVCResponseBuilder; overload;
function Body(const Message: String): IMVCResponseBuilder; overload;
function Body(const ObjDictionary: IMVCObjectDictionary): IMVCResponseBuilder; overload;
function Build: IMVCResponse;
@ -1221,6 +1225,7 @@ type
private
fBuilt: Boolean;
fHeaders: TStringList;
fOwnsData: Boolean;
protected
fStatusCode: Integer;
fMessage: String;
@ -1229,7 +1234,7 @@ type
function HasHeaders: Boolean;
function StatusCode(const StatusCode: Integer): IMVCResponseBuilder;
function Message(const Message: String): IMVCResponseBuilder;
function Body(const Data: TObject): IMVCResponseBuilder; overload;
function Body(const Data: TObject; const Owns: Boolean): IMVCResponseBuilder; overload;
function Body(const MessageText: String): IMVCResponseBuilder; overload;
function Body(const ObjDictionary: IMVCObjectDictionary): IMVCResponseBuilder; overload;
function Header(const Name: String; const Value: String): IMVCResponseBuilder;
@ -2614,7 +2619,7 @@ begin
begin
if Supports(lInvokeResult.AsInterface, IMVCResponse) then
begin
InternalRenderMVCResponse(lSelectedController, TMVCResponse(lInvokeResult.AsInterface));
TMVCRenderer.InternalRenderMVCResponse(lSelectedController, TMVCResponse(lInvokeResult.AsInterface));
end
else
begin
@ -2640,7 +2645,7 @@ begin
end
else if lResponseObject is TMVCResponse then
begin
InternalRenderMVCResponse(lSelectedController, TMVCResponse(lResponseObject));
TMVCRenderer.InternalRenderMVCResponse(lSelectedController, TMVCResponse(lResponseObject));
end
else if (not lResponseObject.InheritsFrom(TJsonBaseObject)) and TDuckTypedList.CanBeWrappedAsList(lResponseObject, lObjList) then
begin
@ -3237,22 +3242,6 @@ begin
': ' + AReasonString);
end;
procedure TMVCEngine.InternalRenderMVCResponse(const Controller: TMVCController; const MVCResponse: TMVCResponse);
begin
if MVCResponse.HasHeaders then
begin
Controller.Context.Response.CustomHeaders.AddStrings(MVCResponse.fHeaders);
end;
if MVCResponse.HasBody then
begin
Controller.Render(MVCResponse.StatusCode, MVCResponse, False, nil, MVCResponse.GetIgnoredList);
end
else
begin
Controller.ResponseStatus(MVCResponse.StatusCode);
end;
end;
procedure TMVCEngine.SendRawHTTPStatus(const AContext: TWebContext; const HTTPStatusCode: Integer;
const AReasonString: string; const AClassName: string);
var
@ -3722,6 +3711,26 @@ begin
Result := GetContext.Response.StatusCode;
end;
class procedure TMVCRenderer.InternalRenderMVCResponse(
const Controller: TMVCRenderer; const MVCResponse: TMVCResponse);
begin
begin
if MVCResponse.HasHeaders then
begin
Controller.FContext.Response.CustomHeaders.AddStrings(MVCResponse.fHeaders);
end;
if MVCResponse.HasBody then
begin
Controller.Render(MVCResponse.StatusCode, MVCResponse, False, nil, MVCResponse.GetIgnoredList);
end
else
begin
Controller.ResponseStatus(MVCResponse.StatusCode);
end;
end;
end;
function TMVCController.GetViewData(const aModelName: string): TObject;
begin
if not FViewModel.TryGetValue(aModelName, Result) then
@ -4041,21 +4050,17 @@ end;
procedure TMVCRenderer.RenderStatusMessage(
const AStatusCode: Integer;
const AReasonMessage, AErrorClassName: string;
const ADataObject: TObject);
const ADataObject: TObject;
const AOwns: Boolean);
var
R: TMVCErrorResponse;
lResponse: IMVCResponse;
begin
ResponseStatus(AStatusCode, AReasonMessage);
R := TMVCErrorResponse.Create;
try
R.StatusCode := AStatusCode;
R.Message := AReasonMessage;
R.Classname := AErrorClassName;
R.Data := ADataObject;
Render(R, False, stProperties, nil);
finally
R.Free;
end;
lResponse := MVCResponseBuilder
.StatusCode(AStatusCode)
.Body(AReasonMessage)
.Body(ADataObject, AOwns)
.Build;
TMVCRenderer.InternalRenderMVCResponse(Self, TMVCResponse(lResponse));
end;
procedure TMVCRenderer.RenderStream(const AStream: TStream; const AOwns,
@ -4114,10 +4119,11 @@ end;
procedure TMVCRenderer.Render(
const AObject: IInterface;
const ASerializationAction: TMVCSerializationAction);
const ASerializationAction: TMVCSerializationAction;
const AIgnoredFields: TMVCIgnoredList);
begin
{TODO -oDanieleT -cGeneral : Handle StatusCode}
Render(TObject(AObject), False, ASerializationAction);
Render(TObject(AObject), False, ASerializationAction, AIgnoredFields);
end;
procedure TMVCRenderer.Render(const AStatusCode: Integer; AObject: TObject; const AOwns: Boolean;
@ -4390,6 +4396,7 @@ end;
constructor TMVCResponse.Create;
begin
inherited Create;
fOwnsData := True;
fData := nil;
fMessage := '';
fObjectDictionary := nil;
@ -4411,7 +4418,10 @@ end;
destructor TMVCResponse.Destroy;
begin
if FOwnsData then
begin
fData.Free;
end;
inherited;
end;
@ -4505,6 +4515,11 @@ begin
fObjectDictionary := Value;
end;
procedure TMVCResponse.SetOwnsData(const Value: Boolean);
begin
fOwnsData := Value;
end;
procedure TMVCResponse.SetReasonString(const Value: string);
begin
fReasonString := Value;
@ -4671,6 +4686,7 @@ function TMVCResponseBuilder.Build: IMVCResponse;
begin
Result := TMVCResponse.Create;
Result.Data := fData;
TMVCResponse(Result).OwnsData := fOwnsData;
Result.Message := fMessage;
Result.ObjectDictionary := fObjectDict;
Result.StatusCode := fStatusCode;
@ -4681,18 +4697,20 @@ end;
constructor TMVCResponseBuilder.Create;
begin
inherited;
fOwnsData := True;
fBuilt := False;
fStatusCode := HTTP_STATUS.OK;
fHeaders := nil;
end;
function TMVCResponseBuilder.Body(const Data: TObject): IMVCResponseBuilder;
function TMVCResponseBuilder.Body(const Data: TObject; const Owns: Boolean): IMVCResponseBuilder;
begin
if fData <> nil then
begin
raise EMVCResponseBuilderException.Create('Body already contains a "Data" node - To add two or more "Data" nodes use "ObjectDict"');
end;
fData := Data;
fOwnsData := Owns;
Result := Self;
end;

2
sources/dmvcframeworkbuildconsts.inc
View File

@ -1,2 +1,2 @@
const
DMVCFRAMEWORK_VERSION = '3.4.0-neon';
DMVCFRAMEWORK_VERSION = '3.4.1-sodium-beta';

11
tasks.py
View File

@ -79,7 +79,6 @@ def build_delphi_project(
+ project_filename
+ '"'
)
#print("\n" + "".join(cmdline))
r = ctx.run(cmdline, hide=True, warn=True)
if r.failed:
print(r.stdout)
@ -325,9 +324,12 @@ def tests32(ctx, delphi_version=DEFAULT_DELPHI_VERSION):
print("\nExecuting tests...")
subprocess.Popen([r"unittests\general\TestServer\bin\TestServer.exe"], shell=True)
r = None
try:
r = subprocess.run([r"unittests\general\Several\bin32\DMVCFrameworkTests.exe"])
if r.returncode != 0:
return Exit("Compilation failed: \n" + str(r.stdout))
return Exit("Cannot run unit test client: \n" + str(r.stdout))
finally:
subprocess.run(["taskkill", "/f", "/im", "TestServer.exe"])
if r.returncode > 0:
print(r)
@ -357,9 +359,12 @@ def tests64(ctx, delphi_version=DEFAULT_DELPHI_VERSION):
print("\nExecuting tests...")
subprocess.Popen([r"unittests\general\TestServer\bin\TestServer.exe"], shell=True)
r = None
try:
r = subprocess.run([r"unittests\general\Several\bin64\DMVCFrameworkTests.exe"])
if r.returncode != 0:
return Exit("Compilation failed: \n" + str(r.stdout))
return Exit("Cannot run unit test client: \n" + str(r.stdout))
finally:
subprocess.run(["taskkill", "/f", "/im", "TestServer.exe"])
if r.returncode > 0:
print(r)

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

@ -2941,14 +2941,11 @@ var
begin
lRes := RESTClient.Accept(TMVCMediaType.TEXT_PLAIN).Get('/website/list');
Assert.areEqual(HTTP_STATUS.OK, lRes.StatusCode, lRes.Content);
var
lLines := lRes.Content.Split([sLineBreak]);
var
lCount: Integer := 1001;
var lLines := lRes.Content.Split([sLineBreak]);
var lCount: Integer := 1001;
for var lLine in lLines do
begin
var
lLinePieces := lLine.Split(['|']);
var lLinePieces := lLine.Split(['|']);
if Length(lLinePieces) = 1 then
begin
lCount := 1001;

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

@ -69,7 +69,7 @@ uses
{$ENDIF}
MVCFramework.Middleware.Compression,
MVCFramework.Middleware.StaticFiles, FireDAC.Comp.Client,
MVCFramework.ActiveRecord, FDConnectionConfigU;
MVCFramework.ActiveRecord, FDConnectionConfigU, System.IOUtils;
procedure TMainWebModule.WebModuleCreate(Sender: TObject);
begin
@ -79,7 +79,7 @@ begin
// no config here
Config[TMVCConfigKey.SessionTimeout] := '0'; // setting cookie
Config[TMVCConfigKey.PathPrefix] := '';
Config[TMVCConfigKey.ViewPath] := '..\templates';
Config[TMVCConfigKey.ViewPath] := TPath.Combine(AppPath, '..\templates');
Config[TMVCConfigKey.DefaultViewFileExtension] := 'html';
end, nil);
MVCEngine