summaryrefslogtreecommitdiff
path: root/gnu/services/base.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/services/base.scm')
-rw-r--r--gnu/services/base.scm126
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."
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-08 18:02:44 +0000