From 7a4494ab114b02f8618a02057c269e650a8a77b4 Mon Sep 17 00:00:00 2001 From: Alexander Thiemann Date: Wed, 30 Sep 2026 10:32:40 -0700 Subject: [PATCH] Bound captured extension route backtracking --- reroute/src/Web/Routing/SafeRouting.hs | 28 +++++++++++++++------ reroute/test/Web/Routing/SafeRoutingSpec.hs | 8 ++++++ 2 files changed, 28 insertions(+), 8 deletions(-) diff --git a/reroute/src/Web/Routing/SafeRouting.hs b/reroute/src/Web/Routing/SafeRouting.hs index a0c04f9..c122bc1 100644 --- a/reroute/src/Web/Routing/SafeRouting.hs +++ b/reroute/src/Web/Routing/SafeRouting.hs @@ -215,14 +215,16 @@ parsePrefix (PI_Append left right) pieces = do pure (leftArgs <++> rightArgs, remaining) parsePrefix (PI_Extension left right) pieces = case splitAt (max 0 $ pathPieceCount left - 1) pieces of - (prefix, joined : rest) -> listToMaybe - [ (leftArgs <++> rightArgs, remaining) - | (base, extension) <- extensionSplits right joined, - Just leftArgs <- [parse left (if pathPieceCount left == 0 then [] else prefix ++ [base])], - pathPieceCount left /= 0 || T.null base, - pathPieceCount right /= 0 || T.null extension, - Just (rightArgs, remaining) <- [parsePrefix right (if pathPieceCount right == 0 then rest else extension : rest)] - ] + (prefix, joined : rest) + | extensionNeedsSearch right && T.count "." joined > maximumExtensionSeparators -> Nothing + | otherwise -> listToMaybe + [ (leftArgs <++> rightArgs, remaining) + | (base, extension) <- extensionSplits right joined, + Just leftArgs <- [parse left (if pathPieceCount left == 0 then [] else prefix ++ [base])], + pathPieceCount left /= 0 || T.null base, + pathPieceCount right /= 0 || T.null extension, + Just (rightArgs, remaining) <- [parsePrefix right (if pathPieceCount right == 0 then rest else extension : rest)] + ] _ -> Nothing parsePrefix _ [] = Nothing parsePrefix (PI_StaticCons expected rest) (piece : pieces) @@ -241,6 +243,16 @@ extensionSplits (PI_StaticCons extension _) piece = extensionSplits PI_Empty piece = [(base, "") | Just base <- [T.stripSuffix "." piece]] extensionSplits _ piece = dotSplits piece +-- Captured extensions require trying possible dot positions. Limiting the +-- number of separators bounds all combinations across a nested chain to 2^16. +maximumExtensionSeparators :: Int +maximumExtensionSeparators = 16 + +extensionNeedsSearch :: PathInternal as -> Bool +extensionNeedsSearch (PI_StaticCons _ _) = False +extensionNeedsSearch PI_Empty = False +extensionNeedsSearch _ = True + -- Rightmost valid split keeps dots in a basename, while allowing a fixed -- multi-dot suffix such as tar.gz or a custom typed extension parser. dotSplits :: T.Text -> [(T.Text, T.Text)] diff --git a/reroute/test/Web/Routing/SafeRoutingSpec.hs b/reroute/test/Web/Routing/SafeRoutingSpec.hs index 426342f..2798d5e 100644 --- a/reroute/test/Web/Routing/SafeRoutingSpec.hs +++ b/reroute/test/Web/Routing/SafeRoutingSpec.hs @@ -84,6 +84,14 @@ spec = let pieces' = T.splitOn "/" $ renderRouteWith StrictSlashes path (number :&: extension :&: HNil) parse (toInternalPath path) pieces' `shouldBe` Just (number :&: extension :&: HNil) map runIdentity (handle True pieces') `shouldBe` [ListVar [IntVar number, StrVar extension]] + it "bounds backtracking for chained captured extensions" $ do + let path = (var :: Var Int) <.> (var :: Var T.Text) <.> (var :: Var T.Text) <.> (var :: Var T.Text) + adversarialPiece = "x" <> T.replicate (maximumExtensionSeparators + 1) "." + parse (toInternalPath path) [adversarialPiece] `shouldBe` Nothing + it "does not limit dots when matching a fixed extension" $ do + let path = (var :: Var T.Text) <.> "txt" + basename = T.replicate (maximumExtensionSeparators + 1) "." + parse (toInternalPath path) [basename <> ".txt"] `shouldBe` Just (basename :&: HNil) it "parses appended extension paths and wildcard tails consistently" $ do let path = ((var :: Var Int) <.> "txt") wildcard parse (toInternalPath path) ["42.txt", "a", "b"] `shouldBe` Just (42 :&: "a/b" :&: HNil)