addr.scm
1 | ;;;; Copyright (C) 2020 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 (netlink route addr) |
19 | #:use-module (ice-9 match) |
20 | #:use-module (netlink data) |
21 | #:use-module (netlink route attrs) |
22 | #:use-module (srfi srfi-9) |
23 | #:use-module (rnrs bytevectors) |
24 | #:export (make-addr-message |
25 | addr-message? |
26 | addr-message-family |
27 | addr-message-prefix-len |
28 | addr-message-flags |
29 | addr-message-scope |
30 | addr-message-index |
31 | addr-message-attrs |
32 | deserialize-addr-message)) |
33 | |
34 | (define (align pos to) |
35 | (+ pos -1 (- to (modulo (- pos 1) to)))) |
36 | |
37 | (define-data-type addr-message |
38 | (lambda (msg) |
39 | (+ 8 (apply + (map (lambda (d) (align (data-size d) 4)) attrs)))) |
40 | (lambda (msg pos bv) |
41 | (match msg |
42 | (($ addr-message-type family prefix-len flags scope index attrs) |
43 | (bytevector-u8-set! bv pos family) |
44 | (bytevector-u8-set! bv (+ pos 1) prefix-len) |
45 | (bytevector-u8-set! bv (+ pos 2) flags) |
46 | (bytevector-u8-set! bv (+ pos 3) scope) |
47 | (bytevector-u32-set! bv (+ pos 4) index (native-endianness)) |
48 | (let loop ((attrs attrs) (pos (+ pos 8))) |
49 | (match attrs |
50 | ((attr attrs ...) |
51 | (serialize attr pos bv) |
52 | (loop attrs (+ pos (align (data-size attr) 4)))) |
53 | (() #t)))))) |
54 | (family addr-message-family addr-message-type-family) |
55 | (prefix-len addr-message-prefix-len addr-message-type-prefix-len) |
56 | (flags addr-message-flags addr-message-type-flags) |
57 | (scope addr-message-scope addr-message-type-scope) |
58 | (index addr-message-index addr-message-type-index) |
59 | (attrs addr-message-attrs addr-message-type-attrs)) |
60 | |
61 | (define (deserialize-addr-message decoder bv pos) |
62 | (let ((family (bytevector-u8-ref bv pos))) |
63 | (make-addr-message |
64 | family |
65 | (bytevector-u8-ref bv (+ pos 1)) |
66 | (bytevector-u8-ref bv (+ pos 2)) |
67 | (bytevector-u8-ref bv (+ pos 3)) |
68 | (bytevector-u32-ref bv (+ pos 4) (native-endianness)) |
69 | (let ((len (bytevector-length bv))) |
70 | (let loop ((pos (+ pos 8)) (attrs '())) |
71 | (if (>= pos len) |
72 | attrs |
73 | (let ((attr (deserialize (cond |
74 | ((equal? family AF_INET) 'ipv4-addr-attr) |
75 | ((equal? family AF_INET6) 'ipv6-addr-attr) |
76 | (else (throw 'unknown-family family))) |
77 | decoder bv pos))) |
78 | (loop (+ pos (align (data-size attr) 4)) |
79 | (cons attr attrs))))))))) |
80 |