diff options
Diffstat (limited to 'gnu')
| -rw-r--r-- | gnu/services.scm | 7 | ||||
| -rw-r--r-- | gnu/services/base.scm | 60 | ||||
| -rw-r--r-- | gnu/services/dmd.scm | 77 | ||||
| -rw-r--r-- | gnu/services/networking.scm | 58 | ||||
| -rw-r--r-- | gnu/services/xorg.scm | 19 | ||||
| -rw-r--r-- | gnu/system.scm | 44 | ||||
| -rw-r--r-- | gnu/system/linux.scm | 74 | ||||
| -rw-r--r-- | gnu/system/shadow.scm | 48 |
8 files changed, 173 insertions, 214 deletions
diff --git a/gnu/services.scm b/gnu/services.scm index eccde4e9a3..8b89b11b8f 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 <user-account> (default '())) (user-groups service-user-groups ; list of <user-groups> diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 3145a657f8..9561995243 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 54fb5cbfd6..c187c09857 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (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 <service> - #: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 <service> + #: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 317800db50..5522541735 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 086150a658..81b5bc17a5 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 65b524d387..20c49c182a 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 65868ce9bf..efe27c55c3 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 <ludo@gnu.org> +;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; 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> 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 (($ <pam-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 (($ <pam-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 ($ <pam-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 2a85a20ebb..52242ee4e0 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 <ludo@gnu.org> +;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; 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> 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 - ((($ <user-account> 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 + (($ <user-account> 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 |