guile-netlink

link.scm

;;;; This file is part of Guile Netlink
;;;;
;;;; Copyright (C) 2021 Julien Lepiller <julien@lepiller.eu>
;;;; 
;;;; This library is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this library.  If not, see <https://www.gnu.org/licenses/>.

(define-module (ip link)
  #:use-module (ice-9 match)
  #:use-module (ip utils)
  #:use-module (netlink route attrs)
  #:use-module (netlink route link)
  #:use-module (netlink connection)
  #:use-module (netlink constant)
  #:use-module (netlink data)
  #:use-module (netlink error)
  #:use-module (netlink deserialize)
  #:use-module (netlink message)
  #:use-module (netlink standard)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:export (link-add
            link-del
            link-set
            link-show
            link-name->index
            get-links
            print-link

            <link> make-link link?
            link-name link-id link-type link-flags link-mtu link-qdisc
            link-state link-mode link-group link-qlen link-addr link-brd))

(define-record-type <link>
  (make-link name id type flags mtu qdisc state mode group qlen addr brd)
  link?
  (name  link-name)
  (id    link-id)
  (type  link-type)
  (flags link-flags)
  (mtu   link-mtu)
  (qdisc link-qdisc)
  (state link-state)
  (mode  link-mode)
  (group link-group)
  (qlen  link-qlen)
  (addr  link-addr)
  (brd   link-brd))

