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>

3 files changed, 330 insertions, 16 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index ad26a29513..dc16ec1d15 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -20453,20 +20453,75 @@ IP address (a string) through which traffic is routed.
 
 @deftp {Data Type} network-link
 Data type for a network link (@pxref{Link,,, guile-netlink,
-Guile-Netlink Manual}).
+Guile-Netlink Manual}).  During startup, network links are employed to
+construct or modify existing or virtual ethernet links.  These ethernet
+links can be identified by their @var{name} or @var{mac-address}.  If
+there is a need to create virtual interface, @var{name} and @var{type}
+fields are required.
 
 @table @code
 @item name
-The name of the link---e.g., @code{"v0p0"}.
+The name of the link---e.g., @code{"v0p0"} (default: @code{#f}).
 
 @item type
-A symbol denoting the type of the link---e.g., @code{'veth}.
+A symbol denoting the type of the link---e.g., @code{'veth} (default: @code{#f}).
+
+@item mac-address
+The mac-address of the link---e.g., @code{"98:11:22:33:44:55"} (default: @code{#f}).
 
 @item arguments
 List of arguments for this type of link.
 @end table
 @end deftp
 
+Consider a scenario where a server equipped with a network interface
+which has multiple ports.  These ports are connected to a switch, which
+supports @uref{https://en.wikipedia.org/wiki/Link_aggregation, link
+aggregation} (also known as bonding or NIC teaming).  The switch uses
+port channels to consolidate multiple physical interfaces into one
+logical interface to provide higher bandwidth, load balancing, and link
+redundancy.  When a port is added to a LAG (or link aggregation group),
+it inherits the properties of the port-channel.  Some of these
+properties are VLAN membership, trunk status, and so on.
+
+@uref{https://en.wikipedia.org/wiki/Virtual_LAN, VLAN} (or virtual local
+area network) is a logical network that is isolated from other VLANs on
+the same physical network.  This can be used to segregate traffic,
+improve security, and simplify network management.
+
+With all that in mind let's configure our static network for the server.
+We will bond two existing interfaces together using 802.3ad schema and on
+top of it, build a VLAN interface with id 1055.  We assign a static ip
+to our new VLAN interface.
+
+@lisp
+(static-networking
+ (links (list (network-link
+               (name "bond0")
+               (type 'bond)
+               (arguments '((mode . "802.3ad")
+                            (miimon . 100)
+                            (lacp-active . "on")
+                            (lacp-rate . "fast"))))
+
+              (network-link
+               (mac-address "98:11:22:33:44:55")
+               (arguments '((master . "bond0"))))
+
+              (network-link
+               (mac-address "98:11:22:33:44:56")
+               (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")))))
+@end lisp
+
 @cindex loopback device
 @defvar %loopback-static-networking
 This is the @code{static-networking} record representing the ``loopback
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.