Handle HEAD requests through GET routes

ober

70477ca9ebf9d33cfd6793fad984d5206dbe5d65

diff --git a/sinatra/handler-test.ss b/sinatra/handler-test.ss
index 5ac7514..22930ae 100644
--- a/sinatra/handler-test.ss
+++ b/sinatra/handler-test.ss
@@ -40,6 +40,17 @@
               (check (request-status resp) => 200)
               (check (request-text resp) => "Hello World"))))))
 
+    (test-case "HEAD falls back to GET route without body"
+      (let ((app (make-sinatra-app)))
+        (sinatra-get app "/"
+          (lambda ()
+            (content-type! "text/plain; charset=utf-8")
+            "Hello World"))
+        (let* ((handler (sinatra-handler app))
+               (resp (handler (th:make-request "HEAD" "/" "HTTP/1.1" '() ""))))
+          (check (th:response-status resp) => 200)
+          (check (th:response-body resp) => ""))))
+
     (test-case "route with named parameter"
       (let ((app (make-sinatra-app)))
         (sinatra-get app "/hello/:name"
diff --git a/sinatra/handler.ss b/sinatra/handler.ss
index 06f371f..bb0394f 100644
--- a/sinatra/handler.ss
+++ b/sinatra/handler.ss
@@ -1,5 +1,6 @@
 (import (std text json)
         (std sugar)
+        (prefix (std net thread-httpd) th:)
         (sinatra context)
         (sinatra request)
         (sinatra response)
@@ -42,14 +43,16 @@
                      (try
                      ;; Handle method override if enabled
                      (let ((effective-method
-                            (if (and (eq? method 'POST)
-                                     (app-setting app "method-override"))
-                              (let ((override (or (hash-get (sinatra-request-query-params sreq) "_method")
-                                                  #f)))
-                                (if override
-                                  (string->symbol (string-upcase override))
-                                  method))
-                              method)))
+                            (cond
+                              ((eq? method 'HEAD) 'GET)
+                              ((and (eq? method 'POST)
+                                    (app-setting app "method-override"))
+                               (let ((override (or (hash-get (sinatra-request-query-params sreq) "_method")
+                                                   #f)))
+                                 (if override
+                                   (string->symbol (string-upcase override))
+                                   method)))
+                              (else method))))
 
                        ;; 1. Check static files first
                        (when (and (eq? effective-method 'GET)
@@ -85,8 +88,17 @@
 
           ;; Return final response unless a direct static response was produced.
           (apply-forced-headers! app sres)
-          (or direct-response
-              (sinatra-response-write! sres #f)))))))
+          (without-head-body method
+            (or direct-response
+                (sinatra-response-write! sres #f))))))))
+
+(def (without-head-body method resp)
+  (if (and (eq? method 'HEAD)
+           (th:response? resp))
+    (th:respond (th:response-status resp)
+                (th:response-headers resp)
+                "")
+    resp))
 
 (def (apply-forced-headers! app sres)
   (let ((forced (app-setting app "force-headers")))