guile-netlink/ip/utils.scm

utils.scm

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 utils)
19
  #:use-module (ice-9 match)
20
  #:use-module (netlink constant)
21
  #:use-module (netlink data)
22
  #:use-module (netlink message)
23
  #:use-module (netlink route attrs)
24
  #:use-module (netlink standard)
25
  #:export (answer-ok?
26
            get-attr
27
            split-flags
28
            cidr->addr
29
            cidr->prefix))
30
31
(define (answer-ok? answer)
32
  (cond
33
    ((equal? (message-kind answer) NLMSG_DONE)
34
     #t)
35
    ((equal? (message-kind answer) NLMSG_ERROR)
36
     (let ((data (message-data answer)))
37
       (if (nl-data-data data)
38
           (let ((err (error-message-err data)))
39
             (if (equal? err 0)
40
                 #t
41
                 (begin
42
                   (format #t "RTNETLINK answers: ~a~%" (strerror (- err)))
43
                   #f)))
44
           #f)))))
45
46
(define (get-attr attrs type)
47
  (let ((attrs (filter (lambda (attr) (equal? (route-attr-kind attr) type)) attrs)))
48
    (match attrs
49
      (() #f)
50
      ((attr) (nl-data-data (route-attr-data attr))))))
51
52
(define (split-flags flags)
53
  (let loop ((max-flag 262144) (flags flags) (result '()))
54
    (cond
55
      ((equal? max-flag 1)
56
       (if (equal? flags 1)
57
           (cons 1 result)
58
           result))
59
      ((< flags max-flag)
60
       (loop (/ max-flag 2) flags result))
61
      (else
62
        (loop (/ max-flag 2) (- flags max-flag)
63
              (cons max-flag result))))))
64
65
(define (cidr->addr str)
66
  (match (string-split str #\/)
67
    ((addr) addr)
68
    ((addr prefix) addr)
69
    (_ (throw 'incorrect-cidr-notation str))))
70
71
(define (cidr->prefix str)
72
  (match (string-split str #\/)
73
    ((addr) #f)
74
    ((addr prefix) (string->number prefix))
75
    (_ (throw 'incorrect-cidr-notation str))))
76