01/07: services: Make 'static-networking' extensible.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 8de3e4b35f98571be39f9c0a95bfdc630ac2d266
Author: Ludovic Courtès <address@hidden>
Date:   Wed Feb 1 17:09:54 2017 +0100

    services: Make 'static-networking' extensible.
    
    This allows users to statically define several interfaces.
    
    * gnu/services/networking.scm (<static-networking>)[provision]
    [name-servers]: Add default values.
    (static-networking-shepherd-service)
    (static-networking-etc-files)
    (static-networking-shepherd-services): New procedures.
    (static-networking-service-type): Change to extend both
    SHEPHERD-ROOT-SERVICE-TYPE and ETC-SERVICE-TYPE.
    (static-networking-service): Remove default value of #:provision.
    Implement using 'simple-service'.
    * gnu/services/base.scm (%base-services): Replace
    'static-networking-service' call with 'service' form.
    * doc/guix.texi (Networking Services): Update documentation.
---
 doc/guix.texi               |   10 +++
 gnu/services/base.scm       |    6 +-
 gnu/services/networking.scm |  205 +++++++++++++++++++++++++++----------------
 3 files changed, 145 insertions(+), 76 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 4ba1010..fb0bbc0 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -8786,11 +8786,21 @@ Return a service that runs @var{dhcp}, a Dynamic Host 
Configuration
 Protocol (DHCP) client, on all the non-loopback network interfaces.
 @end deffn
 
address@hidden {Scheme Variable} static-networking-service-type
+This is the type for statically-configured network interfaces.
address@hidden TODO Document <static-networking> data structures.
address@hidden defvr
+
 @deffn {Scheme Procedure} static-networking-service @var{interface} @var{ip} @
        [#:netmask #f] [#:gateway #f] [#:name-servers @code{'()}]
 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.
+
+This procedure can be called several times, one for each network
+interface of interest.  Behind the scenes what it does is extend
address@hidden with additional network interfaces
+to handle.
 @end deffn
 
 @cindex wicd
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index ecabf78..d9f3a14 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -1546,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/networking.scm b/gnu/services/networking.scm
index f7412ff..766d979 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
address@hidden 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