guix/tests/http.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix tests http)
  21   #:use-module (ice-9 threads)
  22   #:use-module (web server)
  23   #:use-module (web server http)
  24   #:use-module (web response)
  25   #:use-module (srfi srfi-11)
  26   #:use-module (srfi srfi-39)
  27   #:use-module (ice-9 match)
  28   #:export (with-http-server
  29             call-with-http-server
  30             %http-server-port
  31             %local-url))
  32
  33 ;;; Commentary:
  34 ;;;
  35 ;;; Code to spawn a Web server for testing purposes.
  36 ;;;
  37 ;;; Code:
  38
  39 (define %http-server-port
  40   ;; TCP port to use for the stub HTTP server.
  41   ;; If 0, the OS will automatically choose
  42   ;; a port.
  43   (make-parameter 0))
  44
  45 (define (open-http-server-socket)
  46   "Return a listening socket for the web server and the port
  47 actually listened at (in case %http-server-port was 0)."
  48   (catch 'system-error
  49     (lambda ()
  50       (let ((sock (socket PF_INET SOCK_STREAM 0)))
  51         (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
  52         (bind sock
  53               (make-socket-address AF_INET INADDR_LOOPBACK
  54                                    (%http-server-port)))
  55         (values sock
  56                 (sockaddr:port (getsockname sock)))))
  57     (lambda args
  58       (let ((err (system-error-errno args)))
  59         (format (current-error-port)
  60                 "warning: cannot run Web server for tests: ~a~%"
  61                 (strerror err))
  62         (values #f #f)))))
  63
  64 (define* (%local-url #:optional (port (%http-server-port)))
  65   (when (= port 0)
  66     (error "no web server is running!"))
  67   ;; URL to use for 'home-page' tests.
  68   (string-append "http://localhost:" (number->string port)
  69                  "/foo/bar"))
  70
  71 (define* (call-with-http-server responses+data thunk)
  72   "Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP
  73 requests.  Each element of RESPONSES+DATA must be a tuple containing a
  74 response and a string, or an HTTP response code and a string.
  75
  76 %http-server-port will be set to the port listened at
  77 The port listened at will be set for the dynamic extent of THUNK."
  78   (define responses
  79     (map (match-lambda
  80            (((? response? response) data)
  81             (list response data))
  82            (((? integer? code) data)
  83             (list (build-response #:code code
  84                                   #:reason-phrase "Such is life")
  85                   data)))
  86          responses+data))
  87
  88   (define (http-write server client response body)
  89     "Write RESPONSE."
  90     (let* ((response (write-response response client))
  91            (port     (response-port response)))
  92       (cond
  93        ((not body))                               ;pass
  94        (else
  95         (write-response-body response body)))
  96       (close-port port)
  97       (when (null? responses)
  98         (quit #t))                                ;exit the server thread
  99       (values)))
 100
 101   ;; Mutex and condition variable to synchronize with the HTTP server.
 102   (define %http-server-lock (make-mutex))
 103   (define %http-server-ready (make-condition-variable))
 104   (define %http-real-server-port #f)
 105
 106   (define (http-open . args)
 107     "Start listening for HTTP requests and signal %HTTP-SERVER-READY."
 108     (with-mutex %http-server-lock
 109       (let ((result (apply (@@ (web server http) http-open) args)))
 110         (signal-condition-variable %http-server-ready)
 111         result)))
 112
 113   (define-server-impl stub-http-server
 114     ;; Stripped-down version of Guile's built-in HTTP server.
 115     http-open
 116     (@@ (web server http) http-read)
 117     http-write
 118     (@@ (web server http) http-close))
 119
 120   (define (server-body)
 121     (define (handle request body)
 122       (match responses
 123         (((response data) rest ...)
 124          (set! responses rest)
 125          (values response data))))
 126
 127     (let-values (((socket port) (open-http-server-socket)))
 128       (set! %http-real-server-port port)
 129       (catch 'quit
 130         (lambda ()
 131           (run-server handle stub-http-server
 132                       `(#:socket ,socket)))
 133         (lambda _
 134           (close-port socket)))))
 135
 136   (with-mutex %http-server-lock
 137     (let ((server (make-thread server-body)))
 138       (wait-condition-variable %http-server-ready %http-server-lock)
 139       ;; Normally SERVER exits automatically once it has received a request.
 140       (parameterize ((%http-server-port %http-real-server-port))
 141         (thunk)))))
 142
 143 (define-syntax with-http-server
 144   (syntax-rules ()
 145     ((_ responses+data body ...)
 146      (call-with-http-server responses+data (lambda () body ...)))))
 147
 148 ;;; http.scm ends here