link.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 link) |
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-link-message |
25 | link-message? |
26 | link-message-family |
27 | link-message-kind |
28 | link-message-index |
29 | link-message-flags |
30 | link-message-attrs |
31 | deserialize-link-message)) |
32 | |
33 | (define (align pos to) |
34 | (+ pos -1 (- to (modulo (- pos 1) to)))) |
35 | |
36 | (define-data-type link-message |
37 | (lambda (msg) |
38 | (+ 16 (apply + (map (lambda (d) (align (data-size d) 4)) attrs)))) |
39 | (lambda (msg pos bv) |
40 | (match msg |
41 | (($ link-message-type family type index flags attrs) |
42 | (bytevector-u16-set! bv pos family (native-endianness)) |
43 | (bytevector-u16-set! bv (+ pos 2) type (native-endianness)) |
44 | (bytevector-u32-set! bv (+ pos 4) index (native-endianness)) |
45 | (bytevector-u32-set! bv (+ pos 8) flags (native-endianness)) |
46 | (let loop ((attrs attrs) (pos (+ pos 16))) |
47 | (match attrs |
48 | ((attr attrs ...) |
49 | (serialize attr pos bv) |
50 | (loop attrs (+ pos (align (data-size attr) 4)))) |
51 | (() #t)))))) |
52 | (family link-message-family link-message-type-family) |
53 | (type link-message-kind link-message-type-type) |
54 | (index link-message-index link-message-type-index) |
55 | (flags link-message-flags link-message-type-flags) |
56 | (attrs link-message-attrs link-message-type-attrs)) |
57 | |
58 | (define (deserialize-link-message decoder bv pos) |
59 | (make-link-message |
60 | (bytevector-u16-ref bv pos (native-endianness)) |
61 | (bytevector-u16-ref bv (+ pos 2) (native-endianness)) |
62 | (bytevector-u32-ref bv (+ pos 4) (native-endianness)) |
63 | (bytevector-u32-ref bv (+ pos 8) (native-endianness)) |
64 | (let ((len (bytevector-length bv))) |
65 | (let loop ((pos (+ pos 16)) (attrs '())) |
66 | (if (>= pos len) |
67 | attrs |
68 | (let ((attr (deserialize 'attr decoder bv pos))) |
69 | (loop (+ pos (align (data-size attr) 4)) |
70 | (cons attr attrs)))))))) |
71 |