me
/
guix
Archived
1
0
Fork 0

system: Make service procedures non-monadic.

* gnu/services/avahi.scm (configuration-file): Use 'plain-file' instead
  of 'text-file'.
  (avahi-service): Turn into a regular procedure that returns a <service>.
* gnu/services/base.scm (root-file-system-service, file-system-service,
  user-unmount-service, user-processes-service, host-name-service,
  console-keymap-service, console-font-service, mingetty-service,
  nscd.conf-file, nscd-service): Likewise.
  (%default-syslog.conf): New variable.
  (syslog-service): Use it.  Turn into a regular procedure.
  (guix-service, udev-rules-union, kvm-udev-rule, udev-service,
  device-mapping-service, swap-service): Likewise.
* gnu/services/databases.scm (%default-postgres-hba,
  %default-postgres-ident): Use 'plain-file' instead of 'text-file'.
  (%default-postgres-config): Use 'mixed-text-file' instead of
  'text-file*'.
  (postgresql-service):  Use 'program-file' instead of 'gexp->script'.
  Turn into a regular procedure.
* gnu/services/desktop.scm (dbus-configuration-directory): Use
  'computed-file' instead of 'gexp->derivation'.
  (upower-configuration-file, geoclue-configuration-file,
  elogind-configuration-file): Use 'plain-file' instead of 'text-file'.
  (dbus-service, upower-service, colord-service, geoclue-service,
  polkit-service, elogind-service): Turn into regular procedures.
  (%desktop-services): Remove use of 'mlet' when iterating on
  %BASE-SERVICES.
* gnu/services/lirc.scm (lirc-service): Turn into a regular procedure.
* gnu/services/networking.scm (static-networking-service,
  dhcp-client-service, ntp-service, tor-service, bitlbee-service,
  wicd-service): Likewise.
* gnu/services/ssh.scm (lsh-service): Likewise.
* gnu/services/web.scm (nginx-service): Likewise.
* gnu/services/xorg.scm (xorg-configuration-file): Use 'mixed-text-file'
  instead of 'text-file*'.
  (xorg-start-command, slim-service): Turn into regular procedures.
  (xinitrc): Use 'program-file' instead of 'gexp->script'.
* gnu/system/install.scm (cow-store-service,
  configuration-template-service): Turn into regular procedures.
* gnu/system.scm (other-file-system-services, device-mapping-services,
  swap-services, essential-services, operating-system-services,
  user-shells, operating-system-accounts): Remove now unnecessary
  'mlet' and turn into regular procedures.
  (operating-system-etc-directory, operating-system-activation-script,
  operating-system-boot-script): Adjust accordingly.
* doc/guix.texi (Base Services, Networking Services, X Window, Desktop
  Services, Database Services, Web Services, Various Services, Name
  Service Switch): Adjust accordingly.
master
Ludovic Courtès 2015-09-09 09:17:31 +02:00
parent ce8a6dfc43
commit be1c2c54d9
12 changed files with 1071 additions and 1153 deletions

View File

