Bound captured extension route backtracking

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)]

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)