link.scm
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-port 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-port 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-port 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-port sock) |
394 | (answer-ok? (last answer))))) |
395 |