@ -5749,11 +5749,11 @@ this:
@end example
@end defvr
@deffn {Monadic Procedure} host-name-service @var{name}
@deffn {Scheme Procedure} host-name-service @var{name}
Return a service that sets the host name to @var{name}.
@end deffn
@deffn {Monadic Procedure} mingetty-service @var{tty} [#:motd] @
@deffn {Scheme Procedure} mingetty-service @var{tty} [#:motd] @
[#:auto-login #f] [#:login-program] [#:login-pause? #f] @
[#:allow-empty-passwords? #f]
Return a service to run mingetty on @var{tty}.
@ -5774,7 +5774,7 @@ the ``message of the day''.
@cindex name service cache daemon
@cindex nscd
@deffn {Monadic Procedure} nscd-service [@var{config}] [#:glibc glibc] @
@deffn {Scheme Procedure} nscd-service [@var{config}] [#:glibc glibc] @
[#:name-services '()]
Return a service that runs libc's name service cache daemon (nscd) with
the given @var{config}---an @code{<nscd-configuration>} object.
@ -5861,13 +5861,13 @@ external name servers do not even need to be queried.
@end defvr
@deffn {Monadic Procedure} syslog-service [#:config-file #f]
@deffn {Scheme Procedure} syslog-service [#:config-file #f]
Return a service that runs @code{syslogd}. If configuration file name
@var{config-file} is not specified, use some reasonable default
settings.
@end deffn
@deffn {Monadic Procedure} guix-service [#:guix guix] @
@deffn {Scheme Procedure} guix-service [#:guix guix] @
[#:builder-group "guixbuild"] [#:build-accounts 10] @
[#:authorize-hydra-key? #t] [#:use-substitutes? #t] @
[#:extra-options '()]
@ -5886,11 +5886,11 @@ Finally, @var{extra-options} is a list of additional command-line options
passed to @command{guix-daemon}.
@end deffn
@deffn {Monadic Procedure} udev-service [#:udev udev]
@deffn {Scheme Procedure} udev-service [#:udev udev]
Run @var{udev}, which populates the @file{/dev} directory dynamically.
@end deffn
@deffn {Monadic Procedure} console-keymap-service @var{file}
@deffn {Scheme Procedure} console-keymap-service @var{file}
Return a service to load console keymap from @var{file} using
@command{loadkeys} command.
@end deffn
@ -5903,12 +5903,12 @@ The @code{(gnu services networking)} module provides services to configure
the network interface.
@cindex DHCP, networking service
@deffn {Monadic Procedure} dhcp-client-service [#:dhcp @var{isc-dhcp}]
@deffn {Scheme Procedure} dhcp-client-service [#:dhcp @var{isc-dhcp}]
Return a service that runs @var{dhcp}, a Dynamic Host Configuration
Protocol (DHCP) client, on all the non-loopback network interfaces.
@end deffn
@deffn {Monadic Procedure} static-networking-service @var{interface} @var{ip} @
@deffn {Scheme Procedure} static-networking-service @var{interface} @var{ip} @
[#:gateway #f] [#:name-services @code{'()}]
Return a service that starts @var{interface} with address @var{ip}. If
@var{gateway} is true, it must be a string specifying the default network
@ -5916,12 +5916,12 @@ gateway.
@end deffn
@cindex wicd
@deffn {Monadic Procedure} wicd-service [#:wicd @var{wicd}]
@deffn {Scheme Procedure} wicd-service [#:wicd @var{wicd}]
Return a service that runs @url{https://launchpad.net/wicd,Wicd}, a
network manager that aims to simplify wired and wireless networking.
@end deffn
@deffn {Monadic Procedure} ntp-service [#:ntp @var{ntp}] @
@deffn {Scheme Procedure} ntp-service [#:ntp @var{ntp}] @
[#:name-service @var{%ntp-servers}]
Return a service that runs the daemon from @var{ntp}, the
@uref{http://www.ntp.org, Network Time Protocol package}. The daemon will
@ -5932,14 +5932,14 @@ keep the system clock synchronized with that of @var{servers}.
List of host names used as the default NTP servers.
@end defvr
@deffn {Monadic Procedure} tor-service [#:tor tor]
@deffn {Scheme Procedure} tor-service [#:tor tor]
Return a service to run the @uref{https://torproject.org,Tor} daemon.
The daemon runs with the default settings (in particular the default exit
policy) as the @code{tor} unprivileged user.
@end deffn
@deffn {Monadic Procedure} bitlbee-service [#:bitlbee bitlbee] @
@deffn {Scheme Procedure} bitlbee-service [#:bitlbee bitlbee] @
[#:interface "127.0.0.1"] [#:port 6667] @
[#:extra-settings ""]
Return a service that runs @url{http://bitlbee.org,BitlBee}, a daemon that
@ -5956,7 +5956,7 @@ configuration file.
Furthermore, @code{(gnu services ssh)} provides the following service.
@deffn {Monadic Procedure} lsh-service [#:host-key "/etc/lsh/host-key"] @
@deffn {Scheme Procedure} lsh-service [#:host-key "/etc/lsh/host-key"] @
[#:daemonic? #t] [#:interfaces '()] [#:port-number 22] @
[#:allow-empty-passwords? #f] [#:root-login? #f] @
[#:syslog-output? #t] [#:x11-forwarding? #t] @
@ -6023,7 +6023,7 @@ browsers, from accessing Facebook.
The @code{(gnu services avahi)} provides the following definition.
@deffn {Monadic Procedure} avahi-service [#:avahi @var{avahi}] @
@deffn {Scheme Procedure} avahi-service [#:avahi @var{avahi}] @
[#:host-name #f] [#:publish? #t] [#:ipv4? #t] @
[#:ipv6? #t] [#:wide-area? #f] @
[#:domains-to-browse '()]
@ -6053,7 +6053,7 @@ Xorg---is provided by the @code{(gnu services xorg)} module. Note that
there is no @code{xorg-service} procedure. Instead, the X server is
started by the @dfn{login manager}, currently SLiM.
@deffn {Monadic Procedure} slim-service [#:allow-empty-passwords? #f] @
@deffn {Scheme Procedure} slim-service [#:allow-empty-passwords? #f] @
[#:auto-login? #f] [#:default-user ""] [#:startx] @
[#:theme @var{%default-slim-theme}] @
[#:theme-name @var{%default-slim-theme-name}]
@ -6089,7 +6089,7 @@ theme.
The G-Expression denoting the default SLiM theme and its name.
@end defvr
@deffn {Monadic Procedure} xorg-start-command [#:guile] @
@deffn {Scheme Procedure} xorg-start-command [#:guile] @
[#:configuration-file #f] [#:xorg-server @var{xorg-server}]
Return a derivation that builds a @var{guile} script to start the X server
from @var{xorg-server}. @var{configuration-file} is the server configuration
@ -6099,7 +6099,7 @@ file or a derivation that builds it; when omitted, the result of
Usually the X server is started by a login manager.
@end deffn
@deffn {Monadic Procedure} xorg-configuration-file @
@deffn {Scheme Procedure} xorg-configuration-file @
[#:drivers '()] [#:resolutions '()] [#:extra-config '()]
Return a configuration file for the Xorg server containing search paths for
all the common drivers.
@ -6150,7 +6150,7 @@ Reference, @code{services}}).
The actual service definitions provided by @code{(gnu services desktop)}
are described below.
@deffn {Monadic Procedure} dbus-service @var{services} @
@deffn {Scheme Procedure} dbus-service @var{services} @
[#:dbus @var{dbus}]
Return a service that runs the ``system bus'', using @var{dbus}, with
support for @var{services}.
@ -6165,7 +6165,7 @@ and policy files. For example, to allow avahi-daemon to use the system bus,
@var{services} must be equal to @code{(list avahi)}.
@end deffn
@deffn {Monadic Procedure} elogind-service @
@deffn {Scheme Procedure} elogind-service @
[#:elogind @var{elogind}] [#:config @var{config}]
Return a service that runs the @code{elogind} login and
seat management daemon. @uref{https://github.com/andywingo/elogind,
@ -6236,7 +6236,7 @@ their default values are:
@end table
@end deffn
@deffn {Monadic Procedure} polkit-service @
@deffn {Scheme Procedure} polkit-service @
[#:polkit @var{polkit}]
Return a service that runs the Polkit privilege manager.
@uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit} allows
@ -6246,7 +6246,7 @@ whose session is active to shut down the machine, if there are no other
users active.
@end deffn
@deffn {Monadic Procedure} upower-service [#:upower @var{upower}] @
@deffn {Scheme Procedure} upower-service [#:upower @var{upower}] @
[#:watts-up-pro? #f] @
[#:poll-batteries? #t] @
[#:ignore-lid? #f] @
@ -6265,7 +6265,7 @@ levels, with the given configuration settings. It implements the
GNOME.
@end deffn
@deffn {Monadic Procedure} colord-service [#:colord @var{colord}]
@deffn {Scheme Procedure} colord-service [#:colord @var{colord}]
Return a service that runs @command{colord}, a system service with a D-Bus
interface to manage the color profiles of input and output devices such as
screens and scanners. It is notably used by the GNOME Color Manager graphical
@ -6293,7 +6293,7 @@ Firefox and Epiphany both query the user before allowing a web page to
know the user's location.
@end defvr
@deffn {Monadic Procedure} geoclue-service [#:colord @var{colord}] @
@deffn {Scheme Procedure} geoclue-service [#:colord @var{colord}] @
[#:whitelist '()] @
[#:wifi-geolocation-url "https://location.services.mozilla.com/v1/geolocate?key=geoclue"] @
[#:submit-data? #f]
@ -6313,7 +6313,7 @@ web site} for more information.
The @code{(gnu services databases)} module provides the following service.
@deffn {Monadic Procedure} postgresql-service [#:postgresql postgresql] @
@deffn {Scheme Procedure} postgresql-service [#:postgresql postgresql] @
[#:config-file] [#:data-directory ``/var/lib/postgresql/data'']
Return a service that runs @var{postgresql}, the PostgreSQL database
server.
@ -6328,7 +6328,7 @@ The PostgreSQL daemon loads its runtime configuration from
The @code{(gnu services web)} module provides the following service:
@deffn {Monadic Procedure} nginx-service [#:nginx nginx] @
@deffn {Scheme Procedure} nginx-service [#:nginx nginx] @
[#:log-directory ``/var/log/nginx''] @
[#:run-directory ``/var/run/nginx''] @
[#:config-file]
@ -6348,7 +6348,7 @@ directories are created when the service is activated.
The @code{(gnu services lirc)} module provides the following service.
@deffn {Monadic Procedure} lirc-service [#:lirc lirc] @
@deffn {Scheme Procedure} lirc-service [#:lirc lirc] @
[#:device #f] [#:driver #f] [#:config-file #f] @
[#:extra-options '()]
Return a service that runs @url{http://www.lirc.org,LIRC}, a daemon that
@ -6521,13 +6521,11 @@ configuration file:
(define %my-base-services
;; Replace the default nscd service with one that knows
;; about nss-mdns.
(map (lambda (mservice)
;; "Bind" the MSERVICE monadic value to inspect it.
(mlet %store-monad ((service mservice))
(map (lambda (service)
(if (member 'nscd (service-provision service))
(nscd-service (nscd-configuration)
#:name-services (list nss-mdns))
mservice)))
service))
%base-services))
@end example

View File

@ -21,7 +21,6 @@
#:use-module (gnu system shadow)
#:use-module (gnu packages avahi)
#:use-module (gnu packages admin)
#:use-module (guix monads)
#:use-module (guix store)
#:use-module (guix gexp)
#:export (avahi-service))
@ -39,7 +38,7 @@
(define (bool value)
(if value "yes\n" "no\n"))
(text-file "avahi-daemon.conf"
(plain-file "avahi-daemon.conf"
(string-append
"[server]\n"
(if host-name
@ -76,14 +75,13 @@ 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
(let ((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))
@ -107,6 +105,6 @@ sockets."
(comment "Avahi daemon user")
(home-directory "/var/empty")
(shell
#~(string-append #$shadow "/sbin/nologin")))))))))
#~(string-append #$shadow "/sbin/nologin"))))))))
;;; avahi.scm ends here

View File

@ -35,7 +35,6 @@
#:use-module ((gnu build file-systems)
#:select (mount-flags->bit-mask))
#:use-module (guix gexp)
#:use-module (guix monads)
#:use-module (guix records)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
@ -80,8 +79,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."
(with-monad %store-monad
(return
(service
(documentation "Take care of the root file system.")
(provision '(root-file-system))
@ -114,7 +111,7 @@ This service must be the root of the service dependency graph so that its
#:update-mtab? #f)
#f)))))
(respawn? #f)))))
(respawn? #f)))
(define* (file-system-service device target type
#:key (flags '()) (check? #t)
@ -127,8 +124,6 @@ true, check the file system before mounting it. When CREATE-MOUNT-POINT? is
true, create TARGET if it does not exist yet. FLAGS is a list of symbols,
such as 'read-only' etc. Optionally, REQUIREMENTS may be a list of service
names such as device-mapping services."
(with-monad %store-monad
(return
(service
(provision (list (symbol-append 'file-system- (string->symbol target))))
(requirement `(root-file-system ,@requirements))
@ -169,13 +164,11 @@ names such as device-mapping services."
(chdir "/")
(umount #$target)
#f))))))
#f))))
(define (user-unmount-service known-mount-points)
"Return a service whose sole purpose is to unmount file systems not listed
in KNOWN-MOUNT-POINTS when it is stopped."
(with-monad %store-monad
(return
(service
(documentation "Unmount manually-mounted file systems.")
(provision '(user-unmount))
@ -199,7 +192,7 @@ in KNOWN-MOUNT-POINTS when it is stopped."
(format #t "failed to unmount '~a': ~a~%"
mount-point (strerror errno))))))
(filter (negate known?) (mount-points)))
#f))))))
#f))))
(define %do-not-kill-file
;; Name of the file listing PIDs of processes that must survive when halting
@ -217,8 +210,7 @@ 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
(service
(documentation "When stopped, terminate all user processes.")
(provision '(user-processes))
(requirement (cons 'root-file-system requirements))
@ -286,17 +278,16 @@ stopped before 'kill' is called."
(display "all processes have been terminated\n")
#f))
(respawn? #f)))))
(respawn? #f)))
(define (host-name-service name)
"Return a service that sets the host name to @var{name}."
(with-monad %store-monad
(return (service
(service
(documentation "Initialize the machine's host name.")
(provision '(host-name))
(start #~(lambda _
(sethostname #$name)))
(respawn? #f)))))
(respawn? #f)))
(define (unicode-start tty)
"Return a gexp to start Unicode support on @var{tty}."
@ -318,16 +309,13 @@ stopped before 'kill' is called."
(define (console-keymap-service file)
"Return a service to load console keymap from @var{file}."
(with-monad %store-monad
(return
(service
(documentation
(string-append "Load console keymap (loadkeys)."))
(documentation (string-append "Load console keymap (loadkeys)."))
(provision '(console-keymap))
(start #~(lambda _
(zero? (system* (string-append #$kbd "/bin/loadkeys")
#$file))))
(respawn? #f)))))
(respawn? #f)))
(define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
"Return a service that sets up Unicode support in @var{tty} and loads
@ -336,8 +324,7 @@ stopped before 'kill' is called."
;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
;; codepoints notably found in the UTF-8 manual.
(let ((device (string-append "/dev/" tty)))
(with-monad %store-monad
(return (service
(service
(documentation "Load a Unicode console font.")
(provision (list (symbol-append 'console-font-
(string->symbol tty))))
@ -353,7 +340,7 @@ stopped before 'kill' is called."
(system* (string-append #$kbd "/bin/setfont")
"-C" #$device #$font)))))
(stop #~(const #t))
(respawn? #f))))))
(respawn? #f))))
(define* (mingetty-service tty
#:key
@ -379,8 +366,6 @@ of the log-in program (the default is the @code{login} program from the Shadow
tool suite.)
@var{motd} is a file-like object to use as the ``message of the day''."
(with-monad %store-monad
(return
(service
(documentation (string-append "Run mingetty on " tty "."))
(provision (list (symbol-append 'term- (string->symbol tty))))
@ -410,7 +395,7 @@ tool suite.)
;; duplicates are removed.
(list (unix-pam-service "login"
#:allow-empty-passwords? allow-empty-passwords?
#:motd motd)))))))
#:motd motd)))))
(define-record-type* <nscd-configuration> nscd-configuration
make-nscd-configuration
@ -496,7 +481,7 @@ tool suite.)
(match config
(($ <nscd-configuration> log-file debug-level caches)
(text-file "nscd.conf"
(plain-file "nscd.conf"
(string-append "\
# Configuration of libc's name service cache daemon (nscd).\n\n"
(if log-file
@ -518,8 +503,8 @@ tool suite.)
given @var{config}---an @code{<nscd-configuration>} object. Optionally,
@code{#:name-services} is a list of packages that provide name service switch
(NSS) modules needed by nscd. @xref{Name Service Switch}, for an example."
(mlet %store-monad ((nscd.conf (nscd.conf-file config)))
(return (service
(let ((nscd.conf (nscd.conf-file config)))
(service
(documentation "Run libc's name service cache daemon (nscd).")
(provision '(nscd))
(requirement '(user-processes))
@ -542,15 +527,11 @@ given @var{config}---an @code{<nscd-configuration>} object. Optionally,
":")))))
(stop #~(make-kill-destructor))
(respawn? #f)))))
(define* (syslog-service #:key config-file)
"Return a service that runs @code{syslogd}.
If configuration file name @var{config-file} is not specified, use some
reasonable default settings."
(respawn? #f))))
;; Snippet adapted from the GNU inetutils manual.
(define contents "
(define %default-syslog.conf
(plain-file "syslog.conf" "
# Log all error messages, authentication messages of
# level notice or higher and anything of level err or
# higher to the console.
@ -569,20 +550,19 @@ reasonable default settings."
# Log all the mail messages in one place.
mail.* /var/log/maillog
")
(mlet %store-monad
((syslog.conf (text-file "syslog.conf" contents)))
(return
"))
(define* (syslog-service #:key (config-file %default-syslog.conf))
"Return a service that runs @code{syslogd}.
If configuration file name @var{config-file} is not specified, use some
reasonable default settings."
(service
(documentation "Run the syslog daemon (syslogd).")
(provision '(syslogd))
(requirement '(user-processes))
(start
#~(make-forkexec-constructor
(start #~(make-forkexec-constructor
(list (string-append #$inetutils "/libexec/syslogd")
"--no-detach" "--rcfile" #$(or config-file syslog.conf))))
(stop #~(make-kill-destructor))))))
"--no-detach" "--rcfile" #$config-file)))
(stop #~(make-kill-destructor))))
(define* (guix-build-accounts count #:key
(group "guixbuild")
@ -658,8 +638,7 @@ passed to @command{guix-daemon}."
(and authorize-hydra-key?
(hydra-key-authorization guix)))
(with-monad %store-monad
(return (service
(service
(documentation "Run the Guix daemon.")
(provision '(guix-daemon))
(requirement '(user-processes))
@ -675,8 +654,7 @@ passed to @command{guix-daemon}."
;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the
;; daemon's $PATH.
#:environment-variables
(list (string-append "PATH=" #$lsof "/bin:"
#$lsh "/bin"))))
(list (string-append "PATH=" #$lsof "/bin:" #$lsh "/bin"))))
(stop #~(make-kill-destructor))
(user-accounts (guix-build-accounts build-accounts
#:group builder-group))
@ -687,7 +665,7 @@ passed to @command{guix-daemon}."
;; Use a fixed GID so that we can create the
;; store with the right owner.
(id 30000))))
(activate activate)))))
(activate activate)))
(define (udev-rules-union packages)
"Return the union of the @code{lib/udev/rules.d} directories found in each
@ -712,17 +690,16 @@ item of @var{packages}."
(union-build (string-append #$output "/lib/udev/rules.d")
(filter-map rules-sub-directory '#$packages))))
(gexp->derivation "udev-rules" build
(computed-file "udev-rules" build
#:modules '((guix build union)
(guix build utils))
#:local-build? #t))
(guix build utils))))
(define* (kvm-udev-rule)
"Return a directory with a udev rule that changes the group of
@file{/dev/kvm} to \"kvm\" and makes it #o660."
;; Apparently QEMU-KVM used to ship this rule, but now we have to add it by
;; ourselves.
(gexp->derivation "kvm-udev-rules"
(computed-file "kvm-udev-rules"
#~(begin
(use-modules (guix build utils))
@ -743,16 +720,20 @@ KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n" port))))
(define* (udev-service #:key (udev eudev) (rules '()))
"Run @var{udev}, which populates the @file{/dev} directory dynamically. Get
extra rules from the packages listed in @var{rules}."
(mlet* %store-monad ((kvm (kvm-udev-rule))
(rules (udev-rules-union (cons* udev kvm rules)))
(udev.conf (text-file* "udev.conf"
"udev_rules=\"" rules
"/lib/udev/rules.d\"\n")))
(return (service
(let* ((rules (udev-rules-union (cons* udev
(kvm-udev-rule)
rules)))
(udev.conf (computed-file "udev.conf"
#~(call-with-output-file #$output
(lambda (port)
(format port
"udev_rules=\"~a/lib/udev/rules.d\"\n"
#$rules))))))
(service
(provision '(udev))
;; Udev needs /dev to be a 'devtmpfs' mount so that new device
;; nodes can be added: see
;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
;; be added: see
;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
(requirement '(root-file-system))
@ -815,21 +796,19 @@ extra rules from the packages listed in @var{rules}."
;; When halting the system, 'udev' is actually killed by
;; 'user-processes', i.e., before its own 'stop' method was
;; called. Thus, make sure it is not respawned.
(respawn? #f)))))
(respawn? #f))))
(define (device-mapping-service target open close)
"Return a service that maps device @var{target}, a string such as
@code{\"home\"} (meaning @code{/dev/mapper/home}). Evaluate @var{open}, a
gexp, to open it, and evaluate @var{close} to close it."
(with-monad %store-monad
(return (service
(provision (list (symbol-append 'device-mapping-
(string->symbol target))))
(service
(provision (list (symbol-append 'device-mapping- (string->symbol target))))
(requirement '(udev))
(documentation "Map a device node using Linux's device mapper.")
(start #~(lambda () #$open))
(stop #~(lambda _ (not #$close)))
(respawn? #f)))))
(respawn? #f)))
(define (swap-service device)
"Return a service that uses @var{device} as a swap device."
@ -839,8 +818,7 @@ gexp, to open it, and evaluate @var{close} to close it."
(string->symbol (basename device))))
'()))
(with-monad %store-monad
(return (service
(service
(provision (list (symbol-append 'swap- (string->symbol device))))
(requirement `(udev ,@requirement))
(documentation "Enable the given swap device.")
@ -850,7 +828,7 @@ gexp, to open it, and evaluate @var{close} to close it."
(stop #~(lambda _
(restart-on-EINTR (swapoff #$device))
#f))
(respawn? #f)))))
(respawn? #f)))
(define %base-services
;; Convenience variable holding the basic services.

View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -22,7 +23,6 @@
#:use-module (gnu packages admin)
#:use-module (gnu packages databases)
#:use-module (guix records)
#:use-module (guix monads)
#:use-module (guix store)
#:use-module (guix gexp)
#:export (postgresql-service))
@ -34,23 +34,20 @@
;;; Code:
(define %default-postgres-hba
(text-file "pg_hba.conf"
(plain-file "pg_hba.conf"
"
local all all trust
host all all 127.0.0.1/32 trust
host all all ::1/128 trust"))
(define %default-postgres-ident
(text-file "pg_ident.conf"
(plain-file "pg_ident.conf"
"# MAPNAME SYSTEM-USERNAME PG-USERNAME"))
(define %default-postgres-config
(mlet %store-monad ((hba %default-postgres-hba)
(ident %default-postgres-ident))
(text-file* "postgresql.conf"
;; The daemon will not start without these.
"hba_file = '" hba "'\n"
"ident_file = '" ident "'\n")))
(mixed-text-file "postgresql.conf"
"hba_file = '" %default-postgres-hba "'\n"
"ident_file = '" %default-postgres-ident "\n"))
(define* (postgresql-service #:key (postgresql postgresql)
(config-file %default-postgres-config)
@ -62,8 +59,7 @@ and stores the database cluster in @var{data-directory}."
;; Wrapper script that switches to the 'postgres' user before launching
;; daemon.
(define start-script
(mlet %store-monad ((config-file config-file))
(gexp->script "start-postgres"
(program-file "start-postgres"
#~(let ((user (getpwnam "postgres"))
(postgres (string-append #$postgresql
"/bin/postgres")))
@ -71,7 +67,7 @@ and stores the database cluster in @var{data-directory}."
(setuid (passwd:uid user))
(system* postgres
(string-append "--config-file=" #$config-file)
"-D" #$data-directory)))))
"-D" #$data-directory))))
(define activate
#~(begin
@ -99,8 +95,6 @@ and stores the database cluster in @var{data-directory}."
(primitive-exit 1))))
(pid (waitpid pid))))))
(mlet %store-monad ((start-script start-script))
(return
(service
(provision '(postgres))
(documentation "Run the PostgreSQL daemon.")
@ -118,4 +112,4 @@ and stores the database cluster in @var{data-directory}."
(comment "PostgreSQL server user")
(home-directory "/var/empty")
(shell
#~(string-append #$shadow "/sbin/nologin")))))))))
#~(string-append #$shadow "/sbin/nologin")))))))

View File

@ -35,7 +35,6 @@
#:use-module (gnu packages polkit)
#:use-module ((gnu packages linux)
#:select (lvm2 fuse alsa-utils crda))
#:use-module (guix monads)
#:use-module (guix records)
#:use-module (guix store)
#:use-module (guix gexp)
@ -104,7 +103,7 @@
(sxml->xml (services->sxml (list #$@services))
port)))))
(gexp->derivation "dbus-configuration" build))
(computed-file "dbus-configuration" build))
(define* (dbus-service services #:key (dbus dbus))
"Return a service that runs the \"system bus\", using @var{dbus}, with
@ -118,8 +117,7 @@ be notified of system-wide events.
@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
(let ((conf (dbus-configuration-directory dbus services)))
(service
(documentation "Run the D-Bus system daemon.")
(provision '(dbus-system))
@ -161,7 +159,7 @@ and policy files. For example, to allow avahi-daemon to use the system bus,
(close-fdes 1)
(dup2 (port->fdes port) 1)
(execl prog)))
(waitpid pid)))))))))))
(waitpid pid))))))))))
;;;
@ -175,7 +173,7 @@ and policy files. For example, to allow avahi-daemon to use the system bus,
time-critical time-action
critical-power-action)
"Return an upower-daemon configuration file."
(text-file "UPower.conf"
(plain-file "UPower.conf"
(string-append
"[UPower]\n"
"EnableWattsUpPro=" (bool watts-up-pro?)
@ -210,7 +208,7 @@ and policy files. For example, to allow avahi-daemon to use the system bus,
@command{upowerd}}, a system-wide monitor for power consumption and battery
levels, with the given configuration settings. It implements the
@code{org.freedesktop.UPower} D-Bus interface, and is notably used by GNOME."
(mlet %store-monad ((config (upower-configuration-file
(let ((config (upower-configuration-file
#:watts-up-pro? watts-up-pro?
#:poll-batteries? poll-batteries?
#:ignore-lid? ignore-lid?
@ -222,7 +220,6 @@ levels, with the given configuration settings. It implements the
#:time-critical time-critical
#:time-action time-action
#:critical-power-action critical-power-action)))
(return
(service
(documentation "Run the UPower power and battery monitor.")
(provision '(upower-daemon))
@ -250,7 +247,7 @@ levels, with the given configuration settings. It implements the
(comment "UPower daemon user")
(home-directory "/var/empty")
(shell
#~(string-append #$shadow "/sbin/nologin")))))))))
#~(string-append #$shadow "/sbin/nologin"))))))))
;;;
@ -263,8 +260,6 @@ interface to manage the color profiles of input and output devices such as
screens and scanners. It is notably used by the GNOME Color Manager graphical
tool. See @uref{http://www.freedesktop.org/software/colord/, the colord web
site} for more information."
(with-monad %store-monad
(return
(service
(documentation "Run the colord color management service.")
(provision '(colord-daemon))
@ -290,7 +285,7 @@ site} for more information."
(comment "colord daemon user")
(home-directory "/var/empty")
(shell
#~(string-append #$shadow "/sbin/nologin")))))))))
#~(string-append #$shadow "/sbin/nologin")))))))
;;;
@ -321,7 +316,7 @@ users are allowed."
wifi-submission-url submission-nick
applications)
"Return a geoclue configuration file."
(text-file "geoclue.conf"
(plain-file "geoclue.conf"
(string-append
"[agent]\n"
"whitelist=" (string-join whitelist ";") "\n"
@ -350,14 +345,13 @@ and Epiphany web browsers are able to ask for the user's location, and in the
case of Icecat and Epiphany, both will ask the user for permission first. See
@uref{https://wiki.freedesktop.org/www/Software/GeoClue/, the geoclue web
site} for more information."
(mlet %store-monad ((config (geoclue-configuration-file
(let ((config (geoclue-configuration-file
#:whitelist whitelist
#:wifi-geolocation-url wifi-geolocation-url
#:submit-data? submit-data?
#:wifi-submission-url wifi-submission-url
#:submission-nick submission-nick
#:applications applications)))
(return
(service
(documentation "Run the GeoClue location service.")
(provision '(geoclue-daemon))
@ -380,7 +374,7 @@ site} for more information."
(comment "GeoClue daemon user")
(home-directory "/var/empty")
(shell
"/run/current-system/profile/sbin/nologin"))))))))
"/run/current-system/profile/sbin/nologin")))))))
;;;
@ -393,8 +387,6 @@ service. By querying the @command{polkit} service, a privileged system
component can know when it should grant additional capabilities to ordinary
users. For example, an ordinary user can be granted the capability to suspend
the system if the user is logged in locally."
(with-monad %store-monad
(return
(service
(documentation "Run the polkit privilege management service.")
(provision '(polkit-daemon))
@ -416,7 +408,7 @@ the system if the user is logged in locally."
(shell
"/run/current-system/profile/sbin/nologin"))))
(pam-services (list (unix-pam-service "polkit-1")))))))
(pam-services (list (unix-pam-service "polkit-1")))))
;;;
@ -520,7 +512,7 @@ the system if the user is logged in locally."
((_ config str)
(string-append str "\n"))))
(define-syntax-rule (ini-file config file clause ...)
(text-file file (string-append (ini-file-clause config clause) ...)))
(plain-file file (string-append (ini-file-clause config clause) ...)))
(ini-file
config "logind.conf"
"[Login]"
@ -562,8 +554,7 @@ service. The @command{elogind} service integrates with PAM to allow other
system components to know the set of logged-in users as well as their session
types (graphical, console, remote, etc.). It can also clean up after users
when they log out."
(mlet %store-monad ((config-file (elogind-configuration-file config)))
(return
(let ((config-file (elogind-configuration-file config)))
(service
(documentation "Run the elogind login and seat management service.")
(provision '(elogind))
@ -573,7 +564,7 @@ when they log out."
(list (string-append #$elogind "/libexec/elogind/elogind"))
#:environment-variables
(list (string-append "ELOGIND_CONF_FILE=" #$config-file))))
(stop #~(make-kill-destructor))))))
(stop #~(make-kill-destructor)))))
;;;
@ -599,8 +590,7 @@ when they log out."
(ntp-service)
(map (lambda (mservice)
(mlet %store-monad ((service mservice))
(map (lambda (service)
(cond
;; Provide an nscd ready to use nss-mdns.
((memq 'nscd (service-provision service))
@ -617,7 +607,7 @@ when they log out."
(list lvm2 fuse alsa-utils crda
upower colord elogind)))
(else mservice))))
(else service)))
%base-services)))
;;; desktop.scm ends here

View File

@ -19,7 +19,6 @@
(define-module (gnu services lirc)
#:use-module (gnu services)
#:use-module (gnu packages lirc)
#:use-module (guix monads)
#:use-module (guix store)
#:use-module (guix gexp)
#:export (lirc-service))
@ -41,8 +40,6 @@ The daemon will use specified @var{device}, @var{driver} and
Finally, @var{extra-options} is a list of additional command-line options
passed to @command{lircd}."
(with-monad %store-monad
(return
(service
(provision '(lircd))
(documentation "Run the LIRC daemon.")
@ -63,6 +60,6 @@ passed to @command{lircd}."
(stop #~(make-kill-destructor))
(activate #~(begin
(use-modules (guix build utils))
(mkdir-p "/var/run/lirc")))))))
(mkdir-p "/var/run/lirc")))))
;;; lirc.scm ends here

View File

@ -28,7 +28,6 @@
#:use-module (gnu packages wicd)
#:use-module (guix gexp)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (srfi srfi-26)
#:export (%facebook-host-aliases
static-networking-service
@ -93,8 +92,6 @@ gateway."
;; TODO: Eventually replace 'route' with bindings for the appropriate
;; ioctls.
(with-monad %store-monad
(return
(service
;; Unless we're providing the loopback interface, wait for udev to be up
@ -140,7 +137,7 @@ gateway."
"/sbin/route")
"del" "-net" "default")
#t))))
(respawn? #f)))))
(respawn? #f)))
(define* (dhcp-client-service #:key (dhcp isc-dhcp))
"Return a service that runs @var{dhcp}, a Dynamic Host Configuration
@ -152,31 +149,28 @@ Protocol (DHCP) client, on all the non-loopback network interfaces."
(define pid-file
"/var/run/dhclient.pid")
(with-monad %store-monad
(return (service
(service
(documentation "Set up networking via DHCP.")
(requirement '(user-processes udev))
;; XXX: Running with '-nw' ("no wait") avoids blocking for a
;; minute when networking is unavailable, but also means that the
;; interface is not up yet when 'start' completes. To wait for
;; the interface to be ready, one should instead monitor udev
;; events.
;; XXX: Running with '-nw' ("no wait") avoids blocking for a minute when
;; networking is unavailable, but also means that the interface is not up
;; yet when 'start' completes. To wait for the interface to be ready, one
;; should instead monitor udev events.
(provision '(networking))
(start #~(lambda _
;; When invoked without any arguments, 'dhclient'
;; discovers all non-loopback interfaces *that are
;; up*. However, the relevant interfaces are
;; typically down at this point. Thus we perform our
;; own interface discovery here.
;; When invoked without any arguments, 'dhclient' discovers all
;; non-loopback interfaces *that are up*. However, the relevant
;; interfaces are typically down at this point. Thus we perform
;; our own interface discovery here.
(define valid?
(negate loopback-network-interface?))
(define ifaces
(filter valid? (all-network-interface-names)))
;; XXX: Make sure the interfaces are up so that
;; 'dhclient' can actually send/receive over them.
;; XXX: Make sure the interfaces are up so that 'dhclient' can
;; actually send/receive over them.
(for-each set-network-interface-up ifaces)
(false-if-exception (delete-file #$pid-file))
@ -189,15 +183,15 @@ Protocol (DHCP) client, on all the non-loopback network interfaces."
(lambda ()
(call-with-input-file #$pid-file read))
(lambda args
;; 'dhclient' returned before PID-FILE
;; was created, so try again.
;; 'dhclient' returned before PID-FILE was created,
;; so try again.
(let ((errno (system-error-errno args)))
(if (= ENOENT errno)
(begin
(sleep 1)
(loop))
(apply throw args))))))))))
(stop #~(make-kill-destructor))))))
(stop #~(make-kill-destructor))))
(define %ntp-servers
;; Default set of NTP servers.
@ -227,8 +221,7 @@ restrict -6 default kod nomodify notrap nopeer noquery
restrict 127.0.0.1
restrict -6 ::1\n"))
(mlet %store-monad ((ntpd.conf (text-file "ntpd.conf" config)))
(return
(let ((ntpd.conf (plain-file "ntpd.conf" config)))
(service
(provision '(ntpd))
(documentation "Run the Network Time Protocol (NTP) daemon.")
@ -245,15 +238,14 @@ restrict -6 ::1\n"))
(comment "NTP daemon user")
(home-directory "/var/empty")
(shell
#~(string-append #$shadow "/sbin/nologin")))))))))
#~(string-append #$shadow "/sbin/nologin"))))))))
(define* (tor-service #:key (tor tor))
"Return a service to run the @uref{https://torproject.org,Tor} daemon.
The daemon runs with the default settings (in particular the default exit
policy) as the @code{tor} unprivileged user."
(mlet %store-monad ((torrc (text-file "torrc" "User tor\n")))
(return
(let ((torrc (plain-file "torrc" "User tor\n")))
(service
(provision '(tor))
@ -277,7 +269,7 @@ policy) as the @code{tor} unprivileged user."
(shell
#~(string-append #$shadow "/sbin/nologin")))))
(documentation "Run the Tor anonymous network overlay.")))))
(documentation "Run the Tor anonymous network overlay."))))
(define* (bitlbee-service #:key (bitlbee bitlbee)
(interface "127.0.0.1") (port 6667)
@ -292,7 +284,7 @@ come from any networking interface.
In addition, @var{extra-settings} specifies a string to append to the
configuration file."
(mlet %store-monad ((conf (text-file "bitlbee.conf"
(let ((conf (plain-file "bitlbee.conf"
(string-append "
[settings]
User = bitlbee
@ -300,7 +292,6 @@ configuration file."
DaemonInterface = " interface "
DaemonPort = " (number->string port) "
" extra-settings))))
(return
(service
(provision '(bitlbee))
(requirement '(user-processes loopback))
@ -324,13 +315,11 @@ configuration file."
(comment "BitlBee daemon user")
(home-directory "/var/empty")
(shell #~(string-append #$shadow
"/sbin/nologin")))))))))
"/sbin/nologin"))))))))
(define* (wicd-service #:key (wicd wicd))
"Return a service that runs @url{https://launchpad.net/wicd,Wicd}, a network
manager that aims to simplify wired and wireless networking."
(with-monad %store-monad
(return
(service
(documentation "Run the Wicd network manager.")
(provision '(networking))
@ -346,6 +335,6 @@ manager that aims to simplify wired and wireless networking."
(let ((file-name "/etc/wicd/dhclient.conf.template.default"))
(unless (file-exists? file-name)
(copy-file (string-append #$wicd file-name)
file-name)))))))))
file-name)))))))
;;; networking.scm ends here

View File

@ -19,7 +19,6 @@
(define-module (gnu services ssh)
#:use-module (guix gexp)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (gnu services)
#:use-module (gnu system linux) ; 'pam-service'
#:use-module (gnu packages lsh)
@ -152,8 +151,7 @@ The other options should be self-descriptive."
'(networking syslogd)
'(networking)))
(with-monad %store-monad
(return (service
(service
(documentation "GNU lsh SSH server")
(provision '(ssh-daemon))
(requirement requires)
@ -168,6 +166,6 @@ The other options should be self-descriptive."
(mkdir-p "/var/spool/lsh")
#$(if initialize?
(activation lsh host-key)
#t)))))))
#t)))))
;;; ssh.scm ends here

View File

@ -22,7 +22,6 @@
#:use-module (gnu packages admin)
#:use-module (gnu packages web)
#:use-module (guix records)
#:use-module (guix monads)
#:use-module (guix store)
#:use-module (guix gexp)
#:export (nginx-service))
@ -76,8 +75,6 @@ files in LOG-DIRECTORY, and stores temporary runtime files in RUN-DIRECTORY."
(define nologin #~(string-append #$shadow "/sbin/nologin"))
;; TODO: Add 'reload' action.
(mbegin %store-monad
(return
(service
(provision '(nginx))
(documentation "Run the nginx daemon.")
@ -94,4 +91,4 @@ files in LOG-DIRECTORY, and stores temporary runtime files in RUN-DIRECTORY."
(system? #t)
(comment "nginx server user")
(home-directory "/var/empty")
(shell nologin))))))))
(shell nologin))))))

View File

@ -31,7 +31,6 @@
#:use-module (gnu packages bash)
#:use-module (guix gexp)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix derivations)
#:use-module (guix records)
#:use-module (srfi srfi-1)
@ -63,8 +62,8 @@ appropriate screen resolution; otherwise, it must be a list of
resolutions---e.g., @code{((1024 768) (640 480))}.
Last, @var{extra-config} is a list of strings or objects appended to the
@code{text-file*} argument list. It is used to pass extra text to be added
verbatim to the configuration file."
@code{mixed-text-file} argument list. It is used to pass extra text to be
added verbatim to the configuration file."
(define (device-section driver)
(string-append "
Section \"Device\"
@ -87,7 +86,7 @@ Section \"Screen\"
EndSubSection
EndSection"))
(apply text-file* "xserver.conf" "
(apply mixed-text-file "xserver.conf" "
Section \"Files\"
FontPath \"" font-adobe75dpi "/share/fonts/X11/75dpi\"
ModulePath \"" xf86-video-vesa "/lib/xorg/modules/drivers\"
@ -128,7 +127,7 @@ EndSection
(define* (xorg-start-command #:key
(guile (canonical-package guile-2.0))
configuration-file
(configuration-file (xorg-configuration-file))
(xorg-server xorg-server))
"Return a derivation that builds a @var{guile} script to start the X server
from @var{xorg-server}. @var{configuration-file} is the server configuration
@ -136,10 +135,7 @@ file or a derivation that builds it; when omitted, the result of
@code{xorg-configuration-file} is used.
Usually the X server is started by a login manager."
(mlet %store-monad ((config (if configuration-file
(return configuration-file)
(xorg-configuration-file))))
(define script
(define exp
;; Write a small wrapper around the X server.
#~(begin
(setenv "XORG_DRI_DRIVER_PATH" (string-append #$mesa "/lib/dri"))
@ -149,14 +145,14 @@ Usually the X server is started by a login manager."
(string-append #$xorg-server "/bin/X") ;argv[0]
"-logverbose" "-verbose"
"-xkbdir" (string-append #$xkeyboard-config "/share/X11/xkb")
"-config" #$config
"-config" #$configuration-file
"-nolisten" "tcp" "-terminate"
;; Note: SLiM and other display managers add the
;; '-auth' flag by themselves.
(cdr (command-line)))))
(gexp->script "start-xorg" script)))
(program-file "start-xorg" exp))
(define* (xinitrc #:key
(guile (canonical-package guile-2.0))
@ -200,7 +196,7 @@ which should be passed to this script as the first argument. If not, the
(exec-from-login-shell xsession-file session)
;; Otherwise, start the specified session.
(exec-from-login-shell session)))))
(gexp->script "xinitrc" builder))
(program-file "xinitrc" builder))
;;;
@ -224,7 +220,7 @@ which should be passed to this script as the first argument. If not, the
(xauth xauth) (dmd dmd) (bash bash)
(auto-login-session #~(string-append #$windowmaker
"/bin/wmaker"))
startx)
(startx (xorg-start-command)))
"Return a service that spawns the SLiM graphical login manager, which in
turn starts the X display server with @var{startx}, a command as returned by
@code{xorg-start-command}.
@ -251,13 +247,9 @@ If @var{theme} is @code{#f}, the use the default log-in theme; otherwise
theme to use. In that case, @var{theme-name} specifies the name of the
theme."
(define (slim.cfg)
(mlet %store-monad ((startx (if startx
(return startx)
(xorg-start-command)))
(xinitrc (xinitrc #:fallback-session
auto-login-session)))
(text-file* "slim.cfg" "
(define slim.cfg
(let ((xinitrc (xinitrc #:fallback-session auto-login-session)))
(mixed-text-file "slim.cfg" "
default_path /run/current-system/profile/bin
default_xserver " startx "
xserver_arguments :0 vt7
@ -271,8 +263,7 @@ sessiondir /run/current-system/profile/share/xsessions
session_msg session (F1 to change):
halt_cmd " dmd "/sbin/halt
reboot_cmd " dmd "/sbin/reboot
"
reboot_cmd " dmd "/sbin/reboot\n"
(if auto-login?
(string-append "auto_login yes\ndefault_user " default-user "\n")
"")
@ -280,8 +271,6 @@ reboot_cmd " dmd "/sbin/reboot
(string-append "current_theme " theme-name "\n")
""))))
(mlet %store-monad ((slim.cfg (slim.cfg)))
(return
(service
(documentation "Xorg display server")
(provision '(xorg-server))
@ -305,6 +294,6 @@ reboot_cmd " dmd "/sbin/reboot
;; Tell PAM about 'slim'.
(list (unix-pam-service
"slim"
#:allow-empty-passwords? allow-empty-passwords?)))))))
#:allow-empty-passwords? allow-empty-passwords?)))))
;;; xorg.scm ends here

View File

@ -244,7 +244,6 @@ as 'needed-for-boot'."
(string->symbol (mapped-device-target md))))
(device-mappings fs))))
(sequence %store-monad
(map (lambda (fs)
(match fs
(($ <file-system> device title target type flags opts
@ -256,7 +255,7 @@ as 'needed-for-boot'."
#:create-mount-point? create?
#:options opts
#:flags flags))))
file-systems)))
file-systems))
(define (mapped-device-user device file-systems)
"Return a file system among FILE-SYSTEMS that uses DEVICE, or #f."
@ -287,8 +286,7 @@ from the initrd."
devices)))
(define (device-mapping-services os)
"Return the list of device-mapping services for OS as a monadic list."
(sequence %store-monad
"Return the list of device-mapping services for OS as a list."
(map (lambda (md)
(let* ((source (mapped-device-source md))
(target (mapped-device-target md))
@ -298,12 +296,11 @@ from the initrd."
(device-mapping-service target
(open source target)
(close source target))))
(operating-system-user-mapped-devices os))))
(operating-system-user-mapped-devices os)))
(define (swap-services os)
"Return the list of swap services for OS as a monadic list."
(sequence %store-monad
(map swap-service (operating-system-swap-devices os))))
"Return the list of swap services for OS."
(map swap-service (operating-system-swap-devices os)))
(define (essential-services os)
"Return the list of essential services for OS. These are special services
@ -312,7 +309,7 @@ bookkeeping."
(define known-fs
(map file-system-mount-point (operating-system-file-systems os)))
(mlet* %store-monad ((mappings (device-mapping-services os))
(let* ((mappings (device-mapping-services os))
(root-fs (root-file-system-service))
(other-fs (other-file-system-services os))
(unmount (user-unmount-service known-fs))
@ -320,18 +317,15 @@ bookkeeping."
(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 unmount
(append other-fs mappings swaps)))))
(host-name (host-name-service (operating-system-host-name os))))
(cons* host-name procs root-fs unmount
(append other-fs mappings swaps))))
(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))))
(append (operating-system-user-services os)
(essential-services os)))
;;;
@ -420,8 +414,7 @@ settings for 'guix.el' to work out-of-the-box."
(define (user-shells os)
"Return the list of all the shells used by the accounts of OS. These may be
gexps or strings."
(mlet %store-monad ((accounts (operating-system-accounts os)))
(return (map user-account-shell accounts))))
(map user-account-shell (operating-system-accounts os)))
(define (shells-file shells)
"Return a derivation that builds a shell list for use as /etc/shells based
@ -577,9 +570,9 @@ fi\n"))
(operating-system-users os)
(cons %root-account (operating-system-users os))))
(mlet %store-monad ((services (operating-system-services os)))
(return (append users
(append-map service-user-accounts services)))))
(append users
(append-map service-user-accounts
(operating-system-services os))))
(define (maybe-string->file file-name thing)
"If THING is a string, return a <plain-file> with THING as its content.
@ -615,7 +608,7 @@ use 'plain-file' instead~%")
(define (operating-system-etc-directory os)
"Return that static part of the /etc directory of OS."
(mlet* %store-monad
((services (operating-system-services os))
((services -> (operating-system-services os))
(pam-services ->
;; Services known to PAM.
(append (operating-system-pam-services os)
@ -626,7 +619,7 @@ use 'plain-file' instead~%")
"hosts"
(or (operating-system-hosts-file os)
(default-/etc/hosts (operating-system-host-name os)))))
(shells (user-shells os)))
(shells -> (user-shells os)))
(etc-directory #:pam-services pam-services
#:skeletons skeletons
#:issue (operating-system-issue os)
@ -713,7 +706,7 @@ etc."
(sequence %store-monad (map (cut gexp->file "activate-service.scm" <>)
gexps))))
(mlet* %store-monad ((services (operating-system-services os))
(mlet* %store-monad ((services -> (operating-system-services os))
(actions (service-activations services))
(etc (operating-system-etc-directory os))
(modules (imported-modules %modules))
@ -721,7 +714,7 @@ etc."
(modprobe (modprobe-wrapper))
(firmware (directory-union
"firmware" (operating-system-firmware os)))
(accounts (operating-system-accounts os)))
(accounts -> (operating-system-accounts os)))
(define setuid-progs
(operating-system-setuid-programs os))
@ -789,9 +782,8 @@ etc."
"Return the boot script for OS---i.e., the code started by the initrd once
we're running in the final root. When CONTAINER? is true, skip all
hardware-related operations as necessary when booting a Linux container."
(mlet* %store-monad ((services (operating-system-services os))
(activate (operating-system-activation-script
os #:container? container?))
(mlet* %store-monad ((services -> (operating-system-services os))
(activate (operating-system-activation-script os))
(dmd-conf (dmd-configuration-file services)))
(gexp->file "boot"
#~(begin

View File

@ -163,8 +163,7 @@ current store is on a RAM disk."
"Return a service that makes the store copy-on-write, such that writes go to
the user's target storage device rather than on the RAM disk."
;; See <http://bugs.gnu.org/18061> for the initial report.
(with-monad %store-monad
(return (service
(service
(requirement '(root-file-system user-processes))
(provision '(cow-store))
(documentation
@ -188,7 +187,7 @@ the given target.")
;; 'user-unmount' service will unmount TARGET
;; eventually.
(delete-file-recursively
(string-append target #$%backing-directory))))))))
(string-append target #$%backing-directory))))))
(define (configuration-template-service)
"Return a dummy service whose purpose is to install an operating system
@ -204,8 +203,7 @@ configuration template file in the installation system."
'(("gnu/system/examples/bare-bones.tmpl" -> "bare-bones.scm")
("gnu/system/examples/desktop.tmpl" -> "desktop.scm"))))
(with-monad %store-monad
(return (service
(service
(requirement '(root-file-system))
(provision '(os-config-template))
(documentation
@ -222,7 +220,7 @@ configuration template file in the installation system."
((file target)
(unless (file-exists? target)
(copy-file file target))))
'#$templates)))))))
'#$templates)))))
(define %nscd-minimal-caches
;; Minimal in-memory caching policy for nscd.