aboutsummaryrefslogtreecommitdiff
path: root/gnu/services/base.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/services/base.scm')
-rw-r--r--gnu/services/base.scm100
1 files changed, 47 insertions, 53 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index afbecdb47e..1b1ce0d5e8 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -37,7 +37,6 @@
#:use-module ((gnu packages base)
#:select (canonical-package glibc))
#:use-module (gnu packages package-management)
- #:use-module (gnu packages ssh)
#:use-module (gnu packages lsof)
#:use-module (gnu packages terminals)
#:use-module ((gnu build file-systems)
@@ -252,6 +251,8 @@ FILE-SYSTEM."
(device (file-system-device file-system))
(type (file-system-type file-system))
(title (file-system-title file-system))
+ (flags (file-system-flags file-system))
+ (options (file-system-options file-system))
(check? (file-system-check? file-system))
(create? (file-system-create-mount-point? file-system))
(dependencies (file-system-dependencies file-system)))
@@ -264,35 +265,27 @@ FILE-SYSTEM."
,@(map dependency->shepherd-service-name dependencies)))
(documentation "Check, mount, and unmount the given file system.")
(start #~(lambda args
- ;; FIXME: Use or factorize with 'mount-file-system'.
- (let ((device (canonicalize-device-spec #$device '#$title))
- (flags #$(mount-flags->bit-mask
- (file-system-flags file-system))))
- #$(if create?
- #~(mkdir-p #$target)
- #~#t)
- #$(if check?
- #~(begin
- ;; Make sure fsck.ext2 & co. can be found.
- (setenv "PATH"
- (string-append
- #$e2fsprogs "/sbin:"
- "/run/current-system/profile/sbin:"
- (getenv "PATH")))
- (check-file-system device #$type))
- #~#t)
-
- (mount device #$target #$type flags
- #$(file-system-options file-system))
-
- ;; For read-only bind mounts, an extra remount is
- ;; needed, as per <http://lwn.net/Articles/281157/>,
- ;; which still applies to Linux 4.0.
- (when (and (= MS_BIND (logand flags MS_BIND))
- (= MS_RDONLY (logand flags MS_RDONLY)))
- (mount device #$target #$type
- (logior MS_BIND MS_REMOUNT MS_RDONLY))))
- #t))
+ #$(if create?
+ #~(mkdir-p #$target)
+ #t)
+
+ (let (($PATH (getenv "PATH")))
+ ;; Make sure fsck.ext2 & co. can be found.
+ (dynamic-wind
+ (lambda ()
+ (setenv "PATH"
+ (string-append
+ #$e2fsprogs "/sbin:"
+ "/run/current-system/profile/sbin:"
+ $PATH)))
+ (lambda ()
+ (mount-file-system
+ `(#$device #$title #$target #$type #$flags
+ #$options #$check?)
+ #:root "/"))
+ (lambda ()
+ (setenv "PATH" $PATH)))
+ #t)))
(stop #~(lambda args
;; Normally there are no processes left at this point, so
;; TARGET can be safely unmounted.
@@ -305,7 +298,7 @@ FILE-SYSTEM."
;; We need an additional module.
(modules `(((gnu build file-systems)
- #:select (check-file-system canonicalize-device-spec))
+ #:select (mount-file-system))
,@%default-modules)))))))
(define file-system-service-type
@@ -616,7 +609,7 @@ strings or string-valued gexps."
(dup2 (open-fdes #$tty O_RDONLY) 0)
(close-fdes 1)
(dup2 (open-fdes #$tty O_WRONLY) 1)
- (execl (string-append #$kbd "/bin/unicode_start")
+ (execl #$(file-append kbd "/bin/unicode_start")
"unicode_start"))
(else
(zero? (cdr (waitpid pid))))))))
@@ -629,7 +622,7 @@ strings or string-valued gexps."
(documentation (string-append "Load console keymap (loadkeys)."))
(provision '(console-keymap))
(start #~(lambda _
- (zero? (system* (string-append #$kbd "/bin/loadkeys")
+ (zero? (system* #$(file-append kbd "/bin/loadkeys")
#$@files))))
(respawn? #f)))))
@@ -661,7 +654,7 @@ strings or string-valued gexps."
(start #~(lambda _
(and #$(unicode-start device)
(zero?
- (system* (string-append #$kbd "/bin/setfont")
+ (system* #$(file-append kbd "/bin/setfont")
"-C" #$device #$font)))))
(stop #~(const #t))
(respawn? #f)))))
@@ -743,7 +736,7 @@ the message of the day, among other things."
(requirement '(user-processes host-name udev))
(start #~(make-forkexec-constructor
- (list (string-append #$mingetty "/sbin/mingetty")
+ (list #$(file-append mingetty "/sbin/mingetty")
"--noclear" #$tty
#$@(if auto-login
#~("--autologin" #$auto-login)
@@ -878,7 +871,7 @@ the tty to run, among other things."
(provision '(nscd))
(requirement '(user-processes))
(start #~(make-forkexec-constructor
- (list (string-append #$(nscd-configuration-glibc config)
+ (list #$(file-append (nscd-configuration-glibc config)
"/sbin/nscd")
"-f" #$nscd.conf "--foreground")
@@ -1064,7 +1057,7 @@ public key, with GUIX."
(format #t "registering public key '~a'...~%" key)
(close-port (current-input-port))
(dup port 0)
- (execl (string-append #$guix "/bin/guix")
+ (execl #$(file-append guix "/bin/guix")
"guix" "archive" "--authorize")
(exit 1)))
(else
@@ -1096,10 +1089,10 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
(default %default-substitute-urls))
(extra-options guix-configuration-extra-options ;list of strings
(default '()))
+ (log-file guix-configuration-log-file ;string
+ (default "/var/log/guix-daemon.log"))
(lsof guix-configuration-lsof ;<package>
- (default lsof))
- (lsh guix-configuration-lsh ;<package>
- (default lsh)))
+ (default lsof)))
(define %default-guix-configuration
(guix-configuration))
@@ -1110,14 +1103,14 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
(($ <guix-configuration> guix build-group build-accounts
authorize-key? keys
use-substitutes? substitute-urls extra-options
- lsof lsh)
+ log-file lsof)
(list (shepherd-service
(documentation "Run the Guix daemon.")
(provision '(guix-daemon))
(requirement '(user-processes))
(start
#~(make-forkexec-constructor
- (list (string-append #$guix "/bin/guix-daemon")
+ (list #$(file-append guix "/bin/guix-daemon")
"--build-users-group" #$build-group
#$@(if use-substitutes?
'()
@@ -1125,10 +1118,11 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
"--substitute-urls" #$(string-join substitute-urls)
#$@extra-options)
- ;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the
- ;; daemon's $PATH.
+ ;; Add 'lsof' (for the GC) to the daemon's $PATH.
#:environment-variables
- (list (string-append "PATH=" #$lsof "/bin:" #$lsh "/bin"))))
+ (list (string-append "PATH=" #$lsof "/bin"))
+
+ #:log-file #$log-file))
(stop #~(make-kill-destructor)))))))
(define (guix-accounts config)
@@ -1192,7 +1186,7 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
(provision '(guix-publish))
(requirement '(guix-daemon))
(start #~(make-forkexec-constructor
- (list (string-append #$guix "/bin/guix")
+ (list #$(file-append guix "/bin/guix")
"publish" "-u" "guix-publish"
"-p" #$(number->string port)
(string-append "--listen=" #$host))))
@@ -1346,7 +1340,7 @@ item of @var{packages}."
;; The first one is for udev, the second one for eudev.
(setenv "UDEV_CONFIG_FILE" #$udev.conf)
(setenv "EUDEV_RULES_DIRECTORY"
- (string-append #$rules "/lib/udev/rules.d"))
+ #$(file-append rules "/lib/udev/rules.d"))
(let ((pid (primitive-fork)))
(case pid
@@ -1359,11 +1353,11 @@ item of @var{packages}."
(wait-for-udevd)
;; Trigger device node creation.
- (system* (string-append #$udev "/bin/udevadm")
+ (system* #$(file-append udev "/bin/udevadm")
"trigger" "--action=add")
;; Wait for things to settle down.
- (system* (string-append #$udev "/bin/udevadm")
+ (system* #$(file-append udev "/bin/udevadm")
"settle")
pid)))))
(stop #~(make-kill-destructor))
@@ -1434,7 +1428,7 @@ extra rules from the packages listed in @var{rules}."
;; 'gpm' runs in the background and sets a PID file.
;; Note that it requires running as "root".
(false-if-exception (delete-file "/var/run/gpm.pid"))
- (fork+exec-command (list (string-append #$gpm "/sbin/gpm")
+ (fork+exec-command (list #$(file-append gpm "/sbin/gpm")
#$@options))
;; Wait for the PID file to appear; declare failure if
@@ -1449,7 +1443,7 @@ extra rules from the packages listed in @var{rules}."
(stop #~(lambda (_)
;; Return #f if successfully stopped.
- (not (zero? (system* (string-append #$gpm "/sbin/gpm")
+ (not (zero? (system* #$(file-append gpm "/sbin/gpm")
"-k"))))))))))
(define gpm-service-type
@@ -1478,7 +1472,7 @@ This service is not part of @var{%base-services}."
(default kmscon))
(virtual-terminal kmscon-configuration-virtual-terminal)
(login-program kmscon-configuration-login-program
- (default #~(string-append #$shadow "/bin/login")))
+ (default (file-append shadow "/bin/login")))
(login-arguments kmscon-configuration-login-arguments
(default '("-p")))
(hardware-acceleration? kmscon-configuration-hardware-acceleration?
@@ -1496,7 +1490,7 @@ This service is not part of @var{%base-services}."
(define kmscon-command
#~(list
- (string-append #$kmscon "/bin/kmscon") "--login"
+ #$(file-append kmscon "/bin/kmscon") "--login"
"--vt" #$virtual-terminal
#$@(if hardware-acceleration? '("--hwaccel") '())
"--" #$login-program #$@login-arguments))
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-06 07:44:21 +0000