gnu/tests/cups.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com>
   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 (gnu tests cups)
  20   #:use-module (gnu tests)
  21   #:use-module (gnu system)
  22   #:use-module (gnu system vm)
  23   #:use-module (gnu services)
  24   #:use-module (gnu services cups)
  25   #:use-module (gnu services networking)
  26   #:use-module (guix gexp)
  27   #:use-module (guix store)
  28   #:use-module (guix monads)
  29   #:export (%test-cups))
  30
  31 ;;;
  32 ;;; Test the Common Unix Printing System.
  33 ;;;
  34
  35 (define* (run-cups-test os-configuration #:optional (cups-port 631))
  36   (define os
  37     (marionette-operating-system os-configuration
  38                                  #:imported-modules '((gnu services herd))))
  39
  40   (define forwarded-port 8080)
  41
  42   (define vm
  43     (virtual-machine
  44      (operating-system os)
  45      (port-forwardings `((,forwarded-port . ,cups-port)))))
  46
  47   (define test
  48     (with-imported-modules '((gnu build marionette))
  49       #~(begin
  50           (use-modules (gnu build marionette)
  51                        (srfi srfi-11) (srfi srfi-64)
  52                        (web client) (web response))
  53
  54           (define marionette
  55             (make-marionette (list #$vm)))
  56
  57           (test-runner-current (system-test-runner #$output))
  58           (test-begin "cups")
  59
  60           ;; Wait for the web interface to become ready.
  61           (wait-for-tcp-port #$cups-port marionette)
  62
  63           (test-equal "http-get default page"
  64             200
  65             (let-values
  66                 (((response text)
  67                   (http-get #$(simple-format
  68                                #f "http://localhost:~A/" forwarded-port)
  69                             #:decode-body? #t)))
  70               (response-code response)))
  71
  72           (test-equal "http-get admin page"
  73             200
  74             (let-values
  75                 (((response text)
  76                   (http-get #$(simple-format
  77                                #f "http://localhost:~A/admin" forwarded-port)
  78                             #:decode-body? #t)))
  79               (response-code response)))
  80
  81           (test-end))))
  82
  83   (gexp->derivation "cups-test" test))
  84
  85 (define %cups-os
  86   (simple-operating-system
  87    (service dhcp-client-service-type)
  88    (service cups-service-type
  89             (cups-configuration
  90              (web-interface? #t)
  91              ;; Listen on all interfaces instead of just localhost so we
  92              ;; can access the web interface "remotely".
  93              (listen '("*:631" "/var/run/cups/cups.sock"))
  94              ;; Add access controls for the Qemu-managed network.
  95              (location-access-controls
  96               (list (location-access-control
  97                      (path "/")
  98                      (access-controls '("Order allow,deny"
  99                                         "Allow from 10.0.0.0/8")))
 100                     (location-access-control
 101                      (path "/admin")
 102                      (access-controls '("Order allow,deny"
 103                                         "Allow from 10.0.0.0/8")))
 104                     (location-access-control
 105                      (path "/admin/conf")
 106                      (access-controls '("Order allow,deny"
 107                                         "AuthType Basic"
 108                                         "Require user @SYSTEM"
 109                                         "Allow localhost")))))))))
 110
 111 (define %test-cups
 112   (system-test
 113    (name "cups")
 114    (description "Test the CUPS print server")
 115    (value (run-cups-test %cups-os))))
 116