diff options
author | Maxime Devos <maximedevos@telenet.be> | 2021-02-04 17:10:02 +0100 |
---|---|---|
committer | Maxime Devos <maximedevos@telenet.be> | 2021-09-21 12:08:34 +0200 |
commit | 26fa30cb776b079cbfb0b3e6f47453ae2f2ea01d (patch) | |
tree | 2016bb22b23d4010f421bf55f0366b63a1bd4475 | |
parent | a94bf06a36997149fb38e98b48f4505c3024308e (diff) | |
download | gnunet-scheme-26fa30cb776b079cbfb0b3e6f47453ae2f2ea01d.tar.gz gnunet-scheme-26fa30cb776b079cbfb0b3e6f47453ae2f2ea01d.zip |
concurrency: implement an ‘update stream’
This will be used for communicating NSE values.
From README.org:
a box with a value, that can be updated,
resulting in a new box. Updates can be
waited upon.
* README.org (Modules): describe new module.
(Purpose): expand purpose.
* gnu/gnunet/concurrency/update.scm: implement new module.
* tests/update.scm: test new module.
-rw-r--r-- | README.org | 4 | ||||
-rw-r--r-- | gnu/gnunet/concurrency/update.scm | 107 | ||||
-rw-r--r-- | tests/update.scm | 112 |
3 files changed, 223 insertions, 0 deletions
@@ -30,6 +30,7 @@ | |||
30 | * Purposes | 30 | * Purposes |
31 | + for use by Guix and disarchive | 31 | + for use by Guix and disarchive |
32 | + bit-for-bit reproducibility in directory creation | 32 | + bit-for-bit reproducibility in directory creation |
33 | + a nice Scheme interface to GNUnet! | ||
33 | * Modules | 34 | * Modules |
34 | + gnu/gnunet/directory.scm: directory construction | 35 | + gnu/gnunet/directory.scm: directory construction |
35 | + gnu/gnunet/util/mq.scm and friends: message queues for | 36 | + gnu/gnunet/util/mq.scm and friends: message queues for |
@@ -37,6 +38,9 @@ | |||
37 | each message type. | 38 | each message type. |
38 | + gnu/gnunet/message/envelope.scm: some program data around | 39 | + gnu/gnunet/message/envelope.scm: some program data around |
39 | message types (e.g. priority, notify on sent hook) | 40 | message types (e.g. priority, notify on sent hook) |
41 | + gnu/gnunet/concurrency/update.scm: a box with a value, | ||
42 | that can be updated, resulting in a new box. Updates | ||
43 | can be waited upon. | ||
40 | * Conventions | 44 | * Conventions |
41 | ** Fiddling with options | 45 | ** Fiddling with options |
42 | Options like ‘priority’, ‘anonymity’, ‘replication’ | 46 | Options like ‘priority’, ‘anonymity’, ‘replication’ |
diff --git a/gnu/gnunet/concurrency/update.scm b/gnu/gnunet/concurrency/update.scm new file mode 100644 index 0000000..6a487cf --- /dev/null +++ b/gnu/gnunet/concurrency/update.scm | |||
@@ -0,0 +1,107 @@ | |||
1 | ;; This file is part of scheme-GNUnet. | ||
2 | ;; Copyright (C) 2021 Maxime Devos | ||
3 | ;; | ||
4 | ;; scheme-GNUnet is free software: you can redistribute it and/or modify it | ||
5 | ;; under the terms of the GNU Affero General Public License as published | ||
6 | ;; by the Free Software Foundation, either version 3 of the License, | ||
7 | ;; or (at your option) any later version. | ||
8 | ;; | ||
9 | ;; scheme-GNUnet is distributed in the hope that it will be useful, but | ||
10 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | ||
12 | ;; Affero General Public License for more details. | ||
13 | ;; | ||
14 | ;; You should have received a copy of the GNU Affero General Public License | ||
15 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. | ||
16 | ;; | ||
17 | ;; SPDX-License-Identifier: AGPL3.0-or-later | ||
18 | |||
19 | ;; (Can be relicensed for use in guile-fibers on request) | ||
20 | |||
21 | ;; A stream of values, of which the next value might not | ||
22 | ;; yet be determined, but can be waited upon. All can wait | ||
23 | ;; for an update and read the new value, but only the creator | ||
24 | ;; of the original update object can add new values. | ||
25 | |||
26 | ;; TODO implement a time machine for exploring alternate | ||
27 | ;; time-lines (maybe with a @code{time-machine} parameter, | ||
28 | ;; if time machines can be nested this way). | ||
29 | |||
30 | ;; Old updates are reclaimed by the garbage collector. | ||
31 | ;; TODO an implementation *not* relying on a garbage collector, | ||
32 | ;; at the cost of only allowing access to the latest value, | ||
33 | ;; would be nice to compare with. | ||
34 | |||
35 | ;; Example uses: | ||
36 | ;; - network-size estimation client (TODO) | ||
37 | |||
38 | (define-library (gnu gnunet concurrency update) | ||
39 | (export make-update update? update-value wait-for-update-operation | ||
40 | next-update next-update-peek | ||
41 | |||
42 | &double-update double-update? make-double-update-violation) | ||
43 | (import (rnrs records syntactic) | ||
44 | (rnrs conditions) | ||
45 | (rnrs base) | ||
46 | (rnrs exceptions) | ||
47 | (srfi srfi-8) | ||
48 | (fibers conditions) | ||
49 | (fibers operations) | ||
50 | (ice-9 atomic)) | ||
51 | (begin | ||
52 | (define-condition-type &double-update &violation | ||
53 | make-double-update-violation double-update?) | ||
54 | |||
55 | (define (double-update-violation) | ||
56 | (raise (condition | ||
57 | (make-who-condition 'update!) | ||
58 | (make-double-update-violation) | ||
59 | (make-message-condition "An update already exists!")))) | ||
60 | |||
61 | (define-record-type (<update> make-update update?) | ||
62 | (fields (immutable value update-value) | ||
63 | ;; value in box is #f if not yet updated, | ||
64 | ;; otherwise it is an <update> | ||
65 | (immutable next next-update-box) | ||
66 | (immutable when-next next-update-condition)) | ||
67 | (protocol | ||
68 | (lambda (%make) | ||
69 | (lambda (initial) | ||
70 | "Create an update object, initialised to @var{initial}. | ||
71 | Two values are returned: the update object and the update procedure." | ||
72 | (let ((update (%make initial (make-atomic-box #f) | ||
73 | (make-condition)))) | ||
74 | (define (update! next-value) | ||
75 | "Update the update object to the value @var{next-value}. | ||
76 | |||
77 | If the update object was already updated, raise a @code{&double-update} | ||
78 | instead. If the object was updated successfully, return the next update | ||
79 | object and updater." | ||
80 | (receive (next-update next-update!) (make-update next-value) | ||
81 | (case (atomic-box-compare-and-swap! | ||
82 | (next-update-box update) #f next-update) | ||
83 | ((#f) | ||
84 | (signal-condition! (next-update-condition update)) | ||
85 | (values next-update next-update!)) | ||
86 | (else (double-update-violation))))) | ||
87 | (values update update!))))) | ||
88 | (opaque #t) | ||
89 | (sealed #t)) | ||
90 | |||
91 | (define (wait-for-update-operation update) | ||
92 | "Return an operation for waiting for the next value | ||
93 | of the update @var{update}. The return value of the | ||
94 | operation is the next @code{update?}." | ||
95 | (wrap-operation | ||
96 | (wait-operation (next-update-condition update)) | ||
97 | (lambda () | ||
98 | (atomic-box-ref (next-update-box update))))) | ||
99 | |||
100 | (define (next-update update) | ||
101 | "Return the next update of @var{update}." | ||
102 | (perform-operation (wait-for-update-operation update))) | ||
103 | |||
104 | (define (next-update-peek update) | ||
105 | "If the next update of @var{update} is known, return it, | ||
106 | otherwise return @code{#f}." | ||
107 | (atomic-box-ref (next-update-box update))))) | ||
diff --git a/tests/update.scm b/tests/update.scm new file mode 100644 index 0000000..a9b7928 --- /dev/null +++ b/tests/update.scm | |||
@@ -0,0 +1,112 @@ | |||
1 | ;; This file is part of scheme-GNUnet. | ||
2 | ;; Copyright (C) 2021 Maxime Devos | ||
3 | ;; | ||
4 | ;; scheme-GNUnet is free software: you can redistribute it and/or modify it | ||
5 | ;; under the terms of the GNU Affero General Public License as published | ||
6 | ;; by the Free Software Foundation, either version 3 of the License, | ||
7 | ;; or (at your option) any later version. | ||
8 | ;; | ||
9 | ;; scheme-GNUnet is distributed in the hope that it will be useful, but | ||
10 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | ||
12 | ;; Affero General Public License for more details. | ||
13 | ;; | ||
14 | ;; You should have received a copy of the GNU Affero General Public License | ||
15 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. | ||
16 | ;; | ||
17 | ;; SPDX-License-Identifier: AGPL3.0-or-later | ||
18 | |||
19 | (use-modules (gnu gnunet concurrency update) | ||
20 | (srfi srfi-8) | ||
21 | (srfi srfi-11) | ||
22 | (srfi srfi-26) | ||
23 | (fibers operations) | ||
24 | (fibers timers) | ||
25 | (fibers)) | ||
26 | |||
27 | (test-begin "update") | ||
28 | |||
29 | ;; Tests without concurrency | ||
30 | (test-equal "make-update result types" | ||
31 | '(#t . #t) | ||
32 | (receive (update update!) | ||
33 | (make-update 0) | ||
34 | (cons (update? update) | ||
35 | (procedure? update!)))) | ||
36 | |||
37 | (test-equal "update! and next-update-peek" | ||
38 | '(new #t #t) | ||
39 | (let*-values (((update update!) (make-update 'old)) | ||
40 | ((next-update next-update!) (update! 'new))) | ||
41 | (receive (next-update-peeked) (next-update-peek update) | ||
42 | (list (update-value next-update-peeked) | ||
43 | (procedure? next-update!) | ||
44 | (eq? next-update-peeked next-update))))) | ||
45 | |||
46 | (test-eq "no update! and next-update-peek" | ||
47 | #f | ||
48 | (next-update-peek (make-update 0))) | ||
49 | |||
50 | (test-error "update! twice -> &double-update" | ||
51 | &double-update | ||
52 | (receive (next-update next-update!) | ||
53 | (make-update 0) | ||
54 | (next-update! next-update) | ||
55 | (next-update! next-update))) | ||
56 | |||
57 | |||
58 | ;; Tests with operations | ||
59 | |||
60 | ;; Unfortunately, fibers does not not have | ||
61 | ;; a ‘run this operation -- unless it would | ||
62 | ;; block’ procedure, and using a combination | ||
63 | ;; of wrap-operation and sleep-operation/ | ||
64 | ;; timer-operation turns out to be racy. | ||
65 | ;; | ||
66 | ;; Our approach: | ||
67 | ;; * if an operation is expected to block, | ||
68 | ;; include a short timer-operation | ||
69 | ;; for testing detecting blocking. | ||
70 | ;; (Short to ensure tests still pass | ||
71 | ;; quickly.) | ||
72 | ;; | ||
73 | ;; A false ‘PASS’ could occassionally | ||
74 | ;; result, but no false ‘FAIL’ will | ||
75 | ;; be created. | ||
76 | ;; * if a test is expected *not* to block, | ||
77 | ;; just perform the operation. | ||
78 | ;; | ||
79 | ;; If the test terminates, it's a PASS, | ||
80 | ;; if it loops forever, that would be a FAIL. | ||
81 | |||
82 | (define expected-blocking-operation | ||
83 | (wrap-operation (sleep-operation 1e-4) | ||
84 | (lambda () 'blocking))) | ||
85 | |||
86 | (test-eq "no update -> blocking next-update" | ||
87 | 'blocking | ||
88 | (perform-operation | ||
89 | (choice-operation | ||
90 | (wrap-operation (wait-for-update-operation (make-update #f)) | ||
91 | (lambda (_) 'nonblocking)) | ||
92 | expected-blocking-operation))) | ||
93 | |||
94 | (test-eq "updated -> non-blocking next-update" | ||
95 | 'nonblocking | ||
96 | (perform-operation | ||
97 | (receive (update update!) | ||
98 | (make-update 'old) | ||
99 | (update! 'new) | ||
100 | (wrap-operation (wait-for-update-operation update) | ||
101 | (lambda (update) 'nonblocking))))) | ||
102 | |||
103 | (receive (update update!) | ||
104 | (make-update 'old) | ||
105 | (let ((new (update! 'new))) | ||
106 | (test-eq "updated -> correct non-blocking next-update" | ||
107 | new | ||
108 | ;; For unknown reasons, using choice-operation | ||
109 | ;; and blocking-operation leads to a FAIL. | ||
110 | (perform-operation (wait-for-update-operation update))))) | ||
111 | |||
112 | (test-end "update") | ||