From 0f3545295467c2519767c533d4f2559be3624570 Mon Sep 17 00:00:00 2001 From: Daniele Teti Date: Fri, 22 Sep 2023 09:43:35 +0200 Subject: [PATCH] https://github.com/danieleteti/delphimvcframework/issues/694 --- 7ziplistfile.txt | 3 +- .../MVCFramework.ActiveRecordController.pas | 17 ++- .../MVCFramework.View.Renderers.Mustache.pas | 92 +++++++++++----- sources/MVCFramework.pas | 102 ++++++++++-------- sources/dmvcframeworkbuildconsts.inc | 2 +- tasks.py | 23 ++-- unittests/general/Several/LiveServerTestU.pas | 9 +- .../general/TestServer/WebModuleUnit.pas | 4 +- 8 files changed, 159 insertions(+), 93 deletions(-) diff --git a/7ziplistfile.txt b/7ziplistfile.txt index ed2a5c27..022c83e3 100644 --- a/7ziplistfile.txt +++ b/7ziplistfile.txt @@ -10,4 +10,5 @@ .\samples\**\*.jpg .\samples\**\*.js .\samples\**\*.css -.\samples\**\myproj* \ No newline at end of file +.\samples\**\myproj* +.\samples\**\*.htmx \ No newline at end of file diff --git a/sources/MVCFramework.ActiveRecordController.pas b/sources/MVCFramework.ActiveRecordController.pas index 851e437c..925f2e3e 100644 --- a/sources/MVCFramework.ActiveRecordController.pas +++ b/sources/MVCFramework.ActiveRecordController.pas @@ -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 diff --git a/sources/MVCFramework.View.Renderers.Mustache.pas b/sources/MVCFramework.View.Renderers.Mustache.pas index 12b8743a..15392c30 100644 --- a/sources/MVCFramework.View.Renderers.Mustache.pas +++ b/sources/MVCFramework.View.Renderers.Mustache.pas @@ -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; + 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; + 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; + 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; diff --git a/sources/MVCFramework.pas b/sources/MVCFramework.pas index a69ac43c..736b2999 100644 --- a/sources/MVCFramework.pas +++ b/sources/MVCFramework.pas @@ -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); /// /// 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(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 = 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 - fData.Free; + 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; diff --git a/sources/dmvcframeworkbuildconsts.inc b/sources/dmvcframeworkbuildconsts.inc index a79db124..44767c86 100644 --- a/sources/dmvcframeworkbuildconsts.inc +++ b/sources/dmvcframeworkbuildconsts.inc @@ -1,2 +1,2 @@ const - DMVCFRAMEWORK_VERSION = '3.4.0-neon'; \ No newline at end of file + DMVCFRAMEWORK_VERSION = '3.4.1-sodium-beta'; \ No newline at end of file diff --git a/tasks.py b/tasks.py index 2d385385..4aaccf18 100644 --- a/tasks.py +++ b/tasks.py @@ -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,10 +324,13 @@ def tests32(ctx, delphi_version=DEFAULT_DELPHI_VERSION): print("\nExecuting tests...") subprocess.Popen([r"unittests\general\TestServer\bin\TestServer.exe"], shell=True) - r = subprocess.run([r"unittests\general\Several\bin32\DMVCFrameworkTests.exe"]) - if r.returncode != 0: - return Exit("Compilation failed: \n" + str(r.stdout)) - subprocess.run(["taskkill", "/f", "/im", "TestServer.exe"]) + r = None + try: + r = subprocess.run([r"unittests\general\Several\bin32\DMVCFrameworkTests.exe"]) + if r.returncode != 0: + 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) print("Unit Tests Failed") @@ -357,10 +359,13 @@ def tests64(ctx, delphi_version=DEFAULT_DELPHI_VERSION): print("\nExecuting tests...") subprocess.Popen([r"unittests\general\TestServer\bin\TestServer.exe"], shell=True) - r = subprocess.run([r"unittests\general\Several\bin64\DMVCFrameworkTests.exe"]) - if r.returncode != 0: - return Exit("Compilation failed: \n" + str(r.stdout)) - subprocess.run(["taskkill", "/f", "/im", "TestServer.exe"]) + r = None + try: + r = subprocess.run([r"unittests\general\Several\bin64\DMVCFrameworkTests.exe"]) + if r.returncode != 0: + 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) print("Unit Tests Failed") diff --git a/unittests/general/Several/LiveServerTestU.pas b/unittests/general/Several/LiveServerTestU.pas index 6f228947..0e487ff0 100644 --- a/unittests/general/Several/LiveServerTestU.pas +++ b/unittests/general/Several/LiveServerTestU.pas @@ -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; diff --git a/unittests/general/TestServer/WebModuleUnit.pas b/unittests/general/TestServer/WebModuleUnit.pas index 86c9da51..04d1f3da 100644 --- a/unittests/general/TestServer/WebModuleUnit.pas +++ b/unittests/general/TestServer/WebModuleUnit.pas @@ -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