services: static-networking: Add support for bonding.

* gnu/services/base.scm (<network-link>): Add mac-address field. Set
type field to #f by default, so it won't be mandatory. network-link
without a type will be used for existing interfaces.
(assert-network-link-mac-address, mac-address?): Add sanitizer. Allow
valid mac-address or #f.
(assert-network-link-type): Add sanitizer. Allow symbol or #f.
* gnu/services/base.scm (network-set-up/linux,
network-tear-down/linux): Adapt to new structure.
* doc/guix.texi (Networking Setup): Document it.
* gnu/tests/networking.scm (run-static-networking-advanced-test): New
variable.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>

2 files changed, 272 insertions, 13 deletions

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 98d59fd36d..82c6940780 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -2692,6 +2692,33 @@ Write, say, @samp{\"~a/24\"} for a 24-bit network mask.")
                                 address)))))))
   address)
 
+(define (mac-address? str)
+  "Return true if STR is a valid MAC address."
+  (let ((pattern (make-regexp "^([0-9A-Fa-f]{2}:?){6}$")))
+    (false-if-exception (vector? (regexp-exec pattern str)))))
+
+(define-compile-time-procedure (assert-network-link-mac-address (value identity))
+  (cond
+   ((eq? value #f) value)
+   ((and (string? value) (mac-address? value)) value)
+   (else (raise
+          (make-compound-condition
+           (formatted-message (G_ "Value (~S) is not a valid mac address.~%")
+                              value)
+           (condition (&error-location
+                       (location (source-properties->location procedure-call-location)))))))))
+
+(define-compile-time-procedure (assert-network-link-type (value identity))
+  (match value
+    (#f value)
+    (('quote _) (datum->syntax #'value value))
+    (else
+     (raise
+      (make-compound-condition
+       (formatted-message (G_ "Value (~S) is not a symbol.~%") value)
+       (condition (&error-location
+                   (location (source-properties->location procedure-call-location)))))))))
+
 (define-record-type* <static-networking>
   static-networking make-static-networking
   static-networking?
@@ -2719,8 +2746,14 @@ Write, say, @samp{\"~a/24\"} for a 24-bit network mask.")
 (define-record-type* <network-link>
   network-link make-network-link
   network-link?
-  (name      network-link-name)                   ;string--e.g, "v0p0"
-  (type      network-link-type)                   ;symbol--e.g.,'veth
+  (name      network-link-name
+             (default #f))                   ;string or #f --e.g, "v0p0"
+  (type      network-link-type
+             (sanitize assert-network-link-type)
+             (default #f))                   ;symbol or #f--e.g.,'veth, 'bond
+  (mac-address network-link-mac-address
+               (sanitize assert-network-link-mac-address)
+               (default #f))
   (arguments network-link-arguments))             ;list
 
 (define-record-type* <network-route>
@@ -2845,7 +2878,77 @@ to CONFIG."
     (scheme-file "set-up-network"
                  (with-extensions (list guile-netlink)
                    #~(begin
-                       (use-modules (ip addr) (ip link) (ip route))
+                       (use-modules (ip addr) (ip link) (ip route)
+                                    (srfi srfi-1)
+                                    (ice-9 format)
+                                    (ice-9 match))
+
+                       (define (match-link-by field-accessor value)
+                         (fold (lambda (link result)
+                                 (if (equal? (field-accessor link) value)
+                                     link
+                                     result))
+                               #f
+                               (get-links)))
+
+                       (define (alist->keyword+value alist)
+                         (fold (match-lambda*
+                                 (((k . v) r)
+                                  (cons* (symbol->keyword k) v r))) '() alist))
+
+                       ;; FIXME: It is interesting that "modprobe bonding" creates an
+                       ;; interface bond0 straigt away.  If we won't have bonding
+                       ;; module, and execute `ip link add name bond0 type bond' we
+                       ;; will get
+                       ;;
+                       ;; RTNETLINK answers: File exists
+                       ;;
+                       ;; This breaks our configuration if we want to
+                       ;; use `bond0' name.  Create (force modprobe
+                       ;; bonding) and delete the interface to free up
+                       ;; bond0 name.
+                       #$(let lp ((links links))
+                           (cond
+                            ((null? links) #f)
+                            ((and (network-link? (car links))
+                                  ;; Type is not mandatory
+                                  (false-if-exception
+                                   (eq? (network-link-type (car links)) 'bond)))
+                             #~(begin
+                                 (false-if-exception (link-add "bond0" "bond"))
+                                 (link-del "bond0")))
+                            (else (lp (cdr links)))))
+
+                       #$@(map (match-lambda
+                                 (($ <network-link> name type mac-address arguments)
+                                  (cond
+                                   ;; Create a new interface
+                                   ((and (string? name) (symbol? type))
+                                    #~(begin
+                                        (link-add #$name (symbol->string '#$type) #:type-args '#$arguments)
+                                        ;; XXX: If we add routes, addresses must be
+                                        ;; already assigned, and interfaces must be
+                                        ;; up. It doesn't matter if they won't have
+                                        ;; carrier or anything.
+                                        (link-set #$name #:up #t)))
+
+                                   ;; Amend an existing interface
+                                   ((and (string? name)
+                                         (eq? type #f))
+                                    #~(let ((link (match-link-by link-name #$name)))
+                                        (if link
+                                            (apply link-set
+                                                   (link-id link)
+                                                   (alist->keyword+value '#$arguments))
+                                            (format #t (G_ "Interface with name '~a' not found~%") #$name))))
+                                   ((string? mac-address)
+                                    #~(let ((link (match-link-by link-addr #$mac-address)))
+                                        (if link
+                                            (apply link-set
+                                                   (link-id link)
+                                                   (alist->keyword+value '#$arguments))
+                                            (format #t (G_ "Interface with mac-address '~a' not found~%") #$mac-address)))))))
+                                        links)
 
                        #$@(map (lambda (address)
                                  #~(begin
@@ -2864,11 +2967,7 @@ to CONFIG."
                                                #:multicast-on #t
                                                #:up #t)))
                                addresses)
-                       #$@(map (match-lambda
-                                 (($ <network-link> name type arguments)
-                                  #~(link-add #$name #$type
-                                              #:type-args '#$arguments)))
-                               links)
+
                        #$@(map (lambda (route)
                                  #~(route-add #$(network-route-destination route)
                                               #:device
@@ -2912,11 +3011,9 @@ to CONFIG."
                                                #:src
                                                #$(network-route-source route))))
                                routes)
-                       #$@(map (match-lambda
-                                 (($ <network-link> name type arguments)
-                                  #~(false-if-netlink-error
-                                     (link-del #$name))))
-                               links)
+
+                       ;; Cleanup addresses first, they might be assigned to
+                       ;; created bonds, vlans or bridges.
                        #$@(map (lambda (address)
                                  #~(false-if-netlink-error
                                     (addr-del #$(network-address-device
@@ -2925,6 +3022,17 @@ to CONFIG."
                                               #:ipv6?
                                               #$(network-address-ipv6? address))))
                                addresses)
+
+                       ;; It is now safe to delete some links
+                       #$@(map (match-lambda
+                                 (($ <network-link> name type mac-address arguments)
+                                  (cond
+                                   ;; We delete interfaces that were created
+                                   ((and (string? name) (symbol? type))
+                                    #~(false-if-netlink-error
+                                       (link-del #$name)))
+                                   (else #t))))
+                               links)
                        #f)))))
 
 (define (static-networking-shepherd-service config)
diff --git a/gnu/tests/networking.scm b/gnu/tests/networking.scm
index a192c7e655..52f818af48 100644
--- a/gnu/tests/networking.scm
+++ b/gnu/tests/networking.scm
@@ -39,6 +39,7 @@
   #:use-module (gnu services shepherd)
   #:use-module (ice-9 match)
   #:export (%test-static-networking
+            %test-static-networking-advanced
             %test-inetd
             %test-openvswitch
             %test-dhcpd
@@ -124,6 +125,156 @@
                                     (guix combinators)))))
       (run-static-networking-test (virtual-machine os))))))
 
+(define (run-static-networking-advanced-test vm)
+  (define test
+    (with-imported-modules '((gnu build marionette)
+                             (guix build syscalls))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (guix build syscalls)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette
+             '(#$vm "-net" "nic,model=e1000,macaddr=98:11:22:33:44:55"
+                    "-net" "nic,model=e1000,macaddr=98:11:22:33:44:56")))
+
+          (test-runner-current (system-test-runner #$output))
+          (test-begin "static-networking-advanced")
+
+          (test-assert "service is up"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (start-service 'networking))
+             marionette))
+
+          (test-assert "network interfaces"
+            (marionette-eval
+             '(begin
+                (use-modules (guix build syscalls))
+                (network-interface-names))
+             marionette))
+
+          (test-equal "bond0 bonding mode"
+            "802.3ad 4"
+            (marionette-eval
+             '(begin
+                (use-modules (ice-9 rdelim))
+                (call-with-input-file "/sys/class/net/bond0/bonding/mode" read-line))
+             marionette))
+
+          (test-equal "bond0 bonding lacp_rate"
+            "fast 1"
+            (marionette-eval
+             '(begin
+                (use-modules (ice-9 rdelim))
+                (call-with-input-file "/sys/class/net/bond0/bonding/lacp_rate" read-line))
+             marionette))
+
+          (test-equal "bond0 bonding miimon"
+            "100"
+            (marionette-eval
+             '(begin
+                (use-modules (ice-9 rdelim))
+                (call-with-input-file "/sys/class/net/bond0/bonding/miimon" read-line))
+             marionette))
+
+          (test-equal "bond0 bonding slaves"
+            "a b"
+            (marionette-eval
+             '(begin
+                (use-modules (ice-9 rdelim))
+                (call-with-input-file "/sys/class/net/bond0/bonding/slaves" read-line))
+             marionette))
+
+          ;; The hw mac address will come from the first slave bonded to the
+          ;; channel.
+          (test-equal "bond0 mac address"
+            "98:11:22:33:44:55"
+            (marionette-eval
+             '(begin
+                (use-modules (ice-9 rdelim))
+                (call-with-input-file "/sys/class/net/bond0/address" read-line))
+             marionette))
+
+          (test-equal "bond0.1055 is up"
+            IFF_UP
+            (marionette-eval
+             '(let* ((sock  (socket AF_INET SOCK_STREAM 0))
+                     (flags (network-interface-flags sock "bond0.1055")))
+                (logand flags IFF_UP))
+             marionette))
+
+          (test-equal "bond0.1055 address is correct"
+            "192.168.1.4"
+            (marionette-eval
+             '(let* ((sock (socket AF_INET SOCK_STREAM 0))
+                     (addr (network-interface-address sock "bond0.1055")))
+                (close-port sock)
+                (inet-ntop (sockaddr:fam addr) (sockaddr:addr addr)))
+             marionette))
+
+          (test-equal "bond0.1055 netmask is correct"
+            "255.255.255.0"
+            (marionette-eval
+             '(let* ((sock (socket AF_INET SOCK_STREAM 0))
+                     (mask (network-interface-netmask sock "bond0.1055")))
+                (close-port sock)
+                (inet-ntop (sockaddr:fam mask) (sockaddr:addr mask)))
+             marionette))
+          (test-end))))
+
+  (gexp->derivation "static-networking-advanced" test))
+
+(define %test-static-networking-advanced
+  (system-test
+   (name "static-networking-advanced")
+   (description "Test the 'static-networking' service with advanced features like bonds, vlans etc...")
+   (value
+    (let ((os (marionette-operating-system
+               (simple-operating-system
+                (service static-networking-service-type
+                         (list (static-networking
+                                (links (list
+
+                                        (network-link
+                                         (mac-address "98:11:22:33:44:55")
+                                         (arguments '((name . "a"))))
+
+                                        (network-link
+                                         (mac-address "98:11:22:33:44:56")
+                                         (arguments '((name . "b"))))
+
+                                        (network-link
+                                         (name "bond0")
+                                         (type 'bond)
+                                         (arguments '((mode . "802.3ad")
+                                                      (miimon . 100)
+                                                      (lacp-active . "on")
+                                                      (lacp-rate . "fast"))))
+
+                                        (network-link
+                                         (name "a")
+                                         (arguments '((master . "bond0"))))
+
+                                        (network-link
+                                         (name "b")
+                                         (arguments '((master . "bond0"))))
+
+                                        (network-link
+                                         (name "bond0.1055")
+                                         (type 'vlan)
+                                         (arguments '((id . 1055)
+                                                      (link . "bond0"))))))
+
+                                (addresses (list (network-address
+                                                  (value "192.168.1.4/24")
+                                                  (device "bond0.1055"))))))))
+               #:imported-modules '((gnu services herd)
+                                    (guix combinators)))))
+      (run-static-networking-advanced-test (virtual-machine os))))))
+
 
 ;;;
 ;;; Inetd.