diff options
Diffstat (limited to 'gnu/services')
| -rw-r--r-- | gnu/services/base.scm | 187 | ||||
| -rw-r--r-- | gnu/services/cuirass.scm | 11 | ||||
| -rw-r--r-- | gnu/services/networking.scm | 205 |
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 |