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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
|
;; This file is part of scheme-GNUnet, a partial Scheme port of 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: AGPL-3.0-or-later
;; Brief: A quaject for keeping configuration together.
;; Author: Maxime Devos
;; This module has quite some differences from the C implementation.
(define-library (gnu gnunet config db)
(export <configuration>
make-configuration
configuration?
read-value
set-value!
undefine-key!
#; notify-me-on-change!
&config-error make-config-error config-error?
config-error-section config-error-key
&undefined-key-error make-undefined-key-error undefined-key-error?
&unwritable-key-error make-unwritable-key-error unwritable-key-error?
&unundefinable-key-error make-unundefinable-key-error
unundefinable-key-error?
hash->configuration
hash-key key=?)
(import (only (rnrs base)
begin define lambda assert cons string? if
let values and eq? + car cdr string=?)
(only (rnrs exceptions)
raise)
(only (rnrs records syntactic)
define-record-type)
(only (rnrs conditions)
define-condition-type &error)
(only (rnrs hashtables)
hashtable-ref hashtable-set! hashtable-delete!
hashtable-contains? hashtable? hashtable-mutable?
string-hash)
(srfi srfi-26)
(only (srfi srfi-8)
receive)
(only (ice-9 optargs)
lambda*))
(begin
(define-condition-type &config-error &error
make-config-error config-error?
(section config-error-section)
(key config-error-key))
(define-condition-type &undefined-key-error &config-error
make-undefined-key-error undefined-key-error?)
(define-condition-type &unwritable-key-error &config-error
make-unwritable-key-error unwritable-key-error?)
(define-condition-type &unundefinable-key-error &config-error
make-unundefinable-key-error unundefinable-key-error?)
;; The configuration quaject.
;; The concept quaject is documented in
;; <https://valerieaurora.org/synthesis/SynthesisOS/ch4.html>.
(define (default-read-value/raw section key)
(raise (make-undefined-key-error section key)))
(define (default-set-value!/raw section key value)
(raise (make-unwritable-key-error section key)))
(define (default-undefine-key! section key)
(raise (make-unundefinable-key-error section key)))
(define-record-type (<configuration> make-configuration configuration?)
(fields (mutable read-value/raw %read-value/raw %set-read-value/raw!)
(mutable set-value!/raw %set-value!/raw %set-set-value!/raw!)
(mutable undefine-key! %undefine-key! %set-undefine-key!!)
#;(immutable notify-me-on-change! ...))
(sealed #f)
(opaque #t)
(protocol (lambda (%make)
(lambda* (#:key
(read-value/raw default-read-value/raw)
(set-value!/raw default-set-value!/raw)
(undefine-key! default-undefine-key!))
"Make a configuration quaject, that reads configuration
values with the callentry @var{read-value/raw}, writes configuration values
with the callentry @var{set-value!/raw} and undefines values with the
callentry @var{undefine-key!}. They default to procedures raising
a @code{&undefined-key-error}, @code{&unwritable-key-error} and
@code{&unundefinable-key-error} respectively.
The @var{read-value/raw} callentry accepts a section and key as strings,
and is expected to return a string or raise a @code{&undefined-key-error}.
The @var{undefine-key!} callentry accepts a section and key as strings,
and is expected to raise a @code{&unundefinable-key-error} when appropriate
(e.g. when the key was already undefined).
The @var{set-value!/raw} callentry accepts a section, key and value as string,
and is expected to raise a @code{&unwritable-key-error} when appropriate
(e.g. the configuration is read-only).
Three additional values are returned: a mutator for the @var{read-value/raw},
@var{set-value!/raw} and @var{undefine-key!} callentries. More values may be
returned in a later version."
(let ((c (%make read-value/raw set-value!/raw
undefine-key!)))
(values c
(cut %set-read-value/raw! c <>)
(cut %set-set-value!/raw! c <>)
(cut %set-undefine-key!! c <>)))))))
(define (read-value value->object config section key)
"Return the value of the key @var{key} in the section @var{section}
of the configuration @var{config}. The raw value string with
@var{value->object} in tail position. The raw value is retrieved with
the @code{read-value/raw} callentry of @var{config}, which is expected
to raise a @code{&undefined-key-error} exception when appropriate, which will
be propagated."
(value->object ((%read-value/raw config) section key)))
(define (set-value! object->value config section key object)
"Write the object @var{object} to the key @var{key} in the section
@var{section} in the configuration @var{config}. The conversion to a
raw value string is done with @var{object->value}. The raw value is
written with the @code{set-value!/raw} callentry of @var{config}, which
is expected to raise a @code{&unwritable-key-error} exception when appropriate,
which will be propagated."
((%set-value!/raw config) section key (object->value object)))
(define (undefine-key! config section key)
"Undefine the value of the key @var{key} in the section @var{section}
of the configuration @var{config}. When appropriate (e.g. the configuration
is read-only or the key is already undefined), the @code{undefine-key!}
callentry of @var{config} is expected to raise a
@code{&unundefinable-key-error}, which will be propagated."
((%undefine-key! config) section key))
;; Configuration quaject implementation.
(define *unequal* (cons #f #f))
(define (hash-key section+key)
"Hash a @code{(section . key)} pair, for use in R6RS hash tables."
;; Wild guess.
(+ (string-hash (car section+key))
(string-hash (cdr section+key))))
(define (key=? section+key/1 section+key/2)
(and (string=? (car section+key/1) (car section+key/2))
(string=? (cdr section+key/1) (cdr section+key/2))))
(define (hash->configuration hash)
"Make a configuration quaject backed by the hash table @var{table}.
The keys are pairs @code{(section . key)}, where @var{section} and @var{key}
are strings. The values are the raw string values. The contents of
@var{hash} is not verified, but presumed to be correctly typed.
Currently, one additional value is returned: a mutator for replacing the
hash table in use. Replacing the hash table is not an atomic operation;
while the hash table is being replaced, either the new or the old hash
table will be used by the callentries."
(define (%read-value/raw hash section key)
(assert (and (string? section) (string? key)))
;; Grrr SRFI hash-table-ref is nicer
(let ((value (hashtable-ref hash (cons section key) *unequal*)))
(if (eq? *unequal* value)
(raise (make-undefined-key-error section key))
value)))
(define (%set-value!/raw-mutable hash section key value)
(assert (and (string? section) (string? key) (string? value)))
(hashtable-set! hash (cons section key) value))
(define (%undefine-key!/mutable hash section key)
(assert (and (string? section) (string? key)))
(let ((k (cons section key)))
(if (hashtable-contains? hash k)
(hashtable-delete! hash (cons section key))
(raise (make-unundefinable-key-error section key)))))
(receive (c set-read-value/raw! set-set-value!/raw!
set-undefine-key!!)
(make-configuration
#:read-value/raw (cut %read-value/raw hash <> <>)
#:set-value!/raw (if (hashtable-mutable? hash)
(cut %set-value!/raw-mutable hash <> <> <>)
default-set-value!/raw)
#:undefine-key! (if (hashtable-mutable? hash)
(cut %undefine-key!/mutable hash <> <>)
default-undefine-key!))
(values c
(lambda (hash)
(assert (hashtable? hash))
(set-read-value/raw! (cut %read-value/raw hash <> <>))
(set-set-value!/raw!
(if (hashtable-mutable? hash)
(cut %set-value!/raw-mutable hash <> <> <>)
default-set-value!/raw))
(set-undefine-key!!
(if (hashtable-mutable? hash)
(cut %undefine-key!/mutable hash <> <>)
default-undefine-key!))))))))
|
