mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
services: <shepherd-service> no longer has an 'imported-modules' field.
* gnu/services/shepherd.scm (<shepherd-service>)[imported-modules]: Remove. (%default-imported-modules): Make private. (shepherd-service-file): Use 'with-imported-modules'. (shepherd-configuration-file): Remove 'modules' and the calls to 'imported-modules' and 'compiled-modules'. Use 'with-imported-modules' instead. * doc/guix.texi (Shepherd Services): Adjust accordingly. * gnu/services/base.scm (file-system-shepherd-service): Use 'with-imported-modules'. Remove 'imported-modules' field. * gnu/system/mapped-devices.scm (device-mapping-service-type): Remove 'imported-modules'. (open-luks-device): Use 'with-imported-modules'. * gnu/tests.scm (marionette-shepherd-service): Remove 'imported-modules' field and use 'with-imported-modules'.
This commit is contained in:
parent
fd12989398
commit
a91c3fc727
5 changed files with 131 additions and 151 deletions
|
@ -10848,10 +10848,6 @@ where @var{service-name} is one of the symbols in @var{provision}
|
|||
This is the list of modules that must be in scope when @code{start} and
|
||||
@code{stop} are evaluated.
|
||||
|
||||
@item @code{imported-modules} (default: @var{%default-imported-modules})
|
||||
This is the list of modules to import in the execution environment of
|
||||
the Shepherd.
|
||||
|
||||
@end table
|
||||
@end deftp
|
||||
|
||||
|
|
|
@ -229,59 +229,58 @@ (define (file-system-shepherd-service file-system)
|
|||
(create? (file-system-create-mount-point? file-system))
|
||||
(dependencies (file-system-dependencies file-system)))
|
||||
(if (file-system-mount? file-system)
|
||||
(list
|
||||
(shepherd-service
|
||||
(provision (list (file-system->shepherd-service-name file-system)))
|
||||
(requirement `(root-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)
|
||||
(with-imported-modules '((gnu build file-systems)
|
||||
(guix build bournish))
|
||||
(list
|
||||
(shepherd-service
|
||||
(provision (list (file-system->shepherd-service-name file-system)))
|
||||
(requirement `(root-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))
|
||||
(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))
|
||||
(stop #~(lambda args
|
||||
;; Normally there are no processes left at this point, so
|
||||
;; TARGET can be safely unmounted.
|
||||
;; 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))
|
||||
(stop #~(lambda args
|
||||
;; Normally there are no processes left at this point, so
|
||||
;; TARGET can be safely unmounted.
|
||||
|
||||
;; Make sure PID 1 doesn't keep TARGET busy.
|
||||
(chdir "/")
|
||||
;; Make sure PID 1 doesn't keep TARGET busy.
|
||||
(chdir "/")
|
||||
|
||||
(umount #$target)
|
||||
#f))
|
||||
(umount #$target)
|
||||
#f))
|
||||
|
||||
;; We need an additional module.
|
||||
(modules `(((gnu build file-systems)
|
||||
#:select (check-file-system canonicalize-device-spec))
|
||||
,@%default-modules))
|
||||
(imported-modules `((gnu build file-systems)
|
||||
(guix build bournish)
|
||||
,@%default-imported-modules))))
|
||||
;; We need an additional module.
|
||||
(modules `(((gnu build file-systems)
|
||||
#:select (check-file-system canonicalize-device-spec))
|
||||
,@%default-modules)))))
|
||||
'())))
|
||||
|
||||
(define file-system-service-type
|
||||
|
|
|
@ -47,9 +47,7 @@ (define-module (gnu services shepherd)
|
|||
shepherd-service-stop
|
||||
shepherd-service-auto-start?
|
||||
shepherd-service-modules
|
||||
shepherd-service-imported-modules
|
||||
|
||||
%default-imported-modules
|
||||
%default-modules
|
||||
|
||||
shepherd-service-file
|
||||
|
@ -138,9 +136,7 @@ (define-record-type* <shepherd-service>
|
|||
(auto-start? shepherd-service-auto-start? ;Boolean
|
||||
(default #t))
|
||||
(modules shepherd-service-modules ;list of module names
|
||||
(default %default-modules))
|
||||
(imported-modules shepherd-service-imported-modules ;list of module names
|
||||
(default %default-imported-modules)))
|
||||
(default %default-modules)))
|
||||
|
||||
(define (shepherd-service-canonical-name service)
|
||||
"Return the 'canonical name' of SERVICE."
|
||||
|
@ -203,37 +199,26 @@ (define (shepherd-service-file-name service)
|
|||
(define (shepherd-service-file service)
|
||||
"Return a file defining SERVICE."
|
||||
(gexp->file (shepherd-service-file-name service)
|
||||
#~(begin
|
||||
(use-modules #$@(shepherd-service-modules service))
|
||||
(with-imported-modules %default-imported-modules
|
||||
#~(begin
|
||||
(use-modules #$@(shepherd-service-modules service))
|
||||
|
||||
(make <service>
|
||||
#:docstring '#$(shepherd-service-documentation service)
|
||||
#:provides '#$(shepherd-service-provision service)
|
||||
#:requires '#$(shepherd-service-requirement service)
|
||||
#:respawn? '#$(shepherd-service-respawn? service)
|
||||
#:start #$(shepherd-service-start service)
|
||||
#:stop #$(shepherd-service-stop service)))))
|
||||
(make <service>
|
||||
#:docstring '#$(shepherd-service-documentation service)
|
||||
#:provides '#$(shepherd-service-provision service)
|
||||
#:requires '#$(shepherd-service-requirement service)
|
||||
#:respawn? '#$(shepherd-service-respawn? service)
|
||||
#:start #$(shepherd-service-start service)
|
||||
#:stop #$(shepherd-service-stop service))))))
|
||||
|
||||
(define (shepherd-configuration-file services)
|
||||
"Return the shepherd configuration file for SERVICES."
|
||||
(define modules
|
||||
(delete-duplicates
|
||||
(append-map shepherd-service-imported-modules services)))
|
||||
|
||||
(assert-valid-graph services)
|
||||
|
||||
(mlet %store-monad ((modules (imported-modules modules))
|
||||
(compiled (compiled-modules modules))
|
||||
(files (mapm %store-monad
|
||||
shepherd-service-file
|
||||
services)))
|
||||
(mlet %store-monad ((files (mapm %store-monad
|
||||
shepherd-service-file services)))
|
||||
(define config
|
||||
#~(begin
|
||||
(eval-when (expand load eval)
|
||||
(set! %load-path (cons #$modules %load-path))
|
||||
(set! %load-compiled-path
|
||||
(cons #$compiled %load-compiled-path)))
|
||||
|
||||
(use-modules (srfi srfi-34)
|
||||
(system repl error-handling))
|
||||
|
||||
|
|
|
@ -85,9 +85,7 @@ (define device-mapping-service-type
|
|||
(modules `((rnrs bytevectors) ;bytevector?
|
||||
((gnu build file-systems)
|
||||
#:select (find-partition-by-luks-uuid))
|
||||
,@%default-modules))
|
||||
(imported-modules `((gnu build file-systems)
|
||||
,@%default-imported-modules)))))))
|
||||
,@%default-modules)))))))
|
||||
|
||||
(define (device-mapping-service mapped-device)
|
||||
"Return a service that sets up @var{mapped-device}."
|
||||
|
@ -101,20 +99,22 @@ (define (device-mapping-service mapped-device)
|
|||
(define (open-luks-device source target)
|
||||
"Return a gexp that maps SOURCE to TARGET as a LUKS device, using
|
||||
'cryptsetup'."
|
||||
#~(let ((source #$source))
|
||||
(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup")
|
||||
"open" "--type" "luks"
|
||||
(with-imported-modules '((gnu build file-systems)
|
||||
(guix build bournish))
|
||||
#~(let ((source #$source))
|
||||
(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup")
|
||||
"open" "--type" "luks"
|
||||
|
||||
;; Note: We cannot use the "UUID=source" syntax here
|
||||
;; because 'cryptsetup' implements it by searching the
|
||||
;; udev-populated /dev/disk/by-id directory but udev may
|
||||
;; be unavailable at the time we run this.
|
||||
(if (bytevector? source)
|
||||
(or (find-partition-by-luks-uuid source)
|
||||
(error "LUKS partition not found" source))
|
||||
source)
|
||||
;; Note: We cannot use the "UUID=source" syntax here
|
||||
;; because 'cryptsetup' implements it by searching the
|
||||
;; udev-populated /dev/disk/by-id directory but udev may
|
||||
;; be unavailable at the time we run this.
|
||||
(if (bytevector? source)
|
||||
(or (find-partition-by-luks-uuid source)
|
||||
(error "LUKS partition not found" source))
|
||||
source)
|
||||
|
||||
#$target))))
|
||||
#$target)))))
|
||||
|
||||
(define (close-luks-device source target)
|
||||
"Return a gexp that closes TARGET, a LUKS device."
|
||||
|
|
112
gnu/tests.scm
112
gnu/tests.scm
|
@ -80,68 +80,68 @@ (define (marionette-shepherd-service config)
|
|||
(srfi srfi-9 gnu)
|
||||
(guix build syscalls)
|
||||
(rnrs bytevectors)))
|
||||
(imported-modules `((guix build syscalls)
|
||||
,@imported-modules))
|
||||
(start
|
||||
#~(lambda ()
|
||||
(define (clear-echo termios)
|
||||
(set-field termios (termios-local-flags)
|
||||
(logand (lognot (local-flags ECHO))
|
||||
(termios-local-flags termios))))
|
||||
(with-imported-modules `((guix build syscalls)
|
||||
,@imported-modules)
|
||||
#~(lambda ()
|
||||
(define (clear-echo termios)
|
||||
(set-field termios (termios-local-flags)
|
||||
(logand (lognot (local-flags ECHO))
|
||||
(termios-local-flags termios))))
|
||||
|
||||
(define (self-quoting? x)
|
||||
(letrec-syntax ((one-of (syntax-rules ()
|
||||
((_) #f)
|
||||
((_ pred rest ...)
|
||||
(or (pred x)
|
||||
(one-of rest ...))))))
|
||||
(one-of symbol? string? pair? null? vector?
|
||||
bytevector? number? boolean?)))
|
||||
(define (self-quoting? x)
|
||||
(letrec-syntax ((one-of (syntax-rules ()
|
||||
((_) #f)
|
||||
((_ pred rest ...)
|
||||
(or (pred x)
|
||||
(one-of rest ...))))))
|
||||
(one-of symbol? string? pair? null? vector?
|
||||
bytevector? number? boolean?)))
|
||||
|
||||
(match (primitive-fork)
|
||||
(0
|
||||
(dynamic-wind
|
||||
(const #t)
|
||||
(lambda ()
|
||||
(let* ((repl (open-file #$device "r+0"))
|
||||
(termios (tcgetattr (fileno repl)))
|
||||
(console (open-file "/dev/console" "r+0")))
|
||||
;; Don't echo input back.
|
||||
(tcsetattr (fileno repl) (tcsetattr-action TCSANOW)
|
||||
(clear-echo termios))
|
||||
(match (primitive-fork)
|
||||
(0
|
||||
(dynamic-wind
|
||||
(const #t)
|
||||
(lambda ()
|
||||
(let* ((repl (open-file #$device "r+0"))
|
||||
(termios (tcgetattr (fileno repl)))
|
||||
(console (open-file "/dev/console" "r+0")))
|
||||
;; Don't echo input back.
|
||||
(tcsetattr (fileno repl) (tcsetattr-action TCSANOW)
|
||||
(clear-echo termios))
|
||||
|
||||
;; Redirect output to the console.
|
||||
(close-fdes 1)
|
||||
(close-fdes 2)
|
||||
(dup2 (fileno console) 1)
|
||||
(dup2 (fileno console) 2)
|
||||
(close-port console)
|
||||
;; Redirect output to the console.
|
||||
(close-fdes 1)
|
||||
(close-fdes 2)
|
||||
(dup2 (fileno console) 1)
|
||||
(dup2 (fileno console) 2)
|
||||
(close-port console)
|
||||
|
||||
(display 'ready repl)
|
||||
(let loop ()
|
||||
(newline repl)
|
||||
(display 'ready repl)
|
||||
(let loop ()
|
||||
(newline repl)
|
||||
|
||||
(match (read repl)
|
||||
((? eof-object?)
|
||||
(primitive-exit 0))
|
||||
(expr
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(let ((result (primitive-eval expr)))
|
||||
(write (if (self-quoting? result)
|
||||
result
|
||||
(object->string result))
|
||||
repl)))
|
||||
(lambda (key . args)
|
||||
(print-exception (current-error-port)
|
||||
(stack-ref (make-stack #t) 1)
|
||||
key args)
|
||||
(write #f repl)))))
|
||||
(loop))))
|
||||
(lambda ()
|
||||
(primitive-exit 1))))
|
||||
(pid
|
||||
pid))))
|
||||
(match (read repl)
|
||||
((? eof-object?)
|
||||
(primitive-exit 0))
|
||||
(expr
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(let ((result (primitive-eval expr)))
|
||||
(write (if (self-quoting? result)
|
||||
result
|
||||
(object->string result))
|
||||
repl)))
|
||||
(lambda (key . args)
|
||||
(print-exception (current-error-port)
|
||||
(stack-ref (make-stack #t) 1)
|
||||
key args)
|
||||
(write #f repl)))))
|
||||
(loop))))
|
||||
(lambda ()
|
||||
(primitive-exit 1))))
|
||||
(pid
|
||||
pid)))))
|
||||
(stop #~(make-kill-destructor)))))))
|
||||
|
||||
(define marionette-service-type
|
||||
|
|
Loading…
Reference in a new issue