Add `parse-request-multipart/form-data'.

This commit also adds the star variant of this procedure (returning alist) and
an analogous star variant of `parse-multipart/form-data'.  Tests are included.

2 files changed, 94 insertions, 46 deletions

diff --git a/src/guile/cantius.scm b/src/guile/cantius.scm
index 39543ad..9fe9884 100644
--- a/src/guile/cantius.scm
+++ b/src/guile/cantius.scm
@@ -4,7 +4,7 @@
 
 (define-module (cantius)
   #:use-module ((rnrs bytevectors) #:prefix bv:)
-  #:use-module ((srfi srfi-1) #:select (filter-map))
+  #:use-module ((srfi srfi-1) #:select (filter-map fold))
   #:use-module ((srfi srfi-26) #:select (cut))
   #:use-module ((srfi srfi-34) #:select (guard raise))
   #:use-module ((srfi srfi-35) #:prefix s35:)
@@ -19,7 +19,7 @@
                 (match:substring match:end regexp-substitute/global))
   #:use-module ((system repl debug) #:select (terminal-width))
   #:use-module ((web http) #:select (read-headers))
-  #:use-module ((web request) #:select (request-uri))
+  #:use-module ((web request) #:select (request-headers request-uri))
   #:use-module ((web response) #:select (build-response))
   #:use-module ((web uri) #:prefix uri:)
   #:use-module ((fibers web server) #:select (run-server))
@@ -244,6 +244,28 @@
                         (bv:utf8->string data-binary)))))))
        parts))
 
