guile-netlink/ip/utils.scm

utils.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 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
29
(define (answer-ok? answer)
30
  (cond
31
    ((equal? (message-kind answer) NLMSG_DONE)
32
     #t)
33
    ((equal? (message-kind answer) NLMSG_ERROR)
34
     (let ((data (message-data answer)))
35
       (if (nl-data-data data)
36
           (let ((err (error-message-err data)))
37
             (if (equal? err 0)
38
                 #t
39
                 (begin
40
                   (format #t "RTNETLINK answers: ~a~%" (strerror (- err)))
41
                   #f)))
42
           #f)))))
43
44
(define (get-attr attrs type)
45
  (let ((attrs (filter (lambda (attr) (equal? (route-attr-kind attr) type)) attrs)))
46
    (match attrs
47
      (() #f)
48
      ((attr) (nl-data-data (route-attr-data attr))))))
49
50
(define (split-flags flags)
51
  (let loop ((max-flag 262144) (flags flags) (result '()))
52
    (cond
53
      ((equal? max-flag 1)
54
       (if (equal? flags 1)
55
           (cons 1 result)
56
           result))
57
      ((< flags max-flag)
58
       (loop (/ max-flag 2) flags result))
59
      (else
60
        (loop (/ max-flag 2) (- flags max-flag)
61
              (cons max-flag result))))))
62