Improved `get-bindings' using regexps etc.

(But note that it looks like it reimplements `form-urlencoded->alist'.)

original commit: 76c07dd594160bd37b49aff654055aa28ed2fe93

collects/net/cgi-unit.rkt

@@ -24,16 +24,15 @@
 
 ;; --------------------------------------------------------------------
 
-;; query-chars->string : list (char) -> string
+;; query-string->string : string -> string
 
-;; -- The input is the characters post-processed as per Web specs, which
+;; -- The input is the string post-processed as per Web specs, which
 ;; is as follows:
 ;; spaces are turned into "+"es and lots of things are turned into %XX, where
 ;; XX are hex digits, eg, %E7 for ~.  The output is a regular Scheme string
 ;; with all the characters converted back.
 
-(define (query-chars->string chars)
+(define query-string->string form-urlencoded-decode)
-  (form-urlencoded-decode (list->string chars)))
 
 ;; string->html : string -> string
 ;; -- the input is raw text, the output is HTML appropriately quoted
@@ -92,70 +91,53 @@
 (define (output-http-headers)
   (printf "Content-type: text/html\r\n\r\n"))
 
-;; read-until-char : iport x char -> list (char) x bool
+;; delimiter->predicate : symbol -> regexp
-;; -- operates on the default input port; the second value indicates whether
+;; returns a regexp to read a chunk of text up to a delimiter (excluding it)
-;; reading stopped because an EOF was hit (as opposed to the delimiter being
+(define (delimiter->rx delimiter)
-;; seen); the delimiter is not part of the result
-(define (read-until-char ip delimiter?)
-  (let loop ([chars '()])
-    (let ([c (read-char ip)])
-      (cond [(eof-object? c) (values (reverse chars) #t)]
-            [(delimiter? c) (values (reverse chars) #f)]
-            [else (loop (cons c chars))]))))
-
-;; delimiter->predicate :
-;; symbol -> (char -> bool)
-;; returns a predicates to pass to read-until-char
-(define (delimiter->predicate delimiter)
   (case delimiter
-    [(eq) (lambda (c) (char=? c #\=))]
+    [(amp)         #rx#"^[^&]*"]
-    [(amp) (lambda (c) (char=? c #\&))]
+    [(semi)        #rx#"^[^;]*"]
-    [(semi) (lambda (c) (char=? c #\;))]
+    [(amp-or-semi) #rx#"^[^&;]*"]
-    [(amp-or-semi) (lambda (c) (or (char=? c #\&) (char=? c #\;)))]))
+    [else (error 'delimiter->rx
+                 "internal-error, unknown delimiter: ~e" delimiter)]))
 
-;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool
+;; get-bindings* : iport -> (listof (cons symbol string))
-;; -- If the first value is false, so is the second, and the third is true,
+;; Reads all bindings from the input port.  The strings are processed to
-;; indicating EOF was reached without any input seen.  Otherwise, the first
+;; remove the CGI spec "escape"s.
-;; and second values contain strings and the third is either true or false
+;; This code is _slightly_ lax: it allows an input to end in
-;; depending on whether the EOF has been reached.  The strings are processed
+;; (current-alist-separator-mode).  It's not clear this is legal by the
-;; to remove the CGI spec "escape"s.  This code is _slightly_ lax: it allows
+;; CGI spec, which suggests that the last value binding must end in an
-;; an input to end in (current-alist-separator-mode).  
+;; EOF.  It doesn't look like this matters.
-;; It's not clear this is legal by the CGI spec,
+;; ELI: * Keeping this behavior for now, maybe better to remove it?
-;; which suggests that the last value binding must end in an EOF.  It doesn't
+;;      * Looks like `form-urlencoded->alist' is doing almost exactly
-;; look like this matters.  It would also introduce needless modality and
+;;        the same job this code does.
-;; reduce flexibility.
+(define (get-bindings* method ip)
-(define (read-name+value ip)
+  (define (err fmt . xs)
-  (let-values ([(name eof?) (read-until-char ip (delimiter->predicate 'eq))])
+    (generate-error-output
-    (cond [(and eof? (null? name)) (values #f #f #t)]
+     (list (format "Server generated malformed input for ~a method:" method)
-          [eof?
+           (apply format fmt xs))))
-           (generate-error-output
+  (define value-rx (delimiter->rx (current-alist-separator-mode)))
-            (list "Server generated malformed input for POST method:"
+  (define (process str) (query-string->string (bytes->string/utf-8 str)))
-                  (string-append
+  (let loop ([bindings '()])
-                   "No binding for `" (list->string name) "' field.")))]
+    (if (eof-object? (peek-char ip))
-          [else (let-values ([(value eof?) 
+      (reverse bindings)
-                              (read-until-char 
+      (let ()
-                               ip 
+        (define name (car (or (regexp-match #rx"^[^=]+" ip)
-                               (delimiter->predicate
+                              (err "Missing field name before `='"))))
-                                (current-alist-separator-mode)))])
+        (unless (eq? #\= (read-char ip))
-                  (values (string->symbol (query-chars->string name))
+          (err "No binding for `~a' field." name))
-                          (query-chars->string value)
+        (define value (car (regexp-match value-rx ip)))
-                          eof?))])))
+        (read-char ip) ; consume the delimiter, possibly eof (retested above)
+        (loop (cons (cons (string->symbol (process name)) (process value))
+                    bindings))))))
 
 ;; get-bindings/post : () -> bindings
 (define (get-bindings/post)
-  (let-values ([(name value eof?) (read-name+value (current-input-port))])
+  (get-bindings* "POST" (current-input-port)))
-    (cond [(and eof? (not name)) null]
-          [(and eof? name) (list (cons name value))]
-          [else (cons (cons name value) (get-bindings/post))])))
 
 ;; get-bindings/get : () -> bindings
 (define (get-bindings/get)
-  (let ([p (open-input-string (getenv "QUERY_STRING"))])
+  (get-bindings* "GET" (open-input-string (getenv "QUERY_STRING"))))
-    (let loop ()
-      (let-values ([(name value eof?) (read-name+value p)])
-        (cond [(and eof? (not name)) null]
-              [(and eof? name) (list (cons name value))]
-              [else (cons (cons name value) (loop))])))))
 
 ;; get-bindings : () -> bindings
 (define (get-bindings)