From b146c17cecb59397a5efe8c29510534861293025 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=A9gys=20Borges=20da=20Silveira?= Date: Tue, 13 Oct 2026 21:45:09 -0300 Subject: [PATCH 1/5] fix(router): propagate exceptions through middleware before core fallback --- src/Horse.Core.Router.Radix.pas | 60 +++--- src/Horse.Core.RouterTree.NextCaller.pas | 95 ++-------- src/Horse.Core.RouterTree.pas | 40 ++-- .../tests/Tests.Horse.Core.Router.Radix.pas | 178 +++++++++++++++++- .../src/tests/Tests.Horse.Core.RouterTree.pas | 178 +++++++++++++++++- 5 files changed, 419 insertions(+), 132 deletions(-) diff --git a/src/Horse.Core.Router.Radix.pas b/src/Horse.Core.Router.Radix.pas index 2d2510bd..37bd138a 100644 --- a/src/Horse.Core.Router.Radix.pas +++ b/src/Horse.Core.Router.Radix.pas @@ -203,8 +203,17 @@ function TRadixExecutor.Run: Boolean; except on E: Exception do begin - Result := False; - raise; + // The middleware chain has unwound; only unhandled errors reach this fallback. + if E is EHorseCallbackInterrupted then + raise + else if E is EHorseException then + FResponse.ContentType('application/json; charset=UTF-8') + .Send(EHorseException(E).ToJSON).Status(EHorseException(E).Status) + else if THorse.HasOnError then + THorse.ExecuteOnError(FRequest, FResponse, E) + else if FResponse.Status < Integer(THTTPStatus.BadRequest) then + FResponse.Send('Internal Application Error: ' + E.Message).Status(THTTPStatus.InternalServerError); + Result := True; end; end; finally @@ -380,21 +389,7 @@ procedure TRadixFlow.Next; on E: Exception do begin FActive := False; - if E is EHorseCallbackInterrupted then - raise; - if E is EHorseException then - begin - FResponse.ContentType('application/json; charset=UTF-8').Send(EHorseException(E).ToJSON).Status(EHorseException(E).Status); - Exit; - end; - if THorse.HasOnError then - begin - THorse.ExecuteOnError(FRequest, FResponse, E); - Exit; - end; - if FResponse.Status < Integer(THTTPStatus.BadRequest) then - FResponse.Send('Internal Application Error: ' + E.Message).Status(THTTPStatus.InternalServerError); - Exit; + raise; end; end; end; @@ -979,31 +974,26 @@ function THorseRadixRouter.Execute(const ARequest: THorseRequest; const ARespons end); end); Result := LResult; - AResponse.FlushCookiesToWebResponse; except on E: Exception do begin - if THorse.HasOnError then + // The middleware chain has unwound; only unhandled errors reach this fallback. + if E is EHorseCallbackInterrupted then begin - if E is EHorseCallbackInterrupted then - begin - Result := True; - end - else - begin - THorse.ExecuteOnError(ARequest, AResponse, E); - Result := True; - end; + if not THorse.HasOnError then + raise; end - else - begin - {$IF DEFINED(FPC)} - Writeln('CRITICAL RADIX ERROR: ', E.ClassName, ': ', E.Message); Flush(Output); - {$ENDIF} - raise; - end; + else if E is EHorseException then + AResponse.ContentType('application/json; charset=UTF-8') + .Send(EHorseException(E).ToJSON).Status(EHorseException(E).Status) + else if THorse.HasOnError then + THorse.ExecuteOnError(ARequest, AResponse, E) + else if AResponse.Status < Integer(THTTPStatus.BadRequest) then + AResponse.Send('Internal Application Error: ' + E.Message).Status(THTTPStatus.InternalServerError); + Result := True; end; end; + AResponse.FlushCookiesToWebResponse; finally LStopwatch.Stop; THorseCore.ExecuteOnTelemetry(ARequest, AResponse, LStopwatch.Elapsed.TotalMilliseconds); diff --git a/src/Horse.Core.RouterTree.NextCaller.pas b/src/Horse.Core.RouterTree.NextCaller.pas index fe484cba..4dfbc67e 100644 --- a/src/Horse.Core.RouterTree.NextCaller.pas +++ b/src/Horse.Core.RouterTree.NextCaller.pas @@ -96,31 +96,10 @@ procedure NextCallerDoPreValidation; LNextCaller: TNextCaller; begin LNextCaller := TNextCaller(GCurrentNextCaller); - try - LNextCaller.FFound^ := True; - if LNextCaller.FCallBack.TryGetValue(LNextCaller.FHTTPType, LCallback) then - begin - THorseCallbackProc(LCallback.Items[LNextCaller.FIndexCallback])(LNextCaller.FRequest, LNextCaller.FResponse, LNextCaller.Next); - end; - except - on E: Exception do - begin - if E is EHorseCallbackInterrupted then - raise; - if E is EHorseException then - begin - LNextCaller.FResponse.ContentType('application/json; charset=UTF-8').Send(EHorseException(E).ToJSON).Status(EHorseException(E).Status); - Exit; - end; - if THorse.HasOnError then - begin - THorse.ExecuteOnError(LNextCaller.FRequest, LNextCaller.FResponse, E); - Exit; - end; - if LNextCaller.FResponse.Status < Integer(THTTPStatus.BadRequest) then - LNextCaller.FResponse.Send('Internal Application Error: ' + E.Message).Status(THTTPStatus.InternalServerError); - Exit; - end; + LNextCaller.FFound^ := True; + if LNextCaller.FCallBack.TryGetValue(LNextCaller.FHTTPType, LCallback) then + begin + THorseCallbackProc(LCallback.Items[LNextCaller.FIndexCallback])(LNextCaller.FRequest, LNextCaller.FResponse, LNextCaller.Next); end; LNextCaller.Next; end; @@ -242,66 +221,24 @@ procedure TNextCaller.Next; THorse.ExecutePreValidation(FRequest, FResponse, procedure begin - try - FFound^ := True; - {$IF DEFINED(FPC)} - THorseCallbackProc(LCallback.Items[FIndexCallback])(FRequest, FResponse, Next); - {$ELSE} - LCallback[FIndexCallback](FRequest, FResponse, Next); - {$ENDIF} - except - on E: Exception do - begin - if E is EHorseCallbackInterrupted then - raise; - if E is EHorseException then - begin - FResponse.ContentType('application/json; charset=UTF-8').Send(EHorseException(E).ToJSON).Status(EHorseException(E).Status); - Exit; - end; - if THorse.HasOnError then - begin - THorse.ExecuteOnError(FRequest, FResponse, E); - Exit; - end; - if FResponse.Status < Integer(THTTPStatus.BadRequest) then - FResponse.Send('Internal Application Error: ' + E.Message).Status(THTTPStatus.InternalServerError); - Exit; - end; - end; + FFound^ := True; + {$IF DEFINED(FPC)} + THorseCallbackProc(LCallback.Items[FIndexCallback])(FRequest, FResponse, Next); + {$ELSE} + LCallback[FIndexCallback](FRequest, FResponse, Next); + {$ENDIF} Next; end); {$ENDIF} end else begin - try - FFound^ := True; - {$IF DEFINED(FPC)} - THorseCallbackProc(LCallback.Items[FIndexCallback])(FRequest, FResponse, Next); - {$ELSE} - LCallback[FIndexCallback](FRequest, FResponse, Next); - {$ENDIF} - except - on E: Exception do - begin - if E is EHorseCallbackInterrupted then - raise; - if E is EHorseException then - begin - FResponse.ContentType('application/json; charset=UTF-8').Send(EHorseException(E).ToJSON).Status(EHorseException(E).Status); - Exit; - end; - if THorse.HasOnError then - begin - THorse.ExecuteOnError(FRequest, FResponse, E); - Exit; - end; - if FResponse.Status < Integer(THTTPStatus.BadRequest) then - FResponse.Send('Internal Application Error: ' + E.Message).Status(THTTPStatus.InternalServerError); - Exit; - end; - end; + FFound^ := True; + {$IF DEFINED(FPC)} + THorseCallbackProc(LCallback.Items[FIndexCallback])(FRequest, FResponse, Next); + {$ELSE} + LCallback[FIndexCallback](FRequest, FResponse, Next); + {$ENDIF} Next; end; end; diff --git a/src/Horse.Core.RouterTree.pas b/src/Horse.Core.RouterTree.pas index 6d54d14c..04a3caaa 100644 --- a/src/Horse.Core.RouterTree.pas +++ b/src/Horse.Core.RouterTree.pas @@ -93,6 +93,7 @@ implementation System.SyncObjs, System.Diagnostics, {$ENDIF} + Horse.Exception, Horse.Core.RouterTree.NextCaller, Horse, Horse.Core; @@ -177,8 +178,17 @@ function TRouterTreeExecutor.Run: Boolean; except on E: Exception do begin - Result := False; - raise; + // The middleware chain has unwound; only unhandled errors reach this fallback. + if E is EHorseCallbackInterrupted then + raise + else if E is EHorseException then + FResponse.ContentType('application/json; charset=UTF-8') + .Send(EHorseException(E).ToJSON).Status(EHorseException(E).Status) + else if THorse.HasOnError then + THorse.ExecuteOnError(FRequest, FResponse, E) + else if FResponse.Status < Integer(THTTPStatus.BadRequest) then + FResponse.Send('Internal Application Error: ' + E.Message).Status(THTTPStatus.InternalServerError); + Result := True; end; end; finally @@ -440,22 +450,20 @@ function THorseRouterTree.Execute(const ARequest: THorseRequest; const AResponse except on E: Exception do begin - if THorse.HasOnError then + // The middleware chain has unwound; only unhandled errors reach this fallback. + if E is EHorseCallbackInterrupted then begin - if E is EHorseCallbackInterrupted then - begin - Result := True; - end - else - begin - THorse.ExecuteOnError(ARequest, AResponse, E); - Result := True; - end; + if not THorse.HasOnError then + raise; end - else - begin - raise; - end; + else if E is EHorseException then + AResponse.ContentType('application/json; charset=UTF-8') + .Send(EHorseException(E).ToJSON).Status(EHorseException(E).Status) + else if THorse.HasOnError then + THorse.ExecuteOnError(ARequest, AResponse, E) + else if AResponse.Status < Integer(THTTPStatus.BadRequest) then + AResponse.Send('Internal Application Error: ' + E.Message).Status(THTTPStatus.InternalServerError); + Result := True; end; end; AResponse.FlushCookiesToWebResponse; diff --git a/tests/src/tests/Tests.Horse.Core.Router.Radix.pas b/tests/src/tests/Tests.Horse.Core.Router.Radix.pas index 350584c7..5d92ae15 100644 --- a/tests/src/tests/Tests.Horse.Core.Router.Radix.pas +++ b/tests/src/tests/Tests.Horse.Core.Router.Radix.pas @@ -4,7 +4,7 @@ interface uses DUnitX.TestFramework, Horse.Core.Router.Radix, Horse.Request, Horse.Response, - System.SysUtils, System.Generics.Collections, + System.SysUtils, System.Generics.Collections, Horse, Horse.Exception, Horse.Exception.Interrupted, Horse.Provider.RawAdapters, Horse.Callback, Horse.Proc, {$IF DEFINED(FPC)} HTTPApp {$ELSE} Web.HTTPApp {$ENDIF}, Horse.Commons; type @@ -15,6 +15,27 @@ TTestHorseCoreRouterRadix = class FRequest: THorseRequest; FResponse: THorseResponse; public + [TestCase('GenericMiddleware', '0,1,0')] + [TestCase('HorseMiddleware', '1,1,0')] + [TestCase('GenericFallback', '0,0,0')] + [TestCase('HorseFallback', '1,0,0')] + [TestCase('GenericOnError', '0,2,0')] + [TestCase('HorseBeforeOnError', '1,2,0')] + [TestCase('GenericRethrow', '0,3,0')] + [TestCase('HorseRethrow', '1,3,0')] + [TestCase('GenericSecondCallback', '0,1,1')] + [TestCase('HorseSecondCallback', '1,1,1')] + [TestCase('GenericInnerMiddleware', '0,1,2')] + [TestCase('HorseInnerMiddleware', '1,1,2')] + [TestCase('MiddlewareBeforeOnError', '0,4,0')] + [TestCase('HorseMiddlewareBeforeOnError', '1,4,0')] + [TestCase('PreserveErrorResponse', '0,5,0')] + procedure ExceptionPropagation(const AKind, AMode, ASource: Integer); + [TestCase('WithoutOnError', '0')] + [TestCase('WithOnError', '1')] + procedure InterruptedIsNotAnError(const AHook: Integer); + [Test] + procedure FallbackFlushesCookies; [Setup] procedure Setup; [TearDown] @@ -56,6 +77,161 @@ TTestHorseCoreRouterRadix = class implementation +var + LOnError: Boolean; + +procedure PropagationOnError(const Req: THorseRequest; const Res: THorseResponse; const E: Exception); +begin + LOnError := True; + Res.Send('hook').Status(THTTPStatus.ServiceUnavailable); +end; + +procedure TTestHorseCoreRouterRadix.ExceptionPropagation(const AKind, AMode, ASource: Integer); +var + LCaught: Boolean; + LThrow: THorseCallback; +begin + LCaught := False; + LOnError := False; + THorse.OnError(nil); + try + if (AMode = 2) or (AMode = 4) then + THorse.OnError(PropagationOnError); + if (AMode = 1) or (AMode = 3) or (AMode = 4) then + FRouter.RegisterMiddleware( + procedure(Req: THorseRequest; Res: THorseResponse; Next: TNextProc) + begin + try + Next; + except + on E: Exception do + begin + LCaught := True; + if AMode = 3 then + raise; + Res.ContentType('application/json').Send('{"handled":true}').Status(THTTPStatus.UnprocessableEntity); + end; + end; + end); + LThrow := + procedure(Req: THorseRequest; Res: THorseResponse; Next: TNextProc) + begin + if AMode = 5 then + Res.Send('existing error').Status(THTTPStatus.Conflict); + if AKind = 1 then + raise EHorseException.New.Error('route error').Status(THTTPStatus.BadRequest); + raise Exception.Create('route error'); + end; + if ASource = 1 then + FRouter.RegisterRouteMiddleware(mtGet, '/error', + procedure(Req: THorseRequest; Res: THorseResponse; Next: TNextProc) + begin + Next; + end); + if ASource = 2 then + FRouter.RegisterMiddleware(LThrow); + FRouter.RegisterRoute(mtGet, '/error', LThrow); + FRequest.Populate('GET', mtGet, '/error', '', ''); + Assert.IsTrue(FRouter.Execute(FRequest, FResponse)); + Assert.AreEqual((AMode = 1) or (AMode = 3) or (AMode = 4), LCaught, 'Middleware must see the exception'); + Assert.AreEqual((AMode = 2) and (AKind = 0), LOnError, 'OnError fallback precedence'); + if (AMode = 1) or (AMode = 4) then + begin + Assert.AreEqual(422, FResponse.Status); + Assert.AreEqual('{"handled":true}', FResponse.BodyText); + Assert.AreEqual('application/json', FResponse.CSContentType); + end + else if AMode = 5 then + begin + Assert.AreEqual(409, FResponse.Status); + Assert.AreEqual('existing error', FResponse.BodyText); + end + else if AKind = 1 then + begin + Assert.AreEqual(400, FResponse.Status); + Assert.AreEqual('{"error":"route error"}', FResponse.BodyText); + Assert.AreEqual('application/json; charset=UTF-8', FResponse.CSContentType); + end + else if AMode = 2 then + begin + Assert.AreEqual(503, FResponse.Status); + Assert.AreEqual('hook', FResponse.BodyText); + end + else + begin + Assert.AreEqual(500, FResponse.Status); + Assert.AreEqual('Internal Application Error: route error', FResponse.BodyText); + end; + finally + THorse.OnError(nil); + end; +end; + + +procedure TTestHorseCoreRouterRadix.InterruptedIsNotAnError(const AHook: Integer); +var + LInterrupted, LContinued: Boolean; +begin + LOnError := False; + LInterrupted := False; + LContinued := False; + THorse.OnError(nil); + try + if AHook = 1 then + THorse.OnError(PropagationOnError); + FRouter.RegisterRouteMiddleware(mtGet, '/interrupt', + procedure(Req: THorseRequest; Res: THorseResponse; Next: TNextProc) + begin + Res.Send('stopped').Status(THTTPStatus.Accepted); + raise EHorseCallbackInterrupted.Create; + end); + FRouter.RegisterRoute(mtGet, '/interrupt', + procedure(Req: THorseRequest; Res: THorseResponse; Next: TNextProc) + begin + LContinued := True; + end); + FRequest.Populate('GET', mtGet, '/interrupt', '', ''); + try + Assert.IsTrue(FRouter.Execute(FRequest, FResponse)); + except + on EHorseCallbackInterrupted do + LInterrupted := True; + end; + Assert.AreEqual(AHook = 0, LInterrupted); + Assert.IsFalse(LOnError); + Assert.IsFalse(LContinued); + Assert.AreEqual(202, FResponse.Status); + Assert.AreEqual('stopped', FResponse.BodyText); + finally + THorse.OnError(nil); + end; +end; + +procedure TTestHorseCoreRouterRadix.FallbackFlushesCookies; +var + LRaw: TWebResponse; +begin + LRaw := TInterfacedWebResponse.Create(nil); + try + FreeAndNil(FResponse); + FResponse := THorseResponse.Create(LRaw); + FRouter.RegisterRoute(mtGet, '/cookie-error', + procedure(Req: THorseRequest; Res: THorseResponse; Next: TNextProc) + begin + Res.Cookie('error-cookie', 'retained'); + raise Exception.Create('cookie error'); + end); + FRequest.Populate('GET', mtGet, '/cookie-error', '', ''); + Assert.IsTrue(FRouter.Execute(FRequest, FResponse)); + Assert.AreEqual('Internal Application Error: cookie error', string(LRaw.Content)); + Assert.AreEqual(1, LRaw.Cookies.Count); + Assert.AreEqual('retained', string(LRaw.Cookies[0].Value)); + finally + FreeAndNil(FResponse); + LRaw.Free; + end; +end; + { TTestHorseCoreRouterRadix } {$IF SizeOf(Char) > 1} diff --git a/tests/src/tests/Tests.Horse.Core.RouterTree.pas b/tests/src/tests/Tests.Horse.Core.RouterTree.pas index 6837a5a2..00de7795 100644 --- a/tests/src/tests/Tests.Horse.Core.RouterTree.pas +++ b/tests/src/tests/Tests.Horse.Core.RouterTree.pas @@ -4,7 +4,7 @@ interface uses DUnitX.TestFramework, Horse.Core.RouterTree, Horse.Request, Horse.Response, - System.SysUtils, System.Generics.Collections, + System.SysUtils, System.Generics.Collections, Horse, Horse.Exception, Horse.Exception.Interrupted, Horse.Provider.RawAdapters, Horse.Callback, Horse.Proc, {$IF DEFINED(FPC)} HTTPApp {$ELSE} Web.HTTPApp {$ENDIF}, Horse.Commons, Horse.Core; type @@ -15,6 +15,27 @@ TTestHorseCoreRouterTree = class FRequest: THorseRequest; FResponse: THorseResponse; public + [TestCase('GenericMiddleware', '0,1,0')] + [TestCase('HorseMiddleware', '1,1,0')] + [TestCase('GenericFallback', '0,0,0')] + [TestCase('HorseFallback', '1,0,0')] + [TestCase('GenericOnError', '0,2,0')] + [TestCase('HorseBeforeOnError', '1,2,0')] + [TestCase('GenericRethrow', '0,3,0')] + [TestCase('HorseRethrow', '1,3,0')] + [TestCase('GenericSecondCallback', '0,1,1')] + [TestCase('HorseSecondCallback', '1,1,1')] + [TestCase('GenericInnerMiddleware', '0,1,2')] + [TestCase('HorseInnerMiddleware', '1,1,2')] + [TestCase('MiddlewareBeforeOnError', '0,4,0')] + [TestCase('HorseMiddlewareBeforeOnError', '1,4,0')] + [TestCase('PreserveErrorResponse', '0,5,0')] + procedure ExceptionPropagation(const AKind, AMode, ASource: Integer); + [TestCase('WithoutOnError', '0')] + [TestCase('WithOnError', '1')] + procedure InterruptedIsNotAnError(const AHook: Integer); + [Test] + procedure FallbackFlushesCookies; [Setup] procedure Setup; [TearDown] @@ -76,6 +97,161 @@ TTestHorseCoreRouterTree = class implementation +var + LOnError: Boolean; + +procedure PropagationOnError(const Req: THorseRequest; const Res: THorseResponse; const E: Exception); +begin + LOnError := True; + Res.Send('hook').Status(THTTPStatus.ServiceUnavailable); +end; + +procedure TTestHorseCoreRouterTree.ExceptionPropagation(const AKind, AMode, ASource: Integer); +var + LCaught: Boolean; + LThrow: THorseCallback; +begin + LCaught := False; + LOnError := False; + THorse.OnError(nil); + try + if (AMode = 2) or (AMode = 4) then + THorse.OnError(PropagationOnError); + if (AMode = 1) or (AMode = 3) or (AMode = 4) then + FRouterTree.RegisterMiddleware( + procedure(Req: THorseRequest; Res: THorseResponse; Next: TNextProc) + begin + try + Next; + except + on E: Exception do + begin + LCaught := True; + if AMode = 3 then + raise; + Res.ContentType('application/json').Send('{"handled":true}').Status(THTTPStatus.UnprocessableEntity); + end; + end; + end); + LThrow := + procedure(Req: THorseRequest; Res: THorseResponse; Next: TNextProc) + begin + if AMode = 5 then + Res.Send('existing error').Status(THTTPStatus.Conflict); + if AKind = 1 then + raise EHorseException.New.Error('route error').Status(THTTPStatus.BadRequest); + raise Exception.Create('route error'); + end; + if ASource = 1 then + FRouterTree.RegisterRouteMiddleware(mtGet, '/error', + procedure(Req: THorseRequest; Res: THorseResponse; Next: TNextProc) + begin + Next; + end); + if ASource = 2 then + FRouterTree.RegisterMiddleware(LThrow); + FRouterTree.RegisterRoute(mtGet, '/error', LThrow); + FRequest.Populate('GET', mtGet, '/error', '', ''); + Assert.IsTrue(FRouterTree.Execute(FRequest, FResponse)); + Assert.AreEqual((AMode = 1) or (AMode = 3) or (AMode = 4), LCaught, 'Middleware must see the exception'); + Assert.AreEqual((AMode = 2) and (AKind = 0), LOnError, 'OnError fallback precedence'); + if (AMode = 1) or (AMode = 4) then + begin + Assert.AreEqual(422, FResponse.Status); + Assert.AreEqual('{"handled":true}', FResponse.BodyText); + Assert.AreEqual('application/json', FResponse.CSContentType); + end + else if AMode = 5 then + begin + Assert.AreEqual(409, FResponse.Status); + Assert.AreEqual('existing error', FResponse.BodyText); + end + else if AKind = 1 then + begin + Assert.AreEqual(400, FResponse.Status); + Assert.AreEqual('{"error":"route error"}', FResponse.BodyText); + Assert.AreEqual('application/json; charset=UTF-8', FResponse.CSContentType); + end + else if AMode = 2 then + begin + Assert.AreEqual(503, FResponse.Status); + Assert.AreEqual('hook', FResponse.BodyText); + end + else + begin + Assert.AreEqual(500, FResponse.Status); + Assert.AreEqual('Internal Application Error: route error', FResponse.BodyText); + end; + finally + THorse.OnError(nil); + end; +end; + + +procedure TTestHorseCoreRouterTree.InterruptedIsNotAnError(const AHook: Integer); +var + LInterrupted, LContinued: Boolean; +begin + LOnError := False; + LInterrupted := False; + LContinued := False; + THorse.OnError(nil); + try + if AHook = 1 then + THorse.OnError(PropagationOnError); + FRouterTree.RegisterRouteMiddleware(mtGet, '/interrupt', + procedure(Req: THorseRequest; Res: THorseResponse; Next: TNextProc) + begin + Res.Send('stopped').Status(THTTPStatus.Accepted); + raise EHorseCallbackInterrupted.Create; + end); + FRouterTree.RegisterRoute(mtGet, '/interrupt', + procedure(Req: THorseRequest; Res: THorseResponse; Next: TNextProc) + begin + LContinued := True; + end); + FRequest.Populate('GET', mtGet, '/interrupt', '', ''); + try + Assert.IsTrue(FRouterTree.Execute(FRequest, FResponse)); + except + on EHorseCallbackInterrupted do + LInterrupted := True; + end; + Assert.AreEqual(AHook = 0, LInterrupted); + Assert.IsFalse(LOnError); + Assert.IsFalse(LContinued); + Assert.AreEqual(202, FResponse.Status); + Assert.AreEqual('stopped', FResponse.BodyText); + finally + THorse.OnError(nil); + end; +end; + +procedure TTestHorseCoreRouterTree.FallbackFlushesCookies; +var + LRaw: TWebResponse; +begin + LRaw := TInterfacedWebResponse.Create(nil); + try + FreeAndNil(FResponse); + FResponse := THorseResponse.Create(LRaw); + FRouterTree.RegisterRoute(mtGet, '/cookie-error', + procedure(Req: THorseRequest; Res: THorseResponse; Next: TNextProc) + begin + Res.Cookie('error-cookie', 'retained'); + raise Exception.Create('cookie error'); + end); + FRequest.Populate('GET', mtGet, '/cookie-error', '', ''); + Assert.IsTrue(FRouterTree.Execute(FRequest, FResponse)); + Assert.AreEqual('Internal Application Error: cookie error', string(LRaw.Content)); + Assert.AreEqual(1, LRaw.Cookies.Count); + Assert.AreEqual('retained', string(LRaw.Cookies[0].Value)); + finally + FreeAndNil(FResponse); + LRaw.Free; + end; +end; + { TTestHorseCoreRouterTree } {$IF SizeOf(Char) > 1} From 58ba8ea750bd8d1c8d7632e2834486b42e2ba7d6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=A9gys=20Borges=20da=20Silveira?= Date: Tue, 13 Oct 2026 21:54:13 -0300 Subject: [PATCH 2/5] test(fpc): cover middleware exception propagation and core fallback --- .../ExceptionPropagationCheck.dpr | 207 ++++++++++++++++++ tests/fpc-exception-propagation/README.md | 29 +++ .../run-exception-propagation-test.sh | 25 +++ 3 files changed, 261 insertions(+) create mode 100644 tests/fpc-exception-propagation/ExceptionPropagationCheck.dpr create mode 100644 tests/fpc-exception-propagation/README.md create mode 100644 tests/fpc-exception-propagation/run-exception-propagation-test.sh diff --git a/tests/fpc-exception-propagation/ExceptionPropagationCheck.dpr b/tests/fpc-exception-propagation/ExceptionPropagationCheck.dpr new file mode 100644 index 00000000..c20fca48 --- /dev/null +++ b/tests/fpc-exception-propagation/ExceptionPropagationCheck.dpr @@ -0,0 +1,207 @@ +program ExceptionPropagationCheck; + +{$MODE DELPHI}{$H+} + +uses + cthreads, SysUtils, fpjson, jsonparser, + Horse, Horse.Core.Router.Contract, Horse.Core.RouterTree, + Horse.Core.Router.Radix, Horse.Callback, Horse.Commons, + Horse.Exception, Horse.Exception.Interrupted, Horse.Proc, + Horse.Request, Horse.Response; + +var + Kind, Mode: Integer; + Caught, HookCalled, Continued: Boolean; + Total, Failures: Integer; + +procedure Check(Condition: Boolean; const MessageText: string); +begin + if not Condition then + raise Exception.Create(MessageText); +end; + +procedure ErrorHook(const Req: THorseRequest; const Res: THorseResponse; + const E: Exception); +begin + HookCalled := True; + Res.Send('hook').Status(THTTPStatus.ServiceUnavailable); +end; + +procedure CatchError(Req: THorseRequest; Res: THorseResponse; Next: TNextProc); +begin + try + Next; + except + on E: Exception do + begin + Caught := True; + if Mode = 3 then + raise; + Res.ContentType('application/json').Send('{"handled":true}') + .Status(THTTPStatus.UnprocessableEntity); + end; + end; +end; + +procedure PassThrough(Req: THorseRequest; Res: THorseResponse; Next: TNextProc); +begin + Next; +end; + +procedure ThrowError(Req: THorseRequest; Res: THorseResponse; Next: TNextProc); +begin + if Mode = 5 then + Res.Send('existing error').Status(THTTPStatus.Conflict); + if Kind = 1 then + raise EHorseException.New.Error('route error').Status(THTTPStatus.BadRequest); + raise Exception.Create('route error'); +end; + +procedure Interrupt(Req: THorseRequest; Res: THorseResponse; Next: TNextProc); +begin + Res.Send('stopped').Status(THTTPStatus.Accepted); + raise EHorseCallbackInterrupted.Create; +end; + +procedure MustNotContinue(Req: THorseRequest; Res: THorseResponse; Next: TNextProc); +begin + Continued := True; +end; + +procedure RunCase(UseRadix: Boolean; AKind, AMode, Source: Integer); +var + Router: IHorseRouter; + Req: THorseRequest; + Res: THorseResponse; + Interrupted: Boolean; + LabelText: string; + ErrorJSON: TJSONData; +begin + Inc(Total); + if UseRadix then + LabelText := 'Radix' + else + LabelText := 'Tree'; + LabelText := Format('%s kind=%d mode=%d source=%d', + [LabelText, AKind, AMode, Source]); + Kind := AKind; + Mode := AMode; + Caught := False; + HookCalled := False; + Continued := False; + THorse.OnError(nil); + if UseRadix then + Router := THorseRadixRouter.Create + else + Router := THorseRouterTree.Create; + Req := THorseRequest.Create(nil); + Res := THorseResponse.Create(nil); + try + try + if Mode in [2, 4, 7] then + THorse.OnError(@ErrorHook); + if Mode in [1, 3, 4] then + Router.RegisterMiddleware(Pointer(@CatchError)); + if Source = 1 then + Router.RegisterRouteMiddleware(mtGet, '/error', Pointer(@PassThrough)); + if Source = 2 then + Router.RegisterMiddleware(Pointer(@ThrowError)); + if Mode in [6, 7] then + begin + Router.RegisterRouteMiddleware(mtGet, '/error', Pointer(@Interrupt)); + Router.RegisterRoute(mtGet, '/error', Pointer(@MustNotContinue)); + end + else + Router.RegisterRoute(mtGet, '/error', Pointer(@ThrowError)); + Req.Populate('GET', mtGet, '/error', '', ''); + Interrupted := False; + try + Check(Router.Execute(Req, Res), 'Execute must report a handled request'); + except + on EHorseCallbackInterrupted do + Interrupted := True; + end; + if Mode in [6, 7] then + begin + Check(Interrupted, 'FPC must propagate callback interruption'); + Check(not HookCalled, 'Interruption must not invoke OnError'); + Check(not Continued, 'Interruption must stop subsequent callbacks'); + Check(Res.Status = 202, 'Interruption must preserve status'); + Check(Res.BodyText = 'stopped', 'Interruption must preserve body'); + end + else + begin + Check(not Interrupted, 'Unexpected interruption'); + Check(Caught = (Mode in [1, 3, 4]), 'Middleware must see the exception'); + Check(HookCalled = ((Mode = 2) and (Kind = 0)), 'OnError fallback precedence'); + if Mode in [1, 4] then + begin + Check(Res.Status = 422, 'Middleware response status'); + Check(Res.BodyText = '{"handled":true}', 'Middleware response body'); + Check(Res.CSContentType = 'application/json', 'Middleware content type'); + end + else if Mode = 5 then + begin + Check(Res.Status = 409, 'Existing error status'); + Check(Res.BodyText = 'existing error', 'Existing error body'); + end + else if Kind = 1 then + begin + Check(Res.Status = 400, 'Horse exception status'); + ErrorJSON := GetJSON(Res.BodyText); + try + Check(ErrorJSON.FindPath('error') <> nil, 'Horse exception JSON error field'); + Check(ErrorJSON.FindPath('error').AsString = 'route error', 'Horse exception JSON message'); + finally + ErrorJSON.Free; + end; + Check(Res.CSContentType = 'application/json; charset=UTF-8', 'JSON content type'); + end + else if Mode = 2 then + begin + Check(Res.Status = 503, 'OnError response status'); + Check(Res.BodyText = 'hook', 'OnError response body'); + end + else + begin + Check(Res.Status = 500, 'Default fallback status'); + Check(Res.BodyText = 'Internal Application Error: route error', 'Default fallback body'); + end; + end; + Writeln('PASS ', LabelText); + except + on E: Exception do + begin + Inc(Failures); + Writeln('FAIL ', LabelText, ': ', E.ClassName, ': ', E.Message); + end; + end; + finally + THorse.OnError(nil); + Res.Free; + Req.Free; + Router := nil; + end; +end; + +var + Radix: Boolean; + K, M: Integer; +begin + for Radix := False to True do + begin + for K := 0 to 1 do + begin + for M := 0 to 4 do + RunCase(Radix, K, M, 0); + RunCase(Radix, K, 1, 1); + RunCase(Radix, K, 1, 2); + end; + RunCase(Radix, 0, 5, 0); + RunCase(Radix, 0, 6, 0); + RunCase(Radix, 0, 7, 0); + end; + Writeln('Total: ', Total, '; passed: ', Total - Failures, '; failed: ', Failures); + if Failures <> 0 then + Halt(1); +end. diff --git a/tests/fpc-exception-propagation/README.md b/tests/fpc-exception-propagation/README.md new file mode 100644 index 00000000..cfcb2682 --- /dev/null +++ b/tests/fpc-exception-propagation/README.md @@ -0,0 +1,29 @@ +# Regressão de propagação de exceções no FPC + +Execute na raiz do repositório, em Linux com FPC e as units FCL instaladas: + +```sh +sh tests/fpc-exception-propagation/run-exception-propagation-test.sh +sh tests/fpc-exception-propagation/run-exception-propagation-test.sh -dHORSE_PROVIDER_EPOLL +``` + +O teste compila todos os fontes com `-B`, usa um diretório temporário para os +binários e habilita `heaptrc` (`-gh`). Falhas nas verificações ou blocos de memória +não liberados produzem código de saída diferente de zero. + +São 34 casos, 17 para cada roteador (Tree e Radix), usando callbacks procedurais +compatíveis com FPC. Eles cobrem `Exception` e `EHorseException` capturadas pelo +middleware, callbacks posteriores, middleware interno, prioridade sobre `OnError`, +fallback sem middleware e após relançamento, status de erro existente e interrupção +da cadeia com e sem `OnError`. A resposta JSON é verificada por parsing, incluindo +mensagem, status e `Content-Type`. + +Na saída, `kind=0` indica `Exception`, e `kind=1`, `EHorseException`. +`mode` identifica o cenário: 0 = fallback, 1 = middleware trata, 2 = `OnError`, +3 = middleware relança, 4 = middleware trata com `OnError` registrado, +5 = resposta de erro existente, 6 = interrupção e 7 = interrupção com `OnError`. +`source=0` indica a rota, 1 = callback posterior e 2 = middleware interno. + +O parâmetro opcional `HORSE_TEST_SOURCE` permite selecionar outro diretório de +fontes para reproduzir a falha anterior à correção. Esses testes exercitam os +roteadores diretamente; não abrem um servidor HTTP. diff --git a/tests/fpc-exception-propagation/run-exception-propagation-test.sh b/tests/fpc-exception-propagation/run-exception-propagation-test.sh new file mode 100644 index 00000000..bde3249d --- /dev/null +++ b/tests/fpc-exception-propagation/run-exception-propagation-test.sh @@ -0,0 +1,25 @@ +#!/bin/sh +set -eu + +test_dir=$(CDPATH= cd -- "$(dirname -- "$0")" && pwd) +output_dir=$(mktemp -d /tmp/horse-exception-propagation.XXXXXX) + +cd "$test_dir" +# Override only for validating this regression against an earlier source tree. +source_dir=${HORSE_TEST_SOURCE:-../../src} +fpc -B -Mdelphi -Sh -gh -gl \ + -Fu"$source_dir" -Fu../../src -FU"$output_dir" -FE"$output_dir" "$@" \ + ExceptionPropagationCheck.dpr + +set +e +run_output=$("$output_dir/ExceptionPropagationCheck" 2>&1) +run_status=$? +set -e +printf '%s\n' "$run_output" +if [ "$run_status" -ne 0 ]; then + exit "$run_status" +fi +if printf '%s\n' "$run_output" | grep -Eq '[1-9][0-9]* unfreed memory blocks'; then + echo 'Exception propagation regression: FPC reported unfreed memory.' >&2 + exit 1 +fi From c5fe786d3054537c775d193e61f2cd79cd6b1ef2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=A9gys=20Borges=20da=20Silveira?= Date: Tue, 13 Oct 2026 22:02:30 -0300 Subject: [PATCH 3/5] ci(fpc): run exception propagation regression for both routers --- .github/workflows/tests.yml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/.github/workflows/tests.yml b/.github/workflows/tests.yml index 24b3eef2..b785e0f0 100644 --- a/.github/workflows/tests.yml +++ b/.github/workflows/tests.yml @@ -18,6 +18,11 @@ jobs: sudo apt-get update sudo apt-get install -y fpc + - name: Run FPC exception propagation regression (Tree and Radix) + run: | + sh tests/fpc-exception-propagation/run-exception-propagation-test.sh + sh tests/fpc-exception-propagation/run-exception-propagation-test.sh -dHORSE_PROVIDER_EPOLL + - name: Run FPC WebSocket EAGAIN regression run: tests/fpc-websocket/run-ws-eagain-test.sh From c106eca21a96fbd9ba46c83eb2a6080eb5ca0e12 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=A9gys=20Borges=20da=20Silveira?= Date: Tue, 13 Oct 2026 22:06:34 -0300 Subject: [PATCH 4/5] ci(fpc): run portable regression suites instead of Delphi DUnitX --- .github/workflows/tests.yml | 26 +++++++------------------- 1 file changed, 7 insertions(+), 19 deletions(-) diff --git a/.github/workflows/tests.yml b/.github/workflows/tests.yml index b785e0f0..f5444abf 100644 --- a/.github/workflows/tests.yml +++ b/.github/workflows/tests.yml @@ -9,6 +9,7 @@ on: jobs: test: runs-on: ubuntu-latest + timeout-minutes: 15 steps: - uses: actions/checkout@v4 @@ -32,26 +33,13 @@ jobs: - name: Run FPC URL decoding regression run: sh tests/fpc-url-decoding/run-url-decoding-test.sh - - name: Install Boss Dependency Manager - run: | - curl -L https://github.com/hashload/boss/releases/latest/download/boss-linux -o boss - chmod +x boss - sudo mv boss /usr/local/bin/boss - - - name: Install Boss Dependencies - run: | - cd tests/src - boss install + # Console.dpr uses Delphi/DUnitX; validate it with run_delphi_tests.ps1. + # The Linux job runs the standalone FPC suites instead. + - name: Run FPC stream factory regression + run: sh tests/stream-factory/run-stream-factory.sh - - name: Compile Console Tests - run: | - cd tests/src - fpc -Mdelphi -Sh -O2 -FE.. -Fu"../../src:modules/github_com_hashload_jhonson/src:modules/github_com_viniciussanchez_restrequest4delphi/src:controllers:tests" "-dRR4D_INDY" "-dHORSE_CONSOLE" Console.dpr - - - name: Run Console Tests - run: | - cd tests - ./Console -exit:Continue + - name: Run FPC provider configuration regressions + run: bash tests/provider-config/run-provider-config.sh fpc-trunk-keepalive: runs-on: ubuntu-latest From 5ebd5c5b45dc521815bc4ef4e64331de3721c06f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=A9gys=20Borges=20da=20Silveira?= Date: Tue, 13 Oct 2026 22:09:12 -0300 Subject: [PATCH 5/5] chore(release): prepare Horse 3.3.14 --- boss.json | 2 +- src/Horse.Constants.pas | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/boss.json b/boss.json index a396d245..0157f7ab 100644 --- a/boss.json +++ b/boss.json @@ -1,7 +1,7 @@ { "name": "horse", "description": "Express-inspired web framework for Delphi and Lazarus", - "version": "3.3.13", + "version": "3.3.14", "homepage": "https://github.com/HashLoad/horse", "license": "MIT", "mainsrc": "src/", diff --git a/src/Horse.Constants.pas b/src/Horse.Constants.pas index 350bed26..c1347bb9 100644 --- a/src/Horse.Constants.pas +++ b/src/Horse.Constants.pas @@ -10,7 +10,7 @@ interface DEFAULT_HOST = '0.0.0.0'; DEFAULT_PORT = 9000; START_RUNNING = 'Server is running on %s:%d'; - HORSE_VERSION = '3.3.13'; + HORSE_VERSION = '3.3.14'; implementation