route: serve ReDoS-safe linear matcher and bound pregexp fallback
ober
8bfc04a4cd4a9ee1cbf70da7886f08fbbfd566db
--- a/sinatra/filters.ss +++ b/sinatra/filters.ss @@ -1,5 +1,4 @@ -(import (std pregexp) - (sinatra route)) +(import (sinatra route)) (export run-before-filters run-after-filters @@ -28,5 +27,6 @@ ;; Check if a pattern matches the given path. (def (filter-matches? pattern path) (let-values (((rx _names) (compile-route-pattern pattern))) - ;; Filter patterns are trusted configuration compiled by the route DSL. - (and (pregexp-match rx path) #t))) ; jerboa-security: suppress scheme-dynamic-pregexp-redos + ;; Filter patterns are matched through the same linear/bounded matcher as + ;; routes, so a hostile path cannot drive catastrophic backtracking. + (and (route-pattern-captures rx path) #t))) --- a/sinatra/route-test.ss +++ b/sinatra/route-test.ss @@ -1,5 +1,7 @@ (import (std test) (std pregexp) + (std regex) + (only (chezscheme) current-time time-second time-nanosecond) (sinatra route)) (export route-test) @@ -16,6 +18,21 @@ (let ((rt (make-route route-method pattern rx names (lambda () #f) '()))) (route-match rt req-method path)))) +;; Helper: match an already-compiled pattern (re-object or raw pregexp) +(def (route-match-compiled pattern path) + (let-values (((rx names) (compile-route-pattern pattern))) + (let ((rt (make-route 'GET "(compiled)" rx names (lambda () #f) '()))) + (route-match rt 'GET path)))) + +;; Helper: run thunk, returning (values result elapsed-nanoseconds) +(def (elapsed-nanos thunk) + (let* ((t0 (current-time)) + (result (thunk)) + (t1 (current-time))) + (values result + (- (+ (* (time-second t1) 1000000000) (time-nanosecond t1)) + (+ (* (time-second t0) 1000000000) (time-nanosecond t0)))))) + (def route-test (test-suite "route pattern compilation and matching" @@ -74,4 +91,49 @@ (let ((p (route-match-path "/files/:name.:ext" "/files/report.pdf"))) (check (hash-ref p "name") => "report") (check (hash-ref p "ext") => "pdf"))) + + (test-case "compiled re-object is ReDoS-safe on hostile path" + ;; DSL patterns compile to a (std regex) re-object served by the linear + ;; native engine. A pattern that would catastrophically backtrack under + ;; pregexp must complete quickly here. + (let ((rx (re "^(([a-z])+)+!"))) + (let-values (((m ns) (elapsed-nanos + (lambda () + (route-pattern-captures rx + (string-append (make-string 40 #\a) "")))))) + (check m => #f) + (check (< ns 100000000) => #t)))) + + (test-case "raw pregexp route is step-bounded against hostile path" + ;; User-supplied raw pregexp patterns cannot use the linear engine, so + ;; route-pattern-captures bounds backtracking via *pregexp-max-steps*. + ;; A catastrophic pattern must fail fast (returning #f) rather than hang. + (let ((rx (pregexp "^(([a-z])+)+!"))) + (let-values (((m ns) (elapsed-nanos + (lambda () + (route-pattern-captures rx + (make-string 40 #\a)))))) + (check m => #f) + (check (< ns 100000000) => #t)))) + + (test-case "DSL splat route stays linear on long hostile path" + ;; A simple DSL pattern under a long non-matching tail must remain + ;; linear-time. Under backtracking pregexp a (.+?) splat with no + ;; terminator could blow up; the linear path handles it in O(n). + (let-values (((rx _names) (compile-route-pattern "/files/*"))) + (let-values (((m ns) (elapsed-nanos + (lambda () + (route-pattern-captures rx + (string-append "/files/" (make-string 10000 #\a))))))) + (check m ? list?) + (check (< ns 100000000) => #t)))) + + (test-case "linear matcher still rejects non-matching DSL route quickly" + (let-values (((rx _names) (compile-route-pattern "/users/:id"))) + (let-values (((m ns) (elapsed-nanos + (lambda () + (route-pattern-captures rx + (make-string 10000 #\a)))))) + (check m => #f) + (check (< ns 100000000) => #t)))) )) --- a/sinatra/route.ss +++ b/sinatra/route.ss @@ -1,16 +1,18 @@ (import (std pregexp) + (std regex) (std iter) (std sugar)) (export make-route route? route-method route-pattern-src route-pattern-rx route-param-names route-handler route-conditions compile-route-pattern + route-pattern-captures route-match) (defstruct route (method ;; symbol: GET POST PUT DELETE PATCH OPTIONS HEAD or #f (any) pattern-src ;; original pattern string - pattern-rx ;; compiled pregexp + pattern-rx ;; compiled route regex: (std regex) re-object for DSL patterns, raw pregexp for user-supplied regex routes param-names ;; list of param name strings (named params) or 'splat / 'capture markers handler ;; (lambda () body) — route handler conditions) ;; alist of conditions @@ -26,7 +28,12 @@ ;; literal -> escaped literal (def (compile-route-pattern pattern) (cond - ;; Already a compiled regex (pregexp) + ;; Already a compiled (std regex) re-object + ((re? pattern) + (values pattern '())) + ;; Already a compiled pregexp (raw user-supplied regex). The linear engine + ;; cannot consume compiled pregexp SREs, so these are matched with a + ;; step-bounded pregexp. ((pair? pattern) (values pattern '())) ;; String pattern — compile it @@ -47,7 +54,9 @@ (begin (display "$" rx) ;; The route DSL emits only escaped literals and fixed capture fragments. - (values (pregexp (get-output-string rx)) ; jerboa-security: suppress scheme-dynamic-pregexp-redos + ;; Compile to a (std regex) re-object: served by the linear native engine + ;; when available (ReDoS-safe), with a step-bounded pregexp fallback. + (values (re (get-output-string rx)) (reverse names))) (let ((ch (string-ref pattern i))) (cond @@ -131,14 +140,37 @@ (values name j #f))) (loop (+ j 1))))) +;; Maximum pregexp backtracking steps permitted when the linear native engine +;; cannot serve a match (raw user-supplied pregexp routes, or non-ASCII paths). +;; Bounds the ReDoS surface: a hostile path cannot drive catastrophic +;; backtracking, and an over-budget match is treated as no match. +(def *route-match-max-steps* 200000) + +;; Match a compiled route pattern (re-object or raw pregexp) against a request +;; path. Returns the list of capture-group strings (#f for unmatched optional +;; groups), or #f when the path does not match. re-object patterns are served by +;; the linear native engine when available (ReDoS-safe); the pregexp fallback is +;; step-bounded so a hostile path cannot hang request handling. +(def (route-pattern-captures rx path) + (parameterize ((*pregexp-max-steps* *route-match-max-steps*)) + (try + (cond + ((re? rx) + (let ((m (re-search rx path))) + (and m (re-match-groups m)))) + (else + (let ((m (pregexp-match rx path))) + (and m (cdr m))))) + (catch (e) #f)))) + ;; Match a route against method + path. ;; Returns #f or a hash-table of params. (def (route-match rt method path) (and (or (not (route-method rt)) (eq? method (route-method rt))) - (let ((m (pregexp-match (route-pattern-rx rt) path))) - (and m - (build-params (cdr m) (route-param-names rt)))))) + (let ((captures (route-pattern-captures (route-pattern-rx rt) path))) + (and captures + (build-params captures (route-param-names rt)))))) ;; Build a params hash-table from match captures and param name descriptors. (def (build-params captures names)