diff options
Diffstat (limited to 'gnu/services/base.scm')
| -rw-r--r-- | gnu/services/base.scm | 126 |
1 files changed, 92 insertions, 34 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 04bc991356..3fc4d5f885 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com> -;;; Copyright © 2015, 2016 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2015, 2016, 2020 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com> ;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name> ;;; Copyright © 2016 David Craven <david@craven.ch> @@ -62,7 +62,8 @@ #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:use-module (ice-9 format) - #:re-export (user-processes-service-type) ;backwards compatibility + #:re-export (user-processes-service-type ;backwards compatibility + %default-substitute-urls) #:export (fstab-service-type root-file-system-service file-system-service-type @@ -106,6 +107,12 @@ agetty-service-type mingetty-configuration + mingetty-configuration-tty + mingetty-configuration-auto-login + mingetty-configuration-login-program + mingetty-configuration-login-pause? + mingetty-configuration-clear-on-logout? + mingetty-configuration-mingetty mingetty-configuration? mingetty-service mingetty-service-type @@ -291,7 +298,8 @@ FILE-SYSTEM." (define (mapped-device->shepherd-service-name md) "Return the symbol that denotes the shepherd service of MD, a <mapped-device>." (symbol-append 'device-mapping- - (string->symbol (mapped-device-target md)))) + (string->symbol (string-join + (mapped-device-targets md) "-")))) (define dependency->shepherd-service-name (match-lambda @@ -1024,20 +1032,22 @@ the tty to run, among other things." (define-record-type* <mingetty-configuration> mingetty-configuration make-mingetty-configuration mingetty-configuration? - (mingetty mingetty-configuration-mingetty ;<package> - (default mingetty)) - (tty mingetty-configuration-tty) ;string - (auto-login mingetty-auto-login ;string | #f - (default #f)) - (login-program mingetty-login-program ;gexp - (default #f)) - (login-pause? mingetty-login-pause? ;Boolean - (default #f))) + (mingetty mingetty-configuration-mingetty ;<package> + (default mingetty)) + (tty mingetty-configuration-tty) ;string + (auto-login mingetty-auto-login ;string | #f + (default #f)) + (login-program mingetty-login-program ;gexp + (default #f)) + (login-pause? mingetty-login-pause? ;Boolean + (default #f)) + (clear-on-logout? mingetty-clear-on-logout? ;Boolean + (default #t))) (define mingetty-shepherd-service (match-lambda (($ <mingetty-configuration> mingetty tty auto-login login-program - login-pause?) + login-pause? clear-on-logout?) (list (shepherd-service (documentation "Run mingetty on an tty.") @@ -1050,7 +1060,6 @@ the tty to run, among other things." (start #~(make-forkexec-constructor (list #$(file-append mingetty "/sbin/mingetty") - "--noclear" ;; Avoiding 'vhangup' allows us to avoid 'setfont' ;; errors down the path where various ioctls get @@ -1058,6 +1067,9 @@ the tty to run, among other things." ;; in Linux. "--nohangup" #$tty + #$@(if clear-on-logout? + #~() + #~("--noclear")) #$@(if auto-login #~("--autologin" #$auto-login) #~()) @@ -1476,10 +1488,18 @@ archive' public keys, with GUIX." #~(begin (use-modules (guix build utils)) - (unless (file-exists? "/etc/guix/acl") - (mkdir-p "/etc/guix") - (copy-file #+default-acl "/etc/guix/acl") - (chmod "/etc/guix/acl" #o600))))) + ;; If the ACL already exists, move it out of the way. Create a backup + ;; if it's a regular file: it's likely that the user manually updated + ;; it with 'guix archive --authorize'. + (if (file-exists? "/etc/guix/acl") + (if (and (symbolic-link? "/etc/guix/acl") + (store-file-name? (readlink "/etc/guix/acl"))) + (delete-file "/etc/guix/acl") + (rename-file "/etc/guix/acl" "/etc/guix/acl.bak")) + (mkdir-p "/etc/guix")) + + ;; Installed the declared ACL. + (symlink #+default-acl "/etc/guix/acl")))) (define %default-authorized-guix-keys ;; List of authorized substitute keys. @@ -1562,8 +1582,10 @@ proxy of 'guix-daemon'...~%") (ice-9 match) (gnu build shepherd))) (start - (with-imported-modules (source-module-closure - '((gnu build shepherd))) + (with-imported-modules `(((guix config) => ,(make-config.scm)) + ,@(source-module-closure + '((gnu build shepherd)) + #:select? not-config?)) #~(lambda args (define proxy ;; HTTP/HTTPS proxy. The 'http_proxy' variable is set by @@ -1732,6 +1754,8 @@ proxy of 'guix-daemon'...~%") (default "nar")) (cache guix-publish-configuration-cache ;#f | string (default #f)) + (cache-bypass-threshold guix-publish-configuration-cache-bypass-threshold + (default (* 10 (expt 2 20)))) ;integer (workers guix-publish-configuration-workers ;#f | integer (default #f)) (ttl guix-publish-configuration-ttl ;#f | integer @@ -1766,7 +1790,7 @@ raise a deprecation warning if the 'compression-level' field was used." lst)))) (match-record config <guix-publish-configuration> - (guix port host nar-path cache workers ttl) + (guix port host nar-path cache workers ttl cache-bypass-threshold) (list (shepherd-service (provision '(guix-publish)) (requirement '(guix-daemon)) @@ -1788,7 +1812,11 @@ raise a deprecation warning if the 'compression-level' field was used." "s")) #~()) #$@(if cache - #~((string-append "--cache=" #$cache)) + #~((string-append "--cache=" #$cache) + #$(string-append + "--cache-bypass-threshold=" + (number->string + cache-bypass-threshold))) #~())) ;; Make sure we run in a UTF-8 locale so we can produce @@ -2096,22 +2124,52 @@ instance." 'swap (lambda (device) (define requirement - (if (string-prefix? "/dev/mapper/" device) + (if (and (string? device) + (string-prefix? "/dev/mapper/" device)) (list (symbol-append 'device-mapping- (string->symbol (basename device)))) '())) - (shepherd-service - (provision (list (symbol-append 'swap- (string->symbol device)))) - (requirement `(udev ,@requirement)) - (documentation "Enable the given swap device.") - (start #~(lambda () - (restart-on-EINTR (swapon #$device)) - #t)) - (stop #~(lambda _ - (restart-on-EINTR (swapoff #$device)) - #f)) - (respawn? #f))))) + (define (device-lookup device) + ;; The generic 'find-partition' procedures could return a partition + ;; that's not swap space, but that's unlikely. + (cond ((uuid? device) + #~(find-partition-by-uuid #$(uuid-bytevector device))) + ((file-system-label? device) + #~(find-partition-by-label + #$(file-system-label->string device))) + (else + device))) + + (define service-name + (symbol-append 'swap- + (string->symbol + (cond ((uuid? device) + (string-take (uuid->string device) 6)) + ((file-system-label? device) + (file-system-label->string device)) + (else + device))))) + + (with-imported-modules (source-module-closure '((gnu build file-systems))) + (shepherd-service + (provision (list service-name)) + (requirement `(udev ,@requirement)) + (documentation "Enable the given swap device.") + (modules `((gnu build file-systems) + ,@%default-modules)) + (start #~(lambda () + (let ((device #$(device-lookup device))) + (and device + (begin + (restart-on-EINTR (swapon device)) + #t))))) + (stop #~(lambda _ + (let ((device #$(device-lookup device))) + (when device + (restart-on-EINTR (swapoff device))) + #f))) + (respawn? #f)))))) (define (swap-service device) "Return a service that uses @var{device} as a swap device." |