guile-netlink

route.scm

;;;; 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 Lesser 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
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;; 

(define-module (ip route)
  #:use-module (ice-9 match)
  #:use-module (ip link)
  #:use-module (ip utils)
  #:use-module (netlink route route)
  #: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 (route-add
            route-del
            route-show))

(define-record-type <route>
  (make-route family table dest src gateway proto scope priority device)
  route?
  (family   route-family)
  (table    route-table)
  (dest     route-dest)
  (src      route-src)
  (gateway  route-gateway)
  (proto    route-proto)
  (scope    route-scope)
  (priority route-priority)
  (device   route-device))

(define* (route-del dest
                    #:key (ipv6? #f) (device #f) (table RT_TABLE_MAIN)
                          (protocol #f) (scope RT_SCOPE_NOWHERE) (type #f)
                          (priority #f) (src #f) (via #f))
  (define request-num (random 65535))

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

  (define message
    (make-message
      RTM_DELROUTE
      (logior NLM_F_REQUEST NLM_F_ACK)
      request-num
      0
      (make-route-message
        (if ipv6? AF_INET6 AF_INET)
        (if (equal? dest "default") 0 (cidr->prefix dest))
        (if src (cidr->prefix src) 0)
        0
        table
        (or protocol 0)
        scope
        (or type 0)
        0
        `(,@(if (equal? dest "default")
                '()
                (list (make-route-attr RTA_DST
                        ((if ipv6?
                             make-ipv6-route-attr
                             make-ipv4-route-attr)
                         (cidr->addr dest)))))
          ,@(if index
                (list (make-route-attr RTA_OIF
                        (make-u32-route-attr index)))
                '())
          ,@(if src
                (list (make-route-attr RTA_PREFSRC
                        ((if ipv6?
                             make-ipv6-route-attr
                             make-ipv4-route-attr)
                         (cidr->addr src))))
                '())
          ,@(if via
                (list (make-route-attr RTA_GATEWAY
                        ((if ipv6?
                             make-ipv6-route-attr
                             make-ipv4-route-attr)
                         via)))
                '())
          ,@(if priority
                (list (make-route-attr RTA_PRIORITY
                        (make-u32-route-attr priority)))
                '())))))

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

(define* (route-add dest
                    #:key (ipv6? #f) (device #f) (table RT_TABLE_MAIN)
                          (protocol #f) (scope RT_SCOPE_LINK)
                          (type RTN_UNICAST) (priority #f) (src #f) (via #f))
  (define request-num (random 65535))

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

  (define message
    (make-message
      RTM_NEWROUTE
      (logior NLM_F_REQUEST NLM_F_ACK NLM_F_EXCL NLM_F_CREATE)
      request-num
      0
      (make-route-message
        (if ipv6? AF_INET6 AF_INET)
        (if (equal? dest "default") 0 (cidr->prefix dest))
        (if src (cidr->prefix src) 0)
        0
        table
        (or protocol 0)
        scope
        type
        0
        `(,@(if (equal? dest "default")
                '()
                (list (make-route-attr RTA_DST
                        ((if ipv6?
                             make-ipv6-route-attr
                             make-ipv4-route-attr)
                         (cidr->addr dest)))))
          ,@(if index
                (list (make-route-attr RTA_OIF
                        (make-u32-route-attr index)))
                '())
          ,@(if src
                (list (make-route-attr RTA_PREFSRC
                        ((if ipv6?
                             make-ipv6-route-attr
                             make-ipv4-route-attr)
                         (cidr->addr src))))
                '())
          ,@(if via
                (list (make-route-attr RTA_GATEWAY
                        ((if ipv6?
                             make-ipv6-route-attr
                             make-ipv4-route-attr)
                         via)))
                '())
          ,@(if priority
                (list (make-route-attr RTA_PRIORITY
                        (make-u32-route-attr priority)))
                '())))))

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

(define (link-ref links id)
  (let loop ((links links))
    (match links
      (() #f)
      ((link links ...)
       (if (equal? (link-id link) id)
           link
           (loop links))))))

(define (get-routes links)
  (define request-num (random 65535))
  (define message
    (make-message
      RTM_GETROUTE
      (logior NLM_F_REQUEST NLM_F_DUMP)
      request-num
      0
      (make-route-message AF_UNSPEC 0 0 0 0 0 0 0 0 '())))
  (let ((sock (connect-route)))
    (send-msg message sock)
    (let* ((answer (receive-and-decode-msg sock %default-route-decoder))
           (routes (filter
                     (lambda (msg) (equal? (message-kind msg) RTM_NEWROUTE))
                     answer))
           (routes (map
                     (lambda (msg)
                       (let* ((data (message-data msg))
                              (attrs (route-message-attrs data)))
                         (make-route
                           (route-message-family data)
                           (or (get-attr attrs RTA_TABLE)
                               (route-message-table data))
                           (let ((len (route-message-dest-len data))
                                 (dest (get-attr attrs RTA_DST)))
                             (if (or (equal? len 0) (not dest))
                                 #f
                                 (string-append dest "/" (number->string len))))
                           (let ((len (route-message-src-len data))
                                 (src (get-attr attrs RTA_PREFSRC)))
                             (if (or (equal? len 0) (not src))
                                 #f
                                 (string-append src "/" (number->string len))))
                           (get-attr attrs RTA_GATEWAY)
                           (route-message-protocol data)
                           (route-message-scope data)
                           (get-attr attrs RTA_PRIORITY)
                           (link-ref links (get-attr attrs RTA_OIF)))))
                     routes)))
      (close-socket sock)
      routes)))

(define print-route
  (match-lambda
    (($ <route> family table dest src gateway proto scope priority device)
     (format #t "    ~a"
             (or dest "default"))
     (when gateway
       (format #t " via ~a" gateway))
     (when device
       (format #t " dev ~a" (link-name device)))
     (when (and proto (> proto 0))
       (format #t " proto ~a"
               (string-downcase
                 (substring (symbol->string (int->rtm-protocol proto)) 7))))
     (when (and scope (> scope 0))
       (format #t " scope ~a"
               (string-downcase
                 (substring (symbol->string (int->rtm-scope scope)) 9))))
     (when src
       (format #t " src ~a" src))
     (when priority
       (format #t " metric ~a" priority))
     (format #t "~%"))))


(define* (route-show #:key (table RT_TABLE_MAIN) (family AF_UNSPEC))
  (define links (get-links))
  (define routes (get-routes links))

  (for-each
    (lambda (route)
      (when (and (equal? (route-table route) table)
                 (or (equal? family AF_UNSPEC)
                     (equal? (route-family route) family)))
        (print-route route)))
    routes))


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 route)
19	#:use-module (ice-9 match)
20	#:use-module (ip link)
21	#:use-module (ip utils)
22	#:use-module (netlink route route)
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 (route-add
32	route-del
33	route-show))
34
35	(define-record-type <route>
36	(make-route family table dest src gateway proto scope priority device)
37	route?
38	(family route-family)
39	(table route-table)
40	(dest route-dest)
41	(src route-src)
42	(gateway route-gateway)
43	(proto route-proto)
44	(scope route-scope)
45	(priority route-priority)
46	(device route-device))
47
48	(define* (route-del dest
49	#:key (ipv6? #f) (device #f) (table RT_TABLE_MAIN)
50	(protocol #f) (scope RT_SCOPE_NOWHERE) (type #f)
51	(priority #f) (src #f) (via #f))
52	(define request-num (random 65535))
53
54	(define index
55	(cond
56	((number? device) device)
57	((string? device) (link-name->index device))
58	(else #f)))
59
60	(define message
61	(make-message
62	RTM_DELROUTE
63	(logior NLM_F_REQUEST NLM_F_ACK)
64	request-num
65	0
66	(make-route-message
67	(if ipv6? AF_INET6 AF_INET)
68	(if (equal? dest "default") 0 (cidr->prefix dest))
69	(if src (cidr->prefix src) 0)
70	0
71	table
72	(or protocol 0)
73	scope
74	(or type 0)
75	0
76	`(,@(if (equal? dest "default")
77	'()
78	(list (make-route-attr RTA_DST
79	((if ipv6?
80	make-ipv6-route-attr
81	make-ipv4-route-attr)
82	(cidr->addr dest)))))
83	,@(if index
84	(list (make-route-attr RTA_OIF
85	(make-u32-route-attr index)))
86	'())
87	,@(if src
88	(list (make-route-attr RTA_PREFSRC
89	((if ipv6?
90	make-ipv6-route-attr
91	make-ipv4-route-attr)
92	(cidr->addr src))))
93	'())
94	,@(if via
95	(list (make-route-attr RTA_GATEWAY
96	((if ipv6?
97	make-ipv6-route-attr
98	make-ipv4-route-attr)
99	via)))
100	'())
101	,@(if priority
102	(list (make-route-attr RTA_PRIORITY
103	(make-u32-route-attr priority)))
104	'())))))
105
106	(let ((sock (connect-route)))
107	(send-msg message sock)
108	(let ((answer (receive-and-decode-msg sock %default-route-decoder)))
109	(close-socket sock)
110	(answer-ok? (last answer)))))
111
112	(define* (route-add dest
113	#:key (ipv6? #f) (device #f) (table RT_TABLE_MAIN)
114	(protocol #f) (scope RT_SCOPE_LINK)
115	(type RTN_UNICAST) (priority #f) (src #f) (via #f))
116	(define request-num (random 65535))
117
118	(define index
119	(cond
120	((number? device) device)
121	((string? device) (link-name->index device))
122	(else #f)))
123
124	(define message
125	(make-message
126	RTM_NEWROUTE
127	(logior NLM_F_REQUEST NLM_F_ACK NLM_F_EXCL NLM_F_CREATE)
128	request-num
129	0
130	(make-route-message
131	(if ipv6? AF_INET6 AF_INET)
132	(if (equal? dest "default") 0 (cidr->prefix dest))
133	(if src (cidr->prefix src) 0)
134	0
135	table
136	(or protocol 0)
137	scope
138	type
139	0
140	`(,@(if (equal? dest "default")
141	'()
142	(list (make-route-attr RTA_DST
143	((if ipv6?
144	make-ipv6-route-attr
145	make-ipv4-route-attr)
146	(cidr->addr dest)))))
147	,@(if index
148	(list (make-route-attr RTA_OIF
149	(make-u32-route-attr index)))
150	'())
151	,@(if src
152	(list (make-route-attr RTA_PREFSRC
153	((if ipv6?
154	make-ipv6-route-attr
155	make-ipv4-route-attr)
156	(cidr->addr src))))
157	'())
158	,@(if via
159	(list (make-route-attr RTA_GATEWAY
160	((if ipv6?
161	make-ipv6-route-attr
162	make-ipv4-route-attr)
163	via)))
164	'())
165	,@(if priority
166	(list (make-route-attr RTA_PRIORITY
167	(make-u32-route-attr priority)))
168	'())))))
169
170	(let ((sock (connect-route)))
171	(send-msg message sock)
172	(let ((answer (receive-and-decode-msg sock %default-route-decoder)))
173	(close-socket sock)
174	(answer-ok? (last answer)))))
175
176	(define (link-ref links id)
177	(let loop ((links links))
178	(match links
179	(() #f)
180	((link links ...)
181	(if (equal? (link-id link) id)
182	link
183	(loop links))))))
184
185	(define (get-routes links)
186	(define request-num (random 65535))
187	(define message
188	(make-message
189	RTM_GETROUTE
190	(logior NLM_F_REQUEST NLM_F_DUMP)
191	request-num
192	0
193	(make-route-message AF_UNSPEC 0 0 0 0 0 0 0 0 '())))
194	(let ((sock (connect-route)))
195	(send-msg message sock)
196	(let* ((answer (receive-and-decode-msg sock %default-route-decoder))
197	(routes (filter
198	(lambda (msg) (equal? (message-kind msg) RTM_NEWROUTE))
199	answer))
200	(routes (map
201	(lambda (msg)
202	(let* ((data (message-data msg))
203	(attrs (route-message-attrs data)))
204	(make-route
205	(route-message-family data)
206	(or (get-attr attrs RTA_TABLE)
207	(route-message-table data))
208	(let ((len (route-message-dest-len data))
209	(dest (get-attr attrs RTA_DST)))
210	(if (or (equal? len 0) (not dest))
211	#f
212	(string-append dest "/" (number->string len))))
213	(let ((len (route-message-src-len data))
214	(src (get-attr attrs RTA_PREFSRC)))
215	(if (or (equal? len 0) (not src))
216	#f
217	(string-append src "/" (number->string len))))
218	(get-attr attrs RTA_GATEWAY)
219	(route-message-protocol data)
220	(route-message-scope data)
221	(get-attr attrs RTA_PRIORITY)
222	(link-ref links (get-attr attrs RTA_OIF)))))
223	routes)))
224	(close-socket sock)
225	routes)))
226
227	(define print-route
228	(match-lambda
229	(($ <route> family table dest src gateway proto scope priority device)
230	(format #t " ~a"
231	(or dest "default"))
232	(when gateway
233	(format #t " via ~a" gateway))
234	(when device
235	(format #t " dev ~a" (link-name device)))
236	(when (and proto (> proto 0))
237	(format #t " proto ~a"
238	(string-downcase
239	(substring (symbol->string (int->rtm-protocol proto)) 7))))
240	(when (and scope (> scope 0))
241	(format #t " scope ~a"
242	(string-downcase
243	(substring (symbol->string (int->rtm-scope scope)) 9))))
244	(when src
245	(format #t " src ~a" src))
246	(when priority
247	(format #t " metric ~a" priority))
248	(format #t "~%"))))
249
250
251	(define* (route-show #:key (table RT_TABLE_MAIN) (family AF_UNSPEC))
252	(define links (get-links))
253	(define routes (get-routes links))
254
255	(for-each
256	(lambda (route)
257	(when (and (equal? (route-table route) table)
258	(or (equal? family AF_UNSPEC)
259	(equal? (route-family route) family)))
260	(print-route route)))
261	routes))
262