nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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:
Ludovic Courtès 2016-07-12 00:38:50 +02:00
parent fd12989398
commit a91c3fc727
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
5 changed files with 131 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
doc/guix.texi
View File

@ -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

95
gnu/services/base.scm
View File

@ -229,59 +229,58 @@ 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

41
gnu/services/shepherd.scm
View File

@ -47,9 +47,7 @@
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 @@ for a service that extends SHEPHERD-ROOT-SERVICE-TYPE and nothing else."
(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 @@ stored."
(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))

30
gnu/system/mapped-devices.scm
View File

@ -85,9 +85,7 @@
(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 (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
View File

@ -80,68 +80,68 @@
(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