connection.scm
1 | ;;;; This file is part of Guile Netlink |
2 | ;;;; |
3 | ;;;; Copyright (C) 2021 Julien Lepiller <julien@lepiller.eu> |
4 | ;;;; Copyright (C) 2023 Ludovic Courtès <ludo@gnu.org> |
5 | ;;;; |
6 | ;;;; This library is free software: you can redistribute it and/or modify |
7 | ;;;; it under the terms of the GNU General Public License as published by |
8 | ;;;; the Free Software Foundation, either version 3 of the License, or |
9 | ;;;; (at your option) any later version. |
10 | ;;;; |
11 | ;;;; This library is distributed in the hope that it will be useful, |
12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
14 | ;;;; GNU General Public License for more details. |
15 | ;;;; |
16 | ;;;; You should have received a copy of the GNU General Public License |
17 | ;;;; along with this library. If not, see <https://www.gnu.org/licenses/>. |
18 | |
19 | (define-module (netlink connection) |
20 | #:use-module (netlink constant) |
21 | #:use-module (netlink data) |
22 | #:use-module (netlink error) |
23 | #:use-module (netlink message) |
24 | #:use-module (rnrs bytevectors) |
25 | #:use-module (system foreign) |
26 | #:use-module (srfi srfi-34) |
27 | #:use-module (srfi srfi-35) |
28 | #:use-module (srfi srfi-71) |
29 | #:export (connect |
30 | connect-route |
31 | close-socket |
32 | send-msg |
33 | receive-msg |
34 | receive-and-decode-msg |
35 | get-addr)) |
36 | |
37 | (define libc (dynamic-link)) |
38 | |
39 | (define (syscall->procedure return-type function |
40 | argument-types) |
41 | "Return a procedure that calls FUNCTION, a syscall wrapper from the C library |
42 | with the given RETURN-TYPE and ARGUMENT-TYPES." |
43 | (let ((proc (pointer->procedure return-type |
44 | (dynamic-func function libc) |
45 | argument-types |
46 | #:return-errno? #t))) |
47 | (lambda args |
48 | (let ((ret errno (apply proc args))) |
49 | (when (< ret 0) |
50 | (throw 'system-error function "~A" |
51 | (list (strerror errno)) (list errno))) |
52 | ret)))) |
53 | |
54 | (define ffi-sendto |
55 | (syscall->procedure int "sendto" (list int '* size_t int '* int))) |
56 | (define ffi-recvmsg |
57 | (syscall->procedure int "recvmsg" (list int '* int))) |
58 | (define ffi-bind |
59 | (syscall->procedure int "bind" (list int '* int))) |
60 | |
61 | ;; define simple functions to open/close sockets |
62 | (define (open-socket proto) |
63 | (socket AF_NETLINK (logior SOCK_RAW SOCK_CLOEXEC) proto)) |
64 | |
65 | (define (close-socket sock) |
66 | (issue-deprecation-warning |
67 | "'close-socket' is deprecated; use 'close-port' instead.") |
68 | (close-port sock)) |
69 | |
70 | (define (get-addr family pid groups) |
71 | "This is a variant of 'make-socket-address' for AF_NETLINK sockets. The |
72 | main difference is that it returns a raw bytevector that libguile procedures |
73 | such as 'bind' cannot handle." |
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 (fileno 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 (fileno 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 (fileno 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 |