From 0b6f49ef69b4429e05f6e76ccd2ee9e1d07e7776 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 23 Apr 2014 15:47:42 +0200 Subject: system: Factorize (gnu system). * gnu/system.scm (operating-system-accounts, operating-system-etc-directory): New procedures. (operating-system-derivation): Use them. * gnu/services/base.scm (%base-services): Add 'host-name-service' invocation. --- gnu/services/base.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'gnu/services') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index d6c1707c6..3145a657f 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -186,6 +186,9 @@ This is the GNU operating system, welcome!\n\n"))) (mingetty-service "tty6" #:motd motd) (syslog-service) (guix-service) - (nscd-service)))) + (nscd-service) + + ;; FIXME: Make this an activation-time thing instead of a service. + (host-name-service "gnu")))) ;;; base.scm ends here -- cgit v1.3 From b5f4e686359d8842b329e6b161ef89fa6c04ebc3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Apr 2014 23:07:08 +0200 Subject: services: Rewrite using gexps. * gnu/services.scm ()[inputs]: Remove. * gnu/system.scm (links): Remove. (etc-directory): Add PASSWD and SHADOW to #:inputs. (operating-system-boot-script): Pass ETC to 'dmd-configuration-file'. (operating-system-derivation): Remove EXTRAS from the union. * gnu/system/linux.scm (pam-service->configuration): Rewrite in terms of 'gexp->derivation'. Compute the contents on the build side. Expect 'arguments' to contain a list of gexps. (pam-services->directory): Rewrite in terms of 'gexp->derivation'. (unix-pam-service): Change 'arguments' to a list of one gexp. * gnu/system/shadow.scm ()[inputs]: Remove. [shell]: Change default value to a gexp. (passwd-file): Rewrite in terms of 'gexp->derivation'. Compute contents on the build side. * gnu/services/base.scm (host-name-service, mingetty-service, nscd-service, syslog-service, guix-service): Change 'start' and 'stop' to gexps; remove 'inputs' field. (guix-build-accounts): Change 'shell' field to a gexp. * gnu/services/networking.scm (static-networking-service): Change 'start' and 'stop' to gexps; remove 'inputs' field. * gnu/services/xorg.scm (slim-service): Likewise. * gnu/services/dmd.scm (dmd-configuration-file): Expect ETC to be a derivation. Change 'config' to a gexp. Use 'gexp->file' instead of 'text-file'. * doc/guix.texi (Defining Services): Update nscd example with gexps, and without 'inputs'. Add xref to "G-Expressions". --- doc/guix.texi | 31 +++++++++--------- gnu/services.scm | 7 ++--- gnu/services/base.scm | 60 +++++++++++++++++------------------ gnu/services/dmd.scm | 77 +++++++++++++++++++++++---------------------- gnu/services/networking.scm | 58 +++++++++++++++++----------------- gnu/services/xorg.scm | 19 +++++------ gnu/system.scm | 44 +++++--------------------- gnu/system/linux.scm | 74 +++++++++++++++++++++---------------------- gnu/system/shadow.scm | 48 ++++++++++++---------------- 9 files changed, 187 insertions(+), 231 deletions(-) (limited to 'gnu/services') diff --git a/doc/guix.texi b/doc/guix.texi index 9fb226c65..bbfdce51f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3224,29 +3224,26 @@ like: @lisp (define (nscd-service) - (mlet %store-monad ((nscd (package-file glibc "sbin/nscd"))) + (with-monad %store-monad (return (service (documentation "Run libc's name service cache daemon.") (provision '(nscd)) - (start `(make-forkexec-constructor ,nscd "-f" "/dev/null" - "--foreground")) - (stop `(make-kill-destructor)) - - (respawn? #f) - (inputs `(("glibc" ,glibc))))))) + (start #~(make-forkexec-constructor + (string-append #$glibc "/sbin/nscd") + "-f" "/dev/null" "--foreground")) + (stop #~(make-kill-destructor)) + (respawn? #f))))) @end lisp @noindent -The @code{inputs} field specifies that this service depends on the -@var{glibc} package---the package that contains the @command{nscd} -program. The @code{start} and @code{stop} fields are expressions that -make use of dmd's facilities to start and stop processes (@pxref{Service -De- and Constructors,,, dmd, GNU dmd Manual}). The @code{provision} -field specifies the name under which this service is known to dmd, and -@code{documentation} specifies on-line documentation. Thus, the -commands @command{deco start ncsd}, @command{deco stop nscd}, and -@command{deco doc nscd} will do what you would expect (@pxref{Invoking -deco,,, dmd, GNU dmd Manual}). +The @code{start} and @code{stop} fields are G-expressions +(@pxref{G-Expressions}). They refer to dmd's facilities to start and +stop processes (@pxref{Service De- and Constructors,,, dmd, GNU dmd +Manual}). The @code{provision} field specifies the name under which +this service is known to dmd, and @code{documentation} specifies on-line +documentation. Thus, the commands @command{deco start ncsd}, +@command{deco stop nscd}, and @command{deco doc nscd} will do what you +would expect (@pxref{Invoking deco,,, dmd, GNU dmd Manual}). @c ********************************************************************* diff --git a/gnu/services.scm b/gnu/services.scm index eccde4e9a..8b89b11b8 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -26,7 +26,6 @@ service-respawn? service-start service-stop - service-inputs service-user-accounts service-user-groups service-pam-services)) @@ -47,11 +46,9 @@ (default '())) (respawn? service-respawn? ; Boolean (default #t)) - (start service-start) ; expression - (stop service-stop ; expression + (start service-start) ; g-expression + (stop service-stop ; g-expression (default #f)) - (inputs service-inputs ; list of inputs - (default '())) (user-accounts service-user-accounts ; list of (default '())) (user-groups service-user-groups ; list of diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 3145a657f..956199524 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -24,6 +24,7 @@ #:use-module ((gnu packages base) #:select (glibc-final)) #:use-module (gnu packages package-management) + #:use-module (guix gexp) #:use-module (guix monads) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -48,8 +49,8 @@ (return (service (documentation "Initialize the machine's host name.") (provision '(host-name)) - (start `(lambda _ - (sethostname ,name))) + (start #~(lambda _ + (sethostname #$name))) (respawn? #f))))) (define* (mingetty-service tty @@ -57,8 +58,7 @@ (motd (text-file "motd" "Welcome.\n")) (allow-empty-passwords? #t)) "Return a service to run mingetty on TTY." - (mlet %store-monad ((mingetty-bin (package-file mingetty "sbin/mingetty")) - (motd motd)) + (mlet %store-monad ((motd motd)) (return (service (documentation (string-append "Run mingetty on " tty ".")) @@ -68,10 +68,10 @@ ;; service to be done. (requirement '(host-name)) - (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty)) - (stop `(make-kill-destructor)) - (inputs `(("mingetty" ,mingetty) - ("motd" ,motd))) + (start #~(make-forkexec-constructor + (string-append #$mingetty "/sbin/mingetty") + "--noclear" #$tty)) + (stop #~(make-kill-destructor)) (pam-services ;; Let 'login' be known to PAM. All the mingetty services will have @@ -83,16 +83,17 @@ (define* (nscd-service #:key (glibc glibc-final)) "Return a service that runs libc's name service cache daemon (nscd)." - (mlet %store-monad ((nscd (package-file glibc "sbin/nscd"))) + (with-monad %store-monad (return (service (documentation "Run libc's name service cache daemon (nscd).") (provision '(nscd)) - (start `(make-forkexec-constructor ,nscd "-f" "/dev/null" - "--foreground")) - (stop `(make-kill-destructor)) + (start + #~(make-forkexec-constructor (string-append #$glibc "/sbin/nscd") + "-f" "/dev/null" + "--foreground")) + (stop #~(make-kill-destructor)) - (respawn? #f) - (inputs `(("glibc" ,glibc))))))) + (respawn? #f))))) (define (syslog-service) "Return a service that runs 'syslogd' with reasonable default settings." @@ -120,17 +121,17 @@ ") (mlet %store-monad - ((syslog.conf (text-file "syslog.conf" contents)) - (syslogd (package-file inetutils "libexec/syslogd"))) + ((syslog.conf (text-file "syslog.conf" contents))) (return (service (documentation "Run the syslog daemon (syslogd).") (provision '(syslogd)) - (start `(make-forkexec-constructor ,syslogd "--no-detach" - "--rcfile" ,syslog.conf)) - (stop `(make-kill-destructor)) - (inputs `(("inetutils" ,inetutils) - ("syslog.conf" ,syslog.conf))))))) + (start + #~(make-forkexec-constructor (string-append #$inetutils + "/libexec/syslogd") + "--no-detach" + "--rcfile" #$syslog.conf)) + (stop #~(make-kill-destructor)))))) (define* (guix-build-accounts count #:key (first-uid 30001) @@ -148,8 +149,7 @@ starting at FIRST-UID, and under GID." (gid gid) (comment (format #f "Guix Build User ~2d" n)) (home-directory "/var/empty") - (shell (package-file shadow "sbin/nologin")) - (inputs `(("shadow" ,shadow))))) + (shell #~(string-append #$shadow "/sbin/nologin")))) 1+ 1)))) @@ -157,16 +157,16 @@ starting at FIRST-UID, and under GID." (build-user-gid 30000) (build-accounts 10)) "Return a service that runs the build daemon from GUIX, and has BUILD-ACCOUNTS user accounts available under BUILD-USER-GID." - (mlet %store-monad ((daemon (package-file guix "bin/guix-daemon")) - (accounts (guix-build-accounts build-accounts + (mlet %store-monad ((accounts (guix-build-accounts build-accounts #:gid build-user-gid))) (return (service (provision '(guix-daemon)) - (start `(make-forkexec-constructor ,daemon - "--build-users-group" - ,builder-group)) - (stop `(make-kill-destructor)) - (inputs `(("guix" ,guix))) + (start + #~(make-forkexec-constructor (string-append #$guix + "/bin/guix-daemon") + "--build-users-group" + #$builder-group)) + (stop #~(make-kill-destructor)) (user-accounts accounts) (user-groups (list (user-group (name builder-group) diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 54fb5cbfd..c187c0985 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu services dmd) + #:use-module (guix gexp) #:use-module (guix monads) #:use-module (gnu services) #:use-module (ice-9 match) @@ -31,50 +32,50 @@ (define (dmd-configuration-file services etc) "Return the dmd configuration file for SERVICES, that initializes /etc from -ETC (the name of a directory in the store) on startup." +ETC (the derivation that builds the /etc directory) on startup." (define config - `(begin - (use-modules (ice-9 ftw)) + #~(begin + (use-modules (ice-9 ftw)) - (register-services - ,@(map (lambda (service) - `(make - #:docstring ',(service-documentation service) - #:provides ',(service-provision service) - #:requires ',(service-requirement service) - #:respawn? ',(service-respawn? service) - #:start ,(service-start service) - #:stop ,(service-stop service))) - services)) + (register-services + #$@(map (lambda (service) + #~(make + #:docstring '#$(service-documentation service) + #:provides '#$(service-provision service) + #:requires '#$(service-requirement service) + #:respawn? '#$(service-respawn? service) + #:start #$(service-start service) + #:stop #$(service-stop service))) + services)) - ;; /etc is a mixture of static and dynamic settings. Here is where we - ;; initialize it from the static part. - (format #t "populating /etc from ~a...~%" ,etc) - (let ((rm-f (lambda (f) - (false-if-exception (delete-file f))))) - (rm-f "/etc/static") - (symlink ,etc "/etc/static") - (for-each (lambda (file) - ;; TODO: Handle 'shadow' specially so that changed - ;; password aren't lost. - (let ((target (string-append "/etc/" file)) - (source (string-append "/etc/static/" file))) - (rm-f target) - (symlink source target))) - (scandir ,etc - (lambda (file) - (not (member file '("." "..")))))) + ;; /etc is a mixture of static and dynamic settings. Here is where we + ;; initialize it from the static part. + (format #t "populating /etc from ~a...~%" #$etc) + (let ((rm-f (lambda (f) + (false-if-exception (delete-file f))))) + (rm-f "/etc/static") + (symlink #$etc "/etc/static") + (for-each (lambda (file) + ;; TODO: Handle 'shadow' specially so that changed + ;; password aren't lost. + (let ((target (string-append "/etc/" file)) + (source (string-append "/etc/static/" file))) + (rm-f target) + (symlink source target))) + (scandir #$etc + (lambda (file) + (not (member file '("." "..")))))) - ;; Prevent ETC from being GC'd. - (rm-f "/var/guix/gcroots/etc-directory") - (symlink ,etc "/var/guix/gcroots/etc-directory")) + ;; Prevent ETC from being GC'd. + (rm-f "/var/guix/gcroots/etc-directory") + (symlink #$etc "/var/guix/gcroots/etc-directory")) - ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. - (setenv "PATH" "/run/current-system/bin") + ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. + (setenv "PATH" "/run/current-system/bin") - (format #t "starting services...~%") - (for-each start ',(append-map service-provision services)))) + (format #t "starting services...~%") + (for-each start '#$(append-map service-provision services)))) - (text-file "dmd.conf" (object->string config))) + (gexp->file "dmd.conf" config)) ;;; dmd.scm ends here diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index 317800db5..552254173 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -20,6 +20,7 @@ #:use-module (gnu services) #:use-module (gnu packages admin) #:use-module (gnu packages linux) + #:use-module (guix gexp) #:use-module (guix monads) #:export (static-networking-service)) @@ -41,40 +42,41 @@ true, it must be a string specifying the default network gateway." ;; TODO: Eventually we should do this using Guile's networking procedures, ;; like 'configure-qemu-networking' does, but the patch that does this is ;; not yet in stock Guile. - (mlet %store-monad ((ifconfig (package-file inetutils "bin/ifconfig")) - (route (package-file net-tools "sbin/route"))) + (with-monad %store-monad (return (service (documentation (string-append "Set up networking on the '" interface "' interface using a static IP address.")) (provision '(networking)) - (start `(lambda _ - ;; Return #t if successfully started. - (and (zero? (system* ,ifconfig ,interface ,ip "up")) - ,(if gateway - `(zero? (system* ,route "add" "-net" "default" - "gw" ,gateway)) - #t) - ,(if (pair? name-servers) - `(call-with-output-file "/etc/resolv.conf" - (lambda (port) - (display - "# Generated by 'static-networking-service'.\n" - port) - (for-each (lambda (server) - (format port "nameserver ~a~%" - server)) - ',name-servers))) - #t)))) - (stop `(lambda _ + (start #~(lambda _ + ;; Return #t if successfully started. + (and (zero? (system* (string-append #$inetutils + "/bin/ifconfig") + #$interface #$ip "up")) + #$(if gateway + #~(zero? (system* (string-append #$net-tools + "/sbin/route") + "add" "-net" "default" + "gw" #$gateway)) + #t) + #$(if (pair? name-servers) + #~(call-with-output-file "/etc/resolv.conf" + (lambda (port) + (display + "# Generated by 'static-networking-service'.\n" + port) + (for-each (lambda (server) + (format port "nameserver ~a~%" + server)) + '#$name-servers))) + #t)))) + (stop #~(lambda _ ;; Return #f is successfully stopped. - (not (and (system* ,ifconfig ,interface "down") - (system* ,route "del" "-net" "default"))))) - (respawn? #f) - (inputs `(("inetutils" ,inetutils) - ,@(if gateway - `(("net-tools" ,net-tools)) - '()))))))) + (not (and (system* (string-append #$inetutils "/sbin/ifconfig") + #$interface "down") + (system* (string-append #$net-tools "/sbin/route") + "del" "-net" "default"))))) + (respawn? #f))))) ;;; networking.scm ends here diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 086150a65..81b5bc17a 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -27,6 +27,7 @@ #:use-module (gnu packages gnustep) #:use-module (gnu packages admin) #:use-module (gnu packages bash) + #:use-module (guix gexp) #:use-module (guix monads) #:use-module (guix derivations) #:export (xorg-start-command @@ -190,9 +191,7 @@ reboot_cmd " dmd "/sbin/reboot (string-append "auto_login yes\ndefault_user " default-user) "")))) - (mlet %store-monad ((slim-bin (package-file slim "bin/slim")) - (bash-bin (package-file bash "bin/bash")) - (slim.cfg (slim.cfg))) + (mlet %store-monad ((slim.cfg (slim.cfg))) (return (service (documentation "Xorg display server") @@ -200,15 +199,11 @@ reboot_cmd " dmd "/sbin/reboot (requirement '(host-name)) (start ;; XXX: Work around the inability to specify env. vars. directly. - `(make-forkexec-constructor - ,bash-bin "-c" - ,(string-append "SLIM_CFGFILE=" (derivation->output-path slim.cfg) - " " slim-bin - " -nodaemon"))) - (stop `(make-kill-destructor)) - (inputs `(("slim" ,slim) - ("slim.cfg" ,slim.cfg) - ("bash" ,bash))) + #~(make-forkexec-constructor + (string-append #$bash "/bin/sh") "-c" + (string-append "SLIM_CFGFILE=" #$slim.cfg + " " #$slim "/bin/slim" " -nodaemon"))) + (stop #~(make-kill-destructor)) (respawn? #t) (pam-services ;; Tell PAM about 'slim'. diff --git a/gnu/system.scm b/gnu/system.scm index 65b524d38..20c49c182 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -192,29 +192,6 @@ as an inputs; additional inputs, such as derivations, are taken from INPUTS." #:inputs inputs #:local-build? #t)))) -(define (links inputs) - "Return a directory with symbolic links to all of INPUTS. This is -essentially useful when one wants to keep references to all of INPUTS, be they -directories or regular files." - (define builder - '(begin - (use-modules (srfi srfi-1)) - - (let ((out (assoc-ref %outputs "out"))) - (mkdir out) - (chdir out) - (fold (lambda (file number) - (symlink file (number->string number)) - (+ 1 number)) - 0 - (map cdr %build-inputs)) - #t))) - - (mlet %store-monad ((inputs (lower-inputs inputs))) - (derivation-expression "links" builder - #:inputs inputs - #:local-build? #t))) - (define* (etc-directory #:key (locale "C") (timezone "Europe/Paris") (accounts '()) @@ -272,12 +249,14 @@ alias ll='ls -l' ("shells" ,shells) ("profile" ,(derivation->output-path bashrc)) ("localtime" ,tz-file) - ("passwd" ,passwd) - ("shadow" ,shadow) + ("passwd" ,(derivation->output-path passwd)) + ("shadow" ,(derivation->output-path shadow)) ("group" ,group)))) (file-union files #:inputs `(("net" ,net-base) ("pam.d" ,pam.d) + ("passwd" ,passwd) + ("shadow" ,shadow) ("bashrc" ,bashrc) ("tzdata" ,tzdata)) #:name "etc"))) @@ -327,8 +306,7 @@ we're running in the final root." (mlet* %store-monad ((services (sequence %store-monad (operating-system-services os))) (etc (operating-system-etc-directory os)) - (dmd-conf (dmd-configuration-file services - (derivation->output-path etc)))) + (dmd-conf (dmd-configuration-file services etc))) (gexp->file "boot" #~(execl (string-append #$dmd "/bin/dmd") "dmd" "--config" #$dmd-conf)))) @@ -357,25 +335,19 @@ we're running in the final root." (linux-arguments `("--root=/dev/sda1" ,(string-append "--load=" boot))) (initrd initrd-file)))) - (grub.cfg (grub-configuration-file entries)) - (accounts (operating-system-accounts os)) - (extras (links (delete-duplicates - (append (append-map service-inputs services) - (append-map user-account-inputs accounts)))))) + (grub.cfg (grub-configuration-file entries))) (file-union `(("boot" ,boot) ("kernel" ,kernel-dir) ("initrd" ,initrd-file) ("profile" ,profile) ("grub.cfg" ,grub.cfg) - ("etc" ,etc) - ("system-inputs" ,(derivation->output-path extras))) + ("etc" ,etc)) #:inputs `(("boot" ,boot-drv) ("kernel" ,kernel) ("initrd" ,initrd) ("bash" ,bash) ("profile" ,profile-drv) - ("etc" ,etc-drv) - ("system-inputs" ,extras)) + ("etc" ,etc-drv)) #:name "system"))) ;;; system.scm ends here diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm index 65868ce9b..efe27c55c 100644 --- a/gnu/system/linux.scm +++ b/gnu/system/linux.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +21,7 @@ #:use-module (guix records) #:use-module (guix derivations) #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -58,58 +59,56 @@ (define-record-type* pam-entry make-pam-entry pam-entry? - (control pam-entry-control) ; string - (module pam-entry-module) ; file name - (arguments pam-entry-arguments ; list of strings + (control pam-entry-control) ; string + (module pam-entry-module) ; file name + (arguments pam-entry-arguments ; list of string-valued g-expressions (default '()))) (define (pam-service->configuration service) - "Return the configuration string for SERVICE, to be dumped in -/etc/pam.d/NAME, where NAME is the name of SERVICE." - (define (entry->string type entry) + "Return the derivation building the configuration file for SERVICE, to be +dumped in /etc/pam.d/NAME, where NAME is the name of SERVICE." + (define (entry->gexp type entry) (match entry (($ control module (arguments ...)) - (string-append type " " - control " " module " " - (string-join arguments) - "\n")))) + #~(format #t "~a ~a ~a ~a~%" + #$type #$control #$module + (string-join (list #$@arguments)))))) (match service (($ name account auth password session) - (string-concatenate - (append (map (cut entry->string "account" <>) account) - (map (cut entry->string "auth" <>) auth) - (map (cut entry->string "password" <>) password) - (map (cut entry->string "session" <>) session)))))) + (define builder + #~(begin + (with-output-to-file #$output + (lambda () + #$@(append (map (cut entry->gexp "account" <>) account) + (map (cut entry->gexp "auth" <>) auth) + (map (cut entry->gexp "password" <>) password) + (map (cut entry->gexp "session" <>) session)) + #t)))) + + (gexp->derivation name builder)))) (define (pam-services->directory services) "Return the derivation to build the configuration directory to be used as /etc/pam.d for SERVICES." (mlet %store-monad ((names -> (map pam-service-name services)) - (files (mapm %store-monad - (match-lambda - ((and service ($ name)) - (let ((config (pam-service->configuration service))) - (text-file (string-append name ".pam") config)))) - - ;; XXX: Eventually, SERVICES may be a list of monadic - ;; values instead of plain values. - (map return services)))) + (files (sequence %store-monad + (map pam-service->configuration + ;; XXX: Eventually, SERVICES may be a list of + ;; monadic values instead of plain values. + services)))) (define builder - '(begin - (use-modules (ice-9 match)) + #~(begin + (use-modules (ice-9 match)) - (let ((out (assoc-ref %outputs "out"))) - (mkdir out) - (for-each (match-lambda - ((name . file) - (symlink file (string-append out "/" name)))) - %build-inputs) - #t))) + (mkdir #$output) + (for-each (match-lambda + ((name file) + (symlink file (string-append #$output "/" name)))) + '#$(zip names files)))) - (derivation-expression "pam.d" builder - #:inputs (zip names files)))) + (gexp->derivation "pam.d" builder))) (define %pam-other-services ;; The "other" PAM configuration, which denies everything (see @@ -149,7 +148,8 @@ should be the name of a file used as the message-of-the-day." (pam-entry (control "optional") (module "pam_motd.so") - (arguments (list (string-append "motd=" motd))))) + (arguments + (list #~(string-append "motd=" #$motd))))) (list unix)))))))) ;;; linux.scm ends here diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index 2a85a20eb..52242ee4e 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,7 @@ #:use-module (guix store) #:use-module (guix records) #:use-module (guix packages) + #:use-module (guix gexp) #:use-module (guix monads) #:use-module ((gnu packages admin) #:select (shadow)) @@ -35,7 +36,6 @@ user-account-comment user-account-home-directory user-account-shell - user-account-inputs user-group user-group? @@ -63,9 +63,8 @@ (gid user-account-gid) (comment user-account-comment (default "")) (home-directory user-account-home-directory) - (shell user-account-shell ; monadic value - (default (package-file bash "bin/bash"))) - (inputs user-account-inputs (default `(("bash" ,bash))))) + (shell user-account-shell ; gexp + (default #~(string-append #$bash "/bin/bash")))) (define-record-type* user-group make-user-group @@ -97,29 +96,22 @@ SHADOW? is true, then it is a /etc/shadow file, otherwise it is a /etc/passwd file." ;; XXX: The resulting file is world-readable, so beware when SHADOW? is #t! - (define (contents) - (with-monad %store-monad - (let loop ((accounts accounts) - (result '())) - (match accounts - ((($ name pass uid gid comment home-dir mshell) - rest ...) - (mlet %store-monad ((shell mshell)) - (loop rest - (cons (if shadow? - (string-append name - ":" ; XXX: use (crypt PASS …)? - ":::::::") - (string-append name - ":" "x" - ":" (number->string uid) - ":" (number->string gid) - ":" comment ":" home-dir ":" shell)) - result)))) - (() - (return (string-join (reverse result) "\n" 'suffix))))))) + (define account-exp + (match-lambda + (($ name pass uid gid comment home-dir shell) + (if shadow? ; XXX: use (crypt PASS …)? + #~(format #t "~a::::::::~%" #$name) + #~(format #t "~a:x:~a:~a:~a:~a:~a~%" + #$name #$(number->string uid) #$(number->string gid) + #$comment #$home-dir #$shell))))) - (mlet %store-monad ((contents (contents))) - (text-file (if shadow? "shadow" "passwd") contents))) + (define builder + #~(begin + (with-output-to-file #$output + (lambda () + #$@(map account-exp accounts) + #t)))) + + (gexp->derivation (if shadow? "shadow" "passwd") builder)) ;;; shadow.scm ends here -- cgit v1.3 From 8779d3429414b62d3071987bacca7a9e0c8abc06 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Apr 2014 19:28:47 +0200 Subject: services: xorg: Rewrite using gexps. * gnu/services/xorg.scm (xorg-start-command): Rewrite in terms of 'gexp->script'. (xinitrc): Likewise. --- gnu/services/xorg.scm | 93 ++++++++++++++++----------------------------------- 1 file changed, 29 insertions(+), 64 deletions(-) (limited to 'gnu/services') diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 81b5bc17a..e47b33c9b 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -87,77 +87,42 @@ Section \"Screen\" Device \"Device-vesa\" EndSection")) - (mlet %store-monad ((guile-bin (package-file guile "bin/guile")) - (xorg-bin (package-file xorg-server "bin/X")) - (dri (package-file mesa "lib/dri")) - (xkbcomp-bin (package-file xkbcomp "bin")) - (xkb-dir (package-file xkeyboard-config - "share/X11/xkb")) - (config (xserver.conf))) - (define builder + (mlet %store-monad ((config (xserver.conf))) + (define script ;; Write a small wrapper around the X server. - `(let ((out (assoc-ref %outputs "out"))) - (call-with-output-file out - (lambda (port) - (format port "#!~a --no-auto-compile~%!#~%" ,guile-bin) - (write '(begin - (setenv "XORG_DRI_DRIVER_PATH" ,dri) - (setenv "XKB_BINDIR" ,xkbcomp-bin) - - (apply execl - - ,xorg-bin "-ac" "-logverbose" "-verbose" - "-xkbdir" ,xkb-dir - "-config" ,(derivation->output-path config) - "-nolisten" "tcp" "-terminate" - - ;; Note: SLiM and other display managers add the - ;; '-auth' flag by themselves. - (cdr (command-line)))) - port))) - (chmod out #o555) - #t)) - - (mlet %store-monad ((inputs (lower-inputs - `(("xorg" ,xorg-server) - ("xkbcomp" ,xkbcomp) - ("xkeyboard-config" ,xkeyboard-config) - ("mesa" ,mesa) - ("guile" ,guile) - ("xorg.conf" ,config))))) - (derivation-expression "start-xorg" builder - #:inputs inputs)))) + #~(begin + (setenv "XORG_DRI_DRIVER_PATH" (string-append #$mesa "/lib/dri")) + (setenv "XKB_BINDIR" (string-append #$xkbcomp "/bin")) + + (apply execl (string-append #$xorg-server "/bin/X") + "-ac" "-logverbose" "-verbose" + "-xkbdir" (string-append #$xkeyboard-config "/share/X11/xkb") + "-config" #$config + "-nolisten" "tcp" "-terminate" + + ;; Note: SLiM and other display managers add the + ;; '-auth' flag by themselves. + (cdr (command-line))))) + + (gexp->script "start-xorg" script))) (define* (xinitrc #:key (guile guile-final) (ratpoison ratpoison) (windowmaker windowmaker)) "Return a system-wide xinitrc script that starts the specified X session." - (mlet %store-monad ((guile-bin (package-file guile "bin/guile")) - (ratpoison-bin (package-file ratpoison "bin/ratpoison")) - (wmaker-bin (package-file windowmaker "bin/wmaker")) - (inputs (lower-inputs - `(("raptoison" ,ratpoison) - ("wmaker" ,windowmaker))))) - (define builder - `(let ((out (assoc-ref %outputs "out"))) - (call-with-output-file out - (lambda (port) - (format port "#!~a --no-auto-compile~%!#~%" ,guile-bin) - (write '(begin - (use-modules (ice-9 match)) - - ;; TODO: Check for ~/.xsession. - (match (command-line) - ((_ "ratpoison") - (execl ,ratpoison-bin)) - (_ - (execl ,wmaker-bin)))) - port))) - (chmod out #o555) - #t)) - - (derivation-expression "xinitrc" builder #:inputs inputs))) + (define builder + #~(begin + (use-modules (ice-9 match)) + + ;; TODO: Check for ~/.xsession. + (match (command-line) + ((_ "ratpoison") + (execl (string-append #$ratpoison "/bin/ratpoison"))) + (_ + (execl (string-append #$windowmaker "/bin/wmaker")))))) + + (gexp->script "xinitrc" builder)) (define* (slim-service #:key (slim slim) (allow-empty-passwords? #t) auto-login? -- cgit v1.3 From 4dfe6c58ee204cf05ce9ef5abbc96ada44ef0784 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 30 Apr 2014 15:44:59 +0200 Subject: system: Add (guix build activation). * gnu/services/dmd.scm (dmd-configuration-file): Remove 'etc' parameter. Move /etc activation code to... * guix/build/activation.scm: ... here; new file. * gnu/system.scm (operating-system-boot-script): Augment script: add (guix build activation) to the load path; call 'activate-etc'. * Makefile.am (MODULES): Add guix/build/activation.scm. --- Makefile.am | 1 + gnu/services/dmd.scm | 27 ++------------------ gnu/system.scm | 21 +++++++++++++--- guix/build/activation.scm | 63 +++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 84 insertions(+), 28 deletions(-) create mode 100644 guix/build/activation.scm (limited to 'gnu/services') diff --git a/Makefile.am b/Makefile.am index d01032f53..22bbdca13 100644 --- a/Makefile.am +++ b/Makefile.am @@ -71,6 +71,7 @@ MODULES = \ guix/build/rpath.scm \ guix/build/svn.scm \ guix/build/vm.scm \ + guix/build/activation.scm \ guix/packages.scm \ guix/snix.scm \ guix/scripts/download.scm \ diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index c187c0985..161a971ed 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -30,9 +30,8 @@ ;;; ;;; Code: -(define (dmd-configuration-file services etc) - "Return the dmd configuration file for SERVICES, that initializes /etc from -ETC (the derivation that builds the /etc directory) on startup." +(define (dmd-configuration-file services) + "Return the dmd configuration file for SERVICES." (define config #~(begin (use-modules (ice-9 ftw)) @@ -48,28 +47,6 @@ ETC (the derivation that builds the /etc directory) on startup." #:stop #$(service-stop service))) services)) - ;; /etc is a mixture of static and dynamic settings. Here is where we - ;; initialize it from the static part. - (format #t "populating /etc from ~a...~%" #$etc) - (let ((rm-f (lambda (f) - (false-if-exception (delete-file f))))) - (rm-f "/etc/static") - (symlink #$etc "/etc/static") - (for-each (lambda (file) - ;; TODO: Handle 'shadow' specially so that changed - ;; password aren't lost. - (let ((target (string-append "/etc/" file)) - (source (string-append "/etc/static/" file))) - (rm-f target) - (symlink source target))) - (scandir #$etc - (lambda (file) - (not (member file '("." "..")))))) - - ;; Prevent ETC from being GC'd. - (rm-f "/var/guix/gcroots/etc-directory") - (symlink #$etc "/var/guix/gcroots/etc-directory")) - ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. (setenv "PATH" "/run/current-system/bin") diff --git a/gnu/system.scm b/gnu/system.scm index 86904d9be..4a8585758 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -256,10 +256,25 @@ we're running in the final root." (mlet* %store-monad ((services (sequence %store-monad (operating-system-services os))) (etc (operating-system-etc-directory os)) - (dmd-conf (dmd-configuration-file services etc))) + (modules (imported-modules '((guix build activation)))) + (compiled (compiled-modules '((guix build activation)))) + (dmd-conf (dmd-configuration-file services))) (gexp->file "boot" - #~(execl (string-append #$dmd "/bin/dmd") - "dmd" "--config" #$dmd-conf)))) + #~(begin + (eval-when (expand load eval) + ;; Make sure 'use-modules' below succeeds. + (set! %load-path (cons #$modules %load-path)) + (set! %load-compiled-path + (cons #$compiled %load-compiled-path))) + + (use-modules (guix build activation)) + + ;; Populate /etc. + (activate-etc #$etc) + + ;; Start dmd. + (execl (string-append #$dmd "/bin/dmd") + "dmd" "--config" #$dmd-conf))))) (define (operating-system-derivation os) "Return a derivation that builds OS." diff --git a/guix/build/activation.scm b/guix/build/activation.scm new file mode 100644 index 000000000..c8491677d --- /dev/null +++ b/guix/build/activation.scm @@ -0,0 +1,63 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix build activation) + #:use-module (ice-9 ftw) + #:export (activate-etc)) + +;;; Commentary: +;;; +;;; This module provides "activation" helpers. Activation is the process that +;;; consists in setting up system-wide files and directories so that an +;;; 'operating-system' configuration becomes active. +;;; +;;; Code: + +(define (activate-etc etc) + "Install ETC, a directory in the store, as the source of static files for +/etc." + + ;; /etc is a mixture of static and dynamic settings. Here is where we + ;; initialize it from the static part. + + (format #t "populating /etc from ~a...~%" etc) + (let ((rm-f (lambda (f) + (false-if-exception (delete-file f))))) + (rm-f "/etc/static") + (symlink etc "/etc/static") + (for-each (lambda (file) + ;; TODO: Handle 'shadow' specially so that changed + ;; password aren't lost. + (let ((target (string-append "/etc/" file)) + (source (string-append "/etc/static/" file))) + (rm-f target) + (symlink source target))) + (scandir etc + (lambda (file) + (not (member file '("." "..")))) + + ;; The default is 'string-locale)[operating-system-services]: Rename to... [operating-system-user-services]: ... this. (essential-services, operating-system-services): New procedures. (operating-system-accounts, operating-system-etc-directory, operating-system-boot-script, operating-system-derivation): Adjust to new 'operating-system-services' return type. --- gnu/services/base.scm | 9 +-------- gnu/system.scm | 31 ++++++++++++++++++++++++------- 2 files changed, 25 insertions(+), 15 deletions(-) (limited to 'gnu/services') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index ae538ea41..5157349ae 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -267,13 +267,6 @@ This is the GNU operating system, welcome!\n\n"))) (mingetty-service "tty6" #:motd motd) (syslog-service) (guix-service) - (nscd-service) - - ;; FIXME: Make this an activation-time thing instead of a service. - (host-name-service "gnu") - - ;; The "root" services. - (user-processes-service) - (root-file-system-service)))) + (nscd-service)))) ;;; base.scm ends here diff --git a/gnu/system.scm b/gnu/system.scm index 8a5fe47b3..491e0ed7a 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -40,6 +40,7 @@ #:export (operating-system operating-system? operating-system-services + operating-system-user-services operating-system-packages operating-system-bootloader-entries operating-system-host-name @@ -50,7 +51,6 @@ operating-system-packages operating-system-timezone operating-system-locale - operating-system-services operating-system-file-systems operating-system-derivation @@ -112,7 +112,7 @@ (timezone operating-system-timezone) ; string (locale operating-system-locale) ; string - (services operating-system-services ; list of monadic services + (services operating-system-user-services ; list of monadic services (default %base-services)) (pam-services operating-system-pam-services ; list of PAM services @@ -184,6 +184,24 @@ file." (gexp->derivation name builder)) +(define (essential-services os) + "Return the list of essential services for OS. These are special services +that implement part of what's declared in OS are responsible for low-level +bookkeeping." + (mlet %store-monad ((procs (user-processes-service)) + (root-fs (root-file-system-service)) + (host-name (host-name-service + (operating-system-host-name os)))) + (return (list host-name procs root-fs)))) + +(define (operating-system-services os) + "Return all the services of OS, including \"internal\" services that do not +explicitly appear in OS." + (mlet %store-monad + ((user (sequence %store-monad (operating-system-user-services os))) + (essential (essential-services os))) + (return (append essential user)))) + (define* (etc-directory #:key (locale "C") (timezone "Europe/Paris") (accounts '()) @@ -254,8 +272,7 @@ alias ll='ls -l' (define (operating-system-accounts os) "Return the user accounts for OS, including an obligatory 'root' account." - (mlet %store-monad ((services (sequence %store-monad - (operating-system-services os)))) + (mlet %store-monad ((services (operating-system-services os))) (return (cons (user-account (name "root") (password "") @@ -269,7 +286,7 @@ alias ll='ls -l' (define (operating-system-etc-directory os) "Return that static part of the /etc directory of OS." (mlet* %store-monad - ((services (sequence %store-monad (operating-system-services os))) + ((services (operating-system-services os)) (pam-services -> ;; Services known to PAM. (delete-duplicates @@ -310,7 +327,7 @@ we're running in the final root." (guix build utils))) (mlet* %store-monad - ((services (sequence %store-monad (operating-system-services os))) + ((services (operating-system-services os)) (etc (operating-system-etc-directory os)) (modules (imported-modules %modules)) (compiled (compiled-modules %modules)) @@ -367,7 +384,7 @@ we're running in the final root." (mlet* %store-monad ((profile (operating-system-profile os)) (etc (operating-system-etc-directory os)) - (services (sequence %store-monad (operating-system-services os))) + (services (operating-system-services os)) (boot (operating-system-boot-script os)) (kernel -> (operating-system-kernel os)) (initrd ((operating-system-initrd os) boot-file-systems)) -- cgit v1.3 From 23ed63a12d941ad836f3fc9902ba4f145db1975c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 10 May 2014 22:58:22 +0200 Subject: services: Use (guix build syscalls) instead of util-linux. * gnu/services/dmd.scm (dmd-configuration-file): Add derivations for the (guix build syscalls) module, and add that to the load path of dmd.conf. * gnu/services/base.scm (root-file-system-service): Rewrite using the 'sync' and 'mount' procedures. --- gnu/services/base.scm | 19 ++++++++--------- gnu/services/dmd.scm | 56 +++++++++++++++++++++++++++++++-------------------- 2 files changed, 42 insertions(+), 33 deletions(-) (limited to 'gnu/services') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 5157349ae..e0f2888ee 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -22,8 +22,7 @@ #:use-module (gnu system linux) ; 'pam-service', etc. #:use-module (gnu packages admin) #:use-module ((gnu packages base) - #:select (glibc-final %final-inputs)) - #:use-module (gnu packages linux) + #:select (glibc-final)) #:use-module (gnu packages package-management) #:use-module (guix gexp) #:use-module (guix monads) @@ -52,9 +51,6 @@ system upon shutdown (aka. cleanly \"umounting\" root.) This service must be the root of the service dependency graph so that its 'stop' action is invoked when dmd is the only process left." - (define coreutils - (car (assoc-ref %final-inputs "coreutils"))) - (with-monad %store-monad (return (service @@ -63,7 +59,7 @@ This service must be the root of the service dependency graph so that its (start #~(const #t)) (stop #~(lambda _ ;; Return #f if successfully stopped. - (system* (string-append #$coreutils "/bin/sync")) + (sync) (call-with-blocked-asyncs (lambda () @@ -82,12 +78,13 @@ This service must be the root of the service dependency graph so that its ;; Close /dev/console. (for-each close-fdes '(0 1 2)) - ;; At this points, there are no open files left, so the + ;; At this point, there are no open files left, so the ;; root file system can be re-mounted read-only. - (not (zero? - (system* (string-append #$util-linux "/bin/mount") - "-n" "-o" "remount,ro" - "-t" "dummy" "dummy" "/")))))))) + (mount #f "/" #f + (logior MS_REMOUNT MS_RDONLY) + #:update-mtab? #f) + + #f))))) (respawn? #f))))) (define* (user-processes-service #:key (grace-delay 2)) diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 161a971ed..8d4c483cc 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -32,27 +32,39 @@ (define (dmd-configuration-file services) "Return the dmd configuration file for SERVICES." - (define config - #~(begin - (use-modules (ice-9 ftw)) - - (register-services - #$@(map (lambda (service) - #~(make - #:docstring '#$(service-documentation service) - #:provides '#$(service-provision service) - #:requires '#$(service-requirement service) - #:respawn? '#$(service-respawn? service) - #:start #$(service-start service) - #:stop #$(service-stop service))) - services)) - - ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. - (setenv "PATH" "/run/current-system/bin") - - (format #t "starting services...~%") - (for-each start '#$(append-map service-provision services)))) - - (gexp->file "dmd.conf" config)) + (define modules + ;; Extra modules visible to dmd.conf. + '((guix build syscalls))) + + (mlet %store-monad ((modules (imported-modules modules)) + (compiled (compiled-modules modules))) + (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 (ice-9 ftw) + (guix build syscalls)) + + (register-services + #$@(map (lambda (service) + #~(make + #:docstring '#$(service-documentation service) + #:provides '#$(service-provision service) + #:requires '#$(service-requirement service) + #:respawn? '#$(service-respawn? service) + #:start #$(service-start service) + #:stop #$(service-stop service))) + services)) + + ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. + (setenv "PATH" "/run/current-system/bin") + + (format #t "starting services...~%") + (for-each start '#$(append-map service-provision services)))) + + (gexp->file "dmd.conf" config))) ;;; dmd.scm ends here -- cgit v1.3 From 023f391c7860d21aee9e9b3e601d7a81bb5d128d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 10 May 2014 23:33:52 +0200 Subject: services: Add 'file-system-service'. * gnu/services/base.scm (file-system-service): New procedure. (user-processes-service): Add 'requirements' parameter. * gnu/services/dmd.scm (dmd-configuration-file): Use (guix build linux-initrd). * guix/build/linux-initrd.scm (guix): Export 'check-file-system'. * gnu/system.scm (file-union): New procedure. (essential-services): Use it. Add that to the returned list. --- gnu/services/base.scm | 30 ++++++++++++++++++++++++++++-- gnu/services/dmd.scm | 8 ++++++-- gnu/system.scm | 30 +++++++++++++++++++++++++----- guix/build/linux-initrd.scm | 1 + 4 files changed, 60 insertions(+), 9 deletions(-) (limited to 'gnu/services') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index e0f2888ee..6431a3aab 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -30,6 +30,7 @@ #:use-module (srfi srfi-26) #:use-module (ice-9 format) #:export (root-file-system-service + file-system-service user-processes-service host-name-service mingetty-service @@ -87,19 +88,44 @@ This service must be the root of the service dependency graph so that its #f))))) (respawn? #f))))) -(define* (user-processes-service #:key (grace-delay 2)) +(define* (file-system-service device target type + #:key (check? #t) options) + "Return a service that mounts DEVICE on TARGET as a file system TYPE with +OPTIONS. When CHECK? is true, check the file system before mounting it." + (with-monad %store-monad + (return + (service + (provision (list (symbol-append 'file-system- (string->symbol target)))) + (requirement '(root-file-system)) + (documentation "Check, mount, and unmount the given file system.") + (start #~(lambda args + #$(if check? + #~(check-file-system #$device #$type) + #~#t) + (mount #$device #$target #$type 0 #$options) + #t)) + (stop #~(lambda args + ;; Normally there are no processes left at this point, so + ;; TARGET can be safely unmounted. + (umount #$target) + #f)))))) + +(define* (user-processes-service requirements #:key (grace-delay 2)) "Return the service that is responsible for terminating all the processes so that the root file system can be re-mounted read-only, just before rebooting/halting. Processes still running GRACE-DELAY seconds after SIGTERM has been sent are terminated with SIGKILL. +The returned service will depend on 'root-file-system' and on all the services +listed in REQUIREMENTS. + All the services that spawn processes must depend on this one so that they are stopped before 'kill' is called." (with-monad %store-monad (return (service (documentation "When stopped, terminate all user processes.") (provision '(user-processes)) - (requirement '(root-file-system)) + (requirement (cons 'root-file-system requirements)) (start #~(const #t)) (stop #~(lambda _ ;; When this happens, all the processes have been diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 8d4c483cc..0d1728589 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -34,7 +34,9 @@ "Return the dmd configuration file for SERVICES." (define modules ;; Extra modules visible to dmd.conf. - '((guix build syscalls))) + '((guix build syscalls) + (guix build linux-initrd) + (guix build utils))) (mlet %store-monad ((modules (imported-modules modules)) (compiled (compiled-modules modules))) @@ -46,7 +48,9 @@ (cons #$compiled %load-compiled-path))) (use-modules (ice-9 ftw) - (guix build syscalls)) + (guix build syscalls) + ((guix build linux-initrd) + #:select (check-file-system))) (register-services #$@(map (lambda (service) diff --git a/gnu/system.scm b/gnu/system.scm index 491e0ed7a..d76c3670f 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -184,15 +184,35 @@ file." (gexp->derivation name builder)) +(define (other-file-system-services os) + "Return file system services for the file systems of OS that are not marked +as 'needed-for-boot'." + (define file-systems + (remove (lambda (fs) + (or (file-system-needed-for-boot? fs) + (string=? "/" (file-system-mount-point fs)))) + (operating-system-file-systems os))) + + (sequence %store-monad + (map (match-lambda + (($ device target type flags opts #f check?) + (file-system-service device target type + #:check? check? + #:options opts))) + file-systems))) + (define (essential-services os) "Return the list of essential services for OS. These are special services that implement part of what's declared in OS are responsible for low-level bookkeeping." - (mlet %store-monad ((procs (user-processes-service)) - (root-fs (root-file-system-service)) - (host-name (host-name-service - (operating-system-host-name os)))) - (return (list host-name procs root-fs)))) + (mlet* %store-monad ((root-fs (root-file-system-service)) + (other-fs (other-file-system-services os)) + (procs (user-processes-service + (map (compose first service-provision) + other-fs))) + (host-name (host-name-service + (operating-system-host-name os)))) + (return (cons* host-name procs root-fs other-fs)))) (define (operating-system-services os) "Return all the services of OS, including \"internal\" services that do not diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 83636dfd7..0c3b2f0d9 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -30,6 +30,7 @@ linux-command-line make-essential-device-nodes configure-qemu-networking + check-file-system mount-file-system bind-mount load-linux-module* -- cgit v1.3 From 057d6ce5e42d813b9d5e49ddae5d88e6581cc1d8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 11 May 2014 13:41:08 +0200 Subject: services: xorg: Fix harmless typo in slim.cfg. * gnu/services/xorg.scm (slim-service): Add missing whitespace in XINITRC invocation. --- gnu/services/xorg.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gnu/services') diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index db1d80871..1988cfa6a 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -147,7 +147,7 @@ authfile /var/run/slim.auth # The login command. '%session' is replaced by the chosen session name, one # of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc. -login_cmd exec " xinitrc "%session +login_cmd exec " xinitrc " %session sessions wmaker,ratpoison halt_cmd " dmd "/sbin/halt -- cgit v1.3 From ab6a279abbfa39b1e1bec0e363744d241972f844 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 11 May 2014 22:41:01 +0200 Subject: system: Make accounts and groups at activation time. * gnu/services/base.scm (guix-build-accounts): Remove #:gid parameter; add #:group. Remove 'password' and 'gid' fields in 'user-account' form, and add 'group'. (guix-service): Remove #:build-user-gid parameter. Remove 'id' field in 'user-group' form. * gnu/system.scm (etc-directory): Remove #:groups and #:accounts. No longer produce files "passwd", "shadow", and "group". Adjust caller accordingly. (%root-account): New variable. (operating-system-accounts): Add 'users' variable. Add %ROOT-ACCOUNT only of 'operating-system-users' doesn't already contain a root account. (user-group->gexp, user-account->gexp): New procedures. (operating-system-boot-script): Add calls to 'setenv' and 'activate-users+groups' in gexp. * gnu/system/linux.scm (base-pam-services): Add PAM services for "user{add,del,mode}" and "group{add,del,mod}". * gnu/system/shadow.scm ()[gid]: Rename to... [group]: ... this. [supplementary-groups]: New field. [uid, password]: Default to #f. ()[id]: Default to #f. (group-file, passwd-file): Remove. * gnu/system/vm.scm (operating-system-default-contents)[user-directories]: Remove. Add "/home" to the directives. * guix/build/activation.scm (add-group, add-user, activate-users+groups): New procedures. --- build-aux/hydra/demo-os.scm | 3 +- gnu/services/base.scm | 10 ++--- gnu/system.scm | 95 +++++++++++++++++++++++++++++--------------- gnu/system/linux.scm | 14 ++++--- gnu/system/shadow.scm | 61 +++++----------------------- gnu/system/vm.scm | 15 +------ guix/build/activation.scm | 97 ++++++++++++++++++++++++++++++++++++++++++++- 7 files changed, 186 insertions(+), 109 deletions(-) (limited to 'gnu/services') diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm index 03449abda..4116c063f 100644 --- a/build-aux/hydra/demo-os.scm +++ b/build-aux/hydra/demo-os.scm @@ -45,7 +45,8 @@ (locale "en_US.UTF-8") (users (list (user-account (name "guest") - (uid 1000) (gid 100) + (group "wheel") + (password "") (comment "Guest of GNU") (home-directory "/home/guest")))) (groups (list (user-group (name "root") (id 0)) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 6431a3aab..1f5ff3e4c 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -237,8 +237,8 @@ stopped before 'kill' is called." (stop #~(make-kill-destructor)))))) (define* (guix-build-accounts count #:key + (group "guixbuild") (first-uid 30001) - (gid 30000) (shadow shadow)) "Return a list of COUNT user accounts for Guix build users, with UIDs starting at FIRST-UID, and under GID." @@ -247,9 +247,8 @@ starting at FIRST-UID, and under GID." (lambda (n) (user-account (name (format #f "guixbuilder~2,'0d" n)) - (password "!") (uid (+ first-uid n -1)) - (gid gid) + (group group) (comment (format #f "Guix Build User ~2d" n)) (home-directory "/var/empty") (shell #~(string-append #$shadow "/sbin/nologin")))) @@ -257,11 +256,11 @@ starting at FIRST-UID, and under GID." 1)))) (define* (guix-service #:key (guix guix) (builder-group "guixbuild") - (build-user-gid 30000) (build-accounts 10)) + (build-accounts 10)) "Return a service that runs the build daemon from GUIX, and has BUILD-ACCOUNTS user accounts available under BUILD-USER-GID." (mlet %store-monad ((accounts (guix-build-accounts build-accounts - #:gid build-user-gid))) + #:group builder-group))) (return (service (provision '(guix-daemon)) (requirement '(user-processes)) @@ -274,7 +273,6 @@ BUILD-ACCOUNTS user accounts available under BUILD-USER-GID." (user-accounts accounts) (user-groups (list (user-group (name builder-group) - (id build-user-gid) (members (map user-account-name user-accounts))))))))) diff --git a/gnu/system.scm b/gnu/system.scm index d76c3670f..bd69532a8 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -224,17 +224,12 @@ explicitly appear in OS." (define* (etc-directory #:key (locale "C") (timezone "Europe/Paris") - (accounts '()) - (groups '()) (pam-services '()) (profile "/var/run/current-system/profile") (sudoers "")) "Return a derivation that builds the static part of the /etc directory." (mlet* %store-monad - ((passwd (passwd-file accounts)) - (shadow (passwd-file accounts #:shadow? #t)) - (group (group-file groups)) - (pam.d (pam-services->directory pam-services)) + ((pam.d (pam-services->directory pam-services)) (sudoers (text-file "sudoers" sudoers)) (login.defs (text-file "login.defs" "# Empty for now.\n")) (shells (text-file "shells" ; used by xterm and others @@ -278,10 +273,6 @@ alias ll='ls -l' ("profile" ,#~#$bashrc) ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/" #$timezone)) - ("passwd" ,#~#$passwd) - ("shadow" ,#~#$shadow) - ("group" ,#~#$group) - ("sudoers" ,#~#$sudoers))))) (define (operating-system-profile os) @@ -290,18 +281,28 @@ alias ll='ls -l' (union (operating-system-packages os) #:name "default-profile")) +(define %root-account + ;; Default root account. + (user-account + (name "root") + (password "") + (uid 0) (group "root") + (comment "System administrator") + (home-directory "/root"))) + (define (operating-system-accounts os) "Return the user accounts for OS, including an obligatory 'root' account." + (define users + ;; Make sure there's a root account. + (if (find (lambda (user) + (and=> (user-account-uid user) zero?)) + (operating-system-users os)) + (operating-system-users os) + (cons %root-account (operating-system-users os)))) + (mlet %store-monad ((services (operating-system-services os))) - (return (cons (user-account - (name "root") - (password "") - (uid 0) (gid 0) - (comment "System administrator") - (home-directory "/root")) - (append (operating-system-users os) - (append-map service-user-accounts - services)))))) + (return (append users + (append-map service-user-accounts services))))) (define (operating-system-etc-directory os) "Return that static part of the /etc directory of OS." @@ -312,12 +313,8 @@ alias ll='ls -l' (delete-duplicates (append (operating-system-pam-services os) (append-map service-pam-services services)))) - (accounts (operating-system-accounts os)) - (profile-drv (operating-system-profile os)) - (groups -> (append (operating-system-groups os) - (append-map service-user-groups services)))) - (etc-directory #:accounts accounts #:groups groups - #:pam-services pam-services + (profile-drv (operating-system-profile os))) + (etc-directory #:pam-services pam-services #:locale (operating-system-locale os) #:timezone (operating-system-timezone os) #:sudoers (operating-system-sudoers os) @@ -339,6 +336,25 @@ alias ll='ls -l' "root ALL=(ALL) ALL %wheel ALL=(ALL) ALL\n") +(define (user-group->gexp group) + "Turn GROUP, a object, into a list-valued gexp suitable for +'active-groups'." + #~(list #$(user-group-name group) + #$(user-group-password group) + #$(user-group-id group))) + +(define (user-account->gexp account) + "Turn ACCOUNT, a object, into a list-valued gexp suitable for +'activate-users'." + #~`(#$(user-account-name account) + #$(user-account-uid account) + #$(user-account-group account) + #$(user-account-supplementary-groups account) + #$(user-account-comment account) + #$(user-account-home-directory account) + ,#$(user-account-shell account) ; this one is a gexp + #$(user-account-password account))) + (define (operating-system-boot-script os) "Return the boot script for OS---i.e., the code started by the initrd once we're running in the final root." @@ -346,15 +362,25 @@ we're running in the final root." '((guix build activation) (guix build utils))) - (mlet* %store-monad - ((services (operating-system-services os)) - (etc (operating-system-etc-directory os)) - (modules (imported-modules %modules)) - (compiled (compiled-modules %modules)) - (dmd-conf (dmd-configuration-file services))) + (mlet* %store-monad ((services (operating-system-services os)) + (etc (operating-system-etc-directory os)) + (modules (imported-modules %modules)) + (compiled (compiled-modules %modules)) + (dmd-conf (dmd-configuration-file services)) + (accounts (operating-system-accounts os))) (define setuid-progs (operating-system-setuid-programs os)) + (define user-specs + (map user-account->gexp accounts)) + + (define groups + (append (operating-system-groups os) + (append-map service-user-groups services))) + + (define group-specs + (map user-group->gexp groups)) + (gexp->file "boot" #~(begin (eval-when (expand load eval) @@ -368,6 +394,13 @@ we're running in the final root." ;; Populate /etc. (activate-etc #$etc) + ;; Add users and user groups. + (setenv "PATH" + (string-append #$(@ (gnu packages admin) shadow) + "/sbin")) + (activate-users+groups (list #$@user-specs) + (list #$@group-specs)) + ;; Activate setuid programs. (activate-setuid-programs (list #$@setuid-progs)) diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm index 3a43eb45e..5440f5852 100644 --- a/gnu/system/linux.scm +++ b/gnu/system/linux.scm @@ -154,11 +154,13 @@ should be the name of a file used as the message-of-the-day." (define* (base-pam-services #:key allow-empty-passwords?) "Return the list of basic PAM services everyone would want." - (list %pam-other-services - (unix-pam-service "su" #:allow-empty-passwords? allow-empty-passwords?) - (unix-pam-service "passwd" - #:allow-empty-passwords? allow-empty-passwords?) - (unix-pam-service "sudo" - #:allow-empty-passwords? allow-empty-passwords?))) + (cons %pam-other-services + (map (cut unix-pam-service <> + #:allow-empty-passwords? allow-empty-passwords?) + '("su" "passwd" "sudo" + "useradd" "userdel" "usermod" + "groupadd" "groupdel" "groupmod" + ;; TODO: Add other Shadow programs? + )))) ;;; linux.scm ends here diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index 52242ee4e..8745ddb87 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -30,9 +30,10 @@ #:export (user-account user-account? user-account-name - user-account-pass + user-account-password user-account-uid - user-account-gid + user-account-group + user-account-supplementary-groups user-account-comment user-account-home-directory user-account-shell @@ -42,11 +43,7 @@ user-group-name user-group-password user-group-id - user-group-members - - passwd-file - group-file - guix-build-accounts)) + user-group-members)) ;;; Commentary: ;;; @@ -58,9 +55,11 @@ user-account make-user-account user-account? (name user-account-name) - (password user-account-pass (default "")) - (uid user-account-uid) - (gid user-account-gid) + (password user-account-password (default #f)) + (uid user-account-uid (default #f)) + (group user-account-group) ; number | string + (supplementary-groups user-account-supplementary-groups + (default '())) ; list of strings (comment user-account-comment (default "")) (home-directory user-account-home-directory) (shell user-account-shell ; gexp @@ -71,47 +70,7 @@ user-group? (name user-group-name) (password user-group-password (default #f)) - (id user-group-id) + (id user-group-id (default #f)) (members user-group-members (default '()))) -(define (group-file groups) - "Return a /etc/group file for GROUPS, a list of objects." - (define contents - (let loop ((groups groups) - (result '())) - (match groups - ((($ name _ gid (users ...)) rest ...) - ;; XXX: Ignore the group password. - (loop rest - (cons (string-append name "::" (number->string gid) - ":" (string-join users ",")) - result))) - (() - (string-join (reverse result) "\n" 'suffix))))) - - (text-file "group" contents)) - -(define* (passwd-file accounts #:key shadow?) - "Return a password file for ACCOUNTS, a list of objects. If -SHADOW? is true, then it is a /etc/shadow file, otherwise it is a /etc/passwd -file." - ;; XXX: The resulting file is world-readable, so beware when SHADOW? is #t! - (define account-exp - (match-lambda - (($ name pass uid gid comment home-dir shell) - (if shadow? ; XXX: use (crypt PASS …)? - #~(format #t "~a::::::::~%" #$name) - #~(format #t "~a:x:~a:~a:~a:~a:~a~%" - #$name #$(number->string uid) #$(number->string gid) - #$comment #$home-dir #$shell))))) - - (define builder - #~(begin - (with-output-to-file #$output - (lambda () - #$@(map account-exp accounts) - #t)))) - - (gexp->derivation (if shadow? "shadow" "passwd") builder)) - ;;; shadow.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 252085320..ede7ea772 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -267,16 +267,6 @@ such as /etc files." (define (operating-system-default-contents os) "Return a list of directives suitable for 'system-qemu-image' describing the basic contents of the root file system of OS." - (define (user-directories user) - (let ((home (user-account-home-directory user)) - ;; XXX: Deal with automatically allocated ids. - (uid (or (user-account-uid user) 0)) - (gid (or (user-account-gid user) 0)) - (root (string-append "/var/guix/profiles/per-user/" - (user-account-name user)))) - #~((directory #$root #$uid #$gid) - (directory #$home #$uid #$gid)))) - (mlet* %store-monad ((os-drv (operating-system-derivation os)) (build-gid (operating-system-build-gid os)) (profile (operating-system-profile os))) @@ -293,9 +283,8 @@ basic contents of the root file system of OS." (directory "/tmp") (directory "/var/guix/profiles/per-user/root" 0 0) - (directory "/root" 0 0) ; an exception - #$@(append-map user-directories - (operating-system-users os)))))) + (directory "/root" 0 0) ; an exception + (directory "/home" 0 0))))) (define* (system-qemu-image os #:key diff --git a/guix/build/activation.scm b/guix/build/activation.scm index f9d9ba5cb..895f2bca5 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -19,8 +19,11 @@ (define-module (guix build activation) #:use-module (guix build utils) #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) - #:export (activate-etc + #:export (activate-users+groups + activate-etc activate-setuid-programs)) ;;; Commentary: @@ -31,6 +34,98 @@ ;;; ;;; Code: +(define* (add-group name #:key gid password + (log-port (current-error-port))) + "Add NAME as a user group, with the given numeric GID if specified." + ;; Use 'groupadd' from the Shadow package. + (format log-port "adding group '~a'...~%" name) + (let ((args `(,@(if gid `("-g" ,(number->string gid)) '()) + ,@(if password `("-p" ,password) '()) + ,name))) + (zero? (apply system* "groupadd" args)))) + +(define* (add-user name group + #:key uid comment home shell password + (supplementary-groups '()) + (log-port (current-error-port))) + "Create an account for user NAME part of GROUP, with the specified +properties. Return #t on success." + (format log-port "adding user '~a'...~%" name) + + (if (and uid (zero? uid)) + + ;; 'useradd' fails with "Cannot determine your user name" if the root + ;; account doesn't exist. Thus, for bootstrapping purposes, create that + ;; one manually. + (begin + (call-with-output-file "/etc/shadow" + (cut format <> "~a::::::::~%" name)) + (call-with-output-file "/etc/passwd" + (cut format <> "~a:x:~a:~a:~a:~a:~a~%" + name "0" "0" comment home shell)) + (chmod "/etc/shadow" #o600) + #t) + + ;; Use 'useradd' from the Shadow package. + (let ((args `(,@(if uid `("-u" ,(number->string uid)) '()) + "-g" ,(if (number? group) (number->string group) group) + ,@(if (pair? supplementary-groups) + `("-G" ,(string-join supplementary-groups ",")) + '()) + ,@(if comment `("-c" ,comment) '()) + ,@(if home `("-d" ,home "--create-home") '()) + ,@(if shell `("-s" ,shell) '()) + ,@(if password `("-p" ,password) '()) + ,name))) + (zero? (apply system* "useradd" args))))) + +(define (activate-users+groups users groups) + "Make sure the accounts listed in USERS and the user groups listed in GROUPS +are all available. + +Each item in USERS is a list of all the characteristics of a user account; +each item in GROUPS is a tuple with the group name, group password or #f, and +numeric gid or #f." + (define (touch file) + (call-with-output-file file (const #t))) + + (define activate-user + (match-lambda + ((name uid group supplementary-groups comment home shell password) + (unless (false-if-exception (getpwnam name)) + (let ((profile-dir (string-append "/var/guix/profiles/per-user/" + name))) + (add-user name group + #:uid uid + #:supplementary-groups supplementary-groups + #:comment comment + #:home home + #:shell shell + #:password password) + + ;; Create the profile directory for the new account. + (let ((pw (getpwnam name))) + (mkdir-p profile-dir) + (chown profile-dir (passwd:uid pw) (passwd:gid pw)))))))) + + ;; 'groupadd' aborts if the file doesn't already exist. + (touch "/etc/group") + + ;; Create the root account so we can use 'useradd' and 'groupadd'. + (activate-user (find (match-lambda + ((name (? zero?) _ ...) #t) + (_ #f)) + users)) + + ;; Then create the groups. + (for-each (match-lambda + ((name password gid) + (add-group name #:gid gid #:password password))) + groups) + + ;; Finally create the other user accounts. + (for-each activate-user users)) + (define (activate-etc etc) "Install ETC, a directory in the store, as the source of static files for /etc." -- cgit v1.3 From 7d57cfd3b6625d7ab7f796b90b9606c28ec3aeef Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 14 May 2014 16:38:21 +0200 Subject: system: When unionfs-fuse is used for /, don't kill it when halting. * guix/build/linux-initrd.scm (pidof): New procedure. (mount-root-file-system)[mark-as-not-killable]: New procedure. Use it for unionfs when VOLATILE-ROOT?. * gnu/services/base.scm (%do-not-kill-file): New variable. (user-processes-service)[stop]: Honor it. --- gnu/services/base.scm | 42 +++++++++++++++++++++++++++++++++++++++--- guix/build/linux-initrd.scm | 26 +++++++++++++++++++++++++- 2 files changed, 64 insertions(+), 4 deletions(-) (limited to 'gnu/services') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 1f5ff3e4c..aec605058 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -110,6 +110,11 @@ OPTIONS. When CHECK? is true, check the file system before mounting it." (umount #$target) #f)))))) +(define %do-not-kill-file + ;; Name of the file listing PIDs of processes that must survive when halting + ;; the system. Typical example is user-space file systems. + "/etc/dmd/do-not-kill") + (define* (user-processes-service requirements #:key (grace-delay 2)) "Return the service that is responsible for terminating all the processes so that the root file system can be re-mounted read-only, just before @@ -128,6 +133,25 @@ stopped before 'kill' is called." (requirement (cons 'root-file-system requirements)) (start #~(const #t)) (stop #~(lambda _ + (define (kill-except omit signal) + ;; Kill all the processes with SIGNAL except those + ;; listed in OMIT and the current process. + (let ((omit (cons (getpid) omit))) + (for-each (lambda (pid) + (unless (memv pid omit) + (false-if-exception + (kill pid signal)))) + (processes)))) + + (define omitted-pids + ;; List of PIDs that must not be killed. + (if (file-exists? #$%do-not-kill-file) + (map string->number + (call-with-input-file #$%do-not-kill-file + (compose string-tokenize + (@ (ice-9 rdelim) read-string)))) + '())) + ;; When this happens, all the processes have been ;; killed, including 'deco', so DMD-OUTPUT-PORT and ;; thus CURRENT-OUTPUT-PORT are dangling. @@ -136,9 +160,21 @@ stopped before 'kill' is called." (display "sending all processes the TERM signal\n" port))) - (kill -1 SIGTERM) - (sleep #$grace-delay) - (kill -1 SIGKILL) + (if (null? omitted-pids) + (begin + ;; Easy: terminate all of them. + (kill -1 SIGTERM) + (sleep #$grace-delay) + (kill -1 SIGKILL)) + (begin + ;; Kill them all except OMITTED-PIDS. XXX: We + ;; would like to (kill -1 SIGSTOP) to get a fixed + ;; list of processes, like 'killall5' does, but + ;; that seems unreliable. + (kill-except omitted-pids SIGTERM) + (sleep #$grace-delay) + (kill-except omitted-pids SIGKILL) + (delete-file #$%do-not-kill-file))) (display "all processes have been terminated\n") #f)) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 0c3b2f0d9..b488668ee 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -200,11 +200,30 @@ networking values.) Return #t if INTERFACE is up, #f otherwise." the last argument of `mknod'." (+ (* major 256) minor)) +(define (pidof program) + "Return the PID of the first presumed instance of PROGRAM." + (let ((program (basename program))) + (find (lambda (pid) + (let ((exe (format #f "/proc/~a/exe" pid))) + (and=> (false-if-exception (readlink exe)) + (compose (cut string=? program <>) basename)))) + (filter-map string->number (scandir "/proc"))))) + (define* (mount-root-file-system root type #:key volatile-root? (unionfs "unionfs")) "Mount the root file system of type TYPE at device ROOT. If VOLATILE-ROOT? is true, mount ROOT read-only and make it a union with a writable tmpfs using UNIONFS." + (define (mark-as-not-killable pid) + ;; Tell the 'user-processes' dmd service that PID must be kept alive when + ;; shutting down. + (mkdir-p "/root/etc/dmd") + (let ((port (open-file "/root/etc/dmd/do-not-kill" "a"))) + (chmod port #o600) + (write pid port) + (newline port) + (close-port port))) + (catch #t (lambda () (if volatile-root? @@ -222,7 +241,12 @@ UNIONFS." "cow,allow_other,use_ino,suid,dev" "/rw-root=RW:/real-root=RO" "/root")) - (error "unionfs failed"))) + (error "unionfs failed")) + + ;; Make sure unionfs remains alive till the end. Because + ;; 'fuse_daemonize' doesn't tell the PID of the forked daemon, we + ;; have to resort to 'pidof' here. + (mark-as-not-killable (pidof unionfs))) (begin (check-file-system root type) (mount root "/root" type)))) -- cgit v1.3 From b4140694aca6a717ec130e3788b9d877d1b1e534 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 17 May 2014 17:39:30 +0200 Subject: system: Make /run/current-system at activation time. * gnu/system.scm (etc-directory): Change default value of #:profile. Change contents of SHELLS. Use /run/current-system/profile/{s,}bin in BASHRC. (operating-system-boot-script)[%modules]: Add (guix build linux-initrd). Add call to 'activate-current-system' in gexp. (operating-system-initrd-file, operating-system-grub.cfg): New procedures. (operating-system-derivation): Don't build grub.cfg here and remove it from the file union. * gnu/system/vm.scm (qemu-image): Remove #:populate. (operating-system-build-gid, operating-system-default-contents): Remove. (system-qemu-image): Remove call to 'operating-system-default-contents'. Use 'operating-system-grub.cfg' to get grub.cfg. Add GRUB.CFG to #:inputs. (system-qemu-image/shared-store): Likewise, but don't add GRUB.CFG to #:inputs. (system-qemu-image/shared-store-script): Pass --system kernel option. * guix/build/activation.scm (%booted-system, %current-system): New variables. (boot-time-system, activate-current-system): New procedures. * guix/build/install.scm (evaluate-populate-directive): Add case for ('directory name uid gid mode). (directives, populate-root-file-system): New procedures. * guix/build/vm.scm (initialize-hard-disk): Replace calls to 'evaluate-populate-directive' by a call to 'populate-root-file-system'. * gnu/services/dmd.scm (dmd-configuration-file): Use /run/current-system/profile/bin. * gnu/services/xorg.scm (slim-service): Likewise. --- gnu/services/dmd.scm | 2 +- gnu/services/xorg.scm | 2 +- gnu/system.scm | 56 ++++++++++++++++++++++++++++---------------- gnu/system/vm.scm | 59 ++++++----------------------------------------- guix/build/activation.scm | 33 +++++++++++++++++++++++++- guix/build/install.scm | 50 +++++++++++++++++++++++++++++++-------- guix/build/vm.scm | 3 +-- 7 files changed, 118 insertions(+), 87 deletions(-) (limited to 'gnu/services') diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 0d1728589..982c196fe 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -64,7 +64,7 @@ services)) ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. - (setenv "PATH" "/run/current-system/bin") + (setenv "PATH" "/run/current-system/profile/bin") (format #t "starting services...~%") (for-each start '#$(append-map service-provision services)))) diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 1988cfa6a..7215297f6 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -139,7 +139,7 @@ When AUTO-LOGIN? is true, log in automatically as DEFAULT-USER." (mlet %store-monad ((startx (or startx (xorg-start-command))) (xinitrc (xinitrc))) (text-file* "slim.cfg" " -default_path /run/current-system/bin +default_path /run/current-system/profile/bin default_xserver " startx " xserver_arguments :0 vt7 xauth_path " xauth "/bin/xauth diff --git a/gnu/system.scm b/gnu/system.scm index 9ce94d023..ec3e2fcd6 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -55,6 +55,7 @@ operating-system-derivation operating-system-profile + operating-system-grub.cfg file-system @@ -263,7 +264,7 @@ explicitly appear in OS." (locale "C") (timezone "Europe/Paris") (skeletons '()) (pam-services '()) - (profile "/var/run/current-system/profile") + (profile "/run/current-system/profile") (sudoers "")) "Return a derivation that builds the static part of the /etc directory." (mlet* %store-monad @@ -273,8 +274,8 @@ explicitly appear in OS." (shells (text-file "shells" ; used by xterm and others "\ /bin/sh -/run/current-system/bin/sh -/run/current-system/bin/bash\n")) +/run/current-system/profile/bin/sh +/run/current-system/profile/bin/bash\n")) (issue (text-file "issue" " This is an alpha preview of the GNU system. Welcome. @@ -293,8 +294,8 @@ export LC_ALL=\"" locale "\" export TZ=\"" timezone "\" export TZDIR=\"" tzdata "/share/zoneinfo\" -export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin -export PATH=/run/setuid-programs:$PATH +export PATH=/run/setuid-programs:/run/current-system/profile/sbin +export PATH=$HOME/.guix-profile/bin:/run/current-system/profile/bin:$PATH export CPATH=$HOME/.guix-profile/include:" profile "/include export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib alias ls='ls -p --color' @@ -402,7 +403,8 @@ alias ll='ls -l' we're running in the final root." (define %modules '((guix build activation) - (guix build utils))) + (guix build utils) + (guix build linux-initrd))) (mlet* %store-monad ((services (operating-system-services os)) (etc (operating-system-etc-directory os)) @@ -446,6 +448,9 @@ we're running in the final root." ;; Activate setuid programs. (activate-setuid-programs (list #$@setuid-progs)) + ;; Set up /run/current-system. + (activate-current-system #:boot? #t) + ;; Close any remaining open file descriptors to be on the ;; safe side. This must be the very last thing we do, ;; because Guile has internal FDs such as 'sleep_pipe' @@ -466,8 +471,8 @@ we're running in the final root." (_ #f)) (operating-system-file-systems os))) -(define (operating-system-derivation os) - "Return a derivation that builds OS." +(define (operating-system-initrd-file os) + "Return a gexp denoting the initrd file of OS." (define boot-file-systems (filter (match-lambda (($ device "/") @@ -476,15 +481,16 @@ we're running in the final root." boot?)) (operating-system-file-systems os))) + (mlet %store-monad + ((initrd ((operating-system-initrd os) boot-file-systems))) + (return #~(string-append #$initrd "/initrd")))) + +(define (operating-system-grub.cfg os) + "Return the GRUB configuration file for OS." (mlet* %store-monad - ((profile (operating-system-profile os)) - (etc (operating-system-etc-directory os)) - (services (operating-system-services os)) - (boot (operating-system-boot-script os)) - (kernel -> (operating-system-kernel os)) - (initrd ((operating-system-initrd os) boot-file-systems)) - (initrd-file -> #~(string-append #$initrd "/initrd")) + ((system (operating-system-derivation os)) (root-fs -> (operating-system-root-file-system os)) + (kernel -> (operating-system-kernel os)) (entries -> (list (menu-entry (label (string-append "GNU system with " @@ -494,15 +500,25 @@ we're running in the final root." (linux-arguments (list (string-append "--root=" (file-system-device root-fs)) - #~(string-append "--load=" #$boot))) - (initrd initrd-file)))) - (grub.cfg (grub-configuration-file entries))) + #~(string-append "--system=" #$system) + #~(string-append "--load=" #$system + "/boot"))) + (initrd #~(string-append #$system "/initrd")))))) + (grub-configuration-file entries))) + +(define (operating-system-derivation os) + "Return a derivation that builds OS." + (mlet* %store-monad + ((profile (operating-system-profile os)) + (etc (operating-system-etc-directory os)) + (boot (operating-system-boot-script os)) + (kernel -> (operating-system-kernel os)) + (initrd (operating-system-initrd-file os))) (file-union "system" `(("boot" ,#~#$boot) ("kernel" ,#~#$kernel) - ("initrd" ,initrd-file) + ("initrd" ,initrd) ("profile" ,#~#$profile) - ("grub.cfg" ,#~#$grub.cfg) ("etc" ,#~#$etc))))) ;;; system.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 58e5416b3..4bf0e0608 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -192,7 +192,6 @@ made available under the /xchg CIFS share." (file-system-type "ext4") grub-configuration (register-closures? #t) - (populate #f) (inputs '()) copy-inputs?) "Return a bootable, stand-alone QEMU image, with a root partition of type @@ -203,12 +202,7 @@ file (GRUB-CONFIGURATION must be the name of a file in the VM.) INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, register INPUTS in the store database of the image so that Guix can be used in -the image. - -POPULATE is a list of directives stating directories or symlinks to be created -in the disk image partition. It is evaluated once the image has been -populated with INPUTS-TO-COPY. It can be used to provide additional files, -such as /etc files." +the image." (mlet %store-monad ((graph (sequence %store-monad (map input->name+output inputs)))) (expression->derivation-in-linux-vm @@ -241,8 +235,7 @@ such as /etc files." #:copy-closures? #$copy-inputs? #:register-closures? #$register-closures? #:disk-image-size #$disk-image-size - #:file-system-type #$file-system-type - #:directives '#$populate) + #:file-system-type #$file-system-type) (reboot)))) #:system system #:make-disk-image? #t @@ -254,39 +247,6 @@ such as /etc files." ;;; Stand-alone VM image. ;;; -(define (operating-system-build-gid os) - "Return as a monadic value the group id for build users of OS, or #f." - (mlet %store-monad ((services (operating-system-services os))) - (return (any (lambda (service) - (and (equal? '(guix-daemon) - (service-provision service)) - (match (service-user-groups service) - ((group) - (user-group-id group))))) - services)))) - -(define (operating-system-default-contents os) - "Return a list of directives suitable for 'system-qemu-image' describing the -basic contents of the root file system of OS." - (mlet* %store-monad ((os-drv (operating-system-derivation os)) - (build-gid (operating-system-build-gid os)) - (profile (operating-system-profile os))) - (return #~((directory #$(%store-prefix) 0 #$(or build-gid 0)) - (directory "/etc") - (directory "/var/log") ; for dmd - (directory "/var/run/nscd") - (directory "/var/guix/gcroots") - ("/var/guix/gcroots/system" -> #$os-drv) - (directory "/run") - ("/run/current-system" -> #$profile) - (directory "/bin") - ("/bin/sh" -> "/run/current-system/bin/bash") - (directory "/tmp") - (directory "/var/guix/profiles/per-user/root" 0 0) - - (directory "/root" 0 0) ; an exception - (directory "/home" 0 0))))) - (define* (system-qemu-image os #:key (file-system-type "ext4") @@ -312,14 +272,12 @@ of the GNU system as described by OS." file-systems-to-keep))))) (mlet* %store-monad ((os-drv (operating-system-derivation os)) - (os-dir -> (derivation->output-path os-drv)) - (grub.cfg -> (string-append os-dir "/grub.cfg")) - (populate (operating-system-default-contents os))) + (grub.cfg (operating-system-grub.cfg os))) (qemu-image #:grub-configuration grub.cfg - #:populate populate #:disk-image-size disk-image-size #:file-system-type file-system-type - #:inputs `(("system" ,os-drv)) + #:inputs `(("system" ,os-drv) + ("grub.cfg" ,grub.cfg)) #:copy-inputs? #t)))) (define (virtualized-operating-system os) @@ -356,11 +314,8 @@ environment with the store shared with the host." with the host." (mlet* %store-monad ((os-drv (operating-system-derivation os)) - (os-dir -> (derivation->output-path os-drv)) - (grub.cfg -> (string-append os-dir "/grub.cfg")) - (populate (operating-system-default-contents os))) + (grub.cfg (operating-system-grub.cfg os))) (qemu-image #:grub-configuration grub.cfg - #:populate populate #:disk-image-size disk-image-size #:inputs `(("system" ,os-drv)) @@ -390,7 +345,7 @@ exec " #$qemu "/bin/qemu-system-x86_64 -enable-kvm -no-reboot -net nic,model=vir -kernel " #$(operating-system-kernel os) "/bzImage \ -initrd " #$os-drv "/initrd \ -append \"" #$(if graphic? "" "console=ttyS0 ") - "--load=" #$os-drv "/boot --root=/dev/vda1\" \ + "--system=" #$os-drv " --load=" #$os-drv "/boot --root=/dev/vda1\" \ -serial stdio \ -drive file=" #$image ",if=virtio,cache=writeback,werror=report,readonly\n") diff --git a/guix/build/activation.scm b/guix/build/activation.scm index 267c592b5..49f98c021 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -18,13 +18,15 @@ (define-module (guix build activation) #:use-module (guix build utils) + #:use-module (guix build linux-initrd) #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (activate-users+groups activate-etc - activate-setuid-programs)) + activate-setuid-programs + activate-current-system)) ;;; Commentary: ;;; @@ -195,4 +197,33 @@ numeric gid or #f." (for-each make-setuid-program programs)) +(define %booted-system + ;; The system we booted in (a symlink.) + "/run/booted-system") + +(define %current-system + ;; The system that is current (a symlink.) This is not necessarily the same + ;; as %BOOTED-SYSTEM, for instance because we can re-build a new system + ;; configuration and activate it, without rebooting. + "/run/current-system") + +(define (boot-time-system) + "Return the '--system' argument passed on the kernel command line." + (find-long-option "--system" (linux-command-line))) + +(define* (activate-current-system #:optional (system (boot-time-system)) + #:key boot?) + "Atomically make SYSTEM the current system. When BOOT? is true, also make +it the booted system." + (format #t "making '~a' the current system...~%" system) + (when boot? + (when (file-exists? %booted-system) + (delete-file %booted-system)) + (symlink system %booted-system)) + + ;; Atomically make SYSTEM current. + (let ((new (string-append %current-system ".new"))) + (symlink system new) + (rename-file new %current-system))) + ;;; activation.scm ends here diff --git a/guix/build/install.scm b/guix/build/install.scm index 37153703e..a0be6e9d3 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -19,9 +19,10 @@ (define-module (guix build install) #:use-module (guix build utils) #:use-module (guix build install) + #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (install-grub - evaluate-populate-directive + populate-root-file-system reset-timestamps register-closure)) @@ -46,15 +47,44 @@ MOUNT-POINT. Return #t on success." (define (evaluate-populate-directive directive target) "Evaluate DIRECTIVE, an sexp describing a file or directory to create under directory TARGET." - (match directive - (('directory name) - (mkdir-p (string-append target name))) - (('directory name uid gid) - (let ((dir (string-append target name))) - (mkdir-p dir) - (chown dir uid gid))) - ((new '-> old) - (symlink old (string-append target new))))) + (let loop ((directive directive)) + (match directive + (('directory name) + (mkdir-p (string-append target name))) + (('directory name uid gid) + (let ((dir (string-append target name))) + (mkdir-p dir) + (chown dir uid gid))) + (('directory name uid gid mode) + (loop `(directory ,name ,uid ,gid)) + (chmod (string-append target name) mode)) + ((new '-> old) + (symlink old (string-append target new)))))) + +(define (directives store) + "Return a list of directives to populate the root file system that will host +STORE." + `((directory ,store 0 0) + (directory "/etc") + (directory "/var/log") ; for dmd + (directory "/var/run/nscd") + (directory "/var/guix/gcroots") + (directory "/run") + ("/var/guix/gcroots/booted-system" -> "/run/booted-system") + ("/var/guix/gcroots/current-system" -> "/run/current-system") + (directory "/bin") + ("/bin/sh" -> "/run/current-system/profile/bin/bash") + (directory "/tmp" 0 0 #o1777) ; sticky bit + (directory "/var/guix/profiles/per-user/root" 0 0) + + (directory "/root" 0 0) ; an exception + (directory "/home" 0 0))) + +(define (populate-root-file-system target) + "Make the essential non-store files and directories on TARGET. This +includes /etc, /var, /run, /bin/sh, etc." + (for-each (cut evaluate-populate-directive <> target) + (directives (%store-directory)))) (define (reset-timestamps directory) "Reset the timestamps of all the files under DIRECTORY, so that they appear diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 12f952bd1..b9bb66cdb 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -206,8 +206,7 @@ further populate the partition." ;; Evaluate the POPULATE directives. (display "populating...\n") - (for-each (cut evaluate-populate-directive <> target-directory) - directives) + (populate-root-file-system target-directory) (unless (install-grub grub.cfg "/dev/sda" target-directory) (error "failed to install GRUB")) -- cgit v1.3 From 4b2615e1cae8e21df8f180abf261d1dc22a2459e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 24 May 2014 18:09:11 +0200 Subject: services: nscd: Provide an 'activate' script to make /var/run/nscd. * gnu/services/base.scm (nscd-service): Add 'activate' field. * guix/build/install.scm (directives): Remove /var/run/nscd; add /var/run. * doc/guix.texi (Defining Services): Add 'activate' field in example. Document it. --- doc/guix.texi | 19 +++++++++++++------ gnu/services/base.scm | 5 +++++ guix/build/install.scm | 2 +- 3 files changed, 19 insertions(+), 7 deletions(-) (limited to 'gnu/services') diff --git a/doc/guix.texi b/doc/guix.texi index ddb076349..bd853e6ea 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3299,6 +3299,9 @@ like: (return (service (documentation "Run libc's name service cache daemon.") (provision '(nscd)) + (activate #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/nscd"))) (start #~(make-forkexec-constructor (string-append #$glibc "/sbin/nscd") "-f" "/dev/null" "--foreground")) @@ -3307,12 +3310,16 @@ like: @end lisp @noindent -The @code{start} and @code{stop} fields are G-expressions -(@pxref{G-Expressions}). They refer to dmd's facilities to start and -stop processes (@pxref{Service De- and Constructors,,, dmd, GNU dmd -Manual}). The @code{provision} field specifies the name under which -this service is known to dmd, and @code{documentation} specifies on-line -documentation. Thus, the commands @command{deco start ncsd}, +The @code{activate}, @code{start}, and @code{stop} fields are G-expressions +(@pxref{G-Expressions}). The @code{activate} field contains a script to +run at ``activation'' time; it makes sure that the @file{/var/run/nscd} +directory exists before @command{nscd} is started. + +The @code{start} and @code{stop} fields refer to dmd's facilities to +start and stop processes (@pxref{Service De- and Constructors,,, dmd, +GNU dmd Manual}). The @code{provision} field specifies the name under +which this service is known to dmd, and @code{documentation} specifies +on-line documentation. Thus, the commands @command{deco start ncsd}, @command{deco stop nscd}, and @command{deco doc nscd} will do what you would expect (@pxref{Invoking deco,,, dmd, GNU dmd Manual}). diff --git a/gnu/services/base.scm b/gnu/services/base.scm index aec605058..dc0161408 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -225,6 +225,11 @@ stopped before 'kill' is called." (documentation "Run libc's name service cache daemon (nscd).") (provision '(nscd)) (requirement '(user-processes)) + + (activate #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/nscd"))) + (start #~(make-forkexec-constructor (string-append #$glibc "/sbin/nscd") "-f" "/dev/null" diff --git a/guix/build/install.scm b/guix/build/install.scm index 24de95406..afa7d1dd8 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -76,9 +76,9 @@ STORE." `((directory ,store 0 0) (directory "/etc") (directory "/var/log") ; for dmd - (directory "/var/run/nscd") (directory "/var/guix/gcroots") (directory "/var/empty") ; for no-login accounts + (directory "/var/run") (directory "/run") ("/var/guix/gcroots/booted-system" -> "/run/booted-system") ("/var/guix/gcroots/current-system" -> "/run/current-system") -- cgit v1.3 From f4561be2d13668bbb38dcb01d8bfe56c8c12bf0f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 May 2014 18:23:12 +0200 Subject: services: Add D-Bus and Avahi. * gnu/services/dbus.scm: New file. * gnu/services/avahi.scm: New file. * gnu-system.am (GNU_SYSTEM_MODULES): Add them. --- gnu-system.am | 2 + gnu/services/avahi.scm | 108 ++++++++++++++++++++++++++++++++++++++++++++ gnu/services/dbus.scm | 120 +++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 230 insertions(+) create mode 100644 gnu/services/avahi.scm create mode 100644 gnu/services/dbus.scm (limited to 'gnu/services') diff --git a/gnu-system.am b/gnu-system.am index ab8bf113f..242dc2d13 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -245,7 +245,9 @@ GNU_SYSTEM_MODULES = \ gnu/packages/zip.scm \ \ gnu/services.scm \ + gnu/services/avahi.scm \ gnu/services/base.scm \ + gnu/services/dbus.scm \ gnu/services/dmd.scm \ gnu/services/networking.scm \ gnu/services/xorg.scm \ diff --git a/gnu/services/avahi.scm b/gnu/services/avahi.scm new file mode 100644 index 000000000..4b52fd784 --- /dev/null +++ b/gnu/services/avahi.scm @@ -0,0 +1,108 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu services avahi) + #:use-module (gnu services) + #:use-module (gnu system shadow) + #:use-module (gnu packages avahi) + #:use-module (guix monads) + #:use-module (guix gexp) + #:export (avahi-service)) + +;;; Commentary: +;;; +;;; This module provides service definitions for the Avahi +;;; "zero-configuration" tool set. +;;; +;;; Code: + +(define* (configuration-file #:key host-name publish? + ipv4? ipv6? wide-area? domains-to-browse) + "Return an avahi-daemon configuration file." + (define (bool value) + (if value "yes\n" "no\n")) + + (text-file "avahi-daemon.conf" + (string-append + "[server]\n" + (if host-name + (string-append "host-name=" host-name "\n") + "") + + "browse-domains=" (string-join domains-to-browse) + "\n" + "use-ipv4=" (bool ipv4?) + "use-ipv6=" (bool ipv6?) + "[wide-area]\n" + "enable-wide-area=" (bool wide-area?) + "[publish]\n" + "disable-publishing=" (bool (not publish?))))) + +(define* (avahi-service #:key (avahi avahi) + host-name + (publish? #t) + (ipv4? #t) (ipv6? #t) + wide-area? + (domains-to-browse '())) + "Return a service that runs @command{avahi-daemon}, a system-wide +mDNS/DNS-SD responder that allows for service discovery and +\"zero-configuration\" host name lookups. + +If @var{host-name} is different from @code{#f}, use that as the host name to +publish for this machine; otherwise, use the machine's actual host name. + +When @var{publish?} is true, publishing of host names and services is allowed; +in particular, avahi-daemon will publish the machine's host name and IP +address via mDNS on the local network. + +When @var{wide-area?} is true, DNS-SD over unicast DNS is enabled. + +Boolean values @var{ipv4?} and @var{ipv6?} determine whether to use IPv4/IPv6 +sockets." + (mlet %store-monad ((config (configuration-file #:host-name host-name + #:publish? publish? + #:ipv4? ipv4? + #:ipv6? ipv6? + #:wide-area? wide-area? + #:domains-to-browse + domains-to-browse))) + (return + (service + (documentation "Run the Avahi mDNS/DNS-SD responder.") + (provision '(avahi-daemon)) + (requirement '(dbus-system networking)) + + (start #~(make-forkexec-constructor + (string-append #$avahi "/sbin/avahi-daemon") + "--syslog" "-f" #$config)) + (stop #~(make-kill-destructor)) + (activate #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/avahi-daemon"))) + + (user-groups (list (user-group + (name "avahi")))) + (user-accounts (list (user-account + (name "avahi") + (group "avahi") + (comment "Avahi daemon user") + (home-directory "/var/empty") + (shell + "/run/current-system/profile/sbin/nologin")))))))) + +;;; avahi.scm ends here diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm new file mode 100644 index 000000000..3fbbfde09 --- /dev/null +++ b/gnu/services/dbus.scm @@ -0,0 +1,120 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu services dbus) + #:use-module (gnu services) + #:use-module (gnu system shadow) + #:use-module (gnu packages glib) + #:use-module (guix monads) + #:use-module (guix gexp) + #:export (dbus-service)) + +;;; Commentary: +;;; +;;; This module supports the configuration of the D-Bus message bus +;;; (http://dbus.freedesktop.org/). D-Bus is an inter-process communication +;;; facility. Its "system bus" is used to allow system services to +;;; communicate and be notified of system-wide events. +;;; +;;; Code: + +(define (dbus-configuration-directory dbus services) + "Return a configuration directory for @var{dbus} that includes the +@code{etc/dbus-1/system.d} directories of each package listed in +@var{services}." + (define build + #~(begin + (use-modules (sxml simple)) + + (define (services->sxml services) + ;; Return the SXML 'includedir' clauses for DIRS. + `(busconfig + ,@(map (lambda (dir) + `(includedir ,(string-append dir + "/etc/dbus-1/system.d"))) + services))) + + (mkdir #$output) + (copy-file (string-append #$dbus "/etc/dbus-1/system.conf") + (string-append #$output "/system.conf")) + + ;; The default 'system.conf' has an clause for + ;; 'system.d', so create it. + (mkdir (string-append #$output "/system.d")) + + ;; 'system-local.conf' is automatically included by the default + ;; 'system.conf', so this is where we stuff our own things. + (call-with-output-file (string-append #$output "/system-local.conf") + (lambda (port) + (sxml->xml (services->sxml (list #$@services)) + port))))) + + (gexp->derivation "dbus-configuration" build)) + +(define* (dbus-service services #:key (dbus dbus)) + "Return a service that runs the system bus, using @var{dbus}, with support +for @var{services}. + +@var{services} must be a list of packages that provide an +@file{etc/dbus-1/system.d} directory containing additional D-Bus configuration +and policy files. For example, to allow avahi-daemon to use the system bus, +@var{services} must be equal to @code{(list avahi)}." + (mlet %store-monad ((conf (dbus-configuration-directory dbus services))) + (return + (service + (documentation "Run the D-Bus system daemon.") + (provision '(dbus-system)) + (requirement '(user-processes)) + (start #~(make-forkexec-constructor + (string-append #$dbus "/bin/dbus-daemon") + "--nofork" + (string-append "--config-file=" #$conf "/system.conf"))) + (stop #~(make-kill-destructor)) + (user-groups (list (user-group + (name "messagebus")))) + (user-accounts (list (user-account + (name "messagebus") + (group "messagebus") + (comment "D-Bus system bus user") + (home-directory "/var/run/dbus") + (shell + "/run/current-system/profile/sbin/nologin")))) + (activate #~(begin + (use-modules (guix build utils)) + + (mkdir-p "/var/run/dbus") + + (let ((user (getpwnam "messagebus"))) + (chown "/var/run/dbus" + (passwd:uid user) (passwd:gid user))) + + (unless (file-exists? "/etc/machine-id") + (format #t "creating /etc/machine-id...~%") + (let ((prog (string-append #$dbus "/bin/dbus-uuidgen"))) + ;; XXX: We can't use 'system' because the initrd's + ;; guile system(3) only works when 'sh' is in $PATH. + (let ((pid (primitive-fork))) + (if (zero? pid) + (call-with-output-file "/etc/machine-id" + (lambda (port) + (close-fdes 1) + (dup2 (port->fdes port) 1) + (execl prog))) + (waitpid pid))))))))))) + +;;; dbus.scm ends here -- cgit v1.3