projects/guix·blob kernel-updates · refs

118 lines · 4.2 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2016-2020, 2022, 2024 Ludovic Courtès <[email protected]>
3;;; Copyright © 2018 Clément Lassieur <[email protected]>
4;;;
5;;; This file is part of GNU Guix.
6;;;
7;;; GNU Guix is free software; you can redistribute it and/or modify it
8;;; under the terms of the GNU General Public License as published by
9;;; the Free Software Foundation; either version 3 of the License, or (at
10;;; your option) any later version.
11;;;
12;;; GNU Guix is distributed in the hope that it will be useful, but
13;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19
20(define-module (gnu tests mcron)
21 #:use-module (gnu tests)
22 #:use-module (gnu system)
23 #:use-module (gnu system vm)
24 #:use-module (gnu services)
25 #:use-module (gnu services mcron)
26 #:use-module (guix gexp)
27 #:use-module (guix store)
28 #:use-module (guix monads)
29 #:export (%test-mcron))
30
31;;;
32;;; Mcron.
33;;;
34
35(define %mcron-os
36 ;; System with an mcron service, with one mcron job for "root" and one mcron
37 ;; job for an unprivileged user.
38 (let ((job1 #~(job '(next-second '(0 5 10 15 20 25 30 35 40 45 50 55))
39 (lambda ()
40 (unless (file-exists? "witness")
41 (call-with-output-file "witness"
42 (lambda (port)
43 (display (list (getuid) (getgid)) port)))))))
44 (job2 #~(job next-second-from
45 (lambda ()
46 (call-with-output-file "witness"
47 (lambda (port)
48 (display (list (getuid) (getgid)) port))))
49 #:user "alice"))
50 (job3 #~(job next-second-from ;to test $PATH
51 "touch witness-touch")))
52 (simple-operating-system
53 (service mcron-service-type
54 (mcron-configuration (jobs (list job1 job2 job3)))))))
55
56(define (run-mcron-test name)
57 (define os
58 (marionette-operating-system
59 %mcron-os
60 #:imported-modules '((gnu services herd)
61 (guix combinators))))
62
63 (define test
64 (with-imported-modules '((gnu build marionette))
65 #~(begin
66 (use-modules (gnu build marionette)
67 (srfi srfi-64)
68 (ice-9 match))
69
70 (define marionette
71 (make-marionette (list #$(virtual-machine os))))
72
73 (test-runner-current (system-test-runner #$output))
74 (test-begin "mcron")
75
76 (test-assert "service running"
77 (marionette-eval
78 '(begin
79 (use-modules (gnu services herd))
80 (start-service 'mcron))
81 marionette))
82
83 ;; Make sure root's mcron job runs, has its cwd set to "/root", and
84 ;; runs with the right UID/GID.
85 (test-equal "root's job"
86 '(0 0)
87 (wait-for-file "/root/witness" marionette))
88
89 ;; Likewise for Alice's job. We cannot know what its GID is since
90 ;; it's chosen by 'groupadd', but it's strictly positive.
91 (test-assert "alice's job"
92 (match (wait-for-file "/home/alice/witness" marionette)
93 ((1000 gid)
94 (>= gid 100))))
95
96 ;; Last, the job that uses a command; allows us to test whether
97 ;; $PATH is sane.
98 (test-equal "root's job with command"
99 ""
100 (wait-for-file "/root/witness-touch" marionette
101 #:read '(@ (ice-9 rdelim) read-string)))
102
103 ;; Make sure the 'schedule' action is accepted.
104 (test-equal "schedule action"
105 '(#t) ;one value, #t
106 (marionette-eval '(with-shepherd-action 'mcron ('schedule) result
107 result)
108 marionette))
109
110 (test-end))))
111
112 (gexp->derivation name test))
113
114(define %test-mcron
115 (system-test
116 (name "mcron")
117 (description "Make sure the mcron service works as advertised.")
118 (value (run-mcron-test name))))