summaryrefslogtreecommitdiff
path: root/gnu/services
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/services')
-rw-r--r--gnu/services/base.scm187
-rw-r--r--gnu/services/cuirass.scm11
-rw-r--r--gnu/services/networking.scm205
3 files changed, 244 insertions, 159 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 1b1ce0d5e8..d9f3a1445e 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2015, 2016 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
@@ -99,6 +99,18 @@
%default-authorized-guix-keys
guix-configuration
guix-configuration?
+
+ guix-configuration-guix
+ guix-configuration-build-group
+ guix-configuration-build-accounts
+ guix-configuration-authorize-key?
+ guix-configuration-authorized-keys
+ guix-configuration-use-substitutes?
+ guix-configuration-substitute-urls
+ guix-configuration-extra-options
+ guix-configuration-log-file
+ guix-configuration-lsof
+
guix-service
guix-service-type
guix-publish-configuration
@@ -301,13 +313,26 @@ FILE-SYSTEM."
#:select (mount-file-system))
,@%default-modules)))))))
+(define (file-system-shepherd-services file-systems)
+ "Return the list of Shepherd services for FILE-SYSTEMS."
+ (let* ((file-systems (filter file-system-mount? file-systems)))
+ (define sink
+ (shepherd-service
+ (provision '(file-systems))
+ (requirement (cons* 'root-file-system 'user-file-systems
+ (map file-system->shepherd-service-name
+ file-systems)))
+ (documentation "Target for all the initially-mounted file systems")
+ (start #~(const #t))
+ (stop #~(const #f))))
+
+ (cons sink (map file-system-shepherd-service file-systems))))
+
(define file-system-service-type
(service-type (name 'file-systems)
(extensions
(list (service-extension shepherd-root-service-type
- (lambda (file-systems)
- (filter-map file-system-shepherd-service
- file-systems)))
+ file-system-shepherd-services)
(service-extension fstab-service-type
identity)))
(compose concatenate)
@@ -354,93 +379,89 @@ in KNOWN-MOUNT-POINTS when it is stopped."
(define user-processes-service-type
(shepherd-service-type
'user-processes
- (match-lambda
- ((requirements grace-delay)
- (shepherd-service
- (documentation "When stopped, terminate all user processes.")
- (provision '(user-processes))
- (requirement (cons* 'root-file-system 'user-file-systems
- (map file-system->shepherd-service-name
- 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 (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 lset= (@ (srfi srfi-1) lset=))
-
- (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)))
-
- (let wait ()
- (let ((pids (processes)))
- (unless (lset= = pids (cons 1 omitted-pids))
- (format #t "waiting for process termination\
+ (lambda (grace-delay)
+ (shepherd-service
+ (documentation "When stopped, terminate all user processes.")
+ (provision '(user-processes))
+ (requirement '(file-systems))
+ (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 (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 lset= (@ (srfi srfi-1) lset=))
+
+ (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)))
+
+ (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* (user-processes-service file-systems #:key (grace-delay 4))
+(define* (user-processes-service #:key (grace-delay 4))
"Return the service that is responsible for terminating all the processes so
that the root file system can be re-mounted read-only, just before
rebooting/halting. Processes still running GRACE-DELAY seconds after SIGTERM
has been sent are terminated with SIGKILL.
-The returned service will depend on 'root-file-system' and on all the shepherd
-services corresponding to FILE-SYSTEMS.
+The returned service will depend on 'file-systems', meaning that it is
+considered started after all the auto-mount file systems have been mounted.
All the services that spawn processes must depend on this one so that they are
stopped before 'kill' is called."
- (service user-processes-service-type
- (list (filter file-system-mount? file-systems) grace-delay)))
+ (service user-processes-service-type grace-delay))
;;;
@@ -1525,8 +1546,10 @@ This service is not part of @var{%base-services}."
(mingetty-service (mingetty-configuration
(tty "tty6")))
- (static-networking-service "lo" "127.0.0.1"
- #:provision '(loopback))
+ (service static-networking-service-type
+ (list (static-networking (interface "lo")
+ (ip "127.0.0.1")
+ (provision '(loopback)))))
(syslog-service)
(urandom-seed-service)
(guix-service)
diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm
index 1194133f63..237f71a09b 100644
--- a/gnu/services/cuirass.scm
+++ b/gnu/services/cuirass.scm
@@ -64,7 +64,9 @@
(use-substitutes? cuirass-configuration-use-substitutes? ;boolean
(default #f))
(one-shot? cuirass-configuration-one-shot? ;boolean
- (default #f)))
+ (default #f))
+ (load-path cuirass-configuration-load-path
+ (default '())))
(define (cuirass-shepherd-service config)
"Return a <shepherd-service> for the Cuirass service with CONFIG."
@@ -80,7 +82,8 @@
(port (cuirass-configuration-port config))
(specs (cuirass-configuration-specifications config))
(use-substitutes? (cuirass-configuration-use-substitutes? config))
- (one-shot? (cuirass-configuration-one-shot? config)))
+ (one-shot? (cuirass-configuration-one-shot? config))
+ (load-path (cuirass-configuration-load-path config)))
(list (shepherd-service
(documentation "Run Cuirass.")
(provision '(cuirass))
@@ -94,7 +97,9 @@
"--port" #$(number->string port)
"--interval" #$(number->string interval)
#$@(if use-substitutes? '("--use-substitutes") '())
- #$@(if one-shot? '("--one-shot") '()))
+ #$@(if one-shot? '("--one-shot") '())
+ #$@(if (null? load-path) '()
+ `("--load-path" ,(string-join load-path ":"))))
#:user #$user
#:group #$group
#:log-file #$log-file))
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index f7412ff29e..766d979f3e 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -42,6 +42,13 @@
#:use-module (ice-9 match)
#:export (%facebook-host-aliases
static-networking
+
+ static-networking?
+ static-networking-interface
+ static-networking-ip
+ static-networking-netmask
+ static-networking-gateway
+
static-networking-service
static-networking-service-type
dhcp-client-service
@@ -121,88 +128,138 @@ fe80::1%lo0 apps.facebook.com\n")
(ip static-networking-ip)
(netmask static-networking-netmask
(default #f))
- (gateway static-networking-gateway)
- (provision static-networking-provision)
- (name-servers static-networking-name-servers))
+ (gateway static-networking-gateway ;FIXME: doesn't belong here
+ (default #f))
+ (provision static-networking-provision
+ (default #f))
+ (name-servers static-networking-name-servers ;FIXME: doesn't belong here
+ (default '())))
+
+(define static-networking-shepherd-service
+ (match-lambda
+ (($ <static-networking> interface ip netmask gateway provision
+ name-servers)
+ (let ((loopback? (and provision (memq 'loopback provision))))
+ (shepherd-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)))
+
+ (documentation
+ "Bring up the networking interface using a static IP address.")
+ (provision (or provision
+ (list (symbol-append 'networking-
+ (string->symbol interface)))))
+
+ (start #~(lambda _
+ ;; Return #t if successfully started.
+ (let* ((addr (inet-pton AF_INET #$ip))
+ (sockaddr (make-socket-address AF_INET addr 0))
+ (mask (and #$netmask
+ (inet-pton AF_INET #$netmask)))
+ (maskaddr (and mask
+ (make-socket-address AF_INET
+ mask 0)))
+ (gateway (and #$gateway
+ (inet-pton AF_INET #$gateway)))
+ (gatewayaddr (and gateway
+ (make-socket-address AF_INET
+ gateway 0))))
+ (configure-network-interface #$interface sockaddr
+ (logior IFF_UP
+ #$(if loopback?
+ #~IFF_LOOPBACK
+ 0))
+ #:netmask maskaddr)
+ (when gateway
+ (let ((sock (socket AF_INET SOCK_DGRAM 0)))
+ (add-network-route/gateway sock gatewayaddr)
+ (close-port sock))))))
+ (stop #~(lambda _
+ ;; Return #f is successfully stopped.
+ (let ((sock (socket AF_INET SOCK_STREAM 0)))
+ (when #$gateway
+ (delete-network-route sock
+ (make-socket-address
+ AF_INET INADDR_ANY 0)))
+ (set-network-interface-flags sock #$interface 0)
+ (close-port sock)
+ #f)))
+ (respawn? #f))))))
+
+(define (static-networking-etc-files interfaces)
+ "Return a /etc/resolv.conf entry for INTERFACES or the empty list."
+ (match (delete-duplicates
+ (append-map static-networking-name-servers
+ interfaces))
+ (()
+ '())
+ ((name-servers ...)
+ (let ((content (string-join
+ (map (cut string-append "nameserver " <>)
+ name-servers)
+ "\n" 'suffix)))
+ `(("resolv.conf"
+ ,(plain-file "resolv.conf"
+ (string-append "\
+# Generated by 'static-networking-service'.\n"
+ content))))))))
+
+(define (static-networking-shepherd-services interfaces)
+ "Return the list of Shepherd services to bring up INTERFACES, a list of
+<static-networking> objects."
+ (define (loopback? service)
+ (memq 'loopback (shepherd-service-provision service)))
+
+ (let ((services (map static-networking-shepherd-service interfaces)))
+ (match (remove loopback? services)
+ (()
+ ;; There's no interface other than 'loopback', so we assume that the
+ ;; 'networking' service will be provided by dhclient or similar.
+ services)
+ ((non-loopback ...)
+ ;; Assume we're providing all the interfaces, and thus, provide a
+ ;; 'networking' service.
+ (cons (shepherd-service
+ (provision '(networking))
+ (requirement (append-map shepherd-service-provision
+ services))
+ (start #~(const #t))
+ (stop #~(const #f))
+ (documentation "Bring up all the networking interfaces."))
+ services)))))
(define static-networking-service-type
- (shepherd-service-type
- 'static-networking
- (match-lambda
- (($ <static-networking> interface ip netmask gateway provision
- name-servers)
- (let ((loopback? (memq 'loopback provision)))
- (shepherd-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)))
-
- (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))
- (mask (and #$netmask
- (inet-pton AF_INET #$netmask)))
- (maskaddr (and mask
- (make-socket-address AF_INET
- mask 0)))
- (gateway (and #$gateway
- (inet-pton AF_INET #$gateway)))
- (gatewayaddr (and gateway
- (make-socket-address AF_INET
- gateway 0))))
- (configure-network-interface #$interface sockaddr
- (logior IFF_UP
- #$(if loopback?
- #~IFF_LOOPBACK
- 0))
- #:netmask maskaddr)
- (when gateway
- (let ((sock (socket AF_INET SOCK_DGRAM 0)))
- (add-network-route/gateway sock gatewayaddr)
- (close-port sock))))
-
- #$(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))
- #t)))
- (stop #~(lambda _
- ;; Return #f is successfully stopped.
- (let ((sock (socket AF_INET SOCK_STREAM 0)))
- (when #$gateway
- (delete-network-route sock
- (make-socket-address
- AF_INET INADDR_ANY 0)))
- (set-network-interface-flags sock #$interface 0)
- (close-port sock)
- #f)))
- (respawn? #f)))))))
+ ;; The service type for statically-defined network interfaces.
+ (service-type (name 'static-networking)
+ (extensions
+ (list
+ (service-extension shepherd-root-service-type
+ static-networking-shepherd-services)
+ (service-extension etc-service-type
+ static-networking-etc-files)))
+ (compose concatenate)
+ (extend append)))
(define* (static-networking-service interface ip
#:key
- netmask gateway
- (provision '(networking))
+ netmask gateway provision
(name-servers '()))
"Return a service that starts @var{interface} with address @var{ip}. If
@var{netmask} is true, use it as the network mask. If @var{gateway} is true,
-it must be a string specifying the default network gateway."
- (service static-networking-service-type
- (static-networking (interface interface) (ip ip)
- (netmask netmask) (gateway gateway)
- (provision provision)
- (name-servers name-servers))))
+it must be a string specifying the default network gateway.
+
+This procedure can be called several times, one for each network
+interface of interest. Behind the scenes what it does is extend
+@code{static-networking-service-type} with additional network interfaces
+to handle."
+ (simple-service 'static-network-interface
+ static-networking-service-type
+ (list (static-networking (interface interface) (ip ip)
+ (netmask netmask) (gateway gateway)
+ (provision provision)
+ (name-servers name-servers)))))
(define dhcp-client-service-type
(shepherd-service-type
generated by cgit v1.2.3 (git 2.46.0) at 2024-08-05 08:44:40 +0000