Compare commits
316 Commits
690f9e65a8
...
3c7838d5ab
Author | SHA1 | Date |
---|---|---|
Tony Garnock-Jones | 3c7838d5ab | |
Tony Garnock-Jones | 0167cddc58 | |
Tony Garnock-Jones | 345e940833 | |
Tony Garnock-Jones | f4beff6fb9 | |
Tony Garnock-Jones | 257cc5a807 | |
Tony Garnock-Jones | 047dcbd98b | |
Tony Garnock-Jones | d865087b7d | |
Tony Garnock-Jones | 9004725341 | |
Tony Garnock-Jones | fb184e95ff | |
Tony Garnock-Jones | 5c514b7ff6 | |
Tony Garnock-Jones | b10f0b668f | |
Tony Garnock-Jones | e463f56cf5 | |
Tony Garnock-Jones | b6a3200dfa | |
Tony Garnock-Jones | d1269bbc33 | |
Tony Garnock-Jones | c04fea1ab9 | |
Tony Garnock-Jones | a648ab7c8a | |
Tony Garnock-Jones | 65c99e24b4 | |
Tony Garnock-Jones | 3d93dc5570 | |
Tony Garnock-Jones | 7acf72469b | |
Tony Garnock-Jones | 71447a0428 | |
Tony Garnock-Jones | 5f766d5b12 | |
Tony Garnock-Jones | b5bae7f8f6 | |
Tony Garnock-Jones | 104b87cd56 | |
Tony Garnock-Jones | cd32fe631d | |
Tony Garnock-Jones | 4c852e0eb8 | |
Tony Garnock-Jones | 06362c6674 | |
Tony Garnock-Jones | bcc7848e76 | |
Tony Garnock-Jones | 4d828a5ad2 | |
Tony Garnock-Jones | 81034e017e | |
Tony Garnock-Jones | 8899807216 | |
Tony Garnock-Jones | eafd5771b5 | |
Tony Garnock-Jones | 12c255bb40 | |
Tony Garnock-Jones | 7dd217be6a | |
Tony Garnock-Jones | 6c44843f63 | |
Tony Garnock-Jones | 9839e5946c | |
Tony Garnock-Jones | 8478a27e1f | |
Tony Garnock-Jones | 9d58c01795 | |
Tony Garnock-Jones | 573bf36057 | |
Tony Garnock-Jones | 73feb539dd | |
Tony Garnock-Jones | 83af353d9d | |
Tony Garnock-Jones | 82e327e21f | |
Tony Garnock-Jones | d20addd642 | |
Tony Garnock-Jones | c987ac0592 | |
Tony Garnock-Jones | 611be53725 | |
Tony Garnock-Jones | 0f926e7940 | |
Tony Garnock-Jones | 28fd0809e0 | |
Tony Garnock-Jones | 9f03dbb6d3 | |
Tony Garnock-Jones | 5d657d6a95 | |
Tony Garnock-Jones | 244436da45 | |
Tony Garnock-Jones | 322aa5b478 | |
Tony Garnock-Jones | 49cfe6b6c3 | |
Tony Garnock-Jones | f23debf074 | |
Tony Garnock-Jones | 276042134d | |
Tony Garnock-Jones | 08566ef6a6 | |
Tony Garnock-Jones | 4fb114935b | |
Tony Garnock-Jones | 2b9a28cb4f | |
Tony Garnock-Jones | 5918e9ac75 | |
Tony Garnock-Jones | 9f20b36bfc | |
Tony Garnock-Jones | f1672cc695 | |
Tony Garnock-Jones | c424630a7d | |
Tony Garnock-Jones | d669dd5f7c | |
Tony Garnock-Jones | eb2e4c9fcb | |
Tony Garnock-Jones | b09aef3912 | |
Tony Garnock-Jones | 25fb492083 | |
Tony Garnock-Jones | 1e87a16d1c | |
Tony Garnock-Jones | bc5c26ba1d | |
Tony Garnock-Jones | cd290500e7 | |
Tony Garnock-Jones | 3887d8a717 | |
Tony Garnock-Jones | f14794cbd4 | |
Tony Garnock-Jones | f669f053ea | |
Tony Garnock-Jones | ab6f83a281 | |
Tony Garnock-Jones | 25d3656e09 | |
Tony Garnock-Jones | 2ee25068b9 | |
Tony Garnock-Jones | f0db94c102 | |
Tony Garnock-Jones | 856cad237f | |
Tony Garnock-Jones | 239b0810e5 | |
Tony Garnock-Jones | 3bfef265a5 | |
Tony Garnock-Jones | 1d51d1d014 | |
Tony Garnock-Jones | fd8a749cd0 | |
Tony Garnock-Jones | 31dc143437 | |
Tony Garnock-Jones | 91bf17f57e | |
Tony Garnock-Jones | fa0a0c0c4d | |
Tony Garnock-Jones | 0835257e1c | |
Tony Garnock-Jones | 39b70ff9ee | |
Tony Garnock-Jones | c6d907c518 | |
Tony Garnock-Jones | 363995a9c0 | |
Tony Garnock-Jones | 9215682e5c | |
Tony Garnock-Jones | 894ae9d238 | |
Tony Garnock-Jones | f306fface5 | |
Tony Garnock-Jones | f6d0c6868e | |
Tony Garnock-Jones | 97376bc67c | |
Tony Garnock-Jones | a4e38295f0 | |
Tony Garnock-Jones | 69b70d6256 | |
Tony Garnock-Jones | 6f499203d2 | |
Tony Garnock-Jones | 97df84f0f0 | |
Tony Garnock-Jones | 73a9d9cfd8 | |
Tony Garnock-Jones | b4f1d36329 | |
Tony Garnock-Jones | 0021f7f1a9 | |
Tony Garnock-Jones | 4c0e291658 | |
Tony Garnock-Jones | 24fa4834ea | |
Tony Garnock-Jones | f07fcb9081 | |
Tony Garnock-Jones | 40fa2ca620 | |
Tony Garnock-Jones | 5c5316f37e | |
Tony Garnock-Jones | 57d7ec505d | |
Tony Garnock-Jones | eaf52ce2c7 | |
Tony Garnock-Jones | f86652e0b2 | |
Tony Garnock-Jones | 749676b1de | |
Tony Garnock-Jones | ed24d6259a | |
Tony Garnock-Jones | db0580c3f5 | |
Tony Garnock-Jones | 143abcf4c1 | |
Tony Garnock-Jones | dd8a7861d4 | |
Tony Garnock-Jones | 3fec2d2f57 | |
Tony Garnock-Jones | eea8c8ecfe | |
Tony Garnock-Jones | 34723d6f2c | |
Tony Garnock-Jones | 81ae56d7a8 | |
Tony Garnock-Jones | ce706583e5 | |
Tony Garnock-Jones | 61e274398e | |
Tony Garnock-Jones | 43d46f37d4 | |
Tony Garnock-Jones | 55bb6dd5ee | |
Tony Garnock-Jones | 0c47915728 | |
Tony Garnock-Jones | 2ee5ff4bec | |
Tony Garnock-Jones | a1c0247407 | |
Tony Garnock-Jones | d36f8199ec | |
Tony Garnock-Jones | 20cee16200 | |
Tony Garnock-Jones | fe40d6b804 | |
Tony Garnock-Jones | e9d510d658 | |
Tony Garnock-Jones | d08a7536f1 | |
Tony Garnock-Jones | a2ade911f6 | |
Tony Garnock-Jones | f3152fe1c1 | |
Tony Garnock-Jones | a40fb01839 | |
Tony Garnock-Jones | f1a787b17f | |
Tony Garnock-Jones | d490b26dc2 | |
Tony Garnock-Jones | b6063b4d95 | |
Tony Garnock-Jones | 52cf4c3ae5 | |
Tony Garnock-Jones | 4f6ab9bd77 | |
Tony Garnock-Jones | c2fdd8a37e | |
Tony Garnock-Jones | 4141529854 | |
Tony Garnock-Jones | 1114b5b6b9 | |
Tony Garnock-Jones | cc0a7c5a2d | |
Tony Garnock-Jones | 153466bd10 | |
Tony Garnock-Jones | 3ae9d28d37 | |
Tony Garnock-Jones | 34553f4752 | |
Tony Garnock-Jones | 3669b99525 | |
Tony Garnock-Jones | 3b869709fb | |
Tony Garnock-Jones | ec8c91270f | |
Tony Garnock-Jones | 5e6b479279 | |
Tony Garnock-Jones | bbe9950148 | |
Tony Garnock-Jones | bf2d20f40d | |
Tony Garnock-Jones | 19e9623358 | |
Tony Garnock-Jones | 49f64a1058 | |
Tony Garnock-Jones | 120c4ee1c4 | |
Tony Garnock-Jones | 54073eb164 | |
Tony Garnock-Jones | 5683332cc8 | |
Tony Garnock-Jones | 6e98757e85 | |
Tony Garnock-Jones | 39449a1f50 | |
Tony Garnock-Jones | c479faf9a9 | |
Tony Garnock-Jones | 1fcfebf8d9 | |
Tony Garnock-Jones | 3dcc9edea4 | |
Tony Garnock-Jones | 55927716bc | |
Tony Garnock-Jones | 15ddbdc479 | |
Tony Garnock-Jones | c1b7ab9fd5 | |
Tony Garnock-Jones | d5c44ba0d3 | |
Tony Garnock-Jones | f16a911892 | |
Tony Garnock-Jones | 711afb4922 | |
Tony Garnock-Jones | f6bec07f5e | |
Tony Garnock-Jones | 3dd2366a55 | |
Tony Garnock-Jones | 585cbcdb9e | |
Tony Garnock-Jones | da5a60f42c | |
Tony Garnock-Jones | 67d5d1c71f | |
Tony Garnock-Jones | a7aa13818d | |
Tony Garnock-Jones | cb2f2e6853 | |
Tony Garnock-Jones | 13d34e035a | |
Tony Garnock-Jones | acc4def15f | |
Tony Garnock-Jones | 0120875d15 | |
Tony Garnock-Jones | 935ac403b4 | |
Tony Garnock-Jones | 8c501a6591 | |
Tony Garnock-Jones | 7dee4c9b35 | |
Tony Garnock-Jones | 8cecaec69b | |
Tony Garnock-Jones | 9883d2bc5f | |
Tony Garnock-Jones | efd6bc72ea | |
Tony Garnock-Jones | 2b44d82c37 | |
Tony Garnock-Jones | 2dc829229d | |
Tony Garnock-Jones | a383b6703a | |
Tony Garnock-Jones | a24475c707 | |
Tony Garnock-Jones | 181e6a87a0 | |
Tony Garnock-Jones | 8e88d4643c | |
Tony Garnock-Jones | a1c9af708d | |
Tony Garnock-Jones | 710029ea9b | |
Tony Garnock-Jones | 03dad81a49 | |
Tony Garnock-Jones | 41a4593183 | |
Tony Garnock-Jones | 8a34bf20d8 | |
Tony Garnock-Jones | 0d9afec6df | |
Tony Garnock-Jones | 0b7f827cec | |
Tony Garnock-Jones | 65e9ffac59 | |
Tony Garnock-Jones | 8bd848bca0 | |
Tony Garnock-Jones | 2a00d59231 | |
Tony Garnock-Jones | 11f28e13e2 | |
Tony Garnock-Jones | 8cce22face | |
Tony Garnock-Jones | 75b3488c83 | |
Tony Garnock-Jones | 939b0620ed | |
Tony Garnock-Jones | a391b0ff24 | |
Tony Garnock-Jones | 017d5851be | |
Tony Garnock-Jones | dbcc931ebd | |
Tony Garnock-Jones | 07d5656e41 | |
Tony Garnock-Jones | 5cd8e2c2cb | |
Tony Garnock-Jones | fd7cac5bae | |
Tony Garnock-Jones | 3c7676906d | |
Tony Garnock-Jones | 85535608fd | |
Tony Garnock-Jones | 12d4e95ac4 | |
Tony Garnock-Jones | ff4c4a59bd | |
Tony Garnock-Jones | c77416b727 | |
Tony Garnock-Jones | cc54496ac6 | |
Tony Garnock-Jones | 59e1a09d61 | |
Tony Garnock-Jones | 00c6311bfc | |
Tony Garnock-Jones | d9ca939d60 | |
Tony Garnock-Jones | ab75efe7f9 | |
Tony Garnock-Jones | c27ace547d | |
Tony Garnock-Jones | 8acfaab8f8 | |
Tony Garnock-Jones | 58695351d9 | |
Tony Garnock-Jones | b95dd5142a | |
Tony Garnock-Jones | afaebdf69c | |
Tony Garnock-Jones | 7079a14d5a | |
Tony Garnock-Jones | a4b8294734 | |
Tony Garnock-Jones | 83b088e5ee | |
Tony Garnock-Jones | 5631b24904 | |
Tony Garnock-Jones | 835528e855 | |
Tony Garnock-Jones | 496682f550 | |
Tony Garnock-Jones | e7773e918d | |
Tony Garnock-Jones | 81e5cfbec4 | |
Tony Garnock-Jones | 0b0615ec46 | |
Tony Garnock-Jones | f9af2de438 | |
Tony Garnock-Jones | 67279c9da7 | |
Tony Garnock-Jones | d3a7179907 | |
Tony Garnock-Jones | 571fc13787 | |
Tony Garnock-Jones | 15120a8488 | |
Tony Garnock-Jones | 76c74f25c2 | |
Tony Garnock-Jones | 7b05a25301 | |
Tony Garnock-Jones | 77a3042c98 | |
Tony Garnock-Jones | 9d4388ad8c | |
Tony Garnock-Jones | 7e71f04cc6 | |
Tony Garnock-Jones | bf98354984 | |
Tony Garnock-Jones | f4681c21a1 | |
Tony Garnock-Jones | e44ee5ef28 | |
Tony Garnock-Jones | ca67f9405f | |
Tony Garnock-Jones | 007af89325 | |
Tony Garnock-Jones | 36e4de74ad | |
Tony Garnock-Jones | aaea276ec5 | |
Tony Garnock-Jones | dab13836f7 | |
Tony Garnock-Jones | 55d13e7569 | |
Tony Garnock-Jones | 47f645d579 | |
Tony Garnock-Jones | bda2ec0566 | |
Tony Garnock-Jones | c22f9f98f8 | |
Tony Garnock-Jones | 9d5213ecf4 | |
Tony Garnock-Jones | 00b7f42335 | |
Tony Garnock-Jones | d68bc87da5 | |
Tony Garnock-Jones | 77676fca9b | |
Tony Garnock-Jones | 1bd410db23 | |
Tony Garnock-Jones | 2008e66f38 | |
Tony Garnock-Jones | 8bed3d4d4c | |
Tony Garnock-Jones | 63666f4567 | |
Tony Garnock-Jones | 98b7aecd8f | |
Tony Garnock-Jones | 14bc36c4c5 | |
Tony Garnock-Jones | d06acb2b59 | |
Tony Garnock-Jones | 768ee57a15 | |
Tony Garnock-Jones | a13884cbda | |
Tony Garnock-Jones | e3d64677bd | |
Tony Garnock-Jones | 70b4bc5e74 | |
Tony Garnock-Jones | 5a3f89ccf5 | |
Tony Garnock-Jones | 8900eccb1e | |
Tony Garnock-Jones | 71756d8d40 | |
Tony Garnock-Jones | 9b6fd1418a | |
Tony Garnock-Jones | 45f401e607 | |
Tony Garnock-Jones | f2af7cb20b | |
Tony Garnock-Jones | 897c1aec0a | |
Tony Garnock-Jones | 7199e6be64 | |
Tony Garnock-Jones | a22062e043 | |
Tony Garnock-Jones | 2c202d46ad | |
Tony Garnock-Jones | 7be0ccf32c | |
Tony Garnock-Jones | 60a6290bc2 | |
Tony Garnock-Jones | 629b4f8509 | |
Tony Garnock-Jones | c56e5ad547 | |
Tony Garnock-Jones | bcfebeb402 | |
Tony Garnock-Jones | b207a07798 | |
Tony Garnock-Jones | 18418dfc13 | |
Tony Garnock-Jones | 5dd7ec4ae0 | |
Tony Garnock-Jones | e7f3dab519 | |
Tony Garnock-Jones | 762d1d4250 | |
Tony Garnock-Jones | 76c0fe03c9 | |
Tony Garnock-Jones | d298ad2c66 | |
Tony Garnock-Jones | 2878386805 | |
Tony Garnock-Jones | 1b1c598aa0 | |
Tony Garnock-Jones | 8cb4e947a5 | |
Tony Garnock-Jones | d93d773c23 | |
Tony Garnock-Jones | e4a9f1fa8f | |
Tony Garnock-Jones | 6a7b9d57db | |
Tony Garnock-Jones | 6de484b307 | |
Tony Garnock-Jones | 3707782906 | |
Tony Garnock-Jones | d00a0c3216 | |
Tony Garnock-Jones | 7283eb8362 | |
Tony Garnock-Jones | dd816a74ca | |
Tony Garnock-Jones | d37a675afc | |
Tony Garnock-Jones | b8e00e90f9 | |
Tony Garnock-Jones | 8fcf765192 | |
Tony Garnock-Jones | 0673d6d9b3 | |
Tony Garnock-Jones | 0e2384514f | |
Tony Garnock-Jones | a4591944f1 | |
Tony Garnock-Jones | e1de8a2814 | |
Tony Garnock-Jones | 811a7a0a45 | |
Tony Garnock-Jones | 210afa2395 | |
Tony Garnock-Jones | bdd8a0e4ff | |
Tony Garnock-Jones | ffa5b616ab | |
Tony Garnock-Jones | 6a0439cbd0 | |
Tony Garnock-Jones | 55dbc2f29a | |
Tony Garnock-Jones | 7767563ff6 | |
Tony Garnock-Jones | 4a470bd2e0 | |
Tony Garnock-Jones | 5f78b24dc3 |
|
@ -86,6 +86,6 @@
|
|||
counter)))
|
||||
(send! (outbound (tcp-channel us them response)))
|
||||
(for [(i 4)]
|
||||
(define buf (make-bytes 1024 (+ #x30 i)))
|
||||
(define buf (make-bytes 1024 (+ #x30 (modulo i 10))))
|
||||
(send! (outbound (tcp-channel us them buf))))
|
||||
(stop-facet (current-facet-id)))))))
|
||||
|
|
|
@ -0,0 +1,2 @@
|
|||
compiled/
|
||||
scratch/
|
|
@ -0,0 +1,575 @@
|
|||
# Efficient, Imperative Dataspaces for Conversational Concurrency
|
||||
|
||||
Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||
20 October 2018; revised 21 June 2019
|
||||
|
||||
<p style="font-size:90%"><strong>Abstract.</strong> The dataspace
|
||||
model of Conversational Concurrency [is great], but implementing it
|
||||
efficiently has been difficult until now. Existing approaches use a
|
||||
complex data structure that depends for its efficiency on
|
||||
sophisticated run-time support. This paper presents a new approach
|
||||
to implementation of the dataspace model that gives three benefits.
|
||||
First, it avoids the complexity and run-time support requirements of
|
||||
previous approaches, bringing dataspaces to a wider range of
|
||||
environments. Second, it unlocks new types of conversational
|
||||
interaction among concurrent components. Third, it dramatically
|
||||
improves performance. Key to the new technique is a syntactic
|
||||
treatment of assertions of interest, contrasting with the semantic
|
||||
treatment of assertion sets used by the earlier approach.</p>
|
||||
|
||||
## Constructing assertions
|
||||
|
||||
Imagine a language for constructing data with embedded function calls
|
||||
and variable references. Imagine that it is a fragment of a larger
|
||||
language.
|
||||
|
||||
c ∈ assertions C ::= e | x(c, ...)
|
||||
v ∈ values V ::= a | x(v, ...)
|
||||
e ∈ expressions E ::= a | x | e e ...
|
||||
x ∈ identifiers X
|
||||
a ∈ atoms A = numbers ∪ strings ∪ ...
|
||||
|
||||
Here are some examples of assertions in `c`, along with suggested
|
||||
interpretations:
|
||||
|
||||
present("Alice") Alice is present in the chat room
|
||||
speak("Alice", "Hello!") Alice says "Hello!"
|
||||
|
||||
## Assertions of interest
|
||||
|
||||
In the dataspace model, "subscriptions" go hand in hand with
|
||||
assertions of *interest* in subscribed-to data. The model includes two
|
||||
special constructors for discussing interests. The first, `observe`,
|
||||
is interpreted as a declaration of interest in assertions matching the
|
||||
pattern given as its sole argument. The second, `discard`, is
|
||||
interpreted as a "don't care" when part of a pattern within `observe`.
|
||||
|
||||
observe(present(discard())) Interest in the presence of any user
|
||||
observe(speak("Alice", discard())) Interest in every time Alice speaks
|
||||
|
||||
We extend the dataspace model with an additional special constructor
|
||||
which allows interested parties to declare the portions of matching
|
||||
assertions that they specifically wish to examine further: *capturing*
|
||||
positions. The `capture` constructor signals that the interested party
|
||||
will treat specially the corresponding portion of a matching
|
||||
assertion.[^capture-subpattern]
|
||||
|
||||
observe(present(capture())) Interest in each present user
|
||||
observe(speak("Alice", capture())) Interest in the things Alice says
|
||||
|
||||
[^capture-subpattern]: The implemented system affords a single
|
||||
argument to `capture` that restricts matches according to the
|
||||
nested subpattern. What is written here as `capture()` corresponds
|
||||
to `capture(discard())` in the full implementation. The pattern
|
||||
language syntax is analogously extended.
|
||||
|
||||
There is an important difference between `observe(present(discard()))`
|
||||
and `observe(present(capture()))`. The former declares that the
|
||||
interested party cares only about whether any user at all is present,
|
||||
while the latter declares an interest in the identities of the
|
||||
specific users that are present. Similarly, `observe(speak("Alice",
|
||||
discard()))` declares an interest in receiving a notification each
|
||||
time Alice speaks, but no interest in the *content* of each utterance,
|
||||
while `observe(speak("Alice", capture()))` declares interest in
|
||||
learning the things Alice says.
|
||||
|
||||
To drive this point home, the following patterns both result in a
|
||||
notification event for each utterance by any user. The first results
|
||||
in notifications carrying the name of the speaker along with the
|
||||
content of their speech. The second results in notifications carrying
|
||||
only the name of the speaker.
|
||||
|
||||
observe(speak(capture(), capture())) Interest in who says what
|
||||
observe(speak(capture(), discard())) Interest in who speaks
|
||||
|
||||
## Patterns
|
||||
|
||||
Imagine now an enriched version of our language that can construct
|
||||
patterns over data, including captures and "don't care" positions.
|
||||
|
||||
p ∈ patterns P ::= e | x(p, ...) | $x | _
|
||||
|
||||
Syntactic patterns can be translated into assertions of interest
|
||||
directly. Binding subpatterns `$x` are translated into `capture()`,
|
||||
and "don't care" patterns `_` into `discard()`.
|
||||
|
||||
## Indexing assertions and patterns
|
||||
|
||||
There are two kinds of change in a running dataspace model program.
|
||||
First, assertions can be added to and removed from the dataspace. When
|
||||
this happens, interested facets must be informed of relevant changes.
|
||||
Second, facets and their event handlers can be added to and removed
|
||||
from the dataspace. When this happens, new handlers must be informed
|
||||
of preexisting matching assertions.
|
||||
|
||||
To efficiently respond to these two kinds of change, we maintain a
|
||||
special index. Every time an event handler within a facet is created,
|
||||
we augment the index using a data structure called a *skeleton*. Each
|
||||
skeleton contains information gleaned from static analysis of the
|
||||
pattern associated with the event handler. The index also records
|
||||
every assertion added to the dataspace, so as to correctly initialize
|
||||
event handlers added later.
|
||||
|
||||
### Skeletons
|
||||
|
||||
A skeleton is comprised of three pieces: a *shape*, describing the
|
||||
positions and arities of statically-known constructors in matching
|
||||
assertions; a *constant map*, which places restrictions on fields
|
||||
within constructors; and a *capture map*, which specifies locations of
|
||||
captured positions.
|
||||
|
||||
Each time an assertion is added or removed, it is conceptually checked
|
||||
against each handler's skeleton. First, the overall shape is checked.
|
||||
If the assertion passes this check, the constant map is checked. If
|
||||
all the constants match, the capture map is used to prepare an
|
||||
argument vector, and the event handler's callback is invoked.
|
||||
|
||||
k ∈ skeletons K = S × [H×E] × [H]
|
||||
s ∈ shapes S ::= * | x(s, ...)
|
||||
h ∈ paths H = [𝐍]
|
||||
|
||||
Shapes retain only statically-known constructors and arities in a
|
||||
pattern:
|
||||
|
||||
shape :: P -> S
|
||||
shape e = *
|
||||
shape x(p, ...) = x(shape p, ...)
|
||||
shape $x = *
|
||||
shape _ = *
|
||||
|
||||
A constant map extracts all non-capturing, non-discard positions in a
|
||||
pattern. The expressions in the map are evaluated at the time the
|
||||
corresponding event handler is installed; that is, at facet creation
|
||||
time. They are not subsequently reevaluated; if any expression depends
|
||||
on a dataflow variable, and that variable changes, the entire handler
|
||||
is removed, reevaluated, and reinstalled.
|
||||
|
||||
constantmap :: P -> [(H, E)]
|
||||
constantmap p = cmap [] p
|
||||
where
|
||||
cmap :: H -> P -> [(H, E)]
|
||||
cmap h e = [(h, e)]
|
||||
cmap h x(p_0, ..., p_i) = (cmap (h++[0]) p_0) ++
|
||||
... ++
|
||||
(cmap (h++[i]) p_i)
|
||||
cmap h $x = []
|
||||
cmap h _ = []
|
||||
|
||||
Finally, a capture map extracts all capturing positions in a pattern:
|
||||
|
||||
capturemap :: P -> [H]
|
||||
capturemap p = vmap [] p
|
||||
where
|
||||
vmap :: H -> P -> [H]
|
||||
vmap h e = []
|
||||
vmap h x(p_0, ..., p_i) = (vmap (h++[0]) p_0) ++
|
||||
... +
|
||||
(vmap (h++[i]) p_i)
|
||||
vmap h $x = [h]
|
||||
vmap h _ = []
|
||||
|
||||
### The index
|
||||
|
||||
The index incorporates every active event handler and every active
|
||||
assertion in the dataspace.
|
||||
|
||||
#### Overview and structures
|
||||
|
||||
An index is a pair of a bag of all currently-asserted
|
||||
assertion-values, plus the root node of a trie-like structure.
|
||||
Information from each indexed event handler's skeleton's shape is laid
|
||||
out along edges connecting trie nodes.
|
||||
|
||||
Every node contains a "continuation", which embodies information from
|
||||
a skeleton's constant map and capture map alongside handler callback
|
||||
functions and caches of currently-asserted values.
|
||||
|
||||
Index = Bag(V) × Node
|
||||
Node = Continuation × (Selector ⟼ Class ⟼ Node)
|
||||
Selector = 𝐍 × 𝐍 -- pop-count and index
|
||||
Class = X × 𝐍 -- label and arity
|
||||
|
||||
Continuation = 𝒫(V) × ([H] ⟼ [V] ⟼ Leaf)
|
||||
Leaf = 𝒫(V) × ([H] ⟼ Handler)
|
||||
|
||||
Handler = Bag([V]) × 𝒫(Callback)
|
||||
|
||||
Callback = EventType -> [V] -> V
|
||||
EventType ::= "+" | "-" | "!"
|
||||
|
||||
Bag(τ) = τ ⟼ 𝐍 -- bag of τ values
|
||||
|
||||
To use an index in the context of a single assertion—be it a new
|
||||
addition, a removal, or a message to be delivered—follow a path from
|
||||
the root `Node` of the index along `Selector`/`Class`-labelled edges,
|
||||
collecting `Continuations` as you go. This yields a complete set of
|
||||
event handlers that may match the assertion being considered. Further
|
||||
investigating each collected `Continuation` by analyzing its constant
|
||||
maps yields a set of matching `Leaf`s. Finally, each `Leaf` specifies
|
||||
a set of captured positions in the assertion to extract and pass to
|
||||
the contained callbacks.
|
||||
|
||||
At every `Continuation`, `Leaf` and `Handler` object, the index
|
||||
maintains a set of currently-asserted values that conform to the
|
||||
constraints implied by the object's position in the overall index.
|
||||
|
||||
Most of the components in an index are *mutable*: the `Bag(V)` in the
|
||||
root; the assertion-value cache set in each `Continuation` or `Leaf`
|
||||
object; the map from `Selector` to `Class` to `Node` within each
|
||||
`Node`; the map from path list to value-list to `Leaf` in each
|
||||
`Continuation`; the map from path list to `Handler` in each `Leaf`;
|
||||
and the `Bag([V])` in every `Handler`. This reflects the fact that the
|
||||
index directly reflects the current state of the dataspace it is
|
||||
indexing.
|
||||
|
||||
#### Adding and removing event handlers
|
||||
|
||||
Every event handler is a pair of a skeleton and a callback function.
|
||||
|
||||
Adding or removing an event handler proceeds in two stages. First, the
|
||||
index is extended to incorporate a path computed from the skeleton's
|
||||
shape into the `Node`-based trie. Second, the capture map and callback
|
||||
are installed into or removed from the `Continuation` within the
|
||||
`Node` at the end of that path.
|
||||
|
||||
Because (statically-known) shapes are finite and not particularly
|
||||
numerous in any given program, the implementation assumes that it is
|
||||
never necessary to remove shapes from the index. Instead, it limits
|
||||
itself to removal of handler functions, capture maps, and constant
|
||||
maps. This assumption will have to be revisited in future broker-like
|
||||
cases where handlers are dynamically installed.
|
||||
|
||||
**Definition.** The `project` function extracts the subvalue at a
|
||||
given path `h` from an overall value `v`.
|
||||
|
||||
project :: V -> H -> V
|
||||
project v [] = v
|
||||
project x(v_0, ..., v_i) (n:h) = project v_n h
|
||||
|
||||
**Definition.** The `projectMany` function projects a sequence of
|
||||
subvalues.
|
||||
|
||||
projectMany :: V -> [H] -> V
|
||||
projectMany v [h_0, ...] = [project v h_0, ...]
|
||||
|
||||
**Definition.** The `classof` function extracts the constructor label
|
||||
`x` and its arity `i` from a value `v`, yielding `()` if `v` is not
|
||||
a record.
|
||||
|
||||
classof :: V -> 1 + Class
|
||||
classof a = ()
|
||||
classof x(v_0, ..., v_i) = (x,i)
|
||||
|
||||
**Definition.** The `extend` procedure augments an index with shape
|
||||
information `s`, by imperatively updating the index structure. It
|
||||
returns the `Continuation` associated with the deepest `Node`
|
||||
visited in the path described by `s`.
|
||||
|
||||
extend :: Node -> S -> Continuation
|
||||
extend node s =
|
||||
let (_, (cont, _)) = walk-node [] node 0 0 s
|
||||
cont
|
||||
where
|
||||
|
||||
walk-edge :: H -> Node -> 𝐍 -> 𝐍 -> [S] -> (𝐍,Node)
|
||||
walk-edge h node n_pop n_index [] =
|
||||
(n_pop + 1, node)
|
||||
walk-edge h node n_pop n_index (s:shapes) =
|
||||
let (n_pop', node') = walk-node h node n_pop n_index s
|
||||
let n_index' = n_index + 1
|
||||
let h' = (dropRight h 1) ++ [n_index']
|
||||
walk-edge h' node' n_pop' n_index' shapes
|
||||
|
||||
walk-node :: H -> Node -> 𝐍 -> 𝐍 -> S -> (𝐍,Node)
|
||||
walk-node h node n_pop n_index * =
|
||||
(n_pop, node)
|
||||
walk-node h node n_pop n_index x(s_0, ... s_i) =
|
||||
let (cont, edges) = node
|
||||
let selector = (n_pop,n_index)
|
||||
let class = (x,i)
|
||||
if selector not in edges then
|
||||
edges[selector] := {}
|
||||
let table = edges[selector]
|
||||
if class not in table then
|
||||
let (outercache, constmap) = cont
|
||||
let innercache =
|
||||
{ v | v ∈ outercache,
|
||||
classof (project v h) = class }
|
||||
table[class] := ((innercache, {}), {})
|
||||
let node' = table[class]
|
||||
walk-edge (h ++ [0]) node' 0 0 [s_0, ..., s_i]
|
||||
|
||||
**Definition.** The `addHandler` procedure installs into an index an
|
||||
event handler callback `f` expecting values matching and captured by
|
||||
the given skeleton `k`. It then invokes `f` once for each distinct
|
||||
sequence of captured values matching existing assertions in the
|
||||
index.[^function-pointer-equality]
|
||||
|
||||
addHandler :: Index -> (S × [H×V] × [H]) -> Callback -> 1
|
||||
addHandler index (s, constantMap, captureMap) f =
|
||||
let (_, root) = index
|
||||
let (cache, table) = extend root s
|
||||
let constLocs = [h | (h,v) ∈ constantMap]
|
||||
if constLocs not in table then
|
||||
table[constLocs] := {}
|
||||
for v in cache
|
||||
let key = projectMany v constLocs
|
||||
if key not in table[constLocs] then
|
||||
table[constLocs][key] := ({}, {})
|
||||
let (leafcache, _leaftable) = table[constLocs][key]
|
||||
leafcache += v
|
||||
let constVals = [v | (h,v) ∈ constantMap]
|
||||
if constVals not in table[constLocs] then
|
||||
table[constLocs][constVals] := ({}, {})
|
||||
let (leafcache, leaftable) = table[constLocs][constVals]
|
||||
if captureMap not in leaftable then
|
||||
let bag = empty_bag
|
||||
for v in leafcache
|
||||
bag[projectMany v captureMap] += 1
|
||||
leaftable[captureMap] := (bag, {})
|
||||
let (bag, f_table) = leaftable[captureMap]
|
||||
f_table += f
|
||||
for seq in bag
|
||||
f "+" seq
|
||||
()
|
||||
|
||||
[^function-pointer-equality]: Because we store *sets* of function
|
||||
values, we rely on the general availability of a closure
|
||||
equivalence relation. Pointer-equality of closures (`eq?`)
|
||||
suffices.
|
||||
|
||||
**Definition.** The `removeHandler` procedure removes an event handler
|
||||
from an index.
|
||||
|
||||
removeHandler :: Index -> (S × [H×V] × [H]) -> Callback -> 1
|
||||
removeHandler index (s, constantMap, captureMap) f =
|
||||
let (_, root) = index
|
||||
let (cache, table) = extend root s
|
||||
let constLocs = [h | (h,v) ∈ constantMap]
|
||||
if constLocs not in table then
|
||||
return
|
||||
let constVals = [v | (h,v) ∈ constantMap]
|
||||
if constVals not in table[constLocs] then
|
||||
return
|
||||
let (leafcache, leaftable) = table[constLocs][constVals]
|
||||
if captureMap not in leaftable then
|
||||
return
|
||||
let (bag, f_table) = leaftable[captureMap]
|
||||
if f not in f_table then
|
||||
return
|
||||
f_table -= f
|
||||
if f_table = {} then
|
||||
delete leaftable[captureMap]
|
||||
if leafcache = {} and leaftable = {} then
|
||||
delete table[constLocs][constVals]
|
||||
if table[constLocs] = {} then
|
||||
delete table[constLocs]
|
||||
|
||||
#### Adding assertions, removing assertions and sending messages
|
||||
|
||||
All three operations depend on a single traversal procedure,
|
||||
parameterized with different update procedures.
|
||||
|
||||
**Definition.** The `modify` procedure traverses an index trie,
|
||||
following the structure of `v` and updating cached assertion sets
|
||||
according to the given update procedures. The update procedures act
|
||||
by side-effect; in particular, the `m_handler` procedure may choose
|
||||
to invoke the callback passed to it.
|
||||
|
||||
Operation = { AddAssertion, RemoveAssertion, SendMessage }
|
||||
|
||||
modify :: Node ->
|
||||
Operation ->
|
||||
V ->
|
||||
(Continuation -> V -> 1) ->
|
||||
(Leaf -> V -> 1) ->
|
||||
(Handler -> [V] -> 1) ->
|
||||
1
|
||||
modify node operation v m_cont m_leaf m_handler =
|
||||
walk-node node [outermost(v)]
|
||||
where
|
||||
walk-node :: Node -> [V] -> 1
|
||||
walk-node (cont, edges) vs =
|
||||
walk-cont cont
|
||||
for sel@(n_pop, n_index) in edges
|
||||
let vs' = dropLeft vs n_pop
|
||||
let (x(v_0, ...) : _) = vs'
|
||||
let v' = v_{n_index}
|
||||
if classof v' in edges[sel] then
|
||||
walk-node edges[sel][classof v'] (v':vs')
|
||||
|
||||
walk-cont :: Continuation -> 1
|
||||
walk-cont cont@(cache, table) =
|
||||
m_cont cont v
|
||||
for constLocs in table
|
||||
let consts = projectMany v constLocs
|
||||
if operation = AddAssertion and consts not in table[constLocs] then
|
||||
table[constLocs][consts] := ({}, {})
|
||||
if consts in table[constLocs] then
|
||||
let leaf@(leafcache, leaftable) =
|
||||
table[constLocs][consts]
|
||||
m_leaf leaf v
|
||||
for captureMap in leaftable
|
||||
let handler = leaftable[captureMap]
|
||||
let vs = projectMany v captureMap
|
||||
m_handler handler vs
|
||||
if operation = RemoveAssertion and leafcache = {} and leaftable = {} then
|
||||
delete table[constLocs][consts]
|
||||
if table[constLocs] = {} then
|
||||
delete table[constLocs]
|
||||
|
||||
The `outermost` constructor applied to `v` at the top of `modify` is
|
||||
necessary because every path in the trie structure embodied in each
|
||||
`node` is a sequence of zero or more (move, check) pairs. Each "move"
|
||||
pops zero or more items from the stack and then pushes a sub-structure
|
||||
of the topmost stack element onto the stack; the "check" then examines
|
||||
the class of the new top element, abandoning the search if it does not
|
||||
match. Without some outermost constructor, there would be no possible
|
||||
"move", and the trie would have to be expressed as a single optional
|
||||
check followed by zero or more (move, check) pairs.
|
||||
|
||||
**Definition.** The procedure `adjustAssertion` updates the copy-count
|
||||
associated with `v` in the given index, invoking callbacks as a
|
||||
side-effect if this changes the observable contents of the
|
||||
dataspace.
|
||||
|
||||
adjustAssertion :: Index -> V -> 𝐍 -> 1
|
||||
adjustAssertion (cache, root) v delta =
|
||||
let was_present = v in cache
|
||||
cache[v] += delta
|
||||
let is_present = v in cache
|
||||
if not was_present and is_present then
|
||||
modify root AddAssertion v add_cont add_leaf add_handler
|
||||
if was_present and not is_present then
|
||||
modify root RemoveAssertion v del_cont del_leaf del_handler
|
||||
where
|
||||
add_cont (cache, _) v = cache += v
|
||||
add_leaf (leafcache, _) v = leafcache += v
|
||||
add_handler (bag, f_table) vs =
|
||||
let was_present = vs in bag
|
||||
bag[vs] += 1
|
||||
if not was_present then
|
||||
for f in f_table
|
||||
f "+" vs
|
||||
|
||||
del_cont (cache, _) v = cache -= v
|
||||
del_leaf (leafcache, _) v = leafcache -= v
|
||||
del_handler (bag, f_table) vs =
|
||||
bag[vs] -= 1
|
||||
if vs not in bag then
|
||||
for f in f_table
|
||||
f "-" vs
|
||||
|
||||
**Definition.** The procedures `addAssertion` and `removeAssertion`
|
||||
install and remove an assertion `v` into the given index,
|
||||
respectively.
|
||||
|
||||
addAssertion :: Index -> V -> 1
|
||||
addAssertion index v = adjustAssertion index v 1
|
||||
|
||||
removeAssertion :: Index -> V -> 1
|
||||
removeAssertion index v = adjustAssertion index v -1
|
||||
|
||||
Care must be taken when applying entire *patches* to ensure that added
|
||||
assertions are processed before removed assertions; otherwise, actors
|
||||
will observe glitching in certain cases. For example, consider an
|
||||
endpoint with a wildcard subscription `[_]` and a separate endpoint
|
||||
asserting `[3]`. If a patch atomically replaces `[3]` with `[4]`, then
|
||||
if the removal is processed first, it will briefly appear to the `[_]`
|
||||
endpoint as if no assertions remain, whereas if the addition is
|
||||
processed first, no glitch will be detected.
|
||||
|
||||
**Definition.** The procedure `sendMessage` delivers a message `v` to
|
||||
event handlers in the given index.
|
||||
|
||||
sendMessage :: Index -> V -> 1
|
||||
sendMessage (_, root) v =
|
||||
modify root SendMessage v send_cont send_leaf send_handler
|
||||
where
|
||||
send_cont _ _ = ()
|
||||
send_leaf _ _ = ()
|
||||
send (_, f_table) vs =
|
||||
for f in f_table
|
||||
f "!" vs
|
||||
|
||||
## Potential future optimizations
|
||||
|
||||
### Static analysis of messages and assertions
|
||||
|
||||
Static analysis of expressions under `(send! ...)` and `(assert ...)`
|
||||
could cut out even more structural overhead.
|
||||
|
||||
For example, given interests
|
||||
|
||||
observe(message("actor1", capture()))
|
||||
observe(message("actor2", capture()))
|
||||
|
||||
and a message
|
||||
|
||||
:: message(x, y)
|
||||
|
||||
static analysis could directly connect the sending site to a
|
||||
hash-table lookup with `x` as the key, and invocation of the resulting
|
||||
handlers with `y` as the argument. There would be no need to perform a
|
||||
lookup based on the `message` constructor at runtime.
|
||||
|
||||
Similarly, given an interest
|
||||
|
||||
observe(present(capture()))
|
||||
|
||||
and an assertion
|
||||
|
||||
present(user)
|
||||
|
||||
static analysis could directly invoke handlers with `user` as the
|
||||
argument, without needing to at runtime find the set of handlers
|
||||
interested in the `present` constructor.
|
||||
|
||||
---
|
||||
|
||||
# TODO
|
||||
|
||||
- describe the cleanup function associated with a handler in the real implementation
|
||||
- `relay.rkt` uses it. When an inner actor asserts interest in an
|
||||
inbound assertion-set, the relay process pivots into the outer
|
||||
dataspace's context, and adds a new endpoint that relays events
|
||||
to the inner dataspace. The cleanup function attached to that
|
||||
endpoint retracts (from the inner dataspace) any matching
|
||||
assertions left over at the time the endpoint is removed.
|
||||
- that appears to be it! Nowhere else in the code is a
|
||||
`skeleton-interest` constructed with a non-`#f` cleanup
|
||||
function.
|
||||
- figure out and describe scoped assertions / visibility-restrictions
|
||||
- (partial/sketchy answer:) It's to deal with the fact that
|
||||
multiple endpoints may overlap. Within a single dataspace, an
|
||||
assertion matching both endpoints will trigger each of them.
|
||||
When relaying, the relay maintains an endpoint in the outer
|
||||
space for each in the inner space. When both outer endpoints are
|
||||
triggered, if they were to naively relay the matching assertion,
|
||||
the problem isn't so much that they'd double up (because
|
||||
dataspaces deduplicate!), the problem is that they don't have
|
||||
enough information to reconstruct the triggering outer assertion
|
||||
perfectly! So a visibility-restriction causes an assertion to
|
||||
*only* trigger inner endpoints that capture *at most* the
|
||||
captures of the outer endpoint. One of the outer endpoints will
|
||||
trigger its "matching" inner endpoint, but not the inner
|
||||
endpoint of the other endpoint, even though you might expect the
|
||||
relayed assertion to do so.
|
||||
- There's also a need for `(opaque-placeholder)`s to frustrate
|
||||
constant-matching against literal `(discard)` in cases of
|
||||
visibility restriction. See commit b4f1d36 and test case
|
||||
`test/core/nesting-confusion-2.rkt`.
|
||||
- HOWEVER see notes from 2019-06-18 in the googledoc Journal as
|
||||
well as in my notebook. See also commit 5c514b7 from
|
||||
imperative-syndicate and e806f4b from syndicate-js. The
|
||||
opaque-placeholders make the distributed (= non-zero-latency)
|
||||
case of visibility-restriction handling problematic in general,
|
||||
though relaxing the constraint from exact match of captured
|
||||
positions to at-most-match of captured positions allows at least
|
||||
the `during` special case to work in a programmer-unsurprising
|
||||
way.
|
||||
|
||||
- there's more to say about the implementation of the *dataspace*
|
||||
itself, not just the index structures. For example, the care that
|
||||
must be taken regarding `cleanup-changes` and abandoning work
|
||||
during exception handling.
|
|
@ -0,0 +1,21 @@
|
|||
PACKAGENAME=imperative-syndicate
|
||||
COLLECTS=imperative-syndicate
|
||||
|
||||
all: setup
|
||||
|
||||
clean:
|
||||
find . -name compiled -type d | xargs rm -rf
|
||||
|
||||
setup:
|
||||
raco setup $(COLLECTS)
|
||||
|
||||
link:
|
||||
raco pkg install --link -n $(PACKAGENAME) $$(pwd)
|
||||
|
||||
unlink:
|
||||
raco pkg remove $(PACKAGENAME)
|
||||
|
||||
test: setup testonly
|
||||
|
||||
testonly:
|
||||
raco test -p $(PACKAGENAME)
|
|
@ -0,0 +1,42 @@
|
|||
# New "Imperative" Syndicate Implementation
|
||||
|
||||
This experimental reimplementation of Syndicate takes the
|
||||
language-level constructs of facets, endpoints, and fields to heart,
|
||||
and integrates knowledge of facets and endpoints into the dataspace
|
||||
implementation itself.
|
||||
|
||||
It gains a *significant* performance advantage by doing so.
|
||||
|
||||
Programs seem to be about *20x faster*. Some are only 10x faster, some
|
||||
are 30x faster.
|
||||
|
||||
The prototype that embodies the new idea is in
|
||||
[prototype.rkt](prototype.rkt).
|
||||
|
||||
All the drivers end up looking much nicer with this new
|
||||
implementation. The previously-separate GL-2D support is now
|
||||
integrated as just another driver (though the timing characteristics
|
||||
of the old implementation are not precisely preserved). The
|
||||
[ground.rkt](ground.rkt) implementation is much cleaner.
|
||||
|
||||
Install the package by getting a Git checkout and running
|
||||
|
||||
```shell
|
||||
raco pkg install --link -n imperative-syndicate `pwd`
|
||||
```
|
||||
|
||||
The implementation test suite lives in [test/](test/). Run it with:
|
||||
|
||||
```shell
|
||||
raco setup imperative-syndicate; raco test -p imperative-syndicate
|
||||
```
|
||||
|
||||
Try out the "many Racket logos" animation example/demo:
|
||||
|
||||
```shell
|
||||
racket examples/gl-2d-many.rkt
|
||||
```
|
||||
|
||||
Hopefully you'll get a smooth 60fps, though I admit I'm running it on
|
||||
a fairly fast machine so you might need to drop the sprite-count in
|
||||
the code a bit to sustain 60fps.
|
|
@ -0,0 +1,37 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide message-struct
|
||||
assertion-struct
|
||||
(struct-out observe)
|
||||
(struct-out seal)
|
||||
(struct-out inbound)
|
||||
(struct-out outbound)
|
||||
strong-gensym)
|
||||
|
||||
(require (only-in net/base64 base64-encode))
|
||||
(require (only-in racket/random crypto-random-bytes))
|
||||
(require (only-in racket/string string-trim))
|
||||
|
||||
;; Thin veneers over `struct` for declaring intent.
|
||||
(define-syntax-rule (assertion-struct item ...) (struct item ... #:prefab))
|
||||
(define-syntax-rule (message-struct item ...) (struct item ... #:prefab))
|
||||
|
||||
(assertion-struct observe (specification))
|
||||
|
||||
;; Seals are used by protocols to prevent routing from examining
|
||||
;; internal structure of values.
|
||||
(struct seal (contents) ;; NB. Neither transparent nor prefab
|
||||
#:methods gen:custom-write
|
||||
[(define (write-proc s port mode)
|
||||
(fprintf port "#{~v}" (seal-contents s)))])
|
||||
|
||||
(struct inbound (assertion) #:prefab)
|
||||
(struct outbound (assertion) #:prefab)
|
||||
|
||||
(define (strong-gensym [head 'g] #:random-bytes [count 16])
|
||||
(string->symbol
|
||||
(format "~a~a"
|
||||
head
|
||||
(string-trim (bytes->string/latin-1
|
||||
(base64-encode (crypto-random-bytes count) #""))
|
||||
#px"=+"))))
|
|
@ -0,0 +1,72 @@
|
|||
#lang racket/base
|
||||
;; Bags and Deltas (which are Bags where item-counts can be negative).
|
||||
|
||||
(provide make-bag ;; mutable
|
||||
bag ;; immutable
|
||||
bag-change!
|
||||
bag-change
|
||||
bag-ref
|
||||
bag-clear!
|
||||
bag-member?
|
||||
bag-empty?
|
||||
bag-key-count
|
||||
in-bag
|
||||
in-bag/count
|
||||
for/bag/count
|
||||
for/bag
|
||||
set->bag
|
||||
bag->set)
|
||||
|
||||
(require racket/set)
|
||||
|
||||
;; A `(MutableBagof X)` is a `(MutableHash X Nat)`, where the `Nat`
|
||||
;; against an `X` is its replication count in the bag.
|
||||
;;
|
||||
;; A `(Bagof X)` is similar, but immutable.
|
||||
;;
|
||||
;; `MutableDeltaof` and `Deltaof` are like `MutableBagof` and `Bagof`,
|
||||
;; respectively, except the replication counts can be negative.
|
||||
|
||||
(define make-bag make-hash)
|
||||
(define bag hash)
|
||||
|
||||
(define (bag-change! b x delta)
|
||||
(define old-count (bag-ref b x))
|
||||
(define new-count (+ old-count delta))
|
||||
(if (zero? new-count)
|
||||
(begin (hash-remove! b x)
|
||||
(if (zero? old-count) 'absent->absent 'present->absent))
|
||||
(begin (hash-set! b x new-count)
|
||||
(if (zero? old-count) 'absent->present 'present->present))))
|
||||
|
||||
(define (bag-change b x delta #:clamp? [clamp? #f])
|
||||
(define old-count (bag-ref b x))
|
||||
(define new-count (if clamp?
|
||||
(max 0 (+ old-count delta))
|
||||
(+ old-count delta)))
|
||||
(if (zero? new-count)
|
||||
(values (hash-remove b x)
|
||||
(if (zero? old-count) 'absent->absent 'present->absent))
|
||||
(values (hash-set b x new-count)
|
||||
(if (zero? old-count) 'absent->present 'present->present))))
|
||||
|
||||
(define (bag-ref b x)
|
||||
(hash-ref b x 0))
|
||||
|
||||
(define bag-clear! hash-clear!)
|
||||
(define bag-member? hash-has-key?)
|
||||
(define bag-empty? hash-empty?)
|
||||
(define bag-key-count hash-count)
|
||||
|
||||
(define-syntax-rule (in-bag piece ...) (in-hash-keys piece ...))
|
||||
(define-syntax-rule (in-bag/count piece ...) (in-hash piece ...))
|
||||
|
||||
(define-syntax-rule (for/bag/count iters expr ...) (for/hash iters expr ...))
|
||||
(define-syntax-rule (for/bag iters expr ...) (for/bag/count iters (values (begin expr ...) 1)))
|
||||
|
||||
(define (set->bag s [count 1])
|
||||
(for/hash [(e (in-set s))]
|
||||
(values e count)))
|
||||
|
||||
(define (bag->set b)
|
||||
(list->set (hash-keys b)))
|
|
@ -0,0 +1,9 @@
|
|||
#lang racket
|
||||
(module+ main
|
||||
(require racket/logging)
|
||||
(with-logging-to-port (current-error-port)
|
||||
(lambda ()
|
||||
(dynamic-require '(submod imperative-syndicate/distributed main) #f))
|
||||
'debug 'syndicate/distributed
|
||||
'debug 'syndicate/federation
|
||||
))
|
|
@ -0,0 +1,3 @@
|
|||
#lang racket
|
||||
(module+ main
|
||||
(dynamic-require '(submod imperative-syndicate/distributed main) #f))
|
|
@ -0,0 +1,635 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide make-dataspace ;; TODO: how to cleanly provide this?
|
||||
with-current-facet ;; TODO: shouldn't be provided
|
||||
with-non-script-context ;; TODO: shouldn't be provided
|
||||
run-scripts! ;; TODO: how to cleanly provide this?
|
||||
apply-patch! ;; TODO: DEFINITELY SHOULDN'T BE PROVIDED - needed by relay.rkt
|
||||
|
||||
dataspace?
|
||||
dataspace-assertions ;; TODO: shouldn't be provided - needed by various tests
|
||||
dataspace-routing-table ;; TODO: shouldn't be provided - needed by relay.rkt
|
||||
generate-id! ;; TODO: shouldn't be provided - inline syntax.rkt??
|
||||
|
||||
actor?
|
||||
actor-id
|
||||
actor-name
|
||||
actor-dataspace ;; TODO: should this be provided?
|
||||
|
||||
facet?
|
||||
facet-actor
|
||||
facet-live?
|
||||
|
||||
field-handle ;; TODO: shouldn't be provided - inline syntax.rkt??
|
||||
field-handle?
|
||||
field-handle-name
|
||||
field-handle-id
|
||||
field-handle-owner
|
||||
field-handle-value
|
||||
|
||||
current-actor-crash-logger
|
||||
|
||||
current-actor
|
||||
current-facet
|
||||
in-script? ;; TODO: shouldn't be provided - inline syntax.rkt??
|
||||
capture-facet-context ;; TODO: shouldn't be provided - inline syntax.rkt??
|
||||
suspend-script* ;; TODO: shouldn't be provided - inline syntax.rkt??
|
||||
|
||||
add-facet!
|
||||
stop-facet!
|
||||
add-stop-script! ;; TODO: shouldn't be provided - inline syntax.rkt??
|
||||
add-endpoint!
|
||||
remove-endpoint!
|
||||
terminate-facet! ;; TODO: shouldn't be provided - inline syntax.rkt??
|
||||
schedule-script! ;; TODO: shouldn't be provided - inline syntax.rkt??
|
||||
push-script! ;; TODO: shouldn't be provided - inline syntax.rkt??
|
||||
ensure-in-script! ;; TODO: shouldn't be provided - inline syntax.rkt??
|
||||
|
||||
spawn! ;; TODO: should this be provided?
|
||||
enqueue-send! ;; TODO: should this be provided?
|
||||
enqueue-deferred-turn! ;; TODO: should this be provided?
|
||||
adhoc-retract! ;; TODO: should this be provided?
|
||||
adhoc-assert! ;; TODO: should this be provided?
|
||||
actor-adhoc-assertions ;; TODO: should this be provided?
|
||||
)
|
||||
|
||||
(require syndicate/functional-queue)
|
||||
(require syndicate/dataflow)
|
||||
(require racket/match)
|
||||
(require racket/set)
|
||||
(require (only-in racket/exn exn->string))
|
||||
|
||||
(require "skeleton.rkt")
|
||||
(require "pattern.rkt")
|
||||
(require "bag.rkt")
|
||||
(require "reflection.rkt")
|
||||
|
||||
;; An `ActorID` uniquely identifies an actor in a `Dataspace`.
|
||||
;; A `FID` is a Facet ID, uniquely identifying a facet in a `Dataspace`.
|
||||
|
||||
;; A `Dataspace` is a ... TODO
|
||||
|
||||
;; An `Action` is one of
|
||||
;; - `(patch (MutableDeltaof Assertion))`
|
||||
;; - `(message Assertion)`
|
||||
;; - `(spawn Any BootProc (Set Assertion))`
|
||||
;; - `(quit)`
|
||||
;; - `(deferred-turn (-> Any))`
|
||||
(struct patch (changes) #:prefab)
|
||||
(struct message (body) #:prefab)
|
||||
(struct spawn (name boot-proc initial-assertions) #:prefab)
|
||||
(struct quit () #:prefab)
|
||||
(struct deferred-turn (continuation) #:prefab)
|
||||
|
||||
(struct dataspace ([next-id #:mutable] ;; Nat
|
||||
routing-table ;; Skeleton
|
||||
;; v TODO: Caches have to be bags, not sets; once
|
||||
;; this change is made, can I avoid keeping a bag
|
||||
;; of assertions in the dataspace as a whole?
|
||||
assertions ;; (MutableBagof Assertion)
|
||||
dataflow ;; DataflowGraph
|
||||
[runnable #:mutable] ;; (Listof Actor)
|
||||
[pending-actions #:mutable] ;; (Queueof ActionGroup)
|
||||
) #:transparent)
|
||||
|
||||
(struct actor (id ;; ActorID
|
||||
dataspace ;; Dataspace
|
||||
name ;; Any
|
||||
[root-facet #:mutable] ;; (Option Facet)
|
||||
[runnable? #:mutable] ;; Boolean
|
||||
pending-scripts ;; (MutableVectorof (Queueof (-> Any)))
|
||||
[pending-actions #:mutable] ;; (Queueof Action)
|
||||
[adhoc-assertions #:mutable] ;; (Bagof Assertion)
|
||||
[cleanup-changes #:mutable] ;; (Deltaof Assertion)
|
||||
)
|
||||
#:methods gen:custom-write
|
||||
[(define (write-proc a p mode)
|
||||
(fprintf p "#<actor ~a ~v>" (actor-id a) (actor-name a)))])
|
||||
|
||||
(struct action-group (actor ;; (U Actor 'meta)
|
||||
actions ;; (Listof Action)
|
||||
)
|
||||
#:transparent)
|
||||
|
||||
(struct facet (id ;; FID
|
||||
[live? #:mutable] ;; Boolean
|
||||
actor ;; Actor
|
||||
parent ;; (Option Facet)
|
||||
endpoints ;; (MutableHash EID Endpoint)
|
||||
[stop-scripts #:mutable] ;; (Listof Script) -- IN REVERSE ORDER
|
||||
[children #:mutable] ;; (Seteqof Facet)
|
||||
)
|
||||
#:methods gen:custom-write
|
||||
[(define (write-proc f p mode)
|
||||
(local-require (only-in racket/string string-join))
|
||||
(define (facet-id-chain f)
|
||||
(if f
|
||||
(cons (number->string (facet-id f)) (facet-id-chain (facet-parent f)))
|
||||
'()))
|
||||
(fprintf p "#<facet ~a ~v ~a>"
|
||||
(actor-id (facet-actor f))
|
||||
(actor-name (facet-actor f))
|
||||
(string-join (facet-id-chain f) ":")))])
|
||||
|
||||
(struct endpoint (id ;; EID
|
||||
[assertion #:mutable] ;; Assertion
|
||||
[handler #:mutable] ;; (Option SkInterest)
|
||||
update-fn ;; (-> (Values Assertion (Option SkInterest)))
|
||||
)
|
||||
#:methods gen:custom-write
|
||||
[(define (write-proc e p mode)
|
||||
(fprintf p "#<endpoint ~a>" (endpoint-id e)))])
|
||||
|
||||
;; TODO: the field ownership checks during field-ref/field-set! might
|
||||
;; be quite expensive. Are they worth it?
|
||||
(struct field-handle (name ;; Symbol
|
||||
id ;; Nat
|
||||
owner ;; Actor
|
||||
[value #:mutable] ;; Any
|
||||
)
|
||||
#:methods gen:custom-write
|
||||
[(define (write-proc f port mode)
|
||||
(fprintf port "#<field-handle:~a:~a>" (field-handle-name f) (field-handle-id f)))]
|
||||
#:property prop:procedure
|
||||
(case-lambda
|
||||
[(f)
|
||||
(define ac (current-actor))
|
||||
(when (not (eq? (field-handle-owner f) ac)) (field-scope-error 'field-ref f))
|
||||
(dataflow-record-observation! (dataspace-dataflow (actor-dataspace ac)) f)
|
||||
(field-handle-value f)]
|
||||
[(f v)
|
||||
(define ac (current-actor))
|
||||
(when (not (eq? (field-handle-owner f) (current-actor))) (field-scope-error 'field-set! f))
|
||||
(when (not (equal? (field-handle-value f) v))
|
||||
(dataflow-record-damage! (dataspace-dataflow (actor-dataspace ac)) f)
|
||||
(set-field-handle-value! f v))]))
|
||||
|
||||
(define (field-scope-error who f)
|
||||
(error who "Field ~a used out-of-scope; owner = ~a, current = ~a"
|
||||
f
|
||||
(field-handle-owner f)
|
||||
(current-actor)))
|
||||
|
||||
;; Parameterof (Actor Exn -> Void)
|
||||
(define current-actor-crash-logger
|
||||
(make-parameter
|
||||
(lambda (a e)
|
||||
(log-error "Actor ~a died with exception:\n~a" a (exn->string e)))))
|
||||
|
||||
(define (current-actor) (facet-actor (current-facet)))
|
||||
|
||||
;; Parameterof Facet
|
||||
(define current-facet (make-parameter #f))
|
||||
|
||||
;; Parameterof Boolean
|
||||
(define in-script? (make-parameter #t))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
;; Script priorities. These are used to ensure that the results of
|
||||
;; some *side effects* are visible to certain pieces of code.
|
||||
|
||||
(module priorities racket/base
|
||||
(require (for-syntax racket/base))
|
||||
|
||||
(define-syntax (define-priority-levels stx)
|
||||
(let loop ((counter 0) (stx (syntax-case stx ()
|
||||
[(_ level ...) #'(level ...)])))
|
||||
(syntax-case stx ()
|
||||
[()
|
||||
#'(void)]
|
||||
[(#:count c)
|
||||
#`(begin (define c #,counter)
|
||||
(provide c))]
|
||||
[(this-level more ...)
|
||||
#`(begin (define this-level #,counter)
|
||||
(provide this-level)
|
||||
#,(loop (+ counter 1) #'(more ...)))])))
|
||||
|
||||
(define-priority-levels ;; highest-priority to lowest-priority
|
||||
*query-priority-high*
|
||||
*query-priority*
|
||||
*query-handler-priority*
|
||||
*normal-priority*
|
||||
*gc-priority*
|
||||
*idle-priority*
|
||||
#:count priority-count))
|
||||
|
||||
(require (submod "." priorities))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (make-dataspace boot-proc)
|
||||
(dataspace 0
|
||||
(make-empty-skeleton)
|
||||
(make-bag)
|
||||
(make-dataflow-graph)
|
||||
'()
|
||||
(enqueue (make-queue) (action-group 'meta (list (spawn #f boot-proc (set)))))))
|
||||
|
||||
(define (generate-id! ds)
|
||||
(let ((id (dataspace-next-id ds)))
|
||||
(set-dataspace-next-id! ds (+ id 1))
|
||||
id))
|
||||
|
||||
(define (add-actor! ds name boot-proc initial-assertions)
|
||||
(define the-actor-id (generate-id! ds))
|
||||
(define filtered-initial-assertions (set-remove initial-assertions (void)))
|
||||
(define initial-delta (set->bag filtered-initial-assertions +1))
|
||||
(define the-actor (actor the-actor-id
|
||||
ds
|
||||
name
|
||||
#f
|
||||
#f
|
||||
(make-vector priority-count (make-queue))
|
||||
(make-queue)
|
||||
initial-delta
|
||||
(bag)))
|
||||
(apply-patch! ds the-actor initial-delta)
|
||||
;; Root facet is a dummy "system" facet that exists to hold one-or-more "user" "root" facets.
|
||||
(add-facet! #f
|
||||
the-actor
|
||||
#f
|
||||
(lambda ()
|
||||
;; The "true root", user-visible facet.
|
||||
(add-facet! #f
|
||||
the-actor
|
||||
(current-facet)
|
||||
(lambda ()
|
||||
(boot-proc)))
|
||||
(for [(a filtered-initial-assertions)]
|
||||
(adhoc-retract! the-actor a)))))
|
||||
|
||||
(define-syntax-rule (with-current-facet [f0] body ...)
|
||||
(let ((f f0))
|
||||
;; (when (not f)
|
||||
;; (error 'with-current-facet "Cannot use with-current-facet this way"))
|
||||
(parameterize ((current-facet f))
|
||||
(with-handlers ([(lambda (e) (not (exn:break? e)))
|
||||
(lambda (e)
|
||||
(define a (current-actor))
|
||||
((current-actor-crash-logger) a e)
|
||||
(abandon-queued-work! a)
|
||||
;; v Supply #f for `emit-patches?` here
|
||||
;; because we are in an uncertain limbo after
|
||||
;; discarding previously-queued actions.
|
||||
;; Instead of emitting patches to orderly
|
||||
;; tear down assertions from endpoints, we
|
||||
;; rely on the recorded `cleanup-changes`.
|
||||
(terminate-actor! a #f e))]) ;; TODO: tracing
|
||||
(call-with-syndicate-prompt
|
||||
(lambda ()
|
||||
body ...))
|
||||
(void)))))
|
||||
|
||||
(define-syntax-rule (with-non-script-context body ...)
|
||||
(parameterize ((in-script? #f))
|
||||
body ...))
|
||||
|
||||
(define (capture-facet-context proc)
|
||||
(let ((f (current-facet)))
|
||||
;; (when (not f)
|
||||
;; (error 'capture-facet-context "Cannot capture non-facet"))
|
||||
(lambda args
|
||||
(with-current-facet [f]
|
||||
(apply proc args)))))
|
||||
|
||||
(define (pop-next-script! ac)
|
||||
(define priority-levels (actor-pending-scripts ac))
|
||||
(let loop ((level 0))
|
||||
(and (< level (vector-length priority-levels))
|
||||
(let ((q (vector-ref priority-levels level)))
|
||||
(if (queue-empty? q)
|
||||
(loop (+ level 1))
|
||||
(let-values (((script q) (dequeue q)))
|
||||
(vector-set! priority-levels level q)
|
||||
script))))))
|
||||
|
||||
(define (run-actor-pending-scripts! ds ac)
|
||||
(let loop ()
|
||||
(let ((script (pop-next-script! ac)))
|
||||
(and script
|
||||
(begin (script)
|
||||
(refresh-facet-assertions! ds)
|
||||
(loop))))))
|
||||
|
||||
(define (refresh-facet-assertions! ds)
|
||||
(with-non-script-context
|
||||
(dataflow-repair-damage! (dataspace-dataflow ds)
|
||||
(lambda (subject-id)
|
||||
(match-define (list f eid) subject-id)
|
||||
(when (facet-live? f) ;; TODO: necessary test, or tautological?
|
||||
(define ac (facet-actor f))
|
||||
(with-current-facet [f]
|
||||
(define ep (hash-ref (facet-endpoints f) eid))
|
||||
(match-define (endpoint _ old-assertion old-handler update-fn) ep)
|
||||
(define-values (new-assertion new-handler) (update-fn))
|
||||
(when (not (equal? old-assertion new-assertion))
|
||||
(retract! ac old-assertion)
|
||||
(when old-handler (dataspace-unsubscribe! ds old-handler))
|
||||
(set-endpoint-assertion! ep new-assertion)
|
||||
(set-endpoint-handler! ep new-handler)
|
||||
(assert! ac new-assertion)
|
||||
(when new-handler (dataspace-subscribe! ds new-handler)))))))))
|
||||
|
||||
(define (commit-actions! ds ac)
|
||||
(define pending (queue->list (actor-pending-actions ac)))
|
||||
;; (log-info "commit-actions!: ~a actions ~a" ac pending)
|
||||
(when (pair? pending)
|
||||
(set-actor-pending-actions! ac (make-queue))
|
||||
(set-dataspace-pending-actions! ds (enqueue (dataspace-pending-actions ds)
|
||||
(action-group ac pending)))))
|
||||
|
||||
(define (run-all-pending-scripts! ds)
|
||||
(define runnable (dataspace-runnable ds))
|
||||
(set-dataspace-runnable! ds '())
|
||||
(for [(ac (in-list runnable))]
|
||||
(run-actor-pending-scripts! ds ac)
|
||||
(set-actor-runnable?! ac #f)
|
||||
(commit-actions! ds ac)))
|
||||
|
||||
(define (perform-pending-actions! ds)
|
||||
(define groups (queue->list (dataspace-pending-actions ds)))
|
||||
(set-dataspace-pending-actions! ds (make-queue))
|
||||
(for [(group (in-list groups))]
|
||||
(match-define (action-group ac actions) group)
|
||||
(for [(action (in-list actions))]
|
||||
;; (log-info "~a in ~a performing ~a" ac (eq-hash-code ds) action)
|
||||
(match action
|
||||
[(patch delta)
|
||||
(apply-patch! ds ac delta)]
|
||||
[(message body)
|
||||
(send-assertion! (dataspace-routing-table ds) body)]
|
||||
[(spawn name boot-proc initial-assertions)
|
||||
(add-actor! ds name boot-proc initial-assertions)]
|
||||
[(quit)
|
||||
(apply-patch! ds ac (actor-cleanup-changes ac))]
|
||||
[(deferred-turn k)
|
||||
(push-script! ac k)])
|
||||
(run-all-pending-scripts! ds))))
|
||||
|
||||
(define (apply-patch! ds ac delta)
|
||||
(when (not (bag-empty? delta))
|
||||
(define ds-assertions (dataspace-assertions ds))
|
||||
;; (log-info "apply-patch! ~a ~v" ac delta)
|
||||
;; (for [((a c) (in-bag/count ds-assertions))] (log-info " . ~v = ~v" a c))
|
||||
;; (for [((a c) (in-bag/count delta))] (log-info " → ~v = ~v" a c))
|
||||
(define rt (dataspace-routing-table ds))
|
||||
(define pending-removals '())
|
||||
(define new-cleanup-changes
|
||||
(for/fold [(cleanup-changes (actor-cleanup-changes ac))] [((a count) (in-bag/count delta))]
|
||||
(match (bag-change! ds-assertions a count)
|
||||
['present->absent (set! pending-removals (cons a pending-removals))]
|
||||
['absent->present (add-assertion! rt a)]
|
||||
;; 'absent->absent absurd
|
||||
['present->present (void)]) ;; i.e. no visible change
|
||||
(define-values (updated-bag _summary) (bag-change cleanup-changes a (- count)))
|
||||
updated-bag))
|
||||
(for [(a (in-list pending-removals))]
|
||||
(remove-assertion! rt a))
|
||||
(set-actor-cleanup-changes! ac new-cleanup-changes)))
|
||||
|
||||
(define (run-scripts! ds)
|
||||
(run-all-pending-scripts! ds)
|
||||
(perform-pending-actions! ds)
|
||||
;; TODO: figure out when a dataspace should quit itself. Given the
|
||||
;; mutable nature of the implementation, maybe never? It might be
|
||||
;; being held elsewhere!
|
||||
(not (and (null? (dataspace-runnable ds))
|
||||
(queue-empty? (dataspace-pending-actions ds)))))
|
||||
|
||||
(define (add-facet! where actor parent boot-proc)
|
||||
(when (and (not (in-script?)) where)
|
||||
(error 'add-facet!
|
||||
"~a: Cannot add facet outside script; are you missing an (on ...)?"
|
||||
where))
|
||||
(define f (facet (generate-id! (actor-dataspace actor))
|
||||
#t
|
||||
actor
|
||||
parent
|
||||
(make-hash)
|
||||
'()
|
||||
(seteq)))
|
||||
(if parent
|
||||
(set-facet-children! parent (set-add (facet-children parent) f))
|
||||
(begin
|
||||
(when (actor-root-facet actor)
|
||||
;; This should never happen. We deliberately create an
|
||||
;; otherwise-dummy root facet for each actor specifically to
|
||||
;; hold user facets, and there should be no way for the user
|
||||
;; to stop that root facet explicitly, which means user code
|
||||
;; can't start any replacements for it at all, let alone
|
||||
;; more than one!
|
||||
(error 'add-facet! "INTERNAL ERROR: Attempt to add second root facet"))
|
||||
(set-actor-root-facet! actor f)))
|
||||
(with-current-facet [f]
|
||||
(with-non-script-context
|
||||
(boot-proc)))
|
||||
(push-script! actor (lambda ()
|
||||
(when (or (and parent (not (facet-live? parent))) (facet-inert? f))
|
||||
(terminate-facet! f)))))
|
||||
|
||||
(define (facet-inert? f)
|
||||
(and (hash-empty? (facet-endpoints f))
|
||||
(set-empty? (facet-children f))))
|
||||
|
||||
(define (schedule-script! #:priority [priority *normal-priority*] ac thunk)
|
||||
(push-script! #:priority priority ac (capture-facet-context thunk)))
|
||||
|
||||
(define (push-script! #:priority [priority *normal-priority*] ac thunk-with-context)
|
||||
(when (not (actor-runnable? ac))
|
||||
(set-actor-runnable?! ac #t)
|
||||
(let ((ds (actor-dataspace ac)))
|
||||
(set-dataspace-runnable! ds (cons ac (dataspace-runnable ds)))))
|
||||
(define v (actor-pending-scripts ac))
|
||||
(vector-set! v priority (enqueue (vector-ref v priority) thunk-with-context)))
|
||||
|
||||
(define (retract-facet-assertions-and-subscriptions! f emit-patches?)
|
||||
(define ac (facet-actor f))
|
||||
(define ds (actor-dataspace ac))
|
||||
(push-script! ac (lambda ()
|
||||
(for [((eid ep) (in-hash (facet-endpoints f)))]
|
||||
(destroy-endpoint! ds ac f ep emit-patches?))
|
||||
(hash-clear! (facet-endpoints f)))))
|
||||
|
||||
(define (abandon-queued-work! ac)
|
||||
(set-actor-pending-actions! ac (make-queue))
|
||||
(let ((scripts (actor-pending-scripts ac)))
|
||||
(for [(i (in-range (vector-length scripts)))]
|
||||
(vector-set! scripts i (make-queue)))))
|
||||
|
||||
;; Abruptly terminates an entire actor, without running stop-scripts etc.
|
||||
(define (terminate-actor! the-actor emit-patches? maybe-exn)
|
||||
(when emit-patches?
|
||||
(push-script! the-actor (lambda () (for [(a (in-bag (actor-adhoc-assertions the-actor)))]
|
||||
(retract! the-actor a)))))
|
||||
(let ((f (actor-root-facet the-actor)))
|
||||
(when f
|
||||
(let abort-facet! ((f f))
|
||||
(set-facet-live?! f #f)
|
||||
(for [(child (in-set (facet-children f)))] (abort-facet! child))
|
||||
(retract-facet-assertions-and-subscriptions! f emit-patches?))))
|
||||
(push-script! the-actor (lambda ()
|
||||
(let ((name (actor-name the-actor)))
|
||||
(when name
|
||||
(enqueue-send! the-actor (terminated name maybe-exn))))
|
||||
(enqueue-action! the-actor (quit)))))
|
||||
|
||||
;; Cleanly terminates a facet and its children, running stop-scripts etc.
|
||||
(define (terminate-facet! f)
|
||||
(when (facet-live? f)
|
||||
(define ac (facet-actor f))
|
||||
(define parent (facet-parent f))
|
||||
(if parent
|
||||
(set-facet-children! parent (set-remove (facet-children parent) f))
|
||||
(set-actor-root-facet! ac #f))
|
||||
|
||||
(set-facet-live?! f #f)
|
||||
|
||||
(for [(child (in-set (facet-children f)))] (terminate-facet! child))
|
||||
|
||||
;; Run stop-scripts after terminating children. This means that
|
||||
;; children's stop-scripts run before ours.
|
||||
(push-script! ac (lambda ()
|
||||
(with-current-facet [f]
|
||||
(for [(script (in-list (reverse (facet-stop-scripts f))))]
|
||||
(script)))))
|
||||
|
||||
(retract-facet-assertions-and-subscriptions! f #t)
|
||||
|
||||
(push-script! #:priority *gc-priority* ac
|
||||
(lambda ()
|
||||
(if parent
|
||||
(when (facet-inert? parent) (terminate-facet! parent))
|
||||
(terminate-actor! ac #t #f))))))
|
||||
|
||||
(define (stop-facet! f stop-script)
|
||||
(define ac (facet-actor f))
|
||||
(with-current-facet [(facet-parent f)] ;; run in parent context wrt terminating facet
|
||||
(schedule-script! ac (lambda ()
|
||||
(terminate-facet! f)
|
||||
(schedule-script! ac stop-script)))))
|
||||
|
||||
(define (add-stop-script! f script-proc)
|
||||
(set-facet-stop-scripts! f (cons script-proc (facet-stop-scripts f))))
|
||||
|
||||
(define (add-endpoint! f where dynamic? update-fn)
|
||||
(when (in-script?)
|
||||
(error 'add-endpoint!
|
||||
"~a: Cannot add endpoint in script; are you missing a (react ...)?"
|
||||
where))
|
||||
(define ds (actor-dataspace (facet-actor f)))
|
||||
(define eid (generate-id! ds))
|
||||
(define-values (assertion handler)
|
||||
(parameterize ((current-dataflow-subject-id (if dynamic? (list f eid) #f)))
|
||||
(call-with-syndicate-prompt update-fn)))
|
||||
(define ep (endpoint eid assertion handler update-fn))
|
||||
(assert! (facet-actor f) assertion)
|
||||
(when handler (dataspace-subscribe! ds handler))
|
||||
(hash-set! (facet-endpoints f) eid ep)
|
||||
eid)
|
||||
|
||||
(define (remove-endpoint! f eid)
|
||||
(define eps (facet-endpoints f))
|
||||
(define ep (hash-ref eps eid #f))
|
||||
(when ep
|
||||
(define ac (facet-actor f))
|
||||
(define ds (actor-dataspace ac))
|
||||
(destroy-endpoint! ds ac f ep #t)
|
||||
(hash-remove! eps eid)))
|
||||
|
||||
(define (destroy-endpoint! ds ac f ep emit-patches?)
|
||||
(match-define (endpoint eid assertion handler _update-fn) ep)
|
||||
(dataflow-forget-subject! (dataspace-dataflow ds) (list f eid))
|
||||
(when emit-patches? (retract! ac assertion))
|
||||
(when handler (dataspace-unsubscribe! ds handler)))
|
||||
|
||||
(define (enqueue-action! ac action)
|
||||
(set-actor-pending-actions! ac (enqueue (actor-pending-actions ac) action)))
|
||||
|
||||
(define (ensure-patch-action! ac)
|
||||
(let ((q (actor-pending-actions ac)))
|
||||
(when (or (queue-empty? q) (not (patch? (queue-last q))))
|
||||
(enqueue-action! ac (patch (make-bag)))))
|
||||
(patch-changes (queue-last (actor-pending-actions ac))))
|
||||
|
||||
(define (retract! ac assertion)
|
||||
(when (not (void? assertion))
|
||||
(bag-change! (ensure-patch-action! ac) assertion -1)))
|
||||
|
||||
(define (assert! ac assertion)
|
||||
(when (not (void? assertion))
|
||||
(bag-change! (ensure-patch-action! ac) assertion +1)))
|
||||
|
||||
(define (adhoc-retract! ac assertion [count 1])
|
||||
(when (not (void? assertion))
|
||||
(define-values (new-assertions summary)
|
||||
(bag-change (actor-adhoc-assertions ac) assertion (- count) #:clamp? #t))
|
||||
(set-actor-adhoc-assertions! ac new-assertions)
|
||||
(match summary
|
||||
;; 'absent->present absurd (if the call to `adhoc-retract!`
|
||||
;; matches a previous `adhoc-assert!`)
|
||||
['present->absent (retract! ac assertion)]
|
||||
['present->present (void)]
|
||||
['absent->absent (void)]))) ;; can happen if we're exploiting the clamping
|
||||
|
||||
(define (adhoc-assert! ac assertion [count 1])
|
||||
(when (not (void? assertion))
|
||||
(define-values (new-assertions summary)
|
||||
(bag-change (actor-adhoc-assertions ac) assertion count))
|
||||
(set-actor-adhoc-assertions! ac new-assertions)
|
||||
(match summary
|
||||
;; 'absent->absent and 'present->absent absurd (assuming there
|
||||
;; haven't been too many calls to `adhoc-retract!` in the past)
|
||||
['absent->present (assert! ac assertion)]
|
||||
['present->present (void)])))
|
||||
|
||||
(define (dataspace-unsubscribe! ds h)
|
||||
(remove-interest! (dataspace-routing-table ds) h))
|
||||
|
||||
(define (dataspace-subscribe! ds h)
|
||||
(add-interest! (dataspace-routing-table ds) h))
|
||||
|
||||
(define (ensure-in-script! who)
|
||||
(when (not (in-script?))
|
||||
(error who "Attempt to perform action outside script; are you missing an (on ...)?")))
|
||||
|
||||
(define (enqueue-send! ac body)
|
||||
(enqueue-action! ac (message body)))
|
||||
|
||||
(define (enqueue-deferred-turn! ac k)
|
||||
(enqueue-action! ac (deferred-turn (capture-facet-context k))))
|
||||
|
||||
(define (spawn! ac name boot-proc initial-assertions)
|
||||
(enqueue-action! ac (spawn name boot-proc initial-assertions)))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; Script suspend-and-resume.
|
||||
|
||||
(define prompt-tag (make-continuation-prompt-tag 'syndicate))
|
||||
|
||||
(define (call-with-syndicate-prompt thunk)
|
||||
(call-with-continuation-prompt thunk prompt-tag))
|
||||
|
||||
(define (suspend-script* where proc)
|
||||
(when (not (in-script?))
|
||||
(error 'suspend-script
|
||||
"~a: Cannot suspend script outside script; are you missing an (on ...)?"
|
||||
where))
|
||||
(call-with-composable-continuation
|
||||
(lambda (k)
|
||||
(abort-current-continuation
|
||||
prompt-tag
|
||||
(lambda ()
|
||||
(define in? (in-script?))
|
||||
(define raw-resume-parent
|
||||
(capture-facet-context
|
||||
(lambda results
|
||||
(parameterize ((in-script? in?))
|
||||
(apply k results)))))
|
||||
(define resume-parent
|
||||
(lambda results
|
||||
(push-script! (current-actor)
|
||||
(lambda () (apply raw-resume-parent results)))))
|
||||
(proc resume-parent))))
|
||||
prompt-tag))
|
|
@ -0,0 +1,5 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide (all-from-out "distributed/main.rkt"))
|
||||
(require/activate "distributed/main.rkt")
|
||||
(module+ main (require (submod "distributed/main.rkt" main)))
|
|
@ -0,0 +1,14 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide make-buffer)
|
||||
|
||||
(define (make-buffer)
|
||||
(field [pending '()])
|
||||
(define (push item)
|
||||
(pending (cons item (pending))))
|
||||
(define (drain handler)
|
||||
(begin/dataflow
|
||||
(when (pair? (pending))
|
||||
(for [(item (in-list (reverse (pending))))] (handler item))
|
||||
(pending '()))))
|
||||
(values push drain))
|
|
@ -0,0 +1,110 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide generic-client-session-facet)
|
||||
|
||||
(require "wire-protocol.rkt")
|
||||
(require "internal-protocol.rkt")
|
||||
(require "protocol.rkt")
|
||||
(require "turn.rkt")
|
||||
(require imperative-syndicate/term)
|
||||
|
||||
(require/activate "heartbeat.rkt")
|
||||
|
||||
(define-logger syndicate/distributed)
|
||||
|
||||
(spawn #:name 'client-factory
|
||||
(during (to-server $a _) (assert (server-connection a)))
|
||||
(during (observe (from-server $a _)) (assert (server-connection a)))
|
||||
(during (observe (server-connected $a)) (assert (server-connection a))))
|
||||
|
||||
(struct sub (spec [captures #:mutable]) #:transparent)
|
||||
|
||||
(define (generic-client-session-facet address scope w)
|
||||
(on-start (log-syndicate/distributed-info "Connected to ~v" address))
|
||||
(on-stop (log-syndicate/distributed-info "Disconnected from ~v" address))
|
||||
(assert (server-connected address))
|
||||
(assert (server-session-connected address))
|
||||
|
||||
(when (log-level? syndicate/distributed-logger 'debug)
|
||||
(set! w (let ((w* w))
|
||||
(lambda (p)
|
||||
(log-syndicate/distributed-debug "C OUT ~v ~v" address p)
|
||||
(w* p)))))
|
||||
|
||||
(define turn (turn-recorder (lambda (items) (w (Turn items)))))
|
||||
|
||||
(define next-ep
|
||||
(let ((counter 0))
|
||||
(lambda ()
|
||||
(begin0 counter
|
||||
(set! counter (+ counter 1))))))
|
||||
|
||||
(define pubs (hash))
|
||||
(define subs (hash))
|
||||
(define matches (hash))
|
||||
|
||||
(on-start (w (Connect scope)))
|
||||
(on-stop (for* [(s (in-hash-values matches)) (a (in-hash-values (sub-captures s)))] (retract! a)))
|
||||
|
||||
(define (instantiate s vs)
|
||||
(instantiate-term->value (from-server address (sub-spec s)) vs))
|
||||
|
||||
(on (asserted (to-server address $a))
|
||||
(define ep (next-ep))
|
||||
(extend-turn! turn (Assert ep a))
|
||||
(set! pubs (hash-set pubs a ep)))
|
||||
|
||||
(on (retracted (to-server address $a))
|
||||
(define ep (hash-ref pubs a))
|
||||
(extend-turn! turn (Clear ep))
|
||||
(set! pubs (hash-remove pubs a)))
|
||||
|
||||
(on (message (to-server address $a))
|
||||
(extend-turn! turn (Message a)))
|
||||
|
||||
(on (asserted (observe (from-server address $spec)))
|
||||
(define ep (next-ep))
|
||||
(extend-turn! turn (Assert ep (observe spec)))
|
||||
(set! subs (hash-set subs spec ep))
|
||||
(set! matches (hash-set matches ep (sub spec (hash)))))
|
||||
|
||||
(on (retracted (observe (from-server address $spec)))
|
||||
(extend-turn! turn (Clear (hash-ref subs spec)))
|
||||
(set! subs (hash-remove subs spec)))
|
||||
|
||||
(define reset-heartbeat! (heartbeat (list 'client address scope)
|
||||
w
|
||||
(lambda () (stop-current-facet))))
|
||||
|
||||
(on (message (server-packet address _))
|
||||
(reset-heartbeat!))
|
||||
|
||||
(on (message (server-packet address (Ping)))
|
||||
(w (Pong)))
|
||||
|
||||
(on (message (server-packet address (Err $detail $context)))
|
||||
(log-syndicate/distributed-error "Error from ~a: ~v~a"
|
||||
address
|
||||
detail
|
||||
(if context
|
||||
(format " ~v" context)
|
||||
""))
|
||||
(stop-current-facet))
|
||||
|
||||
(on (message (server-packet address (Turn $items)))
|
||||
(for [(item (in-list items))]
|
||||
(match item
|
||||
[(Add ep vs) (let* ((s (hash-ref matches ep))
|
||||
(a (instantiate s vs)))
|
||||
(set-sub-captures! s (hash-set (sub-captures s) vs a))
|
||||
(assert! a))]
|
||||
[(Del ep vs) (let* ((s (hash-ref matches ep))
|
||||
(a (hash-ref (sub-captures s) vs)))
|
||||
(retract! a)
|
||||
(set-sub-captures! s (hash-remove (sub-captures s) vs)))]
|
||||
[(Msg ep vs) (let* ((s (hash-ref matches ep)))
|
||||
(send! (instantiate s vs)))]
|
||||
[(End ep) (let* ((s (hash-ref matches ep #f)))
|
||||
(when s
|
||||
(for [(a (in-hash-values (sub-captures s)))] (retract! a))
|
||||
(set! matches (hash-remove matches ep))))]))))
|
|
@ -0,0 +1,22 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require "../client.rkt")
|
||||
(require "../wire-protocol.rkt")
|
||||
(require "../internal-protocol.rkt")
|
||||
(require "../protocol.rkt")
|
||||
|
||||
(require imperative-syndicate/protocol/credit)
|
||||
|
||||
(require/activate imperative-syndicate/distributed/server)
|
||||
|
||||
(spawn #:name 'loopback-client-factory
|
||||
(during/spawn (server-connection ($ address (server-loopback-connection $scope)))
|
||||
#:name address
|
||||
(assert (server-poa address))
|
||||
(on (message (message-server->poa address $p)) (send! (server-packet address p)))
|
||||
(on-start (react
|
||||
(stop-when (asserted (observe (message-poa->server address _)))
|
||||
(react (generic-client-session-facet
|
||||
address
|
||||
scope
|
||||
(lambda (x) (send! (message-poa->server address x))))))))))
|
|
@ -0,0 +1,44 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require "../client.rkt")
|
||||
(require "../wire-protocol.rkt")
|
||||
(require "../internal-protocol.rkt")
|
||||
(require "../protocol.rkt")
|
||||
(require imperative-syndicate/reassert)
|
||||
|
||||
(require/activate imperative-syndicate/drivers/tcp)
|
||||
|
||||
(spawn #:name 'tcp-client-factory
|
||||
(during/spawn (server-connection ($ address (server-tcp-connection $host $port $scope)))
|
||||
#:name address
|
||||
(define id (list (gensym 'client) host port))
|
||||
|
||||
(reassert-on (tcp-connection id (tcp-address host port))
|
||||
(retracted (tcp-accepted id))
|
||||
(asserted (tcp-rejected id _))
|
||||
(retracted (server-transport-connected address))
|
||||
(retracted (server-session-connected address)))
|
||||
|
||||
(during (tcp-accepted id)
|
||||
(on-start (issue-unbounded-credit! tcp-in id))
|
||||
(assert (server-transport-connected address))
|
||||
(define accumulate! (packet-accumulator (lambda (p) (send! (server-packet address p)))))
|
||||
(on (message (tcp-in id $bs)) (accumulate! bs)))
|
||||
|
||||
(during (server-transport-connected address)
|
||||
;; If we run generic-client-session-facet in the `tcp-accepted` handler above, then
|
||||
;; unfortunately disconnection of the TCP socket on error overtakes the error report
|
||||
;; itself, terminating the generic-client-session-facet before it has a chance to
|
||||
;; handle the error report.
|
||||
;;
|
||||
;; Could timing errors like that be something a type system could help us with? The
|
||||
;; conversation in `server-packet`s is sort-of "nested" inside the conversation in
|
||||
;; `tcp-in`s; a single facet reacting to both conversations (in this instance, to
|
||||
;; `server-packets` in an implicit frame, but explicitly to the frame of the
|
||||
;; `tcp-in`s, namely `tcp-accepted`) is probably an error. Or rather, any situation
|
||||
;; where pending "inner conversation" business could be obliterated by discarding a
|
||||
;; facet based on "outer conversation" framing is probably an error.
|
||||
;;
|
||||
(generic-client-session-facet address
|
||||
scope
|
||||
(lambda (x) (send! (tcp-out id (encode x))))))))
|
|
@ -0,0 +1,468 @@
|
|||
#lang imperative-syndicate
|
||||
;; Relays for federation, both "client" (outbound) and "server" (inbound) ends.
|
||||
|
||||
(require "wire-protocol.rkt")
|
||||
(require "internal-protocol.rkt")
|
||||
(require "protocol.rkt")
|
||||
(require "buffer.rkt")
|
||||
(require "turn.rkt")
|
||||
|
||||
(require imperative-syndicate/term)
|
||||
(require imperative-syndicate/reassert)
|
||||
(require racket/set)
|
||||
|
||||
(require/activate imperative-syndicate/drivers/tcp)
|
||||
|
||||
(define-logger syndicate/federation)
|
||||
|
||||
;; A federated scope (as distinct from a non-federated server scope)
|
||||
;; communicates via "links" to "peers", which come in three flavours:
|
||||
;; - inbound links, aka "downlinks" from the POV of this node, which
|
||||
;; result from incoming TCP/websocket/etc connections
|
||||
;; - outbound links, aka "uplinks", which reach out to a remote TCP/
|
||||
;; websocket/etc server
|
||||
;; - local links, (usually? always?) just one per scope, which
|
||||
;; connect the federated scope to its local server scope
|
||||
;;
|
||||
;; All links are identified by a link ID, scoped the same as
|
||||
;; connection IDs in <server.rkt> (namely, dataspace-unique). Links
|
||||
;; are stateful.
|
||||
;;
|
||||
;; The link protocol is enacted in special non-federated, local
|
||||
;; federation-management server scopes, identified by
|
||||
;; `federation-management-scope` assertions. The code in this module
|
||||
;; responds to assertions and messages in these scopes. Besides its
|
||||
;; scoped nature, the protocol is otherwise ordinary. By reusing
|
||||
;; Syndicate itself for management and operation of federation, we are
|
||||
;; able to address transport independently of federation.
|
||||
;;
|
||||
;; Inbound links are set up by code outside this module in response to
|
||||
;; the appearance of some new federated peer "downstream" of this one.
|
||||
;; For example, after establishing a new client-server connection to a
|
||||
;; federation-management scope, a remote peer may begin using the link
|
||||
;; protocol.
|
||||
;;
|
||||
;; Outbound links are created in response to an assertion of a
|
||||
;; `federated-uplink` record in a federation-management scope. Each
|
||||
;; such record contains a triple of a local scope ID, a client
|
||||
;; transport address (such as `server-tcp-connection` from
|
||||
;; <client/tcp.rkt>), and a remote scope ID. Together, these federate
|
||||
;; the local and remote scope IDs via a client-server connection to
|
||||
;; the given address.
|
||||
;;
|
||||
;; Local links are a special case of inbound link. They are created
|
||||
;; automatically whenever there is an active server scope of the same
|
||||
;; name as a federated scope.
|
||||
;;
|
||||
;; Local federation-management scopes must not be federated.
|
||||
;; TODO: Enforce this?
|
||||
|
||||
;; Subscription IDs (== "endpoint IDs") must be connection-unique AND
|
||||
;; must correspond one-to-one with a specific subscription spec. That
|
||||
;; is, a subscription ID is merely connection-local shorthand for its
|
||||
;; spec, and two subscription IDs within a connection must be `equal?`
|
||||
;; exactly when their corresponding specs are `equal?`.
|
||||
;;
|
||||
;; Local IDs must be scope-unique. They are used as subscription IDs
|
||||
;; in outbound messages.
|
||||
;;
|
||||
;; Each federated scope maintains a bidirectional mapping between
|
||||
;; subscription IDs (each scoped within its connection ID) and local
|
||||
;; IDs. One local ID may map to multiple subscription IDs - this is
|
||||
;; the place where aggregation pops up.
|
||||
|
||||
;; Unlike the client/server protocol, both Actions and Events are
|
||||
;; BIDIRECTIONAL, travelling in both directions along edges linking
|
||||
;; peer nodes.
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; Outbound links. (Really, they end up being a kind of "inbound link"
|
||||
;; too! Ultimately we have just *links*, connected to arbitrary
|
||||
;; things. For traditional "inbound", it's some remote party that has
|
||||
;; connected to us; for "local", it's a local server scope; for
|
||||
;; "outbound", it's a connection to another server that we reached out
|
||||
;; to.)
|
||||
|
||||
(spawn #:name 'federated-uplink-factory
|
||||
(during (federation-management-scope $management-scope)
|
||||
(during/spawn (server-envelope management-scope
|
||||
($ link (federated-uplink $local-scope
|
||||
$peer-addr
|
||||
$remote-scope)))
|
||||
#:name link
|
||||
(during (server-connected peer-addr)
|
||||
|
||||
(assert (server-proposal management-scope (federated-uplink-connected link)))
|
||||
;; ^ out to local requester
|
||||
|
||||
(define session-id (strong-gensym 'peer-))
|
||||
(assert (server-proposal management-scope (federated-link session-id local-scope)))
|
||||
(assert (to-server peer-addr (federated-link session-id remote-scope)))
|
||||
|
||||
;; We have to buffer in both directions, because at startup there's latency
|
||||
;; between asserting a federated-link record and it being ready to receive
|
||||
;; message-poa->server records.
|
||||
(define-values (push-in drain-in) (make-buffer))
|
||||
(define-values (push-out drain-out) (make-buffer))
|
||||
|
||||
(on (message (from-server peer-addr (message-server->poa session-id $p)))
|
||||
(push-in p))
|
||||
(on (message (server-envelope management-scope (message-server->poa session-id $p)))
|
||||
(push-out p))
|
||||
|
||||
(define (wrap p) (message-poa->server session-id p))
|
||||
(during (server-envelope management-scope (federated-link-ready session-id))
|
||||
(during (from-server peer-addr (federated-link-ready session-id))
|
||||
(drain-in (lambda (p) (send! (server-proposal management-scope (wrap p)))))
|
||||
(drain-out (lambda (p) (send! (to-server peer-addr (wrap p)))))))))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; Local links.
|
||||
|
||||
(spawn #:name 'federated-local-link-factory
|
||||
|
||||
(struct sub (spec [captures #:mutable]) #:transparent)
|
||||
|
||||
(during (federation-management-scope $management-scope)
|
||||
(during (server-envelope management-scope (federated-link _ $scope))
|
||||
(during/spawn (server-active scope)
|
||||
#:name (list 'local-link management-scope scope)
|
||||
|
||||
(define session-id (gensym 'local-link))
|
||||
(assert (server-proposal management-scope (federated-link session-id scope)))
|
||||
|
||||
(define (!! m)
|
||||
(send! (server-proposal management-scope (message-poa->server session-id m))))
|
||||
|
||||
(define turn (turn-recorder (lambda (items) (!! (Turn items)))))
|
||||
|
||||
(define remote-endpoints (hash))
|
||||
(define local-endpoints (hash))
|
||||
(define local-matches (hash))
|
||||
|
||||
(define (instantiate s vs)
|
||||
(instantiate-term->value (server-envelope scope (sub-spec s)) vs))
|
||||
|
||||
(on (asserted (observe (server-envelope scope $spec)))
|
||||
(define ep (gensym 'ep))
|
||||
(extend-turn! turn (Assert ep (observe spec)))
|
||||
(set! local-endpoints (hash-set local-endpoints spec ep))
|
||||
(set! local-matches (hash-set local-matches ep (sub spec (hash)))))
|
||||
|
||||
(on (retracted (observe (server-envelope scope $spec)))
|
||||
(define ep (hash-ref local-endpoints spec))
|
||||
(extend-turn! turn (Clear ep))
|
||||
(set! local-endpoints (hash-remove local-endpoints spec)))
|
||||
|
||||
(on (message (server-envelope management-scope
|
||||
(message-server->poa session-id (Turn $items))))
|
||||
(for [(item (in-list items))]
|
||||
(match item
|
||||
[(Assert subid (observe spec))
|
||||
(when (hash-has-key? remote-endpoints subid)
|
||||
(error 'local-link "Duplicate endpoint" subid))
|
||||
(react
|
||||
(define ep-facet (current-facet))
|
||||
(set! remote-endpoints (hash-set remote-endpoints subid ep-facet))
|
||||
(on-stop (set! remote-endpoints (hash-remove remote-endpoints subid)))
|
||||
(assert (server-envelope scope (observe spec)))
|
||||
(define ((! ctor) cs) (extend-turn! turn (ctor subid cs)))
|
||||
(add-observer-endpoint! (lambda () (server-proposal scope spec))
|
||||
#:on-add (! Add)
|
||||
#:on-remove (! Del)
|
||||
#:on-message (! Msg)))]
|
||||
[(Clear subid)
|
||||
(stop-facet (hash-ref remote-endpoints subid)
|
||||
(extend-turn! turn (End subid)))]
|
||||
[(Add ep vs) (let* ((s (hash-ref local-matches ep))
|
||||
(a (instantiate s vs)))
|
||||
(set-sub-captures! s (hash-set (sub-captures s) vs a))
|
||||
(assert! a))]
|
||||
[(Del ep vs) (let* ((s (hash-ref local-matches ep))
|
||||
(a (hash-ref (sub-captures s) vs)))
|
||||
(retract! a)
|
||||
(set-sub-captures! s (hash-remove (sub-captures s) vs)))]
|
||||
[(Msg ep vs) (let* ((s (hash-ref local-matches ep)))
|
||||
(send! (instantiate s vs)))]
|
||||
[(End ep) (let* ((s (hash-ref local-matches ep #f)))
|
||||
(when s
|
||||
(for [(a (in-hash-values (sub-captures s)))] (retract! a))
|
||||
(set! local-matches (hash-remove local-matches ep))))])))))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; Federated scopes.
|
||||
|
||||
(spawn #:name 'federated-scope-factory
|
||||
|
||||
(struct subscription (id ;; LocalID
|
||||
spec ;; Assertion
|
||||
holders ;; (Hash LinkID SubscriptionID)
|
||||
matches ;; (Hash (Listof Assertion) (Set LinkID))
|
||||
)
|
||||
#:transparent)
|
||||
|
||||
(during (federation-management-scope $management-scope)
|
||||
(during/spawn (server-envelope management-scope (federated-link _ $scope))
|
||||
#:name (list 'federated-scope management-scope scope)
|
||||
|
||||
;; Generates a fresh local ID naming a subscription propagated to our peers.
|
||||
(define make-localid (let ((next 0)) (lambda () (begin0 next (set! next (+ next 1))))))
|
||||
|
||||
(field [turns (hash)] ;; (Map LinkID Turn)
|
||||
[specs (hash)] ;; (Hash Spec LocalID)
|
||||
[subs (hasheq)] ;; (Hash LocalID Subscription)
|
||||
)
|
||||
|
||||
(define (send-to-link! peer p)
|
||||
(extend-turn! (hash-ref (turns) peer) p))
|
||||
|
||||
(when (log-level? syndicate/federation-logger 'debug)
|
||||
(begin/dataflow
|
||||
(log-syndicate/federation-debug "~a turns:" scope)
|
||||
(for [((peer turn) (in-hash (turns)))]
|
||||
(log-syndicate/federation-debug " link ~v -> ~v" peer (turn 'debug)))
|
||||
(log-syndicate/federation-debug "-"))
|
||||
(begin/dataflow
|
||||
(log-syndicate/federation-debug "~a specs:" scope)
|
||||
(for [((spec local) (in-hash (specs)))]
|
||||
(log-syndicate/federation-debug " spec ~v -> local ~a" spec local))
|
||||
(log-syndicate/federation-debug "-"))
|
||||
(begin/dataflow
|
||||
(log-syndicate/federation-debug "~a subs:" scope)
|
||||
(for [((local sub) (in-hash (subs)))]
|
||||
(match-define (subscription _id spec holders matches) sub)
|
||||
(log-syndicate/federation-debug " local ~a -> sub spec ~v" local spec)
|
||||
(when (not (hash-empty? holders))
|
||||
(log-syndicate/federation-debug " holders:")
|
||||
(for [((link ep) (in-hash holders))]
|
||||
(log-syndicate/federation-debug " link ~a -> ep ~a" link ep)))
|
||||
(when (not (hash-empty? matches))
|
||||
(log-syndicate/federation-debug " matches:")
|
||||
(for [((captures holders) (in-hash matches))]
|
||||
(log-syndicate/federation-debug " captures ~v held by ~a"
|
||||
captures holders))))
|
||||
(log-syndicate/federation-debug "-")))
|
||||
|
||||
(define (call-with-sub localid linkid f #:not-found-ok? [not-found-ok? #t])
|
||||
(match (hash-ref (subs) localid #f)
|
||||
[#f (when (not not-found-ok?)
|
||||
(log-syndicate/federation-error
|
||||
"Mention of nonexistent local ID ~v from link ~v. Ignoring."
|
||||
localid linkid))]
|
||||
[sub (f sub)]))
|
||||
|
||||
(define (store-sub! sub)
|
||||
(match-define (subscription localid spec holders matches) sub)
|
||||
(if (and (hash-empty? holders) (hash-empty? matches))
|
||||
(begin (specs (hash-remove (specs) spec))
|
||||
(subs (hash-remove (subs) localid)))
|
||||
(subs (hash-set (subs) localid sub))))
|
||||
|
||||
(define (unsubscribe! localid linkid)
|
||||
(call-with-sub
|
||||
#:not-found-ok? #f
|
||||
localid linkid
|
||||
(lambda (sub)
|
||||
(define new-holders (hash-remove (subscription-holders sub) linkid))
|
||||
(store-sub! (struct-copy subscription sub [holders new-holders]))
|
||||
|
||||
;; The messages we send depend on (hash-count new-holders):
|
||||
;; - if >1, there are enough other active subscribers that we don't need to send
|
||||
;; any messages.
|
||||
;; - if =1, we retract the subscription from that peer (INVARIANT: will not be linkid)
|
||||
;; - if =0, we retract the subscription from all peers except linkid
|
||||
|
||||
(match (hash-count new-holders)
|
||||
[0 (for [((peer turn) (in-hash (turns)))]
|
||||
(when (not (equal? peer linkid))
|
||||
(extend-turn! turn (Clear localid))))]
|
||||
[1 (for [(peer (in-hash-keys new-holders))] ;; there will only be one, ≠ linkid
|
||||
(send-to-link! peer (Clear localid)))]
|
||||
[_ (void)]))))
|
||||
|
||||
(define (remove-match! localid captures linkid)
|
||||
(call-with-sub
|
||||
localid linkid
|
||||
(lambda (sub)
|
||||
(define old-matches (subscription-matches sub))
|
||||
(define old-match-holders (hash-ref old-matches captures set))
|
||||
(define new-match-holders (set-remove old-match-holders linkid))
|
||||
(define new-matches (if (set-empty? new-match-holders)
|
||||
(hash-remove old-matches captures)
|
||||
(hash-set old-matches captures new-match-holders)))
|
||||
(store-sub! (struct-copy subscription sub [matches new-matches]))
|
||||
(match (set-count new-match-holders)
|
||||
[0 (for [((peer peer-subid) (in-hash (subscription-holders sub)))]
|
||||
(when (not (equal? peer linkid))
|
||||
(send-to-link! peer (Del peer-subid captures))))]
|
||||
[1 (for [(peer (in-set new-match-holders))] ;; only one, ≠ linkid
|
||||
(define maybe-peer-subid (hash-ref (subscription-holders sub) peer #f))
|
||||
(when maybe-peer-subid
|
||||
(send-to-link! peer (Del maybe-peer-subid captures))))]
|
||||
[_ (void)]))))
|
||||
|
||||
(during (server-envelope management-scope (federated-link $linkid scope))
|
||||
(assert (server-proposal management-scope (federated-link-ready linkid)))
|
||||
|
||||
(define turn (turn-recorder
|
||||
(lambda (items)
|
||||
(send! (server-proposal management-scope
|
||||
(message-server->poa linkid (Turn items)))))))
|
||||
|
||||
(field [link-subs (hash)] ;; (Hash SubscriptionID LocalID)
|
||||
[link-matches (hash)] ;; (Hash LocalID (Set (Listof Assertion)))
|
||||
)
|
||||
|
||||
(define (err! detail [context #f])
|
||||
(send! (server-proposal management-scope (message-server->poa linkid
|
||||
(Err detail context))))
|
||||
(reset-turn! turn)
|
||||
(stop-current-facet))
|
||||
|
||||
(on-start (log-syndicate/federation-debug "+PEER ~a link ~a" scope linkid)
|
||||
(turns (hash-set (turns) linkid turn))
|
||||
(for ([(spec localid) (in-hash (specs))])
|
||||
(when (not (hash-empty? (subscription-holders (hash-ref (subs) localid))))
|
||||
(extend-turn! turn (Assert localid (observe spec)))))
|
||||
(commit-turn! turn))
|
||||
|
||||
(on-stop (log-syndicate/federation-debug "-PEER ~a link ~a" scope linkid)
|
||||
(turns (hash-remove (turns) linkid))
|
||||
(for [((localid matches) (in-hash (link-matches)))]
|
||||
(for [(captures (in-set matches))]
|
||||
(remove-match! localid captures linkid)))
|
||||
(for ([localid (in-hash-values (link-subs))])
|
||||
(unsubscribe! localid linkid))
|
||||
(commit-turn! turn))
|
||||
|
||||
(when (log-level? syndicate/federation-logger 'debug)
|
||||
(begin/dataflow (log-syndicate/federation-debug "~a ~a link-subs:" scope linkid)
|
||||
(for [((sub local) (in-hash (link-subs)))]
|
||||
(log-syndicate/federation-debug " sub ~a -> local ~a" sub local))
|
||||
(log-syndicate/federation-debug "-"))
|
||||
(begin/dataflow (log-syndicate/federation-debug "~a ~a link-matches:" scope linkid)
|
||||
(for [((local matches) (in-hash (link-matches)))]
|
||||
(for [(captures (in-set matches))]
|
||||
(log-syndicate/federation-debug " local ~a captures ~v"
|
||||
local captures)))
|
||||
(log-syndicate/federation-debug "-")))
|
||||
|
||||
(stop-when
|
||||
(message (server-envelope management-scope
|
||||
(message-poa->server linkid (Err $detail $context))))
|
||||
(log-syndicate/federation-error
|
||||
"Received Err from peer link ~v: detail ~v; context ~v"
|
||||
linkid
|
||||
detail
|
||||
context)
|
||||
(reset-turn! turn))
|
||||
|
||||
(on (message (server-envelope management-scope
|
||||
(message-poa->server linkid (Turn $items))))
|
||||
(for [(item (in-list items))]
|
||||
(match item
|
||||
[(Assert subid (observe spec))
|
||||
(define known? (hash-has-key? (specs) spec))
|
||||
(define localid (if known? (hash-ref (specs) spec) (make-localid)))
|
||||
(define sub (hash-ref (subs) localid (lambda () (subscription localid
|
||||
spec
|
||||
(hash)
|
||||
(hash)))))
|
||||
(define holders (subscription-holders sub))
|
||||
(cond
|
||||
[(hash-has-key? holders linkid)
|
||||
(log-syndicate/federation-error
|
||||
"Duplicate subscription ~a, ID ~a, from link ~a."
|
||||
spec subid linkid)
|
||||
(err! 'duplicate-endpoint item)]
|
||||
[else
|
||||
(link-subs (hash-set (link-subs) subid localid))
|
||||
(when (not known?) (specs (hash-set (specs) spec localid)))
|
||||
(subs (hash-set (subs)
|
||||
localid
|
||||
(struct-copy subscription sub
|
||||
[holders (hash-set holders linkid subid)])))
|
||||
|
||||
;; If not known, then relay the subscription to all peers except `linkid`.
|
||||
;;
|
||||
;; If known, then one or more links that aren't this one have previously
|
||||
;; subscribed with this spec. If exactly one other link has previously
|
||||
;; subscribed, the only subscription that needs sent is to that peer;
|
||||
;; otherwise, no subscriptions at all need sent, since everyone has already
|
||||
;; been informed of this subscription.
|
||||
|
||||
(cond
|
||||
[(not known?)
|
||||
(for [((peer peer-turn) (in-hash (turns)))]
|
||||
(when (not (equal? peer linkid))
|
||||
(extend-turn! peer-turn (Assert localid (observe spec)))))]
|
||||
[(= (hash-count holders) 1)
|
||||
(for [(peer (in-hash-keys holders))] ;; there will only be one, ≠ linkid
|
||||
(send-to-link! peer (Assert localid (observe spec))))]
|
||||
[else
|
||||
(void)])
|
||||
|
||||
;; Once subscription relaying has taken place, send up matches to the active
|
||||
;; link.
|
||||
(for [((captures match-holders) (in-hash (subscription-matches sub)))]
|
||||
;; Compute the number of times someone OTHER THAN this link has asserted
|
||||
;; a match to this spec. If it's nonzero, we need to hear about it:
|
||||
(when (not (set-empty? (set-remove match-holders linkid)))
|
||||
(extend-turn! turn (Add subid captures))))
|
||||
|
||||
])]
|
||||
[(Clear subid)
|
||||
(match (hash-ref (link-subs) subid #f)
|
||||
[#f (log-syndicate/federation-error
|
||||
"Mention of nonexistent subscription ID ~v from link ~v."
|
||||
subid linkid)
|
||||
(err! 'nonexistent-endpoint item)]
|
||||
[localid
|
||||
(link-subs (hash-remove (link-subs) subid))
|
||||
(unsubscribe! localid linkid)])
|
||||
(extend-turn! turn (End subid))]
|
||||
[(End localid)
|
||||
(for [(captures (in-set (hash-ref (link-matches) localid set)))]
|
||||
(remove-match! localid captures linkid))
|
||||
(link-matches (hash-remove (link-matches) localid))]
|
||||
[(Add localid captures)
|
||||
(define matches (hash-ref (link-matches) localid set))
|
||||
(cond
|
||||
[(set-member? matches captures)
|
||||
(err! 'duplicate-capture item)]
|
||||
[else
|
||||
(link-matches (hash-set (link-matches) localid (set-add matches captures)))
|
||||
(call-with-sub
|
||||
localid linkid
|
||||
(lambda (sub)
|
||||
(define old-matches (subscription-matches sub))
|
||||
(define old-match-holders (hash-ref old-matches captures set))
|
||||
(define new-match-holders (set-add old-match-holders linkid))
|
||||
(define new-matches (hash-set old-matches captures new-match-holders))
|
||||
(store-sub! (struct-copy subscription sub [matches new-matches]))
|
||||
(match (set-count old-match-holders)
|
||||
[0 (for [((peer peer-subid) (in-hash (subscription-holders sub)))]
|
||||
(when (not (equal? peer linkid))
|
||||
(send-to-link! peer (Add peer-subid captures))))]
|
||||
[1 (for [(peer (in-set old-match-holders))] ;; only one, ≠ linkid
|
||||
(define peer-subid (hash-ref (subscription-holders sub) peer #f))
|
||||
(when peer-subid ;; the other holder may not itself subscribe!
|
||||
(send-to-link! peer (Add peer-subid captures))))]
|
||||
[_ (void)])))])]
|
||||
[(Del localid captures)
|
||||
(define matches (hash-ref (link-matches) localid set))
|
||||
(if (not (set-member? matches captures))
|
||||
(err! 'nonexistent-capture item)
|
||||
(let ((new-matches (set-remove matches captures)))
|
||||
(link-matches (if (set-empty? new-matches)
|
||||
(hash-remove (link-matches) localid)
|
||||
(hash-set (link-matches) localid new-matches)))
|
||||
(remove-match! localid captures linkid)))]
|
||||
[(Msg localid captures)
|
||||
(call-with-sub
|
||||
localid linkid
|
||||
(lambda (sub)
|
||||
(for ([(peer peer-subid) (in-hash (subscription-holders sub))])
|
||||
(when (not (equal? peer linkid))
|
||||
(send-to-link! peer (Msg peer-subid captures))))))]
|
||||
)))))))
|
|
@ -0,0 +1,50 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide heartbeat)
|
||||
|
||||
(module+ for-testing
|
||||
(provide heartbeats-enabled?))
|
||||
|
||||
(require "wire-protocol.rkt")
|
||||
|
||||
(require/activate imperative-syndicate/drivers/timer)
|
||||
|
||||
(define-logger syndicate/distributed)
|
||||
|
||||
(define heartbeats-enabled? (make-parameter #t))
|
||||
|
||||
;; TODO: move heartbeats to transport level, and use separate transport-activity timeouts from
|
||||
;; message-activity timeouts. Using message-activity only has problems when messages are large
|
||||
;; and links are slow. Also, moving to transport level lets us use e.g. WebSocket's ping
|
||||
;; mechanism rather than a message-level mechanism.
|
||||
(define (heartbeat who send-message teardown)
|
||||
(cond
|
||||
[(heartbeats-enabled?)
|
||||
(define period (ping-interval))
|
||||
(define grace (* 3 period))
|
||||
|
||||
(log-syndicate/distributed-debug
|
||||
"Peer ~v heartbeat period ~ams; must not experience silence longer than ~ams"
|
||||
who period grace)
|
||||
|
||||
(field [next-ping-time 0]) ;; when we are to send the next ping
|
||||
(field [last-received-traffic (current-inexact-milliseconds)]) ;; when we last heard from the peer
|
||||
|
||||
(define (schedule-next-ping!)
|
||||
(next-ping-time (+ (current-inexact-milliseconds) period)))
|
||||
|
||||
(on (asserted (later-than (next-ping-time)))
|
||||
(schedule-next-ping!)
|
||||
(send-message (Ping)))
|
||||
|
||||
(on (asserted (later-than (+ (last-received-traffic) grace)))
|
||||
(log-syndicate/distributed-info "Peer ~v heartbeat timeout after ~ams of inactivity"
|
||||
who grace)
|
||||
(teardown))
|
||||
|
||||
(lambda ()
|
||||
(schedule-next-ping!)
|
||||
(last-received-traffic (current-inexact-milliseconds)))]
|
||||
[else
|
||||
(log-syndicate/distributed-debug "Peer ~v heartbeats disabled" who)
|
||||
void]))
|
|
@ -0,0 +1,35 @@
|
|||
#lang imperative-syndicate
|
||||
;; Internal server and federation protocol
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; Client-server internal protocol
|
||||
;; Received packets from server are relayed via one of these.
|
||||
(message-struct server-packet (address packet))
|
||||
;; Like `server-connected`, but for reflecting `tcp-accepted` to the
|
||||
;; client end of a client-server connection without reordering wrt
|
||||
;; `server-packet` messages. Implementation-facing, where
|
||||
;; `server-connected` is part of the API.
|
||||
(assertion-struct server-transport-connected (address))
|
||||
;; Like `server-connected`, but for reflecting the state of the
|
||||
;; session to the transport driver. Observation of
|
||||
;; `server-session-connected` is not creative (of `server-connected`),
|
||||
;; unlike observation of `server-connected`.
|
||||
(assertion-struct server-session-connected (address))
|
||||
|
||||
;; Internal connection protocol
|
||||
(assertion-struct server-poa (connection-id)) ;; "Point of Attachment"
|
||||
(assertion-struct server-poa-ready (connection-id))
|
||||
(assertion-struct message-poa->server (connection-id body))
|
||||
(assertion-struct message-server->poa (connection-id body))
|
||||
|
||||
;; Internal isolation -- these are isomorphic to `to-server` and `from-server`!
|
||||
;; (and, for that matter, to `outbound` and `inbound`!)
|
||||
(assertion-struct server-proposal (scope body)) ;; suggestions (~ actions)
|
||||
(assertion-struct server-envelope (scope body)) ;; decisions (~ events)
|
||||
|
||||
(assertion-struct server-active (scope))
|
||||
|
||||
;; Federated links generally
|
||||
(assertion-struct federated-link (id scope))
|
||||
(assertion-struct federated-link-ready (id))
|
|
@ -0,0 +1,93 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide (all-from-out "protocol.rkt")
|
||||
(all-from-out "client.rkt")
|
||||
(all-from-out "client/tcp.rkt")
|
||||
(all-from-out "client/loopback.rkt")
|
||||
(all-from-out "server.rkt")
|
||||
(all-from-out "server/tcp.rkt")
|
||||
(all-from-out "server/websocket.rkt"))
|
||||
|
||||
(require "internal-protocol.rkt")
|
||||
(require "protocol.rkt")
|
||||
|
||||
(require/activate "client.rkt")
|
||||
(require/activate "client/tcp.rkt")
|
||||
(require/activate "client/loopback.rkt")
|
||||
|
||||
(require/activate "server.rkt")
|
||||
(require/activate "server/tcp.rkt")
|
||||
(require/activate "server/websocket.rkt")
|
||||
|
||||
(require/activate "federation.rkt")
|
||||
|
||||
(module+ main
|
||||
(require racket/cmdline)
|
||||
(define tcp-port default-tcp-server-port)
|
||||
(define http-port default-http-server-port)
|
||||
(define default-management-scope "local")
|
||||
(define uplinks '())
|
||||
(define management-scope default-management-scope)
|
||||
(command-line #:once-any
|
||||
["--tcp" port
|
||||
((format "Listen on plain TCP port (default ~a)" default-tcp-server-port))
|
||||
(set! tcp-port (string->number port))]
|
||||
["--no-tcp" "Do not listen on any plain TCP port"
|
||||
(set! tcp-port #f)]
|
||||
#:once-any
|
||||
["--http" port
|
||||
((format "Listen on websocket HTTP port (default ~a)" default-http-server-port))
|
||||
(set! http-port (string->number port))]
|
||||
["--no-http" "Do not listen on any websocket HTTP port"
|
||||
(set! http-port #f)]
|
||||
#:multi
|
||||
[("--management-scope" "-m") scope
|
||||
("Set the management scope for future `--uplink`s and, "
|
||||
"ultimately, for local federation management use. "
|
||||
(format "(default ~v)" default-management-scope))
|
||||
(set! management-scope scope)]
|
||||
["--uplink" local-scope host port remote-scope
|
||||
("Connect the named local-scope to the named remote-scope"
|
||||
"via the management scope in the server at host:port")
|
||||
(define port-number (string->number port))
|
||||
(when (not port-number)
|
||||
(eprintf "Invalid --uplink port number: ~v" port)
|
||||
(exit 1))
|
||||
(set! uplinks (cons (federated-uplink local-scope
|
||||
(server-tcp-connection host
|
||||
port-number
|
||||
management-scope)
|
||||
remote-scope)
|
||||
uplinks))])
|
||||
(extend-ground-boot! (lambda ()
|
||||
(spawn (assert (federation-management-scope management-scope)))
|
||||
;; ^ for inbound as well as outbound links
|
||||
(when tcp-port (spawn-tcp-server! tcp-port))
|
||||
(when http-port (spawn-websocket-server! http-port))
|
||||
(when (pair? uplinks)
|
||||
(spawn (define a (server-loopback-connection management-scope))
|
||||
(assert (server-connection a))
|
||||
(for [(u uplinks)]
|
||||
(assert (to-server a u))))))))
|
||||
|
||||
(define-logger syndicate/distributed)
|
||||
|
||||
(when (log-level? syndicate/distributed-logger 'debug)
|
||||
(spawn #:name 'client-debug
|
||||
(on (asserted (server-connection $addr))
|
||||
(log-syndicate/distributed-debug "C + ~v" addr))
|
||||
(on (retracted (server-connection $addr))
|
||||
(log-syndicate/distributed-debug "C - ~v" addr))
|
||||
(on (message (server-packet $addr $p))
|
||||
(log-syndicate/distributed-debug "C IN ~v ~v" addr p))
|
||||
;; C OUT is covered in client.rkt
|
||||
)
|
||||
(spawn #:name 'server-debug
|
||||
(on (asserted (server-poa $id))
|
||||
(log-syndicate/distributed-debug "S + ~v" id))
|
||||
(on (retracted (server-poa $id))
|
||||
(log-syndicate/distributed-debug "S - ~v" id))
|
||||
(on (message (message-poa->server $id $p))
|
||||
(log-syndicate/distributed-debug "S IN ~v ~v" id p))
|
||||
(on (message (message-server->poa $id $p))
|
||||
(log-syndicate/distributed-debug "S OUT ~v ~v" id p))))
|
|
@ -0,0 +1,24 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; Addressing
|
||||
(assertion-struct server-tcp-connection (host port scope))
|
||||
(assertion-struct server-loopback-connection (scope))
|
||||
|
||||
(define (standard-localhost-server/tcp [scope "broker"])
|
||||
(server-tcp-connection "localhost" 8001 scope))
|
||||
|
||||
;; Client protocol
|
||||
(assertion-struct to-server (address assertion))
|
||||
(assertion-struct from-server (address assertion))
|
||||
(assertion-struct server-connection (address))
|
||||
(assertion-struct server-connected (address))
|
||||
(message-struct force-server-disconnect (address))
|
||||
|
||||
;; Federation configuration
|
||||
;; e.g. (federated-uplink "scope1" (server-tcp-connection "peer.example" 8001 "local") "scope2")
|
||||
(assertion-struct federated-uplink (local-scope peer remote-scope))
|
||||
(assertion-struct federated-uplink-connected (link))
|
||||
|
||||
(assertion-struct federation-management-scope (name))
|
|
@ -0,0 +1,85 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require "wire-protocol.rkt")
|
||||
(require "internal-protocol.rkt")
|
||||
(require "turn.rkt")
|
||||
|
||||
(require/activate "heartbeat.rkt")
|
||||
|
||||
(spawn #:name 'server-factory
|
||||
|
||||
;; Previously, we just had server-envelope. Now, we have both
|
||||
;; server-envelope and server-proposal. While not everything
|
||||
;; decided is (locally) suggested, it is true that everything
|
||||
;; suggested is decided (in this implementation at least),
|
||||
;; and the following clauses reflect this:
|
||||
(on (asserted (server-proposal $scope $assertion))
|
||||
(assert! (server-envelope scope assertion)))
|
||||
(on (retracted (server-proposal $scope $assertion))
|
||||
(retract! (server-envelope scope assertion)))
|
||||
(on (message (server-proposal $scope $body))
|
||||
(send! (server-envelope scope body)))
|
||||
(on (asserted (observe (server-envelope $scope $spec)))
|
||||
(assert! (server-proposal scope (observe spec))))
|
||||
(on (retracted (observe (server-envelope $scope $spec)))
|
||||
(retract! (server-proposal scope (observe spec))))
|
||||
|
||||
(during/spawn (server-poa $id)
|
||||
(define root-facet (current-facet))
|
||||
(assert (server-poa-ready id))
|
||||
(on-start
|
||||
(match (let-event [(message (message-poa->server id $p))] p)
|
||||
[(Connect scope) (react (connected id scope root-facet))]
|
||||
[_ (send! (message-server->poa id (Err 'connection-not-setup #f)))]))))
|
||||
|
||||
(define (connected id scope root-facet)
|
||||
(define endpoints (hash))
|
||||
|
||||
(define turn (turn-recorder (lambda (items) (send! (message-server->poa id (Turn items))))))
|
||||
|
||||
(assert (server-active scope))
|
||||
|
||||
(define (send-error! detail [context #f])
|
||||
(send! (message-server->poa id (Err detail context)))
|
||||
(reset-turn! turn)
|
||||
(stop-facet root-facet))
|
||||
|
||||
(define reset-heartbeat! (heartbeat (list 'server id scope)
|
||||
(lambda (m) (send! (message-server->poa id m)))
|
||||
(lambda () (stop-facet root-facet))))
|
||||
|
||||
(on (message (message-poa->server id $p))
|
||||
(reset-heartbeat!)
|
||||
(match p
|
||||
[(Turn items)
|
||||
(for [(item (in-list items))]
|
||||
(match item
|
||||
[(Assert ep a)
|
||||
(if (hash-has-key? endpoints ep)
|
||||
(send-error! 'duplicate-endpoint item)
|
||||
(react
|
||||
(define ep-facet (current-facet))
|
||||
(set! endpoints (hash-set endpoints ep ep-facet))
|
||||
(on-stop (set! endpoints (hash-remove endpoints ep)))
|
||||
|
||||
(assert (server-proposal scope a))
|
||||
|
||||
(when (observe? a)
|
||||
(define ((! ctor) cs) (extend-turn! turn (ctor ep cs)))
|
||||
(add-observer-endpoint!
|
||||
(lambda () (server-envelope scope (observe-specification a)))
|
||||
#:on-add (! Add)
|
||||
#:on-remove (! Del)
|
||||
#:on-message (! Msg)))))]
|
||||
[(Clear ep)
|
||||
(match (hash-ref endpoints ep #f)
|
||||
[#f (send-error! 'nonexistent-endpoint item)]
|
||||
[ep-facet (stop-facet ep-facet (extend-turn! turn (End ep)))])]
|
||||
[(Message body)
|
||||
(send! (server-proposal scope body))]))]
|
||||
[(Ping)
|
||||
(send! (message-server->poa id (Pong)))]
|
||||
[(Pong)
|
||||
(void)]
|
||||
[_
|
||||
(send-error! 'invalid-message p)])))
|
|
@ -0,0 +1,32 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide server-facet/tcp
|
||||
default-tcp-server-port
|
||||
spawn-tcp-server!)
|
||||
|
||||
(require "../wire-protocol.rkt")
|
||||
(require "../internal-protocol.rkt")
|
||||
|
||||
(require/activate imperative-syndicate/drivers/tcp)
|
||||
(require/activate imperative-syndicate/distributed/server)
|
||||
|
||||
(define (server-facet/tcp id)
|
||||
(assert (tcp-accepted id))
|
||||
(assert (server-poa id))
|
||||
(stop-when (retracted (server-poa-ready id)))
|
||||
(on-start (issue-unbounded-credit! tcp-in id))
|
||||
(define accumulate! (packet-accumulator (lambda (p) (send! (message-poa->server id p)))))
|
||||
(on (message (tcp-in id $bs))
|
||||
(accumulate! bs))
|
||||
(on (message (message-server->poa id $p))
|
||||
(send! (tcp-out id (encode p)))
|
||||
(when (Err? p) (stop-current-facet))))
|
||||
|
||||
(define default-tcp-server-port 21369)
|
||||
|
||||
(define (spawn-tcp-server! [port default-tcp-server-port])
|
||||
(spawn #:name 'tcp-server-listener
|
||||
(during/spawn (tcp-connection $id (tcp-listener port))
|
||||
#:name `(server-poa ,id)
|
||||
(on-start (issue-credit! (tcp-listener port)))
|
||||
(server-facet/tcp id))))
|
|
@ -0,0 +1,35 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide server-facet/websocket
|
||||
default-http-server-port
|
||||
spawn-websocket-server!)
|
||||
|
||||
(require "../wire-protocol.rkt")
|
||||
(require "../internal-protocol.rkt")
|
||||
|
||||
(require imperative-syndicate/protocol/credit)
|
||||
|
||||
(require/activate imperative-syndicate/drivers/web)
|
||||
(require/activate imperative-syndicate/distributed/server)
|
||||
|
||||
(define (server-facet/websocket id)
|
||||
(assert (http-accepted id))
|
||||
(assert (http-response-websocket id))
|
||||
(assert (server-poa id))
|
||||
(stop-when (retracted (server-poa-ready id)))
|
||||
(on (message (websocket-in id $body))
|
||||
(define-values (packet remainder) (decode body))
|
||||
(when (not (equal? remainder #""))
|
||||
(error 'server-facet/websocket "Multiple packets in a single websocket message"))
|
||||
(send! (message-poa->server id packet)))
|
||||
(on (message (message-server->poa id $p))
|
||||
(send! (websocket-out id (encode p)))
|
||||
(when (Err? p) (stop-current-facet))))
|
||||
|
||||
(define default-http-server-port 8000)
|
||||
|
||||
(define (spawn-websocket-server! [port default-http-server-port])
|
||||
(spawn #:name 'websocket-server-listener
|
||||
(during/spawn (http-request $id 'get (http-resource (http-server _ port #f) `("" ())) _ _ _)
|
||||
#:name `(server-poa ,id)
|
||||
(server-facet/websocket id))))
|
|
@ -0,0 +1,34 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide turn-recorder
|
||||
extend-turn!
|
||||
commit-turn!
|
||||
reset-turn!)
|
||||
|
||||
(require (submod "../dataspace.rkt" priorities))
|
||||
|
||||
(define (extend-turn! t item) (t 'extend item))
|
||||
(define (commit-turn! t) (t 'commit))
|
||||
(define (reset-turn! t) (t 'reset))
|
||||
|
||||
(define (turn-recorder on-commit)
|
||||
(field [commit-needed #f])
|
||||
(define items '())
|
||||
(define t
|
||||
(match-lambda*
|
||||
[(list 'extend item)
|
||||
(set! items (cons item items))
|
||||
(commit-needed #t)]
|
||||
[(list 'commit)
|
||||
(when (commit-needed)
|
||||
(on-commit (reverse items))
|
||||
(reset-turn! t))]
|
||||
[(list 'reset)
|
||||
(set! items '())
|
||||
(commit-needed #f)]
|
||||
[(list 'debug)
|
||||
(reverse items)]))
|
||||
(begin/dataflow
|
||||
#:priority *idle-priority*
|
||||
(commit-turn! t))
|
||||
t)
|
|
@ -0,0 +1,70 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(require (prefix-in preserves: preserves))
|
||||
(require bitsyntax)
|
||||
(require (only-in net/rfc6455 ws-idle-timeout))
|
||||
(require (only-in racket/list index-of))
|
||||
|
||||
;; Enrolment
|
||||
(message-struct Connect (scope)) ;; Client --> Server
|
||||
|
||||
;; Transactions
|
||||
(message-struct Turn (items)) ;; Bidirectional
|
||||
;; Items:
|
||||
;; Actions; Client --> Server (and Peer --> Peer, except for Message)
|
||||
(message-struct Assert (endpoint-name assertion))
|
||||
(message-struct Clear (endpoint-name))
|
||||
(message-struct Message (body))
|
||||
;; Events; Server --> Client (and Peer --> Peer)
|
||||
(message-struct Add (endpoint-name captures))
|
||||
(message-struct Del (endpoint-name captures))
|
||||
(message-struct Msg (endpoint-name captures))
|
||||
(message-struct End (endpoint-name))
|
||||
|
||||
;; Errors
|
||||
(message-struct Err (detail context)) ;; Server --> Client (and Peer --> Peer)
|
||||
|
||||
;; Transport-related; Bidirectional
|
||||
(message-struct Ping ())
|
||||
(message-struct Pong ())
|
||||
|
||||
;; In peer mode, *actions* and *events* travel in *both* directions,
|
||||
;; but `Message`s do not appear and (for now) `Assert` is only used to
|
||||
;; establish `observe`s, i.e. subscriptions.
|
||||
|
||||
(define (decode bs)
|
||||
(parameterize ((preserves:current-placeholder->value
|
||||
(lambda (v) (vector-ref '#(discard capture observe) v))))
|
||||
(bit-string-case bs
|
||||
#:on-short (lambda (fail) (values #f bs))
|
||||
([ (v :: (preserves:wire-value)) (rest :: binary) ] (values v (bit-string->bytes rest)))
|
||||
(else (error 'decode "Invalid wire message")))))
|
||||
|
||||
(define (encode v)
|
||||
(parameterize ((preserves:current-value->placeholder
|
||||
(lambda (v) (index-of '(discard capture observe) v eq?))))
|
||||
(preserves:encode v)))
|
||||
|
||||
(define (ping-interval)
|
||||
(* 1000 (min 60 ;; reasonable default?
|
||||
;;
|
||||
;; TODO: disable the net/rfc6455 ws-idle-timeout, when we can.
|
||||
;;
|
||||
;; The net/rfc6455 ws-idle-timeout has to be paid attention to here because it
|
||||
;; can't be disabled, because the built-in webserver (which net/rfc6455
|
||||
;; interoperates with) has a per-connection timer that also can't be disabled.
|
||||
;;
|
||||
(max (- (ws-idle-timeout) 10)
|
||||
(* (ws-idle-timeout) 0.8)))))
|
||||
|
||||
(define (packet-accumulator handle-packet!)
|
||||
(field [buffer #""])
|
||||
(begin/dataflow
|
||||
(define-values (packet remainder) (decode (buffer)))
|
||||
(when packet
|
||||
(buffer remainder)
|
||||
(handle-packet! packet)))
|
||||
(lambda (chunk)
|
||||
(buffer (bytes-append (buffer) chunk))))
|
|
@ -0,0 +1,38 @@
|
|||
#lang imperative-syndicate
|
||||
;; Monitor configuration files.
|
||||
|
||||
(provide (struct-out config)
|
||||
spawn-configuration
|
||||
define/query-config
|
||||
config-ref)
|
||||
|
||||
(define-logger syndicate/drivers/config)
|
||||
|
||||
(require racket/file)
|
||||
(require/activate imperative-syndicate/drivers/filesystem)
|
||||
|
||||
;; (config Any Any)
|
||||
(assertion-struct config (scope item))
|
||||
|
||||
(define (spawn-configuration scope path #:hook [hook void])
|
||||
(spawn #:name (list 'configuration-monitor scope path)
|
||||
(hook)
|
||||
(during (file-content path file->list $items)
|
||||
(cond
|
||||
[(not items)
|
||||
(log-syndicate/drivers/config-warning "config ~s is missing" path)]
|
||||
[else
|
||||
(log-syndicate/drivers/config-info "loading config ~s" path)
|
||||
(for [(item items)]
|
||||
(log-syndicate/drivers/config-info "config ~s: ~s" path item)
|
||||
(assert (config scope item)))]))))
|
||||
|
||||
(define-syntax define/query-config
|
||||
(syntax-rules ()
|
||||
[(_ scope id default)
|
||||
(define/query-config id scope id default)]
|
||||
[(_ id scope key default)
|
||||
(define/query-value id default (config scope (list 'key $val)) val)]))
|
||||
|
||||
(define (config-ref scope key default)
|
||||
(immediate-query (query-value default (config scope (list key $val)) val)))
|
|
@ -0,0 +1,19 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide (struct-out external-event))
|
||||
|
||||
(message-struct external-event (descriptor values))
|
||||
|
||||
(spawn #:name 'external-event-relay
|
||||
(during/spawn (observe (inbound (external-event $desc _)))
|
||||
(define ch (make-channel))
|
||||
(thread (lambda ()
|
||||
(let loop ()
|
||||
(sync ch
|
||||
(handle-evt desc
|
||||
(lambda results
|
||||
(ground-send! (inbound (external-event desc results)))
|
||||
(loop)))))))
|
||||
(signal-background-activity! +1)
|
||||
(on-stop (channel-put ch 'quit)
|
||||
(signal-background-activity! -1))))
|
|
@ -0,0 +1,82 @@
|
|||
#lang imperative-syndicate
|
||||
;; Filesystem change monitor driver
|
||||
|
||||
(provide (struct-out file-content)
|
||||
spawn-filesystem-driver)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(assertion-struct file-content (name reader-proc content))
|
||||
|
||||
;; Internal driver ground-level protocol
|
||||
(message-struct file-changed (name))
|
||||
(message-struct file-container-changed (parent-path))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (spawn-filesystem-driver)
|
||||
(spawn #:name 'drivers/filesystem
|
||||
(during/spawn (observe (file-content $name $reader-proc _))
|
||||
#:name (list 'file-content name reader-proc)
|
||||
(track-file name reader-proc))
|
||||
(during (observe (inbound (file-changed $name)))
|
||||
(monitor-thread name))))
|
||||
|
||||
(define (read-file name reader-proc)
|
||||
(and (or (file-exists? name) (directory-exists? name))
|
||||
(reader-proc name)))
|
||||
|
||||
(define (path->parent-path name)
|
||||
(let-values (((parent-path _leaf _syntactically-dir?)
|
||||
(split-path (path->complete-path name))))
|
||||
parent-path))
|
||||
|
||||
(define (track-file name reader-proc)
|
||||
(field [content (read-file name reader-proc)])
|
||||
(assert (file-content name reader-proc (content)))
|
||||
(on (message (inbound (file-changed name)))
|
||||
(content (read-file name reader-proc)))
|
||||
;; This horrible hack is required to work around limitations in the
|
||||
;; OS's file-change reporting. It seems (?) as if, monitoring both
|
||||
;; "a/b" and "a/", that only the event for "a/" will be fired when
|
||||
;; "a/b" changes. This manifests as follows: if I monitor "a/b" and
|
||||
;; "a/nonexistent", then when "a/b" changes, only "a/nonexistent"'s
|
||||
;; event will fire. Therefore, I've kludged in the
|
||||
;; `file-container-changed` message, which copes with one level of
|
||||
;; directory hierarchy of this problem.
|
||||
;;
|
||||
;; TODO: Consider whether it will actually be required to listen for
|
||||
;; file-container-changed events for ALL recursive parents of the
|
||||
;; path of interest up to the root.
|
||||
;;
|
||||
(on (message (inbound (file-container-changed (path->parent-path name))))
|
||||
(content (read-file name reader-proc))))
|
||||
|
||||
(define (monitor-thread name)
|
||||
(define control-ch (make-channel))
|
||||
(thread (lambda ()
|
||||
(define parent-path (path->parent-path name))
|
||||
(let loop ()
|
||||
(sync (handle-evt control-ch
|
||||
(lambda (msg)
|
||||
;; (log-info "track-file-changes ~v: ~v" name msg)
|
||||
(match msg
|
||||
['quit (void)])))
|
||||
(if (or (file-exists? name) (directory-exists? name)) ;; TODO: TOCTTOU :-(
|
||||
(handle-evt (filesystem-change-evt name)
|
||||
(lambda (_dummy)
|
||||
;; (log-info "track-file-changes ~v: changed" name)
|
||||
(ground-send! (inbound (file-changed name)))
|
||||
(loop)))
|
||||
(handle-evt (filesystem-change-evt parent-path)
|
||||
(lambda (_dummy)
|
||||
;; (log-info "track-file-changes ~v: directory changed" name)
|
||||
(ground-send! (inbound (file-container-changed parent-path)))
|
||||
(loop))))))
|
||||
(signal-background-activity! -1)))
|
||||
(signal-background-activity! +1)
|
||||
(on-stop (channel-put control-ch 'quit)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(spawn-filesystem-driver)
|
|
@ -0,0 +1,662 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide (struct-out window)
|
||||
(struct-out frame-event)
|
||||
(struct-out key-event)
|
||||
(struct-out key-pressed)
|
||||
(struct-out mouse-event)
|
||||
(struct-out mouse-state)
|
||||
(struct-out touching)
|
||||
(struct-out coordinate-map)
|
||||
(struct-out scene)
|
||||
(except-out (struct-out sprite) sprite)
|
||||
(rename-out [sprite <sprite>] [make-sprite sprite])
|
||||
(struct-out gl-control)
|
||||
in-unit-circle?
|
||||
in-unit-square?
|
||||
simple-sprite
|
||||
assert-scene
|
||||
spawn-keyboard-integrator
|
||||
spawn-mouse-integrator
|
||||
spawn-gl-2d-driver)
|
||||
|
||||
(require data/order)
|
||||
(require data/splay-tree)
|
||||
(require data/queue)
|
||||
(require sgl/gl)
|
||||
(require sgl/gl-vectors)
|
||||
|
||||
(require racket/gui/base)
|
||||
(require racket/dict)
|
||||
(require (only-in racket/class
|
||||
send is-a? make-object class class* inherit this new super-new init
|
||||
define/public define/override define/augment))
|
||||
(require (only-in racket/math sqr))
|
||||
|
||||
(require (prefix-in image: 2htdp/image))
|
||||
(require (prefix-in pict: pict))
|
||||
|
||||
(require syndicate-gl/texture)
|
||||
(require syndicate-gl/affine)
|
||||
|
||||
(require/activate imperative-syndicate/drivers/timer)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; Shared state maintained by dataspace. Describes current window dimensions.
|
||||
(assertion-struct window (width height))
|
||||
|
||||
;; Message sent by dataspace. Describes render time.
|
||||
(message-struct frame-event (counter timestamp elapsed-ms target-frame-rate))
|
||||
|
||||
;; Message sent by dataspace. Describes a key event. Key is a sealed
|
||||
;; key-event%. `press?` is #t when the key is pressed (or
|
||||
;; autorepeated!), and #f when it is released.
|
||||
(message-struct key-event (code press? key))
|
||||
|
||||
;; Assertion. Indicates that the named key is held down. See role
|
||||
;; KeyboardIntegrator and spawn-keyboard-integrator.
|
||||
(assertion-struct key-pressed (code))
|
||||
|
||||
;; Message sent by dataspace. Describes a mouse event. State is a
|
||||
;; MouseState.
|
||||
(message-struct mouse-event (type state))
|
||||
|
||||
;; Assertion. Indicates that the mouse is in a particular state. See
|
||||
;; role MouseIntegrator and spawn-mouse-integrator.
|
||||
(assertion-struct mouse-state (x y left-down? middle-down? right-down?))
|
||||
|
||||
;; Assertion. Indicates that the mouse is touching a particular touchable.
|
||||
(assertion-struct touching (id))
|
||||
|
||||
;; Assertion. Communicates aggregate device-to-user transformation
|
||||
;; requested as part of sprite instruction sequences.
|
||||
(assertion-struct coordinate-map (id matrix))
|
||||
|
||||
;; Shared state maintained by program. Prelude and postlude are to be
|
||||
;; sealed instruction lists. It is an error to have more than exactly
|
||||
;; one active such record at a given time.
|
||||
(assertion-struct scene (prelude postlude))
|
||||
|
||||
;; A SpriteID is an equal?-comparable dataspace-unique value.
|
||||
|
||||
;; Shared state maintained by program. `id` is a SpriteID, and
|
||||
;; `parent-id` is an (Option SpriteID); #f in `parent-id` means that
|
||||
;; this sprite is a child of the root. Z is to be a number, negative
|
||||
;; toward camera. Instructions to be a sealed instruction list.
|
||||
(assertion-struct sprite (id parent-id z instructions))
|
||||
|
||||
;; Message and assertion.
|
||||
;;
|
||||
;; When sent as a message with `body` of `'stop`, closes the GL window
|
||||
;; and terminates the driver.
|
||||
;;
|
||||
;; When asserted with `body` of `'fullscreen`, causes the window to be
|
||||
;; fullscreen; otherwise, it is a normal window.
|
||||
;;
|
||||
(assertion-struct gl-control (body))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-syntax-rule (assert-scene prelude postlude)
|
||||
(assert (scene (seal prelude) (seal postlude))))
|
||||
|
||||
(define (make-sprite z instructions #:id [id #f] #:parent [parent-id #f])
|
||||
(sprite (or id (gensym 'sprite)) parent-id z (seal instructions)))
|
||||
|
||||
(define (in-unit-circle? x y)
|
||||
(<= (+ (sqr (- x 0.5)) (sqr (- y 0.5))) (sqr 0.5)))
|
||||
|
||||
(define (in-unit-square? x y)
|
||||
(and (<= 0 x 1)
|
||||
(<= 0 y 1)))
|
||||
|
||||
(define (simple-sprite z x y w h i
|
||||
#:parent [parent-id #f]
|
||||
#:rotation [rotation 0]
|
||||
#:coordinate-map-id [coordinate-map-id #f]
|
||||
#:touchable-id [touchable-id #f]
|
||||
#:touchable-predicate [touchable-predicate in-unit-square?])
|
||||
(make-sprite #:id touchable-id
|
||||
#:parent parent-id
|
||||
z
|
||||
`((translate ,x ,y)
|
||||
,@(if (zero? rotation) `() `((rotate ,rotation)))
|
||||
(push-matrix
|
||||
(scale ,w ,h)
|
||||
,@(if touchable-id
|
||||
`((touchable ,touchable-id ,touchable-predicate))
|
||||
`())
|
||||
(texture ,i))
|
||||
,@(if coordinate-map-id
|
||||
`((coordinate-map ,coordinate-map-id))
|
||||
`())
|
||||
(render-children))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; KeyboardIntegrator. Integrates key-events into key-pressed assertions.
|
||||
(define (spawn-keyboard-integrator)
|
||||
(spawn #:name 'gl-2d/keyboard-integratpr
|
||||
(local-require racket/set)
|
||||
(define keys-pressed (mutable-set))
|
||||
;; TODO: consider adding set-semantics assert!/retract! API for this kind of thing
|
||||
(on (message (key-event $code #t _))
|
||||
(unless (set-member? keys-pressed code)
|
||||
(set-add! keys-pressed code)
|
||||
(assert! (key-pressed code))))
|
||||
(on (message (key-event $code #f _))
|
||||
(when (set-member? keys-pressed code)
|
||||
(set-remove! keys-pressed code)
|
||||
(retract! (key-pressed code))))))
|
||||
|
||||
;; MouseIntegrator. Integrates mouse-events into mouse-state assertions.
|
||||
(define (spawn-mouse-integrator)
|
||||
(spawn #:name 'gl-2d/mouse-integrator
|
||||
(field [in-bounds? #f] [state #f])
|
||||
(assert #:when (in-bounds?) (state))
|
||||
(on (message (mouse-event $type $new-state))
|
||||
(in-bounds? (not (eq? type 'leave)))
|
||||
(state new-state))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; A Touchable is one of
|
||||
;;
|
||||
;; - (touchable Any TransformationMatrix (Number Number -> Boolean))
|
||||
;; Represents a composed device-to-user transformation, plus a
|
||||
;; predicate on user coordinates, and an ID to use when the
|
||||
;; predicate answers truthily.
|
||||
;;
|
||||
;; - (touchable-map)
|
||||
;; Represents the location in a sequence of touchables where the
|
||||
;; aggregate partial device-to-user transformation used when mapping
|
||||
;; along parent-child relationship edges in the sprite tree should
|
||||
;; be applied to child sprites.
|
||||
;;
|
||||
(struct touchable (id transformation predicate) #:transparent)
|
||||
(struct touchable-map () #:transparent)
|
||||
|
||||
;; A Children is a (SplayTree Sprite CompiledInstructions), ordered
|
||||
;; first by sprite-z, then sprite-id hash code, then
|
||||
;; sprite-instructions hash-code.
|
||||
;;
|
||||
;; A ChildMap is a (Hash SpriteID Children), mapping sprite-id to the
|
||||
;; children of that sprite.
|
||||
|
||||
;; (compiled-instructions (ChildMap SpriteID -> Void)
|
||||
;; (Listof Touchable)
|
||||
;; (Listof CoordinateMap)
|
||||
;; (Listof Resource)
|
||||
;; (Option TransformationMatrix)
|
||||
;; TransformationMatrix)
|
||||
;; A single compiled sprite. The resources and coordinate-maps aren't
|
||||
;; in any particular order, but the touchables are: the leftmost
|
||||
;; touchable is the first to check; that is, it is the *topmost*
|
||||
;; touchable in this sprite. The child-xform, if present, is the
|
||||
;; transformation needed to map between mouse coordinates and child
|
||||
;; sprite space; if absent, no (render-children) instruction was found
|
||||
;; in this sprite's render code. The final-xform is the final
|
||||
;; transformation after the render instructions have completed.
|
||||
(struct compiled-instructions
|
||||
(render-proc touchables coordinate-maps resources child-xform final-xform))
|
||||
|
||||
(define-namespace-anchor ns-anchor)
|
||||
(define ns (namespace-anchor->namespace ns-anchor))
|
||||
|
||||
(define (compile-instructions instrs)
|
||||
(define touchables '())
|
||||
(define coordinate-maps '())
|
||||
(define resources '())
|
||||
(define child-xform #f)
|
||||
|
||||
(define (instructions->racket-code instrs xform)
|
||||
(define-values (code-rev new-xform)
|
||||
(for/fold [(code-rev '()) (xform xform)] [(instr (in-list instrs))]
|
||||
(define-values (new-code new-xform) (instruction->racket-code instr xform))
|
||||
(values (cons new-code code-rev) new-xform)))
|
||||
(let ((code (reverse code-rev)))
|
||||
(values (lambda (CHILDMAP SELF-ID)
|
||||
(for [(p (in-list code))]
|
||||
(p CHILDMAP SELF-ID)))
|
||||
new-xform)))
|
||||
|
||||
(define (instruction->racket-code instr xform)
|
||||
(match instr
|
||||
[`(rotate ,(? number? deg))
|
||||
(values (lambda (CHILDMAP SELF-ID) (glRotated deg 0 0 -1))
|
||||
(compose-transformation xform (rotation-transformation (- deg))))]
|
||||
[`(scale ,(? number? x) ,(? number? y))
|
||||
(values (lambda (CHILDMAP SELF-ID) (glScaled x y 1))
|
||||
(compose-transformation xform (stretching-transformation x y)))]
|
||||
[`(translate ,(? number? x) ,(? number? y))
|
||||
(values (lambda (CHILDMAP SELF-ID) (glTranslated x y 0))
|
||||
(compose-transformation xform (translation-transformation x y)))]
|
||||
[`(color ,(? color-number? r) ,(? color-number? g) ,(? color-number? b) ,(? color-number? a))
|
||||
(values (lambda (CHILDMAP SELF-ID) (glColor4d r g b a)) xform)]
|
||||
[`(texture ,i)
|
||||
(define entry (image->texture-cache-entry i))
|
||||
(define tex (send entry get-texture))
|
||||
(set! resources (cons entry resources))
|
||||
(values (lambda (CHILDMAP SELF-ID) (draw-gl-face tex)) xform)]
|
||||
[`(texture ,i ,l ,t ,w ,h) #:when (andmap number? (list l t w h))
|
||||
(define entry (image->texture-cache-entry i))
|
||||
(define tex (send entry get-texture))
|
||||
(set! resources (cons entry resources))
|
||||
(values (lambda (CHILDMAP SELF-ID) (draw-gl-face tex l t w h)) xform)]
|
||||
[`(touchable ,id ,predicate)
|
||||
(set! touchables (cons (touchable id xform predicate) touchables))
|
||||
(values void xform)]
|
||||
[`(coordinate-map ,id)
|
||||
(set! coordinate-maps (cons (coordinate-map id xform) coordinate-maps))
|
||||
(values void xform)]
|
||||
[`(push-matrix ,instr ...)
|
||||
(define-values (code _new-xform) (instructions->racket-code instr xform))
|
||||
(values (lambda (CHILDMAP SELF-ID)
|
||||
(glPushMatrix)
|
||||
(code CHILDMAP SELF-ID)
|
||||
(glPopMatrix))
|
||||
xform)]
|
||||
[`(begin ,instr ...)
|
||||
(define-values (code new-xform) (instructions->racket-code instr xform))
|
||||
(values code new-xform)]
|
||||
[`(render-children) ;; we assume that there will only be one of these
|
||||
(set! child-xform xform)
|
||||
(set! touchables (cons (touchable-map) touchables))
|
||||
(values render-sprites! xform)]
|
||||
[other
|
||||
(error 'instruction->racket-code "unknown render instruction: ~v" other)]))
|
||||
|
||||
(define-values (render-proc final-transformation)
|
||||
(instruction->racket-code `(begin ,@instrs) identity-transformation))
|
||||
(compiled-instructions render-proc
|
||||
touchables
|
||||
coordinate-maps
|
||||
resources
|
||||
child-xform
|
||||
final-transformation))
|
||||
|
||||
(define empty-instructions (compile-instructions '()))
|
||||
|
||||
(define (compiled-instructions-dispose! i)
|
||||
(when i
|
||||
(for [(resource (in-list (compiled-instructions-resources i)))]
|
||||
(send resource dispose))))
|
||||
|
||||
(define (color-number? n)
|
||||
(and (number? n)
|
||||
(<= 0.0 n 1.0)))
|
||||
|
||||
(define (image->bitmap i)
|
||||
(cond
|
||||
[(is-a? i bitmap%)
|
||||
i]
|
||||
[(image:image? i)
|
||||
(define w (max 1 (image:image-width i)))
|
||||
(define h (max 1 (image:image-height i)))
|
||||
(define bm (make-object bitmap% w h #f #t))
|
||||
(define dc (send bm make-dc))
|
||||
(send i draw dc
|
||||
0 0
|
||||
0 0
|
||||
w h
|
||||
0 0
|
||||
#f)
|
||||
bm]
|
||||
[(pict:pict? i)
|
||||
(pict:pict->bitmap i)]
|
||||
[else
|
||||
(error 'image->bitmap "unsupported image type ~v" i)]))
|
||||
|
||||
(define (image->texture-cache-entry i)
|
||||
(texture-cache-get i image->bitmap))
|
||||
|
||||
;; (define (lerp a b v) (+ (* v a) (* (- 1 v) b)))
|
||||
|
||||
(define (draw-gl-face texture [left 0] [top 0] [width 1] [height 1])
|
||||
(define bot (+ top height))
|
||||
(define right (+ left width))
|
||||
(send texture bind-texture)
|
||||
(glBegin GL_QUADS)
|
||||
(glNormal3d 0 0 -1)
|
||||
(glTexCoord2d left top)
|
||||
(glVertex3d 0 0 0)
|
||||
(glTexCoord2d right top)
|
||||
(glVertex3d 1 0 0)
|
||||
(glTexCoord2d right bot)
|
||||
(glVertex3d 1 1 0)
|
||||
(glTexCoord2d left bot)
|
||||
(glVertex3d 0 1 0)
|
||||
(glEnd))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define sprite-order
|
||||
(order 'sprite-order
|
||||
sprite?
|
||||
(lambda (a b) (and (equal? (sprite-id a) (sprite-id b))
|
||||
(= (sprite-z a) (sprite-z b))
|
||||
(eq? (sprite-instructions a)
|
||||
(sprite-instructions b))))
|
||||
(lambda (a b) (or (> (sprite-z a) (sprite-z b))
|
||||
(and (= (sprite-z a) (sprite-z b))
|
||||
(let ((a-id-code (equal-hash-code (sprite-id a)))
|
||||
(b-id-code (equal-hash-code (sprite-id b))))
|
||||
(or (< a-id-code b-id-code)
|
||||
(and (= a-id-code b-id-code)
|
||||
(< (eq-hash-code (sprite-instructions a))
|
||||
(eq-hash-code (sprite-instructions b)))))))))))
|
||||
|
||||
(define (remove-sprite! childmap s)
|
||||
(define sprites (hash-ref childmap (sprite-parent-id s) #f))
|
||||
(when sprites
|
||||
(compiled-instructions-dispose! (splay-tree-ref sprites s #f))
|
||||
(splay-tree-remove! sprites s)
|
||||
(when (dict-empty? sprites) (hash-remove! childmap (sprite-parent-id s)))))
|
||||
|
||||
(define (add-sprite! childmap s)
|
||||
(define sprites (hash-ref childmap (sprite-parent-id s)
|
||||
(lambda ()
|
||||
(define ss (make-splay-tree sprite-order))
|
||||
(hash-set! childmap (sprite-parent-id s) ss)
|
||||
ss)))
|
||||
(define instrs `((color 1 1 1 1)
|
||||
(push-matrix ,@(seal-contents (sprite-instructions s)))))
|
||||
(define i (compile-instructions instrs))
|
||||
(splay-tree-set! sprites s i))
|
||||
|
||||
(define (for-each-child-sprite childmap id f)
|
||||
(define children (hash-ref childmap id #f))
|
||||
(let loop ((iter (and children (splay-tree-iterate-first children))))
|
||||
(when iter
|
||||
(define s (splay-tree-iterate-key children iter))
|
||||
(define ci (splay-tree-iterate-value children iter))
|
||||
(f s ci)
|
||||
(loop (splay-tree-iterate-next children iter)))))
|
||||
|
||||
(define (render-sprites! childmap self-id)
|
||||
(for-each-child-sprite childmap self-id
|
||||
(lambda (s ci)
|
||||
((compiled-instructions-render-proc ci) childmap (sprite-id s)))))
|
||||
|
||||
(define (render-scene! prelude childmap postlude)
|
||||
((compiled-instructions-render-proc prelude) childmap #f)
|
||||
(render-sprites! childmap #f)
|
||||
((compiled-instructions-render-proc postlude) childmap #f))
|
||||
|
||||
(define (detect-touch prelude childmap postlude state)
|
||||
(and state
|
||||
(let ()
|
||||
(define x (mouse-state-x state))
|
||||
(define y (mouse-state-y state))
|
||||
(or (detect-touch* childmap #f postlude x y)
|
||||
(detect-sprites-touch childmap #f x y)
|
||||
(detect-touch* childmap #f prelude x y)))))
|
||||
|
||||
(define (detect-sprites-touch childmap self-id x y)
|
||||
(define sprites (hash-ref childmap self-id #f))
|
||||
(let loop ((iter (and sprites (splay-tree-iterate-greatest sprites))))
|
||||
(and iter
|
||||
(let ((s (splay-tree-iterate-key sprites iter)))
|
||||
(define ci (splay-tree-iterate-value sprites iter))
|
||||
(or (detect-touch* childmap (sprite-id s) ci x y)
|
||||
(loop (splay-tree-iterate-greatest/<? sprites s)))))))
|
||||
|
||||
(define (detect-touch* childmap self-id ci x y)
|
||||
(for/or [(t (in-list (compiled-instructions-touchables ci)))]
|
||||
(match t
|
||||
[(touchable id xform contains?)
|
||||
(define-values (ux uy) (untransform-point* xform x y))
|
||||
(and (contains? ux uy) (touching id))]
|
||||
[(touchable-map)
|
||||
(define xform (compiled-instructions-child-xform ci))
|
||||
(define-values (ux uy) (untransform-point* xform x y))
|
||||
(detect-sprites-touch childmap self-id ux uy)])))
|
||||
|
||||
(define (untransform-point* xform x y)
|
||||
(define p (untransform-point xform (make-rectangular x y)))
|
||||
(values (real-part p) (imag-part p)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define dataspace-frame%
|
||||
(class* frame% ()
|
||||
(init ground-ch)
|
||||
(super-new)
|
||||
(define (stop!)
|
||||
(parameterize ((current-ground-event-async-channel ground-ch))
|
||||
(ground-send! (gl-control 'stop))))
|
||||
(define/augment (on-close) (stop!))))
|
||||
|
||||
(define dataspace-canvas%
|
||||
(class canvas%
|
||||
(inherit refresh with-gl-context swap-gl-buffers)
|
||||
|
||||
(init [(eventspace0 eventspace)])
|
||||
(init ground-ch)
|
||||
|
||||
(define eventspace eventspace0)
|
||||
|
||||
(define (! msg)
|
||||
(parameterize ((current-ground-event-async-channel ground-ch))
|
||||
(ground-send! msg)))
|
||||
|
||||
(define (++ assertion)
|
||||
(parameterize ((current-ground-event-async-channel ground-ch))
|
||||
(ground-assert! assertion)))
|
||||
|
||||
(define (-- assertion)
|
||||
(parameterize ((current-ground-event-async-channel ground-ch))
|
||||
(ground-retract! assertion)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define initialised? #f)
|
||||
|
||||
(define near-depth 10) ;; 2.5D
|
||||
(define far-depth 15) ;; 2.5D
|
||||
|
||||
(define prelude empty-instructions)
|
||||
(define childmap (make-hash))
|
||||
(define postlude empty-instructions)
|
||||
|
||||
(define current-window-width #f)
|
||||
(define current-window-height #f)
|
||||
(define current-mouse-state #f)
|
||||
(define current-coordinate-maps (hash))
|
||||
(define current-touching #f)
|
||||
|
||||
(define render-needed? #t)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (mark-dirty!)
|
||||
(when (not render-needed?)
|
||||
(parameterize ((current-eventspace eventspace))
|
||||
(queue-callback (lambda () (refresh)))))
|
||||
(set! render-needed? #t))
|
||||
|
||||
(define/public (replace-scene! new-prelude new-postlude)
|
||||
(with-gl-context
|
||||
(lambda ()
|
||||
(compiled-instructions-dispose! prelude)
|
||||
(compiled-instructions-dispose! postlude)
|
||||
(set! prelude (compile-instructions new-prelude))
|
||||
(set! postlude (compile-instructions new-postlude)))))
|
||||
|
||||
(define/public (alter-sprites! changes)
|
||||
(with-gl-context
|
||||
(lambda ()
|
||||
(for [(change (in-list changes))]
|
||||
(match change
|
||||
[(cons '+ s) (add-sprite! childmap s)]
|
||||
[(cons '- s) (remove-sprite! childmap s)]))
|
||||
(mark-dirty!))))
|
||||
|
||||
(define/public (initialize!)
|
||||
(unless initialised?
|
||||
(with-gl-context
|
||||
(lambda ()
|
||||
(glBlendFunc GL_ONE GL_ONE_MINUS_SRC_ALPHA) ;; premultiplied
|
||||
(glEnable GL_BLEND)
|
||||
(glEnable GL_TEXTURE_2D)
|
||||
(glClearColor 0 0 0 1)
|
||||
(set! initialised? #t)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define/override (on-paint)
|
||||
(initialize!)
|
||||
|
||||
(with-gl-context
|
||||
(lambda ()
|
||||
(update-touching!)
|
||||
(update-coordinate-maps!)
|
||||
(flush-texture-cache!)
|
||||
|
||||
(glClear GL_COLOR_BUFFER_BIT)
|
||||
(glLoadIdentity)
|
||||
(glTranslated 0 0 (- near-depth))
|
||||
(render-scene! prelude childmap postlude)
|
||||
(glFlush)
|
||||
(swap-gl-buffers)
|
||||
|
||||
(set! render-needed? #f))))
|
||||
|
||||
(define/override (on-size width height)
|
||||
(with-gl-context
|
||||
(lambda ()
|
||||
(when (not (and (equal? current-window-width width)
|
||||
(equal? current-window-height height)))
|
||||
(-- (window current-window-width current-window-height))
|
||||
(set! current-window-width width)
|
||||
(set! current-window-height height)
|
||||
(++ (window current-window-width current-window-height)))
|
||||
(glViewport 0 0 width height)
|
||||
(glMatrixMode GL_PROJECTION)
|
||||
(glLoadIdentity)
|
||||
(glOrtho 0 width height 0 0.1 100)
|
||||
(glMatrixMode GL_MODELVIEW)
|
||||
(glLoadIdentity)
|
||||
(mark-dirty!))))
|
||||
|
||||
(define/override (on-char key)
|
||||
(with-gl-context
|
||||
(lambda ()
|
||||
(! (match (send key get-key-code)
|
||||
['release (key-event (send key get-key-release-code) #f (seal key))]
|
||||
[code (key-event code #t (seal key))])))))
|
||||
|
||||
(define/override (on-event mouse)
|
||||
(with-gl-context
|
||||
(lambda ()
|
||||
(define-values (x y)
|
||||
(untransform-point* (compiled-instructions-final-xform prelude)
|
||||
(send mouse get-x)
|
||||
(send mouse get-y)))
|
||||
(define s (mouse-state x
|
||||
y
|
||||
(send mouse get-left-down)
|
||||
(send mouse get-middle-down)
|
||||
(send mouse get-right-down)))
|
||||
(set! current-mouse-state s)
|
||||
(update-touching!)
|
||||
(! (mouse-event (send mouse get-event-type) s)))))
|
||||
|
||||
(define (update-touching!)
|
||||
(define new-touching (detect-touch prelude childmap postlude current-mouse-state))
|
||||
(when (not (equal? current-touching new-touching))
|
||||
(when current-touching (-- current-touching))
|
||||
(set! current-touching new-touching)
|
||||
(when current-touching (++ current-touching))))
|
||||
|
||||
(define (update-coordinate-maps!)
|
||||
(define (update-single-map! cmid cmx)
|
||||
(define existing (hash-ref current-coordinate-maps cmid #f))
|
||||
(define proposed (coordinate-map cmid cmx))
|
||||
(when (not (equal? existing proposed))
|
||||
(set! current-coordinate-maps (hash-set current-coordinate-maps cmid proposed))
|
||||
(-- existing)
|
||||
(++ proposed)))
|
||||
|
||||
(let process-children-of ((id #f) (xform identity-transformation))
|
||||
(for-each-child-sprite childmap id
|
||||
(lambda (s ci)
|
||||
(for [(cm (in-list (compiled-instructions-coordinate-maps ci)))]
|
||||
(match-define (coordinate-map cmid cmx) cm)
|
||||
(update-single-map! cmid (compose-transformation xform cmx)))
|
||||
(define child-xform (compiled-instructions-child-xform ci))
|
||||
(when child-xform
|
||||
(process-children-of (sprite-id s)
|
||||
(compose-transformation xform
|
||||
child-xform)))))))
|
||||
|
||||
(super-new (style '(gl no-autoclear)))))
|
||||
|
||||
(define (spawn-gl-2d-driver #:label [frame-label "syndicate-gl"]
|
||||
#:width [width #f]
|
||||
#:height [height #f])
|
||||
(spawn #:name 'gl-2d/driver
|
||||
(define frame #f) ;; "frame" here refers to *window frame* onscreen, i.e. GUI, not GL
|
||||
(define c #f)
|
||||
|
||||
(parameterize ((current-eventspace (make-eventspace)))
|
||||
(set! frame (new dataspace-frame%
|
||||
[style '(fullscreen-button)]
|
||||
[label frame-label]
|
||||
[width (or width 640)]
|
||||
[height (or height 480)]
|
||||
[ground-ch (current-ground-event-async-channel)]))
|
||||
(set! c (new dataspace-canvas%
|
||||
[parent frame]
|
||||
[eventspace (current-eventspace)]
|
||||
[ground-ch (current-ground-event-async-channel)]))
|
||||
(unless (send (send (send c get-dc) get-gl-context) ok?)
|
||||
(error 'gl-2d "OpenGL context failed to initialize"))
|
||||
(send c focus)
|
||||
(send frame show #t))
|
||||
|
||||
(define start-time (current-inexact-milliseconds))
|
||||
(define frame-counter 0)
|
||||
(define target-frame-rate 60)
|
||||
(define changes '())
|
||||
(define dirty? #f)
|
||||
|
||||
(field [sim-time 0])
|
||||
|
||||
(on (asserted (later-than (+ (sim-time) start-time)))
|
||||
(define per-frame-ms (* (/ target-frame-rate) 1000.0))
|
||||
(send! (frame-event frame-counter (sim-time) per-frame-ms target-frame-rate))
|
||||
(set! frame-counter (+ frame-counter 1))
|
||||
(sim-time (* frame-counter per-frame-ms))
|
||||
(when dirty?
|
||||
(send c alter-sprites! (reverse changes))
|
||||
(set! changes '())
|
||||
(set! dirty? #f)))
|
||||
|
||||
;; TODO: maybe add a means of setting target frame rate?
|
||||
;; (define/public (set-target-frame-rate! r)
|
||||
;; (set! target-frame-rate r))
|
||||
|
||||
(on (asserted (scene $sealed-prelude $sealed-postlude))
|
||||
(send c replace-scene!
|
||||
(seal-contents sealed-prelude)
|
||||
(seal-contents sealed-postlude))
|
||||
(set! dirty? #t))
|
||||
|
||||
(on (retracted ($ s (sprite _ _ _ _)))
|
||||
(set! changes (cons (cons '- s) changes))
|
||||
(set! dirty? #t))
|
||||
(on (asserted ($ s (sprite _ _ _ _)))
|
||||
(set! changes (cons (cons '+ s) changes))
|
||||
(set! dirty? #t))
|
||||
|
||||
(on (message (gl-control 'stop))
|
||||
(send frame show #f)
|
||||
(stop-current-facet))
|
||||
|
||||
(during (gl-control 'fullscreen)
|
||||
(on-start (send frame fullscreen #t))
|
||||
(on-stop (send frame fullscreen #f)))
|
||||
|
||||
))
|
|
@ -0,0 +1,167 @@
|
|||
#lang imperative-syndicate
|
||||
;; SQLite driver
|
||||
|
||||
(provide (struct-out sqlite-db)
|
||||
(struct-out sqlite-db-ready)
|
||||
(struct-out sqlite-row)
|
||||
(struct-out sqlite-exec)
|
||||
(struct-out sqlite-create-table)
|
||||
(struct-out sqlite-insert)
|
||||
(struct-out sqlite-delete)
|
||||
sqlite-exec!
|
||||
sqlite-create-table!
|
||||
sqlite-insert!
|
||||
sqlite-delete!
|
||||
(struct-out discard) ;; from imperative-syndicate/pattern
|
||||
)
|
||||
|
||||
(require db)
|
||||
(require racket/set)
|
||||
(require racket/string)
|
||||
(require imperative-syndicate/pattern)
|
||||
|
||||
(define-logger syndicate/sqlite)
|
||||
|
||||
(struct sqlite-db (path) #:prefab)
|
||||
|
||||
(assertion-struct sqlite-db-ready (db))
|
||||
|
||||
(assertion-struct sqlite-row (db table columns))
|
||||
|
||||
(message-struct sqlite-exec (db template arguments id))
|
||||
(message-struct sqlite-status (id value))
|
||||
|
||||
(message-struct sqlite-create-table (db table column-names id))
|
||||
(message-struct sqlite-insert (db table columns id))
|
||||
(message-struct sqlite-delete (db table columns id))
|
||||
|
||||
(define (sqlite-call db msg-proc)
|
||||
(define id (gensym 'exec))
|
||||
(react/suspend (k)
|
||||
(on (message (sqlite-status id $v))
|
||||
(if (exn? v) (raise v) (k v)))
|
||||
(on (asserted (sqlite-db-ready db))
|
||||
(send! (msg-proc id)))))
|
||||
|
||||
(define (sqlite-exec! db template . arguments)
|
||||
(sqlite-call db (lambda (id) (sqlite-exec db template arguments id))))
|
||||
|
||||
(define (sqlite-create-table! db table . column-names)
|
||||
(sqlite-call db (lambda (id) (sqlite-create-table db table column-names id))))
|
||||
|
||||
(define (sqlite-insert! db table . columns)
|
||||
(sqlite-call db (lambda (id) (sqlite-insert db table columns id))))
|
||||
|
||||
(define (sqlite-delete! db table . columns)
|
||||
(sqlite-call db (lambda (id) (sqlite-delete db table columns id))))
|
||||
|
||||
(define (strip-capture p)
|
||||
(if (capture? p)
|
||||
(strip-capture (capture-detail p))
|
||||
p))
|
||||
|
||||
(spawn #:name 'drivers/sqlite
|
||||
(during/spawn ($ db (sqlite-db $path))
|
||||
#:name (list 'drivers/sqlite path)
|
||||
(define handle (sqlite3-connect #:database path #:mode 'create)) ;; TODO: #:use-place ?
|
||||
(on-stop (disconnect handle))
|
||||
|
||||
(assert (sqlite-db-ready db))
|
||||
|
||||
(on (message (sqlite-exec db $template $arguments $id))
|
||||
(with-handlers [(exn:fail? (lambda (e) (send! (sqlite-status id e))))]
|
||||
(log-syndicate/sqlite-debug "~s ~s" template arguments)
|
||||
(send! (sqlite-status id (apply query-exec handle template arguments)))))
|
||||
|
||||
(field [known-tables (set)])
|
||||
|
||||
(on (message (sqlite-create-table db $table $column-names $id))
|
||||
(with-handlers [(exn:fail? (lambda (e) (send! (sqlite-status id e))))]
|
||||
(define template
|
||||
(format "create table ~a (~a)" table (string-join column-names ", ")))
|
||||
(define arguments '())
|
||||
(table-facet handle known-tables db table column-names)
|
||||
(log-syndicate/sqlite-debug "~s ~s" template arguments)
|
||||
(send! (sqlite-status id (apply query-exec handle template arguments)))))
|
||||
|
||||
(on-start
|
||||
(for [(table (query-list handle
|
||||
"select distinct name from sqlite_master where type='table'"))]
|
||||
(define column-names
|
||||
(map (lambda (r) (vector-ref r 1))
|
||||
(query-rows handle (string-append "pragma table_info(" table ")"))))
|
||||
(table-facet handle known-tables db table column-names)))))
|
||||
|
||||
(define (table-facet handle known-tables db table column-names)
|
||||
(when (not (set-member? (known-tables) table))
|
||||
(known-tables (set-add (known-tables) table))
|
||||
(react
|
||||
(on (message ($ m (sqlite-insert db table $columns $id)))
|
||||
(with-handlers [(exn:fail? (lambda (e) (send! (sqlite-status id e))))]
|
||||
(define template (format "insert into ~a values (~a)"
|
||||
table
|
||||
(string-join (for/list [(i (in-naturals 1)) (c columns)]
|
||||
(format "$~a" i))
|
||||
", ")))
|
||||
(define arguments columns)
|
||||
(log-syndicate/sqlite-debug "~s ~s" template arguments)
|
||||
(send! (sqlite-status id (apply query-exec handle template arguments)))))
|
||||
|
||||
(on (message ($ m (sqlite-delete db table $columns $id)))
|
||||
(with-handlers [(exn:fail? (lambda (e) (send! (sqlite-status id e))))]
|
||||
(define filters
|
||||
(for/list [(n column-names) (c columns) #:when (not (discard? c))]
|
||||
(list n c)))
|
||||
(define template
|
||||
(format "delete from ~a~a"
|
||||
table
|
||||
(if (null? filters)
|
||||
""
|
||||
(format " where ~a"
|
||||
(string-join (for/list [(i (in-naturals 1)) (f filters)]
|
||||
(format "~a = $~a" (car f) i))
|
||||
" and ")))))
|
||||
(define arguments (map cadr filters))
|
||||
(log-syndicate/sqlite-debug "~s ~s" template arguments)
|
||||
(send! (sqlite-status id (apply query-exec handle template arguments)))))
|
||||
|
||||
(define (row-facet columns)
|
||||
(react (assert (sqlite-row db table columns))
|
||||
(on (message (sqlite-delete db table $cs _))
|
||||
(when (for/and [(c1 columns) (c2 cs)] (or (discard? c2) (equal? c1 c2)))
|
||||
(stop-current-facet)))))
|
||||
|
||||
(during/spawn (observe (sqlite-row db table $column-patterns0))
|
||||
(define column-patterns
|
||||
(let ((ps (strip-capture column-patterns0)))
|
||||
(if (discard? ps)
|
||||
(for/list [(n column-names)] (discard))
|
||||
ps)))
|
||||
(define filters
|
||||
(for/list [(n column-names)
|
||||
(p (map strip-capture column-patterns))
|
||||
#:when (not (discard? p))]
|
||||
(list n p)))
|
||||
|
||||
(define initial-rows
|
||||
(let ()
|
||||
(define template
|
||||
(format "select distinct * from ~a~a"
|
||||
table
|
||||
(if (null? filters)
|
||||
""
|
||||
(format " where ~a"
|
||||
(string-join (for/list [(i (in-naturals 1)) (f filters)]
|
||||
(format "~a = $~a" (car f) i))
|
||||
" and ")))))
|
||||
(define arguments (map cadr filters))
|
||||
(log-syndicate/sqlite-debug "~s ~s" template arguments)
|
||||
(map vector->list (apply query-rows handle template (map cadr filters)))))
|
||||
|
||||
(on-start (for-each row-facet initial-rows))
|
||||
(on (message (sqlite-insert db table $columns _))
|
||||
(when (for/and [(n column-names) (c columns)]
|
||||
(match (assoc n filters)
|
||||
[(list _ v) (equal? c v)]
|
||||
[#f #t]))
|
||||
(row-facet columns)))))))
|
|
@ -0,0 +1,206 @@
|
|||
#lang imperative-syndicate
|
||||
;; TCP/IP driver interface.
|
||||
;;
|
||||
;; TODO: This protocol is overly simplified.
|
||||
;; a) no facility for separate shutdown of inbound/outbound streams
|
||||
|
||||
(provide (struct-out tcp-connection)
|
||||
(struct-out tcp-connection-peer)
|
||||
(struct-out tcp-accepted)
|
||||
(struct-out tcp-rejected)
|
||||
(struct-out tcp-out)
|
||||
(struct-out tcp-in)
|
||||
(struct-out tcp-in-line)
|
||||
|
||||
(struct-out tcp-address)
|
||||
(struct-out tcp-listener)
|
||||
|
||||
(all-from-out imperative-syndicate/protocol/credit))
|
||||
|
||||
(define-logger syndicate/tcp)
|
||||
|
||||
(require racket/exn)
|
||||
(require (prefix-in tcp: racket/tcp))
|
||||
(require (only-in racket/port read-bytes-avail!-evt read-bytes-line-evt))
|
||||
|
||||
(require racket/unit)
|
||||
(require net/tcp-sig)
|
||||
(require net/tcp-unit)
|
||||
|
||||
(require syndicate/support/bytes)
|
||||
|
||||
(require imperative-syndicate/protocol/credit)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Protocol messages
|
||||
|
||||
(assertion-struct tcp-connection (id spec))
|
||||
(assertion-struct tcp-connection-peer (id addr))
|
||||
(assertion-struct tcp-accepted (id))
|
||||
(assertion-struct tcp-rejected (id exn))
|
||||
(message-struct tcp-out (id bytes))
|
||||
(message-struct tcp-in (id bytes))
|
||||
(message-struct tcp-in-line (id bytes))
|
||||
|
||||
(assertion-struct tcp-address (host port))
|
||||
(assertion-struct tcp-listener (port))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Ground-level communication messages
|
||||
|
||||
(message-struct raw-tcp-accepted (local-addr remote-addr cin cout))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Driver
|
||||
|
||||
(spawn #:name 'drivers/tcp
|
||||
|
||||
(during/spawn (observe (tcp-connection _ (tcp-listener $port)))
|
||||
#:name (list 'drivers/tcp 'listener port)
|
||||
(run-listener port))
|
||||
|
||||
(during/spawn (tcp-connection $id (tcp-address $host $port))
|
||||
#:name (list 'drivers/tcp 'outbound id host port)
|
||||
(match (with-handlers ([exn:fail? (lambda (e) (list e))])
|
||||
(define-values (cin cout) (tcp:tcp-connect host port))
|
||||
(list cin cout))
|
||||
[(list e) (assert (tcp-rejected id e))]
|
||||
[(list cin cout)
|
||||
(assert (tcp-accepted id))
|
||||
(run-connection id cin cout)])))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Listener
|
||||
|
||||
(define (run-listener port)
|
||||
(define server-addr (tcp-listener port))
|
||||
(define listener (tcp:tcp-listen port 128 #t))
|
||||
(define control-ch (make-channel))
|
||||
|
||||
(thread (lambda ()
|
||||
(let loop ((credit 1)) ;; NB. not zero initially!
|
||||
(sync (handle-evt control-ch
|
||||
(match-lambda
|
||||
[(list 'credit 'reset) (loop 0)]
|
||||
[(list 'credit (? number? amount)) (loop (+ credit amount))]
|
||||
['quit (void)]))
|
||||
(if (zero? credit)
|
||||
never-evt
|
||||
(handle-evt (tcp:tcp-accept-evt listener)
|
||||
(lambda (cin+cout)
|
||||
(match-define (list cin cout) cin+cout)
|
||||
(define-values
|
||||
(local-hostname local-port remote-hostname remote-port)
|
||||
(tcp:tcp-addresses cin #t))
|
||||
(ground-send!
|
||||
(inbound
|
||||
(raw-tcp-accepted server-addr
|
||||
(tcp-address remote-hostname remote-port)
|
||||
cin
|
||||
cout)))
|
||||
(loop (- credit 1)))))))
|
||||
(tcp:tcp-close listener)
|
||||
(signal-background-activity! -1)))
|
||||
(signal-background-activity! +1)
|
||||
|
||||
(on-stop (channel-put control-ch 'quit))
|
||||
|
||||
(on (message (credit* (list server-addr) $amount))
|
||||
(channel-put control-ch (list 'credit amount)))
|
||||
|
||||
(on (message (inbound (raw-tcp-accepted server-addr $remote-addr $cin $cout)))
|
||||
(define id (seal (list port remote-addr)))
|
||||
(spawn #:name (list 'drivers/tcp 'inbound id)
|
||||
(assert (tcp-connection id server-addr))
|
||||
(assert (tcp-connection-peer id remote-addr))
|
||||
(run-connection id cin cout)
|
||||
(stop-when (asserted (tcp-rejected id _)))
|
||||
(stop-when (retracted (tcp-accepted id))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Connection
|
||||
|
||||
(define (run-connection id cin cout)
|
||||
(define control-ch (make-channel))
|
||||
(thread (lambda () (connection-thread control-ch id cin)))
|
||||
(signal-background-activity! +1)
|
||||
|
||||
(define (shutdown-connection!)
|
||||
(when control-ch
|
||||
(channel-put control-ch 'quit)
|
||||
(set! control-ch #f))
|
||||
(when cout
|
||||
(close-output-port cout)
|
||||
(set! cout #f)))
|
||||
|
||||
(on-stop (shutdown-connection!))
|
||||
|
||||
(on (asserted (observe (credit* (list tcp-out id) _)))
|
||||
(send! (credit tcp-out id +inf.0)))
|
||||
|
||||
(on (message (credit* (list tcp-in id) $amount))
|
||||
(when control-ch (channel-put control-ch (list 'credit amount))))
|
||||
|
||||
(field [mode 'bytes])
|
||||
(begin/dataflow (when control-ch (channel-put control-ch (mode))))
|
||||
|
||||
(on (message (inbound (tcp-in id $eof-or-bs)))
|
||||
(if (eof-object? eof-or-bs)
|
||||
(stop-current-facet)
|
||||
(send! (match (mode)
|
||||
['bytes (tcp-in id eof-or-bs)]
|
||||
['lines (tcp-in-line id eof-or-bs)]))))
|
||||
|
||||
(during (observe (tcp-in-line id _))
|
||||
(on-start (mode 'lines))
|
||||
(on-stop (mode 'bytes)))
|
||||
|
||||
(define-syntax-rule (trap-exns body ...)
|
||||
(with-handlers ([(lambda (e) (not (exn:break? e)))
|
||||
(lambda (e)
|
||||
(shutdown-connection!)
|
||||
(raise e))])
|
||||
body ...))
|
||||
|
||||
(on (message (tcp-out id $bs))
|
||||
(trap-exns
|
||||
(if (string? bs)
|
||||
(write-string bs cout)
|
||||
(write-bytes bs cout))
|
||||
(flush-output cout))))
|
||||
|
||||
(define (connection-thread control-ch id cin)
|
||||
(let loop ((credit 0) (mode 'bytes))
|
||||
(sync (handle-evt control-ch
|
||||
(match-lambda
|
||||
[(list 'credit 'reset) (loop 0 mode)]
|
||||
[(list 'credit (? number? amount)) (loop (+ credit amount) mode)]
|
||||
['lines (loop credit 'lines)]
|
||||
['bytes (loop credit 'bytes)]
|
||||
['quit (void)]))
|
||||
(if (zero? credit)
|
||||
never-evt
|
||||
(handle-evt (match mode
|
||||
['bytes (read-bytes-avail-evt (inexact->exact (truncate (min credit 32768))) cin)]
|
||||
['lines (read-bytes-line-evt cin 'any)])
|
||||
(lambda (eof-or-bs)
|
||||
(ground-send! (inbound (tcp-in id eof-or-bs)))
|
||||
(loop (if (eof-object? eof-or-bs)
|
||||
0
|
||||
(- credit (match mode
|
||||
['bytes (bytes-length eof-or-bs)]
|
||||
['lines 1])))
|
||||
mode))))))
|
||||
(close-input-port cin)
|
||||
(signal-background-activity! -1))
|
||||
|
||||
(define (read-bytes-avail-evt len input-port)
|
||||
(guard-evt
|
||||
(lambda ()
|
||||
(let ([bstr (make-bytes len)])
|
||||
(handle-evt
|
||||
(read-bytes-avail!-evt bstr input-port)
|
||||
(lambda (v)
|
||||
(if (number? v)
|
||||
(if (= v len) bstr (subbytes bstr 0 v))
|
||||
v)))))))
|
|
@ -0,0 +1,116 @@
|
|||
#lang imperative-syndicate
|
||||
;; Timer driver.
|
||||
|
||||
;; Uses mutable state internally, but because the scope of the
|
||||
;; mutation is limited to each timer process alone, it's easy to show
|
||||
;; correct linear use of the various pointers.
|
||||
|
||||
(provide (struct-out set-timer)
|
||||
(struct-out timer-expired)
|
||||
(struct-out later-than)
|
||||
on-timeout
|
||||
stop-when-timeout
|
||||
sleep)
|
||||
|
||||
(define-logger syndicate/drivers/timer)
|
||||
|
||||
(require racket/set)
|
||||
(require data/heap)
|
||||
|
||||
(message-struct set-timer (label msecs kind))
|
||||
(message-struct timer-expired (label msecs))
|
||||
|
||||
(assertion-struct later-than (msecs))
|
||||
|
||||
(spawn #:name 'drivers/timer
|
||||
(define control-ch (make-channel))
|
||||
|
||||
(thread (lambda ()
|
||||
(struct pending-timer (deadline label) #:transparent)
|
||||
|
||||
(define heap
|
||||
(make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1)
|
||||
(pending-timer-deadline t2)))))
|
||||
|
||||
(define timers (make-hash))
|
||||
|
||||
(define (next-timer)
|
||||
(and (positive? (heap-count heap))
|
||||
(heap-min heap)))
|
||||
|
||||
(define (fire-timers! now)
|
||||
(define count-fired 0)
|
||||
(let loop ()
|
||||
(when (positive? (heap-count heap))
|
||||
(let ((m (heap-min heap)))
|
||||
(when (<= (pending-timer-deadline m) now)
|
||||
(define label (pending-timer-label m))
|
||||
(heap-remove-min! heap)
|
||||
(hash-remove! timers label)
|
||||
(log-syndicate/drivers/timer-debug "expired timer ~a" label)
|
||||
(ground-send! (timer-expired label now))
|
||||
(set! count-fired (+ count-fired 1))
|
||||
(loop)))))
|
||||
(signal-background-activity! (- count-fired)))
|
||||
|
||||
(define (clear-timer! label)
|
||||
(match (hash-ref timers label #f)
|
||||
[#f (void)]
|
||||
[deadline
|
||||
(heap-remove! heap (pending-timer deadline label))
|
||||
(hash-remove! timers label)
|
||||
(signal-background-activity! -1)]))
|
||||
|
||||
(define (install-timer! label deadline)
|
||||
(clear-timer! label)
|
||||
(heap-add! heap (pending-timer deadline label))
|
||||
(hash-set! timers label deadline)
|
||||
(signal-background-activity! +1))
|
||||
|
||||
(let loop ()
|
||||
(sync (match (next-timer)
|
||||
[#f never-evt]
|
||||
[t (handle-evt (alarm-evt (pending-timer-deadline t))
|
||||
(lambda (_dummy)
|
||||
(define now (current-inexact-milliseconds))
|
||||
(fire-timers! now)
|
||||
(loop)))])
|
||||
(handle-evt control-ch
|
||||
(match-lambda
|
||||
[(set-timer label _ 'clear)
|
||||
(clear-timer! label)
|
||||
(loop)]
|
||||
[(set-timer label msecs 'relative)
|
||||
(define deadline (+ (current-inexact-milliseconds) msecs))
|
||||
(install-timer! label deadline)
|
||||
(loop)]
|
||||
[(set-timer label deadline 'absolute)
|
||||
(install-timer! label deadline)
|
||||
(loop)]))))))
|
||||
|
||||
(on (message ($ instruction (set-timer _ _ _)))
|
||||
(log-syndicate/drivers/timer-debug "received instruction ~a" instruction)
|
||||
(channel-put control-ch instruction))
|
||||
|
||||
(during (observe (later-than $msecs))
|
||||
(log-syndicate/drivers/timer-debug "observing (later-than ~a) at ~a"
|
||||
msecs
|
||||
(current-inexact-milliseconds))
|
||||
(define timer-id (gensym 'timestate))
|
||||
(on-start (send! (set-timer timer-id msecs 'absolute)))
|
||||
(on-stop (send! (set-timer timer-id msecs 'clear)))
|
||||
(on (message (timer-expired timer-id _))
|
||||
(react (assert (later-than msecs))))))
|
||||
|
||||
(define-syntax-rule (on-timeout relative-msecs body ...)
|
||||
(let ((timer-id (gensym 'timeout)))
|
||||
(on-start (send! (set-timer timer-id relative-msecs 'relative)))
|
||||
(on (message (timer-expired timer-id _)) body ...)))
|
||||
|
||||
(define-syntax-rule (stop-when-timeout relative-msecs body ...)
|
||||
(on-timeout relative-msecs (stop-current-facet body ...)))
|
||||
|
||||
(define (sleep sec)
|
||||
(define timer-id (gensym 'sleep))
|
||||
(until (message (timer-expired timer-id _))
|
||||
(on-start (send! (set-timer timer-id (* sec 1000.0) 'relative)))))
|
|
@ -0,0 +1,98 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide (struct-out udp-remote-address)
|
||||
(struct-out udp-handle)
|
||||
(struct-out udp-listener)
|
||||
(struct-out udp-multicast-group-member)
|
||||
(struct-out udp-multicast-loopback)
|
||||
udp-address?
|
||||
udp-local-address?
|
||||
(struct-out udp-packet))
|
||||
|
||||
(require (prefix-in udp: racket/udp))
|
||||
|
||||
;; A UdpAddress is one of
|
||||
;; -- a (udp-remote-address String Uint16), representing a remote socket
|
||||
;; -- a (udp-handle Any), representing a local socket on a kernel-assigned port
|
||||
;; -- a (udp-listener Uint16), representing a local socket on a user-assigned port
|
||||
;; Note that udp-handle-ids must be chosen carefully: they are scoped
|
||||
;; to the local dataspace, i.e. shared between processes in that
|
||||
;; dataspace, so processes must make sure not to accidentally clash in
|
||||
;; handle ID selection.
|
||||
(struct udp-remote-address (host port) #:prefab)
|
||||
(struct udp-handle (id) #:prefab)
|
||||
(struct udp-listener (port) #:prefab)
|
||||
|
||||
(define (udp-address? x)
|
||||
(or (udp-remote-address? x)
|
||||
(udp-local-address? x)))
|
||||
|
||||
(define (udp-local-address? x)
|
||||
(or (udp-handle? x)
|
||||
(udp-listener? x)))
|
||||
|
||||
;; A UdpMembership is a (udp-multicast-group-member UdpLocalAddress String String),
|
||||
;; where the latter two arguments correspond to the last two arguments
|
||||
;; of `udp-multicast-join-group!`.
|
||||
(assertion-struct udp-multicast-group-member (local-address group-address interface))
|
||||
|
||||
;; A UdpLoopback is a (udp-multicast-loopback UdpLocalAddress Boolean).
|
||||
(assertion-struct udp-multicast-loopback (local-address enabled?))
|
||||
|
||||
;; A UdpPacket is a (udp-packet UdpAddress UdpAddress Bytes), and
|
||||
;; represents a packet appearing on our local "subnet" of the full UDP
|
||||
;; network, complete with source, destination and contents.
|
||||
(message-struct udp-packet (source destination body))
|
||||
|
||||
(spawn #:name 'udp-driver
|
||||
(during/spawn (observe ($ local-addr (udp-listener _)))
|
||||
#:name local-addr
|
||||
(udp-main local-addr))
|
||||
(during/spawn (observe ($ local-addr (udp-handle _)))
|
||||
#:name local-addr
|
||||
(udp-main local-addr)))
|
||||
|
||||
;; UdpLocalAddress -> Void
|
||||
(define (udp-main local-addr)
|
||||
(define socket (udp:udp-open-socket #f #f))
|
||||
|
||||
(match local-addr
|
||||
[(udp-listener port) (udp:udp-bind! socket #f port #t)]
|
||||
[(udp-handle _) (udp:udp-bind! socket #f 0)]) ;; kernel-allocated port number
|
||||
|
||||
(define control-ch (make-channel))
|
||||
(thread (lambda () (udp-receiver-thread local-addr socket control-ch)))
|
||||
(signal-background-activity! +1)
|
||||
(on-stop (channel-put control-ch 'quit))
|
||||
|
||||
(assert local-addr)
|
||||
(stop-when (retracted (observe local-addr)))
|
||||
|
||||
(during (udp-multicast-group-member local-addr $group $interface)
|
||||
(on-start (udp:udp-multicast-join-group! socket group interface))
|
||||
(on-stop (udp:udp-multicast-leave-group! socket group interface)))
|
||||
|
||||
(on (asserted (udp-multicast-loopback local-addr $enabled))
|
||||
(udp:udp-multicast-set-loopback! socket enabled))
|
||||
|
||||
(on (message (inbound ($ p (udp-packet _ local-addr _))))
|
||||
(send! p))
|
||||
|
||||
(on (message (udp-packet local-addr (udp-remote-address $h $p) $body))
|
||||
(udp:udp-send-to* socket h p body)))
|
||||
|
||||
;; UdpLocalAddress UdpSocket Channel -> Void
|
||||
(define (udp-receiver-thread local-addr socket control-ch)
|
||||
(define buffer (make-bytes 65536))
|
||||
(let loop ()
|
||||
(sync (handle-evt control-ch (match-lambda ['quit (void)]))
|
||||
(handle-evt (udp:udp-receive!-evt socket buffer)
|
||||
(lambda (receive-results)
|
||||
(match-define (list len source-hostname source-port) receive-results)
|
||||
(ground-send!
|
||||
(udp-packet (udp-remote-address source-hostname source-port)
|
||||
local-addr
|
||||
(subbytes buffer 0 len)))
|
||||
(loop)))))
|
||||
(udp:udp-close socket)
|
||||
(signal-background-activity! -1))
|
|
@ -0,0 +1,348 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide (struct-out http-server)
|
||||
(struct-out http-resource)
|
||||
(struct-out http-request)
|
||||
(struct-out http-accepted)
|
||||
(except-out (struct-out http-response) http-response)
|
||||
(rename-out [make-http-response http-response]
|
||||
[http-response <http-response>])
|
||||
(except-out (struct-out http-response-websocket) http-response-websocket)
|
||||
(rename-out [make-http-response-websocket http-response-websocket]
|
||||
[http-response-websocket <http-response-websocket>])
|
||||
(struct-out http-request-peer-details)
|
||||
(struct-out http-request-cookie)
|
||||
(struct-out http-response-chunk)
|
||||
(struct-out websocket-out)
|
||||
(struct-out websocket-in)
|
||||
|
||||
xexpr->bytes/utf-8)
|
||||
|
||||
(require racket/async-channel)
|
||||
(require racket/exn)
|
||||
(require (only-in racket/list flatten))
|
||||
(require (only-in racket/string string-append*))
|
||||
(require (only-in racket/bytes bytes-append*))
|
||||
(require racket/tcp)
|
||||
|
||||
(require net/rfc6455)
|
||||
(require net/rfc6455/conn-api)
|
||||
(require net/rfc6455/dispatcher)
|
||||
(require net/url)
|
||||
|
||||
(require struct-defaults)
|
||||
|
||||
(require web-server/http/bindings)
|
||||
(require web-server/http/cookie)
|
||||
(require web-server/http/cookie-parse)
|
||||
(require web-server/http/request)
|
||||
(require web-server/http/request-structs)
|
||||
(require web-server/http/response)
|
||||
(require web-server/http/response-structs)
|
||||
(require web-server/private/connection-manager)
|
||||
(require (only-in web-server/private/util lowercase-symbol!))
|
||||
(require web-server/dispatchers/dispatch)
|
||||
|
||||
(require xml)
|
||||
|
||||
(module+ test (require rackunit))
|
||||
|
||||
(define-logger syndicate/drivers/web)
|
||||
|
||||
(define (url-path->resource-path up)
|
||||
(define elements (for/list [(p (in-list up))]
|
||||
(match-define (path/param path-element params) p)
|
||||
(list* path-element params)))
|
||||
(foldr (lambda (e acc) (append e (list acc))) '() elements))
|
||||
|
||||
(define (build-headers hs)
|
||||
(for/list ((h (in-list hs)))
|
||||
(header (string->bytes/utf-8 (symbol->string (car h)))
|
||||
(string->bytes/utf-8 (cdr h)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; API/Protocol
|
||||
|
||||
(assertion-struct http-server (host port ssl?))
|
||||
(assertion-struct http-resource (server path))
|
||||
|
||||
(assertion-struct http-request (id method resource headers query body))
|
||||
(assertion-struct http-accepted (id))
|
||||
|
||||
(assertion-struct http-response (id code message last-modified-seconds mime-type headers detail))
|
||||
;; ^ detail = (U Bytes 'chunked)
|
||||
(assertion-struct http-response-websocket (id headers))
|
||||
|
||||
(assertion-struct http-request-peer-details (id local-ip local-port remote-ip remote-port))
|
||||
(assertion-struct http-request-cookie (id name value domain path))
|
||||
|
||||
(message-struct http-response-chunk (id bytes))
|
||||
|
||||
(message-struct websocket-out (id body))
|
||||
(message-struct websocket-in (id body))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Ground messages
|
||||
|
||||
(message-struct web-raw-request (id port connection addresses req control-ch))
|
||||
(message-struct web-raw-client-conn (id connection))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define web-server-max-waiting (make-parameter 511)) ;; sockets
|
||||
(define web-server-connection-manager (make-parameter #f))
|
||||
(define web-server-initial-connection-timeout (make-parameter 30)) ;; seconds
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(spawn
|
||||
#:name 'http-server-factory
|
||||
|
||||
(during (observe (http-request _ _ (http-resource $server _) _ _ _))
|
||||
(assert server))
|
||||
|
||||
(during/spawn (http-server _ $port _)
|
||||
#:name (list 'http-listener port)
|
||||
|
||||
(define ssl? #f)
|
||||
(on (asserted (http-server _ port #t))
|
||||
(error 'http-listener "SSL service not yet implemented")) ;; TODO
|
||||
|
||||
(define cm (or (web-server-connection-manager) (start-connection-manager)))
|
||||
|
||||
(define listener (tcp-listen port (web-server-max-waiting) #t))
|
||||
(define listener-control (make-channel))
|
||||
(thread (lambda ()
|
||||
(let loop ()
|
||||
(sync (handle-evt (tcp-accept-evt listener)
|
||||
(lambda (ports)
|
||||
(connection-thread port cm ports)
|
||||
(loop)))
|
||||
(handle-evt listener-control
|
||||
(match-lambda
|
||||
[(list 'quit k-ch)
|
||||
(tcp-close listener)
|
||||
(signal-background-activity! -1)
|
||||
(channel-put k-ch (void))]))))))
|
||||
(signal-background-activity! +1)
|
||||
|
||||
(on-start (log-syndicate/drivers/web-debug "Starting listener on port ~v" port))
|
||||
(on-stop (define k-ch (make-channel))
|
||||
(log-syndicate/drivers/web-debug "Stopping listener on port ~v" port)
|
||||
(channel-put listener-control (list 'quit k-ch))
|
||||
(channel-get k-ch)
|
||||
(log-syndicate/drivers/web-debug "Stopped listener on port ~v" port))
|
||||
|
||||
(on (message (inbound (web-raw-request $id port $conn $addresses $lowlevel-req $control-ch)))
|
||||
(spawn #:name (list 'http-request id)
|
||||
(define root-facet (current-facet))
|
||||
|
||||
(define method
|
||||
(string->symbol (string-downcase (bytes->string/latin-1 (request-method lowlevel-req)))))
|
||||
(define resource (http-resource (req->http-server lowlevel-req port ssl?)
|
||||
(url-path->resource-path
|
||||
(url-path (request-uri lowlevel-req)))))
|
||||
|
||||
(assert (http-request id
|
||||
method
|
||||
resource
|
||||
(request-headers lowlevel-req)
|
||||
(url-query (request-uri lowlevel-req))
|
||||
(request-post-data/raw lowlevel-req)))
|
||||
|
||||
(for [(c (request-cookies lowlevel-req))]
|
||||
(match-define (client-cookie n v d p) c)
|
||||
(assert (http-request-cookie id n v d p)))
|
||||
|
||||
(match-let ([(list Lip Lport Rip Rport) addresses])
|
||||
(assert (http-request-peer-details id Lip Lport Rip Rport)))
|
||||
|
||||
(define (respond! resp)
|
||||
(match-define (http-response _ c m lms mime-type headers body) resp)
|
||||
(define hs (build-headers headers))
|
||||
(channel-put control-ch
|
||||
(list 'response
|
||||
(response/full c m lms mime-type hs (flatten body)))))
|
||||
|
||||
(define (respond/chunked! resp)
|
||||
(match-define (http-response _ c m lms mime-type headers _) resp)
|
||||
(define hs (build-headers headers))
|
||||
(define stream-ch (make-async-channel))
|
||||
(define (output-writer op)
|
||||
(match (async-channel-get stream-ch)
|
||||
[#f (void)]
|
||||
[bss (for [(bs bss)] (write-bytes bs op))
|
||||
;; (flush-output op) ;; seemingly does nothing. TODO
|
||||
(output-writer op)]))
|
||||
(react (stop-when (retracted resp))
|
||||
(on-stop (async-channel-put stream-ch #f)
|
||||
(stop-facet root-facet))
|
||||
(on (message (http-response-chunk id $chunk))
|
||||
(async-channel-put stream-ch (flatten chunk)))
|
||||
(on-start (channel-put control-ch
|
||||
(list 'response
|
||||
(response c m lms mime-type hs output-writer))))))
|
||||
|
||||
(define (respond/websocket! headers)
|
||||
(define ws-ch (make-channel))
|
||||
(define hs (build-headers headers))
|
||||
(react (stop-when (retracted (http-response-websocket id headers)))
|
||||
(on-start (channel-put control-ch (list 'websocket hs ws-ch)))
|
||||
(on-stop (channel-put ws-ch 'quit)
|
||||
(stop-facet root-facet))
|
||||
(on (message (websocket-out id $body))
|
||||
(define flat (flatten body))
|
||||
(define payload (cond [(null? flat) ""]
|
||||
[(bytes? (car flat)) (bytes-append* flat)]
|
||||
[(string? (car flat)) (string-append* flat)]
|
||||
[else (error 'respond/websocket!
|
||||
"Bad payload: mixed content: ~v"
|
||||
flat)]))
|
||||
(channel-put ws-ch (list 'send payload)))
|
||||
(on (message (inbound (websocket-in id $body)))
|
||||
(if (eof-object? body)
|
||||
(stop-current-facet)
|
||||
(send! (websocket-in id body))))))
|
||||
|
||||
(field [respondent-exists? #f])
|
||||
(on-start (for [(i 3)] (flush!)) ;; TODO: UGHHHH
|
||||
(when (not (respondent-exists?))
|
||||
(stop-facet root-facet
|
||||
(respond! (make-http-response #:code 404
|
||||
#:message #"Not found"
|
||||
id
|
||||
(xexpr->bytes/utf-8
|
||||
`(html (h1 "Not found"))))))))
|
||||
|
||||
(on (asserted (http-accepted id))
|
||||
(respondent-exists? #t)
|
||||
(react
|
||||
(stop-when (retracted (http-accepted id))
|
||||
(stop-facet root-facet
|
||||
(respond! (make-http-response #:code 500
|
||||
#:message #"Server error"
|
||||
id
|
||||
(xexpr->bytes/utf-8
|
||||
`(html (h1 "Server error")))))))
|
||||
(stop-when (asserted ($ resp (http-response id _ _ _ _ _ $detail)))
|
||||
(match detail
|
||||
['chunked (respond/chunked! resp)]
|
||||
[_ (stop-facet root-facet (respond! resp))]))
|
||||
(stop-when (asserted (http-response-websocket id $headers))
|
||||
(respond/websocket! headers))))))))
|
||||
|
||||
(define (req->http-server r port ssl?)
|
||||
(match (assq 'host (request-headers r))
|
||||
[#f
|
||||
(http-server #f port ssl?)]
|
||||
[(cons _ (regexp #px"(.*):(\\d+)" (list _ host port)))
|
||||
(http-server host (string->number port) ssl?)]
|
||||
[(cons _ host)
|
||||
(http-server host port ssl?)]))
|
||||
|
||||
(define (connection-thread listen-port cm connection-ports)
|
||||
(signal-background-activity! +1)
|
||||
(thread
|
||||
(lambda ()
|
||||
(match-define (list i o) connection-ports)
|
||||
;; Deliberately construct an empty custodian for the connection. Killing the connection
|
||||
;; abruptly can cause deadlocks since the connection thread communicates with Syndicate
|
||||
;; via synchronous channels.
|
||||
(define conn
|
||||
(new-connection cm (web-server-initial-connection-timeout) i o (make-custodian) #f))
|
||||
(define addresses
|
||||
(let-values (((Lip Lport Rip Rport) (tcp-addresses i #t)))
|
||||
(list Lip Lport Rip Rport)))
|
||||
(define control-ch (make-channel))
|
||||
(let do-request ()
|
||||
(define-values (req should-close?)
|
||||
(with-handlers ([exn:fail? (lambda (e) (values #f #f))])
|
||||
(read-request conn listen-port tcp-addresses)))
|
||||
(when req
|
||||
(define id (gensym 'web))
|
||||
(ground-send! (inbound (web-raw-request id listen-port conn addresses req control-ch)))
|
||||
(sync (handle-evt control-ch
|
||||
(match-lambda
|
||||
[(list 'websocket reply-headers ws-ch)
|
||||
(with-handlers ((exn:dispatcher?
|
||||
(lambda (_e)
|
||||
(define resp
|
||||
(response/full 400
|
||||
#"Bad request"
|
||||
(current-seconds)
|
||||
#"text/plain"
|
||||
(list)
|
||||
(list)))
|
||||
(output-response/method conn
|
||||
resp
|
||||
(request-method req))
|
||||
(drain-ws-ch! ws-ch))))
|
||||
((make-general-websockets-dispatcher
|
||||
(websocket-connection-main id ws-ch)
|
||||
(lambda _args (values reply-headers (void))))
|
||||
conn req))]
|
||||
[(list 'response resp)
|
||||
(output-response/method conn resp (request-method req))
|
||||
(when (not should-close?)
|
||||
(do-request))])))))
|
||||
(with-handlers ([exn:fail? (lambda (e) (values #f #f))]) (close-input-port i))
|
||||
(with-handlers ([exn:fail? (lambda (e) (values #f #f))]) (close-output-port o))
|
||||
(signal-background-activity! -1))))
|
||||
|
||||
(define ((websocket-connection-main id ws-ch) wsc _ws-connection-state)
|
||||
(define quit-seen? #f)
|
||||
(define (shutdown!)
|
||||
(ground-send! (inbound (websocket-in id eof)))
|
||||
(with-handlers ([(lambda (e) #t)
|
||||
(lambda (e) (log-syndicate/drivers/web-error
|
||||
"Unexpected ws-close! error: ~a"
|
||||
(if (exn? e)
|
||||
(exn->string e)
|
||||
(format "~v" e))))])
|
||||
(ws-close! wsc)))
|
||||
(with-handlers [(exn:fail:network? (lambda (e) (shutdown!)))
|
||||
(exn:fail:port-is-closed? (lambda (e) (shutdown!)))
|
||||
(exn:fail? (lambda (e)
|
||||
(log-syndicate/drivers/web-error "Unexpected websocket error: ~a"
|
||||
(exn->string e))
|
||||
(shutdown!)))]
|
||||
(let loop ()
|
||||
(sync (handle-evt (ws-recv-evt wsc #:payload-type 'auto)
|
||||
(lambda (msg)
|
||||
(ground-send! (inbound (websocket-in id msg)))
|
||||
(loop)))
|
||||
(handle-evt ws-ch (match-lambda
|
||||
['quit
|
||||
(set! quit-seen? #t)
|
||||
(void)]
|
||||
[(list 'send m)
|
||||
(ws-send! wsc m #:payload-type (if (bytes? m) 'binary 'text))
|
||||
(loop)]))))
|
||||
(ws-close! wsc))
|
||||
(when (not quit-seen?)
|
||||
(drain-ws-ch! ws-ch)))
|
||||
|
||||
(define (drain-ws-ch! ws-ch)
|
||||
(when (not (equal? (channel-get ws-ch) 'quit))
|
||||
(drain-ws-ch! ws-ch)))
|
||||
|
||||
;; D-: uck barf
|
||||
;; TODO: something to fix this :-/
|
||||
(define (exn:fail:port-is-closed? e)
|
||||
(and (exn:fail? e)
|
||||
(regexp-match #px"port is closed" (exn-message e))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(begin-for-declarations
|
||||
(define-struct-defaults make-http-response http-response
|
||||
(#:code [http-response-code 200]
|
||||
#:message [http-response-message #"OK"]
|
||||
#:last-modified-seconds [http-response-last-modified-seconds (current-seconds)]
|
||||
#:mime-type [http-response-mime-type #"text/html"]
|
||||
#:headers [http-response-headers '()]))
|
||||
(define-struct-defaults make-http-response-websocket http-response-websocket
|
||||
(#:headers [http-response-websocket-headers '()])))
|
||||
|
||||
(define (xexpr->bytes/utf-8 #:preamble [preamble #"<!DOCTYPE html>"] xexpr)
|
||||
(bytes-append preamble (string->bytes/utf-8 (xexpr->string xexpr))))
|
|
@ -0,0 +1,23 @@
|
|||
#lang racket/base
|
||||
|
||||
(require auxiliary-macro-context)
|
||||
|
||||
(define-auxiliary-macro-context
|
||||
#:context-name event-expander
|
||||
#:prop-name prop:event-expander
|
||||
#:prop-predicate-name event-expander?
|
||||
#:prop-accessor-name event-expander-proc
|
||||
#:macro-definer-name define-event-expander
|
||||
#:introducer-parameter-name current-event-expander-introducer
|
||||
#:local-introduce-name syntax-local-event-expander-introduce
|
||||
#:expander-id-predicate-name event-expander-id?
|
||||
#:expander-transform-name event-expander-transform)
|
||||
|
||||
(provide (for-syntax
|
||||
prop:event-expander
|
||||
event-expander?
|
||||
event-expander-proc
|
||||
syntax-local-event-expander-introduce
|
||||
event-expander-id?
|
||||
event-expander-transform)
|
||||
define-event-expander)
|
|
@ -0,0 +1,21 @@
|
|||
#lang imperative-syndicate
|
||||
;; Simple mutable box and count-to-infinity box client.
|
||||
|
||||
(message-struct set-box (new-value))
|
||||
(assertion-struct box-state (value))
|
||||
|
||||
(spawn (field [current-value 0])
|
||||
(assert (box-state (current-value)))
|
||||
(stop-when-true (= (current-value) 10)
|
||||
(log-info "box: terminating"))
|
||||
(on (message (set-box $new-value))
|
||||
(log-info "box: taking on new-value ~v" new-value)
|
||||
(current-value new-value)))
|
||||
|
||||
(spawn (stop-when (retracted (observe (set-box _)))
|
||||
(log-info "client: box has gone"))
|
||||
(on (asserted (box-state $v))
|
||||
(log-info "client: learned that box's value is now ~v" v)
|
||||
(send! (set-box (+ v 1))))
|
||||
(on (retracted (box-state _))
|
||||
(log-info "client: box state disappeared")))
|
|
@ -0,0 +1,34 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require/activate imperative-syndicate/drivers/tcp)
|
||||
(require/activate imperative-syndicate/drivers/external-event)
|
||||
(require/activate imperative-syndicate/reassert)
|
||||
(require (only-in racket/port read-bytes-line-evt))
|
||||
|
||||
(spawn (define id 'chat)
|
||||
(define root-facet (current-facet))
|
||||
|
||||
(reassert-on (tcp-connection id (tcp-address "localhost" 5999))
|
||||
(retracted (tcp-accepted id))
|
||||
(asserted (tcp-rejected id _)))
|
||||
|
||||
(on (asserted (tcp-rejected id $reason))
|
||||
(printf "*** ~a\n" (exn-message reason)))
|
||||
|
||||
(during (tcp-accepted id)
|
||||
(on-start (printf "*** Connected.\n")
|
||||
(issue-credit! tcp-in id))
|
||||
(on (retracted (tcp-accepted id)) (printf "*** Remote EOF.\n"))
|
||||
;; ^ Not on-stop, because the facet is stopped by local EOF too!
|
||||
|
||||
(on (message (tcp-in-line id $bs))
|
||||
(write-bytes bs)
|
||||
(newline)
|
||||
(flush-output)
|
||||
(issue-credit! tcp-in id))
|
||||
|
||||
(define stdin-evt (read-bytes-line-evt (current-input-port) 'any))
|
||||
(on (message (inbound (external-event stdin-evt (list $line))))
|
||||
(if (eof-object? line)
|
||||
(stop-facet root-facet (printf "*** Local EOF. Terminating.\n"))
|
||||
(send! (tcp-out id (bytes-append line #"\n")))))))
|
|
@ -0,0 +1,29 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require/activate imperative-syndicate/drivers/tcp)
|
||||
(require racket/format)
|
||||
|
||||
(message-struct speak (who what))
|
||||
(assertion-struct present (who))
|
||||
|
||||
(dataspace
|
||||
(spawn #:name 'chat-server
|
||||
(during/spawn (inbound (tcp-connection $id (tcp-listener 5999)))
|
||||
#:name (list 'chat-connection id)
|
||||
(assert (outbound (tcp-accepted id)))
|
||||
(on-start (send! (outbound (credit (tcp-listener 5999) 1)))
|
||||
(send! (outbound (credit tcp-in id 1))))
|
||||
(let ((me (gensym 'user)))
|
||||
(assert (present me))
|
||||
(on (message (inbound (tcp-in-line id $bs)))
|
||||
(match bs
|
||||
[#"/quit" (stop-current-facet)]
|
||||
[#"/stop-server" (quit-dataspace!)]
|
||||
[_ (send! (speak me (bytes->string/utf-8 bs)))
|
||||
(send! (outbound (credit tcp-in id 1)))])))
|
||||
(during (present $user)
|
||||
(on-start (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " arrived\n"))))))
|
||||
(on-stop (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " left\n"))))))
|
||||
(on (message (speak user $text))
|
||||
(send!
|
||||
(outbound (tcp-out id (string->bytes/utf-8 (~a user " says '" text "'\n"))))))))))
|
|
@ -0,0 +1,30 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require/activate imperative-syndicate/drivers/tcp)
|
||||
(require racket/format)
|
||||
|
||||
(message-struct speak (who what))
|
||||
(assertion-struct present (who))
|
||||
|
||||
(message-struct stop-server ())
|
||||
|
||||
(spawn #:name 'chat-server
|
||||
(stop-when (message (stop-server)))
|
||||
(during/spawn (tcp-connection $id (tcp-listener 5999))
|
||||
#:name (list 'chat-connection id)
|
||||
(assert (tcp-accepted id))
|
||||
(on-start (issue-credit! (tcp-listener 5999))
|
||||
(issue-credit! tcp-in id))
|
||||
(let ((me (gensym 'user)))
|
||||
(assert (present me))
|
||||
(on (message (tcp-in-line id $bs))
|
||||
(issue-credit! tcp-in id)
|
||||
(match bs
|
||||
[#"/quit" (stop-current-facet)]
|
||||
[#"/stop-server" (send! (stop-server))]
|
||||
[_ (send! (speak me (bytes->string/utf-8 bs)))])))
|
||||
(during (present $user)
|
||||
(on-start (send! (tcp-out id (string->bytes/utf-8 (~a user " arrived\n")))))
|
||||
(on-stop (send! (tcp-out id (string->bytes/utf-8 (~a user " left\n")))))
|
||||
(on (message (speak user $text))
|
||||
(send! (tcp-out id (string->bytes/utf-8 (~a user " says '" text "'\n"))))))))
|
|
@ -0,0 +1,31 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require/activate imperative-syndicate/drivers/external-event)
|
||||
(require/activate imperative-syndicate/drivers/filesystem)
|
||||
(require racket/file)
|
||||
|
||||
(require (only-in racket/port read-bytes-line-evt))
|
||||
(require (only-in racket/string string-trim string-split))
|
||||
|
||||
(spawn #:name 'monitor-shell
|
||||
(define e (read-bytes-line-evt (current-input-port) 'any))
|
||||
(on (message (inbound (external-event e (list $line))))
|
||||
(match line
|
||||
[(? eof-object?)
|
||||
(stop-current-facet (send! (list "close" 'all)))]
|
||||
[(? bytes? command-bytes)
|
||||
(send! (string-split (string-trim (bytes->string/utf-8 command-bytes))))])))
|
||||
|
||||
(spawn #:name 'monitor-opener
|
||||
|
||||
(define (monitor name reader-proc)
|
||||
(spawn #:name (list 'monitor name)
|
||||
(stop-when (message (list "close" 'all))) ;; old-syndicate version used wildcard
|
||||
(stop-when (message (list "close" name)))
|
||||
(on (asserted (file-content name reader-proc $data))
|
||||
(log-info "~a: ~v" name data))))
|
||||
|
||||
(on (message (list "open" $name)) (monitor name file->bytes))
|
||||
|
||||
;; The driver can track directory "contents" just as well as files.
|
||||
(on (message (list "opendir" $name)) (monitor name directory-list)))
|
|
@ -0,0 +1,133 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require racket/set)
|
||||
(require 2htdp/image)
|
||||
(require/activate imperative-syndicate/drivers/gl-2d)
|
||||
|
||||
(define (spawn-background)
|
||||
(spawn (during (window $width $height)
|
||||
(assert-scene `((push-matrix (scale ,width ,(* height 2))
|
||||
(translate 0 -0.25)
|
||||
(texture
|
||||
,(overlay/xy (rectangle 1 1 "solid" "white")
|
||||
0 0
|
||||
(rectangle 1 2 "solid" "black"))))
|
||||
;; (rotate -30)
|
||||
;; (scale 5 5)
|
||||
)
|
||||
`()))))
|
||||
|
||||
(define (draggable-mixin touching? x y)
|
||||
(define (idle)
|
||||
(react (stop-when #:when (touching?)
|
||||
(message (mouse-event 'left-down (mouse-state $mx $my _ _ _)))
|
||||
(log-info "idle -> dragging; in-script? ~v" (in-script?))
|
||||
(dragging (- mx (x)) (- my (y))))))
|
||||
|
||||
(define (dragging dx dy)
|
||||
(react (on (message (mouse-event 'motion (mouse-state $mx $my _ _ _)))
|
||||
(x (- mx dx))
|
||||
(y (- my dy)))
|
||||
(stop-when (message (mouse-event 'left-up _)) (idle))
|
||||
(stop-when (message (mouse-event 'leave _)) (idle))))
|
||||
|
||||
(idle))
|
||||
|
||||
(define (draggable-shape name orig-x orig-y z plain-image hover-image
|
||||
#:coordinate-map-id [coordinate-map-id #f]
|
||||
#:parent [parent-id #f])
|
||||
(spawn (field [x orig-x] [y orig-y])
|
||||
(define/query-value touching? #f (touching name) #t)
|
||||
(assert (simple-sprite #:parent parent-id
|
||||
#:coordinate-map-id coordinate-map-id
|
||||
#:touchable-id name
|
||||
#:touchable-predicate in-unit-circle?
|
||||
z (x) (y) 50 50
|
||||
(if (touching?)
|
||||
hover-image
|
||||
plain-image)))
|
||||
(on-start (draggable-mixin touching? x y))))
|
||||
|
||||
(define (tooltip touching? x y w h label-string)
|
||||
(define label-text (text label-string 22 "black"))
|
||||
(define label (overlay label-text (empty-scene (+ (image-width label-text) 10)
|
||||
(+ (image-height label-text) 10))))
|
||||
(define (pos)
|
||||
(define v (- (x) (image-width label) 10))
|
||||
(if (negative? v)
|
||||
(+ (x) w 10)
|
||||
v))
|
||||
(react (assert #:when (touching?)
|
||||
(simple-sprite -10
|
||||
(pos)
|
||||
(+ (y) (* 1/2 h) (- (* 1/2 (image-height label))))
|
||||
(image-width label)
|
||||
(image-height label)
|
||||
label))))
|
||||
|
||||
(define (spawn-player-avatar)
|
||||
(local-require 2htdp/planetcute)
|
||||
(define CC character-cat-girl)
|
||||
|
||||
(spawn (field [x 100] [y 100])
|
||||
(assert (simple-sprite #:touchable-id 'player
|
||||
#:coordinate-map-id 'player
|
||||
-0.5 (x) (y) (image-width CC) (image-height CC) CC))
|
||||
|
||||
(field [keys-down (set)])
|
||||
(on (asserted (key-pressed $k)) (keys-down (set-add (keys-down) k)))
|
||||
(on (retracted (key-pressed $k)) (keys-down (set-remove (keys-down) k)))
|
||||
(define (key->delta k distance) (if (set-member? (keys-down) k) distance 0))
|
||||
|
||||
(define/query-value touching? #f (touching 'player) #t)
|
||||
(on-start (draggable-mixin touching? x y))
|
||||
|
||||
(on (asserted (coordinate-map 'player $xform))
|
||||
;; TODO: figure out why this causes lag in frame updates
|
||||
(log-info "Player coordinate map: ~v" xform))
|
||||
|
||||
(on-start (tooltip touching? x y (image-width CC) (image-height CC) "The Player"))
|
||||
|
||||
(on (message (frame-event _ _ $elapsed-ms _))
|
||||
(define-values (old-x old-y) (values (x) (y)))
|
||||
(define distance (* 0.360 elapsed-ms))
|
||||
(define nx (+ old-x (key->delta 'right distance) (key->delta 'left (- distance))))
|
||||
(define ny (+ old-y (key->delta 'down distance) (key->delta 'up (- distance))))
|
||||
(when (not (and (= nx old-x) (= ny old-y)))
|
||||
(x nx)
|
||||
(y ny)))))
|
||||
|
||||
(define (spawn-frame-counter)
|
||||
(spawn (field [i empty-image])
|
||||
(assert (simple-sprite -10 300 10 (image-width (i)) (image-height (i)) (i)))
|
||||
(on (message (frame-event $counter $sim-time-ms _ _))
|
||||
(when (> sim-time-ms 0)
|
||||
(define fps (/ counter (/ sim-time-ms 1000.0)))
|
||||
(i (text (format "~a fps" fps) 22 "black"))))))
|
||||
|
||||
(spawn-keyboard-integrator)
|
||||
(spawn-mouse-integrator)
|
||||
(spawn-background)
|
||||
;; (spawn-frame-counter)
|
||||
(spawn-player-avatar)
|
||||
|
||||
(draggable-shape 'orange 50 50 0
|
||||
(circle 50 "solid" "orange")
|
||||
(circle 50 "solid" "red"))
|
||||
|
||||
(draggable-shape 'yellow 10 -10 0 #:parent 'orange
|
||||
(circle 50 "solid" "yellow")
|
||||
(circle 50 "solid" "purple"))
|
||||
|
||||
(draggable-shape 'green 60 60 -1
|
||||
(circle 50 "solid" "green")
|
||||
(circle 50 "solid" "cyan"))
|
||||
|
||||
(spawn* (until (message (key-event #\q #t _)))
|
||||
(assert! (gl-control 'stop)))
|
||||
|
||||
(spawn (during (touching $id)
|
||||
(on-start (log-info "Touching ~v" id))
|
||||
(on-stop (log-info "No longer touching ~v" id))))
|
||||
|
||||
(spawn-gl-2d-driver)
|
|
@ -0,0 +1,87 @@
|
|||
#lang imperative-syndicate
|
||||
;; Compare to "ezd" clock-face example from: J. F. Bartlett, “Don’t
|
||||
;; Fidget with Widgets, Draw!,” Palo Alto, California, DEC WRL
|
||||
;; Research Report 91/6, May 1991.
|
||||
|
||||
(require lang/posn)
|
||||
(require 2htdp/image)
|
||||
(require (only-in racket/math pi))
|
||||
(require racket/date)
|
||||
|
||||
(require/activate imperative-syndicate/drivers/gl-2d)
|
||||
|
||||
(define hand
|
||||
(polygon (list (make-posn 0 0)
|
||||
(make-posn 30 10)
|
||||
(make-posn 100 0)
|
||||
(make-posn 30 -10))
|
||||
"solid"
|
||||
"black"))
|
||||
|
||||
(define (fmod a b)
|
||||
(- a (* b (truncate (/ a b)))))
|
||||
|
||||
(define (hand-sprite id layer angle-field length)
|
||||
(sprite #:id id layer `((translate 100 100)
|
||||
(rotate ,(fmod (- 90 (angle-field)) 360))
|
||||
(scale ,length ,(/ length 5))
|
||||
(translate 0 -0.5)
|
||||
(touchable ,id ,in-unit-square?)
|
||||
(texture ,hand))))
|
||||
|
||||
(define (text-sprite layer x y content)
|
||||
(define i (text content 24 "green"))
|
||||
(simple-sprite layer x y (image-width i) (image-height i) i))
|
||||
|
||||
(spawn (field [minute-angle 0]
|
||||
[hour-angle 0]
|
||||
[start-time (current-inexact-milliseconds)]
|
||||
[elapsed-seconds 0]
|
||||
[displacement (let ((now (current-date)))
|
||||
(* 6 (+ (* 60 (date-hour now))
|
||||
(date-minute now))))])
|
||||
|
||||
(assert (simple-sprite 10 0 0 200 200 (circle 100 "solid" "blue")))
|
||||
(assert (hand-sprite 'minute 9 minute-angle 95))
|
||||
(assert (text-sprite 8 40 40 "time"))
|
||||
(assert (text-sprite 8 110 80 "drifts"))
|
||||
(assert (text-sprite 8 40 120 "by"))
|
||||
(assert (hand-sprite 'hour 7 hour-angle 65))
|
||||
(assert (simple-sprite 6 95 95 10 10 (circle 5 "solid" "black")))
|
||||
|
||||
(define (respond-to-drags id scale)
|
||||
(define/query-value touching? #f (touching id) #t)
|
||||
(on #:when (touching?) (message (mouse-event 'left-down (mouse-state $mx $my _ _ _)))
|
||||
(start-time #f)
|
||||
(elapsed-seconds 0)
|
||||
(update-displacement! mx my scale)
|
||||
(react (stop-when (message (mouse-event 'left-up _)))
|
||||
(stop-when (message (mouse-event 'leave _)))
|
||||
(on-stop (start-time (current-inexact-milliseconds)))
|
||||
(on (message (mouse-event 'motion (mouse-state $mx $my _ _ _)))
|
||||
(update-displacement! mx my scale)))))
|
||||
|
||||
(define (update-displacement! mx my scale)
|
||||
(define angle (- 90 (* (/ 180 pi) (atan (- 100 my) (- mx 100)))))
|
||||
(define delta0 (fmod (- (* scale angle) (displacement)) 360))
|
||||
(define delta (if (<= delta0 -180) (+ delta0 360) delta0))
|
||||
(displacement (+ (displacement) delta)))
|
||||
|
||||
(respond-to-drags 'minute 1)
|
||||
(respond-to-drags 'hour 12)
|
||||
|
||||
(begin/dataflow
|
||||
(define angle (+ (/ (elapsed-seconds) 1000 10) (displacement)))
|
||||
(minute-angle angle)
|
||||
(hour-angle (/ angle 12)))
|
||||
|
||||
(on (message (frame-event _ _ _ _))
|
||||
(when (start-time)
|
||||
(elapsed-seconds (- (current-inexact-milliseconds) (start-time)))))
|
||||
|
||||
(on (message (key-event #\q #t _))
|
||||
(send! (gl-control 'stop))))
|
||||
|
||||
(spawn-gl-2d-driver #:label "Syndicate Clock"
|
||||
#:width 200
|
||||
#:height 200)
|
|
@ -0,0 +1,84 @@
|
|||
#lang imperative-syndicate
|
||||
;; Multiple animated sprites.
|
||||
;;
|
||||
;; 2018-05-01 With the new "imperative" implementation of Syndicate,
|
||||
;; the same 2.6GHz laptop mentioned below can animate 135 logos in a
|
||||
;; 640x480 window at 60 fps on a single core, with a bit of headroom
|
||||
;; to spare.
|
||||
;;
|
||||
;; 2016-12-12 With the current implementations of (a) Syndicate's
|
||||
;; dataspaces and (b) Syndicate's 2D sprite support, my reasonably new
|
||||
;; 2.6GHz laptop can animate 20 logos at 256x256 pixels at about 20
|
||||
;; frames per second on a single core.
|
||||
;;
|
||||
;; For comparison, Kay recounts in "The Early History of Smalltalk"
|
||||
;; (1993) that "by the Fall of '73 [Steve Purcell] could demo 80
|
||||
;; ping-pong balls and 10 flying horses running at 10 frames per
|
||||
;; second in 2 1/2 D" in an early Smalltalk (?) on a NOVA.
|
||||
|
||||
(require 2htdp/image)
|
||||
(require images/logos)
|
||||
(require/activate imperative-syndicate/drivers/gl-2d)
|
||||
|
||||
(define speed-limit 40)
|
||||
(define sprite-count 135)
|
||||
|
||||
(define (spawn-background)
|
||||
(spawn
|
||||
(during (window $width $height)
|
||||
(assert-scene `((push-matrix (scale ,width ,height)
|
||||
(texture ,(rectangle 1 1 "solid" "white"))))
|
||||
`()))))
|
||||
|
||||
(define i:logo (plt-logo))
|
||||
(define i:logo-width (image-width i:logo))
|
||||
(define i:logo-height (image-height i:logo))
|
||||
|
||||
(define (spawn-logo)
|
||||
(spawn (field [x 100] [y 100])
|
||||
(field [dx (* (- (random) 0.5) speed-limit)]
|
||||
[dy (* (- (random) 0.5) speed-limit)])
|
||||
(define/query-value w #f ($ w (window _ _)) w)
|
||||
(assert (simple-sprite 0
|
||||
(x)
|
||||
(y)
|
||||
i:logo-width
|
||||
i:logo-height
|
||||
i:logo))
|
||||
(define (bounce f df limit)
|
||||
(define v (f))
|
||||
(define limit* (- limit i:logo-width))
|
||||
(cond [(< v 0) (f 0) (df (abs (df)))]
|
||||
[(> v limit*) (f limit*) (df (- (abs (df))))]
|
||||
[else (void)]))
|
||||
(on (message (frame-event _ _ _ _))
|
||||
(when (w) ;; don't animate until we know the window bounds
|
||||
(x (+ (x) (dx)))
|
||||
(y (+ (y) (dy)))
|
||||
(bounce x dx (window-width (w)))
|
||||
(bounce y dy (window-height (w)))))))
|
||||
|
||||
(spawn-background)
|
||||
(for [(i sprite-count)]
|
||||
(spawn-logo))
|
||||
|
||||
(spawn (define start-time #f)
|
||||
(log-info "Sprite count: ~a" sprite-count)
|
||||
(on (message (frame-event $counter $timestamp _ _))
|
||||
(if (eq? start-time #f)
|
||||
(set! start-time (current-inexact-milliseconds))
|
||||
(let ((delta (- (current-inexact-milliseconds) start-time)))
|
||||
(when (and (zero? (modulo counter 100)) (positive? delta))
|
||||
(log-info "~v frames, ~v ms ==> ~v Hz"
|
||||
counter
|
||||
delta
|
||||
(/ counter (/ delta 1000.0))))))))
|
||||
|
||||
(spawn-gl-2d-driver)
|
||||
|
||||
(spawn (field [fullscreen? #f])
|
||||
(on (message (key-event #\f #t _)) (fullscreen? (not (fullscreen?))))
|
||||
(assert #:when (fullscreen?) (gl-control 'fullscreen))
|
||||
|
||||
(on (message (key-event #\q #t _))
|
||||
(send! (gl-control 'stop))))
|
|
@ -0,0 +1,825 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require 2htdp/image)
|
||||
(require 2htdp/planetcute)
|
||||
|
||||
(require racket/set)
|
||||
(require plot/utils) ;; for vector utilities
|
||||
|
||||
(require (only-in racket/string string-prefix?))
|
||||
(require (only-in racket/gui/base play-sound))
|
||||
|
||||
(require/activate imperative-syndicate/drivers/timer)
|
||||
(require/activate imperative-syndicate/drivers/gl-2d)
|
||||
(require imperative-syndicate/bag)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Layers:
|
||||
;;
|
||||
;; - External I/O
|
||||
;; as arranged by syndicate-gl/2d
|
||||
;; including keyboard events, interface to rendering, and frame timing
|
||||
;;
|
||||
;; - Ground
|
||||
;; corresponds to computer itself
|
||||
;; device drivers
|
||||
;; applications (e.g. in this instance, the game)
|
||||
;;
|
||||
;; - Game
|
||||
;; running application
|
||||
;; per-game state, such as score and count-of-deaths
|
||||
;; process which spawns levels
|
||||
;; regular frame ticker
|
||||
;;
|
||||
;; - Level
|
||||
;; model of the game world
|
||||
;; actors represent entities in the world, mostly
|
||||
;; misc actors do physicsish things
|
||||
;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ## Common Data Definitions
|
||||
;;
|
||||
;; A Vec is a (vector Number Number)
|
||||
;; A Point is a (vector Number Number)
|
||||
;; (See vector functions in plot/utils)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ## Ground Layer Protocols
|
||||
|
||||
;;-------------------------------------------------------------------------
|
||||
;; ### Scene Management
|
||||
;; - assertion: ScrollOffset
|
||||
;; - assertion: OnScreenDisplay
|
||||
;; - role: SceneManager
|
||||
;; Displays the scene backdrop and adjusts display coordinates via ScrollOffset.
|
||||
;;
|
||||
;; A ScrollOffset is a (scroll-offset Vec), indicating the vector to *subtract*
|
||||
;; from world coordinates to get device coordinates.
|
||||
(struct scroll-offset (vec) #:transparent)
|
||||
;;
|
||||
;; An OnScreenDisplay is an (on-screen-display Number Number (Seal Image)),
|
||||
;; representing an item to display in a fixed window-relative position
|
||||
;; above the scrolled part of the scene. If the coordinates are
|
||||
;; positive, they measure right/down from the left/top of the image;
|
||||
;; if negative, they measure left/up from the right/bottom.
|
||||
(struct on-screen-display (x y sealed-image) #:transparent)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ## Game Layer Protocols
|
||||
|
||||
;;-------------------------------------------------------------------------
|
||||
;; ### Scoring
|
||||
;; - message: AddToScore
|
||||
;; - assertion: CurrentScore
|
||||
;; - role: ScoreKeeper
|
||||
;; Maintains the score as private state.
|
||||
;; Publishes the score using a CurrentScore.
|
||||
;; Responds to AddToScore by updating the score.
|
||||
;;
|
||||
;; An AddToScore is an (add-to-score Number), a message
|
||||
;; which signals a need to add the given number to the player's
|
||||
;; current score.
|
||||
(struct add-to-score (delta) #:transparent)
|
||||
;;
|
||||
;; A CurrentScore is a (current-score Number), an assertion
|
||||
;; indicating the player's current score.
|
||||
(struct current-score (value) #:transparent)
|
||||
|
||||
;;-------------------------------------------------------------------------
|
||||
;; ### Level Spawning
|
||||
;; - assertion: LevelRunning
|
||||
;; - message: LevelCompleted
|
||||
;; - role: LevelSpawner
|
||||
;; Maintains the current level number as private state.
|
||||
;; Spawns a new Level when required.
|
||||
;; Monitors LevelRunning - when it drops, the level is over.
|
||||
;; Receives LevelCompleted messages. If LevelRunning drops without
|
||||
;; a LevelCompleted having arrived, the level ended in failure and
|
||||
;; should be restarted. If LevelComplete arrived before LevelRunning
|
||||
;; dropped, the level was completed successfully, and the next level
|
||||
;; should be presented.
|
||||
;; - role: Level
|
||||
;; Running level instance. Maintains LevelRunning while it's still
|
||||
;; going. Sends LevelCompleted if the player successfully completed
|
||||
;; the level.
|
||||
;;
|
||||
;; A LevelRunning is a (level-running), an assertion indicating that the
|
||||
;; current level is still in progress.
|
||||
(struct level-running () #:transparent)
|
||||
;;
|
||||
;; A LevelCompleted is a (level-completed), a message indicating that
|
||||
;; the current level was *successfully* completed before it terminated.
|
||||
(struct level-completed () #:transparent)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ## Level Layer Protocols
|
||||
|
||||
;;-------------------------------------------------------------------------
|
||||
;; ### Movement and Physics
|
||||
;; - message: JumpRequest
|
||||
;; - assertion: Impulse
|
||||
;; - assertion: Position
|
||||
;; - assertion: GamePieceConfiguration
|
||||
;; - assertion: Touching
|
||||
;; - role: PhysicsEngine
|
||||
;; Maintains positions, velocities and accelerations of all GamePieces.
|
||||
;; Uses GamePieceConfiguration for global properties of pieces.
|
||||
;; Publishes Position to match.
|
||||
;; Listens to FrameDescription, using it to advance the simulation.
|
||||
;; Considers only mobile GamePieces for movement.
|
||||
;; Takes Impulses as the baseline for moving GamePieces around.
|
||||
;; For massive mobile GamePieces, applies gravitational acceleration.
|
||||
;; Computes collisions between GamePieces.
|
||||
;; Uses Attributes of GamePieces to decide what to do in response to collisions.
|
||||
;; For 'touchable GamePieces, a Touching row is asserted.
|
||||
;; Responds to JumpRequest by checking whether the named piece is in a
|
||||
;; jumpable location, and sets its upward velocity negative if so.
|
||||
;; - role: GamePiece
|
||||
;; Maintains private state. Asserts Impulse to move around,
|
||||
;; and GamePieceConfiguration to get things started. May issue
|
||||
;; JumpRequests at any time. Represents both the player,
|
||||
;; enemies, the goal(s), and platforms and blocks in the
|
||||
;; environment. Asserts a Sprite two layers out to render
|
||||
;; itself.
|
||||
;;
|
||||
;; An ID is a Symbol; the special symbol 'player indicates the player's avatar.
|
||||
;; Gensyms from (gensym 'enemy) name enemies, etc.
|
||||
;;
|
||||
;; A JumpRequest is a (jump-request ID), a message indicating a *request* to jump,
|
||||
;; not necessarily honoured by the physics engine.
|
||||
(struct jump-request (id) #:transparent)
|
||||
;;
|
||||
;; An Impulse is an (impulse ID Vec), an assertion indicating a contribution to
|
||||
;; the net *requested* velocity of the given gamepiece.
|
||||
(struct impulse (id vec) #:transparent)
|
||||
;;
|
||||
;; A Position is a (position ID Point Vec), an assertion describing
|
||||
;; the current actual top-left corner and (physics-related, not
|
||||
;; necessarily graphics-related) size of the named gamepiece.
|
||||
(struct position (id top-left size) #:transparent)
|
||||
;;
|
||||
;; An Attribute is either
|
||||
;; - 'player - the named piece is a player avatar
|
||||
;; - 'touchable - the named piece reacts to the player's touch
|
||||
;; - 'solid - the named piece can be stood on / jumped from
|
||||
;; - 'mobile - the named piece is not fixed in place
|
||||
;; - 'massive - the named piece is subject to effects of gravity
|
||||
;; (it is an error to be 'massive but not 'mobile)
|
||||
;;
|
||||
;; A GamePieceConfiguration is a
|
||||
;; - (game-piece-configuration ID Point Vec (Set Attribute))
|
||||
;; an assertion specifying not only the *existence* of a named
|
||||
;; gamepiece, but also its initial position and size and a collection
|
||||
;; of its Attributes.
|
||||
(struct game-piece-configuration (id initial-position size attributes) #:transparent)
|
||||
;;
|
||||
;; A Touching is a
|
||||
;; - (touching ID ID Side)
|
||||
;; an assertion indicating that the first ID is touching the second on
|
||||
;; the named side of the second ID.
|
||||
(struct touching (a b side) #:transparent)
|
||||
;;
|
||||
;; A Side is either 'top, 'left, 'right, 'bottom or the special value
|
||||
;; 'mid, indicating an unknown or uncomputable side.
|
||||
|
||||
(define (game-piece-has-attribute? g attr)
|
||||
(set-member? (game-piece-configuration-attributes g) attr))
|
||||
|
||||
;;-------------------------------------------------------------------------
|
||||
;; ### Player State
|
||||
;; - message: Damage
|
||||
;; - assertion: Health
|
||||
;; - role: Player
|
||||
;; Maintains hitpoints, which it reflects using Health.
|
||||
;; Responds to Damage.
|
||||
;; When hitpoints drop low enough, removes the player from the board.
|
||||
;;
|
||||
;; A Damage is a (damage ID Number), a message indicating an event that should
|
||||
;; consume the given number of health points of the named gamepiece.
|
||||
(struct damage (id hit-points) #:transparent)
|
||||
;;
|
||||
;; A Health is a (health ID Number), an assertion describing the current hitpoints
|
||||
;; of the named gamepiece.
|
||||
(struct health (id hit-points) #:transparent)
|
||||
|
||||
;;-------------------------------------------------------------------------
|
||||
;; ### World State
|
||||
;; - assertion: LevelSize
|
||||
;; - role: DisplayControl
|
||||
;; Maintains a LevelSize assertion.
|
||||
;; Observes the Position of the player, and computes and maintains a
|
||||
;; ScrollOffset two layers out, to match.
|
||||
;; Also kills the player if they wander below the bottom of the level.
|
||||
;;
|
||||
;; A LevelSize is a (level-size Vec), an assertion describing the right-hand and
|
||||
;; bottom edges of the level canvas (in World coordinates).
|
||||
(struct level-size (vec) #:transparent)
|
||||
|
||||
;; -----------
|
||||
;; Interaction Diagrams (to be refactored into the description later)
|
||||
;;
|
||||
;; ================================================================================
|
||||
;;
|
||||
;; title Jump Sequence
|
||||
;;
|
||||
;; Player -> Physics: (jump 'player)
|
||||
;; note right of Physics: Considers the request.
|
||||
;; note right of Physics: Denied -- Player is not on a surface.
|
||||
;;
|
||||
;; Player -> Physics: (jump 'player)
|
||||
;; note right of Physics: Considers the request.
|
||||
;; note right of Physics: Accepted.
|
||||
;; note right of Physics: Updates velocity, position
|
||||
;; Physics -> Subscribers: (vel 'player ...)
|
||||
;; Physics -> Subscribers: (pos 'player ...)
|
||||
;;
|
||||
;;
|
||||
;; ================================================================================
|
||||
;;
|
||||
;; title Display Control Updates
|
||||
;;
|
||||
;; Physics -> DisplayCtl: (pos 'player ...)
|
||||
;; note right of DisplayCtl: Compares player pos to level size
|
||||
;; DisplayCtl -> Subscribers: (inbound (inbound (scroll-offset ...)))
|
||||
;;
|
||||
;; ================================================================================
|
||||
;;
|
||||
;; title Movement Sequence
|
||||
;;
|
||||
;; Moveable -> Physics: (mobile ID Boolean)
|
||||
;; Moveable -> Physics: (attr ID ...)
|
||||
;; Moveable -> Physics: (impulse ID vec)
|
||||
;; note right of Physics: Processes simulation normally
|
||||
;; Physics -> Subscribers: (pos ID ...)
|
||||
;; Physics -> Subscribers: (vel ID ...)
|
||||
;;
|
||||
;; ================================================================================
|
||||
;;
|
||||
;; title Keyboard Interpretation
|
||||
;;
|
||||
;; Keyboard -> Player: (press right-arrow)
|
||||
;; Player -->> Physics: assert (impulse ID (vec DX 0))
|
||||
;;
|
||||
;; note right of Physics: Processes simulation normally
|
||||
;;
|
||||
;; Keyboard -> Player: (press left-arrow)
|
||||
;; Player -->> Physics: assert (impulse ID (vec 0 0))
|
||||
;;
|
||||
;; Keyboard -> Player: (release right-arrow)
|
||||
;; Player -->> Physics: assert (impulse ID (vec -DX 0))
|
||||
;;
|
||||
;; Keyboard -> Player: (press space)
|
||||
;; Player -> Physics: (jump)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Icon
|
||||
|
||||
(struct icon (pict scale hitbox-width-fraction hitbox-height-fraction baseline-fraction)
|
||||
#:transparent)
|
||||
|
||||
(define (icon-width i) (* (image-width (icon-pict i)) (icon-scale i)))
|
||||
(define (icon-height i) (* (image-height (icon-pict i)) (icon-scale i)))
|
||||
(define (icon-hitbox-width i) (* (icon-width i) (icon-hitbox-width-fraction i)))
|
||||
(define (icon-hitbox-height i) (* (icon-height i) (icon-hitbox-height-fraction i)))
|
||||
(define (icon-hitbox-size i) (vector (icon-hitbox-width i) (icon-hitbox-height i)))
|
||||
|
||||
(define (focus->top-left i x y)
|
||||
(vector (- x (/ (icon-hitbox-width i) 2))
|
||||
(- y (icon-hitbox-height i))))
|
||||
|
||||
(define (icon-sprite i layer pos)
|
||||
(match-define (vector x y) pos)
|
||||
(simple-sprite layer
|
||||
(- x (/ (- (icon-width i) (icon-hitbox-width i)) 2))
|
||||
(- y (- (* (icon-baseline-fraction i) (icon-height i)) (icon-hitbox-height i)))
|
||||
(icon-width i)
|
||||
(icon-height i)
|
||||
(icon-pict i)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; SceneManager
|
||||
|
||||
(define (spawn-scene-manager)
|
||||
(spawn #:name 'scene-manager
|
||||
(define backdrop (rectangle 1 1 "solid" "white"))
|
||||
|
||||
(define/query-value size (vector 0 0) (window $x $y) (vector x y))
|
||||
(define/query-set osds ($ o (on-screen-display _ _ _)) o)
|
||||
(define/query-value offset (vector 0 0) (scroll-offset $v) v)
|
||||
|
||||
(field [fullscreen? #f])
|
||||
(assert #:when (fullscreen?) (gl-control 'fullscreen))
|
||||
(on (message (key-event #\f #t _))
|
||||
(fullscreen? (not (fullscreen?))))
|
||||
|
||||
(define (compute-backdrop)
|
||||
(match-define (vector width height) (size))
|
||||
(match-define (vector ofs-x ofs-y) (offset))
|
||||
(define osd-blocks
|
||||
(for/list [(osd (in-set (osds)))]
|
||||
(match-define (on-screen-display raw-x raw-y (seal i)) osd)
|
||||
(define x (if (negative? raw-x) (+ width raw-x) raw-x))
|
||||
(define y (if (negative? raw-y) (+ height raw-y) raw-y))
|
||||
`(push-matrix (translate ,x ,y)
|
||||
(scale ,(image-width i) ,(image-height i))
|
||||
(texture ,i))))
|
||||
(scene (seal `((push-matrix
|
||||
(scale ,width ,height)
|
||||
(texture ,backdrop))
|
||||
(translate ,(- ofs-x) ,(- ofs-y))))
|
||||
(seal `((translate ,ofs-x ,ofs-y)
|
||||
,@osd-blocks))))
|
||||
(assert (compute-backdrop))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ScoreKeeper
|
||||
|
||||
(define (spawn-score-keeper)
|
||||
(spawn #:name 'score-keeper
|
||||
(field [score 0])
|
||||
(assert (current-score (score)))
|
||||
(assert (outbound
|
||||
(on-screen-display -150 10
|
||||
(seal (text (format "Score: ~a" (score)) 24 "white")))))
|
||||
(on (message (add-to-score $delta))
|
||||
(score (+ (score) delta))
|
||||
(log-info "Score increased by ~a to ~a" delta (score))
|
||||
(play-sound-sequence 270304))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; PhysicsEngine
|
||||
|
||||
(define impulse-multiplier 0.360) ;; 360 pixels per second
|
||||
(define jump-vel (vector 0 -2))
|
||||
(define gravity 0.004)
|
||||
|
||||
(define (spawn-physics-engine)
|
||||
(spawn #:name 'physics-engine
|
||||
(field [configs (hash)]
|
||||
[previous-positions (hash)]
|
||||
[previous-velocities (hash)]
|
||||
[positions (hash)]
|
||||
[velocities (hash)])
|
||||
|
||||
(during (game-piece-configuration $id $initial-position $size $attrs)
|
||||
(on-start (configs
|
||||
(hash-set (configs) id
|
||||
(game-piece-configuration id initial-position size attrs))))
|
||||
(on-stop (configs (hash-remove (configs) id))
|
||||
(positions (hash-remove (positions) id))
|
||||
(velocities (hash-remove (velocities) id)))
|
||||
(assert (position id (hash-ref (positions) id initial-position) size)))
|
||||
|
||||
(define/query-hash impulses (impulse $id $vec) id vec)
|
||||
|
||||
(define (piece-cfg id) (hash-ref (configs) id))
|
||||
(define (piece-pos which id)
|
||||
(hash-ref (which) id (lambda () (game-piece-configuration-initial-position (piece-cfg id)))))
|
||||
(define (piece-vel which id) (hash-ref (which) id (lambda () (vector 0 0))))
|
||||
(define (piece-imp id) (hash-ref (impulses) id (lambda () (vector 0 0))))
|
||||
|
||||
(define (update-piece! g new-pos new-vel)
|
||||
(positions (hash-set (positions) (game-piece-configuration-id g) new-pos))
|
||||
(velocities (hash-set (velocities) (game-piece-configuration-id g) new-vel)))
|
||||
|
||||
(define (find-support p size which-pos)
|
||||
(match-define (vector p-left p-top) p)
|
||||
(match-define (vector p-w p-h) size)
|
||||
(define p-right (+ p-left p-w))
|
||||
(define p-bottom (+ p-top p-h))
|
||||
(for/or [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)]
|
||||
(match-define (vector left top) (piece-pos which-pos id))
|
||||
(and (< (abs (- top p-bottom)) 0.5)
|
||||
(<= left p-right)
|
||||
(match (game-piece-configuration-size g)
|
||||
[(vector w h)
|
||||
(<= p-left (+ left w))])
|
||||
g)))
|
||||
|
||||
(define (segment-intersection-time p0 r q0 q1)
|
||||
;; See http://stackoverflow.com/a/565282/169231
|
||||
;; Enhanced to consider the direction of impact with the segment,
|
||||
;; too: only returns an intersection when the vector of motion is
|
||||
;; at an obtuse angle to the normal of the segment.
|
||||
(define s (v- q1 q0))
|
||||
(define rxs (vcross2 r s))
|
||||
(cond [(< (abs rxs) 0.005) #f] ;; zeroish; lines are parallel (and maybe collinear)
|
||||
[else
|
||||
(define q-p (v- q0 p0))
|
||||
(define q-pxs (vcross2 q-p s))
|
||||
(define t (/ q-pxs rxs))
|
||||
(and (<= 0 t 1)
|
||||
(let* ((q-pxr (vcross2 q-p r))
|
||||
(u (/ q-pxr rxs)))
|
||||
(and (< 0 u 1)
|
||||
(let* ((q-norm
|
||||
(vnormalize (vector (vector-ref s 1) (- (vector-ref s 0))))))
|
||||
(and (not (positive? (vdot r q-norm)))
|
||||
(- t 0.001))))))]))
|
||||
|
||||
(define (three-corners top-left size)
|
||||
(match-define (vector w h) size)
|
||||
(values (v+ top-left (vector w 0))
|
||||
(v+ top-left size)
|
||||
(v+ top-left (vector 0 h))))
|
||||
|
||||
(define (clip-movement-by top-left moved-top-left size solid-top-left solid-size)
|
||||
(define-values (solid-top-right solid-bottom-right solid-bottom-left)
|
||||
(three-corners solid-top-left solid-size))
|
||||
(define-values (top-right bottom-right bottom-left)
|
||||
(three-corners top-left size))
|
||||
(define r (v- moved-top-left top-left))
|
||||
(define t
|
||||
(apply min
|
||||
(for/list [(p (in-list (list #;top-left #;top-right bottom-right bottom-left)))]
|
||||
(min (or (segment-intersection-time p r solid-top-left solid-top-right) 1)
|
||||
;; TODO: some means of specifying *which edges* should appear solid.
|
||||
#;(or (segment-intersection-time p r solid-top-right solid-bottom-right) 1)
|
||||
#;(or (segment-intersection-time p r solid-bottom-right solid-bottom-left) 1)
|
||||
#;(or (segment-intersection-time p r solid-bottom-left solid-top-left) 1)))))
|
||||
(v+ top-left (v* r t)))
|
||||
|
||||
(define (clip-movement-by-solids p0 p1 size)
|
||||
(for/fold [(p1 p1)]
|
||||
[((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)]
|
||||
(clip-movement-by p0 p1 size
|
||||
(piece-pos previous-positions id)
|
||||
(game-piece-configuration-size g))))
|
||||
|
||||
(define (touched-during-movement? TL moved-TL size touchable-TL touchable-size)
|
||||
(define r (v- moved-TL TL))
|
||||
(if (positive? (vmag^2 r)) ;; r is nonzero, in other words
|
||||
(let ()
|
||||
(define-values (touchable-TR touchable-BR touchable-BL)
|
||||
(three-corners touchable-TL touchable-size))
|
||||
(define-values (TR BR BL)
|
||||
(three-corners TL size))
|
||||
(for/or [(p (in-list (list TL TR BR BL)))]
|
||||
(or
|
||||
(and (segment-intersection-time p r touchable-TR touchable-BR) 'right)
|
||||
(and (segment-intersection-time p r touchable-BR touchable-BL) 'bottom)
|
||||
(and (segment-intersection-time p r touchable-BL touchable-TL) 'left)
|
||||
(and (segment-intersection-time p r touchable-TL touchable-TR) 'top))))
|
||||
(let ()
|
||||
(match-define (vector left top) TL)
|
||||
(match-define (vector touchable-left touchable-top) touchable-TL)
|
||||
(match-define (vector width height) size)
|
||||
(match-define (vector touchable-width touchable-height) touchable-size)
|
||||
(and (<= left (+ touchable-left touchable-width))
|
||||
(<= top (+ touchable-top touchable-height))
|
||||
(<= touchable-left (+ left width))
|
||||
(<= touchable-top (+ top height))
|
||||
'mid))))
|
||||
|
||||
(define (touchables-touched-during-movement p0 p1 size)
|
||||
(for/fold [(ts '())]
|
||||
[((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'touchable)]
|
||||
(define side (touched-during-movement? p0 p1 size
|
||||
(piece-pos previous-positions id)
|
||||
(game-piece-configuration-size g)))
|
||||
(if side (cons (cons side g) ts) ts)))
|
||||
|
||||
(define (update-game-piece! elapsed-ms id)
|
||||
(define g (piece-cfg id))
|
||||
(define size (game-piece-configuration-size g))
|
||||
(define pos0 (piece-pos previous-positions id))
|
||||
(define support (find-support pos0 size previous-positions))
|
||||
|
||||
(define vel0 (piece-vel previous-velocities id))
|
||||
(define imp0 (piece-imp id))
|
||||
|
||||
(define vel1 (cond
|
||||
[(and support (not (negative? (vector-ref vel0 1))))
|
||||
(piece-vel previous-velocities (game-piece-configuration-id support))]
|
||||
[(game-piece-has-attribute? g 'massive)
|
||||
(v+ vel0 (vector 0 (* gravity elapsed-ms)))]
|
||||
[else
|
||||
vel0]))
|
||||
|
||||
(define pos1 (v+ pos0 (v* (v+ vel1 imp0) (* impulse-multiplier elapsed-ms))))
|
||||
(define final-pos (clip-movement-by-solids pos0 pos1 size))
|
||||
;; TODO: figure out how to cancel just the component of velocity blocked by the obstacle(s)
|
||||
;; - which will avoid the "sticking to the wall" artifact
|
||||
(define final-vel (if (v= pos1 final-pos) vel1 (vector 0 0))) ;; stop at collision
|
||||
(define touchables (touchables-touched-during-movement pos0 final-pos size))
|
||||
|
||||
(for [(a (in-bag (current-adhoc-assertions)))]
|
||||
(when (touching? a)
|
||||
(retract! a +inf.0)))
|
||||
(for [(t touchables)]
|
||||
(match-define (cons side tg) t)
|
||||
(assert! (touching id (game-piece-configuration-id tg) side)))
|
||||
(update-piece! g final-pos final-vel))
|
||||
|
||||
(on (message (jump-request $id))
|
||||
(define g (piece-cfg id))
|
||||
(define pos (piece-pos positions id))
|
||||
(when (find-support pos (game-piece-configuration-size g) positions)
|
||||
(play-sound-sequence 270318)
|
||||
(update-piece! g pos jump-vel)))
|
||||
|
||||
(define start-time #f)
|
||||
(on (message (inbound (inbound (frame-event $counter _ _ _))))
|
||||
(let ((stop-time (current-inexact-milliseconds)))
|
||||
(when (not (eq? start-time #f))
|
||||
(define elapsed-ms (- stop-time start-time))
|
||||
(when (zero? (modulo counter 10))
|
||||
(log-info "Instantaneous frame rate at frame ~a: ~a Hz"
|
||||
counter
|
||||
(/ 1000.0 elapsed-ms)))
|
||||
(previous-positions (positions))
|
||||
(previous-velocities (velocities))
|
||||
(for [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'mobile)]
|
||||
(update-game-piece! elapsed-ms id)))
|
||||
(set! start-time stop-time)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Player
|
||||
|
||||
(define player-id 'player)
|
||||
(define planetcute-scale 1/2)
|
||||
|
||||
(define (spawn-player-avatar initial-focus-x initial-focus-y)
|
||||
(spawn #:name 'player-avatar
|
||||
(define i (icon character-cat-girl planetcute-scale 2/6 3/10 13/16))
|
||||
(define initial-top-left (focus->top-left i initial-focus-x initial-focus-y))
|
||||
|
||||
(assert (game-piece-configuration player-id
|
||||
initial-top-left
|
||||
(icon-hitbox-size i)
|
||||
(set 'player 'mobile 'massive)))
|
||||
|
||||
(define/query-value pos initial-top-left (position player-id $hitbox-top-left _)
|
||||
hitbox-top-left)
|
||||
(assert (outbound (outbound (icon-sprite i 0 (pos)))))
|
||||
|
||||
(field [hit-points 1])
|
||||
(assert (health player-id (hit-points)))
|
||||
(stop-when-true (<= (hit-points) 0))
|
||||
(on (message (damage player-id $amount))
|
||||
(hit-points (- (hit-points) amount)))
|
||||
|
||||
(on (asserted (inbound (inbound (key-pressed #\space)))) (send! (jump-request player-id)))
|
||||
(on (asserted (inbound (inbound (key-pressed #\.)))) (send! (jump-request player-id)))
|
||||
|
||||
(define/query-set keys-down (inbound (inbound (key-pressed $k))) k)
|
||||
(define (any-key-down? . ks) (for/or [(k ks)] (set-member? (keys-down) k)))
|
||||
(assert (impulse player-id (vector (+ (if (any-key-down? 'left 'prior) -1 0)
|
||||
(if (any-key-down? 'right 'next) 1 0))
|
||||
0)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Ground Block
|
||||
|
||||
(define (spawn-ground-block top-left size #:color [color "purple"])
|
||||
(spawn #:name (list 'ground-block top-left size color)
|
||||
(match-define (vector x y) top-left)
|
||||
(match-define (vector w h) size)
|
||||
(define block-id (gensym 'ground-block))
|
||||
(define block-pict (rectangle w h "solid" color))
|
||||
(assert (outbound (outbound (simple-sprite 0 x y w h block-pict))))
|
||||
(assert (game-piece-configuration block-id
|
||||
top-left
|
||||
size
|
||||
(set 'solid)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Goal piece
|
||||
;;
|
||||
;; When the player touches a goal, sends LevelCompleted one layer out.
|
||||
|
||||
(define (spawn-goal-piece initial-focus-x initial-focus-y)
|
||||
(define goal-id (gensym 'goal))
|
||||
|
||||
(define i (icon key planetcute-scale 1/3 2/5 4/5))
|
||||
(define initial-top-left (focus->top-left i initial-focus-x initial-focus-y))
|
||||
|
||||
(spawn #:name (list 'goal-piece initial-focus-x initial-focus-y)
|
||||
(on (asserted (touching player-id goal-id _))
|
||||
(send! (outbound (level-completed))))
|
||||
(assert (game-piece-configuration goal-id
|
||||
initial-top-left
|
||||
(icon-hitbox-size i)
|
||||
(set 'touchable)))
|
||||
(assert (outbound (outbound (icon-sprite i -1 initial-top-left))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Enemy
|
||||
|
||||
(define (spawn-enemy initial-x initial-y range-lo range-hi
|
||||
#:speed [speed 0.2]
|
||||
#:facing [initial-facing 'right])
|
||||
(spawn #:name (list 'enemy initial-x initial-y initial-facing)
|
||||
(define enemy-id (gensym 'enemy))
|
||||
(define i (icon enemy-bug planetcute-scale 9/10 1/3 5/6))
|
||||
(define i-flipped (struct-copy icon i [pict (flip-horizontal (icon-pict i))]))
|
||||
(define initial-top-left (focus->top-left i initial-x initial-y))
|
||||
(match-define (vector width height) (icon-hitbox-size i))
|
||||
|
||||
(assert (game-piece-configuration enemy-id
|
||||
initial-top-left
|
||||
(icon-hitbox-size i)
|
||||
(set 'mobile 'massive 'touchable)))
|
||||
|
||||
(define/query-value current-level-size #f (level-size $v) v)
|
||||
|
||||
(define/query-value pos initial-top-left (position enemy-id $top-left _) top-left
|
||||
#:on-add (match-let (((vector left top) top-left))
|
||||
(facing (cond [(< left range-lo) 'right]
|
||||
[(> (+ left width) range-hi) 'left]
|
||||
[else (facing)]))))
|
||||
|
||||
(stop-when-true (and (current-level-size)
|
||||
(> (vector-ref (pos) 1)
|
||||
(vector-ref (current-level-size) 1))))
|
||||
|
||||
(field [facing initial-facing])
|
||||
(assert (outbound (outbound
|
||||
(icon-sprite (match (facing) ['right i] ['left i-flipped]) -1 (pos)))))
|
||||
|
||||
(assert (impulse enemy-id (vector (* speed (match (facing) ['right 1] ['left -1])) 0)))
|
||||
|
||||
(stop-when (asserted (touching player-id enemy-id 'top))
|
||||
(play-sound-sequence 270325)
|
||||
(send! (outbound (add-to-score 1))))
|
||||
|
||||
(on (asserted (touching player-id enemy-id $side))
|
||||
(when (not (eq? side 'top)) (send! (damage player-id 1))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; DisplayControl
|
||||
|
||||
(define (spawn-display-controller level-size-vec)
|
||||
(match-define (vector level-width level-height) level-size-vec)
|
||||
|
||||
(spawn #:name 'display-controller
|
||||
(field [offset-pos (vector 0 0)])
|
||||
(assert (outbound (outbound (scroll-offset (offset-pos)))))
|
||||
(assert (level-size level-size-vec))
|
||||
|
||||
(define/query-value window-size-vec #f (inbound (inbound (window $w $h))) (vector w h))
|
||||
|
||||
(define (compute-offset pos viewport limit)
|
||||
(min (max 0 (- pos (/ viewport 2))) (- limit viewport)))
|
||||
|
||||
(on (asserted (position player-id (vector $px $py) _))
|
||||
(when (window-size-vec)
|
||||
(match-define (vector ww wh) (window-size-vec))
|
||||
(when (> py level-height) (send! (damage player-id +inf.0)))
|
||||
(offset-pos (vector (compute-offset px ww level-width)
|
||||
(compute-offset py wh level-height)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; LevelTerminationMonitor
|
||||
;;
|
||||
;; When the player vanishes from the board, or LevelCompleted is seen,
|
||||
;; kills the dataspace.
|
||||
|
||||
(define (wait-for-level-termination)
|
||||
(spawn #:name 'wait-for-level-termination
|
||||
(assert (outbound (level-running)))
|
||||
(on (retracted (game-piece-configuration player-id _ _ _))
|
||||
(log-info "Player died! Terminating level.")
|
||||
(play-sound-sequence 270328)
|
||||
(quit-dataspace!))
|
||||
(on (message (inbound (level-completed)))
|
||||
(log-info "Level completed! Terminating level.")
|
||||
(play-sound-sequence 270330)
|
||||
(send! (outbound (add-to-score 100)))
|
||||
(quit-dataspace!))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; LevelSpawner
|
||||
|
||||
(define (spawn-background-image level-size scene)
|
||||
(match-define (vector level-width level-height) level-size)
|
||||
(define scene-width (image-width scene))
|
||||
(define scene-height (image-height scene))
|
||||
(define level-aspect (/ level-width level-height))
|
||||
(define scene-aspect (/ scene-width scene-height))
|
||||
(define scale (if (> level-aspect scene-aspect) ;; level is wider, proportionally, than scene
|
||||
(/ level-width scene-width)
|
||||
(/ level-height scene-height)))
|
||||
(spawn #:name 'background-image
|
||||
(assert (outbound
|
||||
(outbound
|
||||
(sprite 10
|
||||
`((scale ,(* scene-width scale)
|
||||
,(* scene-height scale))
|
||||
(texture ,scene))))))))
|
||||
|
||||
;; http://www.travelization.net/wp-content/uploads/2012/07/beautiful-grassland-wallpapers-1920x1080.jpg
|
||||
(define grassland-backdrop (bitmap "../../examples/platformer/beautiful-grassland-wallpapers-1920x1080.jpg"))
|
||||
|
||||
(define (spawn-level #:initial-player-x [initial-player-x 50]
|
||||
#:initial-player-y [initial-player-y 50]
|
||||
#:level-size [level-size-vec (vector 4000 2000)]
|
||||
#:scene [scene grassland-backdrop]
|
||||
actions-thunk)
|
||||
(lambda ()
|
||||
(dataspace #:name 'level-dataspace
|
||||
(when scene (spawn-background-image level-size-vec scene))
|
||||
(spawn-display-controller level-size-vec)
|
||||
(spawn-physics-engine)
|
||||
(spawn-player-avatar initial-player-x initial-player-y)
|
||||
(actions-thunk)
|
||||
(wait-for-level-termination))))
|
||||
|
||||
(define standard-ground-height 50)
|
||||
|
||||
(define (slab left top width #:color [color "purple"])
|
||||
(spawn-ground-block (vector left top) (vector width standard-ground-height) #:color color))
|
||||
|
||||
(define levels
|
||||
(list
|
||||
(spawn-level (lambda ()
|
||||
(slab 25 125 100)
|
||||
(slab 50 300 500)
|
||||
(spawn-enemy 100 300 50 550)
|
||||
(spawn-enemy 300 300 50 550 #:facing 'left)
|
||||
(spawn-goal-piece 570 150)
|
||||
(slab 850 300 50)
|
||||
(slab 925 400 50)
|
||||
(slab 975 500 50)
|
||||
(slab 975 600 50)
|
||||
(slab 500 600 150 #:color "orange")))
|
||||
(spawn-level (lambda ()
|
||||
(slab 25 300 500)
|
||||
(slab 500 400 500)
|
||||
(slab 1000 500 400)
|
||||
(spawn-goal-piece 1380 500)))
|
||||
(spawn-level (lambda ()
|
||||
(slab 25 300 1000)
|
||||
(spawn-enemy 600 300 25 1025 #:facing 'left)
|
||||
(spawn-goal-piece 980 300)))
|
||||
(spawn-level (lambda ()
|
||||
(spawn-goal-piece 250 280)
|
||||
(spawn-enemy 530 200 400 600)
|
||||
(spawn-enemy 500 200 -100 1000 #:facing 'left)
|
||||
(slab 400 200 200)
|
||||
(spawn-ground-block (vector 200 280) (vector 200 200) #:color "orange")
|
||||
(slab 25 300 500)
|
||||
(slab 600 1300 600)
|
||||
(slab 1150 1200 25 #:color "red")
|
||||
(for/list ((n 10))
|
||||
(slab 900 (+ 200 (* n 100)) 50)))
|
||||
)
|
||||
))
|
||||
|
||||
(define (spawn-numbered-level level-number)
|
||||
(if (< level-number (length levels))
|
||||
((list-ref levels level-number))
|
||||
(spawn #:name 'victory-message
|
||||
(assert (outbound
|
||||
(let ((message (text "You won!" 72 "red")))
|
||||
(simple-sprite 0
|
||||
10
|
||||
100
|
||||
(image-width message)
|
||||
(image-height message)
|
||||
message)))))))
|
||||
|
||||
(define (spawn-level-spawner starting-level)
|
||||
(spawn #:name 'level-spawner
|
||||
(field [current-level starting-level]
|
||||
[level-complete? #f])
|
||||
|
||||
(on (message (level-completed)) (level-complete? #t))
|
||||
|
||||
(on (retracted (level-running))
|
||||
(current-level (if (level-complete?) (+ (current-level) 1) (current-level)))
|
||||
(level-complete? #f)
|
||||
(spawn-numbered-level (current-level)))
|
||||
|
||||
(on-start (spawn-numbered-level starting-level))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Sounds
|
||||
|
||||
(require racket/runtime-path)
|
||||
(begin-for-declarations
|
||||
(define-runtime-path sounds-path "../../examples/platformer/sounds"))
|
||||
(define (lookup-sound-file sound-number)
|
||||
(define sought-prefix (build-path sounds-path (format "~a__" sound-number)))
|
||||
(for/or [(filename (in-directory sounds-path))]
|
||||
(and (string-prefix? (path->string filename) (path->string sought-prefix))
|
||||
filename)))
|
||||
|
||||
;; TODO: make this a sound driver...
|
||||
;; TODO: ...and make sound triggering based on assertions of game
|
||||
;; state, not hardcoding in game logic
|
||||
(define (play-sound-sequence . sound-numbers)
|
||||
(thread (lambda ()
|
||||
(for [(sound-number (in-list sound-numbers))]
|
||||
(define sound-file (lookup-sound-file sound-number))
|
||||
(play-sound sound-file #f)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(spawn-keyboard-integrator)
|
||||
(spawn-scene-manager)
|
||||
(spawn-gl-2d-driver #:width 600 #:height 400)
|
||||
(dataspace #:name 'game-dataspace
|
||||
(spawn-score-keeper)
|
||||
(spawn-level-spawner 0))
|
|
@ -0,0 +1,22 @@
|
|||
# Simple GUI experiments using Syndicate
|
||||
|
||||
This directory contains UI experiments using
|
||||
[Syndicate](http://syndicate-lang.org/) and its OpenGL 2D support.
|
||||
|
||||
Files:
|
||||
|
||||
- `gui.rkt`: Main entry point. Run `racket gui.rkt` to run the demo.
|
||||
|
||||
- `layout/`: A simple widget layout engine, loosely inspired by TeX's boxes-and-glue model.
|
||||
|
||||
- `sizing.rkt`: TeX-like "dimensions", including "fills"
|
||||
|
||||
- `layout.rkt`: Uses "dimensions" to specify "table layouts",
|
||||
which are then realized in terms of specified rectangle
|
||||
coordinates
|
||||
|
||||
- `hsv.rkt`: Utility for converting HSV colors to RGB.
|
||||
|
||||
Screenshot:
|
||||
|
||||
![Syndicate GUI screenshot](syndicate-gui-snapshot.png)
|
|
@ -0,0 +1,662 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require racket/set)
|
||||
(require data/order)
|
||||
(require srfi/19)
|
||||
(require (prefix-in i: 2htdp/image))
|
||||
(require (prefix-in p: pict))
|
||||
(require syndicate-gl/affine)
|
||||
(require "layout/main.rkt")
|
||||
(require "hsv.rkt")
|
||||
(require imperative-syndicate/bag)
|
||||
(require imperative-syndicate/pattern)
|
||||
|
||||
(require/activate imperative-syndicate/drivers/gl-2d)
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define theme-font (make-parameter "Roboto"))
|
||||
(define theme-font-size (make-parameter 16))
|
||||
(define theme-title-font (make-parameter "Roboto Condensed"))
|
||||
(define theme-title-font-size (make-parameter 20))
|
||||
(define theme-title-font-color (make-parameter "white"))
|
||||
(define theme-title-bar-color (make-parameter (hsv->color 260 1 0.6)))
|
||||
(define theme-title-bar-selected-color (make-parameter (hsv->color 260 1 1)))
|
||||
(define theme-title-bar-height (make-parameter 48))
|
||||
(define theme-button-background-color (make-parameter (hsv->color 30 0.9 1)))
|
||||
(define theme-button-color (make-parameter "white"))
|
||||
(define theme-button-x-padding (make-parameter 40))
|
||||
(define theme-button-y-padding (make-parameter 24))
|
||||
(define theme-button-min-height (make-parameter 48))
|
||||
(define theme-window-border-width (make-parameter 8))
|
||||
(define theme-window-resize-corner-size (make-parameter 16))
|
||||
(define theme-menu-item-color (make-parameter "white"))
|
||||
(define theme-menu-item-background-color (make-parameter (hsv->color 240 1 0.8)))
|
||||
(define theme-menu-item-selected-background-color (make-parameter (hsv->color 345 1 1)))
|
||||
(define theme-menu-item-padding (make-parameter 16))
|
||||
(define theme-menu-separator-width (make-parameter 2))
|
||||
(define theme-menu-separator-color (make-parameter "white"))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (*width x)
|
||||
(cond [(i:image? x) (i:image-width x)]
|
||||
[(p:pict? x) (p:pict-width x)]
|
||||
[else (error '*width "Neither an image nor a pict: ~v" x)]))
|
||||
|
||||
(define (*height x)
|
||||
(cond [(i:image? x) (i:image-height x)]
|
||||
[(p:pict? x) (p:pict-height x)]
|
||||
[else (error '*height "Neither an image nor a pict: ~v" x)]))
|
||||
|
||||
(define (costume #:id [id #f] #:parent [parent-id #f] #:coordinate-map-id [coordinate-map-id #f] i)
|
||||
(define iw (*width i))
|
||||
(define ih (*height i))
|
||||
(define iaspect (/ iw ih))
|
||||
(lambda (z rect)
|
||||
(match-define (rectangle left top sw sh) rect)
|
||||
(define saspect (if (and (positive? sw) (positive? sh)) (/ sw sh) 1))
|
||||
(define-values (scale-w scale-h translate-x translate-y)
|
||||
(if (> saspect iaspect)
|
||||
(let ((scale-h (/ sw iaspect)))
|
||||
(values sw scale-h 0 (/ (- sh scale-h) 2)))
|
||||
(let ((scale-w (* sh iaspect)))
|
||||
(values scale-w sh (/ (- sw scale-w) 2) 0))))
|
||||
(sprite #:id (or id (gensym 'costume))
|
||||
#:parent parent-id
|
||||
z
|
||||
`((translate ,left ,top)
|
||||
(push-matrix (scale ,sw ,sh)
|
||||
,@(if id
|
||||
`((touchable ,id ,in-unit-square?))
|
||||
`())
|
||||
,@(if coordinate-map-id
|
||||
`((coordinate-map ,coordinate-map-id))
|
||||
`())
|
||||
(texture ,i
|
||||
,(- (/ translate-x scale-w))
|
||||
,(- (/ translate-y scale-h))
|
||||
,(/ sw scale-w)
|
||||
,(/ sh scale-h)
|
||||
))
|
||||
(render-children)))))
|
||||
|
||||
(define (draggable-mixin touching? x y id-to-raise)
|
||||
(define (idle)
|
||||
(react (stop-when #:when (touching?)
|
||||
(message (mouse-event 'left-down (mouse-state $mx $my _ _ _)))
|
||||
(dragging (- mx (x)) (- my (y))))))
|
||||
|
||||
(define (dragging dx dy)
|
||||
(when id-to-raise (send! (raise-widget id-to-raise)))
|
||||
(react (on (message (mouse-event 'motion (mouse-state $mx $my _ _ _)))
|
||||
(x (- mx dx))
|
||||
(y (- my dy)))
|
||||
(stop-when (message (mouse-event 'left-up _)) (idle))
|
||||
(stop-when (message (mouse-event 'leave _)) (idle))))
|
||||
|
||||
(idle))
|
||||
|
||||
(spawn #:name 'root-window
|
||||
(define c (costume #:id 'root (i:bitmap "oakura-beach-20081225.jpg")))
|
||||
(define/query-value touching? #f (touching 'root) #t)
|
||||
(on #:when (touching?) (message (mouse-event 'right-down (mouse-state $x $y _ _ _)))
|
||||
(send! (pop-up-menu-trigger 'system-menu x y 0 0.5 'right-up)))
|
||||
;; (during (window $width $height)
|
||||
;; (assert-scene `((translate ,width 0) (rotate -90)) `())
|
||||
;; (assert (desktop height width))
|
||||
;; (assert (c 0 (rectangle 0 0 height width))))
|
||||
(during (window $width $height)
|
||||
(assert (desktop width height))
|
||||
(assert (c 0 (rectangle 0 0 width height))))
|
||||
)
|
||||
|
||||
(define (button-underlay i)
|
||||
(define w (+ (*width i) (theme-button-x-padding)))
|
||||
(define h (max (+ (*height i) (theme-button-y-padding)) (theme-button-min-height)))
|
||||
(i:rectangle w h "solid" (theme-button-background-color)))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; Protocol: Layout.
|
||||
;;---------------------------------------------------------------------------
|
||||
;; Roles:
|
||||
;;
|
||||
;; Layout Solver
|
||||
;; Responds to assertions of interest in layout solutions by
|
||||
;; computing layouts and asserting the resulting positions.
|
||||
;;
|
||||
;; (Observe LayoutSolution)+ ==>
|
||||
;; RequestedLayoutSize ==>
|
||||
;; ComputedLayoutSize ∧ LayoutSolution+
|
||||
;;
|
||||
;; Layout Observer
|
||||
;; Supplies any initial constraints on the overall layout size,
|
||||
;; and may observe the final overall computed layout size.
|
||||
;;
|
||||
;; RequestedLayoutSize ∧ (ComputedLayoutSize ==> 1)?
|
||||
;;
|
||||
;; Layout Participant
|
||||
;; Supplies constraints on an individual item to be laid out
|
||||
;; and monitors the resulting position decision for that item.
|
||||
;;
|
||||
;; LayoutSolution ==> 1
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
;; A LayoutSpec is one of
|
||||
;; - (horizontal-layout Any)
|
||||
;; - (vertical-layout Any)
|
||||
;; - (tabular-layout Nat Nat)
|
||||
;; where the first two use their keys for *ordering* peers relative to
|
||||
;; each other using datum-order, and the last uses the given row and
|
||||
;; column to place the item within an implicitly-sized grid layout.
|
||||
(struct horizontal-layout (key) #:transparent)
|
||||
(struct vertical-layout (key) #:transparent)
|
||||
(struct tabular-layout (row col) #:transparent)
|
||||
|
||||
;; ASSERTION. A RequestedLayoutSize is a
|
||||
;; (requested-layout-size Any (Option (box-size (Option Sizing) (Option Sizing))))
|
||||
;; and describes overall constraints on the total size of the layout to be
|
||||
;; constructed. Supplying `size` as `#f` means that there is no constraint at all;
|
||||
;; otherwise, the `box-size` given is used as the exact dimensions of
|
||||
;; the layout, unless one or both of the dimensions of the `box-size`
|
||||
;; are given as `#f`, in which case there is no constraint for that
|
||||
;; dimension.
|
||||
(struct requested-layout-size (container-id size) #:transparent)
|
||||
|
||||
;; ASSERTION. A ComputedLayoutSize is a
|
||||
;; (computed-layout-size Any BoxSize)
|
||||
;; and gives the concrete dimensions of the layout after layout
|
||||
;; computation has completed.
|
||||
(struct computed-layout-size (container-id size) #:transparent)
|
||||
|
||||
;; ASSERTION. A LayoutSolution is a
|
||||
;; (layout-solution Any LayoutSpec BoxSize Rectangle)
|
||||
;; and denotes the computed bounds of a given item within a layout.
|
||||
;; TODO: introduce an item ID??
|
||||
(struct layout-solution (container-id
|
||||
spec
|
||||
size
|
||||
rectangle) #:transparent)
|
||||
|
||||
;; ASSERTION. Describes the size of the desktop area.
|
||||
(struct desktop (width height) #:transparent)
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(struct layout-item (spec size) #:transparent)
|
||||
|
||||
(define (layout-item-spec-key li)
|
||||
(define v (layout-item-spec li))
|
||||
(if (number? v) (exact->inexact v) v))
|
||||
|
||||
(spawn #:name 'layout-driver
|
||||
(during/spawn (observe (layout-solution $container-id _ _ _))
|
||||
#:name (list 'layout container-id)
|
||||
(stop-when (asserted (observe (layout-solution container-id (horizontal-layout _) _ _)))
|
||||
(react (solve-hv-layout #f container-id)))
|
||||
(stop-when (asserted (observe (layout-solution container-id (vertical-layout _) _ _)))
|
||||
(react (solve-hv-layout #t container-id)))
|
||||
(stop-when (asserted (observe (layout-solution container-id (tabular-layout _ _) _ _)))
|
||||
(react (solve-tabular-layout container-id)))))
|
||||
|
||||
(define (solve-hv-layout vertical? container-id)
|
||||
(field [items (set)])
|
||||
|
||||
(if vertical?
|
||||
(query-set* items
|
||||
(observe (layout-solution container-id (vertical-layout $key) $size _))
|
||||
(layout-item key size))
|
||||
(query-set* items
|
||||
(observe (layout-solution container-id (horizontal-layout $key) $size _))
|
||||
(layout-item key size)))
|
||||
|
||||
(define/dataflow ordered-items (sort (set->list (items))
|
||||
(order-<? datum-order)
|
||||
#:key layout-item-spec-key)
|
||||
#:default '())
|
||||
|
||||
(define/dataflow table
|
||||
(if vertical?
|
||||
(map list (map layout-item-size (ordered-items)))
|
||||
(list (map layout-item-size (ordered-items)))))
|
||||
|
||||
(solve-layout* container-id
|
||||
table
|
||||
(lambda (layout)
|
||||
(for [(item (ordered-items))
|
||||
(cell (if vertical? (map car layout) (car layout)))]
|
||||
(assert! (layout-solution container-id
|
||||
(if vertical?
|
||||
(vertical-layout (layout-item-spec item))
|
||||
(horizontal-layout (layout-item-spec item)))
|
||||
(layout-item-size item)
|
||||
cell))))))
|
||||
|
||||
(define (merge-box-size existing computed)
|
||||
(match existing
|
||||
[#f computed]
|
||||
[(box-size h v)
|
||||
(box-size (or h (box-size-horizontal computed))
|
||||
(or v (box-size-vertical computed)))]))
|
||||
|
||||
(define (solve-layout* container-id table on-layout)
|
||||
(during (requested-layout-size container-id $reqsize)
|
||||
(define/dataflow total-size (merge-box-size reqsize (table-sizing (table))))
|
||||
(assert (computed-layout-size container-id (total-size)))
|
||||
(define (total-width) (sizing-ideal (box-size-horizontal (total-size))))
|
||||
(define (total-height) (sizing-ideal (box-size-vertical (total-size))))
|
||||
(define/dataflow layout (table-layout (table) 0 0 (total-width) (total-height)) #:default '())
|
||||
(begin/dataflow
|
||||
(for [(a (in-bag (current-adhoc-assertions)))]
|
||||
(match a
|
||||
[(layout-solution (== container-id) _ _ _) (retract! a)]
|
||||
[_ (void)]))
|
||||
(on-layout (layout)))))
|
||||
|
||||
(define (solve-tabular-layout container-id)
|
||||
(define/query-set items
|
||||
(observe (layout-solution container-id (tabular-layout $row $col) $size _))
|
||||
(layout-item (cons row col) size))
|
||||
(define/dataflow items-table
|
||||
(let* ((specs (map layout-item-spec (set->list (items))))
|
||||
(row-count (+ 1 (apply max -1 (map car specs))))
|
||||
(col-count (+ 1 (apply max -1 (map cdr specs))))
|
||||
(mtx (for/vector [(r row-count)] (make-vector col-count #f))))
|
||||
(for [(item (items))]
|
||||
(vector-set! (vector-ref mtx (car (layout-item-spec item)))
|
||||
(cdr (layout-item-spec item))
|
||||
item))
|
||||
mtx))
|
||||
(define/dataflow table
|
||||
(for/list [(row (items-table))]
|
||||
(for/list [(item row)]
|
||||
(if item (layout-item-size item) weak-fill-box-size))))
|
||||
|
||||
(solve-layout* container-id
|
||||
table
|
||||
(lambda (layout)
|
||||
(define mtx (list->vector (map list->vector layout)))
|
||||
(for [(item (items))]
|
||||
(match-define (cons row col) (layout-item-spec item))
|
||||
(assert! (layout-solution container-id
|
||||
(tabular-layout row col)
|
||||
(layout-item-size item)
|
||||
(vector-ref (vector-ref mtx row) col)))))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
;; TODO: Having pop-up-menu-trigger be a message means that it's not
|
||||
;; possible to cancel or move the menu once it has been triggered.
|
||||
;; Consider using the "start" button in the corner to pop up a menu,
|
||||
;; following which the screen is resized before the menu is dismissed.
|
||||
;; Currently, the menu will continue to float in an incorrect location
|
||||
;; rather than following the screen resize. If, however, the trigger
|
||||
;; for a menu was an assertion, then the menu could track changes in
|
||||
;; its triggering parameters and could be repositioned without fuss.
|
||||
|
||||
(struct pop-up-menu-trigger (menu-id x y x-pin y-pin release-event) #:transparent)
|
||||
(struct menu-separator (menu-id order) #:transparent)
|
||||
(struct menu-item (menu-id order image message) #:transparent)
|
||||
|
||||
(spawn #:name 'pop-up-menu-driver
|
||||
(on (message (pop-up-menu-trigger $menu-id $x $y $x-pin $y-pin $release-event))
|
||||
(run-pop-up-menu menu-id x y x-pin y-pin release-event)))
|
||||
|
||||
(define (run-pop-up-menu menu-id pop-up-cursor-x pop-up-cursor-y x-pin y-pin release-event)
|
||||
(define instance-id (list menu-id (gensym 'instance)))
|
||||
(define pad (theme-menu-item-padding))
|
||||
(define pad2 (* pad 2))
|
||||
(define normal (i:rectangle 1 1 "solid" (theme-menu-item-background-color)))
|
||||
(define highlight (i:rectangle 1 1 "solid" (theme-menu-item-selected-background-color)))
|
||||
(define separator (i:rectangle 1 1 "solid" (theme-menu-separator-color)))
|
||||
(spawn #:name instance-id
|
||||
(assert (requested-layout-size instance-id #f))
|
||||
(during (menu-item menu-id $order $sealed-image $msg)
|
||||
(define item-id (gensym 'item))
|
||||
(define im (seal-contents sealed-image))
|
||||
(define imsize (box-size (sizing (+ pad2 (*width im)) 0 0)
|
||||
(sizing (+ pad2 (*height im)) 0 0)))
|
||||
(during (layout-solution instance-id (vertical-layout order) imsize $rect)
|
||||
(match-define (rectangle left top width height) rect)
|
||||
(assert (sprite #:id item-id #:parent instance-id
|
||||
0
|
||||
`((translate ,left ,top)
|
||||
(push-matrix
|
||||
(scale ,width ,height)
|
||||
(touchable (,instance-id ,item-id ,msg) ,in-unit-square?)
|
||||
(texture ,(if (eq? (selected-item) item-id) highlight normal)))
|
||||
(push-matrix
|
||||
(translate ,pad ,pad)
|
||||
(scale ,(*width im) ,(*height im))
|
||||
(texture ,im)))))))
|
||||
|
||||
(during (menu-separator menu-id $order)
|
||||
(define sep-id (gensym 'sep))
|
||||
(during (layout-solution instance-id (vertical-layout order)
|
||||
(box-size weak-fill-sizing
|
||||
(sizing (theme-menu-separator-width) 0 0))
|
||||
$rect)
|
||||
(match-define (rectangle left top width height) rect)
|
||||
(assert (sprite #:id sep-id #:parent instance-id
|
||||
0
|
||||
`((translate ,left ,top)
|
||||
(scale ,width ,height)
|
||||
(texture ,separator))))))
|
||||
|
||||
(during (computed-layout-size instance-id $menu-size)
|
||||
(match-define (box-size (sizing menu-width _ _) (sizing menu-height _ _)) menu-size)
|
||||
(define offset-x (- pop-up-cursor-x (* x-pin (+ menu-width 2)) -1))
|
||||
(define offset-y (- pop-up-cursor-y (* y-pin (+ menu-height 2)) -1))
|
||||
(assert (sprite #:id instance-id
|
||||
-1
|
||||
`((translate ,offset-x ,offset-y)
|
||||
(render-children)))))
|
||||
|
||||
(define/query-value selected-item #f (touching `(,instance-id ,$i ,_)) i)
|
||||
(define/query-value selected-msg #f (touching `(,instance-id ,_ ,$msg)) msg)
|
||||
(stop-when (message (mouse-event release-event _))
|
||||
(when (selected-item) (send! (selected-msg))))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (system-text str [color #f])
|
||||
(i:text/font str (theme-font-size) (or color "white")
|
||||
(theme-font) 'default 'normal 'normal #f))
|
||||
|
||||
(define (title-font-text str)
|
||||
(i:text/font str (theme-title-font-size) (theme-title-font-color)
|
||||
(theme-title-font) 'default 'normal 'normal #f))
|
||||
|
||||
(define (menu-item/text menu-id order str message)
|
||||
(menu-item menu-id order (seal (system-text str (theme-menu-item-color))) message))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(struct window-state (window-id title state) #:transparent)
|
||||
(struct raise-widget (id) #:transparent)
|
||||
(struct top-widget (id) #:transparent)
|
||||
|
||||
(define close-icon-i
|
||||
(parameterize ((theme-font-size (round (* 4/3 (theme-title-font-size)))))
|
||||
(system-text "×" (theme-title-font-color))))
|
||||
|
||||
(define (window-frame id title backdrop-color
|
||||
#:close-icon? [close-icon? #t]
|
||||
#:parent [parent-id 'root])
|
||||
(define title-text-i (title-font-text title))
|
||||
(define title-text-w (i:image-width title-text-i))
|
||||
(define title-text-h (i:image-height title-text-i))
|
||||
(define (title-bar-i focus?) (i:rectangle 1 1 "solid"
|
||||
(if focus?
|
||||
(theme-title-bar-selected-color)
|
||||
(theme-title-bar-color))))
|
||||
(define close-icon-w (i:image-width close-icon-i))
|
||||
(define close-icon-h (i:image-height close-icon-i))
|
||||
(define gap (/ (- (theme-title-bar-height) close-icon-w) 2))
|
||||
(define backdrop (i:rectangle 1 1 "solid" backdrop-color))
|
||||
(lambda (z rect focus?)
|
||||
(match-define (rectangle left top width height) rect)
|
||||
(sprite #:id id
|
||||
#:parent parent-id
|
||||
z
|
||||
`((translate ,left ,top)
|
||||
(push-matrix (translate ,(- (theme-window-border-width))
|
||||
,(- (theme-title-bar-height)))
|
||||
(scale ,(+ width (* 2 (theme-window-border-width)))
|
||||
,(+ height (theme-title-bar-height) (theme-window-border-width)))
|
||||
(touchable (,id window-backdrop) ,in-unit-square?)
|
||||
(texture ,(title-bar-i focus?)))
|
||||
(push-matrix (translate 0 ,(- (theme-title-bar-height)))
|
||||
(scale ,width ,(theme-title-bar-height))
|
||||
(touchable (,id title-bar) ,in-unit-square?))
|
||||
(push-matrix (translate ,(- (+ width (theme-window-border-width))
|
||||
(theme-window-resize-corner-size))
|
||||
,(- (+ height (theme-window-border-width))
|
||||
(theme-window-resize-corner-size)))
|
||||
(scale ,(theme-window-resize-corner-size)
|
||||
,(theme-window-resize-corner-size))
|
||||
(touchable (,id resize-corner) ,in-unit-square?))
|
||||
,@(if close-icon?
|
||||
`((push-matrix
|
||||
(translate ,gap ,(- (/ (+ (theme-title-bar-height) close-icon-h) 2)))
|
||||
(scale ,close-icon-w ,close-icon-h)
|
||||
(touchable (,id close-icon) ,in-unit-square?)
|
||||
(texture ,close-icon-i)))
|
||||
`())
|
||||
(push-matrix (translate ,(/ (- width title-text-w) 2)
|
||||
,(- (/ (+ (theme-title-bar-height) title-text-h) 2)))
|
||||
(scale ,title-text-w ,title-text-h)
|
||||
(texture ,title-text-i))
|
||||
(push-matrix (scale ,width ,height)
|
||||
(texture ,backdrop))
|
||||
(render-children)))))
|
||||
|
||||
(define (open-window window-id window-title x y width height [backdrop-color (hsv->color 200 1 1)]
|
||||
#:resizable? [resizable? #t])
|
||||
(define c (window-frame window-id window-title backdrop-color))
|
||||
|
||||
(field [z (- (current-inexact-milliseconds))])
|
||||
(define/query-value touching-title-bar?
|
||||
#f (touching `(,window-id title-bar)) #t)
|
||||
(on-start (draggable-mixin touching-title-bar? x y window-id))
|
||||
|
||||
(when resizable?
|
||||
(define/query-value touching-resize-corner?
|
||||
#f (touching `(,window-id resize-corner)) #t)
|
||||
(on-start (draggable-mixin touching-resize-corner? width height window-id)))
|
||||
|
||||
(define/query-value touching-close-icon?
|
||||
#f (touching `(,window-id close-icon)) #t)
|
||||
(stop-when #:when (touching-close-icon?) (message (mouse-event 'left-up _)))
|
||||
|
||||
(on (message (raise-widget window-id))
|
||||
(z (- (current-inexact-milliseconds))))
|
||||
|
||||
(define/query-value focus? #f (top-widget window-id) #t)
|
||||
|
||||
(define/dataflow bounds (rectangle (x) (y) (width) (height)) #:default zero-rectangle)
|
||||
(assert (window-state window-id window-title (bounds)))
|
||||
(assert (c (z) (bounds) (focus?))))
|
||||
|
||||
(spawn #:name 'top-widget-monitor
|
||||
(local-require data/heap)
|
||||
|
||||
(define *widget-heap* (make-heap (lambda (a b) (<= (cdr a) (cdr b)))))
|
||||
(field [widget-heap-version 0])
|
||||
(define (widget-heap) (begin (widget-heap-version) *widget-heap*)) ;; gross hack
|
||||
;; ^ this is to cope with the use of mutable data in a field.
|
||||
;; Field update only registers damage if the field *changes*, as detected by `equal?`.
|
||||
(define (trigger-dependencies!) (widget-heap-version (+ (widget-heap-version) 1)))
|
||||
|
||||
(on (asserted (<sprite> $id 'root $z _))
|
||||
(heap-add! (widget-heap) (cons id z))
|
||||
(trigger-dependencies!))
|
||||
(on (retracted (<sprite> $id 'root $z _))
|
||||
(heap-remove! (widget-heap) (cons id z))
|
||||
(trigger-dependencies!))
|
||||
|
||||
(assert #:when (positive? (heap-count (widget-heap)))
|
||||
(top-widget (car (heap-min (widget-heap))))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(struct button-click (id mouse-state) #:transparent)
|
||||
|
||||
(begin-for-declarations
|
||||
;; TODO: figure out what it is about (define (f #:x x) x) that
|
||||
;; mandates begin-for-declarations to hide it from syndicate/lang's
|
||||
;; local-expansion here :-(
|
||||
(define (pushbutton label-str x y [w #f] [h #f]
|
||||
#:shrink-x [shrink-x 0]
|
||||
#:id id
|
||||
#:coordinate-map-id [coordinate-map-id #f]
|
||||
#:parent parent-id
|
||||
#:trigger-event [trigger-event 'left-up])
|
||||
(define label (system-text label-str (theme-button-color)))
|
||||
(define i (i:overlay/align "middle" "middle" label (button-underlay label)))
|
||||
(define c (costume #:id id #:parent parent-id #:coordinate-map-id coordinate-map-id i))
|
||||
|
||||
(define/query-value touching? #f (touching id) #t)
|
||||
(on #:when (touching?) (message (mouse-event trigger-event $s))
|
||||
(send! (button-click id s)))
|
||||
(assert (c 0 (rectangle (x)
|
||||
(y)
|
||||
(or (and w (w)) (*width i))
|
||||
(or (and h (h)) (*height i)))))
|
||||
(box-size (sizing (*width i) 0 (* shrink-x (*width i))) (sizing (*height i) 0 0))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (enforce-minimum f v)
|
||||
(begin/dataflow (when (< (f) v) (f v))))
|
||||
|
||||
(begin-for-declarations
|
||||
(define (message-box title init-x init-y body #:id id)
|
||||
(define msg (system-text body))
|
||||
(spawn #:name (list 'message-box id)
|
||||
(field [x init-x]
|
||||
[y init-y]
|
||||
[width (max 250 (*width msg))]
|
||||
[height (max 100 (*height msg))])
|
||||
(open-window id title x y width height #:resizable? #f)
|
||||
(assert ((costume #:parent id msg)
|
||||
0
|
||||
(rectangle (/ (- (width) (*width msg)) 2)
|
||||
(/ (- (height) (*height msg)) 2)
|
||||
(*width msg)
|
||||
(*height msg)))))))
|
||||
|
||||
(spawn #:name 'test-window
|
||||
|
||||
(field [x 140] [y 140] [width 400] [height 300])
|
||||
(open-window 'w "Window Title" x y width height)
|
||||
(enforce-minimum width 300)
|
||||
(enforce-minimum height 300)
|
||||
|
||||
(assert (menu-item/text 'testmenu 0 "First item" '(testmenu first)))
|
||||
(assert (menu-item/text 'testmenu 1 "Second item" '(testmenu second)))
|
||||
(assert (menu-item/text 'testmenu 2 "Third item" '(testmenu third)))
|
||||
|
||||
(during (desktop $width $height)
|
||||
(on (message `(testmenu ,$which))
|
||||
(define box-id (gensym 'box))
|
||||
(message-box #:id box-id
|
||||
(date->string (seconds->date (current-seconds))
|
||||
"Selected at ~3")
|
||||
(random width) (random height)
|
||||
(format "~a" which))))
|
||||
|
||||
(pushbutton "Click me"
|
||||
(lambda () 100)
|
||||
(lambda () 100)
|
||||
#:id 'click-me #:parent 'w #:trigger-event 'left-down)
|
||||
(on (message (button-click 'click-me (mouse-state $x $y _ _ _)))
|
||||
(send! (pop-up-menu-trigger 'testmenu x y 0 0.5 'left-up))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(spawn #:name 'fullscreen-menu-item
|
||||
(field [fullscreen? #f])
|
||||
(assert (menu-item/text 'system-menu -1
|
||||
(if (fullscreen?)
|
||||
"Fullscreen ✓"
|
||||
"Fullscreen")
|
||||
'(system-menu toggle-fullscreen)))
|
||||
(assert (menu-separator 'system-menu -0.9))
|
||||
(on (message '(system-menu toggle-fullscreen))
|
||||
(fullscreen? (not (fullscreen?))))
|
||||
(assert #:when (fullscreen?) (gl-control 'fullscreen)))
|
||||
|
||||
(spawn #:name 'quit-menu-item
|
||||
(assert (menu-item/text 'system-menu 0 "Quit" '(system-menu quit)))
|
||||
(stop-when (message '(system-menu quit))
|
||||
(send! (gl-control 'stop)))
|
||||
(stop-when (message (key-event #\q #t _))
|
||||
(send! (gl-control 'stop))))
|
||||
|
||||
(spawn #:name 'toolbar
|
||||
|
||||
(field [window-width 0] [window-height 0])
|
||||
(on (asserted (desktop $w $h))
|
||||
(window-width w)
|
||||
(window-height h))
|
||||
|
||||
(define pad 4) ;;(theme-menu-item-padding))
|
||||
(define pad2 (* pad 2))
|
||||
|
||||
(assert (requested-layout-size 'toolbar (box-size (sizing (- (window-width) pad2) 0 0) #f)))
|
||||
(assert (observe (layout-solution 'toolbar
|
||||
(horizontal-layout '(0.0 0.0))
|
||||
weak-fill-box-size
|
||||
(discard))))
|
||||
|
||||
(during (computed-layout-size 'toolbar (box-size (sizing $w _ _) (sizing $h _ _)))
|
||||
(assert (sprite #:id 'toolbar #:parent #f
|
||||
-0.5
|
||||
`((translate 0 ,(- (window-height) h pad2))
|
||||
(push-matrix (scale ,(window-width) ,(+ h pad2))
|
||||
(touchable toolbar ,in-unit-square?)
|
||||
(texture ,(i:rectangle 1 1 "solid" "black")))
|
||||
(translate ,pad ,pad)
|
||||
(render-children))))))
|
||||
|
||||
(spawn #:name 'start-button
|
||||
(field [x 0] [y 0])
|
||||
(define reqsize
|
||||
(parameterize ((theme-button-y-padding 8)
|
||||
(theme-button-min-height 0))
|
||||
(pushbutton "Start" x y #:id 'start-button #:parent 'toolbar
|
||||
#:coordinate-map-id 'start-button
|
||||
#:trigger-event 'left-down)))
|
||||
(during (layout-solution 'toolbar (horizontal-layout '(-10.0 0.0)) reqsize
|
||||
(rectangle $l $t $w $h))
|
||||
(x l)
|
||||
(y t)
|
||||
(during (coordinate-map 'start-button $xform)
|
||||
(on (message (button-click 'start-button _))
|
||||
(define pt (- (transform-point xform 0+0i) 1+4i)) ;; padding + unoffset
|
||||
(send!
|
||||
(pop-up-menu-trigger 'system-menu (real-part pt) (imag-part pt) 0 1 'left-up))))))
|
||||
|
||||
(spawn #:name 'window-list-monitor
|
||||
(during/spawn (window-state $id $title _)
|
||||
#:name (list 'window-list id)
|
||||
(field [x 0] [y 0] [width #f] [height #f])
|
||||
(define reqsize
|
||||
(parameterize ((theme-button-y-padding 8)
|
||||
(theme-button-min-height 0)
|
||||
(theme-button-background-color (hsv->color 240 1 0.6)))
|
||||
(pushbutton title x y width height #:id (list 'window-list id) #:parent 'toolbar
|
||||
#:shrink-x 1
|
||||
#:trigger-event 'left-down)))
|
||||
(during (layout-solution 'toolbar (horizontal-layout `(-5.0 ,id)) reqsize
|
||||
(rectangle $l $t $w $h))
|
||||
(begin (x l) (y t) (width w) (height h))
|
||||
(during (top-widget id)
|
||||
(assert (sprite #:id (list 'window-list id 'highlight)
|
||||
#:parent (list 'window-list id)
|
||||
0
|
||||
`((translate 0 ,(- h 1))
|
||||
(scale ,w 1)
|
||||
(texture ,(i:rectangle 1 1 "solid" "white"))))))
|
||||
(on (message (button-click (list 'window-list id) _))
|
||||
(send! (raise-widget id))))))
|
||||
|
||||
(spawn #:name 'clock
|
||||
(field [now (current-seconds)])
|
||||
(on (message (frame-event _ $timestamp _ _))
|
||||
(define new (current-seconds))
|
||||
(when (not (= new (now))) (now new)))
|
||||
(define/dataflow now-im (system-text (date->string (seconds->date (now)) "~a ~b ~d, ~3"))
|
||||
#:default i:empty-image)
|
||||
(during (layout-solution 'toolbar (horizontal-layout '(10.0 0.0))
|
||||
(box-size (sizing (*width (now-im)) 0 0)
|
||||
(sizing (*height (now-im)) 0 0))
|
||||
(rectangle $l $t $w $h))
|
||||
(assert (sprite #:id 'clock #:parent 'toolbar
|
||||
0
|
||||
`((translate ,l ,(+ t (/ (- h (*height (now-im))) 2)))
|
||||
(scale ,(*width (now-im)) ,(*height (now-im)))
|
||||
(texture ,(now-im)))))))
|
||||
|
||||
(spawn-gl-2d-driver)
|
|
@ -0,0 +1,29 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide fmod
|
||||
hsv->color
|
||||
color-by-hash)
|
||||
|
||||
(require 2htdp/image)
|
||||
|
||||
(define (fmod a b)
|
||||
(- a (* b (truncate (/ a b)))))
|
||||
|
||||
(define (hsv->color h s v)
|
||||
(define h* (fmod (/ h 60.0) 6))
|
||||
(define chroma (* v s))
|
||||
(define x (* chroma (- 1 (abs (- (fmod h* 2) 1)))))
|
||||
(define-values (r g b)
|
||||
(cond
|
||||
[(< h* 1) (values chroma x 0)]
|
||||
[(< h* 2) (values x chroma 0)]
|
||||
[(< h* 3) (values 0 chroma x)]
|
||||
[(< h* 4) (values 0 x chroma)]
|
||||
[(< h* 5) (values x 0 chroma)]
|
||||
[else (values chroma 0 x)]))
|
||||
(define m (- v chroma))
|
||||
(define (scale x) (inexact->exact (truncate (* 255 (+ x m)))))
|
||||
(make-color (scale r) (scale g) (scale b)))
|
||||
|
||||
(define (color-by-hash v)
|
||||
(hsv->color (* 360.0 (/ (bitwise-and (equal-hash-code v) 16777215) 16777216.0)) 1 1))
|
|
@ -0,0 +1,191 @@
|
|||
#lang racket/base
|
||||
;; Tabular layout
|
||||
|
||||
(provide table-sizing
|
||||
table-layout)
|
||||
|
||||
(require racket/match)
|
||||
(require "sizing.rkt")
|
||||
|
||||
(module+ test (require rackunit))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (transpose rows)
|
||||
(if (null? rows)
|
||||
'()
|
||||
(apply map list rows)))
|
||||
|
||||
(define (swedish-round x)
|
||||
(floor (+ x 1/2)))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (table-sizing box-sizes)
|
||||
(box-size (sizing-sum (table-column-widths box-sizes))
|
||||
(sizing-sum (table-row-heights box-sizes))))
|
||||
|
||||
(define (table-row-heights box-sizes)
|
||||
(map transverse-sizing (extract box-size-vertical box-sizes)))
|
||||
|
||||
(define (table-column-widths box-sizes)
|
||||
(map transverse-sizing (extract box-size-horizontal (transpose box-sizes))))
|
||||
|
||||
(define (extract acc mtx)
|
||||
(map (lambda (r) (map acc r)) mtx))
|
||||
|
||||
(define (transverse-sizing sizings)
|
||||
(define-values (lb-v lb-f) (transverse-bound sizings sizing-shrink - max))
|
||||
(define-values (ub-v ub-f) (transverse-bound sizings sizing-stretch + min))
|
||||
(let* ((ideal-v (foldl max 0 (map sizing-ideal sizings)))
|
||||
(ideal-v (if ub-v (min ideal-v ub-v) ideal-v))
|
||||
(ideal-v (if lb-v (max ideal-v lb-v) ideal-v)))
|
||||
(sizing ideal-v
|
||||
(if ub-v (- ub-v ideal-v) ub-f)
|
||||
(if lb-v (- ideal-v lb-v) lb-f))))
|
||||
|
||||
(define (transverse-bound sizings sizing-accessor minus-or-plus max-or-min)
|
||||
(define vals (for/list [(s sizings) #:when (number? (sizing-accessor s))]
|
||||
(minus-or-plus (sizing-ideal s) (sizing-accessor s))))
|
||||
(values (and (pair? vals) (apply max-or-min vals))
|
||||
(foldl fill-max 0 (filter fill? (map sizing-accessor sizings)))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (table-layout box-sizes top left width height #:round [round? #t])
|
||||
(define row-sizings (table-row-heights box-sizes))
|
||||
(define col-sizings (table-column-widths box-sizes))
|
||||
(define row-heights (compute-concrete-adjacent-sizes row-sizings height))
|
||||
(define col-widths (compute-concrete-adjacent-sizes col-sizings width))
|
||||
(define local-round (if round? swedish-round values))
|
||||
(define-values (_bot rows-rev)
|
||||
(for/fold [(top top) (rows-rev '())] [(row-height row-heights)]
|
||||
(define next-top (+ top row-height))
|
||||
(define rounded-top (local-round top))
|
||||
(define rounded-height (- (local-round next-top) rounded-top))
|
||||
(define-values (_right cells-rev)
|
||||
(for/fold [(left left) (cells-rev '())] [(col-width col-widths)]
|
||||
(define next-left (+ left col-width))
|
||||
(define rounded-left (local-round left))
|
||||
(define rounded-width (- (local-round next-left) rounded-left))
|
||||
(values next-left
|
||||
(cons (rectangle rounded-left
|
||||
rounded-top
|
||||
rounded-width
|
||||
rounded-height)
|
||||
cells-rev))))
|
||||
(values next-top
|
||||
(cons (reverse cells-rev) rows-rev))))
|
||||
(reverse rows-rev))
|
||||
|
||||
(define (compute-concrete-adjacent-sizes sizings actual-bound)
|
||||
(define ideal-total (foldl + 0 (map sizing-ideal sizings)))
|
||||
(define-values (available-slop sizing-give apply-give)
|
||||
(if (<= ideal-total actual-bound)
|
||||
(values (- actual-bound ideal-total) sizing-stretch +)
|
||||
(values (- ideal-total actual-bound) sizing-shrink -)))
|
||||
(define total-give (foldl fill+ 0 (map sizing-give sizings)))
|
||||
(if (number? total-give)
|
||||
(let ((scale (if (zero? total-give) 0 (/ available-slop total-give))))
|
||||
(map (lambda (s)
|
||||
;; numeric total-give ⇒ no fills for any give in the list
|
||||
(apply-give (sizing-ideal s) (* (sizing-give s) scale)))
|
||||
sizings))
|
||||
(let* ((weight (fill-weight total-give))
|
||||
(rank (fill-rank total-give))
|
||||
(scale (if (zero? weight) 0 (/ available-slop weight))))
|
||||
(map (lambda (s)
|
||||
(match (sizing-give s)
|
||||
[(fill w (== rank)) (apply-give (sizing-ideal s) (* w scale))]
|
||||
[_ (sizing-ideal s)]))
|
||||
sizings))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(module+ test
|
||||
(check-equal? (transpose '((1 2 3) (4 5 6) (7 8 9))) '((1 4 7) (2 5 8) (3 6 9)))
|
||||
(check-equal? (swedish-round 0.1) 0.0)
|
||||
(check-equal? (swedish-round 0.5) 1.0)
|
||||
(check-equal? (swedish-round 0.9) 1.0)
|
||||
(check-equal? (swedish-round 1.1) 1.0)
|
||||
(check-equal? (swedish-round 1.5) 2.0)
|
||||
(check-equal? (swedish-round 1.9) 2.0))
|
||||
|
||||
(module+ test
|
||||
(define s211 (sizing 2 1 1))
|
||||
(define s0f0 (sizing 0 weak-fill 0))
|
||||
(define b22 (box-size s211 s211))
|
||||
(define b42 (box-size (sizing 4 1 1) s211))
|
||||
(define b62 (box-size (sizing 6 1 1) s211))
|
||||
(define b00 (box-size s0f0 s0f0))
|
||||
|
||||
(define t1 (list (list b22 b22 b00 b22)
|
||||
(list b22 b22 b00 b22)
|
||||
(list b22 b22 b00 b22)))
|
||||
|
||||
(define t2 (list (list b22 b22 b22)
|
||||
(list b22 b00 b22)
|
||||
(list b22 b22 b22)))
|
||||
|
||||
(define t3 (list (list b22 b42 b22)
|
||||
(list b22 b00 b22)
|
||||
(list b22 b22 b22)))
|
||||
|
||||
(define t4 (list (list b22 b62 b22)
|
||||
(list b22 b00 b22)
|
||||
(list b22 b22 b22)))
|
||||
|
||||
(check-equal? (table-sizing t1)
|
||||
(box-size (sizing 6 weak-fill 3)
|
||||
(sizing 6 3 3)))
|
||||
|
||||
(check-equal? (table-sizing t2)
|
||||
(box-size (sizing 6 3 3)
|
||||
(sizing 6 3 3)))
|
||||
|
||||
;; Is this sane?
|
||||
(check-equal? (table-sizing t3)
|
||||
(box-size (sizing 7 2 2)
|
||||
(sizing 6 3 3)))
|
||||
|
||||
;; Is this sane?
|
||||
(check-equal? (table-sizing t4)
|
||||
(box-size (sizing 9 0 2)
|
||||
(sizing 6 3 3)))
|
||||
|
||||
(check-equal? (table-layout t1 0 0 20 20)
|
||||
(list (list (rectangle 0 0 2 7)
|
||||
(rectangle 2 0 2 7)
|
||||
(rectangle 4 0 14 7)
|
||||
(rectangle 18 0 2 7))
|
||||
(list (rectangle 0 7 2 6)
|
||||
(rectangle 2 7 2 6)
|
||||
(rectangle 4 7 14 6)
|
||||
(rectangle 18 7 2 6))
|
||||
(list (rectangle 0 13 2 7)
|
||||
(rectangle 2 13 2 7)
|
||||
(rectangle 4 13 14 7)
|
||||
(rectangle 18 13 2 7))))
|
||||
|
||||
(check-equal? (table-layout t2 0 0 20 20)
|
||||
(list (list (rectangle 0 0 7 7)
|
||||
(rectangle 7 0 6 7)
|
||||
(rectangle 13 0 7 7))
|
||||
(list (rectangle 0 7 7 6)
|
||||
(rectangle 7 7 6 6)
|
||||
(rectangle 13 7 7 6))
|
||||
(list (rectangle 0 13 7 7)
|
||||
(rectangle 7 13 6 7)
|
||||
(rectangle 13 13 7 7))))
|
||||
|
||||
;; Is this sane?
|
||||
(check-equal? (table-layout t3 0 0 20 20)
|
||||
(list (list (rectangle 0 0 9 7)
|
||||
(rectangle 9 0 3 7)
|
||||
(rectangle 12 0 8 7))
|
||||
(list (rectangle 0 7 9 6)
|
||||
(rectangle 9 7 3 6)
|
||||
(rectangle 12 7 8 6))
|
||||
(list (rectangle 0 13 9 7)
|
||||
(rectangle 9 13 3 7)
|
||||
(rectangle 12 13 8 7)))))
|
|
@ -0,0 +1,8 @@
|
|||
#lang racket/base
|
||||
;; Layout, based loosely on TeX's boxes-and-glue model.
|
||||
|
||||
(require "sizing.rkt")
|
||||
(require "layout.rkt")
|
||||
|
||||
(provide (all-from-out "sizing.rkt")
|
||||
(all-from-out "layout.rkt"))
|
|
@ -0,0 +1,150 @@
|
|||
#lang racket/base
|
||||
;; Dimension sizing, based loosely on TeX's boxes-and-glue model.
|
||||
|
||||
(provide (struct-out fill)
|
||||
(struct-out sizing)
|
||||
(struct-out box-size)
|
||||
(struct-out rectangle)
|
||||
|
||||
weak-fill
|
||||
zero-sizing
|
||||
weak-fill-sizing
|
||||
zero-box-size
|
||||
weak-fill-box-size
|
||||
zero-rectangle
|
||||
|
||||
fill+
|
||||
fill-max
|
||||
fill-min
|
||||
fill-scale
|
||||
fill-weaken
|
||||
|
||||
sizing-contains?
|
||||
sizing-min
|
||||
sizing-max
|
||||
sizing-overlap?
|
||||
sizing-scale
|
||||
sizing-weaken
|
||||
sizing-pad
|
||||
sizing-adjust-ideal
|
||||
sizing-sum
|
||||
|
||||
box-size-weaken)
|
||||
|
||||
(require racket/match)
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
;; A Fill is one of
|
||||
;; - a Nat, a fixed amount of space
|
||||
;; - a (fill Nat Nat), a potentially infinite amount of space
|
||||
(struct fill (weight rank) #:transparent)
|
||||
|
||||
;; A Sizing is a (sizing Nat Fill Fill)
|
||||
(struct sizing (ideal stretch shrink) #:transparent)
|
||||
|
||||
;; A BoxSize is a (box-size Sizing Sizing)
|
||||
(struct box-size (horizontal vertical) #:transparent)
|
||||
|
||||
;; A Rectangle is a (rectangle Nat Nat BoxSize)
|
||||
(struct rectangle (left top width height) #:transparent)
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
;; A very weak fill.
|
||||
(define weak-fill (fill 1 -1))
|
||||
|
||||
(define zero-sizing (sizing 0 0 0))
|
||||
|
||||
(define weak-fill-sizing (sizing 0 weak-fill 0))
|
||||
|
||||
(define zero-box-size (box-size zero-sizing zero-sizing))
|
||||
|
||||
(define weak-fill-box-size (box-size weak-fill-sizing weak-fill-sizing))
|
||||
|
||||
(define zero-rectangle (rectangle 0 0 0 0))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
;; (Nat Nat -> Nat) -> (Fill Fill -> Fill)
|
||||
(define ((fill-binop op) a b)
|
||||
(match* (a b)
|
||||
[((? number?) (? number?)) (op a b)]
|
||||
[((? number?) (? fill?)) b]
|
||||
[((? fill?) (? number?)) a]
|
||||
[((fill w1 r1) (fill w2 r2))
|
||||
(cond [(= r1 r2) (fill (op w1 w2) r1)]
|
||||
[(> r1 r2) (fill w1 r1)]
|
||||
[(< r1 r2) (fill w2 r2)])]))
|
||||
|
||||
;; Fill Fill -> Fill
|
||||
(define fill+ (fill-binop +))
|
||||
(define fill-max (fill-binop max))
|
||||
(define (fill-min a b)
|
||||
(if (and (number? a) (number? b))
|
||||
(min a b)
|
||||
0))
|
||||
|
||||
(define (fill-scale f scale)
|
||||
(if (number? f)
|
||||
(* f scale)
|
||||
f))
|
||||
|
||||
(define (fill-weaken f w r)
|
||||
(if (fill? f)
|
||||
(fill w r)
|
||||
f))
|
||||
|
||||
(define (sizing-contains? s v)
|
||||
(match-define (sizing x x+ x-) s)
|
||||
(cond [(>= v x) (if (number? x+) (<= v (+ x x+)) #t)]
|
||||
[(<= v x) (if (number? x-) (>= v (- x x-)) #t)]))
|
||||
|
||||
(define (sizing-min s)
|
||||
(match (sizing-shrink s)
|
||||
[(? number? n) (- (sizing-ideal s) n)]
|
||||
[(? fill?) -inf.0]))
|
||||
|
||||
(define (sizing-max s)
|
||||
(match (sizing-stretch s)
|
||||
[(? number? n) (+ (sizing-ideal s) n)]
|
||||
[(? fill?) +inf.0]))
|
||||
|
||||
(define (sizing-overlap? x y)
|
||||
(define largest-min (max (sizing-min x) (sizing-min y)))
|
||||
(define smallest-max (min (sizing-max x) (sizing-max y)))
|
||||
(< largest-min smallest-max))
|
||||
|
||||
(define (sizing-scale s scale)
|
||||
(match-define (sizing x x+ x-) s)
|
||||
(sizing (* x scale) (fill-scale x+ scale) (fill-scale x- scale)))
|
||||
|
||||
(define (sizing-weaken s
|
||||
[stretch-weight 1]
|
||||
[stretch-rank 0]
|
||||
[shrink-weight stretch-weight]
|
||||
[shrink-rank stretch-rank])
|
||||
(match-define (sizing x x+ x-) s)
|
||||
(sizing x
|
||||
(fill-weaken x+ stretch-weight stretch-rank)
|
||||
(fill-weaken x- shrink-weight shrink-rank)))
|
||||
|
||||
(define (sizing-pad s amount)
|
||||
(match-define (sizing x x+ x-) s)
|
||||
(sizing (+ x amount) x+ x-))
|
||||
|
||||
(define (sizing-adjust-ideal s i)
|
||||
(match-define (sizing x x+ x-) s)
|
||||
(sizing i
|
||||
(if (fill? x+) x+ (+ x+ (- x i)))
|
||||
(if (fill? x-) x- (- x- (- x i)))))
|
||||
|
||||
(define (sizing-sum sizings)
|
||||
(sizing (foldl + 0 (map sizing-ideal sizings))
|
||||
(foldl fill+ 0 (map sizing-stretch sizings))
|
||||
(foldl fill+ 0 (map sizing-shrink sizings))))
|
||||
|
||||
(define (box-size-weaken bs [weight 1] [rank 0])
|
||||
(match-define (box-size h v) bs)
|
||||
(box-size (sizing-weaken h weight rank)
|
||||
(sizing-weaken v weight rank)))
|
Binary file not shown.
After Width: | Height: | Size: 483 KiB |
Binary file not shown.
After Width: | Height: | Size: 491 KiB |
|
@ -0,0 +1,10 @@
|
|||
all:
|
||||
|
||||
run:
|
||||
raco make main.rkt && racket main.rkt
|
||||
|
||||
clean:
|
||||
rm -rf compiled
|
||||
|
||||
client:
|
||||
irssi --config=irssi-config -n client
|
|
@ -0,0 +1,31 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require "protocol.rkt")
|
||||
(require "message.rkt")
|
||||
|
||||
(require/activate imperative-syndicate/reload)
|
||||
|
||||
(spawn #:name 'channel-factory
|
||||
(stop-when-reloaded)
|
||||
|
||||
(during (ircd-channel-member $Ch _)
|
||||
(assert (ircd-channel Ch)))
|
||||
|
||||
(during/spawn (ircd-channel $Ch)
|
||||
#:name (ircd-channel Ch)
|
||||
(field [topic #f])
|
||||
(assert (ircd-channel-topic Ch (topic)))
|
||||
|
||||
(define/query-count user-count (ircd-channel-member Ch $who) 'any)
|
||||
(assert (ircd-channel-user-count Ch (hash-ref (user-count) 'any 0)))
|
||||
|
||||
(on (message (ircd-action $who (irc-message _ "MODE" (list Ch "b") _)))
|
||||
(send! (ircd-event who (irc-message server-prefix 368 (list (lookup-nick who) Ch)
|
||||
"End of Channel Ban List"))))
|
||||
|
||||
(on (message (ircd-action $who (irc-message _ "MODE" (list Ch) _)))
|
||||
(send! (ircd-event who (irc-message server-prefix 324
|
||||
(list (lookup-nick who) Ch "+") #f))))
|
||||
|
||||
(on (message (ircd-action _ (irc-message _ "TOPIC" (list Ch) $new-topic)))
|
||||
(topic new-topic))))
|
|
@ -0,0 +1,27 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require/activate imperative-syndicate/reload)
|
||||
(require/activate imperative-syndicate/supervise)
|
||||
(require/activate imperative-syndicate/drivers/config)
|
||||
|
||||
(require "protocol.rkt")
|
||||
|
||||
(require racket/set)
|
||||
(require (only-in racket/list append* flatten))
|
||||
(require (only-in racket/string string-split))
|
||||
|
||||
(spawn-configuration 'ircd "ircd-config.rktd" #:hook (lambda () (stop-when-reloaded)))
|
||||
|
||||
(spawn #:name 'config
|
||||
(stop-when-reloaded)
|
||||
|
||||
(during (config 'ircd `(port ,$port))
|
||||
(assert (ircd-listener port)))
|
||||
|
||||
(during (config 'ircd `(channel ,$Ch))
|
||||
(assert (ircd-channel Ch)))
|
||||
|
||||
(define/query-set motds (config 'ircd `(motd ,$text)) text)
|
||||
(assert (ircd-motd (append*
|
||||
(map (lambda (t) (string-split t "\n"))
|
||||
(flatten (set->list (motds))))))))
|
|
@ -0,0 +1,6 @@
|
|||
#lang imperative-syndicate
|
||||
(require/activate imperative-syndicate/reload)
|
||||
(spawn-reloader "config.rkt")
|
||||
(spawn-reloader "session.rkt")
|
||||
(spawn-reloader "channel.rkt")
|
||||
(spawn-reloader "greeter.rkt")
|
|
@ -0,0 +1,21 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require "protocol.rkt")
|
||||
(require "message.rkt")
|
||||
|
||||
(require/activate imperative-syndicate/reload)
|
||||
|
||||
(spawn #:name 'greeter
|
||||
(stop-when-reloaded)
|
||||
(on (asserted (ircd-channel-member $Ch $conn))
|
||||
(match-define (ircd-connection-info _ N U)
|
||||
(immediate-query [query-value #f ($ I (ircd-connection-info conn _ _)) I]))
|
||||
;; TODO: history replay? As the following illustrates, we are able to forge messages
|
||||
(send! (ircd-event conn (irc-message (irc-source-nick N U) "PRIVMSG" (list Ch)
|
||||
(format "Welcome to ~a, ~a!" Ch N))))))
|
||||
|
||||
(spawn #:name 'authenticator
|
||||
(stop-when-reloaded)
|
||||
(during (observe (ircd-credentials $nick $user $password _))
|
||||
(log-info "Credentials: ~a ~a ~a" nick user password)
|
||||
(assert (ircd-credentials nick user password (equal? password "foobar")))))
|
|
@ -0,0 +1,3 @@
|
|||
(port 6667)
|
||||
(motd "Hello, world!")
|
||||
(channel "#syndicate")
|
|
@ -0,0 +1,24 @@
|
|||
servers = (
|
||||
{
|
||||
address = "localhost";
|
||||
chatnet = "Syndicate";
|
||||
port = "6667";
|
||||
autoconnect = "yes";
|
||||
password = "foobar";
|
||||
}
|
||||
);
|
||||
|
||||
chatnets = { Syndicate = { type = "IRC"; }; };
|
||||
|
||||
channels = (
|
||||
{ name = "#test"; chatnet = "Syndicate"; autojoin = "yes"; },
|
||||
{ name = "#test2"; chatnet = "Syndicate"; autojoin = "yes"; }
|
||||
);
|
||||
settings = {
|
||||
core = {
|
||||
real_name = "Alice Exampleuser";
|
||||
user_name = "alice";
|
||||
nick = "client";
|
||||
};
|
||||
"fe-text" = { actlist_sort = "refnum"; };
|
||||
};
|
|
@ -0,0 +1,3 @@
|
|||
#lang imperative-syndicate
|
||||
(require/activate imperative-syndicate/reload)
|
||||
(spawn-reloader "dynamic-main.rkt")
|
|
@ -0,0 +1,93 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (struct-out irc-message)
|
||||
(struct-out irc-user)
|
||||
(struct-out irc-privmsg)
|
||||
|
||||
(struct-out irc-source-servername)
|
||||
(struct-out irc-source-nick)
|
||||
|
||||
parse-irc-message
|
||||
render-irc-message
|
||||
|
||||
;; TODO make these assertions in the dataspace:
|
||||
server-name
|
||||
server-prefix)
|
||||
|
||||
(require racket/string)
|
||||
(require racket/match)
|
||||
(require racket/format)
|
||||
|
||||
;; <message> ::= [':' <prefix> <SPACE> ] <command> <params> <crlf>
|
||||
;; <prefix> ::= <servername> | <nick> [ '!' <user> ] [ '@' <host> ]
|
||||
;; <command> ::= <letter> { <letter> } | <number> <number> <number>
|
||||
;; <SPACE> ::= ' ' { ' ' }
|
||||
;; <params> ::= <SPACE> [ ':' <trailing> | <middle> <params> ]
|
||||
;;
|
||||
;; <middle> ::= <Any *non-empty* sequence of octets not including SPACE
|
||||
;; or NUL or CR or LF, the first of which may not be ':'>
|
||||
;; <trailing> ::= <Any, possibly *empty*, sequence of octets not including
|
||||
;; NUL or CR or LF>
|
||||
;;
|
||||
;; <crlf> ::= CR LF
|
||||
|
||||
;; <target> ::= <to> [ "," <target> ]
|
||||
;; <to> ::= <channel> | <user> '@' <servername> | <nick> | <mask>
|
||||
;; <channel> ::= ('#' | '&') <chstring>
|
||||
;; <servername> ::= <host>
|
||||
;; <host> ::= see RFC 952 [DNS:4] for details on allowed hostnames
|
||||
;; <nick> ::= <letter> { <letter> | <number> | <special> }
|
||||
;; <mask> ::= ('#' | '$') <chstring>
|
||||
;; <chstring> ::= <any 8bit code except SPACE, BELL, NUL, CR, LF and
|
||||
;; comma (',')>
|
||||
|
||||
;; <user> ::= <nonwhite> { <nonwhite> }
|
||||
;; <letter> ::= 'a' ... 'z' | 'A' ... 'Z'
|
||||
;; <number> ::= '0' ... '9'
|
||||
;; <special> ::= '-' | '[' | ']' | '\' | '`' | '^' | '{' | '}'
|
||||
|
||||
;; <nonwhite> ::= <any 8bit code except SPACE (0x20), NUL (0x0), CR
|
||||
;; (0xd), and LF (0xa)>
|
||||
|
||||
(struct irc-message (prefix command params trailing) #:prefab)
|
||||
(struct irc-user (username hostname realname) #:prefab)
|
||||
(struct irc-privmsg (source target text notice?) #:prefab)
|
||||
|
||||
(struct irc-source-servername (servername) #:prefab)
|
||||
(struct irc-source-nick (nick user) #:prefab)
|
||||
|
||||
(define (parse-irc-message line0)
|
||||
(match (string-trim #:left? #f line0 #px"[\r\n]")
|
||||
[(pregexp #px"^:([^ ]+) +(.*)$" (list _ prefix rest)) (parse-command prefix rest)]
|
||||
[line (parse-command #f line)]))
|
||||
|
||||
(define (parse-command prefix line)
|
||||
(match-define (pregexp #px"^([^ ]+)( +([^:]+)?(:(.*))?)?$" (list _ command _ params _ rest)) line)
|
||||
(irc-message prefix
|
||||
(string-upcase command)
|
||||
(string-split (or params ""))
|
||||
rest))
|
||||
|
||||
;; libpurple's irc protocol support crashes (!) (SIGSEGV) if you send
|
||||
;; a prefix on a JOIN event from the server as just "nick" rather than
|
||||
;; "nick!user@host" - specifically, it will crash if "!" doesn't
|
||||
;; appear in the prefix.
|
||||
;;
|
||||
(define (render-irc-message m)
|
||||
(match-define (irc-message prefix command params trailing) m)
|
||||
(string-append (render-prefix prefix)
|
||||
(~a command)
|
||||
(if (pair? params) (string-append " " (string-join (map ~a params))) "")
|
||||
(if trailing (string-append " :" trailing) "")))
|
||||
|
||||
(define (render-prefix p)
|
||||
(match p
|
||||
[#f
|
||||
""]
|
||||
[(irc-source-servername servername)
|
||||
(format ":~a " servername)]
|
||||
[(irc-source-nick nick (irc-user username hostname _))
|
||||
(format ":~a!~a@~a " nick username hostname)]))
|
||||
|
||||
(define server-name "syndicate-ircd")
|
||||
(define server-prefix (irc-source-servername "syndicate-ircd.example"))
|
|
@ -0,0 +1,68 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide (struct-out ircd-listener)
|
||||
(struct-out ircd-motd)
|
||||
|
||||
(struct-out claim)
|
||||
(struct-out decision)
|
||||
|
||||
(struct-out ircd-nick)
|
||||
(struct-out ircd-connection-info)
|
||||
(struct-out ircd-channel)
|
||||
(struct-out ircd-channel-member)
|
||||
(struct-out ircd-channel-topic)
|
||||
(struct-out ircd-channel-user-count)
|
||||
|
||||
(struct-out ircd-action)
|
||||
(struct-out ircd-event)
|
||||
|
||||
(struct-out ircd-credentials)
|
||||
|
||||
lookup-nick)
|
||||
|
||||
;; A Connection is a TcpAddress
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; Configuration
|
||||
|
||||
;; (ircd-listener PortNumber) - causes TCP connections to be accepted on this port
|
||||
(assertion-struct ircd-listener (port))
|
||||
|
||||
;; (ircd-motd (Listof String)) - Message Of The Day text
|
||||
(assertion-struct ircd-motd (lines))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; Affine resources
|
||||
|
||||
;; (claim Any NonFalse) -- any number of these. Decider picks a claimant
|
||||
(assertion-struct claim (resource claimant))
|
||||
|
||||
;; (decision Any NonFalse) -- zero or one of these for a given resource.
|
||||
(assertion-struct decision (resource resource-holder))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; IRC protocol
|
||||
|
||||
;; (ircd-nick String) - a unique resource
|
||||
(assertion-struct ircd-nick (name))
|
||||
|
||||
;; (ircd-connection-info Connection String IRCUser) -- mapping: nick <--> conn + userinfo
|
||||
(assertion-struct ircd-connection-info (conn nick user))
|
||||
|
||||
(assertion-struct ircd-channel (channel))
|
||||
(assertion-struct ircd-channel-member (channel conn))
|
||||
(assertion-struct ircd-channel-topic (channel topic))
|
||||
(assertion-struct ircd-channel-user-count (channel count))
|
||||
|
||||
(message-struct ircd-action (conn message))
|
||||
(message-struct ircd-event (conn message))
|
||||
|
||||
(assertion-struct ircd-credentials (nick user password valid?))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; Application: chatroom model
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (lookup-nick conn)
|
||||
(immediate-query [query-value #f (ircd-connection-info conn $N _) N]))
|
|
@ -0,0 +1,235 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require racket/set)
|
||||
(require racket/string)
|
||||
|
||||
(require "protocol.rkt")
|
||||
(require "message.rkt")
|
||||
|
||||
(require/activate imperative-syndicate/reload)
|
||||
(require/activate imperative-syndicate/drivers/tcp)
|
||||
(require syndicate/support/hash)
|
||||
(require (only-in racket/list append*))
|
||||
|
||||
(spawn #:name 'affine-resource-arbiter
|
||||
(stop-when-reloaded)
|
||||
(during (claim $resource _)
|
||||
(define/query-set claimants (claim resource $claimant) claimant)
|
||||
(field [holder #f])
|
||||
(begin/dataflow
|
||||
(when (not (set-member? (claimants) (holder)))
|
||||
(holder (and (not (set-empty? (claimants)))
|
||||
(set-first (claimants))))))
|
||||
(assert #:when (holder) (decision resource (holder)))))
|
||||
|
||||
(define (ircd-connection-facet connection-root-facet this-conn peer-host)
|
||||
(define (send-to-remote #:newline [with-newline #t] fmt . vs)
|
||||
(define bs (string->bytes/utf-8 (apply format fmt vs)))
|
||||
(log-info "~a <- ~v" this-conn bs)
|
||||
(send! (tcp-out this-conn (if with-newline (bytes-append bs #"\r\n") bs))))
|
||||
|
||||
(define (send-irc-message m)
|
||||
(send-to-remote "~a" (render-irc-message m)))
|
||||
|
||||
(define (send* #:source [prefix server-prefix] #:trailing [trailing #f] command . params)
|
||||
(send-irc-message (irc-message prefix command params trailing)))
|
||||
|
||||
(on-start (log-info "Connecting ~a" this-conn))
|
||||
(on-stop (log-info "Disconnecting ~a" this-conn))
|
||||
|
||||
(field [nick #f]
|
||||
[user #f]
|
||||
[password #f]
|
||||
[registered? #f])
|
||||
(assert (ircd-connection-info this-conn (nick) (user)))
|
||||
(assert #:when (nick) (claim (ircd-nick (nick)) this-conn))
|
||||
|
||||
(on-start
|
||||
(react
|
||||
(stop-when (asserted (ircd-motd $motd-lines))
|
||||
(react
|
||||
(begin/dataflow
|
||||
(when (and (nick) (user))
|
||||
(stop-current-facet
|
||||
(react
|
||||
(stop-when (asserted (ircd-credentials (nick) (user) (password) $valid?))
|
||||
(cond
|
||||
[valid?
|
||||
(registered? #t)
|
||||
(send* 375 (nick) #:trailing (format "- ~a Message of the day - " server-name))
|
||||
(for [(line motd-lines)] (send* 372 (nick) #:trailing (format "- ~a" line)))
|
||||
(send* 376 (nick) #:trailing (format "End of /MOTD command"))
|
||||
(assert! (ircd-channel-member "#syndicate" this-conn)) ;; force membership!
|
||||
]
|
||||
[else
|
||||
(send* 464 (nick) #:trailing "Password incorrect")
|
||||
(stop-facet connection-root-facet)]))))))))))
|
||||
|
||||
(field [peer-common-channels (hash)]
|
||||
[peer-names (hash)])
|
||||
|
||||
(during (ircd-channel-member $Ch this-conn)
|
||||
(field [initial-names-sent? #f]
|
||||
[initial-member-nicks (set)])
|
||||
|
||||
(on-start (send* #:source (irc-source-nick (nick) (user)) "JOIN" Ch)
|
||||
(flush!)
|
||||
(flush!)
|
||||
(define nicks (initial-member-nicks))
|
||||
(initial-names-sent? #t)
|
||||
(initial-member-nicks 'no-longer-valid)
|
||||
(send* 353 (nick) "@" Ch #:trailing (string-join (set->list nicks)))
|
||||
(send* 366 (nick) Ch #:trailing "End of /NAMES list"))
|
||||
|
||||
(during (ircd-channel-member Ch $other-conn)
|
||||
(on-start (peer-common-channels (hashset-add (peer-common-channels) other-conn Ch)))
|
||||
(on-stop (peer-common-channels (hashset-remove (peer-common-channels) other-conn Ch)))
|
||||
(field [current-other-source #f])
|
||||
(define/query-value next-other-source #f
|
||||
(ircd-connection-info other-conn $N $U)
|
||||
(irc-source-nick N U))
|
||||
(on (retracted (ircd-channel-member Ch other-conn))
|
||||
(when (current-other-source) (send* #:source (current-other-source) "PART" Ch)))
|
||||
(on-stop (when (not (hash-has-key? (peer-common-channels) other-conn))
|
||||
(peer-names (hash-remove (peer-names) other-conn))))
|
||||
(begin/dataflow
|
||||
(when (not (equal? (current-other-source) (next-other-source)))
|
||||
(if (not (next-other-source)) ;; other-conn is disconnecting
|
||||
(when (hash-ref (peer-names) other-conn #f)
|
||||
(send* #:source (current-other-source) "QUIT")
|
||||
(peer-names (hash-remove (peer-names) other-conn)))
|
||||
(begin
|
||||
(cond
|
||||
[(not (initial-names-sent?)) ;; still gathering data for 353/366 below
|
||||
(initial-member-nicks (set-add (initial-member-nicks)
|
||||
(irc-source-nick-nick (next-other-source))))]
|
||||
[(not (current-other-source)) ;; other-conn is joining
|
||||
(send* #:source (next-other-source) "JOIN" Ch)]
|
||||
[else ;; it's a nick change
|
||||
(when (not (equal? this-conn other-conn)) ;; avoid dups for our own connection
|
||||
(when (not (equal? (next-other-source) (hash-ref (peer-names) other-conn #f)))
|
||||
(send* #:source (current-other-source) "NICK"
|
||||
(irc-source-nick-nick (next-other-source)))))])
|
||||
(peer-names (hash-set (peer-names) other-conn (next-other-source)))))
|
||||
(current-other-source (next-other-source)))))
|
||||
|
||||
(on (asserted (ircd-channel-topic Ch $topic))
|
||||
(if topic
|
||||
(send* 332 (nick) Ch #:trailing topic)
|
||||
(send* 331 (nick) Ch #:trailing "No topic is set")))
|
||||
|
||||
(on (message (ircd-action this-conn (irc-message _ "WHO" (list Ch) _)))
|
||||
(flush!) ;; Wait for responses to come in. GROSS and not in
|
||||
;; general correct (e.g. in the presence of
|
||||
;; pipelining)
|
||||
(send! (ircd-event this-conn
|
||||
(irc-message server-prefix 315 (list (nick) Ch) "End of WHO list."))))
|
||||
(on (message (ircd-action $who (irc-message _ "WHO" (list Ch) _)))
|
||||
(match-define (irc-user U H R) (user))
|
||||
(send! (ircd-event who (irc-message server-prefix 352
|
||||
(list (nick) Ch U H server-name (nick) "H")
|
||||
(format "0 ~a" R)))))
|
||||
|
||||
(on (message (ircd-action $other-conn (irc-privmsg $source Ch $text $notice?)))
|
||||
(when (not (equal? other-conn this-conn))
|
||||
(send* #:source source (if notice? "NOTICE" "PRIVMSG") Ch #:trailing text))))
|
||||
|
||||
(on (message (ircd-event this-conn $m))
|
||||
(send-irc-message m))
|
||||
|
||||
(on (message (ircd-action $other-conn (irc-privmsg $source (nick) $text $notice?)))
|
||||
(when (not (equal? other-conn this-conn))
|
||||
(send* #:source source (if notice? "NOTICE" "PRIVMSG") (nick) #:trailing text)))
|
||||
|
||||
(on (message (tcp-in-line this-conn $bs))
|
||||
(define m (parse-irc-message (bytes->string/utf-8 bs)))
|
||||
(log-info "~a -> ~v" this-conn m)
|
||||
(send! (ircd-action this-conn m))
|
||||
(issue-credit! tcp-in this-conn)
|
||||
(match m
|
||||
[(irc-message _ "PING" _ _) (void)] ;; RFC says servers don't reply to PINGs
|
||||
[(or (irc-message _ "PASS" (list P) _)
|
||||
(irc-message _ "PASS" '() P)) ;; libpurple does this (!)
|
||||
(if (registered?)
|
||||
(send* 462 (nick) #:trailing "You may not reregister")
|
||||
(password P))]
|
||||
[(or (irc-message _ "NICK" (list N) _)
|
||||
(irc-message _ "NICK" '() N)) ;; libpurple does this (!)
|
||||
;; TODO: enforce syntactic restrictions on nick
|
||||
(react (assert (claim (ircd-nick N) this-conn))
|
||||
(on (asserted (decision (ircd-nick N) $who))
|
||||
(if (equal? who this-conn)
|
||||
(begin (when (nick) (send* #:source (irc-source-nick (nick) (user)) "NICK" N))
|
||||
(nick N))
|
||||
(send* 433 (or (nick) "*") N #:trailing "Nickname is already in use"))
|
||||
(stop-current-facet)))]
|
||||
[(irc-message _ "USER" (list U _Hostname _Servername) R)
|
||||
;; TODO: enforce syntactic restrictions on parameters to USER
|
||||
(if (registered?)
|
||||
(send* 462 (nick) #:trailing "You may not reregister")
|
||||
(user (irc-user U peer-host R)))]
|
||||
[(irc-message _ "QUIT" _ _) (stop-current-facet)]
|
||||
[_
|
||||
(when (registered?)
|
||||
(match m
|
||||
[(irc-message _ "JOIN" (cons Channels _MaybeKeys) _)
|
||||
(for [(Ch (string-split Channels #px",+"))]
|
||||
(assert! (ircd-channel-member Ch this-conn)))]
|
||||
[(irc-message _ "PART" (list Channels) _)
|
||||
(for [(Ch (string-split Channels #px",+"))]
|
||||
(retract! (ircd-channel-member Ch this-conn)))]
|
||||
[(irc-message _ "WHOIS" _ _)
|
||||
(send* 318 (nick) #:trailing "End of /WHOIS list")] ;; TODO
|
||||
[(irc-message _
|
||||
(and cmd (or "PRIVMSG" "NOTICE"))
|
||||
(list Targets)
|
||||
Text)
|
||||
(for [(T (string-split Targets #px",+"))]
|
||||
(send! (ircd-action this-conn
|
||||
(irc-privmsg (irc-source-nick (nick) (user))
|
||||
T
|
||||
Text
|
||||
(equal? cmd "NOTICE")))))]
|
||||
[_ (void)]))])))
|
||||
|
||||
(spawn #:name 'ison-responder
|
||||
(stop-when-reloaded)
|
||||
(define/query-set nicks (ircd-connection-info _ $N _) N)
|
||||
(on (message (ircd-action $conn (irc-message _ "ISON" $SomeNicks $MoreNicks)))
|
||||
(define Nicks (append SomeNicks (string-split (or MoreNicks ""))))
|
||||
(define (on? N) (set-member? (nicks) N))
|
||||
(define Present (string-join (filter on? Nicks) " "))
|
||||
(send! (ircd-event conn (irc-message server-prefix 303 '("*") Present)))))
|
||||
|
||||
(spawn #:name 'list-responder
|
||||
(stop-when-reloaded)
|
||||
(define/query-hash topics (ircd-channel-topic $Ch $topic) Ch topic)
|
||||
(define/query-hash counts (ircd-channel-user-count $Ch $count) Ch count)
|
||||
(on (message (ircd-action $conn (irc-message _ "LIST" $requested-channel-names0 _)))
|
||||
(define requested-channel-names
|
||||
(append* (map (lambda (ns) (string-split ns #px",+")) requested-channel-names0)))
|
||||
(send! (ircd-event conn (irc-message server-prefix 321 '("*" "Channel") "Users Name")))
|
||||
(for [(Ch (if (null? requested-channel-names)
|
||||
(in-hash-keys (topics))
|
||||
(in-list requested-channel-names)))]
|
||||
(when (hash-has-key? (topics) Ch)
|
||||
(define topic (hash-ref (topics) Ch))
|
||||
(define count (hash-ref (counts) Ch 0))
|
||||
(send! (ircd-event conn (irc-message server-prefix 322 (list "*" Ch count) topic)))))
|
||||
(send! (ircd-event conn (irc-message server-prefix 323 '("*") "End of /LIST")))))
|
||||
|
||||
(spawn #:name 'session-listener-factory
|
||||
(stop-when-reloaded)
|
||||
(during/spawn (ircd-listener $port)
|
||||
#:name (ircd-listener port)
|
||||
(on-start (log-info "Listening on port ~a." port))
|
||||
(on-stop (log-info "No longer listening on port ~a." port))
|
||||
(define server-handle (tcp-listener port))
|
||||
(during/spawn (tcp-connection $this-conn server-handle)
|
||||
#:name `(ircd-connection ,this-conn)
|
||||
(define connection-root-facet (current-facet))
|
||||
(on-start (issue-credit! server-handle)
|
||||
(issue-credit! tcp-in this-conn))
|
||||
(during (tcp-connection-peer this-conn (tcp-address $peer-host _))
|
||||
(assert (tcp-accepted this-conn))
|
||||
(ircd-connection-facet connection-root-facet this-conn peer-host)))))
|
|
@ -0,0 +1,7 @@
|
|||
all:
|
||||
|
||||
run:
|
||||
raco make main.rkt && racket main.rkt
|
||||
|
||||
clean:
|
||||
find . -name compiled -type d | xargs rm -rf
|
|
@ -0,0 +1,19 @@
|
|||
# TCP/IP Stack
|
||||
|
||||
This implementation is largely the same as the old-Syndicate
|
||||
"incremental highlevel" implementation, but using new-Syndicate.
|
||||
|
||||
## Linux Firewall Configuration
|
||||
|
||||
Imagine a setup where the machine you are running this code has IP
|
||||
192.168.1.10. This code claims 192.168.1.222 for itself. Now, pinging
|
||||
192.168.1.222 from some other machine, say 192.168.1.99, will cause
|
||||
the local kernel to receive the pings and then *forward them on to
|
||||
192.168.1.222*, which because of the gratuitous ARP announcement, it
|
||||
knows to be on its own Ethernet MAC address. This causes the ping
|
||||
requests to repeat endlessly, each time with one lower TTL.
|
||||
|
||||
One approach to solving the problem is to prevent the kernel from
|
||||
forwarding packets addressed to 192.168.1.222. To do this,
|
||||
|
||||
sudo iptables -I FORWARD -d 192.168.1.222 -j DROP
|
|
@ -0,0 +1,24 @@
|
|||
Ideas on TCP unit testing:
|
||||
<https://www.snellman.net/blog/archive/2015-07-09-unit-testing-a-tcp-stack/>
|
||||
|
||||
Check behaviour around TCP zero-window probing. Is the correct
|
||||
behaviour already a consequence of the way `send-outbound` works?
|
||||
|
||||
Do something smarter with TCP timers and RTT estimation than the
|
||||
nothing that's already being done.
|
||||
|
||||
TCP options negotiation.
|
||||
- SACK
|
||||
- Window scaling
|
||||
|
||||
Check that we handle the situations in figs. 9, 10, 11, pp.33- of RFC 793.
|
||||
|
||||
Bugs:
|
||||
- RST kills a connection even if its sequence number is bogus. Check
|
||||
to make sure it's in the window. (See
|
||||
http://static.googleusercontent.com/media/research.google.com/en//pubs/archive/41848.pdf
|
||||
and RFC 5961)
|
||||
|
||||
Conform better to the rules for reset generation and processing
|
||||
from pp.36- of RFC 793. In particular, do not blindly accept RSTs
|
||||
without checking sequence numbers against windows etc.
|
|
@ -0,0 +1,189 @@
|
|||
#lang imperative-syndicate
|
||||
;; ARP protocol, http://tools.ietf.org/html/rfc826
|
||||
;; Only does ARP-over-ethernet.
|
||||
|
||||
(provide (struct-out arp-query)
|
||||
(struct-out arp-assertion)
|
||||
(struct-out arp-interface))
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require/activate imperative-syndicate/drivers/timer)
|
||||
(require bitsyntax)
|
||||
|
||||
(require "dump-bytes.rkt")
|
||||
(require "configuration.rkt")
|
||||
(require/activate "ethernet.rkt")
|
||||
|
||||
(struct arp-query (protocol protocol-address interface-name link-address) #:prefab)
|
||||
(struct arp-assertion (protocol protocol-address interface-name) #:prefab)
|
||||
(struct arp-interface (interface-name) #:prefab)
|
||||
|
||||
(struct arp-interface-up (interface-name) #:prefab)
|
||||
|
||||
(define ARP-ethertype #x0806)
|
||||
(define cache-entry-lifetime-msec (* 14400 1000))
|
||||
(define wakeup-interval 5000)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (spawn-arp-driver)
|
||||
(spawn #:name 'arp-driver
|
||||
(during/spawn (arp-interface $interface-name)
|
||||
#:name (list 'arp-interface interface-name)
|
||||
(assert (arp-interface-up interface-name))
|
||||
(during (ethernet-interface interface-name $hwaddr)
|
||||
(run-arp-interface interface-name hwaddr)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(struct cache-key (protocol address) #:transparent)
|
||||
(struct cache-value (expiry interface-name address) #:transparent)
|
||||
|
||||
(define (expire-cache c)
|
||||
(define now (current-inexact-milliseconds))
|
||||
(define (not-expired? v) (< now (cache-value-expiry v)))
|
||||
(for/hash [((k v) (in-hash c)) #:when (not-expired? v)]
|
||||
(values k v)))
|
||||
|
||||
(define (run-arp-interface interface-name hwaddr)
|
||||
(log-info "ARP interface ~v ~v" interface-name hwaddr)
|
||||
|
||||
(define (build-packet dest-mac ptype oper sender-ha sender-pa target-ha target-pa)
|
||||
(define hlen (bytes-length target-ha))
|
||||
(define plen (bytes-length target-pa))
|
||||
(define packet (bit-string->bytes
|
||||
(bit-string (1 :: integer bytes 2)
|
||||
(ptype :: integer bytes 2)
|
||||
hlen
|
||||
plen
|
||||
(oper :: integer bytes 2)
|
||||
(sender-ha :: binary bytes hlen)
|
||||
(sender-pa :: binary bytes plen)
|
||||
(target-ha :: binary bytes hlen)
|
||||
(target-pa :: binary bytes plen))))
|
||||
(ethernet-packet interface-name
|
||||
#f
|
||||
hwaddr
|
||||
dest-mac
|
||||
ARP-ethertype
|
||||
packet))
|
||||
|
||||
(define (some-asserted-pa ptype)
|
||||
(match (filter (lambda (k) (equal? (cache-key-protocol k) ptype)) (set->list (assertions)))
|
||||
['() #f]
|
||||
[(list* k _) (cache-key-address k)]))
|
||||
|
||||
(define (send-questions!)
|
||||
(for [(q (set-subtract (queries) (list->set (hash-keys (cache)))))]
|
||||
(define pa (some-asserted-pa (cache-key-protocol q)))
|
||||
(log-info "~a ARP Asking for ~a from ~a"
|
||||
interface-name
|
||||
(pretty-bytes (cache-key-address q))
|
||||
(and pa (pretty-bytes pa)))
|
||||
(when pa
|
||||
(send! (build-packet broadcast-ethernet-address
|
||||
(cache-key-protocol q)
|
||||
1 ;; request
|
||||
hwaddr
|
||||
pa
|
||||
zero-ethernet-address
|
||||
(cache-key-address q))))))
|
||||
|
||||
(field [cache (hash)]
|
||||
[queries (set)]
|
||||
[assertions (set)])
|
||||
|
||||
(field [expiry-deadline (+ (current-inexact-milliseconds) wakeup-interval)])
|
||||
(on (asserted (later-than (expiry-deadline)))
|
||||
(cache (expire-cache (cache)))
|
||||
(send-questions!)
|
||||
(expiry-deadline (+ (current-inexact-milliseconds) wakeup-interval)))
|
||||
|
||||
(on (message ($ p (ethernet-packet-pattern interface-name #t ARP-ethertype)))
|
||||
(match-define (ethernet-packet _ _ source destination _ body) p)
|
||||
(bit-string-case body
|
||||
([ (= 1 :: integer bytes 2)
|
||||
(ptype :: integer bytes 2)
|
||||
hlen
|
||||
plen
|
||||
(oper :: integer bytes 2)
|
||||
(sender-hardware-address0 :: binary bytes hlen)
|
||||
(sender-protocol-address0 :: binary bytes plen)
|
||||
(target-hardware-address0 :: binary bytes hlen)
|
||||
(target-protocol-address0 :: binary bytes plen)
|
||||
(:: binary) ;; The extra zeros exist because ethernet packets
|
||||
;; have a minimum size. This is, in part, why IPv4
|
||||
;; headers have a total-length field, so that the
|
||||
;; zero padding can be removed.
|
||||
]
|
||||
(let ()
|
||||
(define sender-protocol-address (bit-string->bytes sender-protocol-address0))
|
||||
(define sender-hardware-address (bit-string->bytes sender-hardware-address0))
|
||||
(define target-protocol-address (bit-string->bytes target-protocol-address0))
|
||||
(define learned-key (cache-key ptype sender-protocol-address))
|
||||
|
||||
(when (and (set-member? (queries) learned-key) ;; it is relevant to our interests
|
||||
(not (equal? sender-hardware-address
|
||||
(cache-value-address (hash-ref (cache)
|
||||
learned-key
|
||||
(lambda ()
|
||||
(cache-value #f #f #f)))))))
|
||||
(log-info "~a ARP Adding ~a = ~a to cache"
|
||||
interface-name
|
||||
(pretty-bytes sender-protocol-address)
|
||||
(pretty-bytes sender-hardware-address)))
|
||||
|
||||
(cache (hash-set (expire-cache (cache))
|
||||
learned-key
|
||||
(cache-value (+ (current-inexact-milliseconds)
|
||||
cache-entry-lifetime-msec)
|
||||
interface-name
|
||||
sender-hardware-address)))
|
||||
(case oper
|
||||
[(1) ;; request
|
||||
(when (set-member? (assertions) (cache-key ptype target-protocol-address))
|
||||
(log-info "~a ARP answering request for ~a/~a"
|
||||
interface-name
|
||||
ptype
|
||||
(pretty-bytes target-protocol-address))
|
||||
(send! (build-packet sender-hardware-address
|
||||
ptype
|
||||
2 ;; reply
|
||||
hwaddr
|
||||
target-protocol-address
|
||||
sender-hardware-address
|
||||
sender-protocol-address)))]
|
||||
[(2) (void)] ;; reply
|
||||
[else (void)])))
|
||||
(else #f)))
|
||||
|
||||
(during (arp-assertion $protocol $protocol-address interface-name)
|
||||
(define a (cache-key protocol protocol-address))
|
||||
(on-start (assertions (set-add (assertions) a))
|
||||
(log-info "~a ARP Announcing ~a as ~a"
|
||||
interface-name
|
||||
(pretty-bytes (cache-key-address a))
|
||||
(pretty-bytes hwaddr))
|
||||
(send! (build-packet broadcast-ethernet-address
|
||||
(cache-key-protocol a)
|
||||
2 ;; reply -- gratuitous announcement
|
||||
hwaddr
|
||||
(cache-key-address a)
|
||||
hwaddr
|
||||
(cache-key-address a))))
|
||||
(on-stop (assertions (set-remove (assertions) a))))
|
||||
|
||||
(during (observe (arp-query $protocol $protocol-address interface-name _))
|
||||
(define key (cache-key protocol protocol-address))
|
||||
(on-start (queries (set-add (queries) key))
|
||||
(send-questions!))
|
||||
(on-stop (queries (set-remove (queries) key)))
|
||||
(assert #:when (hash-has-key? (cache) key)
|
||||
(match (hash-ref (cache) key)
|
||||
[(cache-value _ ifname addr)
|
||||
(arp-query protocol protocol-address ifname addr)]))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(spawn-arp-driver)
|
|
@ -0,0 +1,52 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide ones-complement-sum16 ip-checksum)
|
||||
|
||||
(require bitsyntax)
|
||||
(require "dump-bytes.rkt")
|
||||
|
||||
(define (ones-complement-+16 a b)
|
||||
(define c (+ a b))
|
||||
(bitwise-and #xffff (+ (arithmetic-shift c -16) c)))
|
||||
|
||||
(define (ones-complement-sum16 bs)
|
||||
(bit-string-case bs
|
||||
([ (n :: integer bytes 2) (rest :: binary) ]
|
||||
(ones-complement-+16 n (ones-complement-sum16 rest)))
|
||||
([ odd-byte ]
|
||||
(arithmetic-shift odd-byte 8))
|
||||
([ ]
|
||||
0)))
|
||||
|
||||
(define (ones-complement-negate16-safely x)
|
||||
(define r (bitwise-and #xffff (bitwise-not x)))
|
||||
(if (= r 0) #xffff r))
|
||||
|
||||
(define (ip-checksum offset blob #:pseudo-header [pseudo-header #""])
|
||||
(bit-string-case blob
|
||||
([ (prefix :: binary bytes offset)
|
||||
(:: binary bytes 2)
|
||||
(suffix :: binary) ]
|
||||
;; (log-info "Packet pre checksum:\n~a" (dump-bytes->string blob))
|
||||
(define result (ones-complement-+16
|
||||
(ones-complement-sum16 pseudo-header)
|
||||
(ones-complement-+16 (ones-complement-sum16 prefix)
|
||||
(ones-complement-sum16 suffix))))
|
||||
;; (log-info "result: ~a" (number->string result 16))
|
||||
(define checksum (ones-complement-negate16-safely result))
|
||||
;; (log-info "Checksum ~a" (number->string checksum 16))
|
||||
(define final-packet (bit-string (prefix :: binary)
|
||||
(checksum :: integer bytes 2)
|
||||
(suffix :: binary)))
|
||||
;; (log-info "Packet with checksum:\n~a" (dump-bytes->string final-packet))
|
||||
final-packet)))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(check-equal? (ones-complement-negate16-safely
|
||||
(ones-complement-sum16 (bytes #x45 #x00 #x00 #x54
|
||||
#x00 #x00 #x00 #x00
|
||||
#x40 #x01 #x00 #x00
|
||||
#xc0 #xa8 #x01 #xde
|
||||
#xc0 #xa8 #x01 #x8f)))
|
||||
#xf5eb))
|
|
@ -0,0 +1,18 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (struct-out host-route)
|
||||
(struct-out gateway-route)
|
||||
(struct-out net-route)
|
||||
|
||||
(struct-out route-up))
|
||||
|
||||
;; A Route is one of
|
||||
;; - (host-route IpAddrBytes NetmaskNat InterfaceName), an own-IP route
|
||||
;; - (gateway-route NetAddrBytes NetmaskNat IpAddrBytes InterfaceName), a gateway for a subnet
|
||||
;; - (net-route NetAddrBytes NetmaskNat InterfaceName), an ethernet route for a subnet
|
||||
;; NetmaskNat in a net-route is a default route.
|
||||
(struct host-route (ip-addr netmask interface-name) #:prefab)
|
||||
(struct gateway-route (network-addr netmask gateway-addr interface-name) #:prefab)
|
||||
(struct net-route (network-addr netmask link) #:prefab)
|
||||
|
||||
(struct route-up (route) #:prefab) ;; assertion: the given Route is running
|
|
@ -0,0 +1,21 @@
|
|||
#lang imperative-syndicate
|
||||
;; Demonstration stack configuration for various hosts.
|
||||
|
||||
(require racket/match)
|
||||
(require (only-in mzlib/os gethostname))
|
||||
(require (only-in racket/string string-split))
|
||||
(require "configuration.rkt")
|
||||
|
||||
(spawn
|
||||
(match (gethostname)
|
||||
["stockholm.ccs.neu.edu"
|
||||
(assert (host-route (bytes 129 10 115 94) 24 "eth0"))
|
||||
(assert (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0"))]
|
||||
[other ;; assume a private network
|
||||
(define interface
|
||||
(match (car (string-split other "."))
|
||||
["skip" "en0"]
|
||||
["leap" "wlp4s0"] ;; wtf
|
||||
[_ "wlan0"]))
|
||||
(assert (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) interface))
|
||||
(assert (host-route (bytes 192 168 1 222) 24 interface))]))
|
|
@ -0,0 +1,80 @@
|
|||
#lang racket/base
|
||||
;; Copyright (C) 2012 Tony Garnock-Jones <tonygarnockjones@gmail.com>
|
||||
;;
|
||||
;; dump-bytes.rkt is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published
|
||||
;; by the Free Software Foundation, either version 3 of the License,
|
||||
;; or (at your option) any later version.
|
||||
;;
|
||||
;; dump-bytes.rkt 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
|
||||
;; General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with dump-bytes.rkt. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; Pretty hex dump output of a Bytes.
|
||||
|
||||
(provide dump-bytes!
|
||||
dump-bytes->string
|
||||
pretty-bytes)
|
||||
|
||||
(require (only-in bitsyntax bit-string->bytes))
|
||||
(require (only-in file/sha1 bytes->hex-string))
|
||||
|
||||
(define (pretty-bytes bs)
|
||||
(bytes->hex-string (bit-string->bytes bs)))
|
||||
|
||||
;; Exact Exact -> String
|
||||
;; Returns the "0"-padded, width-digit hex representation of n
|
||||
(define (hex width n)
|
||||
(define s (number->string n 16))
|
||||
(define slen (string-length s))
|
||||
(cond
|
||||
((< slen width) (string-append (make-string (- width slen) #\0) s))
|
||||
((= slen width) s)
|
||||
((> slen width) (substring s 0 width))))
|
||||
|
||||
;; Bytes Exact -> Void
|
||||
;; Prints a pretty hex/ASCII dump of bs on (current-output-port).
|
||||
(define (dump-bytes! bs0 [requested-count #f] #:base [baseaddr 0])
|
||||
(define bs (bit-string->bytes bs0))
|
||||
(define count (if requested-count (min requested-count (bytes-length bs)) (bytes-length bs)))
|
||||
(define clipped (subbytes bs 0 count))
|
||||
(define (dump-hex i)
|
||||
(if (< i count)
|
||||
(display (hex 2 (bytes-ref clipped i)))
|
||||
(display " "))
|
||||
(display #\space))
|
||||
(define (dump-char i)
|
||||
(if (< i count)
|
||||
(let ((ch (bytes-ref clipped i)))
|
||||
(if (<= 32 ch 127)
|
||||
(display (integer->char ch))
|
||||
(display #\.)))
|
||||
(display #\space)))
|
||||
(define (for-each-between f low high)
|
||||
(do ((i low (+ i 1)))
|
||||
((= i high))
|
||||
(f i)))
|
||||
(define (dump-line i)
|
||||
(display (hex 8 (+ i baseaddr)))
|
||||
(display #\space)
|
||||
(for-each-between dump-hex i (+ i 8))
|
||||
(display ": ")
|
||||
(for-each-between dump-hex (+ i 8) (+ i 16))
|
||||
(display #\space)
|
||||
(for-each-between dump-char i (+ i 8))
|
||||
(display " : ")
|
||||
(for-each-between dump-char (+ i 8) (+ i 16))
|
||||
(newline))
|
||||
(do ((i 0 (+ i 16)))
|
||||
((>= i count))
|
||||
(dump-line i)))
|
||||
|
||||
(define (dump-bytes->string bs [requested-count #f] #:base [baseaddr 0])
|
||||
(define s (open-output-string))
|
||||
(parameterize ((current-output-port s))
|
||||
(dump-bytes! bs requested-count #:base baseaddr))
|
||||
(get-output-string s))
|
|
@ -0,0 +1,120 @@
|
|||
#lang imperative-syndicate
|
||||
;; Ethernet driver
|
||||
|
||||
(provide (struct-out available-ethernet-interface)
|
||||
(struct-out ethernet-interface)
|
||||
(struct-out ethernet-packet)
|
||||
zero-ethernet-address
|
||||
broadcast-ethernet-address
|
||||
ethernet-packet-pattern)
|
||||
|
||||
(require/activate imperative-syndicate/drivers/timer)
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require racket/async-channel)
|
||||
|
||||
(require packet-socket)
|
||||
(require bitsyntax)
|
||||
|
||||
(require "configuration.rkt")
|
||||
(require "dump-bytes.rkt")
|
||||
(require imperative-syndicate/pattern-expander)
|
||||
|
||||
(assertion-struct available-ethernet-interface (name))
|
||||
(assertion-struct ethernet-interface (name hwaddr))
|
||||
(message-struct ethernet-packet (interface-name from-wire? source destination ethertype body))
|
||||
|
||||
(define zero-ethernet-address (bytes 0 0 0 0 0 0))
|
||||
(define broadcast-ethernet-address (bytes 255 255 255 255 255 255))
|
||||
|
||||
(define interface-names (raw-interface-names))
|
||||
(log-info "Device names: ~a" interface-names)
|
||||
|
||||
(define (spawn-ethernet-driver)
|
||||
(spawn #:name 'ethernet-driver
|
||||
|
||||
(for [(n interface-names)]
|
||||
(assert (available-ethernet-interface n)))
|
||||
|
||||
(during/spawn
|
||||
(observe (ethernet-packet $interface-name #t _ _ _ _))
|
||||
#:name (list 'ethernet-interface interface-name)
|
||||
|
||||
(define h (raw-interface-open interface-name))
|
||||
(when (not h) (error 'ethernet "Couldn't open interface ~v" interface-name))
|
||||
(log-info "Opened interface ~a, yielding handle ~v" interface-name h)
|
||||
|
||||
(assert (ethernet-interface interface-name (raw-interface-hwaddr h)))
|
||||
|
||||
(define control-ch (make-async-channel))
|
||||
(thread (lambda () (interface-packet-read-loop interface-name h control-ch)))
|
||||
(signal-background-activity! +1)
|
||||
(on-start (async-channel-put control-ch 'unblock))
|
||||
(on-stop (async-channel-put control-ch 'quit))
|
||||
|
||||
;; (on (message ($ p (ethernet-packet interface #t _ _ _ _)))
|
||||
;; (log-info "Interface ~a inbound packet ~a -> ~a (type 0x~a)"
|
||||
;; (ethernet-interface-name (ethernet-packet-interface p))
|
||||
;; (pretty-bytes (ethernet-packet-source p))
|
||||
;; (pretty-bytes (ethernet-packet-destination p))
|
||||
;; (number->string (ethernet-packet-ethertype p) 16))
|
||||
;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p))))
|
||||
|
||||
(on (message ($ p (ethernet-packet interface-name #f _ _ _ _)))
|
||||
;; (log-info "Interface ~a OUTBOUND packet ~a -> ~a (type 0x~a)"
|
||||
;; (ethernet-interface-name (ethernet-packet-interface p))
|
||||
;; (pretty-bytes (ethernet-packet-source p))
|
||||
;; (pretty-bytes (ethernet-packet-destination p))
|
||||
;; (number->string (ethernet-packet-ethertype p) 16))
|
||||
;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p)))
|
||||
(raw-interface-write h (encode-ethernet-packet p))))))
|
||||
|
||||
(define (interface-packet-read-loop interface-name h control-ch)
|
||||
(define (blocked)
|
||||
(match (async-channel-get control-ch)
|
||||
['unblock (unblocked)]
|
||||
['quit (void)]))
|
||||
(define (unblocked)
|
||||
(match (async-channel-try-get control-ch)
|
||||
['unblock (unblocked)]
|
||||
['quit (void)]
|
||||
[#f
|
||||
(define p (raw-interface-read h))
|
||||
(define decoded (decode-ethernet-packet interface-name p))
|
||||
(when decoded (ground-send! decoded))
|
||||
(unblocked)]))
|
||||
(blocked)
|
||||
(raw-interface-close h)
|
||||
(signal-background-activity! -1))
|
||||
|
||||
(define (decode-ethernet-packet interface-name p)
|
||||
(bit-string-case p
|
||||
([ (destination :: binary bytes 6)
|
||||
(source :: binary bytes 6)
|
||||
(ethertype :: integer bytes 2)
|
||||
(body :: binary) ]
|
||||
(ethernet-packet interface-name
|
||||
#t
|
||||
(bit-string->bytes source)
|
||||
(bit-string->bytes destination)
|
||||
ethertype
|
||||
(bit-string->bytes body)))
|
||||
(else #f)))
|
||||
|
||||
(define (encode-ethernet-packet p)
|
||||
(match-define (ethernet-packet _ _ source destination ethertype body) p)
|
||||
(bit-string->bytes
|
||||
(bit-string (destination :: binary bytes 6)
|
||||
(source :: binary bytes 6)
|
||||
(ethertype :: integer bytes 2)
|
||||
(body :: binary))))
|
||||
|
||||
(begin-for-declarations
|
||||
(define-pattern-expander ethernet-packet-pattern
|
||||
(syntax-rules ()
|
||||
[(_ interface-name from-wire? ethertype)
|
||||
(ethernet-packet interface-name from-wire? _ _ ethertype _)])))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(spawn-ethernet-driver)
|
|
@ -0,0 +1,32 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require/activate "ethernet.rkt")
|
||||
(require/activate "arp.rkt")
|
||||
(require/activate "ip.rkt")
|
||||
(require/activate "tcp.rkt")
|
||||
(require/activate "udp.rkt")
|
||||
(require/activate "demo-config.rkt")
|
||||
(require net/dns) ;; not syndicateish yet
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(let ()
|
||||
(define host "www.w3.org")
|
||||
(define port 80)
|
||||
(define connection-id 'httpclient)
|
||||
(define remote-handle (tcp-address (dns-get-address (dns-find-nameserver) host) port))
|
||||
|
||||
(spawn (assert (tcp-connection connection-id remote-handle))
|
||||
(stop-when (asserted (tcp-rejected connection-id $reason))
|
||||
(local-require racket/exn)
|
||||
(printf "Connection failed:\n ~a" (exn->string reason)))
|
||||
(on (asserted (tcp-accepted connection-id))
|
||||
(send! (tcp-out connection-id
|
||||
(bytes-append #"GET / HTTP/1.0\r\nHost: "
|
||||
(string->bytes/utf-8 host)
|
||||
#"\r\n\r\n"))))
|
||||
(stop-when (retracted (tcp-accepted connection-id))
|
||||
(printf "URL fetcher exiting.\n"))
|
||||
(on (message (tcp-in connection-id $bs))
|
||||
(printf "----------------------------------------\n~a\n" bs)
|
||||
(printf "----------------------------------------\n"))))
|
|
@ -0,0 +1,259 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide (struct-out ip-packet)
|
||||
ip-address->hostname
|
||||
ip-string->ip-address
|
||||
apply-netmask
|
||||
ip-address-in-subnet?
|
||||
query-local-ip-addresses
|
||||
broadcast-ip-address
|
||||
spawn-ip-driver)
|
||||
|
||||
(require racket/set)
|
||||
(require (only-in racket/string string-split))
|
||||
(require bitsyntax)
|
||||
|
||||
(require "dump-bytes.rkt")
|
||||
(require "configuration.rkt")
|
||||
(require "checksum.rkt")
|
||||
|
||||
(require/activate imperative-syndicate/drivers/timer)
|
||||
(require/activate "ethernet.rkt")
|
||||
(require/activate "arp.rkt")
|
||||
|
||||
(message-struct ip-packet
|
||||
(source-interface ;; string for an ethernet interface, or #f for local interfaces
|
||||
source
|
||||
destination
|
||||
protocol
|
||||
options
|
||||
body
|
||||
;; TODO: more fields
|
||||
))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (ip-address->hostname bs)
|
||||
(bit-string-case bs
|
||||
([ a b c d ] (format "~a.~a.~a.~a" a b c d))))
|
||||
|
||||
(define (ip-string->ip-address str)
|
||||
(list->bytes (map string->number (string-split str "."))))
|
||||
|
||||
(define (apply-netmask addr netmask)
|
||||
(bit-string-case addr
|
||||
([ (n :: integer bytes 4) ]
|
||||
(bit-string ((bitwise-and n (arithmetic-shift #x-100000000 (- netmask)))
|
||||
:: integer bytes 4)))))
|
||||
|
||||
(define (ip-address-in-subnet? addr network netmask)
|
||||
(equal? (apply-netmask network netmask)
|
||||
(apply-netmask addr netmask)))
|
||||
|
||||
(define broadcast-ip-address (bytes 255 255 255 255))
|
||||
|
||||
(define (query-local-ip-addresses)
|
||||
(query-set local-ips (host-route $addr _ _) addr))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (spawn-ip-driver)
|
||||
(spawn #:name 'ip-driver
|
||||
(during/spawn (host-route $my-address $netmask $interface-name)
|
||||
(assert (route-up (host-route my-address netmask interface-name)))
|
||||
(do-host-route my-address netmask interface-name))
|
||||
(during/spawn (gateway-route $network $netmask $gateway-addr $interface-name)
|
||||
(assert (route-up (gateway-route network netmask gateway-addr interface-name)))
|
||||
(do-gateway-route network netmask gateway-addr interface-name))
|
||||
(during/spawn (net-route $network-addr $netmask $link)
|
||||
(assert (route-up (net-route network-addr netmask link)))
|
||||
(do-net-route network-addr netmask link))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Local IP route
|
||||
|
||||
(define (do-host-route my-address netmask interface-name)
|
||||
(let ((network-addr (apply-netmask my-address netmask)))
|
||||
(do-normal-ip-route (host-route my-address netmask interface-name)
|
||||
network-addr
|
||||
netmask
|
||||
interface-name))
|
||||
|
||||
(assert (arp-assertion IPv4-ethertype my-address interface-name))
|
||||
(on (message (ip-packet _ $peer-address my-address PROTOCOL-ICMP _ $body))
|
||||
(bit-string-case body
|
||||
([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum
|
||||
(case type
|
||||
[(8) ;; ECHO (0 is ECHO-REPLY)
|
||||
(log-info "Ping of ~a from ~a"
|
||||
(pretty-bytes my-address)
|
||||
(pretty-bytes peer-address))
|
||||
(define reply-data0 (bit-string 0
|
||||
code
|
||||
(0 :: integer bytes 2) ;; TODO
|
||||
(rest :: binary)))
|
||||
(send! (ip-packet #f
|
||||
my-address
|
||||
peer-address
|
||||
PROTOCOL-ICMP
|
||||
#""
|
||||
(ip-checksum 2 reply-data0)))]
|
||||
[else
|
||||
(log-info "ICMP ~a/~a (cksum ~a) to ~a from ~a:\n~a"
|
||||
type
|
||||
code
|
||||
checksum
|
||||
(pretty-bytes my-address)
|
||||
(pretty-bytes peer-address)
|
||||
(dump-bytes->string rest))]))
|
||||
(else #f))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Gateway IP route
|
||||
|
||||
(define (do-gateway-route network netmask gateway-addr interface-name)
|
||||
(define the-route (gateway-route network netmask gateway-addr interface-name))
|
||||
|
||||
(field [routes (set)])
|
||||
(query-set* routes (host-route $addr $netmask _) (list addr netmask))
|
||||
(query-set* routes (gateway-route $addr $netmask _ _) (list addr netmask))
|
||||
(query-set* routes (net-route $addr $netmask _) (list addr netmask))
|
||||
|
||||
(define (covered-by-some-other-route? addr)
|
||||
(for/or ([r (in-set (routes))])
|
||||
(match-define (list net msk) r)
|
||||
(and (positive? msk)
|
||||
(ip-address-in-subnet? addr net msk))))
|
||||
|
||||
(during (ethernet-interface interface-name $gateway-interface-hwaddr)
|
||||
(field [gateway-hwaddr #f])
|
||||
(on (asserted (arp-query IPv4-ethertype gateway-addr interface-name $hwaddr))
|
||||
(when (not (gateway-hwaddr))
|
||||
(log-info "Discovered gateway ~a at ~a on interface ~a."
|
||||
(ip-address->hostname gateway-addr)
|
||||
interface-name
|
||||
(pretty-bytes hwaddr)))
|
||||
(gateway-hwaddr hwaddr))
|
||||
|
||||
(on (message ($ p (ip-packet _ _ _ _ _ _)))
|
||||
(when (not (gateway-hwaddr))
|
||||
(log-warning "Gateway hwaddr for ~a not known, packet dropped."
|
||||
(ip-address->hostname gateway-addr)))
|
||||
(when (and (gateway-hwaddr)
|
||||
(not (equal? (ip-packet-source-interface p) interface-name))
|
||||
(not (covered-by-some-other-route? (ip-packet-destination p))))
|
||||
(send! (ethernet-packet interface-name
|
||||
#f
|
||||
gateway-interface-hwaddr
|
||||
(gateway-hwaddr)
|
||||
IPv4-ethertype
|
||||
(format-ip-packet p)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; General net route
|
||||
|
||||
(define (do-net-route network-addr netmask link)
|
||||
(do-normal-ip-route (net-route network-addr netmask link) network-addr netmask link))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Normal IP route
|
||||
|
||||
(define (do-normal-ip-route the-route network netmask interface-name)
|
||||
(assert (arp-interface interface-name))
|
||||
(on (message (ethernet-packet interface-name #t _ _ IPv4-ethertype $body))
|
||||
(define p (parse-ip-packet interface-name body))
|
||||
(when p (send! p)))
|
||||
(during (ethernet-interface interface-name $interface-hwaddr)
|
||||
(on (message ($ p (ip-packet _ _ _ _ _ _)))
|
||||
(define destination (ip-packet-destination p))
|
||||
(when (and (not (equal? (ip-packet-source-interface p) interface-name))
|
||||
(ip-address-in-subnet? destination network netmask))
|
||||
;; v Use `spawn` instead of `react` to avoid gratuitous packet
|
||||
;; reordering.
|
||||
(spawn (stop-when-timeout 5000
|
||||
(log-warning "ARP lookup of ~a failed, packet dropped"
|
||||
(ip-address->hostname destination)))
|
||||
(stop-when (asserted (arp-query IPv4-ethertype
|
||||
destination
|
||||
interface-name
|
||||
$destination-hwaddr))
|
||||
(send! (ethernet-packet interface-name
|
||||
#f
|
||||
interface-hwaddr
|
||||
destination-hwaddr
|
||||
IPv4-ethertype
|
||||
(format-ip-packet p)))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define IPv4-ethertype #x0800)
|
||||
|
||||
(define IP-VERSION 4)
|
||||
(define IP-MINIMUM-HEADER-LENGTH 5)
|
||||
|
||||
(define PROTOCOL-ICMP 1)
|
||||
|
||||
(define default-ttl 64)
|
||||
|
||||
(define (parse-ip-packet interface-name body)
|
||||
;; (log-info "IP ~a got body ~a" (pretty-bytes my-address) (pretty-bytes body))
|
||||
(bit-string-case body
|
||||
([ (= IP-VERSION :: bits 4)
|
||||
(header-length :: bits 4)
|
||||
service-type
|
||||
(total-length :: bits 16)
|
||||
(id :: bits 16)
|
||||
(flags :: bits 3)
|
||||
(fragment-offset :: bits 13)
|
||||
ttl
|
||||
protocol
|
||||
(header-checksum :: bits 16) ;; TODO: check checksum
|
||||
(source-ip0 :: binary bits 32)
|
||||
(destination-ip0 :: binary bits 32)
|
||||
(rest :: binary) ]
|
||||
(let* ((source-ip (bit-string->bytes source-ip0))
|
||||
(destination-ip (bit-string->bytes destination-ip0))
|
||||
(options-length (* 4 (- header-length IP-MINIMUM-HEADER-LENGTH)))
|
||||
(data-length (- total-length (* 4 header-length))))
|
||||
(if (and (>= header-length 5)
|
||||
(>= (bit-string-byte-count body) (* header-length 4)))
|
||||
(bit-string-case rest
|
||||
([ (opts :: binary bytes options-length)
|
||||
(data :: binary bytes data-length)
|
||||
(:: binary) ] ;; Very short ethernet packets have a trailer of zeros
|
||||
(ip-packet interface-name
|
||||
(bit-string->bytes source-ip)
|
||||
(bit-string->bytes destination-ip)
|
||||
protocol
|
||||
(bit-string->bytes opts)
|
||||
(bit-string->bytes data))))
|
||||
#f)))
|
||||
(else #f)))
|
||||
|
||||
(define (format-ip-packet p)
|
||||
(match-define (ip-packet _ src dst protocol options body) p)
|
||||
|
||||
(define header-length ;; TODO: ensure options is a multiple of 4 bytes
|
||||
(+ IP-MINIMUM-HEADER-LENGTH (quotient (bit-string-byte-count options) 4)))
|
||||
|
||||
(define header0 (bit-string (IP-VERSION :: bits 4)
|
||||
(header-length :: bits 4)
|
||||
0 ;; TODO: service type
|
||||
((+ (* header-length 4) (bit-string-byte-count body))
|
||||
:: bits 16)
|
||||
(0 :: bits 16) ;; TODO: identifier
|
||||
(0 :: bits 3) ;; TODO: flags
|
||||
(0 :: bits 13) ;; TODO: fragments
|
||||
default-ttl
|
||||
protocol
|
||||
(0 :: bits 16)
|
||||
(src :: binary bits 32)
|
||||
(dst :: binary bits 32)
|
||||
(options :: binary)))
|
||||
(define full-packet (bit-string ((ip-checksum 10 header0) :: binary) (body :: binary)))
|
||||
|
||||
full-packet)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(spawn-ip-driver)
|
|
@ -0,0 +1,93 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require/activate imperative-syndicate/drivers/timer)
|
||||
(require/activate "ethernet.rkt")
|
||||
(require/activate "arp.rkt")
|
||||
(require/activate "ip.rkt")
|
||||
(require/activate "tcp.rkt")
|
||||
(require/activate "udp.rkt")
|
||||
(require/activate "demo-config.rkt")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(let ()
|
||||
(local-require racket/format)
|
||||
|
||||
(message-struct speak (who what))
|
||||
(assertion-struct present (who))
|
||||
|
||||
(dataspace #:name 'chat-server-app
|
||||
(spawn #:name 'chat-server
|
||||
(during/spawn (inbound (tcp-connection $id (tcp-listener 5999)))
|
||||
#:name (list 'chat-connection id)
|
||||
(assert (outbound (tcp-accepted id)))
|
||||
(let ((me (gensym 'user)))
|
||||
(assert (present me))
|
||||
(on (message (inbound (tcp-in-line id $bs)))
|
||||
(match bs
|
||||
[#"/quit" (stop-current-facet)]
|
||||
[_ (send! (speak me (bytes->string/utf-8 bs)))])))
|
||||
(during (present $user)
|
||||
(on-start (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " arrived\n"))))))
|
||||
(on-stop (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " left\n"))))))
|
||||
(on (message (speak user $text))
|
||||
(send! (outbound
|
||||
(tcp-out id (string->bytes/utf-8 (~a user " says '" text "'\n")))))))))))
|
||||
|
||||
(let ()
|
||||
(dataspace #:name 'connection-rejection-test
|
||||
(spawn #:name 'connection-rejection-main
|
||||
(local-require racket/exn)
|
||||
(define peer-host "192.168.1.1")
|
||||
;; TODO: ^ this will only reliably "fail" the way we want on my own network...
|
||||
(define peer-port 9999)
|
||||
(assert (outbound (tcp-connection 'x (tcp-address peer-host peer-port))))
|
||||
(stop-when (asserted (inbound (tcp-rejected 'x $reason)))
|
||||
(log-info "Connection to ~a:~a rejected:\n~a" peer-host peer-port (exn->string reason)))
|
||||
(on (asserted (inbound (tcp-accepted 'x)))
|
||||
(error 'connection-rejection-main
|
||||
"Unexpected accepted connection???")))))
|
||||
|
||||
(let ((dst (udp-listener 6667)))
|
||||
(dataspace #:name 'udp-echo-program-app
|
||||
(spawn #:name 'udp-echo-program
|
||||
(on (message (inbound (udp-packet $src dst $body)))
|
||||
(log-info "Got packet from ~v: ~v" src body)
|
||||
(send! (outbound
|
||||
(udp-packet dst src (string->bytes/utf-8 (format "You said: ~a" body)))))))))
|
||||
|
||||
(let ()
|
||||
(dataspace #:name 'webserver-dataspace
|
||||
(spawn #:name 'webserver-counter
|
||||
(field [counter 0])
|
||||
(on (message 'bump)
|
||||
(send! `(counter ,(counter)))
|
||||
(counter (+ (counter) 1))))
|
||||
|
||||
(define us (tcp-listener 80))
|
||||
(spawn #:name 'webserver
|
||||
(during/spawn (inbound (tcp-connection $them us))
|
||||
#:name (list 'webserver-session them)
|
||||
(log-info "Got connection from ~v" them)
|
||||
(assert (outbound (tcp-accepted them)))
|
||||
(on (message (inbound (tcp-in them _)))) ;; ignore input
|
||||
|
||||
(on-start (send! 'bump))
|
||||
(on (message `(counter ,$counter))
|
||||
(define response
|
||||
(string->bytes/utf-8
|
||||
(format (string-append
|
||||
"HTTP/1.0 200 OK\r\n"
|
||||
"Content-Type: text/html\r\n"
|
||||
"\r\n"
|
||||
"<h1>Hello world from syndicate-netstack!</h1>\n"
|
||||
"<p>This is running on syndicate's own\n"
|
||||
"<a href='https://github.com/tonyg/syndicate/'>\n"
|
||||
"TCP/IP stack</a>.</p>\n"
|
||||
"<p>There have been ~a requests prior to this one.</p>\n")
|
||||
counter)))
|
||||
(send! (outbound (tcp-out them response)))
|
||||
(for [(i 4)]
|
||||
(define buf (make-bytes 1024 (+ #x30 (modulo i 10))))
|
||||
(send! (outbound (tcp-out them buf))))
|
||||
(stop-facet (current-facet)))))))
|
|
@ -0,0 +1,36 @@
|
|||
#lang imperative-syndicate
|
||||
;; UDP/TCP port allocator
|
||||
|
||||
(provide spawn-port-allocator
|
||||
allocate-port!
|
||||
(struct-out port-allocation-request)
|
||||
(struct-out port-allocation-reply))
|
||||
|
||||
(require racket/set)
|
||||
(require "ip.rkt")
|
||||
|
||||
(struct port-allocation-request (reqid type) #:prefab)
|
||||
(struct port-allocation-reply (reqid port) #:prefab)
|
||||
|
||||
(define (spawn-port-allocator allocator-type query-used-ports)
|
||||
(spawn #:name (list 'port-allocator allocator-type)
|
||||
(define local-ips (query-local-ip-addresses))
|
||||
(define used-ports (query-used-ports))
|
||||
|
||||
(begin/dataflow
|
||||
(log-info "port-allocator ~v used ports: ~v" allocator-type (used-ports)))
|
||||
|
||||
(on (message (port-allocation-request $reqid allocator-type))
|
||||
(define currently-used-ports (used-ports))
|
||||
(let randomly-allocate-until-unused ()
|
||||
(define p (+ 1024 (random 64512)))
|
||||
(if (set-member? currently-used-ports p)
|
||||
(randomly-allocate-until-unused)
|
||||
(begin (used-ports (set-add currently-used-ports p))
|
||||
(send! (port-allocation-reply reqid p))))))))
|
||||
|
||||
(define (allocate-port! type)
|
||||
(define reqid (gensym 'allocate-port!))
|
||||
(react/suspend (done)
|
||||
(stop-when (message (port-allocation-reply reqid $port)) (done port))
|
||||
(on-start (send! (port-allocation-request reqid type)))))
|
|
@ -0,0 +1,771 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide (struct-out tcp-connection)
|
||||
(struct-out tcp-accepted)
|
||||
(struct-out tcp-rejected)
|
||||
(struct-out tcp-out)
|
||||
(struct-out tcp-in)
|
||||
(struct-out tcp-in-line)
|
||||
|
||||
(struct-out tcp-address)
|
||||
(struct-out tcp-listener)
|
||||
|
||||
spawn-tcp-driver)
|
||||
|
||||
(require racket/set)
|
||||
(require bitsyntax)
|
||||
|
||||
(require "dump-bytes.rkt")
|
||||
(require "checksum.rkt")
|
||||
|
||||
(require/activate imperative-syndicate/drivers/timer)
|
||||
(require "ip.rkt")
|
||||
(require "port-allocator.rkt")
|
||||
|
||||
(module+ test (require rackunit))
|
||||
|
||||
(define-logger netstack/tcp)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Protocol messages
|
||||
|
||||
(assertion-struct tcp-connection (id spec))
|
||||
(assertion-struct tcp-accepted (id))
|
||||
(assertion-struct tcp-rejected (id exn))
|
||||
(message-struct tcp-out (id bytes))
|
||||
(message-struct tcp-in (id bytes))
|
||||
(message-struct tcp-in-line (id bytes))
|
||||
|
||||
(assertion-struct tcp-address (host port))
|
||||
(assertion-struct tcp-listener (port))
|
||||
|
||||
(assertion-struct tcp-quad (remote-ip remote-port local-ip local-port))
|
||||
|
||||
(message-struct tcp-packet (from-wire?
|
||||
quad
|
||||
sequence-number
|
||||
ack-number
|
||||
flags
|
||||
window-size
|
||||
options
|
||||
data))
|
||||
|
||||
;; (tcp-port-allocation Number (U TcpAddress TcpListener))
|
||||
(assertion-struct tcp-port-allocation (port handle))
|
||||
|
||||
(define (tcp-quad->string from-wire? q)
|
||||
(match-define (tcp-quad ri rp li lp) q)
|
||||
(if from-wire?
|
||||
(format "(I) ~a:~a -> ~a:~a" (ip-address->hostname ri) rp (ip-address->hostname li) lp)
|
||||
(format "(O) ~a:~a -> ~a:~a" (ip-address->hostname li) lp (ip-address->hostname ri) rp)))
|
||||
|
||||
(define (summarize-tcp-packet packet)
|
||||
(format "~a (seq ~a, ack ~a, flags ~a, window ~a, payload ~a)"
|
||||
(tcp-quad->string (tcp-packet-from-wire? packet) (tcp-packet-quad packet))
|
||||
(tcp-packet-sequence-number packet)
|
||||
(tcp-packet-ack-number packet)
|
||||
(tcp-packet-flags packet)
|
||||
(tcp-packet-window-size packet)
|
||||
(bit-string-byte-count (tcp-packet-data packet))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Driver startup
|
||||
|
||||
(define PROTOCOL-TCP 6)
|
||||
|
||||
(define (spawn-tcp-driver)
|
||||
(spawn-port-allocator 'tcp (lambda () (query-set tcp-ports (tcp-port-allocation $p _) p)))
|
||||
|
||||
(spawn #:name 'kernel-tcp-driver
|
||||
(define local-ips (query-local-ip-addresses))
|
||||
|
||||
(define/query-set active-state-vectors ($ q (tcp-quad _ _ _ _)) q)
|
||||
|
||||
(define (state-vector-active? statevec)
|
||||
(set-member? (active-state-vectors) statevec))
|
||||
|
||||
(define (analyze-incoming-packet src-ip dst-ip body)
|
||||
(bit-string-case body
|
||||
([ (src-port :: integer bytes 2)
|
||||
(dst-port :: integer bytes 2)
|
||||
(sequence-number :: integer bytes 4)
|
||||
(ack-number :: integer bytes 4)
|
||||
(data-offset :: integer bits 4)
|
||||
(reserved :: integer bits 3)
|
||||
(ns :: integer bits 1)
|
||||
(cwr :: integer bits 1)
|
||||
(ece :: integer bits 1)
|
||||
(urg :: integer bits 1)
|
||||
(ack :: integer bits 1)
|
||||
(psh :: integer bits 1)
|
||||
(rst :: integer bits 1)
|
||||
(syn :: integer bits 1)
|
||||
(fin :: integer bits 1)
|
||||
(window-size :: integer bytes 2)
|
||||
(checksum :: integer bytes 2) ;; TODO: check checksum
|
||||
(urgent-pointer :: integer bytes 2)
|
||||
(rest :: binary) ]
|
||||
(let* ((flags (set))
|
||||
(statevec (tcp-quad src-ip src-port dst-ip dst-port))
|
||||
(old-active-state-vectors (active-state-vectors))
|
||||
(spawn-needed? (and (not (state-vector-active? statevec))
|
||||
(zero? rst)))) ;; don't bother spawning if it's a rst
|
||||
(define-syntax-rule (set-flags! v ...)
|
||||
(begin (unless (zero? v) (set! flags (set-add flags 'v))) ...))
|
||||
(set-flags! ns cwr ece urg ack psh rst syn fin)
|
||||
(bit-string-case rest
|
||||
([ (opts :: binary bytes (- (* data-offset 4) 20))
|
||||
(data :: binary) ]
|
||||
(let ((packet (tcp-packet #t
|
||||
statevec
|
||||
sequence-number
|
||||
ack-number
|
||||
flags
|
||||
window-size
|
||||
(bit-string->bytes opts)
|
||||
(bit-string->bytes data))))
|
||||
(log-netstack/tcp-debug "TCP ~a" (summarize-tcp-packet packet))
|
||||
(when spawn-needed?
|
||||
(log-netstack/tcp-debug " - spawn needed!")
|
||||
(active-state-vectors (set-add (active-state-vectors) statevec))
|
||||
(spawn-state-vector #f (tcp-address (ip-address->hostname src-ip) src-port) statevec))
|
||||
(send! packet)))
|
||||
(else #f))))
|
||||
(else #f)))
|
||||
|
||||
(begin/dataflow
|
||||
(log-netstack/tcp-debug "SCN yielded statevecs ~v and local-ips ~v"
|
||||
(active-state-vectors)
|
||||
(local-ips)))
|
||||
|
||||
(define (deliver-outbound-packet p)
|
||||
(match-define (tcp-packet #f
|
||||
(tcp-quad dst-ip ;; \__ remote
|
||||
dst-port ;; /
|
||||
src-ip ;; \__ local
|
||||
src-port) ;; /
|
||||
sequence-number
|
||||
ack-number
|
||||
flags
|
||||
window-size
|
||||
options
|
||||
data)
|
||||
p)
|
||||
(log-netstack/tcp-debug "TCP ~a" (summarize-tcp-packet p))
|
||||
(define (flag-bit sym) (if (set-member? flags sym) 1 0))
|
||||
(define payload (bit-string (src-port :: integer bytes 2)
|
||||
(dst-port :: integer bytes 2)
|
||||
(sequence-number :: integer bytes 4)
|
||||
(ack-number :: integer bytes 4)
|
||||
((+ 5 (quotient (bit-string-byte-count options) 4))
|
||||
:: integer bits 4) ;; TODO: enforce 4-byte alignment
|
||||
(0 :: integer bits 3)
|
||||
((flag-bit 'ns) :: integer bits 1)
|
||||
((flag-bit 'cwr) :: integer bits 1)
|
||||
((flag-bit 'ece) :: integer bits 1)
|
||||
((flag-bit 'urg) :: integer bits 1)
|
||||
((flag-bit 'ack) :: integer bits 1)
|
||||
((flag-bit 'psh) :: integer bits 1)
|
||||
((flag-bit 'rst) :: integer bits 1)
|
||||
((flag-bit 'syn) :: integer bits 1)
|
||||
((flag-bit 'fin) :: integer bits 1)
|
||||
(window-size :: integer bytes 2)
|
||||
(0 :: integer bytes 2) ;; checksum location
|
||||
(0 :: integer bytes 2) ;; TODO: urgent pointer
|
||||
(data :: binary)))
|
||||
(define pseudo-header (bit-string (src-ip :: binary bytes 4)
|
||||
(dst-ip :: binary bytes 4)
|
||||
0
|
||||
PROTOCOL-TCP
|
||||
((bit-string-byte-count payload) :: integer bytes 2)))
|
||||
(send! (ip-packet #f src-ip dst-ip PROTOCOL-TCP #""
|
||||
(ip-checksum 16 payload #:pseudo-header pseudo-header))))
|
||||
|
||||
(on (message (ip-packet $source-if $src $dst PROTOCOL-TCP _ $body))
|
||||
(when (and source-if ;; source-if == #f iff packet originates locally
|
||||
(set-member? (local-ips) dst))
|
||||
(analyze-incoming-packet src dst body)))
|
||||
|
||||
(on (message ($ p (tcp-packet #f _ _ _ _ _ _ _)))
|
||||
(deliver-outbound-packet p))
|
||||
|
||||
(during (observe (tcp-connection _ (tcp-listener $port)))
|
||||
(assert (tcp-port-allocation port (tcp-listener port))))
|
||||
|
||||
(on (asserted (tcp-connection $id (tcp-address $remote-host $remote-port)))
|
||||
(define port (allocate-port! 'tcp))
|
||||
;; TODO: Choose a sensible IP address for the outbound
|
||||
;; connection. We don't have enough information to do this
|
||||
;; well at the moment, so just pick some available local IP
|
||||
;; address.
|
||||
;;
|
||||
;; Interesting note: In some sense, the right answer is a
|
||||
;; *wildcard*. This would give us a form of mobility, where IP
|
||||
;; addresses only route to a given bucket-of-state and ONLY the
|
||||
;; port number selects a substate therein. That's not how TCP
|
||||
;; is defined however so we can't do that.
|
||||
(define appropriate-ip (set-first (local-ips)))
|
||||
(define appropriate-host (ip-address->hostname appropriate-ip))
|
||||
(define remote-ip (ip-string->ip-address remote-host))
|
||||
(define q (tcp-quad remote-ip remote-port appropriate-ip port))
|
||||
(active-state-vectors (set-add (active-state-vectors) q))
|
||||
(spawn-state-vector #t id q))
|
||||
|
||||
(during/spawn (observe (tcp-in-line $id _))
|
||||
#:name (list 'drivers/tcp 'line-reader id)
|
||||
(local-require (only-in syndicate/support/bytes bytes-index))
|
||||
(field [buffer #""])
|
||||
(on (message (tcp-in id $bs)) (buffer (bytes-append (buffer) bs)))
|
||||
(begin/dataflow
|
||||
(define newline-pos (bytes-index (buffer) (char->integer #\newline)))
|
||||
(when newline-pos
|
||||
(define line (subbytes (buffer) 0 newline-pos))
|
||||
(buffer (subbytes (buffer) (+ newline-pos 1)))
|
||||
(send! (tcp-in-line id line)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Per-connection state vector process
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; From the RFC:
|
||||
;;
|
||||
;; Send Sequence Variables
|
||||
;;
|
||||
;; SND.UNA - send unacknowledged
|
||||
;; SND.NXT - send next
|
||||
;; SND.WND - send window
|
||||
;; SND.UP - send urgent pointer
|
||||
;; SND.WL1 - segment sequence number used for last window update
|
||||
;; SND.WL2 - segment acknowledgment number used for last window
|
||||
;; update
|
||||
;; ISS - initial send sequence number
|
||||
;;
|
||||
;; Receive Sequence Variables
|
||||
;;
|
||||
;; RCV.NXT - receive next
|
||||
;; RCV.WND - receive window
|
||||
;; RCV.UP - receive urgent pointer
|
||||
;; IRS - initial receive sequence number
|
||||
;;
|
||||
;; The following diagrams may help to relate some of these variables to
|
||||
;; the sequence space.
|
||||
;;
|
||||
;; Send Sequence Space
|
||||
;;
|
||||
;; 1 2 3 4
|
||||
;; ----------|----------|----------|----------
|
||||
;; SND.UNA SND.NXT SND.UNA
|
||||
;; +SND.WND
|
||||
;;
|
||||
;; 1 - old sequence numbers which have been acknowledged
|
||||
;; 2 - sequence numbers of unacknowledged data
|
||||
;; 3 - sequence numbers allowed for new data transmission
|
||||
;; 4 - future sequence numbers which are not yet allowed
|
||||
;;
|
||||
;; Send Sequence Space
|
||||
;;
|
||||
;; Figure 4.
|
||||
;;
|
||||
;; The send window is the portion of the sequence space labeled 3 in
|
||||
;; figure 4.
|
||||
;;
|
||||
;; Receive Sequence Space
|
||||
;;
|
||||
;; 1 2 3
|
||||
;; ----------|----------|----------
|
||||
;; RCV.NXT RCV.NXT
|
||||
;; +RCV.WND
|
||||
;;
|
||||
;; 1 - old sequence numbers which have been acknowledged
|
||||
;; 2 - sequence numbers allowed for new reception
|
||||
;; 3 - future sequence numbers which are not yet allowed
|
||||
;;
|
||||
;; Receive Sequence Space
|
||||
;;
|
||||
;; Figure 5.
|
||||
;;
|
||||
;; The receive window is the portion of the sequence space labeled 2 in
|
||||
;; figure 5.
|
||||
;;
|
||||
;; There are also some variables used frequently in the discussion that
|
||||
;; take their values from the fields of the current segment.
|
||||
;;
|
||||
;; Current Segment Variables
|
||||
;;
|
||||
;; SEG.SEQ - segment sequence number
|
||||
;; SEG.ACK - segment acknowledgment number
|
||||
;; SEG.LEN - segment length
|
||||
;; SEG.WND - segment window
|
||||
;; SEG.UP - segment urgent pointer
|
||||
;; SEG.PRC - segment precedence value
|
||||
;;
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(struct buffer (data ;; bit-string
|
||||
seqn ;; names leftmost byte in data
|
||||
window ;; counts bytes from leftmost byte in data
|
||||
finished?) ;; boolean: true after FIN
|
||||
#:transparent)
|
||||
|
||||
;; Regarding acks:
|
||||
;;
|
||||
;; - we send an ack number that is (buffer-seqn (inbound)) plus the
|
||||
;; number of buffered bytes.
|
||||
;;
|
||||
;; - acks received allow us to advance (buffer-seqn (outbound)) (that
|
||||
;; is, SND.UNA) to that point, discarding buffered data to do so.
|
||||
|
||||
;; Regarding windows:
|
||||
;;
|
||||
;; - (buffer-window (outbound)) is the size of the peer's receive
|
||||
;; window. Do not allow more than this many bytes to be
|
||||
;; unacknowledged on the wire.
|
||||
;;
|
||||
;; - (buffer-window (inbound)) is the size of our receive window. The
|
||||
;; peer should not exceed this; we should ignore data received that
|
||||
;; extends beyond this. Once we implement flow control locally
|
||||
;; (ahem) we should move this around, but at present it is fixed.
|
||||
|
||||
;; TODO: Zero receive window probe when we have something to say.
|
||||
|
||||
(define (buffer-push b data)
|
||||
(struct-copy buffer b [data (bit-string-append (buffer-data b) data)]))
|
||||
|
||||
(define inbound-buffer-limit 65535)
|
||||
(define maximum-segment-size 536) ;; bytes
|
||||
(define maximum-segment-lifetime-sec (* 2 60)) ;; two minutes; 2MSL is TIME-WAIT timeout
|
||||
(define user-timeout-msec (* 5 60 1000)) ;; per RFC 793, this should be per-connection, but I
|
||||
;; cheat; RFC 793 says "the present global default is five minutes", which is
|
||||
;; reasonable to be getting on with
|
||||
|
||||
(define (seq+ a b) (bitwise-and #xffffffff (+ a b)))
|
||||
|
||||
;; Always positive
|
||||
(define (seq- larger smaller)
|
||||
(if (< larger smaller) ;; wraparound has occurred
|
||||
(+ (- larger smaller) #x100000000)
|
||||
(- larger smaller)))
|
||||
|
||||
(define (seq> a b)
|
||||
(not (seq>= b a)))
|
||||
|
||||
(define (seq>= a b)
|
||||
(< (seq- a b) #x80000000))
|
||||
|
||||
(define (seq-min a b) (if (seq> a b) b a))
|
||||
(define (seq-max a b) (if (seq> a b) a b))
|
||||
|
||||
(module+ test
|
||||
(check-equal? (seq+ 41724780 1) 41724781)
|
||||
(check-equal? (seq+ 0 1) 1)
|
||||
(check-equal? (seq+ #x80000000 1) #x80000001)
|
||||
(check-equal? (seq+ #xffffffff 1) #x00000000)
|
||||
|
||||
(check-equal? (seq> 41724780 41724780) #f)
|
||||
(check-equal? (seq> 41724781 41724780) #t)
|
||||
(check-equal? (seq> 41724780 41724781) #f)
|
||||
|
||||
(check-equal? (seq> 0 0) #f)
|
||||
(check-equal? (seq> 1 0) #t)
|
||||
(check-equal? (seq> 0 1) #f)
|
||||
|
||||
(check-equal? (seq> #x80000000 #x80000000) #f)
|
||||
(check-equal? (seq> #x80000001 #x80000000) #t)
|
||||
(check-equal? (seq> #x80000000 #x80000001) #f)
|
||||
|
||||
(check-equal? (seq> #xffffffff #xffffffff) #f)
|
||||
(check-equal? (seq> #x00000000 #xffffffff) #t)
|
||||
(check-equal? (seq> #xffffffff #x00000000) #f)
|
||||
|
||||
(check-equal? (seq>= 41724780 41724780) #t)
|
||||
(check-equal? (seq>= 41724781 41724780) #t)
|
||||
(check-equal? (seq>= 41724780 41724781) #f)
|
||||
|
||||
(check-equal? (seq>= 0 0) #t)
|
||||
(check-equal? (seq>= 1 0) #t)
|
||||
(check-equal? (seq>= 0 1) #f)
|
||||
|
||||
(check-equal? (seq>= #x80000000 #x80000000) #t)
|
||||
(check-equal? (seq>= #x80000001 #x80000000) #t)
|
||||
(check-equal? (seq>= #x80000000 #x80000001) #f)
|
||||
|
||||
(check-equal? (seq>= #xffffffff #xffffffff) #t)
|
||||
(check-equal? (seq>= #x00000000 #xffffffff) #t)
|
||||
(check-equal? (seq>= #xffffffff #x00000000) #f))
|
||||
|
||||
(define (spawn-state-vector outbound? connection-id q)
|
||||
(match-define (tcp-quad remote-ip remote-port local-ip local-port) q)
|
||||
|
||||
(spawn #:name (list 'tcp-state-vector
|
||||
(ip-address->hostname remote-ip)
|
||||
remote-port
|
||||
(ip-address->hostname local-ip)
|
||||
local-port)
|
||||
(define root-facet (current-facet))
|
||||
|
||||
(assert (tcp-port-allocation local-port
|
||||
(tcp-address (ip-address->hostname remote-ip) remote-port)))
|
||||
|
||||
(define initial-outbound-seqn
|
||||
;; Yuck
|
||||
(inexact->exact (truncate (* #x100000000 (random)))))
|
||||
|
||||
(field [outbound (buffer #"!" initial-outbound-seqn 0 #f)] ;; dummy data at SYN position
|
||||
[send-next initial-outbound-seqn] ;; SND.NXT
|
||||
[high-water-mark initial-outbound-seqn]
|
||||
|
||||
[inbound (buffer #"" #f inbound-buffer-limit #f)]
|
||||
[transmission-needed? #f]
|
||||
[syn-acked? #f]
|
||||
[fin-seen? #f]
|
||||
[unblocked? #f]
|
||||
|
||||
[latest-peer-activity-time (current-inexact-milliseconds)]
|
||||
;; ^ the most recent time we heard from our peer
|
||||
[user-timeout-base-time (current-inexact-milliseconds)]
|
||||
;; ^ when the index of the first outbound unacknowledged byte changed
|
||||
|
||||
;; RFC 6298
|
||||
[rtt-estimate #f] ;; milliseconds; "SRTT"
|
||||
[rtt-mean-deviation #f] ;; milliseconds; "RTTVAR"
|
||||
[retransmission-timeout 1000] ;; milliseconds
|
||||
[retransmission-deadline #f]
|
||||
[rtt-estimate-seqn-target #f]
|
||||
[rtt-estimate-start-time #f]
|
||||
)
|
||||
|
||||
(define (next-expected-seqn)
|
||||
(define b (inbound))
|
||||
(define v (buffer-seqn b))
|
||||
(and v (seq+ v (bit-string-byte-count (buffer-data b)))))
|
||||
|
||||
(define (set-inbound-seqn! seqn)
|
||||
(inbound (struct-copy buffer (inbound) [seqn seqn])))
|
||||
|
||||
(define (incorporate-segment! data)
|
||||
(when (not (buffer-finished? (inbound)))
|
||||
(inbound (buffer-push (inbound) data))))
|
||||
|
||||
(define (deliver-inbound-locally!)
|
||||
(define b (inbound))
|
||||
(when (not (bit-string-empty? (buffer-data b)))
|
||||
(define chunk (bit-string->bytes (buffer-data b)))
|
||||
(send! (tcp-in connection-id chunk))
|
||||
(inbound (struct-copy buffer b
|
||||
[data #""]
|
||||
[seqn (seq+ (buffer-seqn b) (bytes-length chunk))]))))
|
||||
|
||||
;; -> Void
|
||||
(define (check-fin!)
|
||||
(define b (inbound))
|
||||
(when (not (buffer-finished? b))
|
||||
(unless (bit-string-empty? (buffer-data b)) ;; assured by deliver-inbound-locally
|
||||
(error 'check-fin "Nonempty inbound buffer"))
|
||||
(when (fin-seen?)
|
||||
(log-netstack/tcp-debug "Closing inbound stream.")
|
||||
(inbound (struct-copy buffer b
|
||||
[seqn (seq+ (buffer-seqn b) 1)] ;; reliable: count fin as a byte
|
||||
[finished? #t]))
|
||||
(transmission-needed? #t)))) ;; we must send an ack
|
||||
|
||||
(define (connected?)
|
||||
(and (syn-acked?) ;; the SYN we sent has been acked by the remote peer
|
||||
(not (buffer-finished? (inbound))))) ;; the remote peer hasn't sent a FIN
|
||||
|
||||
(on (asserted (tcp-accepted connection-id))
|
||||
(unblocked? #t))
|
||||
|
||||
(begin/dataflow
|
||||
(when (and (connected?) (unblocked?))
|
||||
(deliver-inbound-locally!)
|
||||
(check-fin!)))
|
||||
|
||||
;; -> Void
|
||||
(define (arm-retransmission-timer!)
|
||||
(log-netstack/tcp-debug "Arming retransmission timer (~a ms)" (retransmission-timeout))
|
||||
(retransmission-deadline (+ (current-inexact-milliseconds) (retransmission-timeout))))
|
||||
|
||||
;; Timestamp -> Void
|
||||
(define (start-rtt-estimate! now)
|
||||
(define target (send-next))
|
||||
(when (seq>= target (high-water-mark))
|
||||
(log-netstack/tcp-debug "Starting RTT estimation; target seqn is ~a" target)
|
||||
(rtt-estimate-start-time now)
|
||||
(rtt-estimate-seqn-target target)))
|
||||
|
||||
;; -> Void
|
||||
(define (reset-rtt-estimate!)
|
||||
(rtt-estimate-start-time #f)
|
||||
(rtt-estimate-seqn-target #f))
|
||||
|
||||
;; Timestamp -> Void
|
||||
(define (finish-rtt-estimate! now)
|
||||
(define rtt-measurement (- now (rtt-estimate-start-time)))
|
||||
(reset-rtt-estimate!)
|
||||
(log-netstack/tcp-debug "RTT measurement: ~a ms" rtt-measurement)
|
||||
;; RFC 6298 Section 2.
|
||||
(cond [(rtt-estimate) => ;; we have a previous estimate, RFC 6298 rule (2.3)
|
||||
(lambda (prev-estimate)
|
||||
(rtt-mean-deviation (+ (* 0.75 (rtt-mean-deviation))
|
||||
(* 0.25 (abs (- rtt-measurement prev-estimate)))))
|
||||
(rtt-estimate (+ (* 0.875 prev-estimate)
|
||||
(* 0.125 rtt-measurement))))]
|
||||
[else ;; no previous estimate, RFC 6298 rule (2.2) applies
|
||||
(rtt-estimate rtt-measurement)
|
||||
(rtt-mean-deviation (/ rtt-measurement 2))])
|
||||
(default-retransmission-timeout!)
|
||||
(log-netstack/tcp-debug "RTT measurement ~a ms; estimate ~a ms; mean deviation ~a ms; RTO ~a ms"
|
||||
rtt-measurement
|
||||
(rtt-estimate)
|
||||
(rtt-mean-deviation)
|
||||
(retransmission-timeout)))
|
||||
|
||||
(define (default-retransmission-timeout!)
|
||||
(retransmission-timeout
|
||||
(max 200 ;; RFC 6298 rule (2.4), but cribbing from Linux's 200ms minimum
|
||||
(min 60000 ;; (2.5)
|
||||
(+ (rtt-estimate) (* 4 (rtt-mean-deviation))))))) ;; (2.2), (2.3)
|
||||
|
||||
;; Boolean SeqNum -> Void
|
||||
(define (discard-acknowledged-outbound! ack? ackn)
|
||||
(when ack?
|
||||
(let* ((b (outbound))
|
||||
(base (buffer-seqn b))
|
||||
(ackn (seq-min ackn (high-water-mark)))
|
||||
(ackn (seq-max ackn base))
|
||||
(dist (seq- ackn base)))
|
||||
(user-timeout-base-time (current-inexact-milliseconds))
|
||||
(when (positive? dist)
|
||||
(when (not (syn-acked?)) (syn-acked? #t))
|
||||
(log-netstack/tcp-debug "******** ackn ~a; send-next ~a; high-water-mark ~a"
|
||||
ackn
|
||||
(send-next)
|
||||
(high-water-mark))
|
||||
(when (seq> ackn (send-next)) (send-next ackn))
|
||||
(when (and (rtt-estimate-seqn-target) (seq>= ackn (rtt-estimate-seqn-target)))
|
||||
(finish-rtt-estimate! (current-inexact-milliseconds)))
|
||||
|
||||
(define remaining-data (bit-string-drop (buffer-data b) (* dist 8))) ;; bit offset!
|
||||
(outbound (struct-copy buffer b [data remaining-data] [seqn ackn]))
|
||||
|
||||
(default-retransmission-timeout!)
|
||||
(log-netstack/tcp-debug "Positive distance moved by ack, RTO now ~a"
|
||||
(retransmission-timeout))
|
||||
(arm-retransmission-timer!)))))
|
||||
|
||||
;; Nat -> Void
|
||||
(define (update-outbound-window! peer-window)
|
||||
(log-netstack/tcp-debug "Peer's receive-window is now ~a" peer-window)
|
||||
(outbound (struct-copy buffer (outbound) [window peer-window])))
|
||||
|
||||
;; True iff there is no queued-up data waiting either for
|
||||
;; transmission or (if transmitted already) for acknowledgement.
|
||||
(define (all-output-acknowledged?)
|
||||
(bit-string-empty? (buffer-data (outbound))))
|
||||
|
||||
(define (close-outbound-stream!)
|
||||
(log-netstack/tcp-debug "Closing outbound stream.")
|
||||
(define b (outbound))
|
||||
(when (not (buffer-finished? b))
|
||||
(outbound (struct-copy buffer (buffer-push b #"!") ;; dummy FIN byte
|
||||
[finished? #t]))
|
||||
(transmission-needed? #t))) ;; the FIN machinery is awkwardly
|
||||
;; different from the usual
|
||||
;; advance-based decision on
|
||||
;; whether to send a packet or not
|
||||
|
||||
;; SeqNum Boolean Boolean Bytes -> TcpPacket
|
||||
(define (build-outbound-packet seqn mention-syn? mention-fin? payload)
|
||||
(define ackn (next-expected-seqn))
|
||||
(define window (min 65535 ;; limit of field width
|
||||
(max 0 ;; can't be negative
|
||||
(- (buffer-window (inbound))
|
||||
(bit-string-byte-count (buffer-data (inbound)))))))
|
||||
|
||||
(define flags (set))
|
||||
(when ackn (set! flags (set-add flags 'ack)))
|
||||
(when mention-syn? (set! flags (set-add flags 'syn)))
|
||||
(when mention-fin? (set! flags (set-add flags 'fin)))
|
||||
(tcp-packet #f q seqn (or ackn 0) flags window #"" payload))
|
||||
|
||||
(define (outbound-data-chunk offset length)
|
||||
(bit-string-take (bit-string-drop (buffer-data (outbound)) (* offset 8)) (* length 8)))
|
||||
|
||||
;; Transmit acknowledgements and outbound data.
|
||||
(begin/dataflow
|
||||
(define in-flight-count (seq- (send-next) (buffer-seqn (outbound))))
|
||||
|
||||
(define-values (mention-syn? ;; whether to mention SYN
|
||||
payload-size ;; how many bytes of payload data to include
|
||||
mention-fin? ;; whether to mention FIN
|
||||
advance) ;; how far to advance send-next
|
||||
(if (syn-acked?)
|
||||
(let* ((effective-window (max 0 (- (buffer-window (outbound)) in-flight-count)))
|
||||
(stream-ended? (buffer-finished? (outbound)))
|
||||
(max-advance (- (bit-string-byte-count (buffer-data (outbound))) in-flight-count))
|
||||
(payload-size (min maximum-segment-size effective-window max-advance)))
|
||||
(if (and stream-ended? ;; there's a FIN enqueued,
|
||||
(positive? payload-size) ;; we aren't sending nothing at all,
|
||||
(= payload-size max-advance)) ;; and our payload would cover the FIN
|
||||
(values #f (- payload-size 1) #t payload-size)
|
||||
(values #f payload-size #f payload-size)))
|
||||
(cond [(= in-flight-count 0) (values #t 0 #f 1)]
|
||||
[(= in-flight-count 1) (values #t 0 #f 0)]
|
||||
[else (error 'send-outbound!
|
||||
"Invalid state: send-next had advanced too far before SYN")])))
|
||||
|
||||
(when (and (or (next-expected-seqn) outbound?)
|
||||
;; ^ Talk only either if: we know the peer's seqn, or
|
||||
;; we don't, but we're an outbound connection rather
|
||||
;; than a listener.
|
||||
(or (transmission-needed?)
|
||||
(positive? advance))
|
||||
;; ^ ... and we have something to say. Something to
|
||||
;; ack, or something to send.
|
||||
)
|
||||
(define packet-seqn (if mention-syn? (buffer-seqn (outbound)) (send-next)))
|
||||
(define packet (build-outbound-packet packet-seqn
|
||||
mention-syn?
|
||||
mention-fin?
|
||||
(outbound-data-chunk in-flight-count payload-size)))
|
||||
(when (positive? advance)
|
||||
(define new-send-next (seq+ (send-next) advance))
|
||||
(send-next new-send-next)
|
||||
(when (seq> new-send-next (high-water-mark))
|
||||
(high-water-mark new-send-next)))
|
||||
(when (transmission-needed?)
|
||||
(transmission-needed? #f))
|
||||
|
||||
;; (log-netstack/tcp-debug " sending ~v" packet)
|
||||
(send! packet)
|
||||
;; (if (> (random) 0.5)
|
||||
;; (begin (log-netstack/tcp-debug "Send ~a" (summarize-tcp-packet packet))
|
||||
;; (send! packet))
|
||||
;; (log-netstack/tcp-debug "Drop ~a" (summarize-tcp-packet packet)))
|
||||
|
||||
(when (or mention-syn? mention-fin? (positive? advance))
|
||||
(when (not (retransmission-deadline))
|
||||
(arm-retransmission-timer!))
|
||||
(when (not (rtt-estimate-start-time))
|
||||
(start-rtt-estimate! (current-inexact-milliseconds))))))
|
||||
|
||||
(begin/dataflow
|
||||
(when (and (retransmission-deadline) (all-output-acknowledged?))
|
||||
(log-netstack/tcp-debug "All output acknowledged; disarming retransmission timer")
|
||||
(retransmission-deadline #f)))
|
||||
|
||||
(on #:when (retransmission-deadline) (asserted (later-than (retransmission-deadline)))
|
||||
(send-next (buffer-seqn (outbound)))
|
||||
(log-netstack/tcp-debug "Retransmission deadline fired, RTO was ~a; reset to ~a"
|
||||
(retransmission-timeout)
|
||||
(send-next))
|
||||
(update-outbound-window! maximum-segment-size) ;; temporary. Will reopen on next ack
|
||||
(transmission-needed? #t)
|
||||
(retransmission-deadline #f)
|
||||
(reset-rtt-estimate!) ;; give up on current RTT estimation
|
||||
(retransmission-timeout (min 64000 (* 2 (retransmission-timeout))))
|
||||
(log-netstack/tcp-debug " RTO now ~a" (retransmission-timeout)))
|
||||
|
||||
(define (reset! seqn ackn)
|
||||
(define reset-packet (tcp-packet #f q seqn ackn (set 'ack 'rst) 0 #"" #""))
|
||||
(log-netstack/tcp-warning "Reset ~a" (summarize-tcp-packet reset-packet))
|
||||
(stop-facet root-facet)
|
||||
(send! reset-packet))
|
||||
|
||||
(assert q) ;; Declare that this state vector exists
|
||||
(on-start (log-netstack/tcp-info "Starting ~a" (tcp-quad->string (not outbound?) q)))
|
||||
(on-stop (log-netstack/tcp-info "Stopping ~a" (tcp-quad->string (not outbound?) q)))
|
||||
|
||||
(stop-when #:when (and (buffer-finished? (outbound))
|
||||
(buffer-finished? (inbound))
|
||||
(all-output-acknowledged?))
|
||||
(asserted (later-than (+ (latest-peer-activity-time)
|
||||
(* 2 1000 maximum-segment-lifetime-sec))))
|
||||
;; Everything is cleanly shut down, and we just need to wait a while for unexpected
|
||||
;; packets before we release the state vector.
|
||||
)
|
||||
|
||||
(stop-when #:when (not (all-output-acknowledged?))
|
||||
(asserted (later-than (+ (user-timeout-base-time) user-timeout-msec)))
|
||||
;; We've been plaintively retransmitting for user-timeout-msec without hearing anything
|
||||
;; back; this is a crude approximation of the real condition for TCP_USER_TIMEOUT, but
|
||||
;; it will do for now? TODO
|
||||
(log-netstack/tcp-warning "TCP_USER_TIMEOUT fired."))
|
||||
|
||||
(define/query-value listener-listening?
|
||||
#f (observe (tcp-connection _ (tcp-listener local-port))) #t)
|
||||
|
||||
(define (trigger-ack!)
|
||||
(transmission-needed? #t))
|
||||
|
||||
(on (message (tcp-packet #t q $seqn $ackn $flags $window $options $data))
|
||||
(define expected (next-expected-seqn))
|
||||
(define is-syn? (set-member? flags 'syn))
|
||||
(define is-fin? (set-member? flags 'fin))
|
||||
(cond
|
||||
[(set-member? flags 'rst)
|
||||
(stop-facet root-facet
|
||||
(when (not (connected?)) ;; --> rejected!
|
||||
(define e (exn:fail:network
|
||||
(format "~a: Connection rejected" (tcp-quad->string #f q))
|
||||
(current-continuation-marks)))
|
||||
(react (assert (tcp-rejected connection-id e))
|
||||
(on-start (sleep 5)
|
||||
(stop-current-facet)))))]
|
||||
[(and (not expected) ;; no syn yet
|
||||
(or (not is-syn?) ;; and this isn't it
|
||||
(and (not (listener-listening?)) ;; or it is, but no listener...
|
||||
(not outbound?)))) ;; ...and we're not an outbound connection
|
||||
(reset! ackn ;; this is *our* seqn
|
||||
(seq+ seqn (+ (if is-syn? 1 0) (if is-fin? 1 0)))
|
||||
;; ^^ this is what we should acknowledge...
|
||||
)]
|
||||
[else
|
||||
(cond
|
||||
[(not expected) ;; haven't seen syn yet, but we know this is it
|
||||
(set-inbound-seqn! (seq+ seqn 1))
|
||||
(incorporate-segment! data)
|
||||
(trigger-ack!)]
|
||||
[(= expected seqn)
|
||||
(incorporate-segment! data)
|
||||
(when (positive? (bit-string-byte-count data)) (trigger-ack!))]
|
||||
[else
|
||||
(trigger-ack!)])
|
||||
(when is-fin? (fin-seen? #t))
|
||||
(discard-acknowledged-outbound! (set-member? flags 'ack) ackn)
|
||||
(update-outbound-window! window)
|
||||
(latest-peer-activity-time (current-inexact-milliseconds))]))
|
||||
|
||||
(on (message (tcp-out connection-id $bs))
|
||||
;; (log-netstack/tcp-debug "GOT MORE STUFF TO DELIVER ~v" bs)
|
||||
|
||||
(when (all-output-acknowledged?)
|
||||
;; Only move user-timeout-base-time if there wasn't
|
||||
;; already some outstanding output.
|
||||
(user-timeout-base-time (current-inexact-milliseconds)))
|
||||
|
||||
(outbound (buffer-push (outbound) bs)))
|
||||
|
||||
(if outbound?
|
||||
(begin
|
||||
(assert #:when (connected?) (tcp-accepted connection-id))
|
||||
(on (retracted (tcp-connection connection-id (tcp-address _ _)))
|
||||
(close-outbound-stream!)))
|
||||
(begin
|
||||
(assert #:when (connected?) (tcp-connection connection-id (tcp-listener local-port)))
|
||||
(on (asserted (tcp-rejected connection-id _))
|
||||
;; In principle, we have the flexibility to delay
|
||||
;; replying to SYN until userland decides whether or not
|
||||
;; to accept an incoming connection! We don't do that yet
|
||||
;; though.
|
||||
(close-outbound-stream!))
|
||||
(on (retracted (tcp-accepted connection-id))
|
||||
(close-outbound-stream!))
|
||||
(on-start (sleep 5)
|
||||
(when (not (unblocked?))
|
||||
(log-netstack/tcp-error "TCP relay process ~a timed out waiting for peer" q)
|
||||
(stop-facet root-facet)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(spawn-tcp-driver)
|
|
@ -0,0 +1,133 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide (struct-out udp-remote-address)
|
||||
(struct-out udp-handle)
|
||||
(struct-out udp-listener)
|
||||
udp-address?
|
||||
udp-local-address?
|
||||
(struct-out udp-packet)
|
||||
spawn-udp-driver)
|
||||
|
||||
(require racket/set)
|
||||
(require bitsyntax)
|
||||
|
||||
(require "dump-bytes.rkt")
|
||||
(require "checksum.rkt")
|
||||
(require "configuration.rkt")
|
||||
(require/activate "ip.rkt")
|
||||
(require "port-allocator.rkt")
|
||||
|
||||
;; udp-address/udp-address : "kernel" udp connection state machines
|
||||
;; udp-handle/udp-address : "user" outbound connections
|
||||
;; udp-listener/udp-address : "user" inbound connections
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Protocol messages
|
||||
|
||||
(struct udp-remote-address (host port) #:prefab)
|
||||
(struct udp-handle (id) #:prefab)
|
||||
(struct udp-listener (port) #:prefab)
|
||||
|
||||
(define (udp-address? x)
|
||||
(or (udp-remote-address? x)
|
||||
(udp-local-address? x)))
|
||||
|
||||
(define (udp-local-address? x)
|
||||
(or (udp-handle? x)
|
||||
(udp-listener? x)))
|
||||
|
||||
;; USER-level protocol
|
||||
(struct udp-packet (source destination body) #:prefab)
|
||||
|
||||
;; KERNEL-level protocol
|
||||
(struct udp-datagram (source-ip source-port destination-ip destination-port body) #:prefab)
|
||||
(struct udp-port-allocation (port handle) #:prefab) ;; (udp-port-allocation Number UdpLocalAddress)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; User-accessible driver startup
|
||||
|
||||
(define (spawn-udp-driver)
|
||||
(spawn-port-allocator 'udp (lambda () (query-set udp-ports (udp-port-allocation $p _) p)))
|
||||
(spawn-kernel-udp-driver)
|
||||
(spawn #:name 'udp-driver
|
||||
(on (asserted (observe (udp-packet _ ($ h (udp-listener _)) _)))
|
||||
(spawn-udp-relay (udp-listener-port h) h))
|
||||
(on (asserted (observe (udp-packet _ ($ h (udp-handle _)) _)))
|
||||
(spawn #:name (list 'udp-transient h)
|
||||
(on-start (spawn-udp-relay (allocate-port! 'udp) h))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Relaying
|
||||
|
||||
(define (spawn-udp-relay local-port local-user-addr)
|
||||
(spawn #:name (list 'udp-relay local-port local-user-addr)
|
||||
(on-start (log-info "Spawning UDP relay ~v / ~v" local-port local-user-addr))
|
||||
|
||||
(stop-when (retracted (observe (udp-packet _ local-user-addr _))))
|
||||
(assert (udp-port-allocation local-port local-user-addr))
|
||||
|
||||
(during (host-route $ip _ _)
|
||||
(on (message (udp-datagram $source-ip $source-port ip local-port $bs))
|
||||
(send!
|
||||
(udp-packet (udp-remote-address (ip-address->hostname source-ip)
|
||||
source-port)
|
||||
local-user-addr
|
||||
bs))))
|
||||
|
||||
(define local-ips (query-local-ip-addresses))
|
||||
(on (message (udp-packet local-user-addr (udp-remote-address $other-host $other-port) $bs))
|
||||
;; Choose arbitrary local IP address for outbound packet!
|
||||
;; TODO: what can be done? Must I examine the routing table?
|
||||
(send! (udp-datagram (set-first (local-ips))
|
||||
local-port
|
||||
(ip-string->ip-address other-host)
|
||||
other-port
|
||||
bs)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Codec & kernel-level driver
|
||||
|
||||
(define PROTOCOL-UDP 17)
|
||||
|
||||
(define (spawn-kernel-udp-driver)
|
||||
(spawn #:name 'kernel-udp-driver
|
||||
(define local-ips (query-local-ip-addresses))
|
||||
|
||||
(on (message (ip-packet $source-if $src-ip $dst-ip PROTOCOL-UDP _ $body))
|
||||
(when (and source-if (set-member? (local-ips) dst-ip))
|
||||
(bit-string-case body
|
||||
([ (src-port :: integer bytes 2)
|
||||
(dst-port :: integer bytes 2)
|
||||
(length :: integer bytes 2)
|
||||
(checksum :: integer bytes 2) ;; TODO: check checksum
|
||||
(data :: binary) ]
|
||||
(bit-string-case data
|
||||
([ (payload :: binary bytes (- length 8)) ;; min UDP header size is 8 bytes
|
||||
(:: binary) ]
|
||||
(send! (udp-datagram src-ip src-port dst-ip dst-port
|
||||
(bit-string->bytes payload))))
|
||||
(else #f)))
|
||||
(else #f))))
|
||||
|
||||
(on (message (udp-datagram $src-ip $src-port $dst-ip $dst-port $bs))
|
||||
(when (set-member? (local-ips) src-ip)
|
||||
(let* ((payload (bit-string (src-port :: integer bytes 2)
|
||||
(dst-port :: integer bytes 2)
|
||||
((+ 8 (bit-string-byte-count bs))
|
||||
:: integer bytes 2)
|
||||
(0 :: integer bytes 2) ;; checksum location
|
||||
(bs :: binary)))
|
||||
(pseudo-header (bit-string (src-ip :: binary bytes 4)
|
||||
(dst-ip :: binary bytes 4)
|
||||
0
|
||||
PROTOCOL-UDP
|
||||
((bit-string-byte-count payload)
|
||||
:: integer bytes 2)))
|
||||
(checksummed-payload (ip-checksum #:pseudo-header pseudo-header
|
||||
6 payload)))
|
||||
(send! (ip-packet #f src-ip dst-ip PROTOCOL-UDP #""
|
||||
checksummed-payload)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(spawn-udp-driver)
|
|
@ -0,0 +1,83 @@
|
|||
#lang imperative-syndicate
|
||||
;; Santa Claus Problem
|
||||
;; https://www.schoolofhaskell.com/school/advanced-haskell/beautiful-concurrency/4-the-santa-claus-problem
|
||||
;; https://arxiv.org/pdf/1810.09613.pdf
|
||||
|
||||
(require/activate imperative-syndicate/drivers/timer)
|
||||
(require racket/list)
|
||||
(require racket/set)
|
||||
|
||||
(assertion-struct elf-has-a-problem (id))
|
||||
(assertion-struct reindeer-has-returned (id))
|
||||
|
||||
(assertion-struct problem-resolved (id))
|
||||
(assertion-struct deliver-toys ())
|
||||
|
||||
(define N-ELVES 10)
|
||||
(define ELF-GROUP-SIZE 3)
|
||||
(define N-REINDEER 9)
|
||||
|
||||
(define (elf)
|
||||
(define elf-self (gensym 'elf))
|
||||
(spawn* #:name elf-self
|
||||
(let work-industriously ()
|
||||
(sleep (/ (random 1000) 1000.0))
|
||||
(react (assert (elf-has-a-problem elf-self))
|
||||
(stop-when (asserted (problem-resolved elf-self))
|
||||
(work-industriously))))))
|
||||
|
||||
(define (reindeer)
|
||||
(define reindeer-self (gensym 'reindeer))
|
||||
(spawn* #:name reindeer-self
|
||||
(let holiday ()
|
||||
(sleep (/ (random 9000) 1000.0))
|
||||
(react (assert (reindeer-has-returned reindeer-self))
|
||||
(stop-when (asserted (deliver-toys))
|
||||
(react (stop-when (retracted (deliver-toys))
|
||||
(holiday))))))))
|
||||
|
||||
(spawn* #:name 'santa
|
||||
(define (wait-for-work)
|
||||
(react (define/query-set stuck-elves (elf-has-a-problem $id) id)
|
||||
(define/query-set returned-reindeer (reindeer-has-returned $id) id)
|
||||
(stop-when-true (= (set-count (returned-reindeer)) N-REINDEER)
|
||||
(harness-reindeer))
|
||||
(stop-when-true (>= (set-count (stuck-elves)) ELF-GROUP-SIZE)
|
||||
(talk-to-elves (take (set->list (stuck-elves)) ELF-GROUP-SIZE)))))
|
||||
|
||||
(define (harness-reindeer)
|
||||
(react (assert (deliver-toys))
|
||||
(stop-when (retracted (reindeer-has-returned _))
|
||||
(wait-for-work))))
|
||||
|
||||
(define (talk-to-elves elves)
|
||||
(match elves
|
||||
['() (wait-for-work)]
|
||||
[(cons elf remainder)
|
||||
(react (assert (problem-resolved elf))
|
||||
(stop-when (retracted (elf-has-a-problem elf))
|
||||
(talk-to-elves remainder)))]))
|
||||
|
||||
(wait-for-work))
|
||||
|
||||
(for [(i N-ELVES)] (elf))
|
||||
(for [(i N-REINDEER)] (reindeer))
|
||||
|
||||
(spawn #:name 'narrator
|
||||
(during (elf-has-a-problem $id)
|
||||
(on-start (printf "~a has a problem!\n" id))
|
||||
(on-stop (printf "~a's problem is resolved. ~a returns to work.\n" id id)))
|
||||
|
||||
(on (asserted (reindeer-has-returned $id))
|
||||
(printf "~a has returned from holiday and is ready to deliver toys!\n" id))
|
||||
|
||||
(on (retracted (reindeer-has-returned $id))
|
||||
(printf "~a delivers toys with the other reindeer.\n" id)
|
||||
(react (stop-when (retracted (deliver-toys))
|
||||
(printf "~a has been dismissed by Santa, and goes back on holiday.\n" id))))
|
||||
|
||||
(on (asserted (deliver-toys))
|
||||
(printf "Santa does the delivery run!\n"))
|
||||
|
||||
(on (asserted (problem-resolved $id))
|
||||
(printf "Santa resolves the problem of ~a.\n" id)))
|
|
@ -0,0 +1,45 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require/activate imperative-syndicate/distributed)
|
||||
(require/activate imperative-syndicate/drivers/external-event)
|
||||
(require (only-in racket/port read-line-evt))
|
||||
|
||||
(assertion-struct Present (name))
|
||||
(message-struct Says (who what))
|
||||
|
||||
(define host (make-parameter "localhost"))
|
||||
(define port (make-parameter 8001))
|
||||
(define scope (make-parameter "chat"))
|
||||
(define initial-username (make-parameter (symbol->string (strong-gensym 'chatter-))))
|
||||
|
||||
(file-stream-buffer-mode (current-output-port) 'line)
|
||||
|
||||
(module+ main
|
||||
(require racket/cmdline)
|
||||
(command-line #:once-each
|
||||
["--host" hostname "Server hostname" (host hostname)]
|
||||
["--port" portnum "Server port number" (port (string->number portnum))]
|
||||
["--scope" scopename "Server scope" (scope scopename)]
|
||||
["--nick" nick "User nickname" (initial-username nick)]))
|
||||
|
||||
(spawn #:name 'main
|
||||
(field [username (initial-username)])
|
||||
|
||||
(define root-facet (current-facet))
|
||||
(define url (server-tcp-connection (host) (port) (scope)))
|
||||
(during (server-connected url)
|
||||
(on-start (log-info "Connected to server."))
|
||||
(on-stop (log-info "Disconnected from server."))
|
||||
|
||||
(on (asserted (from-server url (Present $who))) (printf "~a arrived.\n" who))
|
||||
(on (retracted (from-server url (Present $who))) (printf "~a departed.\n" who))
|
||||
(on (message (from-server url (Says $who $what))) (printf "~a: ~a\n" who what))
|
||||
|
||||
(assert (to-server url (Present (username))))
|
||||
|
||||
(define stdin-evt (read-line-evt (current-input-port) 'any))
|
||||
(on (message (inbound (external-event stdin-evt (list $line))))
|
||||
(match line
|
||||
[(? eof-object?) (stop-facet root-facet)]
|
||||
[(pregexp #px"^/nick (.+)$" (list _ newnick)) (username newnick)]
|
||||
[other (send! (to-server url (Says (username) other)))]))))
|
|
@ -0,0 +1,12 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(assertion-struct greeting (text))
|
||||
|
||||
(spawn #:name "A" (assert (greeting "Hi from outer space!")))
|
||||
(spawn #:name "B" (on (asserted (greeting $t))
|
||||
(printf "Outer dataspace: ~a\n" t)))
|
||||
|
||||
(dataspace #:name "C"
|
||||
(spawn #:name "D" (assert (outbound (greeting "Hi from inner!"))))
|
||||
(spawn #:name "E" (on (asserted (inbound (greeting $t)))
|
||||
(printf "Inner dataspace: ~a\n" t))))
|
|
@ -0,0 +1,36 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require/activate imperative-syndicate/drivers/sqlite)
|
||||
(require/activate imperative-syndicate/drivers/timer)
|
||||
|
||||
(define PATH "t.sqlite")
|
||||
(define DB (sqlite-db PATH))
|
||||
|
||||
(spawn* (with-handlers [(exn:fail:filesystem? void)]
|
||||
(delete-file PATH))
|
||||
(react (assert DB))
|
||||
|
||||
(sqlite-create-table! DB "x" "y" "z")
|
||||
|
||||
(send! (sqlite-insert DB "x" (list 1 "yy") (gensym 'init)))
|
||||
(send! (sqlite-insert DB "x" (list "yy" "hello") (gensym 'init)))
|
||||
(send! (sqlite-insert DB "x" (list "yy" "goodbye") (gensym 'init)))
|
||||
(send! (sqlite-insert DB "x" (list 1 "yy") (gensym 'init)))
|
||||
|
||||
(react
|
||||
(during (sqlite-row DB "x" (list _ $key))
|
||||
(during (sqlite-row DB "x" (list key $value))
|
||||
(on-start (printf "+ ~a row in x: ~a\n" key value))
|
||||
(on-stop (printf "- ~a row in x: ~a\n" key value))))
|
||||
(during (sqlite-row DB "x" $columns)
|
||||
(on-start (printf "+ row in x: ~a\n" columns))
|
||||
(on-stop (printf "- row in x: ~a\n" columns))))
|
||||
|
||||
(sqlite-insert! DB "x" "a" "b")
|
||||
(sqlite-insert! DB "x" "a" "c")
|
||||
(sqlite-insert! DB "x" "yy" "b")
|
||||
(sqlite-insert! DB "x" "yy" "c")
|
||||
(sqlite-delete! DB "x" "a" "b")
|
||||
(sqlite-delete! DB "x" (discard) "b")
|
||||
(sqlite-delete! DB "x" "a" (discard))
|
||||
(sqlite-delete! DB "x" (discard) "c"))
|
|
@ -0,0 +1,10 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require/activate imperative-syndicate/drivers/external-event)
|
||||
(require (only-in racket/port read-bytes-line-evt))
|
||||
|
||||
(spawn (define stdin-evt (read-bytes-line-evt (current-input-port) 'any))
|
||||
(on (message (inbound (external-event stdin-evt (list $line))))
|
||||
(if (eof-object? line)
|
||||
(stop-current-facet)
|
||||
(printf "~a\n" line))))
|
|
@ -0,0 +1,21 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require/activate imperative-syndicate/drivers/timer)
|
||||
|
||||
(spawn #:name 'plain-timer-demo
|
||||
(field [count 0])
|
||||
(on-start (send! (set-timer 'main-timer 0 'relative)))
|
||||
(on (message (timer-expired 'main-timer $now))
|
||||
(log-info "main-timer expired at ~a" now)
|
||||
(count (+ (count) 1))
|
||||
(when (< (count) 5)
|
||||
(send! (set-timer 'main-timer 500 'relative)))))
|
||||
|
||||
(spawn #:name 'later-than-demo
|
||||
(field [deadline (current-inexact-milliseconds)]
|
||||
[count 0])
|
||||
(on (asserted (later-than (deadline)))
|
||||
(log-info "later-than ticked for deadline ~a" (deadline))
|
||||
(count (+ (count) 1))
|
||||
(when (< (count) 5)
|
||||
(deadline (+ (deadline) 500)))))
|
|
@ -0,0 +1,10 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require/activate imperative-syndicate/drivers/udp)
|
||||
|
||||
(spawn (define s (udp-listener 5999))
|
||||
(during s
|
||||
(on (message (udp-packet $c s $body))
|
||||
(printf "~a: ~v\n" c body)
|
||||
(define reply (string->bytes/utf-8 (format "You said: ~a" body)))
|
||||
(send! (udp-packet s c reply)))))
|
|
@ -0,0 +1,38 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require/activate imperative-syndicate/drivers/timer)
|
||||
(require/activate imperative-syndicate/drivers/udp)
|
||||
(require racket/random file/sha1)
|
||||
|
||||
;; IANA offers guidelines for choosing multicast addresses [1].
|
||||
;;
|
||||
;; Reasonable candidates for local experimentation include:
|
||||
;; - 224.0.1.20, "any private experiment"
|
||||
;; - 233.252.0.0 - 233.252.0.255, "MCAST-TEST-NET", for examples and documentation (only)
|
||||
;;
|
||||
;; For production and semi-production use, registering an address may
|
||||
;; be an option; failing that, the Administratively Scoped Block
|
||||
;; (239/8; see RFC 2365) may be used:
|
||||
;; - 239.255.0.0 - 239.255.255.255, "IPv4 Local Scope"
|
||||
;; - 239.192.0.0 - 239.195.255.255, "Organization Local Scope"
|
||||
;;
|
||||
;; [1] http://www.iana.org/assignments/multicast-addresses/
|
||||
|
||||
(define group-address "233.252.0.101") ;; falls within MCAST-TEST-NET
|
||||
(define group-port 5999) ;; make sure your firewall is open to UDP on this port
|
||||
|
||||
(spawn (define me (bytes->hex-string (crypto-random-bytes 8)))
|
||||
(define h (udp-listener group-port))
|
||||
(during h
|
||||
(assert (udp-multicast-group-member h group-address #f))
|
||||
(assert (udp-multicast-loopback h #t))
|
||||
|
||||
(field [deadline (current-inexact-milliseconds)])
|
||||
(on (asserted (later-than (deadline)))
|
||||
(send! (udp-packet h
|
||||
(udp-remote-address group-address group-port)
|
||||
(string->bytes/utf-8 (format "~a ~a" me (deadline)))))
|
||||
(deadline (+ (deadline) 1000)))
|
||||
|
||||
(on (message (udp-packet $source h $body))
|
||||
(printf "~a: ~a\n" source body))))
|
|
@ -0,0 +1,84 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require/activate imperative-syndicate/drivers/web)
|
||||
(require/activate imperative-syndicate/drivers/timer)
|
||||
|
||||
(define server (http-server "localhost" 8081 #f))
|
||||
|
||||
(define (button text link)
|
||||
`(form ((method "POST") (action ,link)) (button ((type "submit")) ,text)))
|
||||
|
||||
(define (redirect-response id url)
|
||||
(http-response #:code 303 #:message #"See other"
|
||||
#:headers `((Location . ,url))
|
||||
id (xexpr->bytes/utf-8 `(html (a ((href ,url)) "continue")))))
|
||||
|
||||
(spawn
|
||||
|
||||
(during (http-request $id $method $resource _ _ _)
|
||||
(stop-when (asserted ($ details (http-request-peer-details id _ _ _ _)))
|
||||
(log-info "~a: ~a ~v ~v" id method resource details)))
|
||||
|
||||
(during/spawn (http-request $id 'get (http-resource server '("" ())) _ _ _)
|
||||
(assert (http-accepted id))
|
||||
(assert (http-response id (xexpr->bytes/utf-8
|
||||
`(html
|
||||
(h1 "Hello")
|
||||
,(button "Make a new counter" "/newcounter"))))))
|
||||
|
||||
(during/spawn (http-request $id 'post (http-resource server '("newcounter" ())) _ _ _)
|
||||
(assert (http-accepted id))
|
||||
(on-start (define counter-url (spawn-counter))
|
||||
(react (assert (redirect-response id counter-url)))))
|
||||
|
||||
(during/spawn (http-request $id 'get (http-resource server '("chunked" ())) _ _ _)
|
||||
(assert (http-accepted id))
|
||||
(assert (http-response id 'chunked #:mime-type #"text/plain"))
|
||||
(on-start (sleep 1)
|
||||
(send! (http-response-chunk id #"One\n"))
|
||||
(sleep 1)
|
||||
(send! (http-response-chunk id #"Two\n"))
|
||||
(sleep 1)
|
||||
(send! (http-response-chunk id #"Three\n"))
|
||||
(stop-current-facet)))
|
||||
|
||||
(during/spawn (http-request $id 'get (http-resource server '("ws-echo" ())) _ _ _)
|
||||
(assert (http-accepted id))
|
||||
(assert (http-response-websocket id))
|
||||
(on (message (websocket-in id $body))
|
||||
(log-info "~a sent: ~v" id body)
|
||||
(send! (websocket-out id (format "You said: ~a" body))))
|
||||
(on (message (websocket-in id "quit"))
|
||||
(stop-current-facet))
|
||||
(on-start (log-info "Starting websocket connection ~a" id))
|
||||
(on-stop (log-info "Stopping websocket connection ~a" id)))
|
||||
)
|
||||
|
||||
(define (spawn-counter)
|
||||
(define counter-id (symbol->string (gensym 'counter)))
|
||||
(define counter-url (string-append "/" counter-id))
|
||||
(begin0 counter-url
|
||||
(spawn
|
||||
#:name counter-id
|
||||
|
||||
(field [counter 0])
|
||||
|
||||
(during (http-request $id 'get (http-resource server `(,counter-id ())) _ _ _)
|
||||
(assert (http-accepted id))
|
||||
(assert
|
||||
(http-response id (xexpr->bytes/utf-8
|
||||
`(html (h1 "Counter")
|
||||
(p "The counter is: " ,(number->string (counter)))
|
||||
,(button "Increment" (string-append "/" counter-id "/inc"))
|
||||
,(button "Decrement" (string-append "/" counter-id "/dec"))
|
||||
(p "(Return " (a ((href "/")) "home") ")"))))))
|
||||
|
||||
(during (http-request $id 'post (http-resource server `(,counter-id ("inc" ()))) _ _ _)
|
||||
(assert (http-accepted id))
|
||||
(on-start (counter (+ (counter) 1))
|
||||
(react (assert (redirect-response id counter-url)))))
|
||||
|
||||
(during (http-request $id 'post (http-resource server `(,counter-id ("dec" ()))) _ _ _)
|
||||
(assert (http-accepted id))
|
||||
(on-start (counter (- (counter) 1))
|
||||
(react (assert (redirect-response id counter-url))))))))
|
|
@ -0,0 +1,103 @@
|
|||
#lang racket/base
|
||||
;; Breaking the infinite tower of nested dataspaces, connecting to Racket at the fracture line.
|
||||
|
||||
(provide current-ground-event-async-channel
|
||||
ground-send!
|
||||
ground-assert!
|
||||
ground-retract!
|
||||
signal-background-activity!
|
||||
extend-ground-boot!
|
||||
run-ground)
|
||||
|
||||
(define-logger syndicate/ground)
|
||||
|
||||
(require racket/async-channel)
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require racket/list)
|
||||
(require "dataspace.rkt")
|
||||
(require "syntax.rkt")
|
||||
|
||||
(define current-ground-event-async-channel (make-parameter #f))
|
||||
(define *ground-boot-extensions* '())
|
||||
|
||||
(define (ground-enqueue! item)
|
||||
(async-channel-put (current-ground-event-async-channel) item))
|
||||
|
||||
(define (ground-send! body)
|
||||
(ground-enqueue! (lambda (ac) (enqueue-send! ac body))))
|
||||
|
||||
(define (ground-assert! assertion)
|
||||
(ground-enqueue! (lambda (ac) (adhoc-assert! ac assertion))))
|
||||
|
||||
(define (ground-retract! assertion)
|
||||
(ground-enqueue! (lambda (ac) (adhoc-retract! ac assertion))))
|
||||
|
||||
(define (signal-background-activity! delta)
|
||||
(ground-enqueue! delta))
|
||||
|
||||
(define (extend-ground-boot! proc)
|
||||
(set! *ground-boot-extensions* (cons proc *ground-boot-extensions*)))
|
||||
|
||||
(define (run-ground* boot-proc)
|
||||
(define ch (make-async-channel))
|
||||
(parameterize ((current-ground-event-async-channel ch))
|
||||
(define ground-event-relay-actor #f)
|
||||
(define background-activity-count 0)
|
||||
|
||||
(define (handle-ground-event-item item)
|
||||
(match item
|
||||
[(? procedure? proc)
|
||||
(push-script! ground-event-relay-actor
|
||||
(lambda () (proc ground-event-relay-actor)))]
|
||||
[(? number? delta)
|
||||
(set! background-activity-count (+ background-activity-count delta))]))
|
||||
|
||||
(define (drain-external-events)
|
||||
(define item (async-channel-try-get ch))
|
||||
(when item
|
||||
(handle-ground-event-item item)
|
||||
(drain-external-events)))
|
||||
|
||||
(define ground-event-relay-evt
|
||||
(handle-evt ch (lambda (item)
|
||||
(handle-ground-event-item item)
|
||||
(drain-external-events))))
|
||||
|
||||
(define ds (make-dataspace
|
||||
(lambda ()
|
||||
(schedule-script! (current-actor)
|
||||
(lambda ()
|
||||
(spawn #:name 'ground-event-relay
|
||||
(set! ground-event-relay-actor (current-actor))
|
||||
;; v Adds a dummy endpoint to keep this actor alive
|
||||
(begin/dataflow (void)))))
|
||||
(schedule-script! (current-actor)
|
||||
(lambda ()
|
||||
(boot-proc)
|
||||
(let ((extensions (reverse *ground-boot-extensions*)))
|
||||
(set! *ground-boot-extensions* '())
|
||||
(for [(p (in-list extensions))] (p))))))))
|
||||
|
||||
(let loop ()
|
||||
(define work-remaining? (run-scripts! ds))
|
||||
(define events-expected? (positive? background-activity-count))
|
||||
(log-syndicate/ground-debug "GROUND: ~a; ~a background activities"
|
||||
(if work-remaining? "busy" "idle")
|
||||
background-activity-count)
|
||||
(cond
|
||||
[events-expected?
|
||||
(sync ground-event-relay-evt (if work-remaining? (system-idle-evt) never-evt))
|
||||
(loop)]
|
||||
[work-remaining?
|
||||
(sync ground-event-relay-evt (system-idle-evt))
|
||||
(loop)]
|
||||
[else
|
||||
(sync (handle-evt ground-event-relay-evt (lambda _ (loop))) (system-idle-evt))]))))
|
||||
|
||||
(define (run-ground boot-proc)
|
||||
(if (equal? (getenv "SYNDICATE_PROFILE") "ground")
|
||||
(let ()
|
||||
(local-require profile)
|
||||
(profile (run-ground* boot-proc)))
|
||||
(run-ground* boot-proc)))
|
|
@ -0,0 +1,4 @@
|
|||
#lang setup/infotab
|
||||
(define collection "imperative-syndicate")
|
||||
(define racket-launcher-names '("syndicate-server" "syndicate-server-debug"))
|
||||
(define racket-launcher-libraries '("bin/syndicate-server.rkt" "bin/syndicate-server-debug.rkt"))
|
|
@ -0,0 +1,116 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (rename-out [module-begin #%module-begin])
|
||||
activate
|
||||
require/activate
|
||||
current-ground-dataspace
|
||||
current-activated-modules
|
||||
begin-for-declarations ;; TODO: this seems like a horrible hack
|
||||
(except-out (all-from-out racket/base) #%module-begin sleep)
|
||||
(all-from-out racket/match)
|
||||
(all-from-out "main.rkt")
|
||||
(for-syntax (all-from-out racket/base)))
|
||||
|
||||
(require racket/match)
|
||||
(require "main.rkt")
|
||||
(require (for-syntax racket/base syntax/kerncase))
|
||||
|
||||
(define-syntax (activate stx)
|
||||
(syntax-case stx ()
|
||||
[(_ module-path ...)
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
(let ()
|
||||
(local-require (submod module-path syndicate-main))
|
||||
(activate!))
|
||||
...))]))
|
||||
|
||||
(define-syntax (require/activate stx)
|
||||
(syntax-case stx ()
|
||||
[(_ module-path ...)
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
(require module-path ...)
|
||||
(activate module-path ...)))]))
|
||||
|
||||
(define-syntax-rule (begin-for-declarations decl ...)
|
||||
(begin decl ...))
|
||||
|
||||
(define current-ground-dataspace (make-parameter #f))
|
||||
(define current-activated-modules (make-parameter #f))
|
||||
|
||||
(define-syntax (module-begin stx)
|
||||
(unless (eq? (syntax-local-context) 'module-begin)
|
||||
(raise-syntax-error #f "allowed only around a module body" stx))
|
||||
(syntax-case stx ()
|
||||
[(_ forms ...)
|
||||
(let ()
|
||||
|
||||
(define (accumulate-actions activation-forms final-forms forms)
|
||||
(cond
|
||||
[(null? forms)
|
||||
(define final-stx
|
||||
#`(#%module-begin
|
||||
;----------------------------------------
|
||||
; The final module has three pieces:
|
||||
; - a `syndicate-main` submodule, for activation
|
||||
; - a `main` submodule, for programs
|
||||
; - actual definitions, for everything else.
|
||||
; The `main` submodule is split into two pieces,
|
||||
; in order to initialise defaults that can then
|
||||
; be overridden by the module being compiled.
|
||||
|
||||
(module+ syndicate-main
|
||||
(provide activate!* activate!)
|
||||
(define (activate!*)
|
||||
#,@(reverse activation-forms)
|
||||
(void))
|
||||
(define (activate!)
|
||||
(when (not (hash-has-key? (current-activated-modules) activate!*))
|
||||
(hash-set! (current-activated-modules) activate!* #t)
|
||||
(activate!*))))
|
||||
|
||||
(module+ main (current-ground-dataspace run-ground))
|
||||
|
||||
#,@(reverse final-forms)
|
||||
|
||||
(module+ main
|
||||
(require (submod ".." syndicate-main))
|
||||
(parameterize ((current-activated-modules (make-hasheq)))
|
||||
((current-ground-dataspace) activate!)))
|
||||
|
||||
;----------------------------------------
|
||||
))
|
||||
;;(pretty-print (syntax->datum final-stx))
|
||||
final-stx]
|
||||
|
||||
[else
|
||||
(syntax-case (local-expand (car forms)
|
||||
'module
|
||||
(append (list #'module+
|
||||
#'begin-for-declarations)
|
||||
(kernel-form-identifier-list))) ()
|
||||
[(head rest ...)
|
||||
(cond
|
||||
[(free-identifier=? #'head #'begin)
|
||||
(accumulate-actions activation-forms
|
||||
final-forms
|
||||
(append (syntax->list #'(rest ...)) (cdr forms)))]
|
||||
[(ormap (lambda (i) (free-identifier=? #'head i))
|
||||
(syntax->list #'(define-values define-syntaxes begin-for-syntax
|
||||
module module* module+
|
||||
#%module-begin
|
||||
#%require #%provide
|
||||
begin-for-declarations)))
|
||||
(accumulate-actions activation-forms
|
||||
(cons (car forms) final-forms)
|
||||
(cdr forms))]
|
||||
[else
|
||||
(accumulate-action (car forms) activation-forms final-forms (cdr forms))])]
|
||||
[non-pair-syntax
|
||||
(accumulate-action (car forms) activation-forms final-forms (cdr forms))])]))
|
||||
|
||||
(define (accumulate-action action activation-forms final-forms remaining-forms)
|
||||
(accumulate-actions (cons action activation-forms) final-forms remaining-forms))
|
||||
|
||||
(accumulate-actions '() '() (syntax->list #'(forms ...))))]))
|
|
@ -0,0 +1,15 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (all-from-out "dataspace.rkt")
|
||||
(all-from-out "assertions.rkt")
|
||||
(all-from-out "syntax.rkt")
|
||||
(all-from-out "ground.rkt")
|
||||
(all-from-out "relay.rkt"))
|
||||
|
||||
(module reader syntax/module-reader imperative-syndicate/lang)
|
||||
|
||||
(require "dataspace.rkt")
|
||||
(require "assertions.rkt")
|
||||
(require "syntax.rkt")
|
||||
(require "ground.rkt")
|
||||
(require "relay.rkt")
|
|
@ -0,0 +1,25 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require/activate "udp-dataspace.rkt")
|
||||
(require/activate imperative-syndicate/drivers/external-event)
|
||||
(require (only-in racket/port read-bytes-line-evt))
|
||||
(require racket/random file/sha1)
|
||||
|
||||
(message-struct speak (who what))
|
||||
(assertion-struct present (who))
|
||||
|
||||
(spawn (define me (bytes->hex-string (crypto-random-bytes 8)))
|
||||
(define stdin-evt (read-bytes-line-evt (current-input-port) 'any))
|
||||
|
||||
(assert (mcds-outbound (present me)))
|
||||
|
||||
(on (message (inbound (external-event stdin-evt (list $line))))
|
||||
(if (eof-object? line)
|
||||
(stop-current-facet)
|
||||
(send! (mcds-outbound (speak me line)))))
|
||||
|
||||
(during (mcds-inbound (present $user))
|
||||
(on-start (printf "~a arrived\n" user))
|
||||
(on-stop (printf "~a left\n" user))
|
||||
(on (message (mcds-inbound (speak user $text)))
|
||||
(printf "~a says '~a'\n" user text))))
|
|
@ -0,0 +1,120 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide (struct-out mcds-inbound)
|
||||
(struct-out mcds-outbound))
|
||||
|
||||
(require/activate imperative-syndicate/drivers/timer)
|
||||
(require/activate imperative-syndicate/drivers/udp)
|
||||
(require racket/random file/sha1)
|
||||
(require imperative-syndicate/skeleton)
|
||||
(require imperative-syndicate/term)
|
||||
(require preserves)
|
||||
|
||||
(define-logger mcds)
|
||||
|
||||
(struct mcds-inbound (assertion) #:prefab)
|
||||
(struct mcds-outbound (assertion) #:prefab)
|
||||
|
||||
(struct mcds-change (peer type assertion) #:transparent)
|
||||
(struct mcds-demand () #:transparent)
|
||||
|
||||
(struct mcds-relevant (assertion peer) #:transparent)
|
||||
|
||||
(define group-address "239.192.57.49") ;; falls within Organization Local Scope (see RFC 2365)
|
||||
(define group-port 5999) ;; make sure your firewall is open to UDP on this port
|
||||
(define group-target (udp-remote-address group-address group-port))
|
||||
|
||||
(define *assertion-lifetime* 30000)
|
||||
(define *assertion-refresh* (* 0.9 *assertion-lifetime*))
|
||||
|
||||
(define (send-packet! h packet)
|
||||
(send! (udp-packet h group-target (encode packet))))
|
||||
|
||||
(define (packet-statistics h)
|
||||
(define report-period 10000)
|
||||
(field [packet-count 0]
|
||||
[byte-count 0]
|
||||
[reset-time (+ (current-inexact-milliseconds) report-period)])
|
||||
(on (message (udp-packet _ h $body))
|
||||
(packet-count (+ (packet-count) 1))
|
||||
(byte-count (+ (byte-count) (bytes-length body))))
|
||||
(on (asserted (later-than (reset-time)))
|
||||
(reset-time (+ (reset-time) report-period))
|
||||
(log-mcds-info "~a packets, ~a bytes received in ~a ms = ~a Hz, ~a bytes/s"
|
||||
(packet-count)
|
||||
(byte-count)
|
||||
report-period
|
||||
(/ (packet-count) (/ report-period 1000.0))
|
||||
(/ (byte-count) (/ report-period 1000.0)))
|
||||
(packet-count 0)
|
||||
(byte-count 0)))
|
||||
|
||||
(spawn (during (observe (mcds-inbound _)) (assert (mcds-demand)))
|
||||
(during (mcds-outbound _) (assert (mcds-demand)))
|
||||
|
||||
(during/spawn (mcds-demand)
|
||||
(define me (crypto-random-bytes 8))
|
||||
(define h (udp-listener group-port))
|
||||
(during h
|
||||
(assert (udp-multicast-group-member h group-address #f))
|
||||
(assert (udp-multicast-loopback h #t))
|
||||
|
||||
(packet-statistics h)
|
||||
|
||||
(on (message (udp-packet _ h $body))
|
||||
(spawn*
|
||||
;; (log-mcds-info "received: ~v" body)
|
||||
(match (decode body)
|
||||
[(list peer type assertion)
|
||||
;; (log-mcds-info "~v ~v ~v" peer type assertion)
|
||||
(send! (mcds-change peer type assertion))])))
|
||||
|
||||
(on (message (mcds-change $peer '+ $assertion))
|
||||
(spawn
|
||||
(define expiry (+ (current-inexact-milliseconds) *assertion-lifetime*))
|
||||
(assert (mcds-inbound assertion))
|
||||
|
||||
(when (observe? assertion)
|
||||
(define pattern (observe-specification assertion))
|
||||
(define x (mcds-outbound pattern))
|
||||
(add-observer-endpoint!
|
||||
(lambda () x)
|
||||
#:on-add
|
||||
(lambda (captured-values)
|
||||
;; TODO: flawed?? Needs visibility-restriction, or some other way of
|
||||
;; ignoring the opaque placeholders!
|
||||
(assert! (mcds-relevant (instantiate-term->value pattern
|
||||
captured-values
|
||||
#:visibility-restriction-proj
|
||||
#f)
|
||||
peer)))))
|
||||
|
||||
(stop-when (message (mcds-change peer '- assertion)))
|
||||
(stop-when (asserted (later-than expiry)))
|
||||
(stop-when (retracted (mcds-demand)))))
|
||||
|
||||
(during (observe (mcds-inbound $pattern))
|
||||
(assert (mcds-relevant (observe pattern) me))
|
||||
(assert (mcds-outbound (observe pattern))))
|
||||
|
||||
(during (mcds-relevant $assertion _)
|
||||
(during (mcds-outbound assertion)
|
||||
(define (refresh!) (send-packet! h (list me '+ assertion)))
|
||||
(on-start (refresh!))
|
||||
(on-stop (send-packet! h (list me '- assertion)))
|
||||
|
||||
(field [deadline (+ (current-inexact-milliseconds) *assertion-refresh*)])
|
||||
(on (asserted (later-than (deadline)))
|
||||
(refresh!)
|
||||
(deadline (+ (deadline) *assertion-refresh*)))
|
||||
|
||||
(on (asserted (mcds-relevant assertion $peer))
|
||||
;; (log-mcds-info "Peer ~a cares about outbound assertion ~v" peer assertion)
|
||||
(define soon (+ (current-inexact-milliseconds) 100))
|
||||
(when (> (deadline) soon) (deadline soon)))))
|
||||
|
||||
(on (message (mcds-change $peer '! $body))
|
||||
(send! (mcds-inbound body)))
|
||||
|
||||
(on (message (mcds-outbound $body))
|
||||
(send-packet! h (list me '! body))))))
|
|
@ -0,0 +1,23 @@
|
|||
#lang racket/base
|
||||
|
||||
(require auxiliary-macro-context)
|
||||
|
||||
(define-auxiliary-macro-context
|
||||
#:context-name pattern-expander
|
||||
#:prop-name prop:pattern-expander
|
||||
#:prop-predicate-name pattern-expander?
|
||||
#:prop-accessor-name pattern-expander-proc
|
||||
#:macro-definer-name define-pattern-expander
|
||||
#:introducer-parameter-name current-pattern-expander-introducer
|
||||
#:local-introduce-name syntax-local-pattern-expander-introduce
|
||||
#:expander-id-predicate-name pattern-expander-id?
|
||||
#:expander-transform-name pattern-expander-transform)
|
||||
|
||||
(provide (for-syntax
|
||||
prop:pattern-expander
|
||||
pattern-expander?
|
||||
pattern-expander-proc
|
||||
syntax-local-pattern-expander-introduce
|
||||
pattern-expander-id?
|
||||
pattern-expander-transform)
|
||||
define-pattern-expander)
|
|
@ -0,0 +1,240 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (struct-out discard)
|
||||
(struct-out capture)
|
||||
|
||||
(for-syntax analyse-pattern
|
||||
instantiate-pattern->pattern
|
||||
instantiate-pattern->value
|
||||
desc->key
|
||||
desc->skeleton-proj
|
||||
desc->skeleton-stx
|
||||
desc->capture-proj
|
||||
desc->capture-names
|
||||
desc->assertion-stx)
|
||||
|
||||
(all-from-out "pattern-expander.rkt"))
|
||||
|
||||
(require (for-syntax racket/base))
|
||||
(require (for-syntax racket/match))
|
||||
(require (for-syntax racket/struct-info))
|
||||
(require (for-syntax syntax/stx))
|
||||
(require "pattern-expander.rkt")
|
||||
|
||||
(struct discard () #:prefab)
|
||||
(struct capture (detail) #:prefab)
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; ## Analysing patterns
|
||||
;;
|
||||
;; Patterns generate several pieces, which work together to form
|
||||
;; routing tables:
|
||||
;;
|
||||
;; - the *assertion* allows observers of observers to function;
|
||||
;; - the `Skeleton` classifies the shape of the pattern;
|
||||
;; - two `SkProj`s select constant and variable pieces from a pattern, respectively; and
|
||||
;; - a `SkKey` specifies constant pieces of a pattern, matched against one of the `SkProj`s.
|
||||
;;
|
||||
;; The other `SkProj` generates a second `SkKey` which is used as the
|
||||
;; input to a handler function.
|
||||
|
||||
(define-for-syntax orig-insp
|
||||
(variable-reference->module-declaration-inspector (#%variable-reference)))
|
||||
|
||||
(begin-for-syntax
|
||||
(define (dollar-id? stx)
|
||||
(and (identifier? stx)
|
||||
(char=? (string-ref (symbol->string (syntax-e stx)) 0) #\$)))
|
||||
|
||||
(define (undollar stx)
|
||||
(and (dollar-id? stx)
|
||||
(datum->syntax stx (string->symbol (substring (symbol->string (syntax-e stx)) 1)))))
|
||||
|
||||
(define (discard-id? stx)
|
||||
(and (identifier? stx)
|
||||
(free-identifier=? #'_ stx)))
|
||||
|
||||
(define (id-value stx)
|
||||
(and (identifier? stx)
|
||||
(syntax-local-value stx (lambda () #f))))
|
||||
|
||||
(define (list-id? stx)
|
||||
(and (identifier? stx)
|
||||
(free-identifier=? #'list stx)))
|
||||
|
||||
(define (vector-id? stx)
|
||||
(and (identifier? stx)
|
||||
(free-identifier=? #'vector stx)))
|
||||
|
||||
(define (analyse-pattern stx)
|
||||
(define disarmed-stx (syntax-disarm stx orig-insp))
|
||||
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
||||
[(expander args ...)
|
||||
(pattern-expander-id? #'expander)
|
||||
(pattern-expander-transform disarmed-stx
|
||||
(lambda (result)
|
||||
(analyse-pattern (syntax-rearm result stx))))]
|
||||
|
||||
;; Extremely limited support for quasiquoting and quoting
|
||||
[(quasiquote (unquote p)) (analyse-pattern #'p)]
|
||||
[(quasiquote (p ...)) (analyse-pattern #'(list (quasiquote p) ...))]
|
||||
[(quasiquote p) (list 'atom stx)]
|
||||
[(quote p) (list 'atom stx)]
|
||||
|
||||
[(ctor piece ...)
|
||||
(struct-info? (id-value #'ctor))
|
||||
(list* 'compound
|
||||
(extract-struct-info (id-value #'ctor))
|
||||
(stx-map analyse-pattern #'(piece ...)))]
|
||||
[(list piece ...)
|
||||
(list-id? #'list)
|
||||
(list* 'compound
|
||||
'list
|
||||
(stx-map analyse-pattern #'(piece ...)))]
|
||||
[(vector piece ...)
|
||||
(vector-id? #'vector)
|
||||
(list* 'compound
|
||||
'vector
|
||||
(stx-map analyse-pattern #'(piece ...)))]
|
||||
[id
|
||||
(dollar-id? #'id)
|
||||
(list 'capture (undollar #'id) (list 'discard))]
|
||||
[($ id p)
|
||||
(list 'capture #'id (analyse-pattern #'p))]
|
||||
[id
|
||||
(discard-id? #'id)
|
||||
(list 'discard)]
|
||||
[_
|
||||
(list 'atom stx)]))
|
||||
|
||||
(define (instantiate-pattern->pattern stx)
|
||||
(define disarmed-stx (syntax-disarm stx orig-insp))
|
||||
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
||||
[(expander args ...)
|
||||
(pattern-expander-id? #'expander)
|
||||
(pattern-expander-transform disarmed-stx
|
||||
(lambda (result)
|
||||
(instantiate-pattern->pattern (syntax-rearm result stx))))]
|
||||
|
||||
;; Extremely limited support for quasiquoting and quoting
|
||||
[(quasiquote (unquote p)) (instantiate-pattern->pattern #'p)]
|
||||
[(quasiquote (p ...)) (instantiate-pattern->pattern #'(list (quasiquote p) ...))]
|
||||
[(quasiquote p) stx]
|
||||
[(quote p) stx]
|
||||
|
||||
[(ctor piece ...)
|
||||
(struct-info? (id-value #'ctor))
|
||||
(quasisyntax/loc stx (ctor #,@(stx-map instantiate-pattern->pattern #'(piece ...))))]
|
||||
[(list piece ...)
|
||||
(list-id? #'list)
|
||||
(quasisyntax/loc stx (list #,@(stx-map instantiate-pattern->pattern #'(piece ...))))]
|
||||
[(vector piece ...)
|
||||
(vector-id? #'vector)
|
||||
(quasisyntax/loc stx (vector #,@(stx-map instantiate-pattern->pattern #'(piece ...))))]
|
||||
[id
|
||||
(dollar-id? #'id)
|
||||
(undollar #'id)]
|
||||
[($ id p)
|
||||
#'id]
|
||||
[id
|
||||
(discard-id? #'id)
|
||||
#'id]
|
||||
[other
|
||||
#'other]))
|
||||
|
||||
(define (instantiate-pattern->value stx)
|
||||
(define disarmed-stx (syntax-disarm stx orig-insp))
|
||||
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
||||
[(expander args ...)
|
||||
(pattern-expander-id? #'expander)
|
||||
(pattern-expander-transform disarmed-stx
|
||||
(lambda (result)
|
||||
(instantiate-pattern->value (syntax-rearm result stx))))]
|
||||
|
||||
;; Extremely limited support for quasiquoting and quoting
|
||||
[(quasiquote (unquote p)) (instantiate-pattern->value #'p)]
|
||||
[(quasiquote (p ...)) (instantiate-pattern->value #'(list (quasiquote p) ...))]
|
||||
[(quasiquote p) stx]
|
||||
[(quote p) stx]
|
||||
|
||||
[(ctor piece ...)
|
||||
(struct-info? (id-value #'ctor))
|
||||
(quasisyntax/loc stx (ctor #,@(stx-map instantiate-pattern->value #'(piece ...))))]
|
||||
[(list piece ...)
|
||||
(list-id? #'list)
|
||||
(quasisyntax/loc stx (list #,@(stx-map instantiate-pattern->value #'(piece ...))))]
|
||||
[(vector piece ...)
|
||||
(vector-id? #'vector)
|
||||
(quasisyntax/loc stx (vector #,@(stx-map instantiate-pattern->value #'(piece ...))))]
|
||||
[id
|
||||
(dollar-id? #'id)
|
||||
(undollar #'id)]
|
||||
[($ id p)
|
||||
#'id]
|
||||
[id
|
||||
(discard-id? #'id)
|
||||
#'(discard)]
|
||||
[other
|
||||
#'other])))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(begin-for-syntax
|
||||
(define (select-pattern-leaves desc capture-fn atom-fn)
|
||||
(define (walk-node key-rev desc)
|
||||
(match desc
|
||||
[`(compound ,_ ,pieces ...) (walk-edge 0 key-rev pieces)]
|
||||
[`(capture ,name-stx ,p) (append (capture-fn key-rev name-stx) (walk-node key-rev p))]
|
||||
[`(discard) (list)]
|
||||
[`(atom ,v) (atom-fn key-rev v)]))
|
||||
(define (walk-edge index key-rev pieces)
|
||||
(match pieces
|
||||
['() '()]
|
||||
[(cons p pieces) (append (walk-node (cons index key-rev) p)
|
||||
(walk-edge (+ index 1) key-rev pieces))]))
|
||||
(walk-node '() desc))
|
||||
|
||||
(define (desc->key desc)
|
||||
(select-pattern-leaves desc
|
||||
(lambda (key-rev name-stx) (list))
|
||||
(lambda (key-rev atom) (list atom))))
|
||||
|
||||
(define (desc->skeleton-proj desc)
|
||||
(select-pattern-leaves desc
|
||||
(lambda (key-rev name-stx) (list))
|
||||
(lambda (key-rev atom) (list (reverse key-rev)))))
|
||||
|
||||
(define (desc->skeleton-stx desc)
|
||||
(match desc
|
||||
[`(compound list ,pieces ...)
|
||||
#`(list 'list #,@(map desc->skeleton-stx pieces))]
|
||||
[`(compound vector ,pieces ...)
|
||||
#`(list 'vector #,@(map desc->skeleton-stx pieces))]
|
||||
[`(compound (,struct-type ,_ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...)
|
||||
#`(list #,struct-type #,@(map desc->skeleton-stx pieces))]
|
||||
[`(capture ,_ ,p) (desc->skeleton-stx p)]
|
||||
[`(discard) #'#f]
|
||||
[`(atom ,atom-stx) #'#f]))
|
||||
|
||||
(define (desc->capture-proj desc)
|
||||
(select-pattern-leaves desc
|
||||
(lambda (key-rev name-stx) (list (reverse key-rev)))
|
||||
(lambda (key-rev atom) (list))))
|
||||
|
||||
(define (desc->capture-names desc)
|
||||
(select-pattern-leaves desc
|
||||
(lambda (key-rev name-stx) (list name-stx))
|
||||
(lambda (key-rev atom) (list))))
|
||||
|
||||
(define (desc->assertion-stx desc)
|
||||
(match desc
|
||||
[`(compound list ,pieces ...)
|
||||
#`(list #,@(map desc->assertion-stx pieces))]
|
||||
[`(compound vector ,pieces ...)
|
||||
#`(vector #,@(map desc->assertion-stx pieces))]
|
||||
[`(compound (,_struct-type ,ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...)
|
||||
#`(#,ctor #,@(map desc->assertion-stx pieces))]
|
||||
[`(capture ,_ ,p) #`(capture #,(desc->assertion-stx p))]
|
||||
[`(discard) #'(discard)]
|
||||
[`(atom ,v) v]))
|
||||
)
|
|
@ -0,0 +1,72 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(require syndicate/functional-queue)
|
||||
|
||||
(define-logger syndicate/protocol/credit)
|
||||
|
||||
;; (credit* Any (U Number 'reset))
|
||||
;; (credit Any ... (U Number 'reset))
|
||||
;;
|
||||
;; Send this message to issue `amount` units of credit (in the context
|
||||
;; of credit-based flow control) to the given `context`.
|
||||
;;
|
||||
;; A `context` may identify any essentially asynchronous stream where
|
||||
;; either the possibility of overwhelming a consumer exists, or the
|
||||
;; need for occasionally changing the settings of a producer in an
|
||||
;; atomic way exists. For example, reading HTTP headers proceeds
|
||||
;; line-by-line until the body is reached, at which point it proceeds
|
||||
;; byte-by-byte.
|
||||
;;
|
||||
;; The `amount` may either be a number or `'reset`, which should zero
|
||||
;; out (discard) any available credit. In particular, it may be
|
||||
;; `+inf.0`, effectively turning credit-based flow control off for the
|
||||
;; named context.
|
||||
;;
|
||||
;; See also https://eighty-twenty.org/2011/05/15/origins-of-ack-and-flow-control.
|
||||
;;
|
||||
(message-struct credit* (context amount))
|
||||
|
||||
(define-match-expander credit
|
||||
(syntax-rules () [(_ context ... amount) (credit* (list context ...) amount)])
|
||||
(syntax-rules () [(_ context ... amount) (credit* (list context ...) amount)]))
|
||||
|
||||
(define (issue-credit! #:amount [amount 1] . context)
|
||||
(send! (credit* context amount)))
|
||||
|
||||
(define (issue-unbounded-credit! . context)
|
||||
(send! (credit* context +inf.0)))
|
||||
|
||||
(define (make-flow-controlled-sender . context)
|
||||
(make-flow-controlled-sender* context))
|
||||
|
||||
(define (make-flow-controlled-sender* context)
|
||||
(field [q (make-queue)]
|
||||
[item-credit 0])
|
||||
(when (log-level? syndicate/protocol/credit-logger 'debug)
|
||||
(begin/dataflow
|
||||
(log-syndicate/protocol/credit-debug
|
||||
"context ~a, queue length ~a, credit ~a"
|
||||
context
|
||||
(queue-length (q))
|
||||
(item-credit))))
|
||||
(begin/dataflow
|
||||
(when (and (positive? (item-credit))
|
||||
(not (queue-empty? (q))))
|
||||
(define-values (item new-q) (dequeue (q)))
|
||||
(send! item)
|
||||
(q new-q)
|
||||
(item-credit (- (item-credit) 1))))
|
||||
(on (message (credit* context $amount))
|
||||
(item-credit (if (eq? amount 'reset) 0 (+ (item-credit) amount))))
|
||||
(lambda (item) (q (enqueue (q) item))))
|
||||
|
||||
;; It's quite possible that credit-based flow control is not the right
|
||||
;; approach for Syndicate. Using assertions that describe the content
|
||||
;; of a stream more relationally ought to allow "replay" of
|
||||
;; information in different contexts; though the trade-off is not only
|
||||
;; reduced performance, but a need to garbage-collect
|
||||
;; no-longer-interesting portions of the stream; that is,
|
||||
;; *acknowledgements*. In a reliable-delivery context, it would appear
|
||||
;; that at least one of acks or flow-control is required! (?!?)
|
|
@ -0,0 +1,266 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(require syndicate/support/struct)
|
||||
(require racket/match)
|
||||
(require racket/set)
|
||||
(require racket/list)
|
||||
(require racket/hash)
|
||||
|
||||
(require (for-syntax racket/base))
|
||||
(require (for-syntax syntax/stx))
|
||||
|
||||
(module+ test (require rackunit))
|
||||
|
||||
;; A `SkProj` is a *skeleton projection*, a specification of loci
|
||||
;; within a tree-shaped datum to collect into a flat list.
|
||||
;;
|
||||
;; SkProj = (Listof (Listof Nat))
|
||||
;;
|
||||
;; The outer list specifies elements of the flat list; the inner lists
|
||||
;; specify paths via zero-indexed links to child nodes in the
|
||||
;; tree-shaped datum being examined. A precondition for use of a
|
||||
;; `SkProj` is that the datum being examined has been checked for
|
||||
;; conformance to the skeleton being projected.
|
||||
|
||||
;; A `SkKey` is the result of running a `SkProj` over a term,
|
||||
;; extracting the values at the denoted locations.
|
||||
|
||||
;; A `SkCont` is a *skeleton continuation*, a collection of "next
|
||||
;; steps" after a `Skeleton` has matched the general outline of a
|
||||
;; datum.
|
||||
;;
|
||||
;; SkCont = (MutableHash SkProj (MutableHash SkKey (MutableHash SkProj (Setof (... -> Any)))))
|
||||
;;
|
||||
;; The outer `SkProj` selects *constant* portions of the term for more
|
||||
;; matching against the `SkKey`s in the hash table. The inner
|
||||
;; `SkProj`, if any, selects *variable* portions of the term to be
|
||||
;; given to the handler function.
|
||||
|
||||
;; A `Skeleton` is a structural guard on a datum: essentially,
|
||||
;; specification of (the outline of) its shape; its silhouette.
|
||||
;;
|
||||
;; Skeleton = (skeleton-node SkCont (AListof SkLabel SkNode))
|
||||
;; SkLabel = (skeleton-edge Nat Nat SkClass Nat)
|
||||
;; SkClass = StructType | 'list
|
||||
;;
|
||||
(struct skeleton-node (continuations [edges #:mutable]) #:transparent)
|
||||
(struct skeleton-edge (pop-count index class arity) #:transparent)
|
||||
|
||||
(define (make-empty-skeleton)
|
||||
(skeleton-node (make-hash) '()))
|
||||
|
||||
(define (select-pattern-leaves stx capture-fn atom-fn)
|
||||
(define (walk-node key-rev stx)
|
||||
(match stx
|
||||
[(list pieces ...) (walk-edge 0 key-rev pieces)]
|
||||
['$ (capture-fn key-rev)]
|
||||
['_ (list)]
|
||||
[atom (atom-fn key-rev atom)]))
|
||||
(define (walk-edge index key-rev pieces)
|
||||
(match pieces
|
||||
['() '()]
|
||||
[(cons p pieces) (append (walk-node (cons index key-rev) p)
|
||||
(walk-edge (+ index 1) key-rev pieces))]))
|
||||
(walk-node '(0) stx))
|
||||
|
||||
(define (pattern-stx->key stx)
|
||||
(select-pattern-leaves stx
|
||||
(lambda (_key-rev) (list))
|
||||
(lambda (_key-rev atom) (list atom))))
|
||||
|
||||
(define (pattern-stx->skeleton-proj stx)
|
||||
(select-pattern-leaves stx
|
||||
(lambda (_key-rev) (list))
|
||||
(lambda (key-rev _atom) (list (reverse key-rev)))))
|
||||
|
||||
(define (pattern-stx->capture-proj stx)
|
||||
(select-pattern-leaves stx
|
||||
(lambda (key-rev) (list (reverse key-rev)))
|
||||
(lambda (_key-rev _atom) (list))))
|
||||
|
||||
(define merge-skcont!
|
||||
(let ()
|
||||
(define (merge-proj-handler old new)
|
||||
(hash-union! old new #:combine set-union))
|
||||
(define (merge-key-proj-handler old new)
|
||||
(hash-union! old new #:combine merge-proj-handler))
|
||||
(lambda (old new)
|
||||
(hash-union! old new #:combine merge-key-proj-handler))))
|
||||
|
||||
;; Imperatively extends `sk` to include the pattern `stx` terminating
|
||||
;; in `skcont`.
|
||||
(define (extend-skeleton! sk skcont stx)
|
||||
(define (walk-node! sk pop-count index stx)
|
||||
(match stx
|
||||
[(list pieces ...)
|
||||
(define edge (skeleton-edge pop-count index 'list (length pieces)))
|
||||
(define next
|
||||
(match (assoc edge (skeleton-node-edges sk))
|
||||
[#f (let ((next (make-empty-skeleton)))
|
||||
(set-skeleton-node-edges! sk (cons (cons edge next) (skeleton-node-edges sk)))
|
||||
next)]
|
||||
[(cons _edge next) next]))
|
||||
(walk-edge! next 0 0 pieces)]
|
||||
[_
|
||||
(values pop-count sk)]))
|
||||
(define (walk-edge! sk pop-count index pieces)
|
||||
(match pieces
|
||||
['()
|
||||
(values (+ pop-count 1) sk)]
|
||||
[(cons p pieces)
|
||||
(let-values (((pop-count sk) (walk-node! sk pop-count index p)))
|
||||
(walk-edge! sk pop-count (+ index 1) pieces))]))
|
||||
(let-values (((_pop-count sk) (walk-edge! sk 0 0 (list stx))))
|
||||
(merge-skcont! (skeleton-node-continuations sk) skcont)
|
||||
sk))
|
||||
|
||||
;; TODO: avoid repeated descent into `term` by factoring out prefixes of paths in `proj`
|
||||
(define (apply-projection term proj)
|
||||
(for/list [(path proj)]
|
||||
(for/fold [(term (list term))] [(index path)]
|
||||
(cond [(list? term) (list-ref term index)]
|
||||
[else (error 'apply-projection "Non-lists not supported: ~v" term)]))))
|
||||
|
||||
(module+ test
|
||||
(define stx0 '$)
|
||||
(define stx1 '3)
|
||||
(define stxA '($ 3))
|
||||
(define stxB '(4 $))
|
||||
(define stxC '(_ ($ $)))
|
||||
(define stxD '(_ (1 2)))
|
||||
(define stxE '((6 6) _))
|
||||
(define stxF '(($ $) (3 9)))
|
||||
(define stxG '((_ _) (1 2)))
|
||||
(define stxH '((_ _) ((_ _) ($ _))))
|
||||
(define stxI '(((_ _) _) (_ _)))
|
||||
(define stxJ '(((_ _) (_ _)) (_ _)))
|
||||
|
||||
(define (summarise-skeleton sk)
|
||||
(define (walk-node sk)
|
||||
(match-define (skeleton-node continuations edges) sk)
|
||||
(append (if (hash-empty? continuations) '() (list continuations))
|
||||
(map walk-edge edges)))
|
||||
(define (walk-edge e)
|
||||
(match-define (cons (skeleton-edge pop-count index class arity) sk) e)
|
||||
(for/fold [(acc (list* (list index class arity) (walk-node sk)))]
|
||||
[(n pop-count)]
|
||||
(list 'POP acc)))
|
||||
(walk-node sk))
|
||||
|
||||
(define (skcont . ids)
|
||||
(define acc (make-hash))
|
||||
;; Not quite the right shape! Just a dummy placeholder for testing
|
||||
(for [(id ids)]
|
||||
(merge-skcont! acc
|
||||
(make-hash
|
||||
(list (cons id (make-hash
|
||||
(list (cons id (make-hash
|
||||
(list (cons id (set))))))))))))
|
||||
acc)
|
||||
|
||||
(define (skeleton-stx->skeleton id pat-stx)
|
||||
(define sk (make-empty-skeleton))
|
||||
(extend-skeleton! sk (skcont id) pat-stx)
|
||||
sk)
|
||||
|
||||
(check-equal? `(,(skcont 0))
|
||||
(summarise-skeleton (skeleton-stx->skeleton '0 stx0)))
|
||||
(check-equal? `(,(skcont 1))
|
||||
(summarise-skeleton (skeleton-stx->skeleton '1 stx1)))
|
||||
(check-equal? `(((0 list 2) ,(skcont 'A)))
|
||||
(summarise-skeleton (skeleton-stx->skeleton 'A stxA)))
|
||||
(check-equal? `(((0 list 2) ,(skcont 'B)))
|
||||
(summarise-skeleton (skeleton-stx->skeleton 'B stxB)))
|
||||
(check-equal? `(((0 list 2) ((1 list 2) ,(skcont 'C))))
|
||||
(summarise-skeleton (skeleton-stx->skeleton 'C stxC)))
|
||||
(check-equal? `(((0 list 2) ((1 list 2) ,(skcont 'D))))
|
||||
(summarise-skeleton (skeleton-stx->skeleton 'D stxD)))
|
||||
(check-equal? `(((0 list 2) ((0 list 2) ,(skcont 'E))))
|
||||
(summarise-skeleton (skeleton-stx->skeleton 'E stxE)))
|
||||
(check-equal? `(((0 list 2) ((0 list 2) (POP ((1 list 2) ,(skcont 'F))))))
|
||||
(summarise-skeleton (skeleton-stx->skeleton 'F stxF)))
|
||||
(check-equal? `(((0 list 2) ((0 list 2) (POP ((1 list 2) ,(skcont 'G))))))
|
||||
(summarise-skeleton (skeleton-stx->skeleton 'G stxG)))
|
||||
(check-equal? `(((0 list 2)
|
||||
((0 list 2) (POP ((1 list 2) ((0 list 2) (POP ((1 list 2) ,(skcont 'H)))))))))
|
||||
(summarise-skeleton (skeleton-stx->skeleton 'H stxH)))
|
||||
(check-equal? `(((0 list 2) ((0 list 2) ((0 list 2) (POP (POP ((1 list 2) ,(skcont 'I))))))))
|
||||
(summarise-skeleton (skeleton-stx->skeleton 'I stxI)))
|
||||
(check-equal? `(((0 list 2)
|
||||
((0 list 2)
|
||||
((0 list 2) (POP ((1 list 2) (POP (POP ((1 list 2) ,(skcont 'J))))))))))
|
||||
(summarise-skeleton (skeleton-stx->skeleton 'J stxJ)))
|
||||
|
||||
(check-equal? `(,(skcont 0 1)
|
||||
((0 list 2)
|
||||
,(skcont 'A 'B)
|
||||
((0 list 2)
|
||||
,(skcont 'E)
|
||||
((0 list 2)
|
||||
(POP ((1 list 2) (POP (POP ((1 list 2) ,(skcont 'J))))))
|
||||
(POP (POP ((1 list 2) ,(skcont 'I)))))
|
||||
(POP ((1 list 2) ,(skcont 'F 'G) ((0 list 2) (POP ((1 list 2) ,(skcont 'H)))))))
|
||||
((1 list 2) ,(skcont 'C 'D))))
|
||||
(let ((sk (make-empty-skeleton)))
|
||||
(extend-skeleton! sk (skcont '0) stx0)
|
||||
(extend-skeleton! sk (skcont '1) stx1)
|
||||
(extend-skeleton! sk (skcont 'A) stxA)
|
||||
(extend-skeleton! sk (skcont 'B) stxB)
|
||||
(extend-skeleton! sk (skcont 'C) stxC)
|
||||
(extend-skeleton! sk (skcont 'D) stxD)
|
||||
(extend-skeleton! sk (skcont 'E) stxE)
|
||||
(extend-skeleton! sk (skcont 'F) stxF)
|
||||
(extend-skeleton! sk (skcont 'G) stxG)
|
||||
(extend-skeleton! sk (skcont 'H) stxH)
|
||||
(extend-skeleton! sk (skcont 'I) stxI)
|
||||
(extend-skeleton! sk (skcont 'J) stxJ)
|
||||
(summarise-skeleton sk)))
|
||||
|
||||
(check-equal? '() (pattern-stx->skeleton-proj stx0))
|
||||
(check-equal? '((0)) (pattern-stx->skeleton-proj stx1))
|
||||
(check-equal? '((0 1)) (pattern-stx->skeleton-proj stxA))
|
||||
(check-equal? '((0 0)) (pattern-stx->skeleton-proj stxB))
|
||||
(check-equal? '() (pattern-stx->skeleton-proj stxC))
|
||||
(check-equal? '((0 1 0) (0 1 1)) (pattern-stx->skeleton-proj stxD))
|
||||
(check-equal? '((0 0 0) (0 0 1)) (pattern-stx->skeleton-proj stxE))
|
||||
(check-equal? '((0 1 0) (0 1 1)) (pattern-stx->skeleton-proj stxF))
|
||||
(check-equal? '((0 1 0) (0 1 1)) (pattern-stx->skeleton-proj stxG))
|
||||
(check-equal? '() (pattern-stx->skeleton-proj stxH))
|
||||
(check-equal? '() (pattern-stx->skeleton-proj stxI))
|
||||
(check-equal? '() (pattern-stx->skeleton-proj stxJ))
|
||||
|
||||
(check-equal? '() (pattern-stx->key stx0))
|
||||
(check-equal? '(3) (pattern-stx->key stx1))
|
||||
(check-equal? '(3) (pattern-stx->key stxA))
|
||||
(check-equal? '(4) (pattern-stx->key stxB))
|
||||
(check-equal? '() (pattern-stx->key stxC))
|
||||
(check-equal? '(1 2) (pattern-stx->key stxD))
|
||||
(check-equal? '(6 6) (pattern-stx->key stxE))
|
||||
(check-equal? '(3 9) (pattern-stx->key stxF))
|
||||
(check-equal? '(1 2) (pattern-stx->key stxG))
|
||||
(check-equal? '() (pattern-stx->key stxH))
|
||||
(check-equal? '() (pattern-stx->key stxI))
|
||||
(check-equal? '() (pattern-stx->key stxJ))
|
||||
|
||||
(check-equal? '((0)) (pattern-stx->capture-proj stx0))
|
||||
(check-equal? '() (pattern-stx->capture-proj stx1))
|
||||
(check-equal? '((0 0)) (pattern-stx->capture-proj stxA))
|
||||
(check-equal? '((0 1)) (pattern-stx->capture-proj stxB))
|
||||
(check-equal? '((0 1 0) (0 1 1)) (pattern-stx->capture-proj stxC))
|
||||
(check-equal? '() (pattern-stx->capture-proj stxD))
|
||||
(check-equal? '() (pattern-stx->capture-proj stxE))
|
||||
(check-equal? '((0 0 0) (0 0 1)) (pattern-stx->capture-proj stxF))
|
||||
(check-equal? '() (pattern-stx->capture-proj stxG))
|
||||
(check-equal? '((0 1 1 0)) (pattern-stx->capture-proj stxH))
|
||||
(check-equal? '() (pattern-stx->capture-proj stxI))
|
||||
(check-equal? '() (pattern-stx->capture-proj stxJ))
|
||||
|
||||
(check-equal? '(goodbye hello)
|
||||
(apply-projection '((goodbye hello) (3 9)) (pattern-stx->capture-proj stxF)))
|
||||
(check-equal? '(99)
|
||||
(apply-projection '(4 99) (pattern-stx->capture-proj stxB)))
|
||||
(check-equal? '((4 99))
|
||||
(apply-projection '(4 99) (pattern-stx->capture-proj stx0)))
|
||||
)
|
|
@ -0,0 +1,35 @@
|
|||
#lang imperative-syndicate
|
||||
;; Re-assert an assertion when one of a set of triggering events is seen, after a delay.
|
||||
;; Building block for building reconnection strategies.
|
||||
|
||||
(provide reassert-on
|
||||
(struct-out fixed-retry))
|
||||
|
||||
(require/activate imperative-syndicate/drivers/timer)
|
||||
|
||||
(struct fixed-retry (delay-ms) #:transparent
|
||||
#:property prop:procedure
|
||||
(lambda (f) (values (fixed-retry-delay-ms f) f)))
|
||||
|
||||
(define-logger syndicate/reassert)
|
||||
|
||||
(define-syntax reassert-on
|
||||
(syntax-rules ()
|
||||
[(_ assertion #:strategy strategy reset-event ...)
|
||||
(reassert-on* assertion
|
||||
#:strategy strategy
|
||||
(list (lambda (k) (stop-when reset-event (k))) ...))]
|
||||
[(_ assertion reset-event ...)
|
||||
(reassert-on assertion #:strategy (fixed-retry 1000) reset-event ...)]))
|
||||
|
||||
(begin-for-declarations
|
||||
(define (reassert-on* assertion #:strategy strategy event-fns)
|
||||
(on-start (let reassert ((strategy strategy))
|
||||
(react (log-syndicate/reassert-debug "~v: Asserting" assertion)
|
||||
(assert assertion)
|
||||
(define (reset)
|
||||
(log-syndicate/reassert-debug "~v: Resetting with ~v" assertion strategy)
|
||||
(define-values (delay-ms next-strategy) (strategy))
|
||||
(sleep (/ delay-ms 1000.0))
|
||||
(reassert next-strategy))
|
||||
(for-each (lambda (f) (f reset)) event-fns))))))
|
|
@ -0,0 +1,9 @@
|
|||
#lang racket/base
|
||||
;; Reflective protocols
|
||||
|
||||
(provide (struct-out terminated))
|
||||
|
||||
;; (terminated Any (Option Any))
|
||||
;; The `actor-name` is the name of the terminated actor.
|
||||
;; The `reason` is either `#f` or a termination reason, usually an `exn?`.
|
||||
(struct terminated (actor-name reason) #:transparent)
|
|
@ -0,0 +1,154 @@
|
|||
#lang racket/base
|
||||
;; Cross-layer relaying between adjacent dataspaces
|
||||
;; TODO: protocol for *clean* shutdown of a dataspace
|
||||
|
||||
;; TODO: Actually elide the need for relays entirely, by allowing an
|
||||
;; actor to manifest in multiple dataspaces (multiple
|
||||
;; points-of-attachment), and by placing assertions and subscriptions
|
||||
;; directly in the dataspace concerned. (Done naively, this would
|
||||
;; avoid manifesting observed assertions in intermediate nested
|
||||
;; dataspaces; but then, if anyone cared, they'd be observing the
|
||||
;; tuples themselves - right?? Oh, maybe observing the observers would
|
||||
;; be an, er, observable difference.)
|
||||
|
||||
(provide quit-dataspace!
|
||||
dataspace)
|
||||
|
||||
(require racket/match)
|
||||
(require racket/set)
|
||||
(require "assertions.rkt")
|
||||
(require "dataspace.rkt")
|
||||
(require "syntax.rkt")
|
||||
(require "skeleton.rkt")
|
||||
(require "term.rkt")
|
||||
(require "bag.rkt")
|
||||
|
||||
(require (for-syntax racket/base))
|
||||
(require (for-syntax syntax/parse))
|
||||
(require "syntax-classes.rkt")
|
||||
|
||||
(struct *quit-dataspace* () #:transparent)
|
||||
|
||||
;; TODO: inbound^n, outbound^n -- protocol/standard-relay, iow
|
||||
|
||||
(define (quit-dataspace!)
|
||||
(send! (*quit-dataspace*)))
|
||||
|
||||
(define-syntax (dataspace stx)
|
||||
(syntax-parse stx
|
||||
[(_ name:name form ...)
|
||||
(syntax/loc stx
|
||||
(let ((ds-name name.N))
|
||||
(spawn #:name ds-name
|
||||
(define outer-facet (current-facet))
|
||||
(begin/dataflow (void)) ;; eww. dummy endpoint to keep the root facet alive
|
||||
(define (schedule-inner!)
|
||||
(push-script!
|
||||
(facet-actor outer-facet)
|
||||
(lambda ()
|
||||
(with-current-facet [outer-facet]
|
||||
(when (facet-live? outer-facet)
|
||||
(defer-turn! (lambda ()
|
||||
(when (run-scripts! inner-ds)
|
||||
(schedule-inner!)))))))))
|
||||
(define inner-ds (make-dataspace
|
||||
(lambda ()
|
||||
(schedule-script!
|
||||
(current-actor)
|
||||
(lambda ()
|
||||
(spawn #:name (list 'ds-link ds-name)
|
||||
(boot-relay schedule-inner!
|
||||
outer-facet))
|
||||
(spawn* form ...))))))
|
||||
(on-start (schedule-inner!)))))]))
|
||||
|
||||
(define (boot-relay schedule-inner! outer-facet)
|
||||
(define inbound-endpoints (make-hash))
|
||||
(define outbound-endpoints (make-hash))
|
||||
|
||||
(define inner-facet (current-facet))
|
||||
(define inner-actor (current-actor))
|
||||
(define inner-ds (actor-dataspace inner-actor))
|
||||
|
||||
(on (asserted (observe (inbound $x)))
|
||||
;; (log-info "~a (asserted (observe (inbound ~v)))" inner-actor x)
|
||||
(with-current-facet [outer-facet]
|
||||
(with-non-script-context
|
||||
(define (make-endpoint)
|
||||
(define inner-capture-proj
|
||||
;; inner-capture-proj accounts for the extra (inbound ...) layer around
|
||||
;; assertions
|
||||
(let ((outer-capture-proj (term->capture-proj x)))
|
||||
(map (lambda (p) (cons 0 p)) outer-capture-proj)))
|
||||
(define (rebuild cs)
|
||||
(instantiate-term->value (inbound x) cs
|
||||
#:visibility-restriction-proj inner-capture-proj))
|
||||
(define ((wrap f) cs)
|
||||
(f (rebuild cs))
|
||||
(schedule-inner!))
|
||||
(add-raw-observer-endpoint!
|
||||
(lambda () x)
|
||||
#:on-add (wrap (lambda (t) (apply-patch! inner-ds inner-actor (bag t +1))))
|
||||
#:on-remove (wrap (lambda (t) (apply-patch! inner-ds inner-actor (bag t -1))))
|
||||
#:on-message (wrap (lambda (t) (send-assertion! (dataspace-routing-table inner-ds) t)))
|
||||
#:cleanup (lambda (cache)
|
||||
(apply-patch! inner-ds inner-actor (for/bag/count [(cs (in-bag cache))]
|
||||
(values (rebuild cs) -1)))
|
||||
(schedule-inner!))))
|
||||
(record-endpoint-if-live! outer-facet inbound-endpoints x make-endpoint))))
|
||||
|
||||
(on (message (*quit-dataspace*))
|
||||
(with-current-facet [outer-facet]
|
||||
(stop-current-facet)))
|
||||
|
||||
(on (retracted (observe (inbound $x)))
|
||||
;; (log-info "~a (retracted (observe (inbound ~v)))" inner-actor x)
|
||||
(with-current-facet [outer-facet]
|
||||
(with-non-script-context
|
||||
(remove-endpoint! outer-facet (hash-ref inbound-endpoints x))
|
||||
(hash-remove! inbound-endpoints x))))
|
||||
|
||||
(on (asserted (outbound $x))
|
||||
;; (log-info "~a (asserted (outbound ~v))" inner-actor x)
|
||||
(with-current-facet [outer-facet]
|
||||
(with-non-script-context
|
||||
(record-endpoint-if-live! outer-facet
|
||||
outbound-endpoints
|
||||
x
|
||||
(lambda ()
|
||||
(add-endpoint! outer-facet
|
||||
"dataspace-relay (outbound ...)"
|
||||
#t
|
||||
(lambda () (values x #f))))))))
|
||||
|
||||
(on (retracted (outbound $x))
|
||||
;; (log-info "~a (retracted (outbound ~v))" inner-actor x)
|
||||
(with-current-facet [outer-facet]
|
||||
(with-non-script-context
|
||||
(remove-endpoint! outer-facet (hash-ref outbound-endpoints x))
|
||||
(hash-remove! outbound-endpoints x))))
|
||||
|
||||
(on (message (outbound $x))
|
||||
;; (log-info "~a (message (outbound ~v))" inner-actor x)
|
||||
(with-current-facet [outer-facet]
|
||||
(send! x))))
|
||||
|
||||
(define (record-endpoint-if-live! f table key ep-adder)
|
||||
(when (facet-live? f)
|
||||
;;
|
||||
;; ^ Check that `f` is still alive, because we're (carefully!!)
|
||||
;; violating an invariant of `dataspace.rkt` by adding an endpoint
|
||||
;; well after the construction of the facet we're in. We may be
|
||||
;; executing this handler just after clean shutdown of the facet
|
||||
;; by a `quit-dataspace!` request, and in that case we MUST NOT
|
||||
;; add any further endpoints because their assertions will not get
|
||||
;; removed, because cleanup (as part of `(quit)` processing) has
|
||||
;; already been done.
|
||||
;;
|
||||
;; We don't have to do a similar check before calling
|
||||
;; `remove-endpoint!`, because shortly after all (both) calls to
|
||||
;; `destroy-endpoint!`, all destroyed endpoints are removed from
|
||||
;; the `facet-endpoints` table, ensuring they won't be processed
|
||||
;; again.
|
||||
;;
|
||||
(hash-set! table key (ep-adder))))
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue