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
parent
ce8a6dfc43
commit
be1c2c54d9
|
|
@ -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))
|
||||
(if (member 'nscd (service-provision service))
|
||||
(nscd-service (nscd-configuration)
|
||||
#:name-services (list nss-mdns))
|
||||
mservice)))
|
||||
(map (lambda (service)
|
||||
(if (member 'nscd (service-provision service))
|
||||
(nscd-service (nscd-configuration)
|
||||
#:name-services (list nss-mdns))
|
||||
service))
|
||||
%base-services))
|
||||
@end example
|
||||
|
||||
|
|
|
|||
|
|
@ -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,21 +38,21 @@
|
|||
(define (bool value)
|
||||
(if value "yes\n" "no\n"))
|
||||
|
||||
(text-file "avahi-daemon.conf"
|
||||
(string-append
|
||||
"[server]\n"
|
||||
(if host-name
|
||||
(string-append "host-name=" host-name "\n")
|
||||
"")
|
||||
(plain-file "avahi-daemon.conf"
|
||||
(string-append
|
||||
"[server]\n"
|
||||
(if host-name
|
||||
(string-append "host-name=" host-name "\n")
|
||||
"")
|
||||
|
||||
"browse-domains=" (string-join domains-to-browse)
|
||||
"\n"
|
||||
"use-ipv4=" (bool ipv4?)
|
||||
"use-ipv6=" (bool ipv6?)
|
||||
"[wide-area]\n"
|
||||
"enable-wide-area=" (bool wide-area?)
|
||||
"[publish]\n"
|
||||
"disable-publishing=" (bool (not publish?)))))
|
||||
"browse-domains=" (string-join domains-to-browse)
|
||||
"\n"
|
||||
"use-ipv4=" (bool ipv4?)
|
||||
"use-ipv6=" (bool ipv6?)
|
||||
"[wide-area]\n"
|
||||
"enable-wide-area=" (bool wide-area?)
|
||||
"[publish]\n"
|
||||
"disable-publishing=" (bool (not publish?)))))
|
||||
|
||||
(define* (avahi-service #:key (avahi avahi)
|
||||
host-name
|
||||
|
|
@ -76,37 +75,36 @@ When @var{wide-area?} is true, DNS-SD over unicast DNS is enabled.
|
|||
|
||||
Boolean values @var{ipv4?} and @var{ipv6?} determine whether to use IPv4/IPv6
|
||||
sockets."
|
||||
(mlet %store-monad ((config (configuration-file #:host-name host-name
|
||||
#:publish? publish?
|
||||
#:ipv4? ipv4?
|
||||
#:ipv6? ipv6?
|
||||
#:wide-area? wide-area?
|
||||
#:domains-to-browse
|
||||
domains-to-browse)))
|
||||
(return
|
||||
(service
|
||||
(documentation "Run the Avahi mDNS/DNS-SD responder.")
|
||||
(provision '(avahi-daemon))
|
||||
(requirement '(dbus-system networking))
|
||||
(let ((config (configuration-file #:host-name host-name
|
||||
#:publish? publish?
|
||||
#:ipv4? ipv4?
|
||||
#:ipv6? ipv6?
|
||||
#:wide-area? wide-area?
|
||||
#:domains-to-browse
|
||||
domains-to-browse)))
|
||||
(service
|
||||
(documentation "Run the Avahi mDNS/DNS-SD responder.")
|
||||
(provision '(avahi-daemon))
|
||||
(requirement '(dbus-system networking))
|
||||
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$avahi "/sbin/avahi-daemon")
|
||||
"--syslog" "-f" #$config)))
|
||||
(stop #~(make-kill-destructor))
|
||||
(activate #~(begin
|
||||
(use-modules (guix build utils))
|
||||
(mkdir-p "/var/run/avahi-daemon")))
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$avahi "/sbin/avahi-daemon")
|
||||
"--syslog" "-f" #$config)))
|
||||
(stop #~(make-kill-destructor))
|
||||
(activate #~(begin
|
||||
(use-modules (guix build utils))
|
||||
(mkdir-p "/var/run/avahi-daemon")))
|
||||
|
||||
(user-groups (list (user-group
|
||||
(name "avahi")
|
||||
(system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "avahi")
|
||||
(group "avahi")
|
||||
(system? #t)
|
||||
(comment "Avahi daemon user")
|
||||
(home-directory "/var/empty")
|
||||
(shell
|
||||
#~(string-append #$shadow "/sbin/nologin")))))))))
|
||||
(user-groups (list (user-group
|
||||
(name "avahi")
|
||||
(system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "avahi")
|
||||
(group "avahi")
|
||||
(system? #t)
|
||||
(comment "Avahi daemon user")
|
||||
(home-directory "/var/empty")
|
||||
(shell
|
||||
#~(string-append #$shadow "/sbin/nologin"))))))))
|
||||
|
||||
;;; avahi.scm ends here
|
||||
|
|
|
|||
|
|
@ -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,41 +79,39 @@ 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))
|
||||
(start #~(const #t))
|
||||
(stop #~(lambda _
|
||||
;; Return #f if successfully stopped.
|
||||
(sync)
|
||||
(service
|
||||
(documentation "Take care of the root file system.")
|
||||
(provision '(root-file-system))
|
||||
(start #~(const #t))
|
||||
(stop #~(lambda _
|
||||
;; Return #f if successfully stopped.
|
||||
(sync)
|
||||
|
||||
(call-with-blocked-asyncs
|
||||
(lambda ()
|
||||
(let ((null (%make-void-port "w")))
|
||||
;; Close 'dmd.log'.
|
||||
(display "closing log\n")
|
||||
;; XXX: Ideally we'd use 'stop-logging', but that one
|
||||
;; doesn't actually close the port as of dmd 0.1.
|
||||
(close-port (@@ (dmd comm) log-output-port))
|
||||
(set! (@@ (dmd comm) log-output-port) null)
|
||||
(call-with-blocked-asyncs
|
||||
(lambda ()
|
||||
(let ((null (%make-void-port "w")))
|
||||
;; Close 'dmd.log'.
|
||||
(display "closing log\n")
|
||||
;; XXX: Ideally we'd use 'stop-logging', but that one
|
||||
;; doesn't actually close the port as of dmd 0.1.
|
||||
(close-port (@@ (dmd comm) log-output-port))
|
||||
(set! (@@ (dmd comm) log-output-port) null)
|
||||
|
||||
;; Redirect the default output ports..
|
||||
(set-current-output-port null)
|
||||
(set-current-error-port null)
|
||||
;; Redirect the default output ports..
|
||||
(set-current-output-port null)
|
||||
(set-current-error-port null)
|
||||
|
||||
;; Close /dev/console.
|
||||
(for-each close-fdes '(0 1 2))
|
||||
;; Close /dev/console.
|
||||
(for-each close-fdes '(0 1 2))
|
||||
|
||||
;; At this point, there are no open files left, so the
|
||||
;; root file system can be re-mounted read-only.
|
||||
(mount #f "/" #f
|
||||
(logior MS_REMOUNT MS_RDONLY)
|
||||
#:update-mtab? #f)
|
||||
;; At this point, there are no open files left, so the
|
||||
;; root file system can be re-mounted read-only.
|
||||
(mount #f "/" #f
|
||||
(logior MS_REMOUNT MS_RDONLY)
|
||||
#:update-mtab? #f)
|
||||
|
||||
#f)))))
|
||||
(respawn? #f)))))
|
||||
#f)))))
|
||||
(respawn? #f)))
|
||||
|
||||
(define* (file-system-service device target type
|
||||
#:key (flags '()) (check? #t)
|
||||
|
|
@ -127,79 +124,75 @@ 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))
|
||||
(documentation "Check, mount, and unmount the given file system.")
|
||||
(start #~(lambda args
|
||||
;; FIXME: Use or factorize with 'mount-file-system'.
|
||||
(let ((device (canonicalize-device-spec #$device '#$title))
|
||||
(flags #$(mount-flags->bit-mask flags)))
|
||||
#$(if create-mount-point?
|
||||
#~(mkdir-p #$target)
|
||||
#~#t)
|
||||
#$(if check?
|
||||
#~(begin
|
||||
;; Make sure fsck.ext2 & co. can be found.
|
||||
(setenv "PATH"
|
||||
(string-append
|
||||
#$e2fsprogs "/sbin:"
|
||||
"/run/current-system/profile/sbin:"
|
||||
(getenv "PATH")))
|
||||
(check-file-system device #$type))
|
||||
#~#t)
|
||||
(service
|
||||
(provision (list (symbol-append 'file-system- (string->symbol target))))
|
||||
(requirement `(root-file-system ,@requirements))
|
||||
(documentation "Check, mount, and unmount the given file system.")
|
||||
(start #~(lambda args
|
||||
;; FIXME: Use or factorize with 'mount-file-system'.
|
||||
(let ((device (canonicalize-device-spec #$device '#$title))
|
||||
(flags #$(mount-flags->bit-mask flags)))
|
||||
#$(if create-mount-point?
|
||||
#~(mkdir-p #$target)
|
||||
#~#t)
|
||||
#$(if check?
|
||||
#~(begin
|
||||
;; Make sure fsck.ext2 & co. can be found.
|
||||
(setenv "PATH"
|
||||
(string-append
|
||||
#$e2fsprogs "/sbin:"
|
||||
"/run/current-system/profile/sbin:"
|
||||
(getenv "PATH")))
|
||||
(check-file-system device #$type))
|
||||
#~#t)
|
||||
|
||||
(mount device #$target #$type flags #$options)
|
||||
(mount device #$target #$type flags #$options)
|
||||
|
||||
;; For read-only bind mounts, an extra remount is needed,
|
||||
;; as per <http://lwn.net/Articles/281157/>, which still
|
||||
;; applies to Linux 4.0.
|
||||
(when (and (= MS_BIND (logand flags MS_BIND))
|
||||
(= MS_RDONLY (logand flags MS_RDONLY)))
|
||||
(mount device #$target #$type
|
||||
(logior MS_BIND MS_REMOUNT MS_RDONLY))))
|
||||
#t))
|
||||
(stop #~(lambda args
|
||||
;; Normally there are no processes left at this point, so
|
||||
;; TARGET can be safely unmounted.
|
||||
;; For read-only bind mounts, an extra remount is needed,
|
||||
;; as per <http://lwn.net/Articles/281157/>, which still
|
||||
;; applies to Linux 4.0.
|
||||
(when (and (= MS_BIND (logand flags MS_BIND))
|
||||
(= MS_RDONLY (logand flags MS_RDONLY)))
|
||||
(mount device #$target #$type
|
||||
(logior MS_BIND MS_REMOUNT MS_RDONLY))))
|
||||
#t))
|
||||
(stop #~(lambda args
|
||||
;; Normally there are no processes left at this point, so
|
||||
;; TARGET can be safely unmounted.
|
||||
|
||||
;; Make sure PID 1 doesn't keep TARGET busy.
|
||||
(chdir "/")
|
||||
;; Make sure PID 1 doesn't keep TARGET busy.
|
||||
(chdir "/")
|
||||
|
||||
(umount #$target)
|
||||
#f))))))
|
||||
(umount #$target)
|
||||
#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))
|
||||
(start #~(const #t))
|
||||
(stop #~(lambda args
|
||||
(define (known? mount-point)
|
||||
(member mount-point
|
||||
(cons* "/proc" "/sys"
|
||||
'#$known-mount-points)))
|
||||
(service
|
||||
(documentation "Unmount manually-mounted file systems.")
|
||||
(provision '(user-unmount))
|
||||
(start #~(const #t))
|
||||
(stop #~(lambda args
|
||||
(define (known? mount-point)
|
||||
(member mount-point
|
||||
(cons* "/proc" "/sys"
|
||||
'#$known-mount-points)))
|
||||
|
||||
;; Make sure we don't keep the user's mount points busy.
|
||||
(chdir "/")
|
||||
;; Make sure we don't keep the user's mount points busy.
|
||||
(chdir "/")
|
||||
|
||||
(for-each (lambda (mount-point)
|
||||
(format #t "unmounting '~a'...~%" mount-point)
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(umount mount-point))
|
||||
(lambda args
|
||||
(let ((errno (system-error-errno args)))
|
||||
(format #t "failed to unmount '~a': ~a~%"
|
||||
mount-point (strerror errno))))))
|
||||
(filter (negate known?) (mount-points)))
|
||||
#f))))))
|
||||
(for-each (lambda (mount-point)
|
||||
(format #t "unmounting '~a'...~%" mount-point)
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(umount mount-point))
|
||||
(lambda args
|
||||
(let ((errno (system-error-errno args)))
|
||||
(format #t "failed to unmount '~a': ~a~%"
|
||||
mount-point (strerror errno))))))
|
||||
(filter (negate known?) (mount-points)))
|
||||
#f))))
|
||||
|
||||
(define %do-not-kill-file
|
||||
;; Name of the file listing PIDs of processes that must survive when halting
|
||||
|
|
@ -217,86 +210,84 @@ listed in REQUIREMENTS.
|
|||
|
||||
All the services that spawn processes must depend on this one so that they are
|
||||
stopped before 'kill' is called."
|
||||
(with-monad %store-monad
|
||||
(return (service
|
||||
(documentation "When stopped, terminate all user processes.")
|
||||
(provision '(user-processes))
|
||||
(requirement (cons 'root-file-system requirements))
|
||||
(start #~(const #t))
|
||||
(stop #~(lambda _
|
||||
(define (kill-except omit signal)
|
||||
;; Kill all the processes with SIGNAL except those
|
||||
;; listed in OMIT and the current process.
|
||||
(let ((omit (cons (getpid) omit)))
|
||||
(for-each (lambda (pid)
|
||||
(unless (memv pid omit)
|
||||
(false-if-exception
|
||||
(kill pid signal))))
|
||||
(processes))))
|
||||
(service
|
||||
(documentation "When stopped, terminate all user processes.")
|
||||
(provision '(user-processes))
|
||||
(requirement (cons 'root-file-system requirements))
|
||||
(start #~(const #t))
|
||||
(stop #~(lambda _
|
||||
(define (kill-except omit signal)
|
||||
;; Kill all the processes with SIGNAL except those
|
||||
;; listed in OMIT and the current process.
|
||||
(let ((omit (cons (getpid) omit)))
|
||||
(for-each (lambda (pid)
|
||||
(unless (memv pid omit)
|
||||
(false-if-exception
|
||||
(kill pid signal))))
|
||||
(processes))))
|
||||
|
||||
(define omitted-pids
|
||||
;; List of PIDs that must not be killed.
|
||||
(if (file-exists? #$%do-not-kill-file)
|
||||
(map string->number
|
||||
(call-with-input-file #$%do-not-kill-file
|
||||
(compose string-tokenize
|
||||
(@ (ice-9 rdelim) read-string))))
|
||||
'()))
|
||||
(define omitted-pids
|
||||
;; List of PIDs that must not be killed.
|
||||
(if (file-exists? #$%do-not-kill-file)
|
||||
(map string->number
|
||||
(call-with-input-file #$%do-not-kill-file
|
||||
(compose string-tokenize
|
||||
(@ (ice-9 rdelim) read-string))))
|
||||
'()))
|
||||
|
||||
(define (now)
|
||||
(car (gettimeofday)))
|
||||
(define (now)
|
||||
(car (gettimeofday)))
|
||||
|
||||
(define (sleep* n)
|
||||
;; Really sleep N seconds.
|
||||
;; Work around <http://bugs.gnu.org/19581>.
|
||||
(define start (now))
|
||||
(let loop ((elapsed 0))
|
||||
(when (> n elapsed)
|
||||
(sleep (- n elapsed))
|
||||
(loop (- (now) start)))))
|
||||
(define (sleep* n)
|
||||
;; Really sleep N seconds.
|
||||
;; Work around <http://bugs.gnu.org/19581>.
|
||||
(define start (now))
|
||||
(let loop ((elapsed 0))
|
||||
(when (> n elapsed)
|
||||
(sleep (- n elapsed))
|
||||
(loop (- (now) start)))))
|
||||
|
||||
(define lset= (@ (srfi srfi-1) lset=))
|
||||
(define lset= (@ (srfi srfi-1) lset=))
|
||||
|
||||
(display "sending all processes the TERM signal\n")
|
||||
(display "sending all processes the TERM signal\n")
|
||||
|
||||
(if (null? omitted-pids)
|
||||
(begin
|
||||
;; Easy: terminate all of them.
|
||||
(kill -1 SIGTERM)
|
||||
(sleep* #$grace-delay)
|
||||
(kill -1 SIGKILL))
|
||||
(begin
|
||||
;; Kill them all except OMITTED-PIDS. XXX: We
|
||||
;; would like to (kill -1 SIGSTOP) to get a fixed
|
||||
;; list of processes, like 'killall5' does, but
|
||||
;; that seems unreliable.
|
||||
(kill-except omitted-pids SIGTERM)
|
||||
(sleep* #$grace-delay)
|
||||
(kill-except omitted-pids SIGKILL)
|
||||
(delete-file #$%do-not-kill-file)))
|
||||
(if (null? omitted-pids)
|
||||
(begin
|
||||
;; Easy: terminate all of them.
|
||||
(kill -1 SIGTERM)
|
||||
(sleep* #$grace-delay)
|
||||
(kill -1 SIGKILL))
|
||||
(begin
|
||||
;; Kill them all except OMITTED-PIDS. XXX: We
|
||||
;; would like to (kill -1 SIGSTOP) to get a fixed
|
||||
;; list of processes, like 'killall5' does, but
|
||||
;; that seems unreliable.
|
||||
(kill-except omitted-pids SIGTERM)
|
||||
(sleep* #$grace-delay)
|
||||
(kill-except omitted-pids SIGKILL)
|
||||
(delete-file #$%do-not-kill-file)))
|
||||
|
||||
(let wait ()
|
||||
(let ((pids (processes)))
|
||||
(unless (lset= = pids (cons 1 omitted-pids))
|
||||
(format #t "waiting for process termination\
|
||||
(let wait ()
|
||||
(let ((pids (processes)))
|
||||
(unless (lset= = pids (cons 1 omitted-pids))
|
||||
(format #t "waiting for process termination\
|
||||
(processes left: ~s)~%"
|
||||
pids)
|
||||
(sleep* 2)
|
||||
(wait))))
|
||||
pids)
|
||||
(sleep* 2)
|
||||
(wait))))
|
||||
|
||||
(display "all processes have been terminated\n")
|
||||
#f))
|
||||
(respawn? #f)))))
|
||||
(display "all processes have been terminated\n")
|
||||
#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
|
||||
(documentation "Initialize the machine's host name.")
|
||||
(provision '(host-name))
|
||||
(start #~(lambda _
|
||||
(sethostname #$name)))
|
||||
(respawn? #f)))))
|
||||
(service
|
||||
(documentation "Initialize the machine's host name.")
|
||||
(provision '(host-name))
|
||||
(start #~(lambda _
|
||||
(sethostname #$name)))
|
||||
(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)."))
|
||||
(provision '(console-keymap))
|
||||
(start #~(lambda _
|
||||
(zero? (system* (string-append #$kbd "/bin/loadkeys")
|
||||
#$file))))
|
||||
(respawn? #f)))))
|
||||
(service
|
||||
(documentation (string-append "Load console keymap (loadkeys)."))
|
||||
(provision '(console-keymap))
|
||||
(start #~(lambda _
|
||||
(zero? (system* (string-append #$kbd "/bin/loadkeys")
|
||||
#$file))))
|
||||
(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,24 +324,23 @@ 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
|
||||
(documentation "Load a Unicode console font.")
|
||||
(provision (list (symbol-append 'console-font-
|
||||
(string->symbol tty))))
|
||||
(service
|
||||
(documentation "Load a Unicode console font.")
|
||||
(provision (list (symbol-append 'console-font-
|
||||
(string->symbol tty))))
|
||||
|
||||
;; Start after mingetty has been started on TTY, otherwise the
|
||||
;; settings are ignored.
|
||||
(requirement (list (symbol-append 'term-
|
||||
(string->symbol tty))))
|
||||
;; Start after mingetty has been started on TTY, otherwise the
|
||||
;; settings are ignored.
|
||||
(requirement (list (symbol-append 'term-
|
||||
(string->symbol tty))))
|
||||
|
||||
(start #~(lambda _
|
||||
(and #$(unicode-start device)
|
||||
(zero?
|
||||
(system* (string-append #$kbd "/bin/setfont")
|
||||
"-C" #$device #$font)))))
|
||||
(stop #~(const #t))
|
||||
(respawn? #f))))))
|
||||
(start #~(lambda _
|
||||
(and #$(unicode-start device)
|
||||
(zero?
|
||||
(system* (string-append #$kbd "/bin/setfont")
|
||||
"-C" #$device #$font)))))
|
||||
(stop #~(const #t))
|
||||
(respawn? #f))))
|
||||
|
||||
(define* (mingetty-service tty
|
||||
#:key
|
||||
|
|
@ -379,38 +366,36 @@ 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))))
|
||||
(service
|
||||
(documentation (string-append "Run mingetty on " tty "."))
|
||||
(provision (list (symbol-append 'term- (string->symbol tty))))
|
||||
|
||||
;; Since the login prompt shows the host name, wait for the 'host-name'
|
||||
;; service to be done. Also wait for udev essentially so that the tty
|
||||
;; text is not lost in the middle of kernel messages (XXX).
|
||||
(requirement '(user-processes host-name udev))
|
||||
;; Since the login prompt shows the host name, wait for the 'host-name'
|
||||
;; service to be done. Also wait for udev essentially so that the tty
|
||||
;; text is not lost in the middle of kernel messages (XXX).
|
||||
(requirement '(user-processes host-name udev))
|
||||
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$mingetty "/sbin/mingetty")
|
||||
"--noclear" #$tty
|
||||
#$@(if auto-login
|
||||
#~("--autologin" #$auto-login)
|
||||
#~())
|
||||
#$@(if login-program
|
||||
#~("--loginprog" #$login-program)
|
||||
#~())
|
||||
#$@(if login-pause?
|
||||
#~("--loginpause")
|
||||
#~()))))
|
||||
(stop #~(make-kill-destructor))
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$mingetty "/sbin/mingetty")
|
||||
"--noclear" #$tty
|
||||
#$@(if auto-login
|
||||
#~("--autologin" #$auto-login)
|
||||
#~())
|
||||
#$@(if login-program
|
||||
#~("--loginprog" #$login-program)
|
||||
#~())
|
||||
#$@(if login-pause?
|
||||
#~("--loginpause")
|
||||
#~()))))
|
||||
(stop #~(make-kill-destructor))
|
||||
|
||||
(pam-services
|
||||
;; Let 'login' be known to PAM. All the mingetty services will have
|
||||
;; that PAM service, but that's fine because they're all identical and
|
||||
;; duplicates are removed.
|
||||
(list (unix-pam-service "login"
|
||||
#:allow-empty-passwords? allow-empty-passwords?
|
||||
#:motd motd)))))))
|
||||
(pam-services
|
||||
;; Let 'login' be known to PAM. All the mingetty services will have
|
||||
;; that PAM service, but that's fine because they're all identical and
|
||||
;; duplicates are removed.
|
||||
(list (unix-pam-service "login"
|
||||
#:allow-empty-passwords? allow-empty-passwords?
|
||||
#:motd motd)))))
|
||||
|
||||
(define-record-type* <nscd-configuration> nscd-configuration
|
||||
make-nscd-configuration
|
||||
|
|
@ -472,44 +457,44 @@ tool suite.)
|
|||
@code{<nscd-configuration>} object."
|
||||
(define cache->config
|
||||
(match-lambda
|
||||
(($ <nscd-cache> (= symbol->string database)
|
||||
positive-ttl negative-ttl size check-files?
|
||||
persistent? shared? max-size propagate?)
|
||||
(string-append "\nenable-cache\t" database "\tyes\n"
|
||||
(($ <nscd-cache> (= symbol->string database)
|
||||
positive-ttl negative-ttl size check-files?
|
||||
persistent? shared? max-size propagate?)
|
||||
(string-append "\nenable-cache\t" database "\tyes\n"
|
||||
|
||||
"positive-time-to-live\t" database "\t"
|
||||
(number->string positive-ttl) "\n"
|
||||
"negative-time-to-live\t" database "\t"
|
||||
(number->string negative-ttl) "\n"
|
||||
"suggested-size\t" database "\t"
|
||||
(number->string size) "\n"
|
||||
"check-files\t" database "\t"
|
||||
(if check-files? "yes\n" "no\n")
|
||||
"persistent\t" database "\t"
|
||||
(if persistent? "yes\n" "no\n")
|
||||
"shared\t" database "\t"
|
||||
(if shared? "yes\n" "no\n")
|
||||
"max-db-size\t" database "\t"
|
||||
(number->string max-size) "\n"
|
||||
"auto-propagate\t" database "\t"
|
||||
(if propagate? "yes\n" "no\n")))))
|
||||
"positive-time-to-live\t" database "\t"
|
||||
(number->string positive-ttl) "\n"
|
||||
"negative-time-to-live\t" database "\t"
|
||||
(number->string negative-ttl) "\n"
|
||||
"suggested-size\t" database "\t"
|
||||
(number->string size) "\n"
|
||||
"check-files\t" database "\t"
|
||||
(if check-files? "yes\n" "no\n")
|
||||
"persistent\t" database "\t"
|
||||
(if persistent? "yes\n" "no\n")
|
||||
"shared\t" database "\t"
|
||||
(if shared? "yes\n" "no\n")
|
||||
"max-db-size\t" database "\t"
|
||||
(number->string max-size) "\n"
|
||||
"auto-propagate\t" database "\t"
|
||||
(if propagate? "yes\n" "no\n")))))
|
||||
|
||||
(match config
|
||||
(($ <nscd-configuration> log-file debug-level caches)
|
||||
(text-file "nscd.conf"
|
||||
(string-append "\
|
||||
(plain-file "nscd.conf"
|
||||
(string-append "\
|
||||
# Configuration of libc's name service cache daemon (nscd).\n\n"
|
||||
(if log-file
|
||||
(string-append "logfile\t" log-file)
|
||||
"")
|
||||
"\n"
|
||||
(if debug-level
|
||||
(string-append "debug-level\t"
|
||||
(number->string debug-level))
|
||||
"")
|
||||
"\n"
|
||||
(string-concatenate
|
||||
(map cache->config caches)))))))
|
||||
(if log-file
|
||||
(string-append "logfile\t" log-file)
|
||||
"")
|
||||
"\n"
|
||||
(if debug-level
|
||||
(string-append "debug-level\t"
|
||||
(number->string debug-level))
|
||||
"")
|
||||
"\n"
|
||||
(string-concatenate
|
||||
(map cache->config caches)))))))
|
||||
|
||||
(define* (nscd-service #:optional (config %nscd-default-configuration)
|
||||
#:key (glibc (canonical-package glibc))
|
||||
|
|
@ -518,39 +503,35 @@ 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
|
||||
(documentation "Run libc's name service cache daemon (nscd).")
|
||||
(provision '(nscd))
|
||||
(requirement '(user-processes))
|
||||
(let ((nscd.conf (nscd.conf-file config)))
|
||||
(service
|
||||
(documentation "Run libc's name service cache daemon (nscd).")
|
||||
(provision '(nscd))
|
||||
(requirement '(user-processes))
|
||||
|
||||
(activate #~(begin
|
||||
(use-modules (guix build utils))
|
||||
(mkdir-p "/var/run/nscd")
|
||||
(mkdir-p "/var/db/nscd"))) ;for the persistent cache
|
||||
(activate #~(begin
|
||||
(use-modules (guix build utils))
|
||||
(mkdir-p "/var/run/nscd")
|
||||
(mkdir-p "/var/db/nscd"))) ;for the persistent cache
|
||||
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$glibc "/sbin/nscd")
|
||||
"-f" #$nscd.conf "--foreground")
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$glibc "/sbin/nscd")
|
||||
"-f" #$nscd.conf "--foreground")
|
||||
|
||||
#:environment-variables
|
||||
(list (string-append "LD_LIBRARY_PATH="
|
||||
(string-join
|
||||
(map (lambda (dir)
|
||||
(string-append dir "/lib"))
|
||||
(list #$@name-services))
|
||||
":")))))
|
||||
(stop #~(make-kill-destructor))
|
||||
#:environment-variables
|
||||
(list (string-append "LD_LIBRARY_PATH="
|
||||
(string-join
|
||||
(map (lambda (dir)
|
||||
(string-append dir "/lib"))
|
||||
(list #$@name-services))
|
||||
":")))))
|
||||
(stop #~(make-kill-destructor))
|
||||
|
||||
(respawn? #f)))))
|
||||
(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."
|
||||
|
||||
;; Snippet adapted from the GNU inetutils manual.
|
||||
(define contents "
|
||||
;; Snippet adapted from the GNU inetutils manual.
|
||||
(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
|
||||
(service
|
||||
(documentation "Run the syslog daemon (syslogd).")
|
||||
(provision '(syslogd))
|
||||
(requirement '(user-processes))
|
||||
(start
|
||||
#~(make-forkexec-constructor
|
||||
(list (string-append #$inetutils "/libexec/syslogd")
|
||||
"--no-detach" "--rcfile" #$(or config-file syslog.conf))))
|
||||
(stop #~(make-kill-destructor))))))
|
||||
"))
|
||||
(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
|
||||
(list (string-append #$inetutils "/libexec/syslogd")
|
||||
"--no-detach" "--rcfile" #$config-file)))
|
||||
(stop #~(make-kill-destructor))))
|
||||
|
||||
(define* (guix-build-accounts count #:key
|
||||
(group "guixbuild")
|
||||
|
|
@ -658,36 +638,34 @@ passed to @command{guix-daemon}."
|
|||
(and authorize-hydra-key?
|
||||
(hydra-key-authorization guix)))
|
||||
|
||||
(with-monad %store-monad
|
||||
(return (service
|
||||
(documentation "Run the Guix daemon.")
|
||||
(provision '(guix-daemon))
|
||||
(requirement '(user-processes))
|
||||
(start
|
||||
#~(make-forkexec-constructor
|
||||
(list (string-append #$guix "/bin/guix-daemon")
|
||||
"--build-users-group" #$builder-group
|
||||
#$@(if use-substitutes?
|
||||
'()
|
||||
'("--no-substitutes"))
|
||||
#$@extra-options)
|
||||
(service
|
||||
(documentation "Run the Guix daemon.")
|
||||
(provision '(guix-daemon))
|
||||
(requirement '(user-processes))
|
||||
(start
|
||||
#~(make-forkexec-constructor
|
||||
(list (string-append #$guix "/bin/guix-daemon")
|
||||
"--build-users-group" #$builder-group
|
||||
#$@(if use-substitutes?
|
||||
'()
|
||||
'("--no-substitutes"))
|
||||
#$@extra-options)
|
||||
|
||||
;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the
|
||||
;; daemon's $PATH.
|
||||
#:environment-variables
|
||||
(list (string-append "PATH=" #$lsof "/bin:"
|
||||
#$lsh "/bin"))))
|
||||
(stop #~(make-kill-destructor))
|
||||
(user-accounts (guix-build-accounts build-accounts
|
||||
#:group builder-group))
|
||||
(user-groups (list (user-group
|
||||
(name builder-group)
|
||||
(system? #t)
|
||||
;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the
|
||||
;; daemon's $PATH.
|
||||
#:environment-variables
|
||||
(list (string-append "PATH=" #$lsof "/bin:" #$lsh "/bin"))))
|
||||
(stop #~(make-kill-destructor))
|
||||
(user-accounts (guix-build-accounts build-accounts
|
||||
#:group builder-group))
|
||||
(user-groups (list (user-group
|
||||
(name builder-group)
|
||||
(system? #t)
|
||||
|
||||
;; Use a fixed GID so that we can create the
|
||||
;; store with the right owner.
|
||||
(id 30000))))
|
||||
(activate activate)))))
|
||||
;; Use a fixed GID so that we can create the
|
||||
;; store with the right owner.
|
||||
(id 30000))))
|
||||
(activate activate)))
|
||||
|
||||
(define (udev-rules-union packages)
|
||||
"Return the union of the @code{lib/udev/rules.d} directories found in each
|
||||
|
|
@ -712,124 +690,125 @@ item of @var{packages}."
|
|||
(union-build (string-append #$output "/lib/udev/rules.d")
|
||||
(filter-map rules-sub-directory '#$packages))))
|
||||
|
||||
(gexp->derivation "udev-rules" build
|
||||
#:modules '((guix build union)
|
||||
(guix build utils))
|
||||
#:local-build? #t))
|
||||
(computed-file "udev-rules" build
|
||||
#:modules '((guix build union)
|
||||
(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"
|
||||
#~(begin
|
||||
(use-modules (guix build utils))
|
||||
(computed-file "kvm-udev-rules"
|
||||
#~(begin
|
||||
(use-modules (guix build utils))
|
||||
|
||||
(define rules.d
|
||||
(string-append #$output "/lib/udev/rules.d"))
|
||||
(define rules.d
|
||||
(string-append #$output "/lib/udev/rules.d"))
|
||||
|
||||
(mkdir-p rules.d)
|
||||
(call-with-output-file
|
||||
(string-append rules.d "/90-kvm.rules")
|
||||
(lambda (port)
|
||||
;; Build users are part of the "kvm" group, so we
|
||||
;; can fearlessly make /dev/kvm 660 (see
|
||||
;; <http://bugs.gnu.org/18994>, for background.)
|
||||
(display "\
|
||||
(mkdir-p rules.d)
|
||||
(call-with-output-file
|
||||
(string-append rules.d "/90-kvm.rules")
|
||||
(lambda (port)
|
||||
;; Build users are part of the "kvm" group, so we
|
||||
;; can fearlessly make /dev/kvm 660 (see
|
||||
;; <http://bugs.gnu.org/18994>, for background.)
|
||||
(display "\
|
||||
KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n" port))))
|
||||
#:modules '((guix build utils))))
|
||||
#:modules '((guix build utils))))
|
||||
|
||||
(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
|
||||
(provision '(udev))
|
||||
(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
|
||||
;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
|
||||
(requirement '(root-file-system))
|
||||
;; 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))
|
||||
|
||||
(documentation "Populate the /dev directory, dynamically.")
|
||||
(start #~(lambda ()
|
||||
(define find
|
||||
(@ (srfi srfi-1) find))
|
||||
(documentation "Populate the /dev directory, dynamically.")
|
||||
(start #~(lambda ()
|
||||
(define find
|
||||
(@ (srfi srfi-1) find))
|
||||
|
||||
(define udevd
|
||||
;; Choose the right 'udevd'.
|
||||
(find file-exists?
|
||||
(map (lambda (suffix)
|
||||
(string-append #$udev suffix))
|
||||
'("/libexec/udev/udevd" ;udev
|
||||
"/sbin/udevd")))) ;eudev
|
||||
(define udevd
|
||||
;; Choose the right 'udevd'.
|
||||
(find file-exists?
|
||||
(map (lambda (suffix)
|
||||
(string-append #$udev suffix))
|
||||
'("/libexec/udev/udevd" ;udev
|
||||
"/sbin/udevd")))) ;eudev
|
||||
|
||||
(define (wait-for-udevd)
|
||||
;; Wait until someone's listening on udevd's control
|
||||
;; socket.
|
||||
(let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
|
||||
(let try ()
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(connect sock PF_UNIX "/run/udev/control")
|
||||
(close-port sock))
|
||||
(lambda args
|
||||
(format #t "waiting for udevd...~%")
|
||||
(usleep 500000)
|
||||
(try))))))
|
||||
(define (wait-for-udevd)
|
||||
;; Wait until someone's listening on udevd's control
|
||||
;; socket.
|
||||
(let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
|
||||
(let try ()
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(connect sock PF_UNIX "/run/udev/control")
|
||||
(close-port sock))
|
||||
(lambda args
|
||||
(format #t "waiting for udevd...~%")
|
||||
(usleep 500000)
|
||||
(try))))))
|
||||
|
||||
;; Allow udev to find the modules.
|
||||
(setenv "LINUX_MODULE_DIRECTORY"
|
||||
"/run/booted-system/kernel/lib/modules")
|
||||
;; Allow udev to find the modules.
|
||||
(setenv "LINUX_MODULE_DIRECTORY"
|
||||
"/run/booted-system/kernel/lib/modules")
|
||||
|
||||
;; The first one is for udev, the second one for eudev.
|
||||
(setenv "UDEV_CONFIG_FILE" #$udev.conf)
|
||||
(setenv "EUDEV_RULES_DIRECTORY"
|
||||
(string-append #$rules "/lib/udev/rules.d"))
|
||||
;; The first one is for udev, the second one for eudev.
|
||||
(setenv "UDEV_CONFIG_FILE" #$udev.conf)
|
||||
(setenv "EUDEV_RULES_DIRECTORY"
|
||||
(string-append #$rules "/lib/udev/rules.d"))
|
||||
|
||||
(let ((pid (primitive-fork)))
|
||||
(case pid
|
||||
((0)
|
||||
(exec-command (list udevd)))
|
||||
(else
|
||||
;; Wait until udevd is up and running. This
|
||||
;; appears to be needed so that the events
|
||||
;; triggered below are actually handled.
|
||||
(wait-for-udevd)
|
||||
(let ((pid (primitive-fork)))
|
||||
(case pid
|
||||
((0)
|
||||
(exec-command (list udevd)))
|
||||
(else
|
||||
;; Wait until udevd is up and running. This
|
||||
;; appears to be needed so that the events
|
||||
;; triggered below are actually handled.
|
||||
(wait-for-udevd)
|
||||
|
||||
;; Trigger device node creation.
|
||||
(system* (string-append #$udev "/bin/udevadm")
|
||||
"trigger" "--action=add")
|
||||
;; Trigger device node creation.
|
||||
(system* (string-append #$udev "/bin/udevadm")
|
||||
"trigger" "--action=add")
|
||||
|
||||
;; Wait for things to settle down.
|
||||
(system* (string-append #$udev "/bin/udevadm")
|
||||
"settle")
|
||||
pid)))))
|
||||
(stop #~(make-kill-destructor))
|
||||
;; Wait for things to settle down.
|
||||
(system* (string-append #$udev "/bin/udevadm")
|
||||
"settle")
|
||||
pid)))))
|
||||
(stop #~(make-kill-destructor))
|
||||
|
||||
;; 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)))))
|
||||
;; 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))))
|
||||
|
||||
(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))))
|
||||
(requirement '(udev))
|
||||
(documentation "Map a device node using Linux's device mapper.")
|
||||
(start #~(lambda () #$open))
|
||||
(stop #~(lambda _ (not #$close)))
|
||||
(respawn? #f)))))
|
||||
(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)))
|
||||
|
||||
(define (swap-service device)
|
||||
"Return a service that uses @var{device} as a swap device."
|
||||
|
|
@ -839,18 +818,17 @@ gexp, to open it, and evaluate @var{close} to close it."
|
|||
(string->symbol (basename device))))
|
||||
'()))
|
||||
|
||||
(with-monad %store-monad
|
||||
(return (service
|
||||
(provision (list (symbol-append 'swap- (string->symbol device))))
|
||||
(requirement `(udev ,@requirement))
|
||||
(documentation "Enable the given swap device.")
|
||||
(start #~(lambda ()
|
||||
(restart-on-EINTR (swapon #$device))
|
||||
#t))
|
||||
(stop #~(lambda _
|
||||
(restart-on-EINTR (swapoff #$device))
|
||||
#f))
|
||||
(respawn? #f)))))
|
||||
(service
|
||||
(provision (list (symbol-append 'swap- (string->symbol device))))
|
||||
(requirement `(udev ,@requirement))
|
||||
(documentation "Enable the given swap device.")
|
||||
(start #~(lambda ()
|
||||
(restart-on-EINTR (swapon #$device))
|
||||
#t))
|
||||
(stop #~(lambda _
|
||||
(restart-on-EINTR (swapoff #$device))
|
||||
#f))
|
||||
(respawn? #f)))
|
||||
|
||||
(define %base-services
|
||||
;; Convenience variable holding the basic services.
|
||||
|
|
|
|||
|
|
@ -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,16 +59,15 @@ 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"
|
||||
#~(let ((user (getpwnam "postgres"))
|
||||
(postgres (string-append #$postgresql
|
||||
"/bin/postgres")))
|
||||
(setgid (passwd:gid user))
|
||||
(setuid (passwd:uid user))
|
||||
(system* postgres
|
||||
(string-append "--config-file=" #$config-file)
|
||||
"-D" #$data-directory)))))
|
||||
(program-file "start-postgres"
|
||||
#~(let ((user (getpwnam "postgres"))
|
||||
(postgres (string-append #$postgresql
|
||||
"/bin/postgres")))
|
||||
(setgid (passwd:gid user))
|
||||
(setuid (passwd:uid user))
|
||||
(system* postgres
|
||||
(string-append "--config-file=" #$config-file)
|
||||
"-D" #$data-directory))))
|
||||
|
||||
(define activate
|
||||
#~(begin
|
||||
|
|
@ -99,23 +95,21 @@ 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.")
|
||||
(requirement '(user-processes loopback))
|
||||
(start #~(make-forkexec-constructor #$start-script))
|
||||
(stop #~(make-kill-destructor))
|
||||
(activate activate)
|
||||
(user-groups (list (user-group
|
||||
(name "postgres")
|
||||
(system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "postgres")
|
||||
(group "postgres")
|
||||
(system? #t)
|
||||
(comment "PostgreSQL server user")
|
||||
(home-directory "/var/empty")
|
||||
(shell
|
||||
#~(string-append #$shadow "/sbin/nologin")))))))))
|
||||
(service
|
||||
(provision '(postgres))
|
||||
(documentation "Run the PostgreSQL daemon.")
|
||||
(requirement '(user-processes loopback))
|
||||
(start #~(make-forkexec-constructor #$start-script))
|
||||
(stop #~(make-kill-destructor))
|
||||
(activate activate)
|
||||
(user-groups (list (user-group
|
||||
(name "postgres")
|
||||
(system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "postgres")
|
||||
(group "postgres")
|
||||
(system? #t)
|
||||
(comment "PostgreSQL server user")
|
||||
(home-directory "/var/empty")
|
||||
(shell
|
||||
#~(string-append #$shadow "/sbin/nologin")))))))
|
||||
|
|
|
|||
|
|
@ -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,50 +117,49 @@ 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
|
||||
(service
|
||||
(documentation "Run the D-Bus system daemon.")
|
||||
(provision '(dbus-system))
|
||||
(requirement '(user-processes))
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$dbus "/bin/dbus-daemon")
|
||||
"--nofork"
|
||||
(string-append "--config-file=" #$conf "/system.conf"))))
|
||||
(stop #~(make-kill-destructor))
|
||||
(user-groups (list (user-group
|
||||
(name "messagebus")
|
||||
(system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "messagebus")
|
||||
(group "messagebus")
|
||||
(system? #t)
|
||||
(comment "D-Bus system bus user")
|
||||
(home-directory "/var/run/dbus")
|
||||
(shell
|
||||
#~(string-append #$shadow "/sbin/nologin")))))
|
||||
(activate #~(begin
|
||||
(use-modules (guix build utils))
|
||||
(let ((conf (dbus-configuration-directory dbus services)))
|
||||
(service
|
||||
(documentation "Run the D-Bus system daemon.")
|
||||
(provision '(dbus-system))
|
||||
(requirement '(user-processes))
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$dbus "/bin/dbus-daemon")
|
||||
"--nofork"
|
||||
(string-append "--config-file=" #$conf "/system.conf"))))
|
||||
(stop #~(make-kill-destructor))
|
||||
(user-groups (list (user-group
|
||||
(name "messagebus")
|
||||
(system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "messagebus")
|
||||
(group "messagebus")
|
||||
(system? #t)
|
||||
(comment "D-Bus system bus user")
|
||||
(home-directory "/var/run/dbus")
|
||||
(shell
|
||||
#~(string-append #$shadow "/sbin/nologin")))))
|
||||
(activate #~(begin
|
||||
(use-modules (guix build utils))
|
||||
|
||||
(mkdir-p "/var/run/dbus")
|
||||
(mkdir-p "/var/run/dbus")
|
||||
|
||||
(let ((user (getpwnam "messagebus")))
|
||||
(chown "/var/run/dbus"
|
||||
(passwd:uid user) (passwd:gid user)))
|
||||
(let ((user (getpwnam "messagebus")))
|
||||
(chown "/var/run/dbus"
|
||||
(passwd:uid user) (passwd:gid user)))
|
||||
|
||||
(unless (file-exists? "/etc/machine-id")
|
||||
(format #t "creating /etc/machine-id...~%")
|
||||
(let ((prog (string-append #$dbus "/bin/dbus-uuidgen")))
|
||||
;; XXX: We can't use 'system' because the initrd's
|
||||
;; guile system(3) only works when 'sh' is in $PATH.
|
||||
(let ((pid (primitive-fork)))
|
||||
(if (zero? pid)
|
||||
(call-with-output-file "/etc/machine-id"
|
||||
(lambda (port)
|
||||
(close-fdes 1)
|
||||
(dup2 (port->fdes port) 1)
|
||||
(execl prog)))
|
||||
(waitpid pid)))))))))))
|
||||
(unless (file-exists? "/etc/machine-id")
|
||||
(format #t "creating /etc/machine-id...~%")
|
||||
(let ((prog (string-append #$dbus "/bin/dbus-uuidgen")))
|
||||
;; XXX: We can't use 'system' because the initrd's
|
||||
;; guile system(3) only works when 'sh' is in $PATH.
|
||||
(let ((pid (primitive-fork)))
|
||||
(if (zero? pid)
|
||||
(call-with-output-file "/etc/machine-id"
|
||||
(lambda (port)
|
||||
(close-fdes 1)
|
||||
(dup2 (port->fdes port) 1)
|
||||
(execl prog)))
|
||||
(waitpid pid))))))))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -175,24 +173,24 @@ 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"
|
||||
(string-append
|
||||
"[UPower]\n"
|
||||
"EnableWattsUpPro=" (bool watts-up-pro?)
|
||||
"NoPollBatteries=" (bool (not poll-batteries?))
|
||||
"IgnoreLid=" (bool ignore-lid?)
|
||||
"UsePercentageForPolicy=" (bool use-percentage-for-policy?)
|
||||
"PercentageLow=" (number->string percentage-low) "\n"
|
||||
"PercentageCritical=" (number->string percentage-critical) "\n"
|
||||
"PercentageAction=" (number->string percentage-action) "\n"
|
||||
"TimeLow=" (number->string time-low) "\n"
|
||||
"TimeCritical=" (number->string time-critical) "\n"
|
||||
"TimeAction=" (number->string time-action) "\n"
|
||||
"CriticalPowerAction=" (match critical-power-action
|
||||
('hybrid-sleep "HybridSleep")
|
||||
('hibernate "Hibernate")
|
||||
('power-off "PowerOff"))
|
||||
"\n")))
|
||||
(plain-file "UPower.conf"
|
||||
(string-append
|
||||
"[UPower]\n"
|
||||
"EnableWattsUpPro=" (bool watts-up-pro?)
|
||||
"NoPollBatteries=" (bool (not poll-batteries?))
|
||||
"IgnoreLid=" (bool ignore-lid?)
|
||||
"UsePercentageForPolicy=" (bool use-percentage-for-policy?)
|
||||
"PercentageLow=" (number->string percentage-low) "\n"
|
||||
"PercentageCritical=" (number->string percentage-critical) "\n"
|
||||
"PercentageAction=" (number->string percentage-action) "\n"
|
||||
"TimeLow=" (number->string time-low) "\n"
|
||||
"TimeCritical=" (number->string time-critical) "\n"
|
||||
"TimeAction=" (number->string time-action) "\n"
|
||||
"CriticalPowerAction=" (match critical-power-action
|
||||
('hybrid-sleep "HybridSleep")
|
||||
('hibernate "Hibernate")
|
||||
('power-off "PowerOff"))
|
||||
"\n")))
|
||||
|
||||
(define* (upower-service #:key (upower upower)
|
||||
(watts-up-pro? #f)
|
||||
|
|
@ -210,47 +208,46 @@ 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
|
||||
#:watts-up-pro? watts-up-pro?
|
||||
#:poll-batteries? poll-batteries?
|
||||
#:ignore-lid? ignore-lid?
|
||||
#:use-percentage-for-policy? use-percentage-for-policy?
|
||||
#:percentage-low percentage-low
|
||||
#:percentage-critical percentage-critical
|
||||
#:percentage-action percentage-action
|
||||
#:time-low time-low
|
||||
#: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))
|
||||
(requirement '(dbus-system udev))
|
||||
(let ((config (upower-configuration-file
|
||||
#:watts-up-pro? watts-up-pro?
|
||||
#:poll-batteries? poll-batteries?
|
||||
#:ignore-lid? ignore-lid?
|
||||
#:use-percentage-for-policy? use-percentage-for-policy?
|
||||
#:percentage-low percentage-low
|
||||
#:percentage-critical percentage-critical
|
||||
#:percentage-action percentage-action
|
||||
#:time-low time-low
|
||||
#:time-critical time-critical
|
||||
#:time-action time-action
|
||||
#:critical-power-action critical-power-action)))
|
||||
(service
|
||||
(documentation "Run the UPower power and battery monitor.")
|
||||
(provision '(upower-daemon))
|
||||
(requirement '(dbus-system udev))
|
||||
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$upower "/libexec/upowerd"))
|
||||
#:environment-variables
|
||||
(list (string-append "UPOWER_CONF_FILE_NAME=" #$config))))
|
||||
(stop #~(make-kill-destructor))
|
||||
(activate #~(begin
|
||||
(use-modules (guix build utils))
|
||||
(mkdir-p "/var/lib/upower")
|
||||
(let ((user (getpwnam "upower")))
|
||||
(chown "/var/lib/upower"
|
||||
(passwd:uid user) (passwd:gid user)))))
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$upower "/libexec/upowerd"))
|
||||
#:environment-variables
|
||||
(list (string-append "UPOWER_CONF_FILE_NAME=" #$config))))
|
||||
(stop #~(make-kill-destructor))
|
||||
(activate #~(begin
|
||||
(use-modules (guix build utils))
|
||||
(mkdir-p "/var/lib/upower")
|
||||
(let ((user (getpwnam "upower")))
|
||||
(chown "/var/lib/upower"
|
||||
(passwd:uid user) (passwd:gid user)))))
|
||||
|
||||
(user-groups (list (user-group
|
||||
(name "upower")
|
||||
(system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "upower")
|
||||
(group "upower")
|
||||
(system? #t)
|
||||
(comment "UPower daemon user")
|
||||
(home-directory "/var/empty")
|
||||
(shell
|
||||
#~(string-append #$shadow "/sbin/nologin")))))))))
|
||||
(user-groups (list (user-group
|
||||
(name "upower")
|
||||
(system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "upower")
|
||||
(group "upower")
|
||||
(system? #t)
|
||||
(comment "UPower daemon user")
|
||||
(home-directory "/var/empty")
|
||||
(shell
|
||||
#~(string-append #$shadow "/sbin/nologin"))))))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -263,34 +260,32 @@ 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))
|
||||
(requirement '(dbus-system udev))
|
||||
(service
|
||||
(documentation "Run the colord color management service.")
|
||||
(provision '(colord-daemon))
|
||||
(requirement '(dbus-system udev))
|
||||
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$colord "/libexec/colord"))))
|
||||
(stop #~(make-kill-destructor))
|
||||
(activate #~(begin
|
||||
(use-modules (guix build utils))
|
||||
(mkdir-p "/var/lib/colord")
|
||||
(let ((user (getpwnam "colord")))
|
||||
(chown "/var/lib/colord"
|
||||
(passwd:uid user) (passwd:gid user)))))
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$colord "/libexec/colord"))))
|
||||
(stop #~(make-kill-destructor))
|
||||
(activate #~(begin
|
||||
(use-modules (guix build utils))
|
||||
(mkdir-p "/var/lib/colord")
|
||||
(let ((user (getpwnam "colord")))
|
||||
(chown "/var/lib/colord"
|
||||
(passwd:uid user) (passwd:gid user)))))
|
||||
|
||||
(user-groups (list (user-group
|
||||
(name "colord")
|
||||
(system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "colord")
|
||||
(group "colord")
|
||||
(system? #t)
|
||||
(comment "colord daemon user")
|
||||
(home-directory "/var/empty")
|
||||
(shell
|
||||
#~(string-append #$shadow "/sbin/nologin")))))))))
|
||||
(user-groups (list (user-group
|
||||
(name "colord")
|
||||
(system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "colord")
|
||||
(group "colord")
|
||||
(system? #t)
|
||||
(comment "colord daemon user")
|
||||
(home-directory "/var/empty")
|
||||
(shell
|
||||
#~(string-append #$shadow "/sbin/nologin")))))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -321,16 +316,16 @@ users are allowed."
|
|||
wifi-submission-url submission-nick
|
||||
applications)
|
||||
"Return a geoclue configuration file."
|
||||
(text-file "geoclue.conf"
|
||||
(string-append
|
||||
"[agent]\n"
|
||||
"whitelist=" (string-join whitelist ";") "\n"
|
||||
"[wifi]\n"
|
||||
"url=" wifi-geolocation-url "\n"
|
||||
"submit-data=" (bool submit-data?)
|
||||
"submission-url=" wifi-submission-url "\n"
|
||||
"submission-nick=" submission-nick "\n"
|
||||
(string-join applications "\n"))))
|
||||
(plain-file "geoclue.conf"
|
||||
(string-append
|
||||
"[agent]\n"
|
||||
"whitelist=" (string-join whitelist ";") "\n"
|
||||
"[wifi]\n"
|
||||
"url=" wifi-geolocation-url "\n"
|
||||
"submit-data=" (bool submit-data?)
|
||||
"submission-url=" wifi-submission-url "\n"
|
||||
"submission-nick=" submission-nick "\n"
|
||||
(string-join applications "\n"))))
|
||||
|
||||
(define* (geoclue-service #:key (geoclue geoclue)
|
||||
(whitelist '())
|
||||
|
|
@ -350,37 +345,36 @@ 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
|
||||
#: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))
|
||||
(requirement '(dbus-system))
|
||||
(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)))
|
||||
(service
|
||||
(documentation "Run the GeoClue location service.")
|
||||
(provision '(geoclue-daemon))
|
||||
(requirement '(dbus-system))
|
||||
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$geoclue "/libexec/geoclue"))
|
||||
#:user "geoclue"
|
||||
#:environment-variables
|
||||
(list (string-append "GEOCLUE_CONFIG_FILE=" #$config))))
|
||||
(stop #~(make-kill-destructor))
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$geoclue "/libexec/geoclue"))
|
||||
#:user "geoclue"
|
||||
#:environment-variables
|
||||
(list (string-append "GEOCLUE_CONFIG_FILE=" #$config))))
|
||||
(stop #~(make-kill-destructor))
|
||||
|
||||
(user-groups (list (user-group
|
||||
(name "geoclue")
|
||||
(system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "geoclue")
|
||||
(group "geoclue")
|
||||
(system? #t)
|
||||
(comment "GeoClue daemon user")
|
||||
(home-directory "/var/empty")
|
||||
(shell
|
||||
"/run/current-system/profile/sbin/nologin"))))))))
|
||||
(user-groups (list (user-group
|
||||
(name "geoclue")
|
||||
(system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "geoclue")
|
||||
(group "geoclue")
|
||||
(system? #t)
|
||||
(comment "GeoClue daemon user")
|
||||
(home-directory "/var/empty")
|
||||
(shell
|
||||
"/run/current-system/profile/sbin/nologin")))))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -393,30 +387,28 @@ 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))
|
||||
(requirement '(dbus-system))
|
||||
(service
|
||||
(documentation "Run the polkit privilege management service.")
|
||||
(provision '(polkit-daemon))
|
||||
(requirement '(dbus-system))
|
||||
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$polkit "/lib/polkit-1/polkitd"))))
|
||||
(stop #~(make-kill-destructor))
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$polkit "/lib/polkit-1/polkitd"))))
|
||||
(stop #~(make-kill-destructor))
|
||||
|
||||
(user-groups (list (user-group
|
||||
(name "polkitd")
|
||||
(system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "polkitd")
|
||||
(group "polkitd")
|
||||
(system? #t)
|
||||
(comment "Polkit daemon user")
|
||||
(home-directory "/var/empty")
|
||||
(shell
|
||||
"/run/current-system/profile/sbin/nologin"))))
|
||||
(user-groups (list (user-group
|
||||
(name "polkitd")
|
||||
(system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "polkitd")
|
||||
(group "polkitd")
|
||||
(system? #t)
|
||||
(comment "Polkit daemon user")
|
||||
(home-directory "/var/empty")
|
||||
(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,18 +554,17 @@ 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
|
||||
(service
|
||||
(documentation "Run the elogind login and seat management service.")
|
||||
(provision '(elogind))
|
||||
(requirement '(dbus-system))
|
||||
(let ((config-file (elogind-configuration-file config)))
|
||||
(service
|
||||
(documentation "Run the elogind login and seat management service.")
|
||||
(provision '(elogind))
|
||||
(requirement '(dbus-system))
|
||||
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$elogind "/libexec/elogind/elogind"))
|
||||
#:environment-variables
|
||||
(list (string-append "ELOGIND_CONF_FILE=" #$config-file))))
|
||||
(stop #~(make-kill-destructor))))))
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$elogind "/libexec/elogind/elogind"))
|
||||
#:environment-variables
|
||||
(list (string-append "ELOGIND_CONF_FILE=" #$config-file))))
|
||||
(stop #~(make-kill-destructor)))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -599,25 +590,24 @@ when they log out."
|
|||
|
||||
(ntp-service)
|
||||
|
||||
(map (lambda (mservice)
|
||||
(mlet %store-monad ((service mservice))
|
||||
(cond
|
||||
;; Provide an nscd ready to use nss-mdns.
|
||||
((memq 'nscd (service-provision service))
|
||||
(nscd-service (nscd-configuration)
|
||||
#:name-services (list nss-mdns)))
|
||||
(map (lambda (service)
|
||||
(cond
|
||||
;; Provide an nscd ready to use nss-mdns.
|
||||
((memq 'nscd (service-provision service))
|
||||
(nscd-service (nscd-configuration)
|
||||
#:name-services (list nss-mdns)))
|
||||
|
||||
;; Add more rules to udev-service.
|
||||
;;
|
||||
;; XXX Keep this in sync with the 'udev-service' call in
|
||||
;; %base-services. Here we intend only to add 'upower',
|
||||
;; 'colord', and 'elogind'.
|
||||
((memq 'udev (service-provision service))
|
||||
(udev-service #:rules
|
||||
(list lvm2 fuse alsa-utils crda
|
||||
upower colord elogind)))
|
||||
;; Add more rules to udev-service.
|
||||
;;
|
||||
;; XXX Keep this in sync with the 'udev-service' call in
|
||||
;; %base-services. Here we intend only to add 'upower',
|
||||
;; 'colord', and 'elogind'.
|
||||
((memq 'udev (service-provision service))
|
||||
(udev-service #:rules
|
||||
(list lvm2 fuse alsa-utils crda
|
||||
upower colord elogind)))
|
||||
|
||||
(else mservice))))
|
||||
(else service)))
|
||||
%base-services)))
|
||||
|
||||
;;; desktop.scm ends here
|
||||
|
|
|
|||
|
|
@ -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,28 +40,26 @@ 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.")
|
||||
(requirement '(user-processes))
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$lirc "/sbin/lircd")
|
||||
"--nodaemon"
|
||||
#$@(if device
|
||||
#~("--device" #$device)
|
||||
#~())
|
||||
#$@(if driver
|
||||
#~("--driver" #$driver)
|
||||
#~())
|
||||
#$@(if config-file
|
||||
#~(#$config-file)
|
||||
#~())
|
||||
#$@extra-options)))
|
||||
(stop #~(make-kill-destructor))
|
||||
(activate #~(begin
|
||||
(use-modules (guix build utils))
|
||||
(mkdir-p "/var/run/lirc")))))))
|
||||
(service
|
||||
(provision '(lircd))
|
||||
(documentation "Run the LIRC daemon.")
|
||||
(requirement '(user-processes))
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$lirc "/sbin/lircd")
|
||||
"--nodaemon"
|
||||
#$@(if device
|
||||
#~("--device" #$device)
|
||||
#~())
|
||||
#$@(if driver
|
||||
#~("--driver" #$driver)
|
||||
#~())
|
||||
#$@(if config-file
|
||||
#~(#$config-file)
|
||||
#~())
|
||||
#$@extra-options)))
|
||||
(stop #~(make-kill-destructor))
|
||||
(activate #~(begin
|
||||
(use-modules (guix build utils))
|
||||
(mkdir-p "/var/run/lirc")))))
|
||||
|
||||
;;; lirc.scm ends here
|
||||
|
|
|
|||
|
|
@ -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,54 +92,52 @@ gateway."
|
|||
|
||||
;; TODO: Eventually replace 'route' with bindings for the appropriate
|
||||
;; ioctls.
|
||||
(with-monad %store-monad
|
||||
(return
|
||||
(service
|
||||
(service
|
||||
|
||||
;; Unless we're providing the loopback interface, wait for udev to be up
|
||||
;; and running so that INTERFACE is actually usable.
|
||||
(requirement (if loopback? '() '(udev)))
|
||||
;; Unless we're providing the loopback interface, wait for udev to be up
|
||||
;; and running so that INTERFACE is actually usable.
|
||||
(requirement (if loopback? '() '(udev)))
|
||||
|
||||
(documentation
|
||||
"Bring up the networking interface using a static IP address.")
|
||||
(provision provision)
|
||||
(start #~(lambda _
|
||||
;; Return #t if successfully started.
|
||||
(let* ((addr (inet-pton AF_INET #$ip))
|
||||
(sockaddr (make-socket-address AF_INET addr 0)))
|
||||
(configure-network-interface #$interface sockaddr
|
||||
(logior IFF_UP
|
||||
#$(if loopback?
|
||||
#~IFF_LOOPBACK
|
||||
0))))
|
||||
#$(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.
|
||||
(let ((sock (socket AF_INET SOCK_STREAM 0)))
|
||||
(set-network-interface-flags sock #$interface 0)
|
||||
(close-port sock))
|
||||
(not #$(if gateway
|
||||
#~(system* (string-append #$net-tools
|
||||
(documentation
|
||||
"Bring up the networking interface using a static IP address.")
|
||||
(provision provision)
|
||||
(start #~(lambda _
|
||||
;; Return #t if successfully started.
|
||||
(let* ((addr (inet-pton AF_INET #$ip))
|
||||
(sockaddr (make-socket-address AF_INET addr 0)))
|
||||
(configure-network-interface #$interface sockaddr
|
||||
(logior IFF_UP
|
||||
#$(if loopback?
|
||||
#~IFF_LOOPBACK
|
||||
0))))
|
||||
#$(if gateway
|
||||
#~(zero? (system* (string-append #$net-tools
|
||||
"/sbin/route")
|
||||
"del" "-net" "default")
|
||||
#t))))
|
||||
(respawn? #f)))))
|
||||
"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.
|
||||
(let ((sock (socket AF_INET SOCK_STREAM 0)))
|
||||
(set-network-interface-flags sock #$interface 0)
|
||||
(close-port sock))
|
||||
(not #$(if gateway
|
||||
#~(system* (string-append #$net-tools
|
||||
"/sbin/route")
|
||||
"del" "-net" "default")
|
||||
#t))))
|
||||
(respawn? #f)))
|
||||
|
||||
(define* (dhcp-client-service #:key (dhcp isc-dhcp))
|
||||
"Return a service that runs @var{dhcp}, a Dynamic Host Configuration
|
||||
|
|
@ -152,52 +149,49 @@ Protocol (DHCP) client, on all the non-loopback network interfaces."
|
|||
(define pid-file
|
||||
"/var/run/dhclient.pid")
|
||||
|
||||
(with-monad %store-monad
|
||||
(return (service
|
||||
(documentation "Set up networking via DHCP.")
|
||||
(requirement '(user-processes udev))
|
||||
(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.
|
||||
(provision '(networking))
|
||||
;; 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.
|
||||
(define valid?
|
||||
(negate loopback-network-interface?))
|
||||
(define ifaces
|
||||
(filter valid? (all-network-interface-names)))
|
||||
(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.
|
||||
(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.
|
||||
(for-each set-network-interface-up ifaces)
|
||||
;; 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))
|
||||
(let ((pid (fork+exec-command
|
||||
(cons* #$dhclient "-nw"
|
||||
"-pf" #$pid-file ifaces))))
|
||||
(and (zero? (cdr (waitpid pid)))
|
||||
(let loop ()
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(call-with-input-file #$pid-file read))
|
||||
(lambda args
|
||||
;; '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))))))
|
||||
(false-if-exception (delete-file #$pid-file))
|
||||
(let ((pid (fork+exec-command
|
||||
(cons* #$dhclient "-nw"
|
||||
"-pf" #$pid-file ifaces))))
|
||||
(and (zero? (cdr (waitpid pid)))
|
||||
(let loop ()
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(call-with-input-file #$pid-file read))
|
||||
(lambda args
|
||||
;; '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))))
|
||||
|
||||
(define %ntp-servers
|
||||
;; Default set of NTP servers.
|
||||
|
|
@ -227,57 +221,55 @@ 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
|
||||
(service
|
||||
(provision '(ntpd))
|
||||
(documentation "Run the Network Time Protocol (NTP) daemon.")
|
||||
(requirement '(user-processes networking))
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$ntp "/bin/ntpd") "-n"
|
||||
"-c" #$ntpd.conf
|
||||
"-u" "ntpd")))
|
||||
(stop #~(make-kill-destructor))
|
||||
(user-accounts (list (user-account
|
||||
(name "ntpd")
|
||||
(group "nogroup")
|
||||
(system? #t)
|
||||
(comment "NTP daemon user")
|
||||
(home-directory "/var/empty")
|
||||
(shell
|
||||
#~(string-append #$shadow "/sbin/nologin")))))))))
|
||||
(let ((ntpd.conf (plain-file "ntpd.conf" config)))
|
||||
(service
|
||||
(provision '(ntpd))
|
||||
(documentation "Run the Network Time Protocol (NTP) daemon.")
|
||||
(requirement '(user-processes networking))
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$ntp "/bin/ntpd") "-n"
|
||||
"-c" #$ntpd.conf
|
||||
"-u" "ntpd")))
|
||||
(stop #~(make-kill-destructor))
|
||||
(user-accounts (list (user-account
|
||||
(name "ntpd")
|
||||
(group "nogroup")
|
||||
(system? #t)
|
||||
(comment "NTP daemon user")
|
||||
(home-directory "/var/empty")
|
||||
(shell
|
||||
#~(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
|
||||
(service
|
||||
(provision '(tor))
|
||||
(let ((torrc (plain-file "torrc" "User tor\n")))
|
||||
(service
|
||||
(provision '(tor))
|
||||
|
||||
;; Tor needs at least one network interface to be up, hence the
|
||||
;; dependency on 'loopback'.
|
||||
(requirement '(user-processes loopback))
|
||||
;; Tor needs at least one network interface to be up, hence the
|
||||
;; dependency on 'loopback'.
|
||||
(requirement '(user-processes loopback))
|
||||
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$tor "/bin/tor") "-f" #$torrc)))
|
||||
(stop #~(make-kill-destructor))
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$tor "/bin/tor") "-f" #$torrc)))
|
||||
(stop #~(make-kill-destructor))
|
||||
|
||||
(user-groups (list (user-group
|
||||
(name "tor")
|
||||
(system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "tor")
|
||||
(group "tor")
|
||||
(system? #t)
|
||||
(comment "Tor daemon user")
|
||||
(home-directory "/var/empty")
|
||||
(shell
|
||||
#~(string-append #$shadow "/sbin/nologin")))))
|
||||
(user-groups (list (user-group
|
||||
(name "tor")
|
||||
(system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "tor")
|
||||
(group "tor")
|
||||
(system? #t)
|
||||
(comment "Tor daemon user")
|
||||
(home-directory "/var/empty")
|
||||
(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,60 +284,57 @@ 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"
|
||||
(string-append "
|
||||
(let ((conf (plain-file "bitlbee.conf"
|
||||
(string-append "
|
||||
[settings]
|
||||
User = bitlbee
|
||||
ConfigDir = /var/lib/bitlbee
|
||||
DaemonInterface = " interface "
|
||||
DaemonPort = " (number->string port) "
|
||||
" extra-settings))))
|
||||
(return
|
||||
(service
|
||||
(provision '(bitlbee))
|
||||
(requirement '(user-processes loopback))
|
||||
(activate #~(begin
|
||||
(use-modules (guix build utils))
|
||||
(service
|
||||
(provision '(bitlbee))
|
||||
(requirement '(user-processes loopback))
|
||||
(activate #~(begin
|
||||
(use-modules (guix build utils))
|
||||
|
||||
;; This directory is used to store OTR data.
|
||||
(mkdir-p "/var/lib/bitlbee")
|
||||
(let ((user (getpwnam "bitlbee")))
|
||||
(chown "/var/lib/bitlbee"
|
||||
(passwd:uid user) (passwd:gid user)))))
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$bitlbee "/sbin/bitlbee")
|
||||
"-n" "-F" "-u" "bitlbee" "-c" #$conf)))
|
||||
(stop #~(make-kill-destructor))
|
||||
(user-groups (list (user-group (name "bitlbee") (system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "bitlbee")
|
||||
(group "bitlbee")
|
||||
(system? #t)
|
||||
(comment "BitlBee daemon user")
|
||||
(home-directory "/var/empty")
|
||||
(shell #~(string-append #$shadow
|
||||
"/sbin/nologin")))))))))
|
||||
;; This directory is used to store OTR data.
|
||||
(mkdir-p "/var/lib/bitlbee")
|
||||
(let ((user (getpwnam "bitlbee")))
|
||||
(chown "/var/lib/bitlbee"
|
||||
(passwd:uid user) (passwd:gid user)))))
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$bitlbee "/sbin/bitlbee")
|
||||
"-n" "-F" "-u" "bitlbee" "-c" #$conf)))
|
||||
(stop #~(make-kill-destructor))
|
||||
(user-groups (list (user-group (name "bitlbee") (system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "bitlbee")
|
||||
(group "bitlbee")
|
||||
(system? #t)
|
||||
(comment "BitlBee daemon user")
|
||||
(home-directory "/var/empty")
|
||||
(shell #~(string-append #$shadow
|
||||
"/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))
|
||||
(requirement '(user-processes dbus-system loopback))
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$wicd "/sbin/wicd")
|
||||
"--no-daemon")))
|
||||
(stop #~(make-kill-destructor))
|
||||
(activate
|
||||
#~(begin
|
||||
(use-modules (guix build utils))
|
||||
(mkdir-p "/etc/wicd")
|
||||
(let ((file-name "/etc/wicd/dhclient.conf.template.default"))
|
||||
(unless (file-exists? file-name)
|
||||
(copy-file (string-append #$wicd file-name)
|
||||
file-name)))))))))
|
||||
(service
|
||||
(documentation "Run the Wicd network manager.")
|
||||
(provision '(networking))
|
||||
(requirement '(user-processes dbus-system loopback))
|
||||
(start #~(make-forkexec-constructor
|
||||
(list (string-append #$wicd "/sbin/wicd")
|
||||
"--no-daemon")))
|
||||
(stop #~(make-kill-destructor))
|
||||
(activate
|
||||
#~(begin
|
||||
(use-modules (guix build utils))
|
||||
(mkdir-p "/etc/wicd")
|
||||
(let ((file-name "/etc/wicd/dhclient.conf.template.default"))
|
||||
(unless (file-exists? file-name)
|
||||
(copy-file (string-append #$wicd file-name)
|
||||
file-name)))))))
|
||||
|
||||
;;; networking.scm ends here
|
||||
|
|
|
|||
|
|
@ -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,22 +151,21 @@ The other options should be self-descriptive."
|
|||
'(networking syslogd)
|
||||
'(networking)))
|
||||
|
||||
(with-monad %store-monad
|
||||
(return (service
|
||||
(documentation "GNU lsh SSH server")
|
||||
(provision '(ssh-daemon))
|
||||
(requirement requires)
|
||||
(start #~(make-forkexec-constructor (list #$@lsh-command)))
|
||||
(stop #~(make-kill-destructor))
|
||||
(pam-services
|
||||
(list (unix-pam-service
|
||||
"lshd"
|
||||
#:allow-empty-passwords? allow-empty-passwords?)))
|
||||
(activate #~(begin
|
||||
(use-modules (guix build utils))
|
||||
(mkdir-p "/var/spool/lsh")
|
||||
#$(if initialize?
|
||||
(activation lsh host-key)
|
||||
#t)))))))
|
||||
(service
|
||||
(documentation "GNU lsh SSH server")
|
||||
(provision '(ssh-daemon))
|
||||
(requirement requires)
|
||||
(start #~(make-forkexec-constructor (list #$@lsh-command)))
|
||||
(stop #~(make-kill-destructor))
|
||||
(pam-services
|
||||
(list (unix-pam-service
|
||||
"lshd"
|
||||
#:allow-empty-passwords? allow-empty-passwords?)))
|
||||
(activate #~(begin
|
||||
(use-modules (guix build utils))
|
||||
(mkdir-p "/var/spool/lsh")
|
||||
#$(if initialize?
|
||||
(activation lsh host-key)
|
||||
#t)))))
|
||||
|
||||
;;; ssh.scm ends here
|
||||
|
|
|
|||
|
|
@ -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,22 +75,20 @@ 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.")
|
||||
(requirement '(user-processes loopback))
|
||||
(start (nginx-action "-p" run-directory))
|
||||
(stop (nginx-action "-s" "stop"))
|
||||
(activate activate)
|
||||
(user-groups (list (user-group
|
||||
(name "nginx")
|
||||
(system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "nginx")
|
||||
(group "nginx")
|
||||
(system? #t)
|
||||
(comment "nginx server user")
|
||||
(home-directory "/var/empty")
|
||||
(shell nologin))))))))
|
||||
(service
|
||||
(provision '(nginx))
|
||||
(documentation "Run the nginx daemon.")
|
||||
(requirement '(user-processes loopback))
|
||||
(start (nginx-action "-p" run-directory))
|
||||
(stop (nginx-action "-s" "stop"))
|
||||
(activate activate)
|
||||
(user-groups (list (user-group
|
||||
(name "nginx")
|
||||
(system? #t))))
|
||||
(user-accounts (list (user-account
|
||||
(name "nginx")
|
||||
(group "nginx")
|
||||
(system? #t)
|
||||
(comment "nginx server user")
|
||||
(home-directory "/var/empty")
|
||||
(shell nologin))))))
|
||||
|
|
|
|||
|
|
@ -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,27 +135,24 @@ 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
|
||||
;; Write a small wrapper around the X server.
|
||||
#~(begin
|
||||
(setenv "XORG_DRI_DRIVER_PATH" (string-append #$mesa "/lib/dri"))
|
||||
(setenv "XKB_BINDIR" (string-append #$xkbcomp "/bin"))
|
||||
(define exp
|
||||
;; Write a small wrapper around the X server.
|
||||
#~(begin
|
||||
(setenv "XORG_DRI_DRIVER_PATH" (string-append #$mesa "/lib/dri"))
|
||||
(setenv "XKB_BINDIR" (string-append #$xkbcomp "/bin"))
|
||||
|
||||
(apply execl (string-append #$xorg-server "/bin/X")
|
||||
(string-append #$xorg-server "/bin/X") ;argv[0]
|
||||
"-logverbose" "-verbose"
|
||||
"-xkbdir" (string-append #$xkeyboard-config "/share/X11/xkb")
|
||||
"-config" #$config
|
||||
"-nolisten" "tcp" "-terminate"
|
||||
(apply execl (string-append #$xorg-server "/bin/X")
|
||||
(string-append #$xorg-server "/bin/X") ;argv[0]
|
||||
"-logverbose" "-verbose"
|
||||
"-xkbdir" (string-append #$xkeyboard-config "/share/X11/xkb")
|
||||
"-config" #$configuration-file
|
||||
"-nolisten" "tcp" "-terminate"
|
||||
|
||||
;; Note: SLiM and other display managers add the
|
||||
;; '-auth' flag by themselves.
|
||||
(cdr (command-line)))))
|
||||
;; 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,40 +263,37 @@ sessiondir /run/current-system/profile/share/xsessions
|
|||
session_msg session (F1 to change):
|
||||
|
||||
halt_cmd " dmd "/sbin/halt
|
||||
reboot_cmd " dmd "/sbin/reboot
|
||||
"
|
||||
(if auto-login?
|
||||
(string-append "auto_login yes\ndefault_user " default-user "\n")
|
||||
"")
|
||||
(if theme-name
|
||||
(string-append "current_theme " theme-name "\n")
|
||||
""))))
|
||||
reboot_cmd " dmd "/sbin/reboot\n"
|
||||
(if auto-login?
|
||||
(string-append "auto_login yes\ndefault_user " default-user "\n")
|
||||
"")
|
||||
(if theme-name
|
||||
(string-append "current_theme " theme-name "\n")
|
||||
""))))
|
||||
|
||||
(mlet %store-monad ((slim.cfg (slim.cfg)))
|
||||
(return
|
||||
(service
|
||||
(documentation "Xorg display server")
|
||||
(provision '(xorg-server))
|
||||
(requirement '(user-processes host-name udev))
|
||||
(start
|
||||
#~(lambda ()
|
||||
;; A stale lock file can prevent SLiM from starting, so remove it
|
||||
;; to be on the safe side.
|
||||
(false-if-exception (delete-file "/var/run/slim.lock"))
|
||||
(service
|
||||
(documentation "Xorg display server")
|
||||
(provision '(xorg-server))
|
||||
(requirement '(user-processes host-name udev))
|
||||
(start
|
||||
#~(lambda ()
|
||||
;; A stale lock file can prevent SLiM from starting, so remove it
|
||||
;; to be on the safe side.
|
||||
(false-if-exception (delete-file "/var/run/slim.lock"))
|
||||
|
||||
(fork+exec-command
|
||||
(list (string-append #$slim "/bin/slim") "-nodaemon")
|
||||
#:environment-variables
|
||||
(list (string-append "SLIM_CFGFILE=" #$slim.cfg)
|
||||
#$@(if theme
|
||||
(list #~(string-append "SLIM_THEMESDIR=" #$theme))
|
||||
#~())))))
|
||||
(stop #~(make-kill-destructor))
|
||||
(respawn? #t)
|
||||
(pam-services
|
||||
;; Tell PAM about 'slim'.
|
||||
(list (unix-pam-service
|
||||
"slim"
|
||||
#:allow-empty-passwords? allow-empty-passwords?)))))))
|
||||
(fork+exec-command
|
||||
(list (string-append #$slim "/bin/slim") "-nodaemon")
|
||||
#:environment-variables
|
||||
(list (string-append "SLIM_CFGFILE=" #$slim.cfg)
|
||||
#$@(if theme
|
||||
(list #~(string-append "SLIM_THEMESDIR=" #$theme))
|
||||
#~())))))
|
||||
(stop #~(make-kill-destructor))
|
||||
(respawn? #t)
|
||||
(pam-services
|
||||
;; Tell PAM about 'slim'.
|
||||
(list (unix-pam-service
|
||||
"slim"
|
||||
#:allow-empty-passwords? allow-empty-passwords?)))))
|
||||
|
||||
;;; xorg.scm ends here
|
||||
|
|
|
|||
104
gnu/system.scm
104
gnu/system.scm
|
|
@ -244,19 +244,18 @@ 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
|
||||
#f check? create?)
|
||||
(file-system-service device target type
|
||||
#:title title
|
||||
#:requirements (requirements fs)
|
||||
#:check? check?
|
||||
#:create-mount-point? create?
|
||||
#:options opts
|
||||
#:flags flags))))
|
||||
file-systems)))
|
||||
(map (lambda (fs)
|
||||
(match fs
|
||||
(($ <file-system> device title target type flags opts
|
||||
#f check? create?)
|
||||
(file-system-service device target type
|
||||
#:title title
|
||||
#:requirements (requirements fs)
|
||||
#:check? check?
|
||||
#:create-mount-point? create?
|
||||
#:options opts
|
||||
#:flags flags))))
|
||||
file-systems))
|
||||
|
||||
(define (mapped-device-user device file-systems)
|
||||
"Return a file system among FILE-SYSTEMS that uses DEVICE, or #f."
|
||||
|
|
@ -287,23 +286,21 @@ 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
|
||||
(map (lambda (md)
|
||||
(let* ((source (mapped-device-source md))
|
||||
(target (mapped-device-target md))
|
||||
(type (mapped-device-type md))
|
||||
(open (mapped-device-kind-open type))
|
||||
(close (mapped-device-kind-close type)))
|
||||
(device-mapping-service target
|
||||
(open source target)
|
||||
(close source target))))
|
||||
(operating-system-user-mapped-devices os))))
|
||||
"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))
|
||||
(type (mapped-device-type md))
|
||||
(open (mapped-device-kind-open type))
|
||||
(close (mapped-device-kind-close type)))
|
||||
(device-mapping-service target
|
||||
(open source target)
|
||||
(close source target))))
|
||||
(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,26 +309,23 @@ bookkeeping."
|
|||
(define known-fs
|
||||
(map file-system-mount-point (operating-system-file-systems os)))
|
||||
|
||||
(mlet* %store-monad ((mappings (device-mapping-services os))
|
||||
(root-fs (root-file-system-service))
|
||||
(other-fs (other-file-system-services os))
|
||||
(unmount (user-unmount-service known-fs))
|
||||
(swaps (swap-services os))
|
||||
(procs (user-processes-service
|
||||
(map (compose first service-provision)
|
||||
other-fs)))
|
||||
(host-name (host-name-service
|
||||
(operating-system-host-name os))))
|
||||
(return (cons* host-name procs root-fs unmount
|
||||
(append other-fs mappings swaps)))))
|
||||
(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))
|
||||
(swaps (swap-services os))
|
||||
(procs (user-processes-service
|
||||
(map (compose first service-provision)
|
||||
other-fs)))
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -163,32 +163,31 @@ 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
|
||||
(requirement '(root-file-system user-processes))
|
||||
(provision '(cow-store))
|
||||
(documentation
|
||||
"Make the store copy-on-write, with writes going to \
|
||||
(service
|
||||
(requirement '(root-file-system user-processes))
|
||||
(provision '(cow-store))
|
||||
(documentation
|
||||
"Make the store copy-on-write, with writes going to \
|
||||
the given target.")
|
||||
|
||||
;; This is meant to be explicitly started by the user.
|
||||
(auto-start? #f)
|
||||
;; This is meant to be explicitly started by the user.
|
||||
(auto-start? #f)
|
||||
|
||||
(start #~(case-lambda
|
||||
((target)
|
||||
#$(make-cow-store #~target)
|
||||
target)
|
||||
(else
|
||||
;; Do nothing, and mark the service as stopped.
|
||||
#f)))
|
||||
(stop #~(lambda (target)
|
||||
;; Delete the temporary directory, but leave everything
|
||||
;; mounted as there may still be processes using it
|
||||
;; since 'user-processes' doesn't depend on us. The
|
||||
;; 'user-unmount' service will unmount TARGET
|
||||
;; eventually.
|
||||
(delete-file-recursively
|
||||
(string-append target #$%backing-directory))))))))
|
||||
(start #~(case-lambda
|
||||
((target)
|
||||
#$(make-cow-store #~target)
|
||||
target)
|
||||
(else
|
||||
;; Do nothing, and mark the service as stopped.
|
||||
#f)))
|
||||
(stop #~(lambda (target)
|
||||
;; Delete the temporary directory, but leave everything
|
||||
;; mounted as there may still be processes using it
|
||||
;; since 'user-processes' doesn't depend on us. The
|
||||
;; 'user-unmount' service will unmount TARGET
|
||||
;; eventually.
|
||||
(delete-file-recursively
|
||||
(string-append target #$%backing-directory))))))
|
||||
|
||||
(define (configuration-template-service)
|
||||
"Return a dummy service whose purpose is to install an operating system
|
||||
|
|
@ -204,25 +203,24 @@ 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
|
||||
(requirement '(root-file-system))
|
||||
(provision '(os-config-template))
|
||||
(documentation
|
||||
"This dummy service installs an OS configuration template.")
|
||||
(start #~(const #t))
|
||||
(stop #~(const #f))
|
||||
(activate
|
||||
#~(begin
|
||||
(use-modules (ice-9 match)
|
||||
(guix build utils))
|
||||
(service
|
||||
(requirement '(root-file-system))
|
||||
(provision '(os-config-template))
|
||||
(documentation
|
||||
"This dummy service installs an OS configuration template.")
|
||||
(start #~(const #t))
|
||||
(stop #~(const #f))
|
||||
(activate
|
||||
#~(begin
|
||||
(use-modules (ice-9 match)
|
||||
(guix build utils))
|
||||
|
||||
(mkdir-p "/etc/configuration")
|
||||
(for-each (match-lambda
|
||||
((file target)
|
||||
(unless (file-exists? target)
|
||||
(copy-file file target))))
|
||||
'#$templates)))))))
|
||||
(mkdir-p "/etc/configuration")
|
||||
(for-each (match-lambda
|
||||
((file target)
|
||||
(unless (file-exists? target)
|
||||
(copy-file file target))))
|
||||
'#$templates)))))
|
||||
|
||||
(define %nscd-minimal-caches
|
||||
;; Minimal in-memory caching policy for nscd.
|
||||
|
|
|
|||
Reference in New Issue