guile-knots/tests/web-server.scm

(use-modules (srfi srfi-71)
             (rnrs bytevectors)
             (ice-9 binary-ports)
             (ice-9 textual-ports)
             (tests)
             (fibers)
             (fibers channels)
             (unit-test)
             (web uri)
             (web client)
             (web request)
             (web response)
             (knots web-server)
             (knots non-blocking))

(run-fibers-for-tests
 (lambda ()
   (let* ((web-server
           (run-knots-web-server
            (lambda (request)
              (values '((content-type . (text/plain)))
                      "Hello, World!"))
            #:port 0)) ;; Bind to any port
          (port
           (web-server-port web-server))
          (uri
           (build-uri 'http #:host "127.0.0.1" #:port port)))

     (assert-equal
      200
      (response-code
       (http-get
        uri
        #:port (non-blocking-open-socket-for-uri uri)))))))

(run-fibers-for-tests
 (lambda ()
   (let* ((web-server
           (run-knots-web-server
            (lambda (request)
              "Hello, World!")
            #:port 0)) ;; Bind to any port
          (port
           (web-server-port web-server))
          (uri
           (build-uri 'http #:host "127.0.0.1" #:port port)))

     (assert-equal
      500
      (response-code
       (http-get
        uri
        #:port (non-blocking-open-socket-for-uri uri)))))))

(run-fibers-for-tests
 (lambda ()
   (let* ((web-server
           (run-knots-web-server
            (lambda (request)
              "Hello, World!")
            #:port 0
            #:exception-handler
            (lambda (exn request)
              "Error"))) ;; Bind to any port
          (port
           (web-server-port web-server))
          (uri
           (build-uri 'http #:host "127.0.0.1" #:port port)))

     (assert-equal
      500
      (response-code
       (http-get
        uri
        #:port (non-blocking-open-socket-for-uri uri)))))))

(run-fibers-for-tests
 (lambda ()
   (let* ((web-server
           (run-knots-web-server
            (lambda (request)
              (values '((content-type . (text/plain))
                        (content-length . 3))
                      (lambda (port)
                        (display "foo" port))))
            #: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-get
             uri
             #:port (non-blocking-open-socket-for-uri uri))))
       (assert-equal
        "foo"
        body)))))

(run-fibers-for-tests
 (lambda ()
   (let* ((web-server
           (run-knots-web-server
            (lambda (request)
              (values '((content-type . (text/plain
                                         (charset . "utf-8"))))
                      (lambda (port)
                        (display "☺" port))))
            #: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-get
             uri
             #:port (non-blocking-open-socket-for-uri uri))))
       (assert-equal
        "☺"
        body)))))

(run-fibers-for-tests
 (lambda ()
   (let* ((web-server
           (run-knots-web-server
            (lambda (request)
              (values '((content-type . (text/plain
                                         (charset . "utf-8")))
                        (content-length . 3))
                      (lambda (port)
                        (display "☺" port))))
            #: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-get
             uri
             ;; TODO Remove once using Guile 3.0.10
             #:streaming? #t
             #:port (non-blocking-open-socket-for-uri uri))))
       (assert-equal
        "☺"
        (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 ()
   (let* ((exception-handled-sucecssfully-channel
           (make-channel))
          (port-closed-channel (make-channel))
          (web-server
           (run-knots-web-server
            (lambda (request)
              ;; TODO Not sure why buffering makes a difference here
              (setvbuf (request-port request) 'none)
              (get-message port-closed-channel)
              (values '((content-type . (text/plain)))
                      "Hello, World!"))
            #:write-response-exception-handler
            (lambda (exn request)
              (spawn-fiber
               (lambda ()
                 (put-message exception-handled-sucecssfully-channel
                              #t)))
              #f)
            #:port 0)) ;; Bind to any port
          (port
           (web-server-port web-server))
          (uri
           (build-uri 'http #:host "127.0.0.1" #:port port)))

     (let ((request-port (non-blocking-open-socket-for-uri uri)))
       (write-request
        (build-request uri)
        request-port)
       (close-port request-port))
     (put-message port-closed-channel #t)

     (assert-equal (get-message exception-handled-sucecssfully-channel)
                   #t))))

(display "web-server test finished successfully\n")