projects/guix·blob master · refs

116 lines · 4.0 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2020 Marius Bakke <[email protected]>
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 dhcpcd-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