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