1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
;; This file is part of scheme-GNUnet.
;; Copyright (C) 2021 GNUnet e.V.
;;
;; scheme-GNUnet is free software: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published
;; by the Free Software Foundation, either version 3 of the License,
;; or (at your option) any later version.
;;
;; scheme-GNUnet is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;
;; SPDX-License-Identifier: AGPL3.0-or-later
;; @author Maxime Devos (scheme-GNUnet)
;;
;; @brief General-purpose message queue (message handlers)
(library (gnu gnunet mq handler)
(export <message-handler> message-handler
make-message-handler message-handler?
message-handler-index
verify-message? handle-message!
message-handlers message-handler-for)
(import (rnrs records syntactic)
(rnrs base)
(only (srfi srfi-43)
vector-index)
(only (gnu extractor enum)
integer->value value->index)
(only (gnu gnunet message protocols)
message-type message-type?))
(begin
;; TODO support docstrings for record types
;; in Guile
(define-record-type
(<message-handler> make-message-handler message-handler?)
;; Message type to handle. Currently a raw integer.
(fields (immutable index message-handler-index)
;; (() -> X) -> X for all X
(immutable interposition %message-handler-interposition)
(immutable verifier %message-verifier)
(immutable handler %message-handler))
(protocol
(lambda (%make)
(lambda (index interposition verifier handler)
"Make a message handler for messages of type
@var{index}. @var{index} must be a @code{message-type},
or its raw numeric value."
(%make (canonicalise-index index)
interposition verifier handler))))
(opaque #t)
;; Sure, why not?
;; Can be removed later (along with <message-handler>),
;; if proved troublesome.
(sealed #f))
(define-syntax message-handler
(syntax-rules (type interpose well-formed? handle!)
((_ (type the-type)
((interpose code) exp1 exp1* ...)
((well-formed? slice1) exp2 exp2* ...)
((handle! slice2) exp3 exp3* ...))
(let ((interpose
(lambda (thunk)
(let-syntax ((code (identifier-syntax (thunk))))
exp1 exp1* ...)))
(well-formed? (lambda (slice1) exp2 exp2* ...))
(handle! (lambda (slice2) exp3 exp3* ...)))
(make-message-handler the-type interpose well-formed? handle!)))))
(define (canonicalise-index index)
(cond ((and (integer? index)
(exact? index)
(<= 0 index)
(< index 65536))
index)
((message-type? index)
(value->index index))
;; FIXME nicer error message
(#t (assert #f))))
(define (call-with-interposed-environment handler thunk)
"Call the thunk @var{thunk} in the dynamic environment
of the message handler @var{handler} -- e.g., temporarily
raise/lower the ambient authority (root filesystem, user & groups,
...) when running on the Hurd, or adjust logging ports."
((%message-handler-interposition handler) thunk))
(define (verify-message? handler message)
"Verify whether @var{handler} considers @var{message}
to be acceptable (true/false). The message type should probably
be checked first, using @code{message-handler-index}."
(call-with-interposed-environment
handler
(lambda () ((%message-verifier handler) message))))
;; Why #\!? Because in practice handlers need some state.
(define (handle-message! handler message)
"Call ‘handler’ procedure of @var{handler} with @var{message}
(in the interposed environment)."
(call-with-interposed-environment
handler
(lambda () ((%message-handler handler) message))))
(define (message-handlers . rest)
"Construct a message handler vector, consisting
of the message handlers @var{rest}. Currently, this
is just a vector, but that might change at some point
in the future!"
;; XXX check for duplicates
(let ((vec (list->vector rest)))
(vector-for-each (lambda (x) (assert (message-handler? x)))
vec)
vec))
;; FIXME maybe a &no-handler exception is nicer?
(define (message-handler-for handlers index)
"Return the message handler for messages at an index
@var{index} (numeric value, or enum value), for the message
@var{message} (in the interposed environment). If no suitable
handler is found, return @code{#f} instead."
(let* ((index (canonicalise-index index))
(handler-index
(vector-index (lambda (handler)
(= index (message-handler-index handler)))
handlers)))
(and handler-index (vector-ref handlers handler-index))))))
|
