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 This is the list of modules that must be in scope when @code{start} and
@code{stop} are evaluated. @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 table
@end deftp @end deftp

95
gnu/services/base.scm
View File

@ -229,59 +229,58 @@ FILE-SYSTEM."
(create? (file-system-create-mount-point? file-system)) (create? (file-system-create-mount-point? file-system))
(dependencies (file-system-dependencies file-system))) (dependencies (file-system-dependencies file-system)))
(if (file-system-mount? file-system) (if (file-system-mount? file-system)
(list (with-imported-modules '((gnu build file-systems)
(shepherd-service (guix build bournish))
(provision (list (file-system->shepherd-service-name file-system))) (list
(requirement `(root-file-system (shepherd-service
,@(map dependency->shepherd-service-name dependencies))) (provision (list (file-system->shepherd-service-name file-system)))
(documentation "Check, mount, and unmount the given file system.") (requirement `(root-file-system
(start #~(lambda args ,@(map dependency->shepherd-service-name dependencies)))
;; FIXME: Use or factorize with 'mount-file-system'. (documentation "Check, mount, and unmount the given file system.")
(let ((device (canonicalize-device-spec #$device '#$title)) (start #~(lambda args
(flags #$(mount-flags->bit-mask ;; FIXME: Use or factorize with 'mount-file-system'.
(file-system-flags file-system)))) (let ((device (canonicalize-device-spec #$device '#$title))
#$(if create? (flags #$(mount-flags->bit-mask
#~(mkdir-p #$target) (file-system-flags file-system))))
#~#t) #$(if create?
#$(if check? #~(mkdir-p #$target)
#~(begin #~#t)
;; Make sure fsck.ext2 & co. can be found. #$(if check?
(setenv "PATH" #~(begin
(string-append ;; Make sure fsck.ext2 & co. can be found.
#$e2fsprogs "/sbin:" (setenv "PATH"
"/run/current-system/profile/sbin:" (string-append
(getenv "PATH"))) #$e2fsprogs "/sbin:"
(check-file-system device #$type)) "/run/current-system/profile/sbin:"
#~#t) (getenv "PATH")))
(check-file-system device #$type))
#~#t)
(mount device #$target #$type flags (mount device #$target #$type flags
#$(file-system-options file-system)) #$(file-system-options file-system))
;; For read-only bind mounts, an extra remount is ;; For read-only bind mounts, an extra remount is
;; needed, as per <http://lwn.net/Articles/281157/>, ;; needed, as per <http://lwn.net/Articles/281157/>,
;; which still applies to Linux 4.0. ;; which still applies to Linux 4.0.
(when (and (= MS_BIND (logand flags MS_BIND)) (when (and (= MS_BIND (logand flags MS_BIND))
(= MS_RDONLY (logand flags MS_RDONLY))) (= MS_RDONLY (logand flags MS_RDONLY)))
(mount device #$target #$type (mount device #$target #$type
(logior MS_BIND MS_REMOUNT MS_RDONLY)))) (logior MS_BIND MS_REMOUNT MS_RDONLY))))
#t)) #t))
(stop #~(lambda args (stop #~(lambda args
;; Normally there are no processes left at this point, so ;; Normally there are no processes left at this point, so
;; TARGET can be safely unmounted. ;; TARGET can be safely unmounted.
;; Make sure PID 1 doesn't keep TARGET busy. ;; Make sure PID 1 doesn't keep TARGET busy.
(chdir "/") (chdir "/")
(umount #$target) (umount #$target)
#f)) #f))
;; We need an additional module. ;; We need an additional module.
(modules `(((gnu build file-systems) (modules `(((gnu build file-systems)
#:select (check-file-system canonicalize-device-spec)) #:select (check-file-system canonicalize-device-spec))
,@%default-modules)) ,@%default-modules)))))
(imported-modules `((gnu build file-systems)
(guix build bournish)
,@%default-imported-modules))))
'()))) '())))
(define file-system-service-type (define file-system-service-type

41
gnu/services/shepherd.scm
View File

@ -47,9 +47,7 @@
shepherd-service-stop shepherd-service-stop
shepherd-service-auto-start? shepherd-service-auto-start?
shepherd-service-modules shepherd-service-modules
shepherd-service-imported-modules
%default-imported-modules
%default-modules %default-modules
shepherd-service-file 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 (auto-start? shepherd-service-auto-start? ;Boolean
(default #t)) (default #t))
(modules shepherd-service-modules ;list of module names (modules shepherd-service-modules ;list of module names
(default %default-modules)) (default %default-modules)))
(imported-modules shepherd-service-imported-modules ;list of module names
(default %default-imported-modules)))
(define (shepherd-service-canonical-name service) (define (shepherd-service-canonical-name service)
"Return the 'canonical name' of SERVICE." "Return the 'canonical name' of SERVICE."
@ -203,37 +199,26 @@ stored."
(define (shepherd-service-file service) (define (shepherd-service-file service)
"Return a file defining SERVICE." "Return a file defining SERVICE."
(gexp->file (shepherd-service-file-name service) (gexp->file (shepherd-service-file-name service)
#~(begin (with-imported-modules %default-imported-modules
(use-modules #$@(shepherd-service-modules service)) #~(begin
(use-modules #$@(shepherd-service-modules service))
(make <service> (make <service>
#:docstring '#$(shepherd-service-documentation service) #:docstring '#$(shepherd-service-documentation service)
#:provides '#$(shepherd-service-provision service) #:provides '#$(shepherd-service-provision service)
#:requires '#$(shepherd-service-requirement service) #:requires '#$(shepherd-service-requirement service)
#:respawn? '#$(shepherd-service-respawn? service) #:respawn? '#$(shepherd-service-respawn? service)
#:start #$(shepherd-service-start service) #:start #$(shepherd-service-start service)
#:stop #$(shepherd-service-stop service))))) #:stop #$(shepherd-service-stop service))))))
(define (shepherd-configuration-file services) (define (shepherd-configuration-file services)
"Return the shepherd configuration file for SERVICES." "Return the shepherd configuration file for SERVICES."
(define modules
(delete-duplicates
(append-map shepherd-service-imported-modules services)))
(assert-valid-graph services) (assert-valid-graph services)
(mlet %store-monad ((modules (imported-modules modules)) (mlet %store-monad ((files (mapm %store-monad
(compiled (compiled-modules modules)) shepherd-service-file services)))
(files (mapm %store-monad
shepherd-service-file
services)))
(define config (define config
#~(begin #~(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) (use-modules (srfi srfi-34)
(system repl error-handling)) (system repl error-handling))

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

@ -85,9 +85,7 @@
(modules `((rnrs bytevectors) ;bytevector? (modules `((rnrs bytevectors) ;bytevector?
((gnu build file-systems) ((gnu build file-systems)
#:select (find-partition-by-luks-uuid)) #:select (find-partition-by-luks-uuid))
,@%default-modules)) ,@%default-modules)))))))
(imported-modules `((gnu build file-systems)
,@%default-imported-modules)))))))
(define (device-mapping-service mapped-device) (define (device-mapping-service mapped-device)
"Return a service that sets up @var{mapped-device}." "Return a service that sets up @var{mapped-device}."
@ -101,20 +99,22 @@
(define (open-luks-device source target) (define (open-luks-device source target)
"Return a gexp that maps SOURCE to TARGET as a LUKS device, using "Return a gexp that maps SOURCE to TARGET as a LUKS device, using
'cryptsetup'." 'cryptsetup'."
#~(let ((source #$source)) (with-imported-modules '((gnu build file-systems)
(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup") (guix build bournish))
"open" "--type" "luks" #~(let ((source #$source))
(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup")
"open" "--type" "luks"
;; Note: We cannot use the "UUID=source" syntax here ;; Note: We cannot use the "UUID=source" syntax here
;; because 'cryptsetup' implements it by searching the ;; because 'cryptsetup' implements it by searching the
;; udev-populated /dev/disk/by-id directory but udev may ;; udev-populated /dev/disk/by-id directory but udev may
;; be unavailable at the time we run this. ;; be unavailable at the time we run this.
(if (bytevector? source) (if (bytevector? source)
(or (find-partition-by-luks-uuid source) (or (find-partition-by-luks-uuid source)
(error "LUKS partition not found" source)) (error "LUKS partition not found" source))
source) source)
#$target)))) #$target)))))
(define (close-luks-device source target) (define (close-luks-device source target)
"Return a gexp that closes TARGET, a LUKS device." "Return a gexp that closes TARGET, a LUKS device."

112
gnu/tests.scm
View File

@ -80,68 +80,68 @@
(srfi srfi-9 gnu) (srfi srfi-9 gnu)
(guix build syscalls) (guix build syscalls)
(rnrs bytevectors))) (rnrs bytevectors)))
(imported-modules `((guix build syscalls)
,@imported-modules))
(start (start
#~(lambda () (with-imported-modules `((guix build syscalls)
(define (clear-echo termios) ,@imported-modules)
(set-field termios (termios-local-flags) #~(lambda ()
(logand (lognot (local-flags ECHO)) (define (clear-echo termios)
(termios-local-flags termios)))) (set-field termios (termios-local-flags)
(logand (lognot (local-flags ECHO))
(termios-local-flags termios))))
(define (self-quoting? x) (define (self-quoting? x)
(letrec-syntax ((one-of (syntax-rules () (letrec-syntax ((one-of (syntax-rules ()
((_) #f) ((_) #f)
((_ pred rest ...) ((_ pred rest ...)
(or (pred x) (or (pred x)
(one-of rest ...)))))) (one-of rest ...))))))
(one-of symbol? string? pair? null? vector? (one-of symbol? string? pair? null? vector?
bytevector? number? boolean?))) bytevector? number? boolean?)))
(match (primitive-fork) (match (primitive-fork)
(0 (0
(dynamic-wind (dynamic-wind
(const #t) (const #t)
(lambda () (lambda ()
(let* ((repl (open-file #$device "r+0")) (let* ((repl (open-file #$device "r+0"))
(termios (tcgetattr (fileno repl))) (termios (tcgetattr (fileno repl)))
(console (open-file "/dev/console" "r+0"))) (console (open-file "/dev/console" "r+0")))
;; Don't echo input back. ;; Don't echo input back.
(tcsetattr (fileno repl) (tcsetattr-action TCSANOW) (tcsetattr (fileno repl) (tcsetattr-action TCSANOW)
(clear-echo termios)) (clear-echo termios))
;; Redirect output to the console. ;; Redirect output to the console.
(close-fdes 1) (close-fdes 1)
(close-fdes 2) (close-fdes 2)
(dup2 (fileno console) 1) (dup2 (fileno console) 1)
(dup2 (fileno console) 2) (dup2 (fileno console) 2)
(close-port console) (close-port console)
(display 'ready repl) (display 'ready repl)
(let loop () (let loop ()
(newline repl) (newline repl)
(match (read repl) (match (read repl)
((? eof-object?) ((? eof-object?)
(primitive-exit 0)) (primitive-exit 0))
(expr (expr
(catch #t (catch #t
(lambda () (lambda ()
(let ((result (primitive-eval expr))) (let ((result (primitive-eval expr)))
(write (if (self-quoting? result) (write (if (self-quoting? result)
result result
(object->string result)) (object->string result))
repl))) repl)))
(lambda (key . args) (lambda (key . args)
(print-exception (current-error-port) (print-exception (current-error-port)
(stack-ref (make-stack #t) 1) (stack-ref (make-stack #t) 1)
key args) key args)
(write #f repl))))) (write #f repl)))))
(loop)))) (loop))))
(lambda () (lambda ()
(primitive-exit 1)))) (primitive-exit 1))))
(pid (pid
pid)))) pid)))))
(stop #~(make-kill-destructor))))))) (stop #~(make-kill-destructor)))))))
(define marionette-service-type (define marionette-service-type