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 (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
                    (lambda (msg) (equal? (message-kind msg) RTM_NEWADDR))
                    answer))
           (addrs (map
                    (lambda (msg)
                      (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))))
                    addrs)))
      (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 (get-addrs)
187	(define request-num (random 65535))
188	(define message
189	(make-message
190	RTM_GETADDR
191	(logior NLM_F_REQUEST NLM_F_DUMP)
192	request-num
193	0
194	(make-addr-message AF_UNSPEC 0 0 0 0 '())))
195	(let ((sock (connect-route)))
196	(send-msg message sock)
197	(let* ((answer (receive-and-decode-msg sock %default-route-decoder))
198	(addrs (filter
199	(lambda (msg) (equal? (message-kind msg) RTM_NEWADDR))
200	answer))
201	(addrs (map
202	(lambda (msg)
203	(let* ((data (message-data msg))
204	(attrs (addr-message-attrs data)))
205	(make-addr
206	(addr-message-family data)
207	(addr-message-prefix-len data)
208	(map
209	int->ifa-flag
210	(split-flags (logior (addr-message-flags data)
211	(get-attr attrs IFA_FLAGS))))
212	(addr-message-scope data)
213	(addr-message-index data)
214	(get-attr attrs IFA_LABEL)
215	(get-attr attrs IFA_ADDRESS)
216	(get-attr attrs IFA_BROADCAST)
217	(get-attr attrs IFA_CACHEINFO))))
218	addrs)))
219	(close-port sock)
220	addrs)))
221
222	(define print-addr
223	(match-lambda
224	(($ <addr> family prefix flags scope link label addr brd cacheinfo)
225	(format #t " ~a ~a/~a"
226	(cond
227	((= family AF_INET) "inet")
228	((= family AF_INET6) "inet6")
229	(else "????"))
230	addr prefix)
231	(when brd
232	(format #t " brd ~a" brd))
233	(when scope
234	(format #t " scope ~a"
235	(cond
236	((equal? scope RT_SCOPE_UNIVERSE) "global")
237	(else (string-downcase
238	(substring (symbol->string (int->rtm-scope scope))
239	9))))))
240
241	(for-each
242	(lambda (flag)
243	(unless (equal? flag 'IFA_F_PERMANENT)
244	(format #t " ~a"
245	(string-downcase (substring (symbol->string flag) 6)))))
246	flags)
247
248	(when label
249	(format #t " ~a" label))
250
251	(format #t "~%")
252	(when cacheinfo
253	(if (member 'IFA_F_PERMANENT flags)
254	(format #t " valid_lft forever preferred_lft forever~%")
255	(format #t " valid_lft ~asec preferred_lft ~asec~%"
256	(route-cache-info-attr-type-valid cacheinfo)
257	(route-cache-info-attr-type-prefered cacheinfo)))))))
258
259
260	(define* (addr-show #:optional (device #f))
261	(define links (get-links))
262	(define index
263	(cond
264	((number? device) device)
265	((string? device) (link-name->index device))
266	(else #f)))
267	(define addrs (get-addrs))
268
269	(for-each
270	(lambda (link)
271	(unless (and index (not (equal? (link-id link) index)))
272	(print-link link)
273	(for-each print-addr
274	(filter (lambda (addr) (equal? (link-id link) (addr-link addr)))
275	addrs))))
276	links))
277