Improve the mechanism of conditions tied to HTTP error codes.

Tere's now an extra `&condition-with-http-code' type that can be raised to
trigger an appropriate HTTP response.  This is meant to be used for all HTTP
codes other than those few that have their own condition types.

1 files changed, 46 insertions, 9 deletions

diff --git a/src/guile/cantius.scm b/src/guile/cantius.scm
index bd67a24..e51a32e 100644
--- a/src/guile/cantius.scm
+++ b/src/guile/cantius.scm
@@ -34,6 +34,18 @@
 (s35:define-condition-type &forbidden s35:&condition
   forbidden-condition?)
 
+(export &bad-request)
+(export bad-request-condition?)
+(s35:define-condition-type &bad-request s35:&condition
+  bad-request-condition?)
+
+(export &condition-with-http-code)
+(export condition-with-http-code?)
+
+(s35:define-condition-type &condition-with-http-code s35:&condition
+  condition-with-http-code?
+  (http-code condition-http-code))
+
 (define-public (normalize-path path)
   (define absolute?
     (eqv? #\/ (string-ref path 0)))
@@ -111,20 +123,32 @@
 (define-public %default-headers
   (make-parameter *%default-headers))
 
-(define-public %default-handler
-  (make-parameter (lambda (request body . _)
+(define (make-handler-parameter http-code default-message)
+  (make-parameter (lambda* (request body #:key message)
                     (values (build-response* #:headers *%default-headers
-                                             #:code 404)
-                            "There's no page with this address :("))))
+                                             #:code http-code)
+                            (or message default-message)))))
 
 (define-public %not-found-handler
-  (make-parameter (%default-handler)))
+  (make-handler-parameter 404 "There's no page with this address :("))
 
 (define-public %forbidden-handler
-  (make-parameter (lambda (request body . _)
+  (make-handler-parameter 403 "You. Shall not. Pass. (forbidden)"))
+
+(define-public %bad-request-handler
+  (make-handler-parameter 400 "Bad Request (you or your software seems to have messed sth up)."))
+
+(define-public %default-handler
+  (let ((not-found-handler (%not-found-handler)))
+    (make-parameter (lambda (request body . _)
+                      (not-found-handler request body)))))
+
+(define-public %other-codes-handler
+  (make-parameter (lambda* (request body http-code #:key message)
                     (values (build-response* #:headers *%default-headers
-                                             #:code 403)
-                            "You. Shall not. Pass. (forbidden)"))))
+                                             #:code http-code)
+                            (or message
+                                (format #f "HTTP code ~d" http-code))))))
 
 
 
@@ -429,8 +453,21 @@
                   (start-stack 'cantius-request
                     (guard (ex ((s35:condition-has-type? ex &not-found)
                                 ((%not-found-handler) request body))
+
                                ((s35:condition-has-type? ex &forbidden)
-                                ((%forbidden-handler) request body)))
+                                ((%forbidden-handler) request body))
+
+                               ((s35:condition-has-type? ex &bad-request)
+                                ((%bad-request-handler) request body))
+
+                               ((s35:condition-has-type?
+                                 ex &condition-with-http-code)
+                                ((%other-codes-handler) request body
+                                 (condition-http-code ex)
+                                 #:message
+                                 (and (s35:condition-has-type? ex s35:&message)
+                                      (s35:condition-message ex)))))
+
                       (apply (endpoint-handler endpoint) request body
                              (or (and=> path-tail list) '()))))))))))