connection.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 (netlink connection) |
19 | #:use-module (netlink constant) |
20 | #:use-module (netlink data) |
21 | #:use-module (netlink error) |
22 | #:use-module (netlink message) |
23 | #:use-module (rnrs bytevectors) |
24 | #:use-module (system foreign) |
25 | #:use-module (srfi srfi-9) |
26 | #:use-module (srfi srfi-34) |
27 | #:use-module (srfi srfi-35) |
28 | #:export (connect |
29 | connect-route |
30 | close-socket |
31 | send-msg |
32 | receive-msg |
33 | receive-and-decode-msg |
34 | get-addr)) |
35 | |
36 | (define libc (dynamic-link)) |
37 | (define ffi-socket (pointer->procedure int |
38 | (dynamic-func "socket" libc) |
39 | (list int int int))) |
40 | (define ffi-close (pointer->procedure void |
41 | (dynamic-func "close" libc) |
42 | (list int))) |
43 | (define ffi-sendmsg (pointer->procedure int |
44 | (dynamic-func "sendmsg" libc) |
45 | (list int '* int) |
46 | #:return-errno? #t)) |
47 | (define ffi-sendto (pointer->procedure int |
48 | (dynamic-func "sendto" libc) |
49 | (list int '* size_t int '* int) |
50 | #:return-errno? #t)) |
51 | (define ffi-recvmsg (pointer->procedure int |
52 | (dynamic-func "recvmsg" libc) |
53 | (list int '* int))) |
54 | (define ffi-bind (pointer->procedure int |
55 | (dynamic-func "bind" libc) |
56 | (list int '* int))) |
57 | |
58 | ;; define socket type |
59 | (define-record-type socket |
60 | (make-socket num open?) |
61 | socket? |
62 | (num socket-num) |
63 | (open? socket-open?)) |
64 | |
65 | ;; define simple functions to open/close sockets |
66 | (define (open-socket proto) |
67 | (make-socket (ffi-socket AF_NETLINK (logior SOCK_RAW SOCK_CLOEXEC) proto) #t)) |
68 | (define (close-socket socket) |
69 | (if (socket-open? socket) |
70 | (ffi-close (socket-num socket))) |
71 | (make-socket (socket-num socket) #f)) |
72 | |
73 | (define (get-addr family pid groups) |
74 | (let ((addr (make-bytevector 12))) |
75 | (bytevector-u16-set! addr 0 family (native-endianness)) |
76 | (bytevector-u32-set! addr 4 pid (native-endianness)) |
77 | (bytevector-u32-set! addr 8 groups (native-endianness)) |
78 | addr)) |
79 | |
80 | (define (get-msghdr name namelen iov iovlen control controllen flags) |
81 | (make-c-struct |
82 | (list '* size_t '* size_t '* size_t int) |
83 | (list name namelen iov iovlen control controllen flags))) |
84 | |
85 | (define (get-iovec content size) |
86 | (make-c-struct |
87 | (list '* size_t) |
88 | (list content size))) |
89 | |
90 | (define* (connect proto addr) |
91 | (let ((sock (open-socket proto))) |
92 | (ffi-bind (socket-num sock) |
93 | (bytevector->pointer addr) |
94 | 12) |
95 | sock)) |
96 | |
97 | (define* (connect-route #:key (groups 0)) |
98 | (connect NETLINK_ROUTE (get-addr AF_NETLINK 0 groups))) |
99 | |
100 | (define* (send-msg msg sock #:key (addr (get-addr AF_NETLINK 0 0))) |
101 | (unless (message? msg) |
102 | (raise (condition (&netlink-message-type-error |
103 | (message msg))))) |
104 | |
105 | (let* ((len (data-size msg)) |
106 | (bv (make-bytevector len))) |
107 | (serialize msg 0 bv) |
108 | (ffi-sendto (socket-num sock) (bytevector->pointer bv) len 0 %null-pointer 0))) |
109 | |
110 | (define* (receive-msg sock #:key (addr (get-addr AF_NETLINK 0 0))) |
111 | (let* ((len (* 1024 32)) |
112 | (bv (make-bytevector len)) |
113 | (iovec (get-iovec (bytevector->pointer bv) len)) |
114 | (msghdr (get-msghdr (bytevector->pointer addr) (bytevector-length addr) |
115 | iovec 1 |
116 | %null-pointer 0 |
117 | 0)) |
118 | (size (ffi-recvmsg (socket-num sock) msghdr 0)) |
119 | (answer (make-bytevector size))) |
120 | (when (> size (* 1024 32)) |
121 | (raise (condition (&netlink-answer-too-big-error (size size))))) |
122 | (when (> size 0) |
123 | (bytevector-copy! bv 0 answer 0 size)) |
124 | answer)) |
125 | |
126 | (define* (receive-and-decode-msg sock decoder |
127 | #:key (addr (get-addr AF_NETLINK 0 0))) |
128 | (let* ((answer (receive-msg sock #:addr addr)) |
129 | (size (bytevector-length answer))) |
130 | (let loop ((messages '()) (pos 0)) |
131 | (if (>= pos size) |
132 | (let ((last-message (car messages))) |
133 | (if (and |
134 | (equal? (logand (message-flags last-message) NLM_F_MULTI) |
135 | NLM_F_MULTI) |
136 | (> (message-kind last-message) NLMSG_OVERUN)) |
137 | (append (reverse messages) |
138 | (receive-and-decode-msg sock decoder #:addr addr)) |
139 | (reverse messages))) |
140 | (let ((message (deserialize 'message decoder answer pos))) |
141 | (loop (cons message messages) |
142 | (+ (data-size message) pos))))))) |
143 |