guix/tests/http.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017 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   #:export (with-http-server
  26             call-with-http-server
  27             %http-server-port
  28             http-server-can-listen?
  29             %local-url))
  30
  31 ;;; Commentary:
  32 ;;;
  33 ;;; Code to spawn a Web server for testing purposes.
  34 ;;;
  35 ;;; Code:
  36
  37 (define %http-server-port
  38   ;; TCP port to use for the stub HTTP server.
  39   (make-parameter 9999))
  40
  41 (define (open-http-server-socket)
  42   "Return a listening socket for the web server.  It is useful to export it so
  43 that tests can check whether we succeeded opening the socket and tests skip if
  44 needed."
  45   (catch 'system-error
  46     (lambda ()
  47       (let ((sock (socket PF_INET SOCK_STREAM 0)))
  48         (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
  49         (bind sock
  50               (make-socket-address AF_INET INADDR_LOOPBACK
  51                                    (%http-server-port)))
  52         sock))
  53     (lambda args
  54       (let ((err (system-error-errno args)))
  55         (format (current-error-port)
  56                 "warning: cannot run Web server for tests: ~a~%"
  57                 (strerror err))
  58         #f))))
  59
  60 (define (http-server-can-listen?)
  61   "Return #t if we managed to open a listening socket."
  62   (and=> (open-http-server-socket)
  63          (lambda (socket)
  64            (close-port socket)
  65            #t)))
  66
  67 (define (%local-url)
  68   ;; URL to use for 'home-page' tests.
  69   (string-append "http://localhost:" (number->string (%http-server-port))
  70                  "/foo/bar"))
  71
  72 (define* (call-with-http-server code data thunk
  73                                 #:key (headers '()))
  74   "Call THUNK with an HTTP server running and returning CODE and DATA (a
  75 string) on HTTP requests."
  76   (define (http-write server client response body)
  77     "Write RESPONSE."
  78     (let* ((response (write-response response client))
  79            (port     (response-port response)))
  80       (cond
  81        ((not body))                               ;pass
  82        (else
  83         (write-response-body response body)))
  84       (close-port port)
  85       (quit #t)                                   ;exit the server thread
  86       (values)))
  87
  88   ;; Mutex and condition variable to synchronize with the HTTP server.
  89   (define %http-server-lock (make-mutex))
  90   (define %http-server-ready (make-condition-variable))
  91
  92   (define (http-open . args)
  93     "Start listening for HTTP requests and signal %HTTP-SERVER-READY."
  94     (with-mutex %http-server-lock
  95       (let ((result (apply (@@ (web server http) http-open) args)))
  96         (signal-condition-variable %http-server-ready)
  97         result)))
  98
  99   (define-server-impl stub-http-server
 100     ;; Stripped-down version of Guile's built-in HTTP server.
 101     http-open
 102     (@@ (web server http) http-read)
 103     http-write
 104     (@@ (web server http) http-close))
 105
 106   (define (server-body)
 107     (define (handle request body)
 108       (values (build-response #:code code
 109                               #:reason-phrase "Such is life"
 110                               #:headers headers)
 111               data))
 112
 113     (let ((socket (open-http-server-socket)))
 114       (catch 'quit
 115         (lambda ()
 116           (run-server handle stub-http-server
 117                       `(#:socket ,socket)))
 118         (lambda _
 119           (close-port socket)))))
 120
 121   (with-mutex %http-server-lock
 122     (let ((server (make-thread server-body)))
 123       (wait-condition-variable %http-server-ready %http-server-lock)
 124       ;; Normally SERVER exits automatically once it has received a request.
 125       (thunk))))
 126
 127 (define-syntax with-http-server
 128   (syntax-rules ()
 129     ((_ (code headers) data body ...)
 130      (call-with-http-server code data (lambda () body ...)
 131                             #:headers headers))
 132     ((_ code data body ...)
 133      (call-with-http-server code data (lambda () body ...)))))
 134
 135 ;;; http.scm ends here