Fix some issues handling head requests

Rather than raising an exception when there's a body provided, use the
body as normal to inform the headers, as this is useful, and just
don't write the body to the client.

knots/web-server.scm

@@ -228,8 +228,6 @@ on the procedure being called at any particular time."
                        (adapt-response-version response
                                                (request-version request))
                        body))
-   ((not body)
-    (values response #vu8()))
    ((string? body)
     (let* ((type (response-content-type response
                                         '(text/plain)))
@@ -243,16 +241,15 @@ on the procedure being called at any particular time."
                             `(,@type (charset . ,charset))))
        (string->bytevector body charset))))
    ((not (or (bytevector? body)
-             (procedure? body)))
+             (procedure? body)
+             (eq? #f body)))
     (raise-exception
      (make-exception-with-irritants
       (list (make-exception-with-message
              "unexpected body type")
             body))))
    ((and (response-must-not-include-body? response)
-         body
+         body)
-         ;; FIXME make this stricter: even an empty body should be prohibited.
-         (not (zero? (bytevector-length body))))
     (raise-exception
      (make-exception-with-irritants
       (list (make-exception-with-message
@@ -262,25 +259,24 @@ on the procedure being called at any particular time."
     ;; check length; assert type; add other required fields?
     (values (response-maybe-add-connection-header-value
              request
-             (if (procedure? body)
+             (cond
+              ((procedure? body)
                (if (response-content-length response)
                    response
                    (extend-response response
                                     'transfer-encoding
-                                      '((chunked))))
+                                    '((chunked)))))
+              ((bytevector? body)
                (let ((rlen (response-content-length response))
                      (blen (bytevector-length body)))
                  (cond
                   (rlen (if (= rlen blen)
                             response
                             (error "bad content-length" rlen blen)))
-                    (else (extend-response response 'content-length blen))))))
+                  (else (extend-response response 'content-length blen)))))
+              (else response)))
             (if (eq? (request-method request) 'HEAD)
-                (raise-exception
+                #f
-                 (make-exception-with-irritants
-                  (list (make-exception-with-message
-                         "unexpected body type")
-                        body)))
                 body)))))
 
 (define (with-stack-and-prompt thunk)
@@ -405,7 +401,11 @@ on the procedure being called at any particular time."
           (let ((response-start-time
                  (get-internal-real-time))
                 (body-written?
-                 (if (procedure? body)
+                 (cond
+                  ((and (procedure? body)
+                        (not
+                         (eq? (request-method request)
+                              'HEAD)))
                    (let* ((type (response-content-type response
                                                        '(text/plain)))
                           (declared-charset (assq-ref (cdr type) 'charset))
@@ -436,9 +436,12 @@ on the procedure being called at any particular time."
                               #:unwind? #t)))
                        (unless (response-content-length response)
                          (close-port body-port))
-                         body-written?))
+                       body-written?)))
-                     (begin
+                  ((bytevector? body)
                    (put-bytevector client body)
+                   #t)
+                  (else
+                   ;; No body to write
                    #t))))
             (if body-written?
                 (begin

tests/web-server.scm

@@ -1,5 +1,6 @@
 (use-modules (srfi srfi-71)
              (rnrs bytevectors)
+             (ice-9 match)
              (ice-9 binary-ports)
              (ice-9 textual-ports)
              (tests)
@@ -233,4 +234,68 @@
      (assert-equal (get-message exception-handled-sucecssfully-channel)
                    #t))))
 
+(run-fibers-for-tests
+ (lambda ()
+   (let* ((web-server
+           (run-knots-web-server
+            (lambda (request)
+              (match (split-and-decode-uri-path
+                      (uri-path (request-uri request)))
+                (("head-no-body")
+                 (values '((content-type . (text/plain)))
+                         #f))
+                (("head-empty-body")
+                 (values '((content-type . (text/plain)))
+                         ""))
+                (("head-no-body-with-content-length")
+                 (values '((content-type . (text/plain))
+                           (content-length . 10))
+                         #f))
+                (("head-with-body")
+                 (values '((content-type . (text/plain)))
+                         "foo"))
+                (("head-procedure-body")
+                 (values '((content-type . (text/plain)))
+                         (lambda _
+                           (error "should not be run"))))
+                (("head-procedure-body-with-content-length")
+                 (values '((content-type . (text/plain))
+                           (content-length . 10))
+                         (lambda _
+                           (error "should not be run"))))))
+            #:port 0)) ;; Bind to any port
+          (port
+           (web-server-port web-server)))
+
+     (define* (head path)
+       (let ((uri
+              (build-uri 'http #:host "127.0.0.1" #:port port
+                         #:path path)))
+         (http-head
+          uri
+          #:port (non-blocking-open-socket-for-uri uri))))
+
+     (let ((response
+            (head "/head-no-body")))
+       (assert-equal 200 (response-code response)))
+     (let ((response
+            (head "/head-empty-body")))
+       (assert-equal 200 (response-code response))
+       (assert-equal 0 (response-content-length response)))
+     (let ((response
+            (head "/head-no-body-with-content-length")))
+       (assert-equal 200 (response-code response))
+       (assert-equal 10 (response-content-length response)))
+     (let ((response
+            (head "/head-with-body")))
+       (assert-equal 200 (response-code response))
+       (assert-equal 3 (response-content-length response)))
+     (let ((response
+            (head "/head-procedure-body")))
+       (assert-equal 200 (response-code response)))
+     (let ((response
+            (head "/head-procedure-body-with-content-length")))
+       (assert-equal 200 (response-code response))
+       (assert-equal 10 (response-content-length response))))))
+
 (display "web-server test finished successfully\n")