Ticket #688: default-reason-phrases.patch

tests/run.scm

@@ -933 +933 @@
             (update-response
              res
              headers: (headers `((transfer-encoding chunked))))
-            "foo" "1234567890")))))
+            "foo" "1234567890"))))
+  (test-group "Reason phrase"
+    (let ((res (make-response major: 1 minor: 1)))
+      (test "is added implicitly for known codes when not set"
+            "HTTP/1.1 409 Conflict\r\n\r\ntest"
+            (test-write-response
+             (update-response res code: 409)
+             "test"))
+      (test-error "when not set an error is raised for unknown status codes"
+                  (test-write-response 
+                   (update-response res code: 999)
+                   "test"))
+      (test "unknown status can still be used when a reason is given"
+            "HTTP/1.1 999 No Way\r\n\r\ntest"
+            (test-write-response 
+             (update-response res code: 999 reason: "No Way")
+             "test"))
+      (test "defaults can be parameterized"
+            "HTTP/1.1 999 Say What\r\n\r\ntest"
+            (parameterize ((http-status-codes (alist-cons 999 "Say What" (http-status-codes))))
+              (test-write-response
+               (update-response res code: 999)
+               "test"))))))
 
 (test-group "Etag comparison procedures"
   (test-group "Weak comparison"

intarweb.scm

@@ -61 +61 @@
    write-response response-parsers response-unparsers read-response
    http-0.9-response-parser http-1.x-response-parser
    http-0.9-response-unparser http-1.x-response-unparser
+   http-status-codes
 
    ;; http-header-parsers
    header-contents header-values header-value header-params header-param
@@ -557 +558 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defstruct response
-  (code 200) (reason "OK") (major 1) (minor 1) (headers (make-headers '())) port)
+  (code 200) reason (major 1) (minor 1) (headers (make-headers '())) port)
 
+(define http-status-codes
+  (make-parameter 
+   `((100 . "Continue")
+     (101 . "Switching Protocols")
+     (200 . "OK")
+     (201 . "Created")
+     (202 . "Accepted")
+     (203 . "Non-Authoritative Information")
+     (204 . "No Content")
+     (205 . "Reset Content")
+     (206 . "Partial Content")
+     (300 . "Multiple Choices")
+     (301 . "Moved Permanently")
+     (302 . "Found")
+     (303 . "See Other")
+     (304 . "Not Modified")
+     (305 . "Use Proxy")
+     (307 . "Temporary Redirect")
+     (400 . "Bad Request")
+     (401 . "Unauthorized")
+     (402 . "Payment Required")
+     (403 . "Forbidden")
+     (404 . "Not Found")
+     (405 . "Method Not Allowed")
+     (406 . "Not Acceptable")
+     (407 . "Proxy Authentication Required")
+     (408 . "Request Time-out")
+     (409 . "Conflict")
+     (410 . "Gone")
+     (411 . "Length Required")
+     (412 . "Precondition Failed")
+     (413 . "Request Entity Too Large")
+     (414 . "Request-URI Too Large")
+     (415 . "Unsupported Media Type")
+     (416 . "Requested range not satisfiable")
+     (417 . "Expectation Failed")
+     (500 . "Internal Server Error")
+     (501 . "Not Implemented")
+     (502 . "Bad Gateway")
+     (503 . "Service Unavailable")
+     (504 . "Gateway Time-out")
+     (505 . "HTTP Version not supported"))))
+
 (define (http-0.9-response-unparser response)
   response) ;; The response-body will just follow
 
@@ -568 +612 @@
            (response-major response)
            (response-minor response)
            (response-code response)
-           (response-reason response)))
+           (or (response-reason response)
+               (alist-ref (response-code response) (http-status-codes))
+               (signal-http-condition "Unknown status code" 'unknown-status-code
+                                      'code (response-code response)))))
 
 (define (http-1.0-response-unparser response)
   (and-let* (((= (response-major response) 1))