projects/guix·blob bootstrap-team · refs

677 lines · 28.2 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2016 Jan Nieuwenhuizen <[email protected]>
3;;; Copyright © 2016-2025 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;;;
9;;; This file is part of GNU Guix.
10;;;
11;;; GNU Guix is free software; you can redistribute it and/or modify it
12;;; under the terms of the GNU General Public License as published by
13;;; the Free Software Foundation; either version 3 of the License, or (at
14;;; your option) any later version.
15;;;
16;;; GNU Guix is distributed in the hope that it will be useful, but
17;;; WITHOUT ANY WARRANTY; without even the implied warranty of
18;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;;; GNU General Public License for more details.
20;;;
21;;; You should have received a copy of the GNU General Public License
22;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
23
24(define-module (gnu services admin)
25 #:use-module (gnu system file-systems)
26 #:use-module (gnu packages admin)
27 #:use-module ((gnu packages base)
28 #:select (canonical-package findutils coreutils sed))
29 #:use-module (gnu packages file-systems)
30 #:use-module (gnu packages nss)
31 #:use-module (gnu packages disk)
32 #:use-module (gnu packages package-management)
33 #:use-module (gnu packages linux)
34 #:use-module (gnu services)
35 #:use-module (gnu services configuration)
36 #:use-module (gnu services mcron)
37 #:use-module (gnu services shepherd)
38 #:use-module (gnu system accounts)
39 #:use-module ((gnu system shadow) #:select (account-service-type))
40 #:use-module ((guix store) #:select (%store-prefix))
41 #:use-module (guix deprecation)
42 #:use-module (guix gexp)
43 #:use-module (guix modules)
44 #:use-module (guix packages)
45 #:use-module (guix records)
46 #:use-module (srfi srfi-1)
47 #:use-module (ice-9 match)
48 #:use-module (ice-9 vlist)
49 #:export (log-rotation-configuration
50 log-rotation-configuration?
51 log-rotation-configuration-provision
52 log-rotation-configuration-requirement
53 log-rotation-configuration-calendar-event
54 log-rotation-configuration-external-log-files
55 log-rotation-configuration-compression
56 log-rotation-configuration-expiry
57 log-rotation-configuration-size-threshold
58 log-rotation-service-type
59
60 log-cleanup-service-type
61 log-cleanup-configuration
62 log-cleanup-configuration?
63 log-cleanup-configuration-directory
64 log-cleanup-configuration-expiry
65 log-cleanup-configuration-schedule
66
67 file-database-service-type
68 file-database-configuration
69 file-database-configuration?
70 file-database-configuration-package
71 file-database-configuration-schedule
72 file-database-configuration-excluded-directories
73 %default-file-database-update-schedule
74 %default-file-database-excluded-directories
75
76 package-database-service-type
77 package-database-configuration
78 package-database-configuration?
79 package-database-configuration-package
80 package-database-configuration-schedule
81 package-database-configuration-method
82 package-database-configuration-channels
83
84 unattended-upgrade-service-type
85 unattended-upgrade-configuration
86 unattended-upgrade-configuration?
87 unattended-upgrade-configuration-operating-system-file
88 unattended-upgrade-configuration-operating-system-expression
89 unattended-upgrade-configuration-channels
90 unattended-upgrade-configuration-schedule
91 unattended-upgrade-configuration-services-to-restart
92 unattended-upgrade-configuration-system-expiration
93 unattended-upgrade-configuration-maximum-duration
94 unattended-upgrade-configuration-log-file
95
96 resize-file-system-service-type
97 resize-file-system-configuration
98 resize-file-system-configuration?
99 resize-file-system-configuration-file-system
100 resize-file-system-configuration-cloud-utils
101 resize-file-system-configuration-e2fsprogs
102 resize-file-system-configuration-btrfs-progs
103 resize-file-system-configuration-bcachefs-tools))
104
105;;; Commentary:
106;;;
107;;; This module provides basic system administration tools: log rotation,
108;;; unattended upgrades, etc.
109;;;
110;;; Code:
111
112
113;;;
114;;; Shepherd's log rotation service.
115;;;
116
117(define %default-log-rotation-calendar-event
118 ;; Default calendar event when log rotation is triggered.
119 #~(calendar-event #:minutes '(0)
120 #:hours '(22)
121 #:days-of-week '(sunday)))
122
123(define (gexp-or-integer? x)
124 (or (gexp? x) (integer? x)))
125
126(define (gexp-or-symbol? x)
127 (or (gexp? x) (symbol? x)))
128
129(define-configuration log-rotation-configuration
130 (provision
131 (list-of-symbols '(log-rotation))
132 "The name(s) of the log rotation Shepherd service."
133 empty-serializer)
134 (requirement
135 (list-of-symbols (if for-home? '() '(user-processes)))
136 "Dependencies of the log rotation Shepherd service."
137 empty-serializer)
138 (calendar-event
139 (gexp %default-log-rotation-calendar-event)
140 "Gexp containing the @dfn{calendar event} when log rotation occurs.
141@xref{Timers,,, shepherd, The GNU Shepherd Manual}, for more information on
142calendar events."
143 empty-serializer)
144 (external-log-files
145 (list-of-strings '())
146 "List of file names, external log files that should also be
147rotated."
148 empty-serializer)
149 (compression
150 (gexp-or-symbol 'zstd)
151 "The compression method used for rotated log files, one of @code{'none},
152@code{'gzip}, and @code{'zstd}. Alternatively, it can be a gexp that evaluates
153to a procedure; that procedure gets called with the file to be rotated."
154 empty-serializer)
155 (expiry
156 (gexp-or-integer #~(%default-log-expiry))
157 "Age in seconds after which a log file is deleted."
158 empty-serializer)
159 (size-threshold
160 (gexp-or-integer #~(%default-rotation-size-threshold))
161 "Size in bytes below which a log file is @emph{not} rotated."
162 empty-serializer))
163
164(define (log-rotation-shepherd-services config)
165 (let* ((compression-raw (log-rotation-configuration-compression config))
166 (compression
167 (if (symbol? compression-raw)
168 #~'#$compression-raw
169 compression-raw)))
170 (list (shepherd-service
171 (provision (log-rotation-configuration-provision config))
172 (requirement (log-rotation-configuration-requirement config))
173 (modules '((shepherd service timer) ;for 'calendar-event'
174 (shepherd service log-rotation)))
175 (free-form #~(log-rotation-service
176 #$(log-rotation-configuration-calendar-event config)
177 #:provision
178 '#$(log-rotation-configuration-provision config)
179 #:requirement
180 '#$(log-rotation-configuration-requirement config)
181 #:external-log-files
182 '#$(log-rotation-configuration-external-log-files
183 config)
184 #:compression
185 #$compression
186 #:expiry
187 #$(log-rotation-configuration-expiry config)
188 #:rotation-size-threshold
189 #$(log-rotation-configuration-size-threshold
190 config)))))))
191
192(define log-rotation-service-type
193 (service-type
194 (name 'log-rotation)
195 (description
196 "Periodically rotate log files using the Shepherd's log rotation service.
197Run @command{herd status log-rotation} to view its status, @command{herd files
198log-rotation} to list files subject to log rotation.")
199 (extensions (list (service-extension shepherd-root-service-type
200 log-rotation-shepherd-services)))
201 (compose concatenate)
202 (extend (lambda (config log-files)
203 (log-rotation-configuration
204 (inherit config)
205 (external-log-files
206 (append (log-rotation-configuration-external-log-files config)
207 log-files)))))
208 (default-value (log-rotation-configuration))))
209
210
211;;;
212;;; Build log removal.
213;;;
214
215(define-record-type* <log-cleanup-configuration>
216 log-cleanup-configuration make-log-cleanup-configuration
217 log-cleanup-configuration?
218 (directory log-cleanup-configuration-directory) ;string
219 (expiry log-cleanup-configuration-expiry ;integer (seconds)
220 (default (* 6 30 24 3600)))
221 (schedule log-cleanup-configuration-schedule ;string or gexp
222 (default "30 12 01,08,15,22 * *")))
223
224(define (log-cleanup-program directory expiry)
225 (program-file "delete-old-logs"
226 (with-imported-modules '((guix build utils))
227 #~(begin
228 (use-modules (guix build utils))
229
230 (let* ((now (car (gettimeofday)))
231 (logs (find-files #$directory
232 (lambda (file stat)
233 (> (- now (stat:mtime stat))
234 #$expiry)))))
235 (format #t "deleting ~a log files from '~a'...~%"
236 (length logs) #$directory)
237 (for-each delete-file logs))))))
238
239(define (log-cleanup-shepherd-services configuration)
240 (match-record configuration <log-cleanup-configuration>
241 (directory expiry schedule)
242 (let ((program (log-cleanup-program directory expiry)))
243 (list (shepherd-service
244 (provision '(log-cleanup))
245 (requirement '(user-processes))
246 (modules '((shepherd service timer)))
247 (start #~(make-timer-constructor
248 #$(if (string? schedule)
249 #~(cron-string->calendar-event #$schedule)
250 schedule)
251 (command '(#$program))))
252 (stop #~(make-timer-destructor))
253 (actions (list shepherd-trigger-action))
254 (documentation "Periodically delete old log files."))))))
255
256(define log-cleanup-service-type
257 (service-type
258 (name 'log-cleanup)
259 (extensions
260 (list (service-extension shepherd-root-service-type
261 log-cleanup-shepherd-services)))
262 (description
263 "Periodically delete old log files.")))
264
265
266;;;
267;;; File databases.
268;;;
269
270(define %default-file-database-update-schedule
271 ;; Default mcron schedule for the periodic 'updatedb' job: once every
272 ;; Sunday.
273 "10 23 * * 0")
274
275(define %default-file-database-excluded-directories
276 ;; Regexps of directories excluded from the 'locate' database.
277 (list (%store-prefix)
278 "/tmp" "/var/tmp" "/var/cache" ".*/\\.cache"
279 "/run/udev" "/dev"))
280
281(define (string-or-gexp? obj)
282 (or (string? obj) (gexp? obj)))
283
284(define string-list?
285 (match-lambda
286 (((? string?) ...) #t)
287 (_ #f)))
288
289(define-configuration/no-serialization file-database-configuration
290 (package
291 (file-like (let-system (system target)
292 ;; Unless we're cross-compiling, avoid pulling a second copy
293 ;; of findutils.
294 (if target
295 findutils
296 (canonical-package findutils))))
297 "The package from which the @command{updatedb} command is taken.
298Examples of such packages are GNU@tie{}Findutils and Plocate.")
299 (schedule
300 (string-or-gexp %default-file-database-update-schedule)
301 "String or G-exp denoting an mcron schedule for the periodic
302@command{updatedb} job (@pxref{Guile Syntax,,, mcron, GNU@tie{}mcron}).")
303 (excluded-directories
304 (string-list %default-file-database-excluded-directories)
305 "List of regular expressions of directories to ignore when building the
306file database. By default, this includes @file{/tmp} and @file{/gnu/store};
307the latter should instead be indexed by @command{guix locate} (@pxref{Invoking
308guix locate}). This list is passed to the @option{--prunepaths} option of
309@command{updatedb} (@pxref{Invoking updatedb,,, find, GNU@tie{}Findutils})."))
310
311(define (file-database-shepherd-services configuration)
312 (match-record configuration <file-database-configuration>
313 (package schedule excluded-directories)
314 (let ((updatedb (program-file
315 "updatedb"
316 #~(begin
317 (define updatedb
318 (let ((try (lambda (file)
319 (and (file-exists? file) file))))
320 (or (try #$(file-append package "/bin/updatedb"))
321 (try #$(file-append package "/sbin/updatedb")))))
322 ;; 'updatedb' is a shell script that expects various
323 ;; commands in $PATH.
324 (setenv "PATH"
325 (string-append (dirname updatedb) ":"
326 #$(canonical-package coreutils)
327 "/bin:"
328 #$(canonical-package sed)
329 "/bin"))
330 (execl updatedb
331 "updatedb"
332 #$(string-append "--prunepaths="
333 (string-join
334 excluded-directories)))))))
335 (list (shepherd-service
336 (provision '(file-database-update))
337 (requirement '(user-processes))
338 (modules '((shepherd service timer)))
339 (start #~(make-timer-constructor
340 #$(if (string? schedule)
341 #~(cron-string->calendar-event #$schedule)
342 schedule)
343 (command '(#$updatedb))
344 #:wait-for-termination? #t))
345 (stop #~(make-timer-destructor))
346 (documentation
347 "Periodically update the system-wide file database that can be
348queried by the 'locate' command.")
349 (actions (list shepherd-trigger-action)))))))
350
351(define file-database-service-type
352 (service-type
353 (name 'file-database)
354 (extensions (list (service-extension shepherd-root-service-type
355 file-database-shepherd-services)))
356 (description
357 "Periodically update the file database used by the @command{locate} command,
358which lets you search for files by name. The database is created by running
359the @command{updatedb} command.")
360 (default-value (file-database-configuration))))
361
362(define %default-package-database-update-schedule
363 ;; Default mcron schedule for the periodic 'guix locate --update' job: once
364 ;; every Monday.
365 "10 23 * * 1")
366
367(define-configuration/no-serialization package-database-configuration
368 (package (file-like guix)
369 "The Guix package to use.")
370 (schedule (string-or-gexp
371 %default-package-database-update-schedule)
372 "String or G-exp denoting an mcron schedule for the periodic
373@command{guix locate --update} job (@pxref{Guile Syntax,,, mcron,
374GNU@tie{}mcron}).")
375 (method (symbol 'store)
376 "Indexing method for @command{guix locate}. The default value,
377@code{'store}, yields a more complete database but is relatively expensive in
378terms of CPU and input/output.")
379 (channels (gexp #~%default-channels)
380 "G-exp denoting the channels to use when updating the database
381(@pxref{Channels})."))
382
383(define (package-database-shepherd-services configuration)
384 (match-record configuration <package-database-configuration>
385 (package schedule method channels)
386 (let ((channels (scheme-file "channels.scm" channels)))
387 (list (shepherd-service
388 (provision '(package-database-update))
389 (requirement '(user-processes guix-daemon))
390 (modules '((shepherd service timer)))
391 ;; XXX: The whole thing's running as "root" just because it needs
392 ;; write access to /var/cache/guix/locate.
393 (start #~(make-timer-constructor
394 #$(if (string? schedule)
395 #~(cron-string->calendar-event #$schedule)
396 schedule)
397 (command '(#$(file-append package "/bin/guix")
398 "time-machine" "-C" #$channels
399 "--" "locate" "--update"
400 #$(string-append
401 "--method=" (symbol->string method))))
402 #:wait-for-termination? #t))
403 (stop #~(make-timer-destructor))
404 (documentation
405 "Periodically update the system-wide package database that can
406be queried by the 'guix locate' command.")
407 (actions (list shepherd-trigger-action)))))))
408
409(define package-database-service-type
410 (service-type
411 (name 'package-database)
412 (extensions (list (service-extension shepherd-root-service-type
413 package-database-shepherd-services)))
414 (description
415 "Periodically update the package database used by the @code{guix locate} command,
416which lets you search for packages that provide a given file.")
417 (default-value (package-database-configuration))))
418
419
420;;;
421;;; Unattended upgrade.
422;;;
423
424(define-record-type* <unattended-upgrade-configuration>
425 unattended-upgrade-configuration make-unattended-upgrade-configuration
426 unattended-upgrade-configuration?
427 (operating-system-file unattended-upgrade-operating-system-file
428 (default "/run/current-system/configuration.scm"))
429 (operating-system-expression unattended-upgrade-operating-system-expression
430 (default #f))
431 (schedule unattended-upgrade-configuration-schedule
432 (default "30 01 * * 0"))
433 (channels unattended-upgrade-configuration-channels
434 (default #~%default-channels))
435 (reboot? unattended-upgrade-configuration-reboot?
436 (default #f))
437 (services-to-restart unattended-upgrade-configuration-services-to-restart
438 (default '(unattended-upgrade)))
439 (system-expiration unattended-upgrade-system-expiration
440 (default (* 3 30 24 3600)))
441 (maximum-duration unattended-upgrade-maximum-duration
442 (default 3600))
443 (log-file unattended-upgrade-configuration-log-file
444 (default %unattended-upgrade-log-file)))
445
446(define %unattended-upgrade-log-file
447 "/var/log/unattended-upgrade.log")
448
449(define (unattended-upgrade-shepherd-services config)
450 (define channels
451 (scheme-file "channels.scm"
452 (unattended-upgrade-configuration-channels config)))
453
454 (define log
455 (unattended-upgrade-configuration-log-file config))
456
457 (define schedule
458 (unattended-upgrade-configuration-schedule config))
459
460 (define services
461 (unattended-upgrade-configuration-services-to-restart config))
462
463 (define reboot?
464 (unattended-upgrade-configuration-reboot? config))
465
466 (define expiration
467 (unattended-upgrade-system-expiration config))
468
469 (define config-file
470 (unattended-upgrade-operating-system-file config))
471
472 (define expression
473 (unattended-upgrade-operating-system-expression config))
474
475 (define arguments
476 (if expression
477 #~(list "-e" (object->string '#$expression))
478 #~(list #$config-file)))
479
480 (define code
481 (with-imported-modules (source-module-closure '((guix build utils)
482 (gnu services herd)))
483 #~(begin
484 (use-modules (guix build utils)
485 (gnu services herd)
486 (srfi srfi-34))
487
488 (setvbuf (current-output-port) 'line)
489 (setvbuf (current-error-port) 'line)
490
491 ;; 'guix time-machine' needs X.509 certificates to authenticate the
492 ;; Git host.
493 (setenv "SSL_CERT_DIR"
494 #$(file-append nss-certs "/etc/ssl/certs"))
495
496 (format #t "starting upgrade...~%")
497 (guard (c ((invoke-error? c)
498 (report-invoke-error c)
499 (exit 1)))
500 (apply invoke #$(file-append guix "/bin/guix")
501 "time-machine" "-C" #$channels
502 "--" "system" "reconfigure" #$arguments)
503
504 ;; 'guix system delete-generations' fails when there's no
505 ;; matching generation. Thus, catch 'invoke-error?'.
506 (guard (c ((invoke-error? c)
507 (report-invoke-error c)))
508 (invoke #$(file-append guix "/bin/guix")
509 "system" "delete-generations"
510 #$(string-append (number->string expiration)
511 "s")))
512
513 (unless #$reboot?
514 ;; Rebooting effectively restarts services anyway and execution
515 ;; would be halted here if mcron is restarted.
516 (format #t "restarting services...~%")
517 (for-each restart-service '#$services))
518
519 ;; XXX: If this service has been restarted, this is not reached.
520 (format #t "upgrade complete~%")
521
522 ;; Stopping the root shepherd service triggers a reboot.
523 (when #$reboot?
524 (format #t "rebooting system~%")
525 (force-output) ;ensure the entire log is written.
526 (stop-service 'root))))))
527
528 (define upgrade
529 (program-file "unattended-upgrade" code))
530
531 (list (shepherd-service
532 (provision '(unattended-upgrade))
533 (requirement '(user-processes networking))
534 (modules '((shepherd service timer)))
535 (start #~(make-timer-constructor
536 #$(if (string? schedule)
537 #~(cron-string->calendar-event #$schedule)
538 schedule)
539 (command '(#$upgrade))
540
541 #:log-file #$log
542
543 ;; Make sure the upgrade doesn't take too long.
544 #:max-duration
545 #$(unattended-upgrade-maximum-duration config)
546
547 ;; Wait for the previous attempt to terminate before trying
548 ;; again.
549 #:wait-for-termination? #t))
550 (stop #~(make-timer-destructor))
551 (actions (list shepherd-trigger-action)))))
552
553(define unattended-upgrade-service-type
554 (service-type
555 (name 'unattended-upgrade)
556 (extensions
557 (list (service-extension shepherd-root-service-type
558 unattended-upgrade-shepherd-services)))
559 (description
560 "Periodically upgrade the system from the current configuration.")
561 (default-value (unattended-upgrade-configuration))))
562
563;;;
564;;; Resize file system.
565;;;
566
567(define-record-type* <resize-file-system-configuration>
568 resize-file-system-configuration make-resize-file-system-configuration
569 resize-file-system-configuration?
570 (file-system resize-file-system-file-system)
571 (cloud-utils resize-file-system-cloud-utils
572 (default cloud-utils))
573 (e2fsprogs resize-file-system-e2fsprogs
574 (default e2fsprogs))
575 (btrfs-progs resize-file-system-btrfs-progs
576 (default btrfs-progs))
577 (bcachefs-tools resize-file-system-bcachefs-tools
578 (default bcachefs-tools)))
579
580(define (resize-file-system-shepherd-service config)
581 "Returns a <shepherd-service> for resize-file-system-service for CONFIG."
582 (match-record config <resize-file-system-configuration>
583 (file-system cloud-utils e2fsprogs btrfs-progs
584 bcachefs-tools)
585 (let ((fs-spec (file-system->spec file-system)))
586 (shepherd-service
587 (documentation "Resize a file system. Intended for Guix Systems that
588are booted from a system image flashed onto a larger medium.")
589 ;; XXX: This could be extended with file-system info.
590 (provision '(resize-file-system))
591 (requirement '(user-processes))
592 (one-shot? #t)
593 (respawn? #f)
594 (modules '((guix build utils)
595 (gnu build file-systems)
596 (gnu system file-systems)
597 (ice-9 control)
598 (ice-9 match)
599 (ice-9 ftw)
600 (ice-9 rdelim)
601 (srfi srfi-34)))
602 (start (with-imported-modules (source-module-closure
603 '((guix build utils)
604 (gnu build file-systems)
605 (gnu system file-systems)))
606 #~(lambda _
607 (use-modules (guix build utils)
608 (gnu build file-systems)
609 (gnu system file-systems)
610 (ice-9 control)
611 (ice-9 match)
612 (ice-9 ftw)
613 (ice-9 rdelim)
614 (srfi srfi-34))
615
616 (define file-system
617 (spec->file-system '#$fs-spec))
618
619 ;; Shepherd recommends the start constructor takes <1
620 ;; minute, canonicalize-device-spec will hang for up to
621 ;; max-trials seconds (20 seconds) if an invalid device is
622 ;; connected. Revisit this if max-trials increases.
623 (define device (canonicalize-device-spec
624 (file-system-device file-system)))
625
626 (define grow-partition-command
627 (let* ((sysfs-device
628 (string-append "/sys/class/block/"
629 (basename device)))
630 (partition-number
631 (with-input-from-file
632 (string-append sysfs-device
633 "/partition")
634 read-line))
635 (parent (string-append
636 "/dev/"
637 (basename (dirname (readlink sysfs-device))))))
638 (list #$(file-append cloud-utils "/bin/growpart")
639 parent partition-number)))
640
641 (define grow-filesystem-command
642 (match (file-system-type file-system)
643 ((or "ext2" "ext3" "ext4")
644 (list #$(file-append e2fsprogs "/sbin/resize2fs") device))
645 ("btrfs"
646 (list #$(file-append btrfs-progs "/bin/btrfs")
647 "filesystem" "resize" device))
648 ("bcachefs"
649 (list #$(file-append bcachefs-tools "/sbin/bcachefs")
650 "device" "resize" device))
651 (e (error "Unsupported filesystem type" e))))
652
653 (let/ec return
654 (guard (c ((and (invoke-error? c)
655 ;; growpart NOCHANGE exits with 1. It is
656 ;; unlikely the partition was resized
657 ;; while the file system was not. Just
658 ;; exit.
659 (equal? (invoke-error-exit-status c) 1))
660 (format (current-error-port)
661 "The device ~a is already resized.~%" device)
662 ;; Must return something or Shepherd considers
663 ;; the service perpetually starting.
664 (return 0)))
665 (apply invoke grow-partition-command))
666 (apply invoke grow-filesystem-command)))))))))
667
668(define resize-file-system-service-type
669 (service-type
670 (name 'resize-file-system)
671 (description "Resize a partition and the underlying file system during boot.")
672 (extensions
673 (list
674 (service-extension shepherd-root-service-type
675 (compose list resize-file-system-shepherd-service))))))
676
677;;; admin.scm ends here