;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix tests http)
  #:use-module (ice-9 threads)
  #:use-module (web server)
  #:use-module (web server http)
  #:use-module (web response)
  #:use-module (srfi srfi-39)
  #:export (with-http-server
            call-with-http-server
            %http-server-port
            %http-server-socket
            %local-url))

;;; Commentary:
;;;
;;; Code to spawn a Web server for testing purposes.
;;;
;;; Code:

(define %http-server-port
  ;; TCP port to use for the stub HTTP server.
  (make-parameter 9999))

(define (%local-url)
  ;; URL to use for 'home-page' tests.
  (string-append "http://localhost:" (number->string (%http-server-port))
                 "/foo/bar"))

(define %http-server-socket
  ;; Listening socket for the web server.  It is useful to export it so that
  ;; tests can check whether we succeeded opening the socket and tests skip if
  ;; needed.
  (delay
    (catch 'system-error
      (lambda ()
        (let ((sock (socket PF_INET SOCK_STREAM 0)))
          (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
          (bind sock
                (make-socket-address AF_INET INADDR_LOOPBACK
                                     (%http-server-port)))
          sock))
      (lambda args
        (let ((err (system-error-errno args)))
          (format (current-error-port)
                  "warning: cannot run Web server for tests: ~a~%"
                  (strerror err))
          #f)))))

(define (http-write server client response body)
  "Write RESPONSE."
  (let* ((response (write-response response client))
         (port     (response-port response)))
    (cond
     ((not body))                                 ;pass
     (else
      (write-response-body response body)))
    (close-port port)
    (quit #t)                                     ;exit the server thread
    (values)))

;; Mutex and condition variable to synchronize with the HTTP server.
(define %http-server-lock (make-mutex))
(define %http-server-ready (make-condition-variable))

(define (http-open . args)
  "Start listening for HTTP requests and signal %HTTP-SERVER-READY."
  (with-mutex %http-server-lock
    (let ((result (apply (@@ (web server http) http-open) args)))
      (signal-condition-variable %http-server-ready)
      result)))

(define-server-impl stub-http-server
  ;; Stripped-down version of Guile's built-in HTTP server.
  http-open
  (@@ (web server http) http-read)
  http-write
  (@@ (web server http) http-close))

(define (call-with-http-server code data thunk)
  "Call THUNK with an HTTP server running and returning CODE and DATA (a
string) on HTTP requests."
  (define (server-body)
    (define (handle request body)
      (values (build-response #:code code
                              #:reason-phrase "Such is life")
              data))

    (catch 'quit
      (lambda ()
        (run-server handle stub-http-server
                    `(#:socket ,(force %http-server-socket))))
      (const #t)))

  (with-mutex %http-server-lock
    (let ((server (make-thread server-body)))
      (wait-condition-variable %http-server-ready %http-server-lock)
      ;; Normally SERVER exits automatically once it has received a request.
      (thunk))))

(define-syntax-rule (with-http-server code data body ...)
  (call-with-http-server code data (lambda () body ...)))

;;; http.scm ends here
