ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2025-01-11 13:49:23 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

services: Rewrite using gexps.

Browse source 
* gnu/services.scm (<service>)[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 (<user-account>)[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".
This commit is contained in:
Ludovic Courtès 2014-04-28 23:07:08 +02:00
parent 1aa0033b64
commit b5f4e68635
9 changed files with 187 additions and 231 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
doc/guix.texi
View file

@ -3224,29 +3224,26 @@ like:
@lisp @lisp
(define (nscd-service) (define (nscd-service)
(mlet %store-monad ((nscd (package-file glibc "sbin/nscd"))) (with-monad %store-monad
(return (service (return (service
(documentation "Run libc's name service cache daemon.") (documentation "Run libc's name service cache daemon.")
(provision '(nscd)) (provision '(nscd))
(start `(make-forkexec-constructor ,nscd "-f" "/dev/null" (start #~(make-forkexec-constructor
"--foreground")) (string-append #$glibc "/sbin/nscd")
(stop `(make-kill-destructor)) "-f" "/dev/null" "--foreground"))
(stop #~(make-kill-destructor))
(respawn? #f) (respawn? #f)))))
(inputs `(("glibc" ,glibc)))))))
@end lisp @end lisp
@noindent @noindent
The @code{inputs} field specifies that this service depends on the The @code{start} and @code{stop} fields are G-expressions
@var{glibc} package---the package that contains the @command{nscd} (@pxref{G-Expressions}). They refer to dmd's facilities to start and
program. The @code{start} and @code{stop} fields are expressions that stop processes (@pxref{Service De- and Constructors,,, dmd, GNU dmd
make use of dmd's facilities to start and stop processes (@pxref{Service Manual}). The @code{provision} field specifies the name under which
De- and Constructors,,, dmd, GNU dmd Manual}). The @code{provision} this service is known to dmd, and @code{documentation} specifies on-line
field specifies the name under which this service is known to dmd, and documentation. Thus, the commands @command{deco start ncsd},
@code{documentation} specifies on-line documentation. Thus, the @command{deco stop nscd}, and @command{deco doc nscd} will do what you
commands @command{deco start ncsd}, @command{deco stop nscd}, and would expect (@pxref{Invoking deco,,, dmd, GNU dmd Manual}).
@command{deco doc nscd} will do what you would expect (@pxref{Invoking
deco,,, dmd, GNU dmd Manual}).
@c ********************************************************************* @c *********************************************************************

7
gnu/services.scm
View file

@ -26,7 +26,6 @@ (define-module (gnu services)
service-respawn? service-respawn?
service-start service-start
service-stop service-stop
service-inputs
service-user-accounts service-user-accounts
service-user-groups service-user-groups
service-pam-services)) service-pam-services))
@ -47,11 +46,9 @@ (define-record-type* <service>
(default '())) (default '()))
(respawn? service-respawn? ; Boolean (respawn? service-respawn? ; Boolean
(default #t)) (default #t))
(start service-start) ; expression (start service-start) ; g-expression
(stop service-stop ; expression (stop service-stop ; g-expression
(default #f)) (default #f))
(inputs service-inputs ; list of inputs
(default '()))
(user-accounts service-user-accounts ; list of <user-account> (user-accounts service-user-accounts ; list of <user-account>
(default '())) (default '()))
(user-groups service-user-groups ; list of <user-groups> (user-groups service-user-groups ; list of <user-groups>

60
gnu/services/base.scm
View file

@ -24,6 +24,7 @@ (define-module (gnu services base)
#:use-module ((gnu packages base) #:use-module ((gnu packages base)
#:select (glibc-final)) #:select (glibc-final))
#:use-module (gnu packages package-management) #:use-module (gnu packages package-management)
#:use-module (guix gexp)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
@ -48,8 +49,8 @@ (define (host-name-service name)
(return (service (return (service
(documentation "Initialize the machine's host name.") (documentation "Initialize the machine's host name.")
(provision '(host-name)) (provision '(host-name))
(start `(lambda _ (start #~(lambda _
(sethostname ,name))) (sethostname #$name)))
(respawn? #f))))) (respawn? #f)))))
(define* (mingetty-service tty (define* (mingetty-service tty
@ -57,8 +58,7 @@ (define* (mingetty-service tty
(motd (text-file "motd" "Welcome.\n")) (motd (text-file "motd" "Welcome.\n"))
(allow-empty-passwords? #t)) (allow-empty-passwords? #t))
"Return a service to run mingetty on TTY." "Return a service to run mingetty on TTY."
(mlet %store-monad ((mingetty-bin (package-file mingetty "sbin/mingetty")) (mlet %store-monad ((motd motd))
(motd motd))
(return (return
(service (service
(documentation (string-append "Run mingetty on " tty ".")) (documentation (string-append "Run mingetty on " tty "."))
@ -68,10 +68,10 @@ (define* (mingetty-service tty
;; service to be done. ;; service to be done.
(requirement '(host-name)) (requirement '(host-name))
(start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty)) (start #~(make-forkexec-constructor
(stop `(make-kill-destructor)) (string-append #$mingetty "/sbin/mingetty")
(inputs `(("mingetty" ,mingetty) "--noclear" #$tty))
("motd" ,motd))) (stop #~(make-kill-destructor))
(pam-services (pam-services
;; Let 'login' be known to PAM. All the mingetty services will have ;; Let 'login' be known to PAM. All the mingetty services will have
@ -83,16 +83,17 @@ (define* (mingetty-service tty
(define* (nscd-service #:key (glibc glibc-final)) (define* (nscd-service #:key (glibc glibc-final))
"Return a service that runs libc's name service cache daemon (nscd)." "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 (return (service
(documentation "Run libc's name service cache daemon (nscd).") (documentation "Run libc's name service cache daemon (nscd).")
(provision '(nscd)) (provision '(nscd))
(start `(make-forkexec-constructor ,nscd "-f" "/dev/null" (start
"--foreground")) #~(make-forkexec-constructor (string-append #$glibc "/sbin/nscd")
(stop `(make-kill-destructor)) "-f" "/dev/null"
"--foreground"))
(stop #~(make-kill-destructor))
(respawn? #f) (respawn? #f)))))
(inputs `(("glibc" ,glibc)))))))
(define (syslog-service) (define (syslog-service)
"Return a service that runs 'syslogd' with reasonable default settings." "Return a service that runs 'syslogd' with reasonable default settings."
@ -120,17 +121,17 @@ (define contents "
") ")
(mlet %store-monad (mlet %store-monad
((syslog.conf (text-file "syslog.conf" contents)) ((syslog.conf (text-file "syslog.conf" contents)))
(syslogd (package-file inetutils "libexec/syslogd")))
(return (return
(service (service
(documentation "Run the syslog daemon (syslogd).") (documentation "Run the syslog daemon (syslogd).")
(provision '(syslogd)) (provision '(syslogd))
(start `(make-forkexec-constructor ,syslogd "--no-detach" (start
"--rcfile" ,syslog.conf)) #~(make-forkexec-constructor (string-append #$inetutils
(stop `(make-kill-destructor)) "/libexec/syslogd")
(inputs `(("inetutils" ,inetutils) "--no-detach"
("syslog.conf" ,syslog.conf))))))) "--rcfile" #$syslog.conf))
(stop #~(make-kill-destructor))))))
(define* (guix-build-accounts count #:key (define* (guix-build-accounts count #:key
(first-uid 30001) (first-uid 30001)
@ -148,8 +149,7 @@ (define* (guix-build-accounts count #:key
(gid gid) (gid gid)
(comment (format #f "Guix Build User ~2d" n)) (comment (format #f "Guix Build User ~2d" n))
(home-directory "/var/empty") (home-directory "/var/empty")
(shell (package-file shadow "sbin/nologin")) (shell #~(string-append #$shadow "/sbin/nologin"))))
(inputs `(("shadow" ,shadow)))))
1+ 1+
1)))) 1))))
@ -157,16 +157,16 @@ (define* (guix-service #:key (guix guix) (builder-group "guixbuild")
(build-user-gid 30000) (build-accounts 10)) (build-user-gid 30000) (build-accounts 10))
"Return a service that runs the build daemon from GUIX, and has "Return a service that runs the build daemon from GUIX, and has
BUILD-ACCOUNTS user accounts available under BUILD-USER-GID." BUILD-ACCOUNTS user accounts available under BUILD-USER-GID."
(mlet %store-monad ((daemon (package-file guix "bin/guix-daemon")) (mlet %store-monad ((accounts (guix-build-accounts build-accounts
(accounts (guix-build-accounts build-accounts
#:gid build-user-gid))) #:gid build-user-gid)))
(return (service (return (service
(provision '(guix-daemon)) (provision '(guix-daemon))
(start `(make-forkexec-constructor ,daemon (start
"--build-users-group" #~(make-forkexec-constructor (string-append #$guix
,builder-group)) "/bin/guix-daemon")
(stop `(make-kill-destructor)) "--build-users-group"
(inputs `(("guix" ,guix))) #$builder-group))
(stop #~(make-kill-destructor))
(user-accounts accounts) (user-accounts accounts)
(user-groups (list (user-group (user-groups (list (user-group
(name builder-group) (name builder-group)

77
gnu/services/dmd.scm
View file

@ -17,6 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu services dmd) (define-module (gnu services dmd)
#:use-module (guix gexp)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (ice-9 match) #:use-module (ice-9 match)
@ -31,50 +32,50 @@ (define-module (gnu services dmd)
(define (dmd-configuration-file services etc) (define (dmd-configuration-file services etc)
"Return the dmd configuration file for SERVICES, that initializes /etc from "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 (define config
`(begin #~(begin
(use-modules (ice-9 ftw)) (use-modules (ice-9 ftw))
(register-services (register-services
,@(map (lambda (service) #$@(map (lambda (service)
`(make <service> #~(make <service>
#:docstring ',(service-documentation service) #:docstring '#$(service-documentation service)
#:provides ',(service-provision service) #:provides '#$(service-provision service)
#:requires ',(service-requirement service) #:requires '#$(service-requirement service)
#:respawn? ',(service-respawn? service) #:respawn? '#$(service-respawn? service)
#:start ,(service-start service) #:start #$(service-start service)
#:stop ,(service-stop service))) #:stop #$(service-stop service)))
services)) services))
;; /etc is a mixture of static and dynamic settings. Here is where we ;; /etc is a mixture of static and dynamic settings. Here is where we
;; initialize it from the static part. ;; initialize it from the static part.
(format #t "populating /etc from ~a...~%" ,etc) (format #t "populating /etc from ~a...~%" #$etc)
(let ((rm-f (lambda (f) (let ((rm-f (lambda (f)
(false-if-exception (delete-file f))))) (false-if-exception (delete-file f)))))
(rm-f "/etc/static") (rm-f "/etc/static")
(symlink ,etc "/etc/static") (symlink #$etc "/etc/static")
(for-each (lambda (file) (for-each (lambda (file)
;; TODO: Handle 'shadow' specially so that changed ;; TODO: Handle 'shadow' specially so that changed
;; password aren't lost. ;; password aren't lost.
(let ((target (string-append "/etc/" file)) (let ((target (string-append "/etc/" file))
(source (string-append "/etc/static/" file))) (source (string-append "/etc/static/" file)))
(rm-f target) (rm-f target)
(symlink source target))) (symlink source target)))
(scandir ,etc (scandir #$etc
(lambda (file) (lambda (file)
(not (member file '("." "..")))))) (not (member file '("." ".."))))))
;; Prevent ETC from being GC'd. ;; Prevent ETC from being GC'd.
(rm-f "/var/guix/gcroots/etc-directory") (rm-f "/var/guix/gcroots/etc-directory")
(symlink ,etc "/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. ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it.
(setenv "PATH" "/run/current-system/bin") (setenv "PATH" "/run/current-system/bin")
(format #t "starting services...~%") (format #t "starting services...~%")
(for-each start ',(append-map service-provision 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 ;;; dmd.scm ends here

58
gnu/services/networking.scm
View file

@ -20,6 +20,7 @@ (define-module (gnu services networking)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu packages admin) #:use-module (gnu packages admin)
#:use-module (gnu packages linux) #:use-module (gnu packages linux)
#:use-module (guix gexp)
#:use-module (guix monads) #:use-module (guix monads)
#:export (static-networking-service)) #:export (static-networking-service))
@ -41,40 +42,41 @@ (define* (static-networking-service interface ip
;; TODO: Eventually we should do this using Guile's networking procedures, ;; TODO: Eventually we should do this using Guile's networking procedures,
;; like 'configure-qemu-networking' does, but the patch that does this is ;; like 'configure-qemu-networking' does, but the patch that does this is
;; not yet in stock Guile. ;; not yet in stock Guile.
(mlet %store-monad ((ifconfig (package-file inetutils "bin/ifconfig")) (with-monad %store-monad
(route (package-file net-tools "sbin/route")))
(return (return
(service (service
(documentation (documentation
(string-append "Set up networking on the '" interface (string-append "Set up networking on the '" interface
"' interface using a static IP address.")) "' interface using a static IP address."))
(provision '(networking)) (provision '(networking))
(start `(lambda _ (start #~(lambda _
;; Return #t if successfully started. ;; Return #t if successfully started.
(and (zero? (system* ,ifconfig ,interface ,ip "up")) (and (zero? (system* (string-append #$inetutils
,(if gateway "/bin/ifconfig")
`(zero? (system* ,route "add" "-net" "default" #$interface #$ip "up"))
"gw" ,gateway)) #$(if gateway
#t) #~(zero? (system* (string-append #$net-tools
,(if (pair? name-servers) "/sbin/route")
`(call-with-output-file "/etc/resolv.conf" "add" "-net" "default"
(lambda (port) "gw" #$gateway))
(display #t)
"# Generated by 'static-networking-service'.\n" #$(if (pair? name-servers)
port) #~(call-with-output-file "/etc/resolv.conf"
(for-each (lambda (server) (lambda (port)
(format port "nameserver ~a~%" (display
server)) "# Generated by 'static-networking-service'.\n"
',name-servers))) port)
#t)))) (for-each (lambda (server)
(stop `(lambda _ (format port "nameserver ~a~%"
server))
'#$name-servers)))
#t))))
(stop #~(lambda _
;; Return #f is successfully stopped. ;; Return #f is successfully stopped.
(not (and (system* ,ifconfig ,interface "down") (not (and (system* (string-append #$inetutils "/sbin/ifconfig")
(system* ,route "del" "-net" "default"))))) #$interface "down")
(respawn? #f) (system* (string-append #$net-tools "/sbin/route")
(inputs `(("inetutils" ,inetutils) "del" "-net" "default")))))
,@(if gateway (respawn? #f)))))
`(("net-tools" ,net-tools))
'())))))))
;;; networking.scm ends here ;;; networking.scm ends here

19
gnu/services/xorg.scm
View file

@ -27,6 +27,7 @@ (define-module (gnu services xorg)
#:use-module (gnu packages gnustep) #:use-module (gnu packages gnustep)
#:use-module (gnu packages admin) #:use-module (gnu packages admin)
#:use-module (gnu packages bash) #:use-module (gnu packages bash)
#:use-module (guix gexp)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix derivations) #:use-module (guix derivations)
#:export (xorg-start-command #:export (xorg-start-command
@ -190,9 +191,7 @@ (define (slim.cfg)
(string-append "auto_login yes\ndefault_user " default-user) (string-append "auto_login yes\ndefault_user " default-user)
"")))) ""))))
(mlet %store-monad ((slim-bin (package-file slim "bin/slim")) (mlet %store-monad ((slim.cfg (slim.cfg)))
(bash-bin (package-file bash "bin/bash"))
(slim.cfg (slim.cfg)))
(return (return
(service (service
(documentation "Xorg display server") (documentation "Xorg display server")
@ -200,15 +199,11 @@ (define (slim.cfg)
(requirement '(host-name)) (requirement '(host-name))
(start (start
;; XXX: Work around the inability to specify env. vars. directly. ;; XXX: Work around the inability to specify env. vars. directly.
`(make-forkexec-constructor #~(make-forkexec-constructor
,bash-bin "-c" (string-append #$bash "/bin/sh") "-c"
,(string-append "SLIM_CFGFILE=" (derivation->output-path slim.cfg) (string-append "SLIM_CFGFILE=" #$slim.cfg
" " slim-bin " " #$slim "/bin/slim" " -nodaemon")))
" -nodaemon"))) (stop #~(make-kill-destructor))
(stop `(make-kill-destructor))
(inputs `(("slim" ,slim)
("slim.cfg" ,slim.cfg)
("bash" ,bash)))
(respawn? #t) (respawn? #t)
(pam-services (pam-services
;; Tell PAM about 'slim'. ;; Tell PAM about 'slim'.

44
gnu/system.scm
View file

@ -192,29 +192,6 @@ (define* (file-union files
#:inputs inputs #:inputs inputs
#:local-build? #t)))) #: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 (define* (etc-directory #:key
(locale "C") (timezone "Europe/Paris") (locale "C") (timezone "Europe/Paris")
(accounts '()) (accounts '())
@ -272,12 +249,14 @@ (define* (etc-directory #:key
("shells" ,shells) ("shells" ,shells)
("profile" ,(derivation->output-path bashrc)) ("profile" ,(derivation->output-path bashrc))
("localtime" ,tz-file) ("localtime" ,tz-file)
("passwd" ,passwd) ("passwd" ,(derivation->output-path passwd))
("shadow" ,shadow) ("shadow" ,(derivation->output-path shadow))
("group" ,group)))) ("group" ,group))))
(file-union files (file-union files
#:inputs `(("net" ,net-base) #:inputs `(("net" ,net-base)
("pam.d" ,pam.d) ("pam.d" ,pam.d)
("passwd" ,passwd)
("shadow" ,shadow)
("bashrc" ,bashrc) ("bashrc" ,bashrc)
("tzdata" ,tzdata)) ("tzdata" ,tzdata))
#:name "etc"))) #:name "etc")))
@ -327,8 +306,7 @@ (define (operating-system-boot-script os)
(mlet* %store-monad (mlet* %store-monad
((services (sequence %store-monad (operating-system-services os))) ((services (sequence %store-monad (operating-system-services os)))
(etc (operating-system-etc-directory os)) (etc (operating-system-etc-directory os))
(dmd-conf (dmd-configuration-file services (dmd-conf (dmd-configuration-file services etc)))
(derivation->output-path etc))))
(gexp->file "boot" (gexp->file "boot"
#~(execl (string-append #$dmd "/bin/dmd") #~(execl (string-append #$dmd "/bin/dmd")
"dmd" "--config" #$dmd-conf)))) "dmd" "--config" #$dmd-conf))))
@ -357,25 +335,19 @@ (define (operating-system-derivation os)
(linux-arguments `("--root=/dev/sda1" (linux-arguments `("--root=/dev/sda1"
,(string-append "--load=" boot))) ,(string-append "--load=" boot)))
(initrd initrd-file)))) (initrd initrd-file))))
(grub.cfg (grub-configuration-file entries)) (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))))))
(file-union `(("boot" ,boot) (file-union `(("boot" ,boot)
("kernel" ,kernel-dir) ("kernel" ,kernel-dir)
("initrd" ,initrd-file) ("initrd" ,initrd-file)
("profile" ,profile) ("profile" ,profile)
("grub.cfg" ,grub.cfg) ("grub.cfg" ,grub.cfg)
("etc" ,etc) ("etc" ,etc))
("system-inputs" ,(derivation->output-path extras)))
#:inputs `(("boot" ,boot-drv) #:inputs `(("boot" ,boot-drv)
("kernel" ,kernel) ("kernel" ,kernel)
("initrd" ,initrd) ("initrd" ,initrd)
("bash" ,bash) ("bash" ,bash)
("profile" ,profile-drv) ("profile" ,profile-drv)
("etc" ,etc-drv) ("etc" ,etc-drv))
("system-inputs" ,extras))
#:name "system"))) #:name "system")))
;;; system.scm ends here ;;; system.scm ends here

74
gnu/system/linux.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -21,6 +21,7 @@ (define-module (gnu system linux)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix gexp)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
@ -58,58 +59,56 @@ (define-record-type* <pam-service> pam-service
(define-record-type* <pam-entry> pam-entry (define-record-type* <pam-entry> pam-entry
make-pam-entry make-pam-entry
pam-entry? pam-entry?
(control pam-entry-control) ; string (control pam-entry-control) ; string
(module pam-entry-module) ; file name (module pam-entry-module) ; file name
(arguments pam-entry-arguments ; list of strings (arguments pam-entry-arguments ; list of string-valued g-expressions
(default '()))) (default '())))
(define (pam-service->configuration service) (define (pam-service->configuration service)
"Return the configuration string for SERVICE, to be dumped in "Return the derivation building the configuration file for SERVICE, to be
/etc/pam.d/NAME, where NAME is the name of SERVICE." dumped in /etc/pam.d/NAME, where NAME is the name of SERVICE."
(define (entry->string type entry) (define (entry->gexp type entry)
(match entry (match entry
(($ <pam-entry> control module (arguments ...)) (($ <pam-entry> control module (arguments ...))
(string-append type " " #~(format #t "~a ~a ~a ~a~%"
control " " module " " #$type #$control #$module
(string-join arguments) (string-join (list #$@arguments))))))
"\n"))))
(match service (match service
(($ <pam-service> name account auth password session) (($ <pam-service> name account auth password session)
(string-concatenate (define builder
(append (map (cut entry->string "account" <>) account) #~(begin
(map (cut entry->string "auth" <>) auth) (with-output-to-file #$output
(map (cut entry->string "password" <>) password) (lambda ()
(map (cut entry->string "session" <>) session)))))) #$@(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) (define (pam-services->directory services)
"Return the derivation to build the configuration directory to be used as "Return the derivation to build the configuration directory to be used as
/etc/pam.d for SERVICES." /etc/pam.d for SERVICES."
(mlet %store-monad (mlet %store-monad
((names -> (map pam-service-name services)) ((names -> (map pam-service-name services))
(files (mapm %store-monad (files (sequence %store-monad
(match-lambda (map pam-service->configuration
((and service ($ <pam-service> name)) ;; XXX: Eventually, SERVICES may be a list of
(let ((config (pam-service->configuration service))) ;; monadic values instead of plain values.
(text-file (string-append name ".pam") config)))) services))))
;; XXX: Eventually, SERVICES may be a list of monadic
;; values instead of plain values.
(map return services))))
(define builder (define builder
'(begin #~(begin
(use-modules (ice-9 match)) (use-modules (ice-9 match))
(let ((out (assoc-ref %outputs "out"))) (mkdir #$output)
(mkdir out) (for-each (match-lambda
(for-each (match-lambda ((name file)
((name . file) (symlink file (string-append #$output "/" name))))
(symlink file (string-append out "/" name)))) '#$(zip names files))))
%build-inputs)
#t)))
(derivation-expression "pam.d" builder (gexp->derivation "pam.d" builder)))
#:inputs (zip names files))))
(define %pam-other-services (define %pam-other-services
;; The "other" PAM configuration, which denies everything (see ;; The "other" PAM configuration, which denies everything (see
@ -149,7 +148,8 @@ (module "pam_unix.so")
(pam-entry (pam-entry
(control "optional") (control "optional")
(module "pam_motd.so") (module "pam_motd.so")
(arguments (list (string-append "motd=" motd))))) (arguments
(list #~(string-append "motd=" #$motd)))))
(list unix)))))))) (list unix))))))))
;;; linux.scm ends here ;;; linux.scm ends here

48
gnu/system/shadow.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -20,6 +20,7 @@ (define-module (gnu system shadow)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix gexp)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module ((gnu packages admin) #:use-module ((gnu packages admin)
#:select (shadow)) #:select (shadow))
@ -35,7 +36,6 @@ (define-module (gnu system shadow)
user-account-comment user-account-comment
user-account-home-directory user-account-home-directory
user-account-shell user-account-shell
user-account-inputs
user-group user-group
user-group? user-group?
@ -63,9 +63,8 @@ (define-record-type* <user-account>
(gid user-account-gid) (gid user-account-gid)
(comment user-account-comment (default "")) (comment user-account-comment (default ""))
(home-directory user-account-home-directory) (home-directory user-account-home-directory)
(shell user-account-shell ; monadic value (shell user-account-shell ; gexp
(default (package-file bash "bin/bash"))) (default #~(string-append #$bash "/bin/bash"))))
(inputs user-account-inputs (default `(("bash" ,bash)))))
(define-record-type* <user-group> (define-record-type* <user-group>
user-group make-user-group user-group make-user-group
@ -97,29 +96,22 @@ (define* (passwd-file accounts #:key shadow?)
SHADOW? is true, then it is a /etc/shadow file, otherwise it is a /etc/passwd SHADOW? is true, then it is a /etc/shadow file, otherwise it is a /etc/passwd
file." file."
;; XXX: The resulting file is world-readable, so beware when SHADOW? is #t! ;; XXX: The resulting file is world-readable, so beware when SHADOW? is #t!
(define (contents) (define account-exp
(with-monad %store-monad (match-lambda
(let loop ((accounts accounts) (($ <user-account> name pass uid gid comment home-dir shell)
(result '())) (if shadow? ; XXX: use (crypt PASS …)?
(match accounts #~(format #t "~a::::::::~%" #$name)
((($ <user-account> name pass uid gid comment home-dir mshell) #~(format #t "~a:x:~a:~a:~a:~a:~a~%"
rest ...) #$name #$(number->string uid) #$(number->string gid)
(mlet %store-monad ((shell mshell)) #$comment #$home-dir #$shell)))))
(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)))))))
(mlet %store-monad ((contents (contents))) (define builder
(text-file (if shadow? "shadow" "passwd") contents))) #~(begin
(with-output-to-file #$output
(lambda ()
#$@(map account-exp accounts)
#t))))
(gexp->derivation (if shadow? "shadow" "passwd") builder))
;;; shadow.scm ends here ;;; shadow.scm ends here