link.scm
1 | ;;;; Copyright (C) 2021 Julien Lepiller <julien@lepiller.eu> |
2 | ;;;; |
3 | ;;;; This library is free software; you can redistribute it and/or |
4 | ;;;; modify it under the terms of the GNU Lesser General Public |
5 | ;;;; License as published by the Free Software Foundation; either |
6 | ;;;; version 3 of the License, or (at your option) any later version. |
7 | ;;;; |
8 | ;;;; This library is distributed in the hope that it will be useful, |
9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
10 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
11 | ;;;; Lesser General Public License for more details. |
12 | ;;;; |
13 | ;;;; You should have received a copy of the GNU Lesser General Public |
14 | ;;;; License along with this library; if not, write to the Free Software |
15 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
16 | ;;;; |
17 | |
18 | (define-module (ip link) |
19 | #:use-module (ice-9 match) |
20 | #:use-module (netlink route attrs) |
21 | #:use-module (netlink route link) |
22 | #:use-module (netlink connection) |
23 | #:use-module (netlink constant) |
24 | #:use-module (netlink data) |
25 | #:use-module (netlink deserialize) |
26 | #:use-module (netlink message) |
27 | #:use-module (srfi srfi-9) |
28 | #:export (link-set |
29 | link-show)) |
30 | |
31 | (define-record-type <link> |
32 | (make-link name id type flags mtu qdisc state mode group qlen addr brd) |
33 | link? |
34 | (name link-name) |
35 | (id link-id) |
36 | (type link-type) |
37 | (flags link-flags) |
38 | (mtu link-mtu) |
39 | (qdisc link-qdisc) |
40 | (state link-state) |
41 | (mode link-mode) |
42 | (group link-group) |
43 | (qlen link-qlen) |
44 | (addr link-addr) |
45 | (brd link-brd)) |
46 | |
47 | (define (get-attr attrs type) |
48 | (let ((attrs (filter (lambda (attr) (equal? (route-attr-kind attr) type)) attrs))) |
49 | (match attrs |
50 | (() #f) |
51 | ((attr) (nl-data-data (route-attr-data attr)))))) |
52 | |
53 | (define (split-flags flags) |
54 | (let loop ((max-flag 262144) (flags flags) (result '())) |
55 | (cond |
56 | ((equal? max-flag 1) |
57 | (if (equal? flags 1) |
58 | (cons (int->device-flags 1) result) |
59 | result)) |
60 | ((< flags max-flag) |
61 | (loop (/ max-flag 2) flags result)) |
62 | (else |
63 | (loop (/ max-flag 2) (- flags max-flag) |
64 | (cons |
65 | (int->device-flags max-flag) |
66 | result)))))) |
67 | |
68 | (define (get-links) |
69 | (define request-num (random 65535)) |
70 | (define message |
71 | (make-message |
72 | RTM_GETLINK |
73 | (logior NLM_F_REQUEST NLM_F_DUMP) |
74 | request-num |
75 | 0 |
76 | (make-link-message AF_UNSPEC 0 0 0 0 '()))) |
77 | |
78 | (let ((sock (connect-route))) |
79 | (send-msg message sock) |
80 | (let* ((answer (receive-and-decode-msg sock %default-route-decoder)) |
81 | (links (filter |
82 | (lambda (msg) (equal? (message-kind msg) RTM_NEWLINK)) |
83 | answer)) |
84 | (links |
85 | (map |
86 | (lambda (msg) |
87 | (let* ((data (message-data msg)) |
88 | (attrs (link-message-attrs data))) |
89 | (make-link |
90 | (get-attr attrs IFLA_IFNAME) |
91 | (link-message-index data) |
92 | (link-message-kind data) |
93 | (split-flags (link-message-flags data)) |
94 | (get-attr attrs IFLA_MTU) |
95 | (get-attr attrs IFLA_QDISC) |
96 | (get-attr attrs IFLA_OPERSTATE) |
97 | (get-attr attrs IFLA_LINKMODE) |
98 | (get-attr attrs IFLA_GROUP) |
99 | (get-attr attrs IFLA_TXQLEN) |
100 | (get-attr attrs IFLA_ADDRESS) |
101 | (get-attr attrs IFLA_BROADCAST)))) |
102 | links))) |
103 | (close-socket sock) |
104 | links))) |
105 | |
106 | (define* (link-show #:key (device #f) (group #f) (up #f) (master #f) (vrf #f) |
107 | (type #f)) |
108 | "Return a list whose elements represent the data about the links. If a key |
109 | is given, the resulting list is limited to those elements that match the given |
110 | criteria." |
111 | (define print-link |
112 | (match-lambda |
113 | (($ <link> name id type flags mtu qdisc state mode group qlen addr brd) |
114 | (format #t "~a: ~a: <~a>" id name |
115 | (string-join |
116 | (map |
117 | (lambda (s) |
118 | ;; IFF_UP -> UP |
119 | (substring (symbol->string s) 4)) |
120 | flags) |
121 | ",")) |
122 | (when mtu |
123 | (format #t " mtu ~a" mtu)) |
124 | (when qdisc |
125 | (format #t " qdisc ~a" qdisc)) |
126 | (when state |
127 | (format #t " state ~a" |
128 | (substring (symbol->string (int->operstate state)) 8))) |
129 | (when mode |
130 | (format #t " mode ~a" (match mode (0 "DEFAULT") (1 "DORMANT")))) |
131 | (when group |
132 | (format #t " group ~a" (match group (0 "DEFAULT")))) |
133 | (when qlen |
134 | (format #t " qlen ~a" qlen)) |
135 | (newline) |
136 | (cond |
137 | ((equal? type ARPHRD_ETHER) |
138 | (format #t " link/ether ~a brd ~a~%" addr brd)) |
139 | ((equal? type ARPHRD_LOOPBACK) |
140 | (format #t " link/loopback ~a brd ~a~%" addr brd)))))) |
141 | |
142 | (for-each |
143 | (lambda (link) |
144 | (match link |
145 | (($ <link> lname lid ltype lflags lmtu lqdisc lstate lmode lgroup lqlen laddr lbrd) |
146 | (when (and (or (not device) (equal? device lname)) |
147 | (or (not group) (equal? group lgroup)) |
148 | (or (not up) (member 'IFF_UP lflags)) |
149 | ;(or (not master) ()) |
150 | ;(or (not vrf) ()) |
151 | (or (not type) (equal? type ltype))) |
152 | (print-link link))))) |
153 | (get-links))) |
154 | |
155 | (define (link-name->index device) |
156 | (let loop ((links (get-links))) |
157 | (match links |
158 | (() (throw 'no-such-device device)) |
159 | ((link links ...) |
160 | (if (equal? (link-name link) device) |
161 | (link-id link) |
162 | (loop links)))))) |
163 | |
164 | (define* (link-set device #:key (up #f) (down #f) (type #f) |
165 | (arp-on #f) (arp-off #f) |
166 | (dynamic-on #f) (dynamic-off #f) |
167 | (multicast-on #f) (multicast-off #f) |
168 | (allmulticast-on #f) (allmulticast-off #f) |
169 | (promisc-on #f) (promisc-off #f) |
170 | (trailers-on #f) (trailers-off #f) |
171 | (carrier-on #f) (carrier-off #f) |
172 | (txqueuelen #f) (name #f) (address #f) |
173 | (broadcast #f) (mtu #f) (netns #f)) |
174 | (define request-num (random 65535)) |
175 | (define id (if (number? device) device (link-name->index device))) |
176 | (define netnsfd (cond |
177 | ((string? netns) |
178 | (open (string-append "/var/run/netns/" netns) O_RDONLY)) |
179 | ((number? netns) |
180 | (open (string-append "/var/run/netns/" (number->string netns)) |
181 | O_RDONLY)) |
182 | (else |
183 | #f))) |
184 | (define message |
185 | (make-message |
186 | RTM_NEWLINK |
187 | (logior NLM_F_REQUEST NLM_F_ACK) |
188 | request-num |
189 | 0 |
190 | (make-link-message |
191 | AF_UNSPEC |
192 | (or type 0) |
193 | id |
194 | (+ (if up IFF_UP 0) |
195 | (if arp-off IFF_NOARP 0) |
196 | (if dynamic-on IFF_DYNAMIC 0) |
197 | (if multicast-on IFF_MULTICAST 0) |
198 | (if allmulticast-on IFF_ALLMULTI 0) |
199 | (if promisc-on IFF_PROMISC 0) |
200 | (if trailers-off IFF_NOTRAILERS 0)) |
201 | (+ (if (or up down) IFF_UP 0) |
202 | (if (or arp-on arp-off) IFF_NOARP 0) |
203 | (if (or dynamic-on dynamic-off) IFF_DYNAMIC 0) |
204 | (if (or multicast-on multicast-off) IFF_MULTICAST 0) |
205 | (if (or allmulticast-on allmulticast-off) IFF_ALLMULTI 0) |
206 | (if (or promisc-on promisc-off) IFF_PROMISC 0) |
207 | (if (or trailers-on trailers-off) IFF_NOTRAILERS 0)) |
208 | `(,@(if (or carrier-on carrier-off) |
209 | (list |
210 | (make-route-attr IFLA_CARRIER |
211 | (make-u32-route-attr (if carrier-on 1 0)))) |
212 | '()) |
213 | ,@(if txqueuelen |
214 | (list |
215 | (make-route-attr IFLA_TXQLEN |
216 | (make-u32-route-attr txqueuelen))) |
217 | '()) |
218 | ,@(if name |
219 | (list |
220 | (make-route-attr IFLA_TXQLEN |
221 | (make-u32-route-attr txqueuelen))) |
222 | '()) |
223 | ,@(if address |
224 | (list |
225 | (make-route-attr IFLA_ADDRESS |
226 | (make-ethernet-route-attr address))) |
227 | '()) |
228 | ,@(if broadcast |
229 | (list |
230 | (make-route-attr IFLA_BROADCAST |
231 | (make-ethernet-route-attr broadcast))) |
232 | '()) |
233 | ,@(if mtu |
234 | (list |
235 | (make-route-attr IFLA_MTU |
236 | (make-u32-route-attr mtu))) |
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))) |
251 |