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 | #:autoload (ice-9 suspendable-ports) (current-read-waiter |
30 | current-write-waiter) |
31 | #:export (connect |
32 | connect-route |
33 | close-socket |
34 | send-msg |
35 | receive-msg |
36 | receive-and-decode-msg |
37 | get-addr)) |
38 | |
39 | (define libc (dynamic-link)) |
40 | |
41 | (define* (syscall->procedure return-type function |
42 | argument-types |
43 | #:key waiter) |
44 | "Return a procedure that calls FUNCTION, a syscall wrapper from the C library |
45 | with the given RETURN-TYPE and ARGUMENT-TYPES. When WAITER is true and the |
46 | first argument is a port, call it upon EAGAIN or EWOULDBLOCK." |
47 | (let ((proc (pointer->procedure return-type |
48 | (dynamic-func function libc) |
49 | argument-types |
50 | #:return-errno? #t))) |
51 | (lambda (first . rest) |
52 | (let loop () |
53 | (let ((ret errno (apply proc |
54 | (if (port? first) (fileno first) first) |
55 | rest))) |
56 | (if (< ret 0) |
57 | (if (and (memv errno (list EAGAIN EWOULDBLOCK)) |
58 | (port? first) waiter) |
59 | (begin |
60 | ((waiter) first) |
61 | (loop)) |
62 | (throw 'system-error function "~A" |
63 | (list (strerror errno)) (list errno))) |
64 | ret)))))) |
65 | |
66 | (define ffi-sendto |
67 | (syscall->procedure int "sendto" (list int '* size_t int '* int) |
68 | #:waiter (lambda () (current-write-waiter)))) |
69 | (define ffi-recvmsg |
70 | (syscall->procedure int "recvmsg" (list int '* int) |
71 | #:waiter (lambda () (current-read-waiter)))) |
72 | (define ffi-bind |
73 | (syscall->procedure int "bind" (list int '* int) |
74 | #:waiter (lambda () (current-read-waiter)))) |
75 | |
76 | ;; define simple functions to open/close sockets |
77 | (define (open-socket proto flags) |
78 | (socket AF_NETLINK (logior SOCK_RAW SOCK_CLOEXEC flags) proto)) |
79 | |
80 | (define (close-socket sock) |
81 | (issue-deprecation-warning |
82 | "'close-socket' is deprecated; use 'close-port' instead.") |
83 | (close-port sock)) |
84 | |
85 | (define (get-addr family pid groups) |
86 | "This is a variant of 'make-socket-address' for AF_NETLINK sockets. The |
87 | main difference is that it returns a raw bytevector that libguile procedures |
88 | such as 'bind' cannot handle." |
89 | (let ((addr (make-bytevector 12))) |
90 | (bytevector-u16-set! addr 0 family (native-endianness)) |
91 | (bytevector-u32-set! addr 4 pid (native-endianness)) |
92 | (bytevector-u32-set! addr 8 groups (native-endianness)) |
93 | addr)) |
94 | |
95 | (define (get-msghdr name namelen iov iovlen control controllen flags) |
96 | (make-c-struct |
97 | (list '* size_t '* size_t '* size_t int) |
98 | (list name namelen iov iovlen control controllen flags))) |
99 | |
100 | (define (get-iovec content size) |
101 | (make-c-struct |
102 | (list '* size_t) |
103 | (list content size))) |
104 | |
105 | (define* (connect proto addr #:key (flags 0)) |
106 | (let ((sock (open-socket proto flags))) |
107 | (ffi-bind sock |
108 | (bytevector->pointer addr) |
109 | 12) |
110 | sock)) |
111 | |
112 | (define* (connect-route #:key (groups 0) (flags 0)) |
113 | (connect NETLINK_ROUTE (get-addr AF_NETLINK 0 groups) |
114 | #:flags flags)) |
115 | |
116 | (define* (send-msg msg sock #:key (addr (get-addr AF_NETLINK 0 0))) |
117 | (unless (message? msg) |
118 | (raise (condition (&netlink-message-type-error |
119 | (message msg))))) |
120 | |
121 | (let* ((len (data-size msg)) |
122 | (bv (make-bytevector len))) |
123 | (serialize msg 0 bv) |
124 | (ffi-sendto sock (bytevector->pointer bv) len 0 %null-pointer 0))) |
125 | |
126 | (define* (receive-msg sock #:key (addr (get-addr AF_NETLINK 0 0))) |
127 | (let* ((len (* 1024 32)) |
128 | (bv (make-bytevector len)) |
129 | (iovec (get-iovec (bytevector->pointer bv) len)) |
130 | (msghdr (get-msghdr (bytevector->pointer addr) (bytevector-length addr) |
131 | iovec 1 |
132 | %null-pointer 0 |
133 | 0)) |
134 | (size (ffi-recvmsg sock msghdr 0)) |
135 | (answer (make-bytevector size))) |
136 | (when (> size (* 1024 32)) |
137 | (raise (condition (&netlink-answer-too-big-error (size size))))) |
138 | (when (> size 0) |
139 | (bytevector-copy! bv 0 answer 0 size)) |
140 | answer)) |
141 | |
142 | (define* (receive-and-decode-msg sock decoder |
143 | #:key (addr (get-addr AF_NETLINK 0 0))) |
144 | (let* ((answer (receive-msg sock #:addr addr)) |
145 | (size (bytevector-length answer))) |
146 | (let loop ((messages '()) (pos 0)) |
147 | (if (>= pos size) |
148 | (let ((last-message (car messages))) |
149 | (if (and |
150 | (equal? (logand (message-flags last-message) NLM_F_MULTI) |
151 | NLM_F_MULTI) |
152 | (> (message-kind last-message) NLMSG_OVERUN)) |
153 | (append (reverse messages) |
154 | (receive-and-decode-msg sock decoder #:addr addr)) |
155 | (reverse messages))) |
156 | (let ((message (deserialize 'message decoder answer pos))) |
157 | (loop (cons message messages) |
158 | (+ (data-size message) pos))))))) |
159 |