web: Raise &http-error condition on failure.

1 files changed, 14 insertions, 11 deletions

diff --git a/kaagum/web.scm b/kaagum/web.scm
index 7aa8595..e2f9877 100644
--- a/kaagum/web.scm
+++ b/kaagum/web.scm
@@ -24,7 +24,11 @@
   #:use-module (web response)
   #:use-module (kaagum trace)
   #:use-module (json)
-  #:export (uri-join
+  #:export (http-error
+            http-error?
+            http-error-code
+
+            uri-join
             json-request
             json-get
             json-post))
@@ -33,6 +37,11 @@
 ;; with it.
 (declare-opaque-header! "Authorization")
 
+(define-condition-type &http-error &error
+  http-error http-error?
+  (code http-error-code)
+  (reason-phrase http-error-reason-phrase))
+
 ;; TODO: URIs must not be operated on using string operations. Replace with a
 ;; more principled implementation involving (web uri).
 (define (uri-join base uri)
@@ -40,7 +49,8 @@
 
 (define* (json-request method url #:key (headers '()) body)
   "Send a HTTP @var{method} request to @var{url} with @var{body} and
-additional @var{headers}. Return JSON response."
+additional @var{headers}. Return JSON response. Raise @code{&http-error}
+condition on failure."
   (if body
       (trace 'web "-> ~a ~a ~a" method url body)
       (trace 'web "-> ~a ~a" method url))
@@ -58,18 +68,11 @@ additional @var{headers}. Return JSON response."
       ((2) (let ((result (json->scm body)))
              (trace 'web "<- ~a ~a" (response-code response) (scm->json-string result))
              result))
-      ((4)
-       (trace 'web "<- ~a" (response-code response))
-       (raise-exception
-        (condition (make-violation)
-                   (make-irritants-condition (list method url headers body))
-                   (make-message-condition
-                    (string-append "JSON API request failed with client error code "
-                                   (number->string (response-code response)))))))
       (else
        (trace 'web "<- ~a" (response-code response))
        (raise-exception
-        (condition (make-error)
+        (condition (http-error (response-code response)
+                               (response-reason-phrase response))
                    (make-irritants-condition (list method url headers body))
                    (make-message-condition
                     (string-append "JSON API request failed with code "