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