Read numeric header fields by their grammar, not strtol

http.carp

@@ -30,6 +30,22 @@ Returns -1 if not found.")
           m (length sub)]
       (and (>= n m) (= sub &(byte-slice s (- n m) n))))))
 
+(private parse-digits)
+(hidden parse-digits)
+; 1*DIGIT as an Int, saturating at Int.MAX
+(defn parse-digits [s]
+  (let-do [len (String.length s)
+           acc 0
+           ok (> len 0)]
+    (for [i 0 len]
+      (let [c (String.char-at s i)
+            d (- (Char.to-int c) 48)]
+        (cond
+          (not (Char.num? c)) (do (set! ok false) (break))
+          (> acc (/ (- Int.MAX d) 10)) (set! acc Int.MAX)
+          (set! acc (+ (* acc 10) d)))))
+    (if ok (Maybe.Just acc) (Maybe.Nothing))))
+
 (doc HttpDate "reads and writes HTTP-date values (RFC 9110 §5.6.7), the
 timestamp form used by `Date`, `Expires`, `Last-Modified`, `If-Modified-Since`
 and the `Expires` attribute of a `Set-Cookie` header.")
@@ -214,7 +230,13 @@ instants, not as wall-clock readings.")
               (if l<2
                 (Result.Error
                   @"malformed max-age property in set-cookie, no value")
-                (let [mi (Int.from-string &(join "=" &(Array.suffix splt 1)))]
+                (let [v (trim &(join "=" &(Array.suffix splt 1)))
+                      negative (String.byte-starts-with? &v "-")
+                      digits (if (or negative (String.byte-starts-with? &v "+"))
+                        (parse-digits
+                          &(String.byte-slice &v 1 (String.length &v)))
+                        (parse-digits &v))
+                      mi (if negative (Maybe.apply digits &Int.neg) digits)]
                   (match mi
                     (Maybe.Nothing)
                       (Result.Error @"malformed max-age value in set-cookie")
@@ -535,6 +557,15 @@ such a body with `TransferEncoding.dechunk`.")
   (doc server-error? "checks whether the status code is between 500 and 600.")
   (defn server-error? [r] (let [c @(code r)] (and (<= 500 c) (< c 600))))
 
+  (hidden skip-sp)
+  (private skip-sp)
+  (defn skip-sp [s i]
+    (let-do [j i
+             len (String.length s)]
+      (while (and (< j len) (= (String.char-at s j) \space))
+        (set! j (Int.inc j)))
+      j))
+
   (doc parse "parses a HTTP response from a string `txt`.
 
 Returns a `(Error String)` holding the error message if it fails, otherwise
@@ -550,18 +581,19 @@ it will return a `(Success Response)`.")
             (if (= sp1 -1)
               (Result.Error
                 (fmt "Malformed response: found first line '%s'" first-line))
-              (let [sp2 (String.index-of-from first-line \space (Int.inc sp1))]
+              (let [code-start (skip-sp first-line (Int.inc sp1))
+                    sp2 (String.index-of-from first-line \space code-start)]
                 (if (= sp2 -1)
                   (Result.Error
                     (fmt "Malformed response: found first line '%s'" first-line))
                   (let [version &(String.byte-slice first-line 0 sp1)
-                        code-str &(String.byte-slice first-line
-                                                     (Int.inc sp1)
-                                                     sp2)
+                        code-str &(String.byte-slice first-line code-start sp2)
                         message &(String.byte-slice first-line
                                                     (Int.inc sp2)
                                                     (String.length first-line))]
-                    (match (Int.from-string code-str)
+                    (match (if (= (String.length code-str) 3)
+                        (parse-digits code-str)
+                        (Maybe.Nothing))
                       (Maybe.Nothing)
                         (Result.Error
                           (fmt
@@ -1129,7 +1161,8 @@ media range, content coding or language range — and its quality `q` between
 (defmodule Weighted
   (hidden clamp-q)
   (private clamp-q)
-  (defn clamp-q [d] (cond (Double.< d 0.0) 0.0 (Double.> d 1.0) 1.0 d))
+  ; NaN falls through to 1.0
+  (defn clamp-q [d] (cond (Double.< d 0.0) 0.0 (Double.< d 1.0) d 1.0))
 
   (hidden q-of)
   (private q-of)
@@ -1139,9 +1172,11 @@ media range, content coding or language range — and its quality `q` between
     (match (Map.get-maybe &(MediaType.parse-params s) "q")
       (Maybe.Nothing) 1.0
       (Maybe.Just qs)
-        (match (Double.from-string &qs)
-          (Maybe.Nothing) 1.0
-          (Maybe.Just d) (clamp-q d))))
+        (if (String.empty? &qs)
+          1.0
+          (match (Double.from-string &qs)
+            (Maybe.Nothing) 1.0
+            (Maybe.Just d) (clamp-q d)))))
 
   (doc parse-list "parses a weighted, comma-separated header list into its
 entries, in header order. Each entry's `value` is the lower-cased text before
@@ -1459,15 +1494,15 @@ value as `(Maybe String)`. A present valueless directive yields `(Just @\"\")`."
   (private int-directive)
   (defn int-directive [m name]
     (match (directive m name)
-      (Maybe.Just v) (Int.from-string &v)
+      (Maybe.Just v) (parse-digits &v)
       (Maybe.Nothing) (Maybe.Nothing)))
 
   (doc max-age "the `max-age` delta-seconds as `(Maybe Int)`, when present and
-numeric.")
+all digits. A value too large for an `Int` reads as `Int.MAX`.")
   (defn max-age [m] (int-directive m "max-age"))
 
   (doc s-maxage "the `s-maxage` delta-seconds as `(Maybe Int)`, when present and
-numeric.")
+all digits. A value too large for an `Int` reads as `Int.MAX`.")
   (defn s-maxage [m] (int-directive m "s-maxage"))
 
   (doc no-cache? "whether the `no-cache` directive is present.")

test/http.carp

@@ -417,6 +417,9 @@
 (defn cc-directive [s k]
   (Maybe.from (Map.get-maybe &(CacheControl.parse s) k) @"<none>"))
 
+(defn cc-max-age [s]
+  (Maybe.from (CacheControl.max-age &(CacheControl.parse s)) -1))
+
 (defn cookie-summary [s]
   (match (Cookie.parse-set s)
     (Result.Success c) (fmt "%s=%s" (Cookie.name &c) (Cookie.value &c))
@@ -495,6 +498,41 @@
     (resp-code "HTTP/1.1 404 Not Found\r\n\r\n")
     "parse 404 response")
 
+  (assert-equal test
+    -1
+    (resp-code "HTTP/1.1 2000 OK\r\n\r\n")
+    "a four-digit status code is malformed")
+
+  (assert-equal test
+    -1
+    (resp-code "HTTP/1.1 20 OK\r\n\r\n")
+    "a two-digit status code is malformed")
+
+  (assert-equal test
+    -1
+    (resp-code "HTTP/1.1 +200 OK\r\n\r\n")
+    "a status code with a plus sign is malformed")
+
+  (assert-equal test
+    -1
+    (resp-code "HTTP/1.1 -200 OK\r\n\r\n")
+    "a negative status code is malformed")
+
+  (assert-equal test
+    200
+    (resp-code "HTTP/1.1  200 OK\r\n\r\n")
+    "a doubled space before the status code is skipped")
+
+  (assert-equal test
+    200
+    (resp-code "HTTP/1.1   200 OK\r\n\r\n")
+    "three spaces before the status code are skipped")
+
+  (assert-equal test
+    -1
+    (resp-code "HTTP/1.1 \t200 OK\r\n\r\n")
+    "a tab before the status code is malformed")
+
   (assert-true test
     (Response.ok? &(Response.init 200 @"OK" @"HTTP/1.1" [] {} @""))
     "ok? true for 200")
@@ -1549,6 +1587,10 @@
     "text/html"
     &(pick "text/html;q=bogus, image/png;q=0.5" &[@"text/html" @"image/png"])
     "an unparseable q falls back to weight 1")
+  (assert-equal test
+    "text/html"
+    &(pick "text/html;q=nan, text/html;q=0.5" &[@"text/html"])
+    "a NaN q falls back to weight 1 whatever the order of the ranges")
   (assert-true test
     (= 3
        (Array.length
@@ -1640,6 +1682,22 @@
     "gzip@0.5"
     &(weighted-entry &(AcceptEncoding.parse "br, GZIP;q=0.5") 1)
     "parse lower-cases a coding and keeps its weight")
+  (assert-equal test
+    "gzip@1.0"
+    &(weighted-entry &(AcceptEncoding.parse "gzip;q=nan") 0)
+    "a NaN q falls back to weight 1")
+  (assert-equal test
+    "gzip"
+    &(pick-enc "gzip;q=" &[@"gzip"])
+    "an empty q falls back to weight 1 instead of refusing the coding")
+  (assert-equal test
+    "gzip@1.0"
+    &(weighted-entry &(AcceptEncoding.parse "gzip;q=2") 0)
+    "a q above 1 is clamped to 1")
+  (assert-equal test
+    "gzip@0.0"
+    &(weighted-entry &(AcceptEncoding.parse "gzip;q=-1") 0)
+    "a q below 0 is clamped to 0")
   (assert-equal test
     "gzip"
     &(req-pick-enc (the (Map String (Array String)) {}) &[@"gzip" @"identity"])
@@ -2516,6 +2574,42 @@
     (let [m (CacheControl.parse "public, s-maxage=120")]
       (Maybe.from (CacheControl.s-maxage &m) -1))
     "CacheControl.s-maxage is parsed as an Int")
+  (assert-equal test
+    -1
+    (cc-max-age "max-age=")
+    "CacheControl.max-age is Nothing for an empty value")
+  (assert-equal test
+    -1
+    (cc-max-age "max-age=-5")
+    "CacheControl.max-age is Nothing for a negative value")
+  (assert-equal test
+    -1
+    (cc-max-age "max-age=+5")
+    "CacheControl.max-age is Nothing for a value with a plus sign")
+  (assert-equal test
+    7
+    (cc-max-age "max-age=007")
+    "CacheControl.max-age reads leading zeros")
+  (assert-equal test
+    2147483646
+    (cc-max-age "max-age=2147483646")
+    "CacheControl.max-age reads one below Int.MAX exactly")
+  (assert-equal test
+    Int.MAX
+    (cc-max-age "max-age=2147483647")
+    "CacheControl.max-age reads Int.MAX exactly")
+  (assert-equal test
+    Int.MAX
+    (cc-max-age "max-age=2147483648")
+    "CacheControl.max-age saturates one past Int.MAX")
+  (assert-equal test
+    Int.MAX
+    (cc-max-age "max-age=4294967296")
+    "CacheControl.max-age saturates 2^32 instead of wrapping to 0")
+  (assert-equal test
+    Int.MAX
+    (cc-max-age "max-age=99999999999999999999")
+    "CacheControl.max-age saturates a value past 64 bits")
   (assert-equal test
     2
     (Map.length &(CacheControl.parse "no-cache=\"Set-Cookie, X\", max-age=5"))
@@ -2702,6 +2796,30 @@
     "live"
     &(expiry-verdict "id=abc; Max-Age=3600")
     "a positive Max-Age keeps the cookie alive")
+  (assert-equal test
+    "malformed max-age value in set-cookie"
+    &(expiry-verdict "id=abc; Max-Age=")
+    "an empty Max-Age is malformed rather than expiring the cookie")
+  (assert-equal test
+    "live"
+    &(expiry-verdict "id=abc; Max-Age=+60")
+    "a Max-Age with a plus sign keeps the cookie alive")
+  (assert-equal test
+    "live"
+    &(expiry-verdict "id=abc; Max-Age=0060")
+    "a Max-Age with leading zeros keeps the cookie alive")
+  (assert-equal test
+    "live"
+    &(expiry-verdict "id=abc; Max-Age= 60")
+    "whitespace before a Max-Age value is ignored")
+  (assert-equal test
+    "live"
+    &(expiry-verdict "id=abc; Max-Age=4294967296")
+    "a Max-Age too large for an Int saturates instead of wrapping")
+  (assert-equal test
+    "expired"
+    &(expiry-verdict "id=abc; Max-Age=-99999999999999999999")
+    "a Max-Age too negative for an Int still expires the cookie")
   (assert-equal test
     "expired"
     &(expiry-verdict "id=abc; Expires=Wed, 09 Jun 2021 10:18:14 GMT")