guile-netlink

addr.scm

;;;; This file is part of Guile Netlink
;;;;
;;;; Copyright (C) 2021 Julien Lepiller <julien@lepiller.eu>
;;;; 
;;;; This library is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this library.  If not, see <https://www.gnu.org/licenses/>.

(define-module (ip addr)
  #:use-module (ice-9 match)
  #:use-module (ip link)
  #:use-module (ip utils)
  #:use-module (netlink route addr)
  #:use-module (netlink route attrs)
  #:use-module (netlink connection)
  #:use-module (netlink constant)
  #:use-module (netlink deserialize)
  #:use-module (netlink message)
  #:use-module (netlink standard)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:export (addr-add
            addr-del
            addr-show))

(define-record-type <addr>
  (make-addr family prefix flags scope link label addr brd cacheinfo)
  addr?
  (family    addr-family)
  (prefix    addr-prefix)
  (flags     addr-flags)
  (scope     addr-scope)
  (link      addr-link)
  (label     addr-label)
  (addr      addr-addr)
  (brd       addr-brd)
  (cacheinfo addr-cacheinfo))

(define* (addr-del device cidr #:key (ipv6? #f) (peer (cidr->addr cidr))
                   (broadcast #f) (anycast #f)
                   (label #f) (scope 'global) (metric #f)
                   (home? #f) (mngtmpaddr? #f) (nodad? #f) (optimistic? #f)
                   (noprefixroute? #f) (autojoin? #f))
  (define request-num (random 65535))
  (define prefix (cidr->prefix cidr))
  (define addr (cidr->addr cidr))

  (define index
    (cond
      ((number? device) device)
      ((string? device) (link-name->index device))))

  (define scope-num
    (match scope
      ((? number? scope) scope)
      ('global RT_SCOPE_UNIVERSE)
      ('host RT_SCOPE_HOST)
      ('link RT_SCOPE_LINK)))

  (define ifa-flags
    (logior (if (and ipv6? mngtmpaddr?) IFA_F_MANAGETEMPADDR 0)
            (if noprefixroute? IFA_F_NOPREFIXROUTE 0)
            (if autojoin? IFA_F_MCAUTOJOIN 0)))

  (define message
    (make-message
      RTM_DELADDR
      (logior NLM_F_REQUEST NLM_F_ACK)
      request-num
      0
      (make-addr-message
        (if ipv6? AF_INET6 AF_INET)
        (if prefix prefix 0)
        (logior (if (and ipv6? home?) IFA_F_HOMEADDRESS 0)
                (if (and ipv6? nodad?) IFA_F_NODAD 0)
                (if (and ipv6? optimistic?) IFA_F_OPTIMISTIC 0))
        scope-num
        index
        (list
          (make-route-attr IFA_LOCAL
            ((if ipv6?
                 make-ipv6-route-attr
                 make-ipv4-route-attr)
             addr))
          (make-route-attr IFA_ADDRESS
            ((if ipv6?
                 make-ipv6-route-attr
                 make-ipv4-route-attr)
             peer))))))

  (let ((sock (connect-route)))
    (send-msg message sock)
    (let ((answer (receive-and-decode-msg sock %default-route-decoder)))
      (close-port sock)
      (answer-ok? (last answer)))))

(define* (addr-add device cidr #:key (ipv6? #f) (peer (cidr->addr cidr))
                   (broadcast #f) (anycast #f)
                   (label #f) (scope 'global) (metric #f)
                   (home? #f) (mngtmpaddr? #f) (nodad? #f) (optimistic? #f)
                   (noprefixroute? #f) (autojoin? #f))
  (define request-num (random 65535))
  (define prefix (cidr->prefix cidr))
  (define addr (cidr->addr cidr))

  (define index
    (cond
      ((number? device) device)
      ((string? device) (link-name->index device))))

  (define scope-num
    (match scope
      ((? number? scope) scope)
      ('global RT_SCOPE_UNIVERSE)
      ('host RT_SCOPE_HOST)
      ('link RT_SCOPE_LINK)))

  (define ifa-flags
    (logior (if (and ipv6? mngtmpaddr?) IFA_F_MANAGETEMPADDR 0)
            (if noprefixroute? IFA_F_NOPREFIXROUTE 0)
            (if autojoin? IFA_F_MCAUTOJOIN 0)))

  (define message
    (make-message
      RTM_NEWADDR
      (logior NLM_F_REQUEST NLM_F_ACK NLM_F_EXCL NLM_F_CREATE)
      request-num
      0
      (make-addr-message
        (if ipv6? AF_INET6 AF_INET)
        (if prefix prefix 0)
        (logior (if (and ipv6? home?) IFA_F_HOMEADDRESS 0)
                (if (and ipv6? nodad?) IFA_F_NODAD 0)
                (if (and ipv6? optimistic?) IFA_F_OPTIMISTIC 0))
        scope-num
        index
        `(,(make-route-attr IFA_LOCAL
            ((if ipv6?
                 make-ipv6-route-attr
                 make-ipv4-route-attr)
             addr))
          ,(make-route-attr IFA_ADDRESS
            ((if ipv6?
                 make-ipv6-route-attr
                 make-ipv4-route-attr)
             peer))
          ,@(if broadcast
                `((,(make-route-attr IFA_BROADCAST
                      ((if ipv6?
                           make-ipv6-route-attr
                           make-ipv4-route-attr)
                       broadcast))))
                '())
          ,@(if anycast
                `((,(make-route-attr IFA_ANYCAST
                      ((if ipv6?
                           make-ipv6-route-attr
                           make-ipv4-route-attr)
                       anycast))))
                '())
          ,@(if (> ifa-flags 0)
                `((,(make-route-attr IFA_FLAGS (make-u32-route-attr ifa-flags))))
                '())
          ,@(if label
                `((,(make-route-attr IFA_LABEL (make-string-route-attr label))))
                '())
          ,@(if metric
                `((,(make-route-attr IFA_RT_PRIORITY (make-u32-route-attr metric))))
                '())))))

  (let ((sock (connect-route)))
    (send-msg message sock)
    (let ((answer (receive-and-decode-msg sock %default-route-decoder)))
      (close-port sock)
      (answer-ok? (last answer)))))

(define (new-address-message->address msg)
  "If MSG has type 'RTM_NEWADDR', return the corresponding <addr> object.
Otherwise return #f."
  (and (eqv? (message-kind msg) RTM_NEWADDR)
       (let* ((data (message-data msg))
              (attrs (addr-message-attrs data)))
         (make-addr (addr-message-family data)
                    (addr-message-prefix-len data)
                    (map int->ifa-flag
                         (split-flags (logior (addr-message-flags data)
                                              (get-attr attrs IFA_FLAGS))))
                    (addr-message-scope data)
                    (addr-message-index data)
                    (get-attr attrs IFA_LABEL)
                    (get-attr attrs IFA_ADDRESS)
                    (get-attr attrs IFA_BROADCAST)
                    (get-attr attrs IFA_CACHEINFO)))))

(define (get-addrs)
  (define request-num (random 65535))
  (define message
    (make-message
      RTM_GETADDR
      (logior NLM_F_REQUEST NLM_F_DUMP)
      request-num
      0
      (make-addr-message AF_UNSPEC 0 0 0 0 '())))
  (let ((sock (connect-route)))
    (send-msg message sock)
    (let* ((answer (receive-and-decode-msg sock %default-route-decoder))
           (addrs (filter-map new-address-message->address answer)))
      (close-port sock)
      addrs)))

(define print-addr
  (match-lambda
    (($ <addr> family prefix flags scope link label addr brd cacheinfo)
     (format #t "    ~a ~a/~a"
             (cond
               ((= family AF_INET) "inet")
               ((= family AF_INET6) "inet6")
               (else "????"))
             addr prefix)
     (when brd
       (format #t " brd ~a" brd))
     (when scope
       (format #t " scope ~a"
               (cond
                 ((equal? scope RT_SCOPE_UNIVERSE) "global")
                 (else (string-downcase
                         (substring (symbol->string (int->rtm-scope scope))
                                    9))))))

     (for-each
       (lambda (flag)
         (unless (equal? flag 'IFA_F_PERMANENT)
           (format #t " ~a"
                   (string-downcase (substring (symbol->string flag) 6)))))
       flags)

     (when label
       (format #t " ~a" label))

     (format #t "~%")
     (when cacheinfo
       (if (member 'IFA_F_PERMANENT flags)
           (format #t "        valid_lft forever preferred_lft forever~%")
           (format #t "        valid_lft ~asec preferred_lft ~asec~%"
                   (route-cache-info-attr-type-valid cacheinfo)
                   (route-cache-info-attr-type-prefered cacheinfo)))))))


(define* (addr-show #:optional (device #f))
  (define links (get-links))
  (define index
    (cond
      ((number? device) device)
      ((string? device) (link-name->index device))
      (else #f)))
  (define addrs (get-addrs))

  (for-each
    (lambda (link)
      (unless (and index (not (equal? (link-id link) index)))
        (print-link link)
        (for-each print-addr
                  (filter (lambda (addr) (equal? (link-id link) (addr-link addr)))
                          addrs))))
    links))


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 addr)
19	#:use-module (ice-9 match)
20	#:use-module (ip link)
21	#:use-module (ip utils)
22	#:use-module (netlink route addr)
23	#:use-module (netlink route attrs)
24	#:use-module (netlink connection)
25	#:use-module (netlink constant)
26	#:use-module (netlink deserialize)
27	#:use-module (netlink message)
28	#:use-module (netlink standard)
29	#:use-module (srfi srfi-1)
30	#:use-module (srfi srfi-9)
31	#:export (addr-add
32	addr-del
33	addr-show))
34
35	(define-record-type <addr>
36	(make-addr family prefix flags scope link label addr brd cacheinfo)
37	addr?
38	(family addr-family)
39	(prefix addr-prefix)
40	(flags addr-flags)
41	(scope addr-scope)
42	(link addr-link)
43	(label addr-label)
44	(addr addr-addr)
45	(brd addr-brd)
46	(cacheinfo addr-cacheinfo))
47
48	(define* (addr-del device cidr #:key (ipv6? #f) (peer (cidr->addr cidr))
49	(broadcast #f) (anycast #f)
50	(label #f) (scope 'global) (metric #f)
51	(home? #f) (mngtmpaddr? #f) (nodad? #f) (optimistic? #f)
52	(noprefixroute? #f) (autojoin? #f))
53	(define request-num (random 65535))
54	(define prefix (cidr->prefix cidr))
55	(define addr (cidr->addr cidr))
56
57	(define index
58	(cond
59	((number? device) device)
60	((string? device) (link-name->index device))))
61
62	(define scope-num
63	(match scope
64	((? number? scope) scope)
65	('global RT_SCOPE_UNIVERSE)
66	('host RT_SCOPE_HOST)
67	('link RT_SCOPE_LINK)))
68
69	(define ifa-flags
70	(logior (if (and ipv6? mngtmpaddr?) IFA_F_MANAGETEMPADDR 0)
71	(if noprefixroute? IFA_F_NOPREFIXROUTE 0)
72	(if autojoin? IFA_F_MCAUTOJOIN 0)))
73
74	(define message
75	(make-message
76	RTM_DELADDR
77	(logior NLM_F_REQUEST NLM_F_ACK)
78	request-num
79	0
80	(make-addr-message
81	(if ipv6? AF_INET6 AF_INET)
82	(if prefix prefix 0)
83	(logior (if (and ipv6? home?) IFA_F_HOMEADDRESS 0)
84	(if (and ipv6? nodad?) IFA_F_NODAD 0)
85	(if (and ipv6? optimistic?) IFA_F_OPTIMISTIC 0))
86	scope-num
87	index
88	(list
89	(make-route-attr IFA_LOCAL
90	((if ipv6?
91	make-ipv6-route-attr
92	make-ipv4-route-attr)
93	addr))
94	(make-route-attr IFA_ADDRESS
95	((if ipv6?
96	make-ipv6-route-attr
97	make-ipv4-route-attr)
98	peer))))))
99
100	(let ((sock (connect-route)))
101	(send-msg message sock)
102	(let ((answer (receive-and-decode-msg sock %default-route-decoder)))
103	(close-port sock)
104	(answer-ok? (last answer)))))
105
106	(define* (addr-add device cidr #:key (ipv6? #f) (peer (cidr->addr cidr))
107	(broadcast #f) (anycast #f)
108	(label #f) (scope 'global) (metric #f)
109	(home? #f) (mngtmpaddr? #f) (nodad? #f) (optimistic? #f)
110	(noprefixroute? #f) (autojoin? #f))
111	(define request-num (random 65535))
112	(define prefix (cidr->prefix cidr))
113	(define addr (cidr->addr cidr))
114
115	(define index
116	(cond
117	((number? device) device)
118	((string? device) (link-name->index device))))
119
120	(define scope-num
121	(match scope
122	((? number? scope) scope)
123	('global RT_SCOPE_UNIVERSE)
124	('host RT_SCOPE_HOST)
125	('link RT_SCOPE_LINK)))
126
127	(define ifa-flags
128	(logior (if (and ipv6? mngtmpaddr?) IFA_F_MANAGETEMPADDR 0)
129	(if noprefixroute? IFA_F_NOPREFIXROUTE 0)
130	(if autojoin? IFA_F_MCAUTOJOIN 0)))
131
132	(define message
133	(make-message
134	RTM_NEWADDR
135	(logior NLM_F_REQUEST NLM_F_ACK NLM_F_EXCL NLM_F_CREATE)
136	request-num
137	0
138	(make-addr-message
139	(if ipv6? AF_INET6 AF_INET)
140	(if prefix prefix 0)
141	(logior (if (and ipv6? home?) IFA_F_HOMEADDRESS 0)
142	(if (and ipv6? nodad?) IFA_F_NODAD 0)
143	(if (and ipv6? optimistic?) IFA_F_OPTIMISTIC 0))
144	scope-num
145	index
146	`(,(make-route-attr IFA_LOCAL
147	((if ipv6?
148	make-ipv6-route-attr
149	make-ipv4-route-attr)
150	addr))
151	,(make-route-attr IFA_ADDRESS
152	((if ipv6?
153	make-ipv6-route-attr
154	make-ipv4-route-attr)
155	peer))
156	,@(if broadcast
157	`((,(make-route-attr IFA_BROADCAST
158	((if ipv6?
159	make-ipv6-route-attr
160	make-ipv4-route-attr)
161	broadcast))))
162	'())
163	,@(if anycast
164	`((,(make-route-attr IFA_ANYCAST
165	((if ipv6?
166	make-ipv6-route-attr
167	make-ipv4-route-attr)
168	anycast))))
169	'())
170	,@(if (> ifa-flags 0)
171	`((,(make-route-attr IFA_FLAGS (make-u32-route-attr ifa-flags))))
172	'())
173	,@(if label
174	`((,(make-route-attr IFA_LABEL (make-string-route-attr label))))
175	'())
176	,@(if metric
177	`((,(make-route-attr IFA_RT_PRIORITY (make-u32-route-attr metric))))
178	'())))))
179
180	(let ((sock (connect-route)))
181	(send-msg message sock)
182	(let ((answer (receive-and-decode-msg sock %default-route-decoder)))
183	(close-port sock)
184	(answer-ok? (last answer)))))
185
186	(define (new-address-message->address msg)
187	"If MSG has type 'RTM_NEWADDR', return the corresponding <addr> object.
188	Otherwise return #f."
189	(and (eqv? (message-kind msg) RTM_NEWADDR)
190	(let* ((data (message-data msg))
191	(attrs (addr-message-attrs data)))
192	(make-addr (addr-message-family data)
193	(addr-message-prefix-len data)
194	(map int->ifa-flag
195	(split-flags (logior (addr-message-flags data)
196	(get-attr attrs IFA_FLAGS))))
197	(addr-message-scope data)
198	(addr-message-index data)
199	(get-attr attrs IFA_LABEL)
200	(get-attr attrs IFA_ADDRESS)
201	(get-attr attrs IFA_BROADCAST)
202	(get-attr attrs IFA_CACHEINFO)))))
203
204	(define (get-addrs)
205	(define request-num (random 65535))
206	(define message
207	(make-message
208	RTM_GETADDR
209	(logior NLM_F_REQUEST NLM_F_DUMP)
210	request-num
211	0
212	(make-addr-message AF_UNSPEC 0 0 0 0 '())))
213	(let ((sock (connect-route)))
214	(send-msg message sock)
215	(let* ((answer (receive-and-decode-msg sock %default-route-decoder))
216	(addrs (filter-map new-address-message->address answer)))
217	(close-port sock)
218	addrs)))
219
220	(define print-addr
221	(match-lambda
222	(($ <addr> family prefix flags scope link label addr brd cacheinfo)
223	(format #t " ~a ~a/~a"
224	(cond
225	((= family AF_INET) "inet")
226	((= family AF_INET6) "inet6")
227	(else "????"))
228	addr prefix)
229	(when brd
230	(format #t " brd ~a" brd))
231	(when scope
232	(format #t " scope ~a"
233	(cond
234	((equal? scope RT_SCOPE_UNIVERSE) "global")
235	(else (string-downcase
236	(substring (symbol->string (int->rtm-scope scope))
237	9))))))
238
239	(for-each
240	(lambda (flag)
241	(unless (equal? flag 'IFA_F_PERMANENT)
242	(format #t " ~a"
243	(string-downcase (substring (symbol->string flag) 6)))))
244	flags)
245
246	(when label
247	(format #t " ~a" label))
248
249	(format #t "~%")
250	(when cacheinfo
251	(if (member 'IFA_F_PERMANENT flags)
252	(format #t " valid_lft forever preferred_lft forever~%")
253	(format #t " valid_lft ~asec preferred_lft ~asec~%"
254	(route-cache-info-attr-type-valid cacheinfo)
255	(route-cache-info-attr-type-prefered cacheinfo)))))))
256
257
258	(define* (addr-show #:optional (device #f))
259	(define links (get-links))
260	(define index
261	(cond
262	((number? device) device)
263	((string? device) (link-name->index device))
264	(else #f)))
265	(define addrs (get-addrs))
266
267	(for-each
268	(lambda (link)
269	(unless (and index (not (equal? (link-id link) index)))
270	(print-link link)
271	(for-each print-addr
272	(filter (lambda (addr) (equal? (link-id link) (addr-link addr)))
273	addrs))))
274	links))
275