From 6af35a3997887fe24620fc7448ded3649e04b82b Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Tue, 28 Aug 2018 23:15:36 -0400
Subject: [PATCH 2/2] PRELIMINARY: web: Fix parsing of HTTP Content-Type
 header.

---
 module/web/http.scm | 109 +++++++++++++++++++++++++++++++++++---------
 1 file changed, 88 insertions(+), 21 deletions(-)

diff --git a/module/web/http.scm b/module/web/http.scm
index 15f173173..6ccd853c1 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -290,16 +290,94 @@ as an ordered alist."
 (define (write-opaque-string val port)
   (put-string port val))
 
-(define separators-without-slash
-  (string->char-set "[^][()<>@,;:\\\"?= \t]"))
-(define (validate-media-type str)
-  (let ((idx (string-index str #\/)))
-    (and idx (= idx (string-rindex str #\/))
-         (not (string-index str separators-without-slash)))))
+(define separators
+  (string->char-set "()<>@,;:\\\"/[]?={} \t"))
+
+(define (ascii-char? c)
+  (char-set-contains? char-set:ascii c))
+
+(define valid-token-chars
+  (char-set-difference char-set:ascii
+                       char-set:iso-control
+                       separators))
+
+(define (valid-token? str)
+  (and (not (string-null? str))
+       (string-every valid-token-chars str)))
+
+(define (string-skip* s pred i)
+  (or (string-skip s pred i)
+      (string-length s)))
+
+(define (parse-token str i)
+  (let* ((i   (string-skip* str spaces-and-tabs i))
+         (end (string-skip* str valid-token-chars i)))
+    (and (< i end)
+         (cons end (substring str i end)))))
+
+(define valid-text-chars
+  (char-set-adjoin (char-set-difference (ucs-range->char-set 0 256)
+                                        char-set:iso-control)
+                   #\space #\tab))
+
+(define (text-char? c)
+  (char-set-contains? valid-text-chars c))
+
+(define (parse-quoted-string str i)
+  (let ((len (string-length str))
+        (i   (string-skip* str spaces-and-tabs i)))
+    (and (< i len)
+         (eqv? #\" (string-ref str i))
+         (let loop ((i (+ i 1))
+                    (accum '()))
+           (and (< i len)
+                (match (string-ref str i)
+                  (#\" (cons (+ i 1) (reverse-list->string accum)))
+                  (#\\ (and (< (+ i 1) len)
+                            (let ((c (string-ref str (+ i 1))))
+                              (and (ascii-char? c)
+                                   (loop (+ i 2) (cons c accum))))))
+                  (c   (and (text-char? c)
+                            (loop (+ i 1) (cons c accum))))))))))
+
+(define (parse-parameter str i)
+  (let* ((eq (string-index str #\= i))
+         (attribute (string-trim-both (substring str i eq)
+                                      spaces-and-tabs)))
+    (and (valid-token? attribute)
+         (match (or (parse-token         str (+ eq 1))
+                    (parse-quoted-string str (+ eq 1)))
+           ((i . val) (cons i (cons (string->symbol attribute) val)))
+           (#f        #f)))))
+
+(define (parse-parameter-list str i)
+  (let ((len (string-length str))
+        (i   (string-skip* str spaces-and-tabs i)))
+    (if (= i len)
+        '()
+        (and (< i len)
+             (eqv? #\; (string-ref str i))
+             (match (parse-parameter str (+ i 1))
+               (#f      #f)
+               ((i . p) (match (parse-parameter-list str i)
+                          (#f  #f)
+                          (lst (cons p lst)))))))))
+
 (define (parse-media-type str)
-  (unless (validate-media-type str)
-    (bad-header-component 'media-type str))
-  (string->symbol str))
+  (let* ((i (or (string-index str #\;)
+                (string-length str)))
+         (params (parse-parameter-list str i)))
+    (or (match (string-split (substring str 0 i) #\/)
+          ((type* subtype*)
+           (let ((type    (string-trim-both type*    spaces-and-tabs))
+                 (subtype (string-trim-both subtype* spaces-and-tabs)))
+             (and (valid-token? type)
+                  (valid-token? subtype)
+                  params
+                  (cons (string->symbol (string-append type "/" subtype))
+                        params))))
+          (_ #f))
+        (bad-header 'content-type str))))
 
 (define* (skip-whitespace str #:optional (start 0) (end (string-length str)))
   (let lp ((i start))
@@ -1617,18 +1695,7 @@ treated specially, and is just returned as a plain string."
 ;; Content-Type = media-type
 ;;
 (declare-header! "Content-Type"
-  (lambda (str)
-    (let ((parts (string-split str #\;)))
-      (cons (parse-media-type (car parts))
-            (map (lambda (x)
-                   (let ((eq (string-index x #\=)))
-                     (unless (and eq (= eq (string-rindex x #\=)))
-                       (bad-header 'content-type str))
-                     (cons
-                      (string->symbol
-                       (string-trim x char-set:whitespace 0 eq))
-                      (string-trim-right x char-set:whitespace (1+ eq)))))
-                 (cdr parts)))))
+  parse-media-type
   (lambda (val)
     (match val
       (((? symbol?) ((? symbol?) . (? string?)) ...) #t)
-- 
2.18.0