Add some helpers for handling request bodies

knots/web-server.scm

@@ -42,6 +42,12 @@
 
             make-chunked-output-port/knots
 
+            &request-body-ended-prematurely
+            request-body-ended-prematurely-error?
+
+            request-body-port/knots
+            read-request-body/knots
+
             default-exception-handler
             default-write-response-exception-handler
 
@@ -85,6 +91,75 @@ KEEP-ALIVE? is true."
   (setvbuf ret 'block buffering)
   ret)
 
+(define* (make-delimited-input-port port len fail
+                                    #:key (keep-alive? #t))
+  "Return an input port that reads from PORT, and makes sure that
+exactly LEN bytes are available from PORT.  Closing the returned port
+closes PORT, unless KEEP-ALIVE? is true."
+  (define bytes-read 0)
+
+  (define (read! bv start count)
+    (let ((count (min count (- len bytes-read))))
+      (let loop ((ret (get-bytevector-n! port bv start count)))
+        (cond ((eof-object? ret)
+               (if (= bytes-read len)
+                   0                              ; EOF
+                   (fail bytes-read)))
+              ((and (zero? ret) (> count 0))
+               ;; Do not return zero since zero means EOF, so try again.
+               (loop (get-bytevector-n! port bv start count)))
+              (else
+               (set! bytes-read (+ bytes-read ret))
+               ret)))))
+
+  (define close
+    (and (not keep-alive?)
+         (lambda ()
+           (close-port port))))
+
+  (make-custom-binary-input-port "delimited input port" read! #f #f close))
+
+;; Chunked Responses
+(define &request-body-ended-prematurely
+  (make-exception-type '&request-body-ended-prematurely
+                       &external-error
+                       '(bytes-read)))
+
+(define make-request-body-ended-prematurely-error
+  (record-constructor &request-body-ended-prematurely))
+
+(define request-body-ended-prematurely-error?
+  (record-predicate &request-body-ended-prematurely))
+
+(define (request-body-port/knots r)
+  (cond
+   ((member '(chunked) (request-transfer-encoding r))
+    (make-chunked-input-port (request-port r)
+                             #:keep-alive? #t))
+   (else
+    (let ((content-length
+           (request-content-length r)))
+      (make-delimited-input-port
+       (request-port r)
+       content-length
+       (lambda (bytes-read)
+         (raise-exception
+          (make-request-body-ended-prematurely-error bytes-read))))))))
+
+(define (read-request-body/knots r)
+  (cond
+   ((member '(chunked) (request-transfer-encoding r))
+    (get-bytevector-all
+     (request-body-port/knots r)))
+   (else
+    (let ((content-length
+           (request-content-length r)))
+      (if content-length
+          (get-bytevector-n
+           (request-body-port/knots r)
+           content-length)
+          #f)))))
+
 (define (extend-response r k v . additional)
   (define (extend-alist alist k v)
     (let ((pair (assq k alist)))

tests/web-server.scm

@@ -150,6 +150,74 @@
         (utf8->string
          (get-bytevector-n body 3)))))))
 
+(run-fibers-for-tests
+ (lambda ()
+   (let* ((web-server
+           (run-knots-web-server
+            (lambda (request)
+              (if (string=? (utf8->string
+                             (read-request-body/knots request))
+                            "☺")
+                  (values (build-response #:code 200)
+                          "")
+                  (values (build-response #:code 500)
+                          "")))
+            #:port 0)) ;; Bind to any port
+          (port
+           (web-server-port web-server))
+          (uri
+           (build-uri 'http #:host "127.0.0.1" #:port port)))
+
+     (let ((response
+            body
+            (http-post
+             uri
+             #:body "☺"
+             #:port (non-blocking-open-socket-for-uri uri))))
+       (assert-equal
+        200
+        (response-code response))))))
+
+(run-fibers-for-tests
+ (lambda ()
+   (let* ((channel (make-channel))
+          (web-server
+           (run-knots-web-server
+            (lambda (request)
+              (with-exception-handler
+                  (lambda (exn)
+                    (put-message channel exn))
+                (lambda ()
+                  (read-request-body/knots request))
+                #:unwind? #t))
+            #:port 0)) ;; Bind to any port
+          (port
+           (web-server-port web-server))
+          (uri
+           (build-uri 'http #:host "127.0.0.1" #:port port)))
+
+     (let* ((port (non-blocking-open-socket-for-uri uri))
+            (request
+             (build-request
+              uri
+              #:method 'POST
+              #:version '(1 . 1)
+              #:headers `((connection close)
+                          (content-length . 20)
+                          (Content-Type . "application/octet-stream"))
+              #:port port)))
+
+       (set-port-encoding! port "ISO-8859-1")
+       (let ((request (write-request request port)))
+         (display "12")
+         (force-output port)
+
+         (close-port port)))
+
+     (assert-true
+      (request-body-ended-prematurely-error?
+       (get-message channel))))))
+
 ;; Test hanlding of exceptions when writing the response to a client
 (run-fibers-for-tests
  (lambda ()