(define (get-links)
  (define request-num (random 65535))
  (define message
    (make-message
      RTM_GETLINK
      (logior NLM_F_REQUEST NLM_F_DUMP)
      request-num
      0
      (make-link-message AF_UNSPEC 0 0 0 0 '())))

  (let ((sock (connect-route)))
    (send-msg message sock)
    (let* ((answer (receive-and-decode-msg sock %default-route-decoder))
           (links (filter
                    (lambda (msg) (equal? (message-kind msg) RTM_NEWLINK))
                    answer))
           (links
             (map
               (lambda (msg)
                 (let* ((data (message-data msg))
                        (attrs (link-message-attrs data)))
                 (make-link
                   (get-attr attrs IFLA_IFNAME)
                   (link-message-index data)
                   (link-message-kind data)
                   (map int->device-flags (split-flags (link-message-flags data)))
                   (get-attr attrs IFLA_MTU)
                   (get-attr attrs IFLA_QDISC)
                   (get-attr attrs IFLA_OPERSTATE)
                   (get-attr attrs IFLA_LINKMODE)
                   (get-attr attrs IFLA_GROUP)
                   (get-attr attrs IFLA_TXQLEN)
                   (get-attr attrs IFLA_ADDRESS)
                   (get-attr attrs IFLA_BROADCAST))))
               links)))
      (close-socket sock)
      links)))

(define print-link
  (match-lambda
    (($ <link> name id type flags mtu qdisc state mode group qlen addr brd)
     (format #t "~a: ~a: <~a>" id name
             (string-join 
               (map
                 (lambda (s)
                   ;; IFF_UP -> UP
                   (substring (symbol->string s) 4))
                 flags)
               ","))
     (when mtu
       (format #t " mtu ~a" mtu))
     (when qdisc
       (format #t " qdisc ~a" qdisc))
     (when state
       (format #t " state ~a"
               (substring (symbol->string (int->operstate state)) 8)))
     (when mode
       (format #t " mode ~a" (match mode (0 "DEFAULT") (1 "DORMANT"))))
     (when group
       (format #t " group ~a" (match group (0 "DEFAULT"))))
     (when qlen
       (format #t " qlen ~a" qlen))
     (newline)
     (cond
       ((equal? type ARPHRD_ETHER)
        (format #t "    link/ether ~a brd ~a~%" addr brd))
       ((equal? type ARPHRD_LOOPBACK)
        (format #t "    link/loopback ~a brd ~a~%" addr brd))))))

(define* (link-show #:key (device #f) (group #f) (up #f) (master #f) (vrf #f)
                    (type #f))
  "Return a list whose elements represent the data about the links.  If a key
is given, the resulting list is limited to those elements that match the given
criteria."
  (for-each
    (lambda (link)
      (match link
        (($ <link> lname lid ltype lflags lmtu lqdisc lstate lmode lgroup lqlen laddr lbrd)
         (when (and (or (not device) (equal? device lname))
                    (or (not group) (equal? group lgroup))
                    (or (not up) (member 'IFF_UP lflags))
                    ;(or (not master) ())
                    ;(or (not vrf) ())
                    (or (not type) (equal? type ltype)))
           (print-link link)))))
    (get-links)))

(define (link-name->index device)
  (let loop ((links (get-links)))
    (match links
      (() (throw 'no-such-device device))
      ((link links ...)
       (if (equal? (link-name link) device)
           (link-id link)
           (loop links))))))

(define* (link-set device #:key (up #f) (down #f) (type #f)
                   (arp-on #f) (arp-off #f)
                   (dynamic-on #f) (dynamic-off #f)
                   (multicast-on #f) (multicast-off #f)
                   (allmulticast-on #f) (allmulticast-off #f)
                   (promisc-on #f) (promisc-off #f)
                   (trailers-on #f) (trailers-off #f)
                   (carrier-on #f) (carrier-off #f)
                   (txqueuelen #f) (name #f) (address #f)
                   (broadcast #f) (mtu #f) (netns #f)
                   (master #f))
  (define request-num (random 65535))
  (define id (if (number? device) device (link-name->index device)))
  (define netnsfd (cond
                    ((string? netns)
                     (open (string-append "/var/run/netns/" netns) O_RDONLY))
                    ((number? netns)
                     (open (string-append "/var/run/netns/" (number->string netns))
                           O_RDONLY))
                    (else
                      #f)))
  (define message
    (make-message
      RTM_NEWLINK
      (logior NLM_F_REQUEST NLM_F_ACK)
      request-num
      0
      (make-link-message
        AF_UNSPEC
        (or type 0)
        id
        (+ (if up IFF_UP 0)
           (if arp-off IFF_NOARP 0)
           (if dynamic-on IFF_DYNAMIC 0)
           (if multicast-on IFF_MULTICAST 0)
           (if allmulticast-on IFF_ALLMULTI 0)
           (if promisc-on IFF_PROMISC 0)
           (if trailers-off IFF_NOTRAILERS 0))
        (+ (if (or up down) IFF_UP 0)
           (if (or arp-on arp-off) IFF_NOARP 0)
           (if (or dynamic-on dynamic-off) IFF_DYNAMIC 0)
           (if (or multicast-on multicast-off) IFF_MULTICAST 0)
           (if (or allmulticast-on allmulticast-off) IFF_ALLMULTI 0)
           (if (or promisc-on promisc-off) IFF_PROMISC 0)
           (if (or trailers-on trailers-off) IFF_NOTRAILERS 0))
        `(,@(if (or carrier-on carrier-off)
                (list
                  (make-route-attr IFLA_CARRIER
                    (make-u32-route-attr (if carrier-on 1 0))))
                '())
          ,@(if txqueuelen
                (list
                  (make-route-attr IFLA_TXQLEN
                    (make-u32-route-attr txqueuelen)))
                '())
          ,@(if name
                (list
                  (make-route-attr IFLA_IFNAME
                    (make-string-route-attr name)))
                '())
          ,@(if address
                (list
                  (make-route-attr IFLA_ADDRESS
                    (make-ethernet-route-attr address)))
                '())
          ,@(if broadcast
                (list
                  (make-route-attr IFLA_BROADCAST
                    (make-ethernet-route-attr broadcast)))
                '())
          ,@(if mtu
                (list
                  (make-route-attr IFLA_MTU
                    (make-u32-route-attr mtu)))
                '())
          ,@(if master
                (list
                  (make-route-attr IFLA_MASTER
                    (make-u32-route-attr (link-name->index master))))
                '())
          ,@(if netns
                (list
                  (make-route-attr IFLA_NET_NS_FD
                    (make-u32-route-attr
                      (fileno netnsfd))))
                '())))))
  (let ((sock (connect-route)))
    (send-msg message sock)
    (let ((answer (receive-and-decode-msg sock %default-route-decoder)))
      (when netnsfd
        (close netnsfd))
      (close-socket sock)
      (answer-ok? (last answer)))))

(define* (bond-type-args #:key (mode #f) (miimon #f) (lacp-active #f) (lacp-rate #f)
                         (primary #f) (primary-reselect #f))
  `(,@(if mode
          (list
           (make-route-attr IFLA_BOND_MODE
             (match mode
               ("balance-rr" (make-u8-route-attr BOND_MODE_ROUNDROBIN))
               ("active-backup" (make-u8-route-attr BOND_MODE_ACTIVEBACKUP))
               ("balance-xor" (make-u8-route-attr BOND_MODE_XOR))
               ("broadcast" (make-u8-route-attr BOND_MODE_BROADCAST))
               ("802.3ad" (make-u8-route-attr BOND_MODE_8023AD))
               ("balance-tlb" (make-u8-route-attr BOND_MODE_TLB))
               ("balance-alb" (make-u8-route-attr BOND_MODE_ALB))
               (_ (raise (condition
                          (&message
                           (message "Bond field `mode' can be defined as \
balance-rr|active-backup|balance-xor|broadcast|802.3ad|balance-tlb|balance-alb" ))))))))
          '())
    ,@(if miimon
          (list
           (make-route-attr IFLA_BOND_MIIMON
             (make-u32-route-attr miimon)))
          '())
    ,@(if primary
          (list
           (make-route-attr IFLA_BOND_PRIMARY
             (make-u32-route-attr (link-name->index primary))))
          '())
    ,@(if primary-reselect
          (list
           (make-route-attr IFLA_BOND_PRIMARY_RESELECT
             (match primary-reselect
               ("always" (make-u8-route-attr BOND_PRIMARY_RESELECT_ALWAYS))
               ("better" (make-u8-route-attr BOND_PRIMARY_RESELECT_BETTER))
               ("failure" (make-u8-route-attr BOND_PRIMARY_RESELECT_FAILURE))
               (_ (raise (condition
                          (&message
                           (message "Bond field `primary-reselect' can be defined as always|better|failure" ))))))))
          '())
    ,@(if lacp-active
          (list
           (make-route-attr IFLA_BOND_AD_LACP_ACTIVE
             (match lacp-active
               ("on" (make-u8-route-attr BOND_AD_LACP_ACTIVE_ON))
               ("off" (make-u8-route-attr BOND_AD_LACP_ACTIVE_OFF))
               (_ (raise (condition
                          (&message
                           (message "Bond field `lacp-active' can be defined as off|on" ))))))))
          '())
    ,@(if lacp-rate
          (list
           (make-route-attr IFLA_BOND_AD_LACP_RATE
             (match lacp-rate
               ("slow" (make-u8-route-attr 0))
               ("fast" (make-u8-route-attr 1))
               (_ (raise (condition
                          (&message
                           (message "Bond field `lacp-rate' can be defined as slow|fast"))))))))
          '())))

(define (alist->keyword+value alist)
  (fold (match-lambda*
          (((k . v) r)
           (cons* (symbol->keyword k) v r))) '() alist))

(define* (link-add name type #:key (type-args '()))
  (define request-num (random 65535))
  (define type-data
    (match type
      ("vlan"
       `(,@(if (assoc-ref type-args 'id)
               (list (make-route-attr IFLA_VLAN_ID
                       (make-u16-route-attr (assoc-ref type-args 'id))))
               '())))
      ("veth"
       `(,@(if (assoc-ref type-args 'peer)
               (list (make-route-attr VETH_INFO_PEER
                       (make-link-message
                         AF_UNSPEC 0 0 0 0
                         (list
                           (make-route-attr IFLA_IFNAME
                             (make-string-route-attr
                               (assoc-ref type-args 'peer)))))))
               '())))
      ("bond" (apply bond-type-args (alist->keyword+value type-args)))
      ;; TODO: unsupported for now
      (_ '())))
  (define message
    (make-message
      RTM_NEWLINK
      (logior NLM_F_REQUEST NLM_F_ACK NLM_F_EXCL NLM_F_CREATE)
      request-num
      0
      (make-link-message
        AF_UNSPEC
        0
        0
        0
        0
        `(,(make-route-attr IFLA_IFNAME
            (make-string-route-attr name))
          ,(make-route-attr IFLA_LINKINFO
            (make-nested-route-attr
              (list
                (make-route-attr IFLA_INFO_KIND
                  (make-string-route-attr type))
                (make-route-attr IFLA_INFO_DATA
                  (make-nested-route-attr type-data)))))
          ,@(if (assoc-ref type-args 'link)
                `(,(make-route-attr IFLA_LINK
                     (make-u32-route-attr (link-name->index (assoc-ref type-args 'link)))))
                '())))))
  (let ((sock (connect-route)))
    (send-msg message sock)
    (let ((answer (receive-and-decode-msg sock %default-route-decoder)))
      (close-socket sock)
      (answer-ok? (last answer)))))

(define* (link-del device)
  (define request-num (random 65535))

  (define message
    (make-message
      RTM_DELLINK
      (logior NLM_F_REQUEST NLM_F_ACK)
      request-num
      0
      (make-link-message
        AF_UNSPEC
        0
        (cond
          ((number? device) device)
          ((string? device) (link-name->index device)))
        0
        0
        '())))


  (let ((sock (connect-route)))
    (send-msg message sock)
    (let ((answer (receive-and-decode-msg sock %default-route-decoder)))
      (close-socket sock)
      (answer-ok? (last answer)))))


1	;;;; This file is part of Guile Netlink
2	;;;;
3	;;;; Copyright (C) 2021 Julien Lepiller <julien@lepiller.eu>
4	;;;;
5	;;;; This library is free software: you can redistribute it and/or modify
6	;;;; it under the terms of the GNU General Public License as published by
7	;;;; the Free Software Foundation, either version 3 of the License, or
8	;;;; (at your option) any later version.
9	;;;;
10	;;;; This library is distributed in the hope that it will be useful,
11	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13	;;;; GNU General Public License for more details.
14	;;;;
15	;;;; You should have received a copy of the GNU General Public License
16	;;;; along with this library. If not, see <https://www.gnu.org/licenses/>.
17
18	(define-module (ip link)
19	#:use-module (ice-9 match)
20	#:use-module (ip utils)
21	#:use-module (netlink route attrs)
22	#:use-module (netlink route link)
23	#:use-module (netlink connection)
24	#:use-module (netlink constant)
25	#:use-module (netlink data)
26	#:use-module (netlink error)
27	#:use-module (netlink deserialize)
28	#:use-module (netlink message)
29	#:use-module (netlink standard)
30	#:use-module (srfi srfi-1)
31	#:use-module (srfi srfi-9)
32	#:use-module (srfi srfi-34)
33	#:use-module (srfi srfi-35)
34	#:export (link-add
35	link-del
36	link-set
37	link-show
38	link-name->index
39	get-links
40	print-link
41
42	<link> make-link link?
43	link-name link-id link-type link-flags link-mtu link-qdisc
44	link-state link-mode link-group link-qlen link-addr link-brd))
45
46	(define-record-type <link>
47	(make-link name id type flags mtu qdisc state mode group qlen addr brd)
48	link?
49	(name link-name)
50	(id link-id)
51	(type link-type)
52	(flags link-flags)
53	(mtu link-mtu)
54	(qdisc link-qdisc)
55	(state link-state)
56	(mode link-mode)
57	(group link-group)
58	(qlen link-qlen)
59	(addr link-addr)
60	(brd link-brd))
61
62	(define (get-links)
63	(define request-num (random 65535))
64	(define message
65	(make-message
66	RTM_GETLINK
67	(logior NLM_F_REQUEST NLM_F_DUMP)
68	request-num
69	0
70	(make-link-message AF_UNSPEC 0 0 0 0 '())))
71
72	(let ((sock (connect-route)))
73	(send-msg message sock)
74	(let* ((answer (receive-and-decode-msg sock %default-route-decoder))
75	(links (filter
76	(lambda (msg) (equal? (message-kind msg) RTM_NEWLINK))
77	answer))
78	(links
79	(map
80	(lambda (msg)
81	(let* ((data (message-data msg))
82	(attrs (link-message-attrs data)))
83	(make-link
84	(get-attr attrs IFLA_IFNAME)
85	(link-message-index data)
86	(link-message-kind data)
87	(map int->device-flags (split-flags (link-message-flags data)))
88	(get-attr attrs IFLA_MTU)
89	(get-attr attrs IFLA_QDISC)
90	(get-attr attrs IFLA_OPERSTATE)
91	(get-attr attrs IFLA_LINKMODE)
92	(get-attr attrs IFLA_GROUP)
93	(get-attr attrs IFLA_TXQLEN)
94	(get-attr attrs IFLA_ADDRESS)
95	(get-attr attrs IFLA_BROADCAST))))
96	links)))
97	(close-socket sock)
98	links)))
99
100	(define print-link
101	(match-lambda
102	(($ <link> name id type flags mtu qdisc state mode group qlen addr brd)
103	(format #t "~a: ~a: <~a>" id name
104	(string-join
105	(map
106	(lambda (s)
107	;; IFF_UP -> UP
108	(substring (symbol->string s) 4))
109	flags)
110	","))
111	(when mtu
112	(format #t " mtu ~a" mtu))
113	(when qdisc
114	(format #t " qdisc ~a" qdisc))
115	(when state
116	(format #t " state ~a"
117	(substring (symbol->string (int->operstate state)) 8)))
118	(when mode
119	(format #t " mode ~a" (match mode (0 "DEFAULT") (1 "DORMANT"))))
120	(when group
121	(format #t " group ~a" (match group (0 "DEFAULT"))))
122	(when qlen
123	(format #t " qlen ~a" qlen))
124	(newline)
125	(cond
126	((equal? type ARPHRD_ETHER)
127	(format #t " link/ether ~a brd ~a~%" addr brd))
128	((equal? type ARPHRD_LOOPBACK)
129	(format #t " link/loopback ~a brd ~a~%" addr brd))))))
130
131	(define* (link-show #:key (device #f) (group #f) (up #f) (master #f) (vrf #f)
132	(type #f))
133	"Return a list whose elements represent the data about the links. If a key
134	is given, the resulting list is limited to those elements that match the given
135	criteria."
136	(for-each
137	(lambda (link)
138	(match link
139	(($ <link> lname lid ltype lflags lmtu lqdisc lstate lmode lgroup lqlen laddr lbrd)
140	(when (and (or (not device) (equal? device lname))
141	(or (not group) (equal? group lgroup))
142	(or (not up) (member 'IFF_UP lflags))
143	;(or (not master) ())
144	;(or (not vrf) ())
145	(or (not type) (equal? type ltype)))
146	(print-link link)))))
147	(get-links)))
148
149	(define (link-name->index device)
150	(let loop ((links (get-links)))
151	(match links
152	(() (throw 'no-such-device device))
153	((link links ...)
154	(if (equal? (link-name link) device)
155	(link-id link)
156	(loop links))))))
157
158	(define* (link-set device #:key (up #f) (down #f) (type #f)
159	(arp-on #f) (arp-off #f)
160	(dynamic-on #f) (dynamic-off #f)
161	(multicast-on #f) (multicast-off #f)
162	(allmulticast-on #f) (allmulticast-off #f)
163	(promisc-on #f) (promisc-off #f)
164	(trailers-on #f) (trailers-off #f)
165	(carrier-on #f) (carrier-off #f)
166	(txqueuelen #f) (name #f) (address #f)
167	(broadcast #f) (mtu #f) (netns #f)
168	(master #f))
169	(define request-num (random 65535))
170	(define id (if (number? device) device (link-name->index device)))
171	(define netnsfd (cond
172	((string? netns)
173	(open (string-append "/var/run/netns/" netns) O_RDONLY))
174	((number? netns)
175	(open (string-append "/var/run/netns/" (number->string netns))
176	O_RDONLY))
177	(else
178	#f)))
179	(define message
180	(make-message
181	RTM_NEWLINK
182	(logior NLM_F_REQUEST NLM_F_ACK)
183	request-num
184	0
185	(make-link-message
186	AF_UNSPEC
187	(or type 0)
188	id
189	(+ (if up IFF_UP 0)
190	(if arp-off IFF_NOARP 0)
191	(if dynamic-on IFF_DYNAMIC 0)
192	(if multicast-on IFF_MULTICAST 0)
193	(if allmulticast-on IFF_ALLMULTI 0)
194	(if promisc-on IFF_PROMISC 0)
195	(if trailers-off IFF_NOTRAILERS 0))
196	(+ (if (or up down) IFF_UP 0)
197	(if (or arp-on arp-off) IFF_NOARP 0)
198	(if (or dynamic-on dynamic-off) IFF_DYNAMIC 0)
199	(if (or multicast-on multicast-off) IFF_MULTICAST 0)
200	(if (or allmulticast-on allmulticast-off) IFF_ALLMULTI 0)
201	(if (or promisc-on promisc-off) IFF_PROMISC 0)
202	(if (or trailers-on trailers-off) IFF_NOTRAILERS 0))
203	`(,@(if (or carrier-on carrier-off)
204	(list
205	(make-route-attr IFLA_CARRIER
206	(make-u32-route-attr (if carrier-on 1 0))))
207	'())
208	,@(if txqueuelen
209	(list
210	(make-route-attr IFLA_TXQLEN
211	(make-u32-route-attr txqueuelen)))
212	'())
213	,@(if name
214	(list
215	(make-route-attr IFLA_IFNAME
216	(make-string-route-attr name)))
217	'())
218	,@(if address
219	(list
220	(make-route-attr IFLA_ADDRESS
221	(make-ethernet-route-attr address)))
222	'())
223	,@(if broadcast
224	(list
225	(make-route-attr IFLA_BROADCAST
226	(make-ethernet-route-attr broadcast)))
227	'())
228	,@(if mtu
229	(list
230	(make-route-attr IFLA_MTU
231	(make-u32-route-attr mtu)))
232	'())
233	,@(if master
234	(list
235	(make-route-attr IFLA_MASTER
236	(make-u32-route-attr (link-name->index master))))
237	'())
238	,@(if netns
239	(list
240	(make-route-attr IFLA_NET_NS_FD
241	(make-u32-route-attr
242	(fileno netnsfd))))
243	'())))))
244	(let ((sock (connect-route)))
245	(send-msg message sock)
246	(let ((answer (receive-and-decode-msg sock %default-route-decoder)))
247	(when netnsfd
248	(close netnsfd))
249	(close-socket sock)
250	(answer-ok? (last answer)))))
251
252	(define* (bond-type-args #:key (mode #f) (miimon #f) (lacp-active #f) (lacp-rate #f)
253	(primary #f) (primary-reselect #f))
254	`(,@(if mode
255	(list
256	(make-route-attr IFLA_BOND_MODE
257	(match mode
258	("balance-rr" (make-u8-route-attr BOND_MODE_ROUNDROBIN))
259	("active-backup" (make-u8-route-attr BOND_MODE_ACTIVEBACKUP))
260	("balance-xor" (make-u8-route-attr BOND_MODE_XOR))
261	("broadcast" (make-u8-route-attr BOND_MODE_BROADCAST))
262	("802.3ad" (make-u8-route-attr BOND_MODE_8023AD))
263	("balance-tlb" (make-u8-route-attr BOND_MODE_TLB))
264	("balance-alb" (make-u8-route-attr BOND_MODE_ALB))
265	(_ (raise (condition
266	(&message
267	(message "Bond field `mode' can be defined as \
268	balance-rr\|active-backup\|balance-xor\|broadcast\|802.3ad\|balance-tlb\|balance-alb" ))))))))
269	'())
270	,@(if miimon
271	(list
272	(make-route-attr IFLA_BOND_MIIMON
273	(make-u32-route-attr miimon)))
274	'())
275	,@(if primary
276	(list
277	(make-route-attr IFLA_BOND_PRIMARY
278	(make-u32-route-attr (link-name->index primary))))
279	'())
280	,@(if primary-reselect
281	(list
282	(make-route-attr IFLA_BOND_PRIMARY_RESELECT
283	(match primary-reselect
284	("always" (make-u8-route-attr BOND_PRIMARY_RESELECT_ALWAYS))
285	("better" (make-u8-route-attr BOND_PRIMARY_RESELECT_BETTER))
286	("failure" (make-u8-route-attr BOND_PRIMARY_RESELECT_FAILURE))
287	(_ (raise (condition
288	(&message
289	(message "Bond field `primary-reselect' can be defined as always\|better\|failure" ))))))))
290	'())
291	,@(if lacp-active
292	(list
293	(make-route-attr IFLA_BOND_AD_LACP_ACTIVE
294	(match lacp-active
295	("on" (make-u8-route-attr BOND_AD_LACP_ACTIVE_ON))
296	("off" (make-u8-route-attr BOND_AD_LACP_ACTIVE_OFF))
297	(_ (raise (condition
298	(&message
299	(message "Bond field `lacp-active' can be defined as off\|on" ))))))))
300	'())
301	,@(if lacp-rate
302	(list
303	(make-route-attr IFLA_BOND_AD_LACP_RATE
304	(match lacp-rate
305	("slow" (make-u8-route-attr 0))
306	("fast" (make-u8-route-attr 1))
307	(_ (raise (condition
308	(&message
309	(message "Bond field `lacp-rate' can be defined as slow\|fast"))))))))
310	'())))
311
312	(define (alist->keyword+value alist)
313	(fold (match-lambda*
314	(((k . v) r)
315	(cons* (symbol->keyword k) v r))) '() alist))
316
317	(define* (link-add name type #:key (type-args '()))
318	(define request-num (random 65535))
319	(define type-data
320	(match type
321	("vlan"
322	`(,@(if (assoc-ref type-args 'id)
323	(list (make-route-attr IFLA_VLAN_ID
324	(make-u16-route-attr (assoc-ref type-args 'id))))
325	'())))
326	("veth"
327	`(,@(if (assoc-ref type-args 'peer)
328	(list (make-route-attr VETH_INFO_PEER
329	(make-link-message
330	AF_UNSPEC 0 0 0 0
331	(list
332	(make-route-attr IFLA_IFNAME
333	(make-string-route-attr
334	(assoc-ref type-args 'peer)))))))
335	'())))
336	("bond" (apply bond-type-args (alist->keyword+value type-args)))
337	;; TODO: unsupported for now
338	(_ '())))
339	(define message
340	(make-message
341	RTM_NEWLINK
342	(logior NLM_F_REQUEST NLM_F_ACK NLM_F_EXCL NLM_F_CREATE)
343	request-num
344	0
345	(make-link-message
346	AF_UNSPEC
347	0
348	0
349	0
350	0
351	`(,(make-route-attr IFLA_IFNAME
352	(make-string-route-attr name))
353	,(make-route-attr IFLA_LINKINFO
354	(make-nested-route-attr
355	(list
356	(make-route-attr IFLA_INFO_KIND
357	(make-string-route-attr type))
358	(make-route-attr IFLA_INFO_DATA
359	(make-nested-route-attr type-data)))))
360	,@(if (assoc-ref type-args 'link)
361	`(,(make-route-attr IFLA_LINK
362	(make-u32-route-attr (link-name->index (assoc-ref type-args 'link)))))
363	'())))))
364	(let ((sock (connect-route)))
365	(send-msg message sock)
366	(let ((answer (receive-and-decode-msg sock %default-route-decoder)))
367	(close-socket sock)
368	(answer-ok? (last answer)))))
369
370	(define* (link-del device)
371	(define request-num (random 65535))
372
373	(define message
374	(make-message
375	RTM_DELLINK
376	(logior NLM_F_REQUEST NLM_F_ACK)
377	request-num
378	0
379	(make-link-message
380	AF_UNSPEC
381	0
382	(cond
383	((number? device) device)
384	((string? device) (link-name->index device)))
385	0
386	0
387	'())))
388
389
390	(let ((sock (connect-route)))
391	(send-msg message sock)
392	(let ((answer (receive-and-decode-msg sock %default-route-decoder)))
393	(close-socket sock)
394	(answer-ok? (last answer)))))
395