123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117 |
- (define-module (gnu tests cups)
- #:use-module (gnu tests)
- #:use-module (gnu system)
- #:use-module (gnu system vm)
- #:use-module (gnu services)
- #:use-module (gnu services cups)
- #:use-module (gnu services networking)
- #:use-module (guix gexp)
- #:use-module (guix store)
- #:use-module (guix monads)
- #:export (%test-cups))
- (define* (run-cups-test os-configuration #:optional (cups-port 631))
- (define os
- (marionette-operating-system os-configuration
- #:imported-modules '((gnu services herd))))
- (define forwarded-port 8080)
- (define vm
- (virtual-machine
- (operating-system os)
- (port-forwardings `((,forwarded-port . ,cups-port)))))
- (define test
- (with-imported-modules '((gnu build marionette))
- #~(begin
- (use-modules (gnu build marionette)
- (srfi srfi-11) (srfi srfi-64)
- (web client) (web response))
- (define marionette
- (make-marionette (list #$vm)))
- (test-runner-current (system-test-runner #$output))
- (test-begin "cups")
-
- (wait-for-tcp-port #$cups-port marionette)
- (test-equal "http-get default page"
- 200
- (let-values
- (((response text)
- (http-get #$(simple-format
- #f "http://localhost:~A/" forwarded-port)
- #:decode-body? #t)))
- (response-code response)))
- (test-equal "http-get admin page"
- 200
- (let-values
- (((response text)
- (http-get #$(simple-format
- #f "http://localhost:~A/admin" forwarded-port)
- #:decode-body? #t)))
- (response-code response)))
- (test-end))))
- (gexp->derivation "cups-test" test))
- (define %cups-os
- (simple-operating-system
- (service dhcp-client-service-type)
- (service cups-service-type
- (cups-configuration
- (web-interface? #t)
-
-
- (listen '("*:631" "/var/run/cups/cups.sock"))
-
- (location-access-controls
- (list (location-access-control
- (path "/")
- (access-controls '("Order allow,deny"
- "Allow from 10.0.0.0/8")))
- (location-access-control
- (path "/admin")
- (access-controls '("Order allow,deny"
- "Allow from 10.0.0.0/8")))
- (location-access-control
- (path "/admin/conf")
- (access-controls '("Order allow,deny"
- "AuthType Basic"
- "Require user @SYSTEM"
- "Allow localhost")))))))))
- (define %test-cups
- (system-test
- (name "cups")
- (description "Test the CUPS print server")
- (value (run-cups-test %cups-os))))
|