+(define-public (parse-request-multipart/form-data request body)
+  (match-let* ((content-type (assq-ref (request-headers request) 'content-type))
+               (('multipart/form-data
+                 . (= (cut assq-ref <> 'boundary)
+                      (? identity boundary)))
+                content-type))
+    (parse-multipart/form-data boundary body)))
+
+(define (parts->alist parts)
+  ;; This shouldn't be strongly relevant but we make later parts appear
+  ;; earlier in the alist so that they take precedence when `assoc' is used.
+  (fold (lambda (part acc)
+          `((,(form-data-part-name part) . ,part)
+            . ,acc))
+        '() parts))
+
+(define-public parse-multipart/form-data*
+  (compose parts->alist parse-multipart/form-data))
+
+(define-public parse-request-multipart/form-data*
+  (compose parts->alist parse-request-multipart/form-data))
+
 
 
 ;;;
diff --git a/tests/guile/cantius-test.scm b/tests/guile/cantius-test.scm
index db6b28a..7a12434 100644
--- a/tests/guile/cantius-test.scm
+++ b/tests/guile/cantius-test.scm
@@ -2,16 +2,20 @@
 ;;;
 ;;; Copyright (C) 2023, 2024 Wojtek Kosior <koszko@koszko.org>
 
-(use-modules ((scheme base) #:select (bytevector-copy string->utf8))
+(use-modules ((scheme base) #:select
+              (bytevector-copy bytevector-length string->utf8))
              ((rnrs bytevectors) #:prefix bv:)
              ((srfi srfi-8) #:select (receive))
              ((srfi srfi-26) #:select (cut))
              ((srfi srfi-34) #:select (guard raise))
              ((srfi srfi-35) #:select (condition-has-type?))
+             ((srfi srfi-45) #:select (delay force))
              ((ice-9 safe-r5rs) #:select (null-environment))
              ((ice-9 format) #:select (format))
+             ((ice-9 match) #:select (match-let*))
              ((ice-9 regex) #:select (regexp-substitute/global))
              ((web client) #:select (open-socket-for-uri http-get))
+             ((web request) #:prefix req:)
              ((web response) #:prefix rsp:)
              ((web uri) #:prefix uri:)
              ((myra-test-utils) #:prefix tu:)
@@ -20,25 +24,26 @@
 (define (use-crlf text)
   (regexp-substitute/global #f "\n" text 'pre "\r\n" 'post))
 
-(define %form-data-good
-  (use-crlf "\
-----boundary
+(define (form-data-good boundary)
+  (use-crlf (format #f "\
+--~a
 Content-Disposition: form-data; name=\"binary-field\"; filename=\"somefile\"
 Content-Type: application/octet-stream
 
 śómę-ńóń-ĄŚĆII-dątą\\
-----boundary
+--~@*~a
 Content-Disposition: form-data; name=\"text-field1\"
 Content-Transfer-Encoding: binary
 
 óthęr-ńóń-ĄŚĆII-dątą\\
-----boundary
+--~@*~a
 Content-Disposition: form-data; name=\"text-field2\";
 Content-Type: text/plain
 
 //yęt-óthęr-ńóń-ĄŚĆII-dątą
-----boundary--
-"))
+--~@*~a--
+"
+                    boundary)))
 
 (define %form-data-bad-epilogue
   (use-crlf "\
@@ -59,56 +64,77 @@ value
 ----boundary--
 "))
 
-(define %form-boundary-1
+(define %form-boundary
   "--boundary")
 
-(define %form-boundary-2
+(define %form-boundary-with-backslash
   "--boundary-with-\\-(a-backslash)")
 
 (tu:test-group "parse-multipart/form-data"
   (for-each
-   (lambda (boundary form-data)
-     (define (parsed-multipart)
-       (cant:parse-multipart/form-data boundary (bv:string->utf8 form-data)))
-
-     (tu:test-eqv 3 (length (parsed-multipart)))
-
-     (tu:test-equal '("binary-field" "text-field1" "text-field2")
-                    (map cant:form-data-part-name (parsed-multipart)))
-
-     (tu:test-equal '(((content-disposition . (form-data
-                                               (name . "binary-field")
-                                               (filename . "somefile")))
-                       (content-type . (application/octet-stream)))
-                      ((content-disposition . (form-data
-                                               (name . "text-field1")))
-                       (content-transfer-encoding . "binary"))
-                      ((content-disposition . (form-data
-                                               (name . "text-field2")))
-                       (content-type . (text/plain))))
-                    (map cant:form-data-part-headers (parsed-multipart)))
-
-     (tu:test-equal '(#t #f #f)
-                    (map cant:form-data-part-binary? (parsed-multipart)))
-
-     (tu:test-equal `(,(bv:string->utf8 "śómę-ńóń-ĄŚĆII-dątą\\")
-                      "óthęr-ńóń-ĄŚĆII-dątą\\"
-                      "//yęt-óthęr-ńóń-ĄŚĆII-dątą")
-                    (map cant:form-data-part-data (parsed-multipart))))
-   (list %form-boundary-1 %form-boundary-2)
-   (list %form-data-good
-         (regexp-substitute/global #f %form-boundary-1 %form-data-good
-                                   'pre %form-boundary-2 'post)))
+   (lambda (boundary)
+     (match-let* ((form-data (form-data-good boundary))
+                  (data-bytevector (string->utf8 form-data))
+                  (data-length (bytevector-length data-bytevector))
+                  (request-text (format #f "\
+GET /dummy HTTP/1.0
+Host: example.com
+Content-Type: multipart/form-data; boundary=~a
+Content-Length: ~d
+
+~a"
+                                        boundary data-length form-data))
+                  ((request body) (call-with-input-string request-text
+                                    (lambda (port)
+                                      (let* ((request (req:read-request port))
+                                             (body (req:read-request-body
+                                                    request)))
+                                        (list request body)))))
+                  (parsed-alist (delay (cant:parse-request-multipart/form-data*
+                                        request body)))
+                  (parsed (delay (reverse (map cdr (force parsed-alist))))))
+       (tu:test-eqv 3 (length (force parsed)))
+
+       (tu:test-equal (force parsed-alist)
+                      (cant:parse-multipart/form-data*
+                       boundary data-bytevector))
+
+       (tu:test-equal '("text-field2" "text-field1" "binary-field")
+                      (map car (force parsed-alist)))
+
+       (tu:test-equal '("binary-field" "text-field1" "text-field2")
+                      (map cant:form-data-part-name (force parsed)))
+
+       (tu:test-equal '(((content-disposition . (form-data
+                                                 (name . "binary-field")
+                                                 (filename . "somefile")))
+                         (content-type . (application/octet-stream)))
+                        ((content-disposition . (form-data
+                                                 (name . "text-field1")))
+                         (content-transfer-encoding . "binary"))
+                        ((content-disposition . (form-data
+                                                 (name . "text-field2")))
+                         (content-type . (text/plain))))
+                      (map cant:form-data-part-headers (force parsed)))
+
+       (tu:test-equal '(#t #f #f)
+                      (map cant:form-data-part-binary? (force parsed)))
+
+       (tu:test-equal `(,(bv:string->utf8 "śómę-ńóń-ĄŚĆII-dątą\\")
+                        "óthęr-ńóń-ĄŚĆII-dątą\\"
+                        "//yęt-óthęr-ńóń-ĄŚĆII-dątą")
+                      (map cant:form-data-part-data (force parsed)))))
+   (list %form-boundary %form-boundary-with-backslash))
 
   (tu:test-error (cut condition-has-type? <> cant:&bad-request)
                  (cant:parse-multipart/form-data
-                  %form-boundary-1
+                  %form-boundary
                   (bv:string->utf8 %form-data-bad-epilogue)))
 
   (tu:test-error (compose (cut = 415 <>)
                           cant:condition-http-code)
                  (cant:parse-multipart/form-data
-                  %form-boundary-1
+                  %form-boundary
                   (bv:string->utf8 %form-data-unsupported-encoding))))
 
 (tu:test-group "parse-cookies"