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 | (map |
85 | (lambda (msg) |
86 | (let* ((data (message-data msg)) |
87 | (attrs (link-message-attrs data))) |
88 | (make-link |
89 | (get-attr attrs IFLA_IFNAME) |
90 | (link-message-index data) |
91 | (link-message-kind data) |
92 | (split-flags (link-message-flags data)) |
93 | (get-attr attrs IFLA_MTU) |
94 | (get-attr attrs IFLA_QDISC) |
95 | (get-attr attrs IFLA_OPERSTATE) |
96 | (get-attr attrs IFLA_LINKMODE) |
97 | (get-attr attrs IFLA_GROUP) |
98 | (get-attr attrs IFLA_TXQLEN) |
99 | (get-attr attrs IFLA_ADDRESS) |
100 | (get-attr attrs IFLA_BROADCAST)))) |
101 | links)))) |
102 | |
103 | (define* (link-show #:key (device #f) (group #f) (up #f) (master #f) (vrf #f) |
104 | (type #f)) |
105 | "Return a list whose elements represent the data about the links. If a key |
106 | is given, the resulting list is limited to those elements that match the given |
107 | criteria." |
108 | (define print-link |
109 | (match-lambda |
110 | (($ <link> name id type flags mtu qdisc state mode group qlen addr brd) |
111 | (format #t "~a: ~a: <~a>" id name |
112 | (string-join |
113 | (map |
114 | (lambda (s) |
115 | ;; IFF_UP -> UP |
116 | (substring (symbol->string s) 4)) |
117 | flags) |
118 | ",")) |
119 | (when mtu |
120 | (format #t " mtu ~a" mtu)) |
121 | (when qdisc |
122 | (format #t " qdisc ~a" qdisc)) |
123 | (when state |
124 | (format #t " state ~a" |
125 | (substring (symbol->string (int->operstate state)) 8))) |
126 | (when mode |
127 | (format #t " mode ~a" (match mode (0 "DEFAULT") (1 "DORMANT")))) |
128 | (when group |
129 | (format #t " group ~a" (match group (0 "DEFAULT")))) |
130 | (when qlen |
131 | (format #t " qlen ~a" qlen)) |
132 | (newline) |
133 | (cond |
134 | ((equal? type ARPHRD_ETHER) |
135 | (format #t " link/ether ~a brd ~a~%" addr brd)) |
136 | ((equal? type ARPHRD_LOOPBACK) |
137 | (format #t " link/loopback ~a brd ~a~%" addr brd)))))) |
138 | |
139 | (for-each |
140 | (lambda (link) |
141 | (match link |
142 | (($ <link> lname lid ltype lflags lmtu lqdisc lstate lmode lgroup lqlen laddr lbrd) |
143 | (when (and (or (not device) (equal? device lname)) |
144 | (or (not group) (equal? group lgroup)) |
145 | (or (not up) (member 'IFF_UP lflags)) |
146 | ;(or (not master) ()) |
147 | ;(or (not vrf) ()) |
148 | (or (not type) (equal? type ltype))) |
149 | (print-link link))))) |
150 | (get-links))) |
151 | |
152 | (define (link-name->index device) |
153 | (let loop ((links (get-links))) |
154 | (match links |
155 | (() (throw 'no-such-device device)) |
156 | ((link links) |
157 | (if (equal? (link-name link) device) |
158 | (link-id link) |
159 | (loop links)))))) |
160 | |
161 | (define* (link-set device #:key (up #f) (down #f) (type #f)) |
162 | (define request-num (random 65535)) |
163 | (define id (if (number? device) device (link-name->index device))) |
164 | (define message |
165 | (make-message |
166 | RTM_NEWLINK |
167 | (logior NLM_F_REQUEST NLM_F_ACK) |
168 | request-num |
169 | 0 |
170 | (make-link-message |
171 | AF_UNSPEC |
172 | (or type 0) |
173 | id |
174 | (+ (if up IFF_UP 0)) |
175 | (+ (if (or up down) IFF_UP 0)) |
176 | '()))) |
177 | (let ((sock (connect-route))) |
178 | (send-msg message sock) |
179 | (let ((answer (receive-and-decode-msg sock %default-route-decoder))) |
180 | (close-socket sock) |
181 | answer))) |
182 |