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