(BREAKING!) Make monadic versions of helper procedures.

This, among others, removes `parse-request-multipart/form-data' and its
asterisked variant.  It insteads adds the monadic `multipart/form-data'
procedure with an asterisked variant.

2 files changed, 92 insertions, 53 deletions

diff --git a/src/guile/cantius.scm b/src/guile/cantius.scm
index d6d64a3..d7413fe 100644
--- a/src/guile/cantius.scm
+++ b/src/guile/cantius.scm
@@ -66,6 +66,29 @@
 
 
 ;;;
+;;; Cantius syntactic monad.
+;;;
+
+(eval-when (compile load eval)
+  (define-public $-args
+    '(cant$resource-roots
+      cant$redirect/normalize-path?
+      cant$redirect/remove-query?
+      cant$default-headers
+      cant$http-code-handlers
+      cant$other-http-codes-handler
+      cant$request
+      cant$body
+      cant$current-path
+      cant$current-endpoint
+      cant$endpoint-matched-path))
+
+  (export $)
+  (eval `(define-syntactic-monad $ . ,$-args) (current-module)))
+
+
+
+;;;
 ;;; Multipart form parser.
 ;;;
 
@@ -207,14 +230,13 @@
                         (utf8->string data-binary)))))))
        parts))
 
-(define-public (parse-request-multipart/form-data request body)
-  (match-let* ((content-type (assq-ref (req:request-headers request)
-                                       'content-type))
-               (('multipart/form-data
-                 . (= (cut assq-ref <> 'boundary)
-                      (? identity boundary)))
-                content-type))
-    (parse-multipart/form-data boundary body)))
+(export multipart/form-data)
+($ define (multipart/form-data)
+  (match-let ((('multipart/form-data
+                . (= (cut assq-ref <> 'boundary) (? identity boundary)))
+               (req:request-content-type cant$request)))
+
+    (parse-multipart/form-data boundary cant$body)))
 
 (define (parts->alist parts)
   ;; This shouldn't be strongly relevant but we make later parts appear
@@ -227,8 +249,8 @@
 (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))
+(define-public multipart/form-data*
+  (compose parts->alist multipart/form-data))
 
 
 
@@ -320,6 +342,12 @@
             (= match:end idx*))
        (loop idx* `((,name . ,value) . ,cookies-alist))))))
 
+(export cookies)
+($ define (cookies)
+  (or (and=> (assq-ref (req:request-headers cant$request) 'cookie)
+             parse-cookies)
+      '()))
+
 ;; Sugar over `build-response', with support for easy redirects.
 
 (export build-response*)
@@ -348,29 +376,16 @@
       ((keyword keyword-arg . rest)
        (loop rest (cons* keyword-arg keyword filtered))))))
 
+(export response)
+($ define (response . rest)
+  (apply build-response* cant$default-headers rest))
+
 
 
 ;;;
-;;; Cantius syntactic monad and default values to use as its arguments.
+;;; Default values to use as monadic arguments.
 ;;;
 
-(eval-when (compile load eval)
-  (define-public $-args
-    '(cant$resource-roots
-      cant$redirect/normalize-path?
-      cant$redirect/remove-query?
-      cant$default-headers
-      cant$http-code-handlers
-      cant$other-http-codes-handler
-      cant$request
-      cant$body
-      cant$current-path
-      cant$current-endpoint
-      cant$endpoint-matched-path))
-
-  (export $)
-  (eval `(define-syntactic-monad $ . ,$-args) (current-module)))
-
 (define %default-headers
   '((content-type . (text/plain (charset . "utf-8")))))
 
diff --git a/tests/guile/cantius-test.scm b/tests/guile/cantius-test.scm
index 1e11586..4d9a6d6 100644
--- a/tests/guile/cantius-test.scm
+++ b/tests/guile/cantius-test.scm
@@ -13,7 +13,7 @@
              ((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 match) #:select (match-lambda))
              ((ice-9 regex) #:select (regexp-substitute/global))
              ((web client) #:select (open-socket-for-uri http-get))
              ((web request) #:prefix req:)
@@ -74,26 +74,29 @@ value
 (tu:test-group "parse-multipart/form-data"
   (for-each
    (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 "\
+     (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))))))
+                                  boundary data-length form-data))
+
+            (parsed-alist
+             (delay (call-with-input-string request-text
+                      (lambda (port)
+                        (let* ((request (req:read-request port))
+                               (body (req:read-request-body request)))
+                          (cant:$ let*-values ((() (apply values cant:$-args)))
+                            (cant:$ cant:multipart/form-data*
+                              ((cant$request request)
+                               (cant$body body)))))))))
+
+            (parsed (delay (reverse (map cdr (force parsed-alist))))))
        (tu:test-eqv 3 (length (force parsed)))
 
        (tu:test-equal (force parsed-alist)
@@ -142,15 +145,36 @@ Content-Length: ~d
   (tu:test-equal '(("name" . "val"))
                  (cant:parse-cookies "name=val;"))
 
-  (tu:test-equal '(("ses sion" . "fargtrg34")
-                   ("s" . "f")
-                   ("forms-session2" . "")
-                   ("forms-sessio n3" . "f4 3433=g = 4"))
-                 (cant:parse-cookies
-                  (string-append "\t\tses sion =fargtrg34;"
-                                 " s = f;"
-                                 "forms-session2=\n;"
-                                 " forms-sessio n3=f4 3433=g = 4")))
+  (for-each (match-lambda
+              ((alist request-text)
+               (tu:test-equal alist
+                              (cant:$ let*-values ((() (apply values
+                                                              cant:$-args)))
+                                (let ((request (call-with-input-string
+                                                   request-text
+                                                 req:read-request)))
+                                  (cant:$ cant:cookies
+                                          ((cant$request request))))))))
+            `(((("ses sion" . "fargtrg34")
+                ("s" . "f")
+                ("forms-session2" . "")
+                ("forms-sessio n3" . "f4 3433=g = 4"))
+               ,(format #f "\
+GET /dummy HTTP/1.0
+Host: example.com
+Cookie: ~
+~/~/ses sion =fargtrg34;~
+ s = f  ;~
+forms-session2=~/;~
+ forms-sessio n3=f4 3433=g = 4
+
+"))
+              (()
+               "\
+GET /dummy HTTP/1.0
+Host: example.com
+
+")))
 
   (tu:test-equal '() (cant:parse-cookies ""))
 
@@ -232,7 +256,7 @@ Content-Length: ~d
                     (cant:$ values ((cant$redirect/normalize-path? #f)
                                     (cant$redirect/remove-query? #f))))
 
-                  (values (cant:build-response* cant$default-headers)
+                  (values (cant:$ cant:response)
                           "Google provides the best services in the world..."))
 
                 (cant:define-endpoint %my-endset