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-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 | (define request-num (random 65535)) |
169 | (define id (if (number? device) device (link-name->index device))) |
170 | (define netnsfd (cond |
171 | ((string? netns) |
172 | (open (string-append "/var/run/netns/" netns) O_RDONLY)) |
173 | ((number? netns) |
174 | (open (string-append "/var/run/netns/" (number->string netns)) |
175 | O_RDONLY)) |
176 | (else |
177 | #f))) |
178 | (define message |
179 | (make-message |
180 | RTM_NEWLINK |
181 | (logior NLM_F_REQUEST NLM_F_ACK) |
182 | request-num |
183 | 0 |
184 | (make-link-message |
185 | AF_UNSPEC |
186 | (or type 0) |
187 | id |
188 | (+ (if up IFF_UP 0) |
189 | (if arp-off IFF_NOARP 0) |
190 | (if dynamic-on IFF_DYNAMIC 0) |
191 | (if multicast-on IFF_MULTICAST 0) |
192 | (if allmulticast-on IFF_ALLMULTI 0) |
193 | (if promisc-on IFF_PROMISC 0) |
194 | (if trailers-off IFF_NOTRAILERS 0)) |
195 | (+ (if (or up down) IFF_UP 0) |
196 | (if (or arp-on arp-off) IFF_NOARP 0) |
197 | (if (or dynamic-on dynamic-off) IFF_DYNAMIC 0) |
198 | (if (or multicast-on multicast-off) IFF_MULTICAST 0) |
199 | (if (or allmulticast-on allmulticast-off) IFF_ALLMULTI 0) |
200 | (if (or promisc-on promisc-off) IFF_PROMISC 0) |
201 | (if (or trailers-on trailers-off) IFF_NOTRAILERS 0)) |
202 | `(,@(if (or carrier-on carrier-off) |
203 | (list |
204 | (make-route-attr IFLA_CARRIER |
205 | (make-u32-route-attr (if carrier-on 1 0)))) |
206 | '()) |
207 | ,@(if txqueuelen |
208 | (list |
209 | (make-route-attr IFLA_TXQLEN |
210 | (make-u32-route-attr txqueuelen))) |
211 | '()) |
212 | ,@(if name |
213 | (list |
214 | (make-route-attr IFLA_TXQLEN |
215 | (make-u32-route-attr txqueuelen))) |
216 | '()) |
217 | ,@(if address |
218 | (list |
219 | (make-route-attr IFLA_ADDRESS |
220 | (make-ethernet-route-attr address))) |
221 | '()) |
222 | ,@(if broadcast |
223 | (list |
224 | (make-route-attr IFLA_BROADCAST |
225 | (make-ethernet-route-attr broadcast))) |
226 | '()) |
227 | ,@(if mtu |
228 | (list |
229 | (make-route-attr IFLA_MTU |
230 | (make-u32-route-attr mtu))) |
231 | '()) |
232 | ,@(if netns |
233 | (list |
234 | (make-route-attr IFLA_NET_NS_FD |
235 | (make-u32-route-attr |
236 | (fileno netnsfd)))) |
237 | '()))))) |
238 | (let ((sock (connect-route))) |
239 | (send-msg message sock) |
240 | (let ((answer (receive-and-decode-msg sock %default-route-decoder))) |
241 | (when netnsfd |
242 | (close netnsfd)) |
243 | (close-socket sock) |
244 | (answer-ok? (last answer))))) |
245 | |
246 | (define* (link-add name type #:key (type-args '())) |
247 | (define request-num (random 65535)) |
248 | (define type-data |
249 | (match type |
250 | ("vlan" |
251 | `(,@(if (assoc-ref type-args 'id) |
252 | (list (make-route-attr IFLA_VLAN_ID |
253 | (make-u16-route-attr (assoc-ref type-args 'id)))) |
254 | '()))) |
255 | ("veth" |
256 | `(,@(if (assoc-ref type-args 'peer) |
257 | (list (make-route-attr VETH_INFO_PEER |
258 | (make-link-message |
259 | AF_UNSPEC 0 0 0 0 |
260 | (list |
261 | (make-route-attr IFLA_IFNAME |
262 | (make-string-route-attr |
263 | (assoc-ref type-args 'peer))))))) |
264 | '()))) |
265 | ;; TODO: unsupported for now |
266 | (_ '()))) |
267 | (define message |
268 | (make-message |
269 | RTM_NEWLINK |
270 | (logior NLM_F_REQUEST NLM_F_ACK NLM_F_EXCL NLM_F_CREATE) |
271 | request-num |
272 | 0 |
273 | (make-link-message |
274 | AF_UNSPEC |
275 | 0 |
276 | 0 |
277 | 0 |
278 | 0 |
279 | (list |
280 | (make-route-attr IFLA_IFNAME |
281 | (make-string-route-attr name)) |
282 | (make-route-attr IFLA_LINKINFO |
283 | (make-nested-route-attr |
284 | (list |
285 | (make-route-attr IFLA_INFO_KIND |
286 | (make-string-route-attr type)) |
287 | (make-route-attr IFLA_INFO_DATA |
288 | (make-nested-route-attr type-data))))))))) |
289 | (let ((sock (connect-route))) |
290 | (send-msg message sock) |
291 | (let ((answer (receive-and-decode-msg sock %default-route-decoder))) |
292 | (close-socket sock) |
293 | (answer-ok? (last answer))))) |
294 | |
295 | (define* (link-del device) |
296 | (define request-num (random 65535)) |
297 | |
298 | (define message |
299 | (make-message |
300 | RTM_DELLINK |
301 | (logior NLM_F_REQUEST NLM_F_ACK) |
302 | request-num |
303 | 0 |
304 | (make-link-message |
305 | AF_UNSPEC |
306 | 0 |
307 | (cond |
308 | ((number? device) device) |
309 | ((string? device) (link-name->index device))) |
310 | 0 |
311 | 0 |
312 | '()))) |
313 | |
314 | |
315 | (let ((sock (connect-route))) |
316 | (send-msg message sock) |
317 | (let ((answer (receive-and-decode-msg sock %default-route-decoder))) |
318 | (close-socket sock) |
319 | (answer-ok? (last answer))))) |
320 |