projects/guix·blob master · refs

920 lines · 36.6 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2016 Jan Nieuwenhuizen <[email protected]>
3;;; Copyright © 2016-2026 Ludovic Courtès <[email protected]>
4;;; Copyright © 2020 Brice Waegeneire <[email protected]>
5;;; Copyright © 2023 Giacomo Leidi <[email protected]>
6;;; Copyright © 2024 Gabriel Wicki <[email protected]>
7;;; Copyright © 2024 Richard Sent <[email protected]>
8;;; Copyright © 2025 Luis Guilherme Coelho <[email protected]>
9;;;
10;;; This file is part of GNU Guix.
11;;;
12;;; GNU Guix is free software; you can redistribute it and/or modify it
13;;; under the terms of the GNU General Public License as published by
14;;; the Free Software Foundation; either version 3 of the License, or (at
15;;; your option) any later version.
16;;;
17;;; GNU Guix is distributed in the hope that it will be useful, but
18;;; WITHOUT ANY WARRANTY; without even the implied warranty of
19;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;;; GNU General Public License for more details.
21;;;
22;;; You should have received a copy of the GNU General Public License
23;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
24
25;;; Commentary:
26;;;
27;;; This module provides basic system administration tools: log rotation,
28;;; unattended upgrades, etc.
29;;;
30;;; Code:
31
32(define-module (gnu services admin)
33 #:use-module (gnu system file-systems)
34 #:use-module (gnu packages admin)
35 #:use-module ((gnu packages base)
36 #:select (canonical-package findutils coreutils sed))
37 #:use-module (gnu packages file-systems)
38 #:use-module (gnu packages nss)
39 #:use-module (gnu packages disk)
40 #:use-module (gnu packages package-management)
41 #:use-module (gnu packages linux)
42 #:use-module (gnu services)
43 #:use-module (gnu services configuration)
44 #:use-module (gnu services mcron)
45 #:use-module (gnu services shepherd)
46 #:use-module (gnu system accounts)
47 #:use-module ((gnu system shadow) #:select (account-service-type))
48 #:use-module ((guix store) #:select (%store-prefix))
49 #:use-module (guix deprecation)
50 #:use-module (guix gexp)
51 #:use-module (guix modules)
52 #:use-module (guix packages)
53 #:use-module (guix records)
54 #:use-module (gnu system privilege)
55 #:use-module (srfi srfi-1)
56 #:use-module (srfi srfi-26)
57 #:use-module (ice-9 format)
58 #:use-module (ice-9 match)
59 #:use-module (ice-9 vlist)
60 #:export (log-rotation-configuration
61 log-rotation-configuration?
62 log-rotation-configuration-provision
63 log-rotation-configuration-requirement
64 log-rotation-configuration-calendar-event
65 log-rotation-configuration-external-log-files
66 log-rotation-configuration-compression
67 log-rotation-configuration-expiry
68 log-rotation-configuration-size-threshold
69 log-rotation-service-type
70
71 log-cleanup-service-type
72 log-cleanup-configuration
73 log-cleanup-configuration?
74 log-cleanup-configuration-directory
75 log-cleanup-configuration-expiry
76 log-cleanup-configuration-schedule
77
78 file-database-service-type
79 file-database-configuration
80 file-database-configuration?
81 file-database-configuration-package
82 file-database-configuration-schedule
83 file-database-configuration-excluded-directories
84 %default-file-database-update-schedule
85 %default-file-database-excluded-directories
86
87 package-database-service-type
88 package-database-configuration
89 package-database-configuration?
90 package-database-configuration-package
91 package-database-configuration-schedule
92 package-database-configuration-method
93 package-database-configuration-channels
94
95 unattended-upgrade-service-type
96 unattended-upgrade-configuration
97 unattended-upgrade-configuration?
98 unattended-upgrade-configuration-operating-system-file
99 unattended-upgrade-configuration-operating-system-expression
100 unattended-upgrade-configuration-channels
101 unattended-upgrade-configuration-schedule
102 unattended-upgrade-configuration-services-to-restart
103 unattended-upgrade-configuration-system-expiration
104 unattended-upgrade-configuration-maximum-duration
105 unattended-upgrade-configuration-log-file
106
107 opendoas-service-type
108 opendoas-configuration
109 opendoas-configuration-opendoas
110 opendoas-configuration-rules
111 opendoas-permit-rule
112 opendoas-deny-rule
113
114 resize-file-system-service-type
115 resize-file-system-configuration
116 resize-file-system-configuration?
117 resize-file-system-configuration-file-system
118 resize-file-system-configuration-cloud-utils
119 resize-file-system-configuration-e2fsprogs
120 resize-file-system-configuration-btrfs-progs
121 resize-file-system-configuration-bcachefs-tools))
122
123
124;;;
125;;; Shepherd's log rotation service.
126;;;
127
128(define %default-log-rotation-calendar-event
129 ;; Default calendar event when log rotation is triggered.
130 #~(calendar-event #:minutes '(0)
131 #:hours '(22)
132 #:days-of-week '(sunday)))
133
134(define (gexp-or-integer? x)
135 (or (gexp? x) (integer? x)))
136
137(define (gexp-or-symbol? x)
138 (or (gexp? x) (symbol? x)))
139
140(define-configuration log-rotation-configuration
141 (provision
142 (list-of-symbols '(log-rotation))
143 "The name(s) of the log rotation Shepherd service."
144 empty-serializer)
145 (requirement
146 (list-of-symbols (if for-home? '() '(user-processes)))
147 "Dependencies of the log rotation Shepherd service."
148 empty-serializer)
149 (calendar-event
150 (gexp %default-log-rotation-calendar-event)
151 "Gexp containing the @dfn{calendar event} when log rotation occurs.
152@xref{Timers,,, shepherd, The GNU Shepherd Manual}, for more information on
153calendar events."
154 empty-serializer)
155 (external-log-files
156 (list-of-strings '())
157 "List of file names, external log files that should also be
158rotated."
159 empty-serializer)
160 (compression
161 (gexp-or-symbol 'zstd)
162 "The compression method used for rotated log files, one of @code{'none},
163@code{'gzip}, and @code{'zstd}. Alternatively, it can be a gexp that evaluates
164to a procedure; that procedure gets called with the file to be rotated."
165 empty-serializer)
166 (expiry
167 (gexp-or-integer #~(%default-log-expiry))
168 "Age in seconds after which a log file is deleted."
169 empty-serializer)
170 (size-threshold
171 (gexp-or-integer #~(%default-rotation-size-threshold))
172 "Size in bytes below which a log file is @emph{not} rotated."
173 empty-serializer))
174
175(define (log-rotation-shepherd-services config)
176 (let* ((compression-raw (log-rotation-configuration-compression config))
177 (compression
178 (if (symbol? compression-raw)
179 #~'#$compression-raw
180 compression-raw)))
181 (list (shepherd-service
182 (provision (log-rotation-configuration-provision config))
183 (requirement (log-rotation-configuration-requirement config))
184 (modules '((shepherd service timer) ;for 'calendar-event'
185 (shepherd service log-rotation)))
186 (free-form #~(log-rotation-service
187 #$(log-rotation-configuration-calendar-event config)
188 #:provision
189 '#$(log-rotation-configuration-provision config)
190 #:requirement
191 '#$(log-rotation-configuration-requirement config)
192 #:external-log-files
193 '#$(log-rotation-configuration-external-log-files
194 config)
195 #:compression
196 #$compression
197 #:expiry
198 #$(log-rotation-configuration-expiry config)
199 #:rotation-size-threshold
200 #$(log-rotation-configuration-size-threshold
201 config)))))))
202
203(define log-rotation-service-type
204 (service-type
205 (name 'log-rotation)
206 (description
207 "Periodically rotate log files using the Shepherd's log rotation service.
208Run @command{herd status log-rotation} to view its status, @command{herd files
209log-rotation} to list files subject to log rotation.")
210 (extensions (list (service-extension shepherd-root-service-type
211 log-rotation-shepherd-services)))
212 (compose concatenate)
213 (extend (lambda (config log-files)
214 (log-rotation-configuration
215 (inherit config)
216 (external-log-files
217 (append (log-rotation-configuration-external-log-files config)
218 log-files)))))
219 (default-value (log-rotation-configuration))))
220
221
222;;;
223;;; Build log removal.
224;;;
225
226(define-record-type* <log-cleanup-configuration>
227 log-cleanup-configuration make-log-cleanup-configuration
228 log-cleanup-configuration?
229 (directory log-cleanup-configuration-directory) ;string
230 (expiry log-cleanup-configuration-expiry ;integer (seconds)
231 (default (* 6 30 24 3600)))
232 (schedule log-cleanup-configuration-schedule ;string or gexp
233 (default "30 12 01,08,15,22 * *")))
234
235(define (log-cleanup-program directory expiry)
236 (program-file "delete-old-logs"
237 (with-imported-modules '((guix build utils))
238 #~(begin
239 (use-modules (guix build utils))
240 (let* ((now (car (gettimeofday)))
241 (logs (find-files #$directory
242 (lambda (file stat)
243 (> (- now (stat:mtime stat))
244 #$expiry)))))
245 (format #t "deleting ~a log files from '~a'...~%"
246 (length logs) #$directory)
247 (for-each delete-file logs))))))
248
249(define (log-cleanup-shepherd-services configuration)
250 (match-record configuration <log-cleanup-configuration>
251 (directory expiry schedule)
252 (let ((program (log-cleanup-program directory expiry)))
253 (list (shepherd-service
254 (provision '(log-cleanup))
255 (requirement '(user-processes))
256 (modules '((shepherd service timer)))
257 (start #~(make-timer-constructor
258 #$(if (string? schedule)
259 #~(cron-string->calendar-event #$schedule)
260 schedule)
261 (command '(#$program))))
262 (stop #~(make-timer-destructor))
263 (actions (list shepherd-trigger-action))
264 (documentation "Periodically delete old log files."))))))
265
266(define log-cleanup-service-type
267 (service-type
268 (name 'log-cleanup)
269 (extensions
270 (list (service-extension shepherd-root-service-type
271 log-cleanup-shepherd-services)))
272 (description
273 "Periodically delete old log files.")))
274
275
276;;;
277;;; File databases.
278;;;
279
280(define %default-file-database-update-schedule
281 ;; Default mcron schedule for the periodic 'updatedb' job: once every
282 ;; Sunday.
283 "10 23 * * 0")
284
285(define %default-file-database-excluded-directories
286 ;; Regexps of directories excluded from the 'locate' database.
287 (list (%store-prefix)
288 "/tmp" "/var/tmp" "/var/cache" ".*/\\.cache"
289 "/run/udev" "/dev"))
290
291(define (string-or-gexp? obj)
292 (or (string? obj) (gexp? obj)))
293
294(define string-list?
295 (match-lambda
296 (((? string?) ...) #t)
297 (_ #f)))
298
299(define-configuration/no-serialization file-database-configuration
300 (package
301 (file-like (let-system (system target)
302 ;; Unless we're cross-compiling, avoid pulling a second copy
303 ;; of findutils.
304 (if target
305 findutils
306 (canonical-package findutils))))
307 "The package from which the @command{updatedb} command is taken.
308Examples of such packages are GNU@tie{}Findutils and Plocate.")
309 (schedule
310 (string-or-gexp %default-file-database-update-schedule)
311 "String or G-exp denoting an mcron schedule for the periodic
312@command{updatedb} job (@pxref{Guile Syntax,,, mcron, GNU@tie{}mcron}).")
313 (excluded-directories
314 (string-list %default-file-database-excluded-directories)
315 "List of regular expressions of directories to ignore when building the
316file database. By default, this includes @file{/tmp} and @file{/gnu/store};
317the latter should instead be indexed by @command{guix locate} (@pxref{Invoking
318guix locate}). This list is passed to the @option{--prunepaths} option of
319@command{updatedb} (@pxref{Invoking updatedb,,, find, GNU@tie{}Findutils})."))
320
321(define (file-database-shepherd-services configuration)
322 (match-record configuration <file-database-configuration>
323 (package schedule excluded-directories)
324 (let ((updatedb (program-file
325 "updatedb"
326 #~(begin
327 (define updatedb
328 (let ((try (lambda (file)
329 (and (file-exists? file) file))))
330 (or (try #$(file-append package "/bin/updatedb"))
331 (try #$(file-append package "/sbin/updatedb")))))
332 ;; 'updatedb' is a shell script that expects various
333 ;; commands in $PATH.
334 (setenv "PATH"
335 (string-append (dirname updatedb) ":"
336 #$(canonical-package coreutils)
337 "/bin:"
338 #$(canonical-package sed)
339 "/bin"))
340 (execl updatedb
341 "updatedb"
342 #$(string-append "--prunepaths="
343 (string-join
344 excluded-directories)))))))
345 (list (shepherd-service
346 (provision '(file-database-update))
347 (requirement '(user-processes))
348 (modules '((shepherd service timer)))
349 (start #~(make-timer-constructor
350 #$(if (string? schedule)
351 #~(cron-string->calendar-event #$schedule)
352 schedule)
353 (command '(#$updatedb))
354 #:wait-for-termination? #t))
355 (stop #~(make-timer-destructor))
356 (documentation
357 "Periodically update the system-wide file database that can be
358queried by the 'locate' command.")
359 (actions (list shepherd-trigger-action)))))))
360
361(define file-database-service-type
362 (service-type
363 (name 'file-database)
364 (extensions (list (service-extension shepherd-root-service-type
365 file-database-shepherd-services)))
366 (description
367 "Periodically update the file database used by the @command{locate} command,
368which lets you search for files by name. The database is created by running
369the @command{updatedb} command.")
370 (default-value (file-database-configuration))))
371
372(define %default-package-database-update-schedule
373 ;; Default mcron schedule for the periodic 'guix locate --update' job: once
374 ;; every Monday.
375 "10 23 * * 1")
376
377(define-configuration/no-serialization package-database-configuration
378 (package (file-like guix)
379 "The Guix package to use.")
380 (schedule (string-or-gexp
381 %default-package-database-update-schedule)
382 "String or G-exp denoting an mcron schedule for the periodic
383@command{guix locate --update} job (@pxref{Guile Syntax,,, mcron,
384GNU@tie{}mcron}).")
385 (method (symbol 'store)
386 "Indexing method for @command{guix locate}. The default value,
387@code{'store}, yields a more complete database but is relatively expensive in
388terms of CPU and input/output.")
389 (channels (gexp #~%default-channels)
390 "G-exp denoting the channels to use when updating the database
391(@pxref{Channels})."))
392
393(define %package-database-file
394 ;; System-wide package database used by 'guix locate'.
395 ;; See 'system-database-file' in (guix scripts locate).
396 "/var/cache/guix/locate/db.sqlite")
397
398(define %package-database-accounts
399 (list (user-account
400 (name "guix-locate")
401 (group "guix-locate")
402 (system? #t)
403 (comment "Account running 'guix locate'")
404 (home-directory "/var/run/guix-locate"))
405 (user-group
406 (name "guix-locate")
407 (system? #t))))
408
409(define %package-database-activation
410 ;; Create the package database directory at activation time. Make it
411 ;; writable by 'guix-locate' and world-readable.
412 #~(begin
413 (use-modules (guix build utils))
414 (let ((directory #$(dirname %package-database-file))
415 (owner (getpwnam "guix-locate")))
416 (mkdir-p/perms directory owner #o755))))
417
418(define (package-database-shepherd-services configuration)
419 (match-record configuration <package-database-configuration>
420 (package schedule method channels)
421 (let ((channels (scheme-file "channels.scm" channels)))
422 (list (shepherd-service
423 (provision '(package-database-update))
424 (requirement '(user-processes guix-daemon))
425 (modules '((shepherd service timer)))
426 (start #~(make-timer-constructor
427 #$(if (string? schedule)
428 #~(cron-string->calendar-event #$schedule)
429 schedule)
430 (command '(#$(file-append package "/bin/guix")
431 "time-machine" "-C" #$channels
432 "--" "locate" "--update"
433 #$(string-append "--database="
434 %package-database-file)
435 #$(string-append
436 "--method=" (symbol->string method)))
437 #:user "guix-locate"
438 #:group "guix-locate")
439 #:log-file "/var/log/guix-locate.log"
440 #:wait-for-termination? #t))
441 (stop #~(make-timer-destructor))
442 (documentation
443 "Periodically update the system-wide package database that can
444be queried by the 'guix locate' command.")
445 (actions (list shepherd-trigger-action)))))))
446
447(define package-database-service-type
448 (service-type
449 (name 'package-database)
450 (extensions (list (service-extension shepherd-root-service-type
451 package-database-shepherd-services)
452 (service-extension activation-service-type
453 (const %package-database-activation))
454 (service-extension account-service-type
455 (const %package-database-accounts))))
456 (description
457 "Periodically update the package database used by the @code{guix locate} command,
458which lets you search for packages that provide a given file.")
459 (default-value (package-database-configuration))))
460
461
462;;;
463;;; Unattended upgrade.
464;;;
465
466(define-record-type* <unattended-upgrade-configuration>
467 unattended-upgrade-configuration make-unattended-upgrade-configuration
468 unattended-upgrade-configuration?
469 (operating-system-file unattended-upgrade-operating-system-file
470 (default "/run/current-system/configuration.scm"))
471 (operating-system-expression unattended-upgrade-operating-system-expression
472 (default #f))
473 (schedule unattended-upgrade-configuration-schedule
474 (default "30 01 * * 0"))
475 (channels unattended-upgrade-configuration-channels
476 (default #~%default-channels))
477 (reboot? unattended-upgrade-configuration-reboot?
478 (default #f))
479 (services-to-restart unattended-upgrade-configuration-services-to-restart
480 (default '(unattended-upgrade)))
481 (system-expiration unattended-upgrade-system-expiration
482 (default (* 3 30 24 3600)))
483 (maximum-duration unattended-upgrade-maximum-duration
484 (default 3600))
485 (log-file unattended-upgrade-configuration-log-file
486 (default %unattended-upgrade-log-file)))
487
488(define %unattended-upgrade-log-file
489 "/var/log/unattended-upgrade.log")
490
491(define (unattended-upgrade-shepherd-services config)
492 (define channels
493 (scheme-file "channels.scm"
494 (unattended-upgrade-configuration-channels config)))
495
496 (define log
497 (unattended-upgrade-configuration-log-file config))
498
499 (define schedule
500 (unattended-upgrade-configuration-schedule config))
501
502 (define services
503 (unattended-upgrade-configuration-services-to-restart config))
504
505 (define reboot?
506 (unattended-upgrade-configuration-reboot? config))
507
508 (define expiration
509 (unattended-upgrade-system-expiration config))
510
511 (define config-file
512 (unattended-upgrade-operating-system-file config))
513
514 (define expression
515 (unattended-upgrade-operating-system-expression config))
516
517 (define arguments
518 (if expression
519 #~(list "-e" (object->string '#$expression))
520 #~(list #$config-file)))
521
522 (define code
523 (with-imported-modules (source-module-closure '((guix build utils)
524 (gnu services herd)))
525 #~(begin
526 (use-modules (guix build utils)
527 (gnu services herd)
528 (srfi srfi-34))
529
530 (setvbuf (current-output-port) 'line)
531 (setvbuf (current-error-port) 'line)
532
533 ;; 'guix time-machine' needs X.509 certificates to authenticate the
534 ;; Git host.
535 (setenv "SSL_CERT_DIR"
536 #$(file-append nss-certs "/etc/ssl/certs"))
537
538 (format #t "starting upgrade...~%")
539 (guard (c ((invoke-error? c)
540 (report-invoke-error c)
541 (exit 1)))
542 (apply invoke #$(file-append guix "/bin/guix")
543 "time-machine" "-C" #$channels
544 "--" "system" "reconfigure" #$arguments)
545
546 ;; 'guix system delete-generations' fails when there's no
547 ;; matching generation. Thus, catch 'invoke-error?'.
548 (guard (c ((invoke-error? c)
549 (report-invoke-error c)))
550 (invoke #$(file-append guix "/bin/guix")
551 "system" "delete-generations"
552 #$(string-append (number->string expiration)
553 "s")))
554
555 (unless #$reboot?
556 ;; Rebooting effectively restarts services anyway and execution
557 ;; would be halted here if mcron is restarted.
558 (format #t "restarting services...~%")
559 (for-each restart-service '#$services))
560
561 ;; XXX: If this service has been restarted, this is not reached.
562 (format #t "upgrade complete~%")
563
564 ;; Stopping the root shepherd service triggers a reboot.
565 (when #$reboot?
566 (format #t "rebooting system~%")
567 (force-output) ;ensure the entire log is written.
568 (stop-service 'root))))))
569
570 (define upgrade
571 (program-file "unattended-upgrade" code))
572
573 (list (shepherd-service
574 (provision '(unattended-upgrade))
575 (requirement '(user-processes networking))
576 (modules '((shepherd service timer)))
577 (start #~(make-timer-constructor
578 #$(if (string? schedule)
579 #~(cron-string->calendar-event #$schedule)
580 schedule)
581 (command '(#$upgrade))
582
583 #:log-file #$log
584
585 ;; Make sure the upgrade doesn't take too long.
586 #:max-duration
587 #$(unattended-upgrade-maximum-duration config)
588
589 ;; Wait for the previous attempt to terminate before trying
590 ;; again.
591 #:wait-for-termination? #t))
592 (stop #~(make-timer-destructor))
593 (actions (list shepherd-trigger-action)))))
594
595(define unattended-upgrade-service-type
596 (service-type
597 (name 'unattended-upgrade)
598 (extensions
599 (list (service-extension shepherd-root-service-type
600 unattended-upgrade-shepherd-services)))
601 (description
602 "Periodically upgrade the system from the current configuration.")
603 (default-value (unattended-upgrade-configuration))))
604
605
606;;;
607;;; Opendoas.
608;;;
609
610(define (setenv-pair? x)
611 (and (pair? x)
612 (string? (car x))
613 (or (string? (cdr x))
614 (boolean? (cdr x)))))
615
616(define setenv-list?
617 (list-of setenv-pair?))
618
619(define (serialize-setenv-list field-name val)
620 (map (match-lambda
621 ((var . #t) var)
622 ((var . #f) (string-append "-" var))
623 ((var . value) (string-append var "=" value)))
624 val))
625
626(define-maybe list-of-strings)
627(define-maybe setenv-list)
628(define-maybe string)
629
630(define-configuration/no-serialization opendoas-permit-rule
631 (nopass?
632 (boolean #f)
633 "Whether the user should be permitted to run the command without a password.")
634 (nolog?
635 (boolean #f)
636 "Wheter sucessful command execution should be logged.")
637 (persist?
638 (boolean #f)
639 "After the user sucessfully authenticates, do not ask for a password again
640for some time.")
641 (keepenv?
642 (boolean #f)
643 "Wheter environment variables other than those listed in doas should be
644retained when creating the enviroment for the new process.")
645 (identity
646 string
647 "The username to match. Groups may be specified by prepending a colon ':'."
648 empty-serializer)
649 (as-user
650 maybe-string
651 "The target user the running user is allowed to run the command as. The
652default is all users."
653 empty-serializer)
654 (command
655 maybe-string
656 "The command the user is allowed to run. The default is all commands.
657It's preferable to have commands specifieds by absolute paths. If a relative
658path is specified, only a restricted PATH will be searched."
659 empty-serializer)
660 (args
661 maybe-list-of-strings
662 "Arguments to command. The command arguments provided by the user need to
663match those specified. The keyword args alone means that command must be run
664without arguments."
665 empty-serializer)
666 (setenv
667 maybe-setenv-list
668 "Set the specified variables. Variables may also be removed by setting them
669to #f, or simply exported, by setting them to #t. If the first character of the
670value is @code{$} then the value to be set is taken from the existing environment
671variable with the given name."))
672
673(define-configuration/no-serialization opendoas-deny-rule
674 (identity
675 string
676 "The username to match. Groups may be specified by prepending a colon ':'."
677 empty-serializer)
678 (as-user
679 maybe-string
680 "The target user the running user is allowed to run the command as. The
681default is all users."
682 empty-serializer)
683 (command
684 maybe-string
685 "The command the user is allowed to run. The default is all commands.
686It's preferable to have commands specifieds by absolute paths. If a relative
687path is specified, only a restricted PATH will be searched."
688 empty-serializer)
689 (args
690 maybe-string
691 "Arguments to command. The command arguments provided by the user need to
692match those specified. The keyword args alone means that command must be run
693without arguments."
694 empty-serializer))
695
696(define (opendoas-rule? x)
697 (or (opendoas-permit-rule? x)
698 (opendoas-deny-rule? x)))
699
700(define* (if-set val #:optional (proc identity))
701 "Apply PROC to VAL if VAL is not unset, otherwise returns #f."
702 (if (maybe-value-set? val) (proc val) #f))
703
704(define serialize-opendoas-permit-rule
705 (match-record-lambda <opendoas-permit-rule>
706 (identity as-user command args setenv keepenv? nopass? nolog? persist?)
707 (format #f "permit ~:[~;keepenv ~]~
708 ~:[~;nopass ~]~
709 ~:[~;nolog ~]~
710 ~:[~;persist ~]~
711 ~@[setenv {~{ ~a~} } ~]~
712 ~a~@[ as ~a~]~
713 ~@[ cmd ~a~]~
714 ~@[ args~{ ~a~}~]~%"
715 keepenv?
716 nopass?
717 nolog?
718 persist?
719 (if-set setenv (cut serialize-setenv-list #f <>))
720 identity
721 (if-set as-user)
722 (if-set command)
723 (if-set args))))
724
725(define serialize-opendoas-deny-rule
726 (match-record-lambda <opendoas-deny-rule>
727 (identity as-user command args)
728 (format #f "deny ~a~@[ as ~a~]~@[ cmd ~a~]~@[ args~{ ~a~}~]~%"
729 identity
730 (if-set as-user)
731 (if-set command)
732 (if-set args))))
733
734(define (serialize-opendoas-rule rule)
735 (cond ((opendoas-permit-rule? rule)
736 (serialize-opendoas-permit-rule rule))
737 ((opendoas-deny-rule? rule)
738 (serialize-opendoas-deny-rule rule))))
739
740(define list-of-opendoas-rules?
741 (list-of opendoas-rule?))
742
743(define-configuration/no-serialization opendoas-configuration
744 (opendoas
745 (package opendoas)
746 "The opendoas package to be used.")
747 (rules
748 (list-of-opendoas-rules
749 (list (opendoas-permit-rule
750 (identity ":wheel"))))
751 "The list of permit and/or deny rules used by opendoas."))
752
753(define (opendoas-extensions original-config extension-configs)
754 (opendoas-configuration
755 (inherit original-config)
756 (rules (append (opendoas-configuration-rules original-config)
757 (reverse (apply append extension-configs))))))
758
759(define (opendoas-activation config)
760 ;; Opendoas requires this file to be owned by root. So we install this file
761 ;; on activation rather than by etc-service-type to ensure proper working on
762 ;; unprivileged daemon setups
763 #~(let* ((doas.conf "/etc/doas.conf")
764 (root:pwnam (getpwnam "root"))
765 (root:uid (passwd:uid root:pwnam))
766 (root:gid (passwd:gid root:pwnam)))
767 ;; Just being extra cautious
768 (mkdir-p/perms "/etc" root:pwnam #o755)
769 ;; If /etc/doas.conf is a symlink, copy-file fails to replace it, so delete
770 ;; it before copying the new file there
771 (when (file-exists? doas.conf) (delete-file doas.conf))
772 (copy-file
773 #$(plain-file "doas.conf"
774 (apply string-append
775 (map serialize-opendoas-rule
776 (opendoas-configuration-rules config))))
777 doas.conf)
778 (chown doas.conf root:uid root:gid)
779 (chmod doas.conf #o400)))
780
781(define (opendoas-privileged-programs config)
782 (let ((opendoas (opendoas-configuration-opendoas config)))
783 (list (privileged-program
784 (program (file-append opendoas "/bin/doas"))
785 (setuid? #t)))))
786
787(define (opendoas-packages config)
788 (list (opendoas-configuration-opendoas config)))
789
790(define opendoas-service-type
791 (service-type
792 (name 'opendoas)
793 (extensions
794 (list (service-extension activation-service-type
795 opendoas-activation)
796 (service-extension profile-service-type
797 opendoas-packages)
798 (service-extension privileged-program-service-type
799 opendoas-privileged-programs)))
800 (compose identity)
801 (extend opendoas-extensions)
802 (default-value (opendoas-configuration))
803 (description "Set /etc/doas.conf")))
804
805
806;;;
807;;; Resize file system.
808;;;
809
810(define-record-type* <resize-file-system-configuration>
811 resize-file-system-configuration make-resize-file-system-configuration
812 resize-file-system-configuration?
813 (file-system resize-file-system-file-system)
814 (cloud-utils resize-file-system-cloud-utils
815 (default cloud-utils))
816 (e2fsprogs resize-file-system-e2fsprogs
817 (default e2fsprogs))
818 (btrfs-progs resize-file-system-btrfs-progs
819 (default btrfs-progs))
820 (bcachefs-tools resize-file-system-bcachefs-tools
821 (default bcachefs-tools)))
822
823(define (resize-file-system-shepherd-service config)
824 "Returns a <shepherd-service> for resize-file-system-service for CONFIG."
825 (match-record config <resize-file-system-configuration>
826 (file-system cloud-utils e2fsprogs btrfs-progs
827 bcachefs-tools)
828 (let ((fs-spec (file-system->spec file-system)))
829 (shepherd-service
830 (documentation "Resize a file system. Intended for Guix Systems that
831are booted from a system image flashed onto a larger medium.")
832 ;; XXX: This could be extended with file-system info.
833 (provision '(resize-file-system))
834 (requirement '(user-processes))
835 (one-shot? #t)
836 (respawn? #f)
837 (modules '((guix build utils)
838 (gnu build file-systems)
839 (gnu system file-systems)
840 (ice-9 control)
841 (ice-9 match)
842 (ice-9 ftw)
843 (ice-9 rdelim)
844 (srfi srfi-34)))
845 (start (with-imported-modules (source-module-closure
846 '((guix build utils)
847 (gnu build file-systems)
848 (gnu system file-systems)))
849 #~(lambda _
850 (use-modules (guix build utils)
851 (gnu build file-systems)
852 (gnu system file-systems)
853 (ice-9 control)
854 (ice-9 match)
855 (ice-9 ftw)
856 (ice-9 rdelim)
857 (srfi srfi-34))
858
859 (define file-system
860 (spec->file-system '#$fs-spec))
861
862 ;; Shepherd recommends the start constructor takes <1
863 ;; minute, canonicalize-device-spec will hang for up to
864 ;; max-trials seconds (20 seconds) if an invalid device is
865 ;; connected. Revisit this if max-trials increases.
866 (define device (canonicalize-device-spec
867 (file-system-device file-system)))
868
869 (define grow-partition-command
870 (let* ((sysfs-device
871 (string-append "/sys/class/block/"
872 (basename device)))
873 (partition-number
874 (with-input-from-file
875 (string-append sysfs-device
876 "/partition")
877 read-line))
878 (parent (string-append
879 "/dev/"
880 (basename (dirname (readlink sysfs-device))))))
881 (list #$(file-append cloud-utils "/bin/growpart")
882 parent partition-number)))
883
884 (define grow-filesystem-command
885 (match (file-system-type file-system)
886 ((or "ext2" "ext3" "ext4")
887 (list #$(file-append e2fsprogs "/sbin/resize2fs") device))
888 ("btrfs"
889 (list #$(file-append btrfs-progs "/bin/btrfs")
890 "filesystem" "resize" device))
891 ("bcachefs"
892 (list #$(file-append bcachefs-tools "/sbin/bcachefs")
893 "device" "resize" device))
894 (e (error "Unsupported filesystem type" e))))
895
896 (let/ec return
897 (guard (c ((and (invoke-error? c)
898 ;; growpart NOCHANGE exits with 1. It is
899 ;; unlikely the partition was resized
900 ;; while the file system was not. Just
901 ;; exit.
902 (equal? (invoke-error-exit-status c) 1))
903 (format (current-error-port)
904 "The device ~a is already resized.~%" device)
905 ;; Must return something or Shepherd considers
906 ;; the service perpetually starting.
907 (return 0)))
908 (apply invoke grow-partition-command))
909 (apply invoke grow-filesystem-command)))))))))
910
911(define resize-file-system-service-type
912 (service-type
913 (name 'resize-file-system)
914 (description "Resize a partition and the underlying file system during boot.")
915 (extensions
916 (list
917 (service-extension shepherd-root-service-type
918 (compose list resize-file-system-shepherd-service))))))
919
920;;; admin.scm ends here