Compare commits
14 Commits
ba2bd81f3d
...
9a0697e3c5
Author | SHA1 | Date |
---|---|---|
Tony Garnock-Jones | 9a0697e3c5 | |
Tony Garnock-Jones | 0370c19e43 | |
Tony Garnock-Jones | e6234b7713 | |
Tony Garnock-Jones | c97069375a | |
Tony Garnock-Jones | 6673c2b68c | |
Tony Garnock-Jones | 269dd2dc40 | |
Tony Garnock-Jones | ca18ca08df | |
Tony Garnock-Jones | 40ca168eac | |
Tony Garnock-Jones | cdb44de662 | |
Tony Garnock-Jones | 5a73e8d4c3 | |
Tony Garnock-Jones | 710ff91a64 | |
Tony Garnock-Jones | c59e044695 | |
Tony Garnock-Jones | bf0d47f1b7 | |
Tony Garnock-Jones | 7797a3cd09 |
|
@ -1,4 +1,4 @@
|
|||
; syndicate-server -c chat.pr
|
||||
#!/usr/bin/env -S syndicate-server -c
|
||||
|
||||
<require-service <relay-listener <tcp "0.0.0.0" 9001> $gatekeeper>>
|
||||
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
; syndicate-server -c dummy-port-relay.pr
|
||||
#!/usr/bin/env -S syndicate-server -c
|
||||
|
||||
<require-service <daemon dummy-port-relay>>
|
||||
<daemon dummy-port-relay {
|
||||
|
|
|
@ -0,0 +1,55 @@
|
|||
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
||||
;;; SPDX-FileCopyrightText: Copyright © 2024 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||
|
||||
#lang syndicate
|
||||
;; Simple example of the HTTP server protocol and Racket implementation.
|
||||
|
||||
(require syndicate/drivers/http)
|
||||
(require racket/pretty)
|
||||
(require xml)
|
||||
|
||||
(define (html-response #:title title #:head [head '()] . body-items)
|
||||
(parameterize ((current-unescaped-tags html-unescaped-tags)
|
||||
(empty-tag-shorthand html-empty-tags))
|
||||
(mime 'text/html
|
||||
(string-append "<!DOCTYPE html>\n"
|
||||
(xexpr->string
|
||||
`(html
|
||||
(head
|
||||
(meta ((http-equiv "Content-Type") (content "text/html; charset=utf-8")))
|
||||
(meta ((name "viewport") (content "width=device-width, initial-scale=1.0")))
|
||||
(title ,title)
|
||||
,@head)
|
||||
(body ,@body-items)))))))
|
||||
|
||||
(module+ main
|
||||
(standard-actor-system (ds)
|
||||
(with-services [syndicate/drivers/http]
|
||||
(spawn #:name 'logger
|
||||
(at ds
|
||||
(during (HttpRequest $id $host $port $method $path $headers $query $body)
|
||||
(define start-time (current-inexact-milliseconds))
|
||||
(on-start (log-info ":+ ~a ~a ~a ~a ~v" id method host port path))
|
||||
(on-stop (define stop-time (current-inexact-milliseconds))
|
||||
(define duration-ms (- stop-time start-time))
|
||||
(log-info ":- ~a ~a ~a ~a ~v ~ams" id method host port path
|
||||
duration-ms)))))
|
||||
|
||||
(spawn #:name 'server
|
||||
(define-field counter 0)
|
||||
|
||||
(at ds
|
||||
(define-http-route [#f 8080 'get [""] req res]
|
||||
[]
|
||||
(counter (+ (counter) 1))
|
||||
(html-response #:title "Hello"
|
||||
`(h1 "Hello world")
|
||||
`(p "Counter " ,(number->string (counter)))
|
||||
`(a ((href "/page2")) "Go forward")))
|
||||
(define-http-route [#f 8080 'get ["page2"] req res]
|
||||
[]
|
||||
(html-response #:title "Page 2"
|
||||
`(h1 "Second page")
|
||||
`(a ((href "/")) "Go back")))))
|
||||
|
||||
)))
|
|
@ -1,7 +1,7 @@
|
|||
# Efficient, Imperative Dataspaces for Conversational Concurrency
|
||||
|
||||
Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||
20 October 2018; revised 21 June 2019
|
||||
20 October 2018; revised 21 June 2019 and 4-5 April 2024
|
||||
|
||||
<p style="font-size:90%"><strong>Abstract.</strong> The dataspace
|
||||
model of Conversational Concurrency [is great], but implementing it
|
||||
|
@ -29,7 +29,7 @@ language.
|
|||
x ∈ identifiers X
|
||||
a ∈ atoms A = numbers ∪ strings ∪ ...
|
||||
|
||||
Here are some examples of assertions in `c`, along with suggested
|
||||
Here are some examples of assertions in `C`, along with suggested
|
||||
interpretations:
|
||||
|
||||
present("Alice") Alice is present in the chat room
|
||||
|
@ -87,7 +87,7 @@ only the name of the speaker.
|
|||
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 | _
|
||||
p ∈ patterns P ::= v | x(p, ...) | $x | _
|
||||
|
||||
Syntactic patterns can be translated into assertions of interest
|
||||
directly. Binding subpatterns `$x` are translated into `capture()`,
|
||||
|
@ -113,10 +113,9 @@ 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.
|
||||
positions 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.
|
||||
|
@ -124,49 +123,57 @@ 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 = [𝐍]
|
||||
k ∈ skeletons K = S × (H ⟼ V+1) × [H]
|
||||
s ∈ shapes S = (H ⟼ L)
|
||||
ℓ ∈ classes L = X -- label
|
||||
h ∈ paths H = [𝐍]
|
||||
|
||||
Shapes retain only statically-known constructors and arities in a
|
||||
pattern:
|
||||
Shapes retain only statically-known constructors in a pattern:
|
||||
|
||||
shape :: P -> S
|
||||
shape e = *
|
||||
shape x(p, ...) = x(shape p, ...)
|
||||
shape $x = *
|
||||
shape _ = *
|
||||
shape :: P → S
|
||||
shape p = shape' [] p
|
||||
where
|
||||
shape' :: H → P → S
|
||||
shape h v = ∅
|
||||
shape h x(p₀, ..., pᵢ) = (h ⟼ x)
|
||||
∪ (shape (h++[0]) p₀) ∪ ...
|
||||
∪ (shape (h++[i]) pᵢ)
|
||||
shape h $x = ∅
|
||||
shape h _ = ∅
|
||||
|
||||
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.
|
||||
A constant map filters potential matches by placing constraints on
|
||||
contained fields. The paths `H` in the map denote positions to be
|
||||
checked; the predicates `V+1` denote either a particular value that must
|
||||
exist at that position, or a simple check that the term in question
|
||||
merely *has* a value in that position.
|
||||
|
||||
constantmap :: P -> [(H, E)]
|
||||
constantmap :: P → (H ⟼ V+1)
|
||||
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 _ = []
|
||||
cmap :: H → P → (H ⟼ V+1)
|
||||
cmap h v = (h ⟼ inl v)
|
||||
cmap h x(p₀, ..., pᵢ) = (cmap (h++[0]) p₀) ∪ ...
|
||||
∪ (cmap (h++[i]) pᵢ)
|
||||
cmap h $x = ∅
|
||||
cmap h _ = (h ⟼ inr ())
|
||||
|
||||
Finally, a capture map extracts all capturing positions in a pattern:
|
||||
It will be useful to separate value-check operations from existence-check operations.
|
||||
|
||||
capturemap :: P -> [H]
|
||||
constantchecks :: (H ⟼ V+1) → (H ⟼ V) × 𝒫(H)
|
||||
constantchecks m = ( { h ⟼ v | h ⟼ inl v ∈ m },
|
||||
{ h | h ⟼ inr () ∈ m } )
|
||||
|
||||
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 _ = []
|
||||
vmap :: H → P → [H]
|
||||
vmap h v = []
|
||||
vmap h x(p₀, ..., pᵢ) = (vmap (h++[0]) p₀) ++ ...
|
||||
++ (vmap (h++[i]) pᵢ)
|
||||
vmap h $x = [h]
|
||||
vmap h _ = []
|
||||
|
||||
### The index
|
||||
|
||||
|
@ -175,8 +182,8 @@ 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.
|
||||
An index contains a bag of all currently-asserted
|
||||
assertion-values, as well as the root of a trie-like structure.
|
||||
Information from each indexed event handler's skeleton's shape is laid
|
||||
out along edges connecting trie nodes.
|
||||
|
||||
|
@ -185,23 +192,22 @@ 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
|
||||
Node = Continuation × (Move ⟼ L ⟼ Node)
|
||||
Move = 𝐍 × H
|
||||
|
||||
Continuation = 𝒫(V) × ([H] ⟼ [V] ⟼ Leaf)
|
||||
Continuation = 𝒫(V) × ([H]×𝒫(H) ⟼ [V] ⟼ Leaf)
|
||||
Leaf = 𝒫(V) × ([H] ⟼ Handler)
|
||||
|
||||
Handler = Bag([V]) × 𝒫(Callback)
|
||||
|
||||
Callback = EventType -> [V] -> V
|
||||
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,
|
||||
the root `Node` of the index along move- and 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
|
||||
|
@ -213,15 +219,103 @@ 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
|
||||
Most of the components in an index are *mutable*: the `Bag(V)` and
|
||||
initial class-to-`Node` map in the
|
||||
root; the assertion-value cache set in each `Continuation` or `Leaf`
|
||||
object; the map from `Selector` to `Class` to `Node` within each
|
||||
object; the map from move 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.
|
||||
|
||||
#### From pattern shapes to tries of moves
|
||||
|
||||
**Definition.** A *visit* of a tree is a sequence of paths to nodes
|
||||
within the tree. It may be described in two equivalent ways: as a
|
||||
sequence of rooted (absolute) paths, `[H]`, or as a sequence of *moves*,
|
||||
relative paths, `[Move]`.
|
||||
|
||||
w ∈ absolute visits [H]
|
||||
w̅ ∈ relative visits [Move]
|
||||
|
||||
**Definition.** A *move* or *relative path* `h̅ ∈ Move` consists of zero
|
||||
or more steps rootward from a position in a tree, followed by a path
|
||||
from that position leafward in the tree. We define operators `⊕` and `⊖`
|
||||
for applying a move to an existing path and computing a move from one
|
||||
path to another, respectively:
|
||||
|
||||
⊕ :: H → Move → H
|
||||
hₒ ⊕ (n, h) = dropRight n hₒ ++ h
|
||||
|
||||
⊖ :: H → H → Move
|
||||
h ⊖ hₒ = (|hₒ| - |h'|, dropLeft |h'| h)
|
||||
where
|
||||
h' = longestCommonPrefix hₒ h
|
||||
|
||||
The first relative path in a relative visit is interpreted with respect
|
||||
to the root of the tree. Relative and absolute visits are
|
||||
interconvertible:
|
||||
|
||||
absToRel :: [H] → [Move]
|
||||
absToRel hs = rel [] hs
|
||||
where
|
||||
rel hₒ [] = []
|
||||
rel hₒ [h, h₁, ...] = [h ⊖ hₒ] ++ rel h [h₁, ...]
|
||||
|
||||
relToAbs :: [Move] → [H]
|
||||
relToAbs hs = abs [] hs
|
||||
where
|
||||
abs hₒ [] = []
|
||||
abs hₒ [h̅, h̅₁, ...] = [hₒ ⊕ h̅] ++ abs (hₒ ⊕ h̅) [h̅₁, ...]
|
||||
|
||||
**Definition.** The `shapeVisit` function converts a shape into a
|
||||
sequence of `Move × L` pairs. The `Move`s in the sequence are a
|
||||
visit of the nodes in the domain of the input shape.
|
||||
|
||||
shapeVisit :: S → [Move × L]
|
||||
shapeVisit s = zip (absToRel (map fst s')) (map snd s')
|
||||
where
|
||||
s' = sort lexLt s
|
||||
|
||||
The utility `sort :: ∀A ∀B . (A → A → 2) → (A ⟼ B) → [(A, B)]`
|
||||
produces a sorted sequence from a finite map and a "less-than"
|
||||
predicate, which in this case is `lexLt`, the lexicographic ordering on
|
||||
paths.
|
||||
|
||||
*Implementation note.* The type `S = (H ⟼ L)` is an (unordered) map, but
|
||||
could equally well be a sequence of pairs `S = [H × L]` with the side
|
||||
condition that the `H`s must be unique. With that representation,
|
||||
`shape` can be adjusted to produce output in lexicographically-sorted
|
||||
order, obviating the need for `sort` in `shapeVisit`.
|
||||
|
||||
*Implementation note.* In the special case of visiting a shape derived
|
||||
from a pattern, a move `(n, h)` will always have either `|h| = 0` (if it
|
||||
is the first move in the visit) or `|h| = 1` (if not). This allows
|
||||
representation of moves in indexes as `𝐍 × (1 + 𝐍)` instead of the fully
|
||||
general `𝐍 × H`.
|
||||
|
||||
**Lemma.** Every shape produced by `shape p` for a pattern `p` includes
|
||||
a mapping for all and only the interior nodes of the tree embodied by
|
||||
`p`. That is, every non-leaf node in `p` has a path in the domain of
|
||||
`shape p`.
|
||||
|
||||
*Proof*. By induction on `p` and examination of `shape`. ∎
|
||||
|
||||
**Lemma.** Every relative path contained in a nonempty visit produced by
|
||||
`shapeVisit (shape p)` has a leafward path of length one, except the
|
||||
first such relative path, which always equals `(0, [])`.
|
||||
|
||||
*Proof*. By properties of the lexicographic ordering of paths and the
|
||||
lemma above. The first path in `shapeVisit`'s result will always be the
|
||||
relative path to the root node, `(0, [])`, since that is the smallest
|
||||
possible path by the ordering. Subsequent paths will always be to an
|
||||
*immediate* child of the current node or of one of its ancestors. If it
|
||||
were not so, a contradiction would arise: since every interior node is
|
||||
represented, every immediate child with children of its own must appear,
|
||||
and lexicographic ordering requires that such nodes appear before their
|
||||
own children, so "skipping" a generation is not possible. ∎
|
||||
|
||||
#### Adding and removing event handlers
|
||||
|
||||
Every event handler is a pair of a skeleton and a callback function.
|
||||
|
@ -239,64 +333,72 @@ 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`.
|
||||
**Example.** Let our pattern be
|
||||
|
||||
project :: V -> H -> V
|
||||
p = x(y(3, 4), $v, z(_, w(), _), _)
|
||||
|
||||
The skeleton of the pattern is then
|
||||
|
||||
k = (shape p, constantmap p, capturemap p)
|
||||
|
||||
shape p = ([] ⟼ x)
|
||||
∪ ([0] ⟼ y)
|
||||
∪ ([2] ⟼ z)
|
||||
∪ ([2, 1] ⟼ w)
|
||||
|
||||
constantmap p = ([0, 0] ⟼ inl 3)
|
||||
∪ ([0, 1] ⟼ inl 4)
|
||||
∪ ([2, 0] ⟼ inr ())
|
||||
∪ ([2, 2] ⟼ inr ())
|
||||
∪ ([3] ⟼ inr ())
|
||||
|
||||
capturemap p = [[1]]
|
||||
|
||||
The shape-visit of `p` is thus
|
||||
|
||||
shapeVisit (shape p) = [((0, []), x),
|
||||
((0, [0]), y),
|
||||
((1, [2]), z),
|
||||
((0, [1]), w)]
|
||||
|
||||
**Definition.** The partial `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
|
||||
project x(v₀, ..., vᵢ) (n:h) = project vₙ h, if 0 ≤ n ≤ i
|
||||
|
||||
**Definition.** The `projectMany` function projects a sequence of
|
||||
subvalues.
|
||||
**Definition.** The `projectMany` partial function projects a sequence
|
||||
of subvalues.
|
||||
|
||||
projectMany :: V -> [H] -> V
|
||||
projectMany v [h_0, ...] = [project v h_0, ...]
|
||||
projectMany :: V → [H] ⇀ [V]
|
||||
projectMany v [h, ...] = [project v h, ...]
|
||||
|
||||
**Definition.** The `classof` function extracts the constructor label
|
||||
`x` from a value `v`, yielding `()` if `v` is not a record.
|
||||
**Definition.** The `classof` partial function extracts the constructor
|
||||
label `x` from a record value. It is undefined for non-record values.
|
||||
|
||||
classof :: V -> 1 + Class
|
||||
classof a = ()
|
||||
classof x(v_0, ..., v_i) = x
|
||||
classof :: V ⇀ L
|
||||
classof x(v₀, ..., vᵢ) = x
|
||||
|
||||
**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`.
|
||||
information `s`, where `∃p . s = shape p`, by imperatively updating
|
||||
the index structure. It returns the `Continuation` associated with the
|
||||
final `Node` visited in the path described by `s`.
|
||||
|
||||
extend :: Node -> S -> Continuation
|
||||
extend node s =
|
||||
let (_, (cont, _)) = walk-node [] node 0 0 s
|
||||
cont
|
||||
extend :: Index → S → Continuation
|
||||
extend (_, root) s = visit [] root (shapeVisit s)
|
||||
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
|
||||
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]
|
||||
visit :: H → Node → [Move × L] → Continuation
|
||||
visit h (cont, moveTable) [] = cont
|
||||
visit h (cont, moveTable) ([(h̅, ℓ)] ++ moves) =
|
||||
if h̅ not in moveTable then
|
||||
moveTable[h̅] := {}
|
||||
let classTable = moveTable[h̅]
|
||||
if ℓ not in classTable then
|
||||
let vs = { v | v ∈ fst cont,
|
||||
classof (project v (h ⊕ h̅)) = ℓ }
|
||||
classTable[ℓ] := ((vs, {}), {})
|
||||
visit (h ⊕ h̅) classTable[ℓ] moves
|
||||
|
||||
**Definition.** The `addHandler` procedure installs into an index an
|
||||
event handler callback `f` expecting values matching and captured by
|
||||
|
@ -304,31 +406,35 @@ cases where handlers are dynamically installed.
|
|||
sequence of captured values matching existing assertions in the
|
||||
index.[^function-pointer-equality]
|
||||
|
||||
addHandler :: Index -> (S × [H×V] × [H]) -> Callback -> 1
|
||||
addHandler :: Index → K → 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] := {}
|
||||
let (cache, table) = extend index s
|
||||
let (unsortedConstants, checks) = constantchecks constantMap
|
||||
let constants = sort lexLt unsortedConstants
|
||||
let constLocs = map fst constants
|
||||
let constKey = (constLocs, checks)
|
||||
if constKey not in table then
|
||||
table[constKey] := {}
|
||||
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 ∀h ∈ checks, project v h is defined and
|
||||
∃key . key = projectMany v constLocs then
|
||||
if key not in table[constKey] then
|
||||
table[constKey][key] := ({}, {})
|
||||
let (leafcache, _leaftable) = table[constKey][key]
|
||||
leafcache += v
|
||||
let constVals = map snd constants
|
||||
if constVals not in table[constKey] then
|
||||
table[constKey][constVals] := ({}, {})
|
||||
let (leafcache, leaftable) = table[constKey][constVals]
|
||||
if captureMap not in leaftable then
|
||||
let bag = empty_bag
|
||||
for v in leafcache
|
||||
bag[projectMany v captureMap] += 1
|
||||
if ∃seq . seq = projectMany v captureMap then
|
||||
bag[seq] += 1
|
||||
leaftable[captureMap] := (bag, {})
|
||||
let (bag, f_table) = leaftable[captureMap]
|
||||
f_table += f
|
||||
for seq in bag
|
||||
for (seq ⟼ _) in bag
|
||||
f "+" seq
|
||||
()
|
||||
|
||||
|
@ -340,17 +446,19 @@ cases where handlers are dynamically installed.
|
|||
**Definition.** The `removeHandler` procedure removes an event handler
|
||||
from an index.
|
||||
|
||||
removeHandler :: Index -> (S × [H×V] × [H]) -> Callback -> 1
|
||||
removeHandler :: Index → K → 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
|
||||
let (_, table) = extend index s
|
||||
let (unsortedConstants, checks) = constantchecks constantMap
|
||||
let constants = sort lexLt unsortedConstants
|
||||
let constLocs = map fst constants
|
||||
let constKey = (constLocs, checks)
|
||||
if constKey not in table then
|
||||
return
|
||||
let constVals = [v | (h,v) ∈ constantMap]
|
||||
if constVals not in table[constLocs] then
|
||||
let constVals = map snd constants
|
||||
if constVals not in table[constKey] then
|
||||
return
|
||||
let (leafcache, leaftable) = table[constLocs][constVals]
|
||||
let (leafcache, leaftable) = table[constKey][constVals]
|
||||
if captureMap not in leaftable then
|
||||
return
|
||||
let (bag, f_table) = leaftable[captureMap]
|
||||
|
@ -360,9 +468,9 @@ cases where handlers are dynamically installed.
|
|||
if f_table = {} then
|
||||
delete leaftable[captureMap]
|
||||
if leafcache = {} and leaftable = {} then
|
||||
delete table[constLocs][constVals]
|
||||
if table[constLocs] = {} then
|
||||
delete table[constLocs]
|
||||
delete table[constKey][constVals]
|
||||
if table[constKey] = {} then
|
||||
delete table[constKey]
|
||||
|
||||
#### Adding assertions, removing assertions and sending messages
|
||||
|
||||
|
@ -377,70 +485,59 @@ parameterized with different update procedures.
|
|||
|
||||
Operation = { AddAssertion, RemoveAssertion, SendMessage }
|
||||
|
||||
modify :: Node ->
|
||||
Operation ->
|
||||
V ->
|
||||
(Continuation -> V -> 1) ->
|
||||
(Leaf -> V -> 1) ->
|
||||
(Handler -> [V] -> 1) ->
|
||||
modify :: Index →
|
||||
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)]
|
||||
modify (_, root) operation v m_cont m_leaf m_handler =
|
||||
visit root [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')
|
||||
visit :: Node → [V] → 1
|
||||
visit (cont, moveTable) vs =
|
||||
visit-cont cont
|
||||
for ((n, h) ⟼ classTable) in moveTable
|
||||
let (v' : vs') = dropLeft vs n in
|
||||
if ∃v . v = project v' h and
|
||||
∃ℓ . ℓ = classof v and
|
||||
∃next . (ℓ ⟼ next) ∈ classTable then
|
||||
visit next (v : v' : vs')
|
||||
|
||||
walk-cont :: Continuation -> 1
|
||||
walk-cont cont@(cache, table) =
|
||||
visit-cont :: Continuation → 1
|
||||
visit-cont cont@(_, 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.
|
||||
for ((constLocs, checks) ⟼ constVals) in table
|
||||
if ∀h ∈ checks, project v h is defined and
|
||||
∃consts . consts = projectMany v constLocs then
|
||||
if operation = AddAssertion and consts not in constVals then
|
||||
constVals[consts] := ({}, {})
|
||||
if consts in constVals then
|
||||
let leaf@(leafcache, leaftable) = constVals[consts]
|
||||
m_leaf leaf v
|
||||
for (captureMap ⟼ handler) in leaftable
|
||||
if ∃vs . vs = projectMany v captureMap then
|
||||
m_handler handler vs
|
||||
if operation = RemoveAssertion and leafcache = {} and leaftable = {} then
|
||||
delete constVals[consts]
|
||||
if constVals = {} then
|
||||
delete table[(constLocs, checks)]
|
||||
|
||||
**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 =
|
||||
adjustAssertion :: Index → V → 𝐍 → 1
|
||||
adjustAssertion index@(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
|
||||
modify index 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
|
||||
modify index RemoveAssertion v del_cont del_leaf del_handler
|
||||
where
|
||||
add_cont (cache, _) v = cache += v
|
||||
add_leaf (leafcache, _) v = leafcache += v
|
||||
|
@ -463,10 +560,10 @@ check followed by zero or more (move, check) pairs.
|
|||
install and remove an assertion `v` into the given index,
|
||||
respectively.
|
||||
|
||||
addAssertion :: Index -> V -> 1
|
||||
addAssertion :: Index → V → 1
|
||||
addAssertion index v = adjustAssertion index v 1
|
||||
|
||||
removeAssertion :: 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
|
||||
|
@ -481,7 +578,7 @@ 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 :: Index → V → 1
|
||||
sendMessage (_, root) v =
|
||||
modify root SendMessage v send_cont send_leaf send_handler
|
||||
where
|
||||
|
@ -491,8 +588,32 @@ processed first, no glitch will be detected.
|
|||
for f in f_table
|
||||
f "!" vs
|
||||
|
||||
## Variations
|
||||
|
||||
### Exact arity matching
|
||||
|
||||
The initial version of this design had
|
||||
|
||||
k ∈ skeletons K = S × (H ⟼ V) × [H]
|
||||
ℓ ∈ classes L = X × 𝐍 -- label and arity
|
||||
|
||||
which provided for exact arity matching instead of extensible "at-least"
|
||||
arity matching. Constant maps contained `V` rather than `V+1` because
|
||||
the arity check as part of the class obviated the need to check a
|
||||
position for mere existence.
|
||||
|
||||
### Matching atom classes
|
||||
|
||||
Skeleton constant map predicates `V+1` can be changed to include any
|
||||
other kind of predicate besides equal-to-expected-value `V` and simple
|
||||
existence `1`, such as `string?`/`int?`/etc.
|
||||
|
||||
## Potential future optimizations
|
||||
|
||||
### JIT compilation of shapes, constant checks, captures
|
||||
|
||||
TODO
|
||||
|
||||
### Static analysis of messages and assertions
|
||||
|
||||
Static analysis of expressions under `(send! ...)` and `(assert ...)`
|
||||
|
|
|
@ -70,8 +70,12 @@
|
|||
(when (eq? (bag-change! assertions value -1) 'present->absent)
|
||||
(remove-assertion! this-turn skeleton value)
|
||||
(match maybe-observe
|
||||
[(? eof-object?) (void)]
|
||||
[(Observe pat ref) (remove-interest! this-turn skeleton pat ref)]))]))
|
||||
[(? eof-object?)
|
||||
(log-syndicate/dataspace-debug "Not an observer:~a" (pretty-assertion 4 value))
|
||||
(void)]
|
||||
[(Observe pat ref)
|
||||
(remove-interest! this-turn skeleton pat ref)
|
||||
(log-syndicate/dataspace-debug "Updated index:~a" (pretty-assertion 4 skeleton))]))]))
|
||||
#:message (lambda (message)
|
||||
(log-syndicate/dataspace-debug "~v !~a" ds-e (pretty-assertion 4 message))
|
||||
(send-assertion! this-turn skeleton message))))
|
||||
|
|
|
@ -49,17 +49,21 @@
|
|||
(lambda (set-peer-session! handle-message)
|
||||
(at acceptor-ref
|
||||
(assert (Resolve (Step (NoiseStepType) service-selector)
|
||||
(object #:name 'noise-initiator
|
||||
(object #:name 'noise-observer
|
||||
[#:asserted (Resolved-accepted responder-session)
|
||||
(at responder-session
|
||||
(assert (Initiator
|
||||
(object #:name 'noise-initiator
|
||||
[#:message m
|
||||
(handle-message m)]))))
|
||||
(set-peer-session! responder-session)
|
||||
#:retracted
|
||||
(stop-current-facet)]
|
||||
[#:message m (handle-message m)])))))))
|
||||
(stop-current-facet)])))))))
|
||||
|
||||
(define (noise-responder #:service-selector service-selector
|
||||
#:static-keypair static-keypair
|
||||
#:export initial-ref
|
||||
#:initiator-session initiator-session
|
||||
#:observer observer
|
||||
#:preshared-keys [psks #f]
|
||||
#:pattern [pattern #f])
|
||||
(noise* #:role 'responder
|
||||
|
@ -69,11 +73,15 @@
|
|||
#:preshared-keys psks
|
||||
#:pattern pattern
|
||||
(lambda (set-peer-session! handle-message)
|
||||
(set-peer-session! initiator-session)
|
||||
(at initiator-session
|
||||
(at observer
|
||||
(assert (Resolved-accepted
|
||||
(object #:name (list 'noise-responder initial-ref initiator-session)
|
||||
[#:message m (handle-message m)])))))))
|
||||
(object #:name (list 'noise-responder initial-ref observer)
|
||||
[#:asserted (Initiator s)
|
||||
(set-peer-session! s)
|
||||
#:retracted
|
||||
(stop-current-facet)]
|
||||
[#:message m
|
||||
(handle-message m)])))))))
|
||||
|
||||
(define (noise* #:role role
|
||||
#:service-selector service-selector
|
||||
|
@ -127,6 +135,7 @@
|
|||
(handshake-step))))))
|
||||
|
||||
(define (set-peer-session! session)
|
||||
(when peer-session (error 'noise* "Double-setting of peer-session"))
|
||||
(set! peer-session session)
|
||||
(when (eq? role 'initiator) (handshake-step)))
|
||||
|
||||
|
@ -134,12 +143,15 @@
|
|||
|
||||
(module+ test
|
||||
(require libsodium)
|
||||
(file-stream-buffer-mode (current-output-port) 'none)
|
||||
|
||||
(when (file-stream-buffer-mode (current-output-port))
|
||||
;; ^ Only try to set it if we get a non-#f answer when we ask for it
|
||||
(file-stream-buffer-mode (current-output-port) 'none))
|
||||
|
||||
(standard-actor-system (ds)
|
||||
(spawn #:name 'test-main
|
||||
(define server-keys (make-crypto-box-keypair))
|
||||
(define server-keys (make-crypto-box-keypair))
|
||||
|
||||
(spawn #:name 'test-responder
|
||||
(define service-object
|
||||
(object [a
|
||||
(printf "service+: ~v\n" a)
|
||||
|
@ -149,12 +161,13 @@
|
|||
(stop-current-facet)]))
|
||||
|
||||
(at ds
|
||||
(during (Resolve (Step (NoiseStepType) 'test-service) $initiator-session)
|
||||
(during (Resolve (Step (NoiseStepType) 'test-service) $observer)
|
||||
(noise-responder #:service-selector 'test-service
|
||||
#:static-keypair server-keys
|
||||
#:initiator-session initiator-session
|
||||
#:export service-object)))
|
||||
#:observer observer
|
||||
#:export service-object))))
|
||||
|
||||
(spawn #:name 'test-initiator
|
||||
(noise-initiator #:service-selector 'test-service
|
||||
#:remote-static-pk (crypto-box-keypair-pk server-keys)
|
||||
#:acceptor-ref ds
|
||||
|
|
|
@ -44,6 +44,8 @@
|
|||
|
||||
(define-logger syndicate/drivers/http)
|
||||
|
||||
(struct active-handler (ref signal) #:transparent)
|
||||
|
||||
(provide-service [ds]
|
||||
(at ds
|
||||
(during/spawn (HttpBinding _ $port _ _ _)
|
||||
|
@ -59,8 +61,11 @@
|
|||
(define handler-set (hash-ref! method-map method mutable-set))
|
||||
(unless (set-empty? handler-set)
|
||||
(log-syndicate/drivers/http-warning "Multiple active handlers for ~v" service))
|
||||
(set-add! handler-set handler)
|
||||
(on-stop (set-remove! handler-set handler)
|
||||
(define-field handler-terminated? #f)
|
||||
(define entry (active-handler handler handler-terminated?))
|
||||
(set-add! handler-set entry)
|
||||
(on-stop (handler-terminated? #t)
|
||||
(set-remove! handler-set entry)
|
||||
(when (set-empty? handler-set) (hash-remove! method-map method))
|
||||
(when (hash-empty? method-map) (hash-remove! pattern-map path))
|
||||
(when (hash-empty? pattern-map) (hash-remove! routes host)))
|
||||
|
@ -100,7 +105,7 @@
|
|||
(with-handlers ([exn:fail? (lambda (e) (values #f #t))])
|
||||
(read-request conn port tcp-addresses)))
|
||||
(when req
|
||||
;; (log-syndicate/drivers/http-debug "~v ~v ~v ~v ~v" connection-name routes req close?)
|
||||
;; (log-syndicate/drivers/http-debug "~v ~v ~v ~v" connection-name routes req close?)
|
||||
(define continue-ch (make-async-channel))
|
||||
(turn! facet
|
||||
(lambda ()
|
||||
|
@ -192,48 +197,73 @@
|
|||
(list (header #"Allow" methods))
|
||||
(list)))
|
||||
(return (void)))))
|
||||
(define handler (set-first handler-set))
|
||||
(define pending-code #f)
|
||||
(define pending-message #f)
|
||||
(match-define (active-handler handler handler-terminated?) (set-first handler-set))
|
||||
(define processing #f)
|
||||
(define pending-code 500)
|
||||
(define pending-message "Internal Server Error")
|
||||
(define pending-headers-rev '())
|
||||
(define chunk-ch #f)
|
||||
(define res (object #:name connection-name
|
||||
[#:message (HttpResponse-status code message)
|
||||
(set! pending-code code)
|
||||
(set! pending-message message)]
|
||||
[#:message (HttpResponse-header name value)
|
||||
(set! pending-headers-rev (cons (cons name value) pending-headers-rev))]
|
||||
[#:message (HttpResponse-chunk chunk)
|
||||
(unless chunk-ch
|
||||
(set! chunk-ch (make-async-channel))
|
||||
(output-response/method
|
||||
conn
|
||||
(response pending-code
|
||||
(string->bytes/utf-8 pending-message)
|
||||
(current-seconds)
|
||||
#f
|
||||
(build-headers (reverse pending-headers-rev))
|
||||
(lambda (output-port)
|
||||
(let loop ()
|
||||
(match (async-channel-get chunk-ch)
|
||||
[#f (void)]
|
||||
[bs (write-bytes bs output-port) (loop)]))))
|
||||
(request-method req)))
|
||||
(async-channel-put chunk-ch (chunk->bytes chunk))]
|
||||
[#:message (HttpResponse-done chunk)
|
||||
(if chunk-ch
|
||||
(begin (async-channel-put chunk-ch (chunk->bytes chunk))
|
||||
(async-channel-put chunk-ch #f))
|
||||
(output-response/method
|
||||
conn
|
||||
(response/full pending-code
|
||||
|
||||
(define (check-processing!)
|
||||
(unless processing
|
||||
(error 'HttpResponse "Attempt to reply before <processing> has been asserted")))
|
||||
|
||||
(define (send-headers!)
|
||||
(unless chunk-ch
|
||||
(set! chunk-ch (make-async-channel))
|
||||
(thread
|
||||
(lambda ()
|
||||
(output-response/method conn
|
||||
(response pending-code
|
||||
(string->bytes/utf-8 pending-message)
|
||||
(current-seconds)
|
||||
#f
|
||||
(build-headers (reverse pending-headers-rev))
|
||||
(list (chunk->bytes chunk)))
|
||||
(request-method req)))
|
||||
(stop-current-facet)]))
|
||||
(lambda (output-port)
|
||||
(let loop ()
|
||||
(match (async-channel-get chunk-ch)
|
||||
[#f (void)]
|
||||
[bs
|
||||
(write-bytes bs output-port)
|
||||
(flush-output output-port)
|
||||
(loop)]))))
|
||||
(request-method req))))))
|
||||
|
||||
(define (finish-request!)
|
||||
(send-headers!)
|
||||
(async-channel-put chunk-ch #f)
|
||||
(stop-current-facet))
|
||||
|
||||
(begin/dataflow
|
||||
(when (handler-terminated?)
|
||||
(finish-request!)))
|
||||
|
||||
(define res (object #:name connection-name
|
||||
[#:asserted (HttpResponse-processing)
|
||||
(log-syndicate/drivers/http-debug "~v: +processing" connection-name)
|
||||
(set! processing #t)
|
||||
(set! pending-code 200)
|
||||
(set! pending-message "OK")
|
||||
#:retracted
|
||||
(log-syndicate/drivers/http-debug "~v: -processing" connection-name)
|
||||
(finish-request!)]
|
||||
[#:message (HttpResponse-status code message)
|
||||
(log-syndicate/drivers/http-debug "~v: status ~v ~v" connection-name
|
||||
code message)
|
||||
(check-processing!)
|
||||
(set! pending-code code)
|
||||
(set! pending-message message)]
|
||||
[#:message (HttpResponse-header name value)
|
||||
(log-syndicate/drivers/http-debug "~v: header ~v ~v" connection-name
|
||||
name value)
|
||||
(check-processing!)
|
||||
(set! pending-headers-rev (cons (cons name value) pending-headers-rev))]
|
||||
[#:message (HttpResponse-body chunk)
|
||||
(log-syndicate/drivers/http-debug "~v: chunk ~v" connection-name
|
||||
chunk)
|
||||
(check-processing!)
|
||||
(send-headers!)
|
||||
(async-channel-put chunk-ch (chunk->bytes chunk))]))
|
||||
(at handler (assert (HttpContext decoded-req res)))
|
||||
(return (void)))))
|
||||
|
||||
|
@ -283,14 +313,11 @@
|
|||
(lambda () method)
|
||||
(lambda () (quote-path-pattern () (path-pattern-element ...)))
|
||||
(lambda (req res)
|
||||
(at res (assert (HttpResponse-processing)))
|
||||
(match (HttpRequest-path req)
|
||||
[#,(match-quote-path-pattern #'(path-pattern-element ...))
|
||||
(async (match (with-handlers [((lambda (e) #t)
|
||||
(lambda (e)
|
||||
(send-http-response! res 500 "Internal Server Error")
|
||||
(raise e)))]
|
||||
(let () body ...))
|
||||
[(mime (? symbol? type) (? bytes? data))
|
||||
(async (match (let () body ...)
|
||||
[(mime (? symbol? type) (or (? bytes? data) (? string? data)))
|
||||
(log-syndicate/drivers/http-debug "REPLY: ~a ~v" type data)
|
||||
(send-http-response! res 200 "OK" #:mime-type type data)]
|
||||
[(? void?)
|
||||
|
@ -298,7 +325,8 @@
|
|||
[bad
|
||||
(log-syndicate/drivers/http-error "Bad MIME response: ~v" bad)
|
||||
(send-http-response! res 500 "Internal Server Error")]))]
|
||||
[_ (send-http-response! res 400 "Bad request path")]))))])))
|
||||
[_ (send-http-response! res 400 "Bad request path")])
|
||||
(stop-current-facet))))])))
|
||||
|
||||
(define (define-http-route* ds host port method path-pattern handler)
|
||||
(at ds
|
||||
|
@ -362,11 +390,7 @@
|
|||
(for [(header headers)]
|
||||
(match-define (cons name value) header)
|
||||
(send! res (HttpResponse-header name value)))
|
||||
(let loop ((chunks chunks))
|
||||
(cond [(null? chunks) (send! res (HttpResponse-done ""))]
|
||||
[(null? (cdr chunks)) (send! res (HttpResponse-done (car chunks)))]
|
||||
[else (send! res (HttpResponse-chunk (car chunks))) (loop (cdr chunks))]))
|
||||
(void))
|
||||
(for [(chunk chunks)] (send! res (HttpResponse-body chunk))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
|
|
|
@ -14,7 +14,7 @@
|
|||
|
||||
(provide-service [ds]
|
||||
(at ds
|
||||
(during/spawn (Observe (:pattern (RacketEvent ,(DLit $embedded-event) ,_)) _)
|
||||
(during/spawn (Observe (:pattern (RacketEvent ,(Pattern-lit $embedded-event) ,_)) _)
|
||||
#:name (embedded-value embedded-event)
|
||||
(define event (embedded-value embedded-event))
|
||||
(linked-thread
|
||||
|
|
|
@ -23,7 +23,7 @@
|
|||
(with-services [syndicate/drivers/stream]
|
||||
(at ds
|
||||
(during/spawn
|
||||
(Observe (:pattern (StreamConnection ,_ ,_ (TcpLocal ,(DLit $host) ,(DLit $port)))) _)
|
||||
(Observe (:pattern (StreamConnection ,_ ,_ (TcpLocal ,(Pattern-lit $host) ,(Pattern-lit $port)))) _)
|
||||
#:name (TcpLocal host port)
|
||||
(run-listener ds host port))
|
||||
|
||||
|
|
|
@ -88,7 +88,7 @@
|
|||
(log-syndicate/drivers/timer-debug "received instruction ~a" instruction)
|
||||
(channel-put control-ch instruction))
|
||||
|
||||
(during (Observe (:pattern (LaterThan ,(DLit $seconds))) _)
|
||||
(during (Observe (:pattern (LaterThan ,(Pattern-lit $seconds))) _)
|
||||
(log-syndicate/drivers/timer-debug "observing (later-than ~a) at ~a"
|
||||
seconds
|
||||
(/ (current-inexact-milliseconds) 1000.0))
|
||||
|
|
|
@ -13,8 +13,10 @@
|
|||
:pattern
|
||||
:parse
|
||||
|
||||
pattern->shape
|
||||
pattern->constant-values
|
||||
pattern->constant-paths
|
||||
pattern->check-paths
|
||||
pattern->capture-paths
|
||||
|
||||
!dump-registered-preserves-patterns!
|
||||
|
@ -180,14 +182,14 @@
|
|||
|
||||
[id
|
||||
(dollar-id? #'id)
|
||||
(transform-binding (undollar #'id) #`(Pattern-DBind (DBind (Pattern-DDiscard (DDiscard)))))]
|
||||
(transform-binding (undollar #'id) #`(Pattern-bind (Pattern-discard)))]
|
||||
|
||||
[($ id p)
|
||||
(transform-binding #'id #`(Pattern-DBind (DBind #,(walk #'p))))]
|
||||
(transform-binding #'id #`(Pattern-bind #,(walk #'p)))]
|
||||
|
||||
[id
|
||||
(discard-id? #'id)
|
||||
#`(Pattern-DDiscard (DDiscard))]
|
||||
#`(Pattern-discard)]
|
||||
|
||||
[(c l (list-stx piece ...))
|
||||
(and (id=? #'rec #'c)
|
||||
|
@ -379,36 +381,55 @@
|
|||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (select-pattern-leaves desc capture-fn lit-fn)
|
||||
(define (pattern->shape desc)
|
||||
(let walk-node ((key-rev '()) (desc desc))
|
||||
(match desc
|
||||
[(Pattern-DCompound (or (DCompound-rec _ fields)
|
||||
(DCompound-arr fields)))
|
||||
(append* (for/list [(key (in-naturals)) (subdesc (in-list fields))]
|
||||
[(Pattern-group type entries)
|
||||
(append* (list (cons (reverse key-rev) type))
|
||||
(for/list [((key subdesc) (in-hash entries))]
|
||||
(walk-node (cons key key-rev) subdesc)))]
|
||||
[(Pattern-DCompound (DCompound-dict entries))
|
||||
[(Pattern-bind subdesc)
|
||||
(walk-node key-rev subdesc)]
|
||||
[(Pattern-discard)
|
||||
'()]
|
||||
[(Pattern-lit value)
|
||||
'()])))
|
||||
|
||||
(define (select-pattern-leaves desc capture-fn discard-fn lit-fn)
|
||||
(let walk-node ((key-rev '()) (desc desc))
|
||||
(match desc
|
||||
[(Pattern-group _type entries)
|
||||
(append* (for/list [((key subdesc) (in-hash entries))]
|
||||
(walk-node (cons key key-rev) subdesc)))]
|
||||
[(Pattern-DBind (DBind subdesc))
|
||||
[(Pattern-bind subdesc)
|
||||
(append (capture-fn key-rev) (walk-node key-rev subdesc))]
|
||||
[(Pattern-DDiscard (DDiscard))
|
||||
'()]
|
||||
[(Pattern-DLit (DLit value))
|
||||
[(Pattern-discard)
|
||||
(discard-fn key-rev)]
|
||||
[(Pattern-lit value)
|
||||
(lit-fn key-rev (->preserve value))])))
|
||||
|
||||
(define (pattern->constant-values desc)
|
||||
(select-pattern-leaves desc
|
||||
(lambda (key-rev) (list))
|
||||
(lambda (key-rev) (list))
|
||||
(lambda (key-rev value) (list value))))
|
||||
|
||||
(define (pattern->constant-paths desc)
|
||||
(select-pattern-leaves desc
|
||||
(lambda (key-rev) (list))
|
||||
(lambda (key-rev) (list))
|
||||
(lambda (key-rev value) (list (reverse key-rev)))))
|
||||
|
||||
(define (pattern->check-paths desc)
|
||||
(select-pattern-leaves desc
|
||||
(lambda (key-rev) (list))
|
||||
(lambda (key-rev) (list (reverse key-rev)))
|
||||
(lambda (key-rev value) (list))))
|
||||
|
||||
(define (pattern->capture-paths desc)
|
||||
(select-pattern-leaves desc
|
||||
(lambda (key-rev) (list (reverse key-rev)))
|
||||
(lambda (key-rev) (list))
|
||||
(lambda (key-rev value) (list))))
|
||||
|
||||
(define-syntax (!dump-registered-preserves-patterns! stx)
|
||||
|
|
|
@ -4,13 +4,15 @@ ByteString
|
|||
QueryValue´³orµµ±string´³atom³String„„µ±file´³rec´³lit³file„´³tupleµ´³named³filename´³atom³String„„´³named³headers´³refµ„³Headers„„´³named³body´³atom³
|
||||
ByteString„„„„„„„„³HostPattern´³orµµ±host´³atom³String„„µ±any´³lit€„„„„³HttpBinding´³rec´³lit³ http-bind„´³tupleµ´³named³host´³refµ„³HostPattern„„´³named³port´³atom³
SignedInteger„„´³named³method´³refµ„³
MethodPattern„„´³named³path´³refµ„³PathPattern„„´³named³handler´³embedded´³refµ„³HttpRequest„„„„„„³HttpContext´³rec´³lit³request„´³tupleµ´³named³req´³refµ„³HttpRequest„„´³named³res´³embedded´³refµ„³HttpResponse„„„„„„³HttpRequest´³rec´³lit³http-request„´³tupleµ´³named³sequenceNumber´³atom³
SignedInteger„„´³named³host´³atom³String„„´³named³port´³atom³
SignedInteger„„´³named³method´³atom³Symbol„„´³named³path´³seqof´³atom³String„„„´³named³headers´³refµ„³Headers„„´³named³query´³dictof´³atom³Symbol„´³seqof´³refµ„³
|
||||
QueryValue„„„„´³named³body´³refµ„³RequestBody„„„„„³HttpService´³rec´³lit³http-service„´³tupleµ´³named³host´³refµ„³HostPattern„„´³named³port´³atom³
SignedInteger„„´³named³method´³refµ„³
MethodPattern„„´³named³path´³refµ„³PathPattern„„„„„³PathPattern´³seqof´³refµ„³PathPatternElement„„³RequestBody´³orµµ±present´³atom³
|
||||
ByteString„„µ±absent´³lit€„„„„³HttpListener´³rec´³lit³
http-listener„´³tupleµ´³named³port´³atom³
SignedInteger„„„„„³HttpResponse´³orµµ±status´³rec´³lit³status„´³tupleµ´³named³code´³atom³
SignedInteger„„´³named³message´³atom³String„„„„„„µ±header´³rec´³lit³header„´³tupleµ´³named³name´³atom³Symbol„„´³named³value´³atom³String„„„„„„µ±chunk´³rec´³lit³chunk„´³tupleµ´³named³chunk´³refµ„³Chunk„„„„„„µ±done´³rec´³lit³done„´³tupleµ´³named³chunk´³refµ„³Chunk„„„„„„„„³
MethodPattern´³orµµ±any´³lit€„„µ±specific´³atom³Symbol„„„„³PathPatternElement´³orµµ±label´³atom³String„„µ±wildcard´³lit³_„„µ±rest´³lit³...„„„„„³embeddedType€„„µ³noise„´³schema·³version°³definitions·³Packet´³orµµ±complete´³atom³
|
||||
ByteString„„µ±absent´³lit€„„„„³HttpListener´³rec´³lit³
http-listener„´³tupleµ´³named³port´³atom³
SignedInteger„„„„„³HttpResponse´³orµµ±
|
||||
processing´³rec´³lit³
|
||||
processing„´³tupleµ„„„„µ±status´³rec´³lit³status„´³tupleµ´³named³code´³atom³
SignedInteger„„´³named³message´³atom³String„„„„„„µ±header´³rec´³lit³header„´³tupleµ´³named³name´³atom³Symbol„„´³named³value´³atom³String„„„„„„µ±body´³rec´³lit³body„´³tupleµ´³named³chunk´³refµ„³Chunk„„„„„„„„³
MethodPattern´³orµµ±any´³lit€„„µ±specific´³atom³Symbol„„„„³PathPatternElement´³orµµ±label´³atom³String„„µ±wildcard´³lit³_„„µ±rest´³lit³...„„„„„³embeddedType€„„µ³noise„´³schema·³version°³definitions·³Packet´³orµµ±complete´³atom³
|
||||
ByteString„„µ±
|
||||
fragmented´³seqof´³atom³
|
||||
ByteString„„„„„³ NoiseSpec´³andµ´³dict·³key´³named³key´³atom³
|
||||
ByteString„„³service´³named³service´³refµ„³ServiceSelector„„„„´³named³protocol´³refµ„³
NoiseProtocol„„´³named³
preSharedKeys´³refµ„³NoisePreSharedKeys„„„„³
NoiseProtocol´³orµµ±present´³dict·³protocol´³named³protocol´³atom³String„„„„„µ±invalid´³dict·³protocol´³named³protocol³any„„„„µ±absent´³dict·„„„„„³
NoiseStepType´³lit³noise„³SecretKeyField´³orµµ±present´³dict·³ secretKey´³named³ secretKey´³atom³
|
||||
ByteString„„„„„³ Initiator´³rec´³lit³ initiator„´³tupleµ´³named³initiatorSession´³embedded´³refµ„³Packet„„„„„„³ NoiseSpec´³andµ´³dict·³key´³named³key´³atom³
|
||||
ByteString„„³service´³named³service´³refµ„³ServiceSelector„„„„´³named³protocol´³refµ„³
NoiseProtocol„„´³named³
preSharedKeys´³refµ„³NoisePreSharedKeys„„„„³SessionItem´³orµµ± Initiator´³refµ„³ Initiator„„µ±Packet´³refµ„³Packet„„„„³
NoiseProtocol´³orµµ±present´³dict·³protocol´³named³protocol´³atom³String„„„„„µ±invalid´³dict·³protocol´³named³protocol³any„„„„µ±absent´³dict·„„„„„³
NoiseStepType´³lit³noise„³SecretKeyField´³orµµ±present´³dict·³ secretKey´³named³ secretKey´³atom³
|
||||
ByteString„„„„„µ±invalid´³dict·³ secretKey´³named³ secretKey³any„„„„µ±absent´³dict·„„„„„³DefaultProtocol´³lit±!Noise_NK_25519_ChaChaPoly_BLAKE2s„³NoiseStepDetail´³refµ„³ServiceSelector„³ServiceSelector³any³NoiseServiceSpec´³andµ´³named³base´³refµ„³ NoiseSpec„„´³named³ secretKey´³refµ„³SecretKeyField„„„„³NoisePreSharedKeys´³orµµ±present´³dict·³
preSharedKeys´³named³
preSharedKeys´³seqof´³atom³
|
||||
ByteString„„„„„„µ±invalid´³dict·³
preSharedKeys´³named³
preSharedKeys³any„„„„µ±absent´³dict·„„„„„³NoisePathStepDetail´³refµ„³ NoiseSpec„³NoiseDescriptionDetail´³refµ„³NoiseServiceSpec„„³embeddedType€„„µ³timer„´³schema·³version°³definitions·³SetTimer´³rec´³lit³ set-timer„´³tupleµ´³named³label³any„´³named³seconds´³atom³Double„„´³named³kind´³refµ„³ TimerKind„„„„„³ LaterThan´³rec´³lit³
|
||||
ByteString„„„„„„µ±invalid´³dict·³
preSharedKeys´³named³
preSharedKeys³any„„„„µ±absent´³dict·„„„„„³NoisePathStepDetail´³refµ„³ NoiseSpec„³NoiseDescriptionDetail´³refµ„³NoiseServiceSpec„„³embeddedType´³refµ³ EntityRef„³Cap„„„µ³timer„´³schema·³version°³definitions·³SetTimer´³rec´³lit³ set-timer„´³tupleµ´³named³label³any„´³named³seconds´³atom³Double„„´³named³kind´³refµ„³ TimerKind„„„„„³ LaterThan´³rec´³lit³
|
||||
later-than„´³tupleµ´³named³seconds´³atom³Double„„„„„³ TimerKind´³orµµ±relative´³lit³relative„„µ±absolute´³lit³absolute„„µ±clear´³lit³clear„„„„³TimerExpired´³rec´³lit³
timer-expired„´³tupleµ´³named³label³any„´³named³seconds´³atom³Double„„„„„„³embeddedType€„„µ³trace„´³schema·³version°³definitions·³Oid³any³Name´³orµµ± anonymous´³rec´³lit³ anonymous„´³tupleµ„„„„µ±named´³rec´³lit³named„´³tupleµ´³named³name³any„„„„„„„³Target´³rec´³lit³entity„´³tupleµ´³named³actor´³refµ„³ActorId„„´³named³facet´³refµ„³FacetId„„´³named³oid´³refµ„³Oid„„„„„³TaskId³any³TurnId³any³ActorId³any³FacetId³any³ TurnCause´³orµµ±turn´³rec´³lit³ caused-by„´³tupleµ´³named³id´³refµ„³TurnId„„„„„„µ±cleanup´³rec´³lit³cleanup„´³tupleµ„„„„µ±linkedTaskRelease´³rec´³lit³linked-task-release„´³tupleµ´³named³id´³refµ„³TaskId„„´³named³reason´³refµ„³LinkedTaskReleaseReason„„„„„„µ±periodicActivation´³rec´³lit³periodic-activation„´³tupleµ´³named³period´³atom³Double„„„„„„µ±delay´³rec´³lit³delay„´³tupleµ´³named³causingTurn´³refµ„³TurnId„„´³named³amount´³atom³Double„„„„„„µ±external´³rec´³lit³external„´³tupleµ´³named³description³any„„„„„„„³ TurnEvent´³orµµ±assert´³rec´³lit³assert„´³tupleµ´³named³ assertion´³refµ„³AssertionDescription„„´³named³handle´³refµ³protocol„³Handle„„„„„„µ±retract´³rec´³lit³retract„´³tupleµ´³named³handle´³refµ³protocol„³Handle„„„„„„µ±message´³rec´³lit³message„´³tupleµ´³named³body´³refµ„³AssertionDescription„„„„„„µ±sync´³rec´³lit³sync„´³tupleµ´³named³peer´³refµ„³Target„„„„„„µ± breakLink´³rec´³lit³
|
||||
break-link„´³tupleµ´³named³source´³refµ„³ActorId„„´³named³handle´³refµ³protocol„³Handle„„„„„„„„³
|
||||
ExitStatus´³orµµ±ok´³lit³ok„„µ±Error´³refµ³protocol„³Error„„„„³
|
||||
|
@ -40,5 +42,5 @@ ByteString
|
|||
RunService´³rec´³lit³run-service„´³tupleµ´³named³serviceName³any„„„„³ServiceState´³rec´³lit³
service-state„´³tupleµ´³named³serviceName³any„´³named³state´³refµ„³State„„„„„³
ServiceObject´³rec´³lit³service-object„´³tupleµ´³named³serviceName³any„´³named³object³any„„„„³RequireService´³rec´³lit³require-service„´³tupleµ´³named³serviceName³any„„„„³RestartService´³rec´³lit³restart-service„´³tupleµ´³named³serviceName³any„„„„³ServiceDependency´³rec´³lit³
|
||||
depends-on„´³tupleµ´³named³depender³any„´³named³dependee´³refµ„³ServiceState„„„„„„³embeddedType´³refµ³ EntityRef„³Cap„„„µ³protocol„´³schema·³version°³definitions·³Oid´³atom³
SignedInteger„³Sync´³rec´³lit³S„´³tupleµ´³named³peer´³embedded´³lit<69>„„„„„„³Turn´³seqof´³refµ„³ TurnEvent„„³Error´³rec´³lit³error„´³tupleµ´³named³message´³atom³String„„´³named³detail³any„„„„³Event´³orµµ±Assert´³refµ„³Assert„„µ±Retract´³refµ„³Retract„„µ±Message´³refµ„³Message„„µ±Sync´³refµ„³Sync„„„„³Assert´³rec´³lit³A„´³tupleµ´³named³ assertion´³refµ„³ Assertion„„´³named³handle´³refµ„³Handle„„„„„³Handle´³atom³
SignedInteger„³Packet´³orµµ±Turn´³refµ„³Turn„„µ±Error´³refµ„³Error„„µ± Extension´³refµ„³ Extension„„„„³Message´³rec´³lit³M„´³tupleµ´³named³body´³refµ„³ Assertion„„„„„³Retract´³rec´³lit³R„´³tupleµ´³named³handle´³refµ„³Handle„„„„„³ Assertion³any³ Extension´³rec´³named³label³any„´³named³fields´³seqof³any„„„³ TurnEvent´³tupleµ´³named³oid´³refµ„³Oid„„´³named³event´³refµ„³Event„„„„„³embeddedType€„„µ³ dataspace„´³schema·³version°³definitions·³Observe´³rec´³lit³Observe„´³tupleµ´³named³pattern´³refµ³dataspacePatterns„³Pattern„„´³named³observer´³embedded³any„„„„„„³embeddedType´³refµ³ EntityRef„³Cap„„„µ³
|
||||
gatekeeper„´³schema·³version°³definitions·³Bind´³rec´³lit³bind„´³tupleµ´³named³description´³refµ„³Description„„´³named³target´³embedded³any„„´³named³observer´³refµ„³BindObserver„„„„„³Step´³rec´³named³stepType´³atom³Symbol„„´³tupleµ´³named³detail³any„„„„³Bound´³orµµ±bound´³rec´³lit³bound„´³tupleµ´³named³pathStep´³refµ„³PathStep„„„„„„µ±Rejected´³refµ„³Rejected„„„„³Route´³rec´³lit³route„´³tuplePrefixµ´³named³
|
||||
transports´³seqof³any„„„´³named³ pathSteps´³seqof´³refµ„³PathStep„„„„„³Resolve´³rec´³lit³resolve„´³tupleµ´³named³step´³refµ„³Step„„´³named³observer´³embedded´³refµ„³Resolved„„„„„„³PathStep´³rec´³named³stepType´³atom³Symbol„„´³tupleµ´³named³detail³any„„„„³Rejected´³rec´³lit³rejected„´³tupleµ´³named³detail³any„„„„³Resolved´³orµµ±accepted´³rec´³lit³accepted„´³tupleµ´³named³responderSession´³embedded³any„„„„„„µ±Rejected´³refµ„³Rejected„„„„³Description´³rec´³named³stepType´³atom³Symbol„„´³tupleµ´³named³detail³any„„„„³ResolvePath´³rec´³lit³resolve-path„´³tupleµ´³named³route´³refµ„³Route„„´³named³addr³any„´³named³control´³embedded´³refµ„³TransportControl„„„´³named³resolved´³refµ„³Resolved„„„„„³BindObserver´³orµµ±present´³embedded´³refµ„³Bound„„„µ±absent´³lit€„„„„³ForceDisconnect´³rec´³lit³force-disconnect„´³tupleµ„„„³ResolvedPathStep´³rec´³lit³ path-step„´³tupleµ´³named³origin´³embedded´³refµ„³Resolve„„„´³named³pathStep´³refµ„³PathStep„„´³named³resolved´³refµ„³Resolved„„„„„³TransportControl´³refµ„³ForceDisconnect„³TransportConnection´³rec´³lit³connect-transport„´³tupleµ´³named³addr³any„´³named³control´³embedded´³refµ„³TransportControl„„„´³named³resolved´³refµ„³Resolved„„„„„„³embeddedType´³refµ³ EntityRef„³Cap„„„µ³transportAddress„´³schema·³version°³definitions·³Tcp´³rec´³lit³tcp„´³tupleµ´³named³host´³atom³String„„´³named³port´³atom³
SignedInteger„„„„„³Unix´³rec´³lit³unix„´³tupleµ´³named³path´³atom³String„„„„„³Stdio´³rec´³lit³stdio„´³tupleµ„„„³ WebSocket´³rec´³lit³ws„´³tupleµ´³named³url´³atom³String„„„„„„³embeddedType€„„µ³dataspacePatterns„´³schema·³version°³definitions·³DLit´³rec´³lit³lit„´³tupleµ´³named³value´³refµ„³AnyAtom„„„„„³DBind´³rec´³lit³bind„´³tupleµ´³named³pattern´³refµ„³Pattern„„„„„³AnyAtom´³orµµ±bool´³atom³Boolean„„µ±double´³atom³Double„„µ±int´³atom³
SignedInteger„„µ±string´³atom³String„„µ±bytes´³atom³
|
||||
ByteString„„µ±symbol´³atom³Symbol„„µ±embedded´³embedded³any„„„„³Pattern´³orµµ±DDiscard´³refµ„³DDiscard„„µ±DBind´³refµ„³DBind„„µ±DLit´³refµ„³DLit„„µ± DCompound´³refµ„³ DCompound„„„„³DDiscard´³rec´³lit³_„´³tupleµ„„„³ DCompound´³orµµ±rec´³rec´³lit³rec„´³tupleµ´³named³label³any„´³named³fields´³seqof´³refµ„³Pattern„„„„„„„µ±arr´³rec´³lit³arr„´³tupleµ´³named³items´³seqof´³refµ„³Pattern„„„„„„„µ±dict´³rec´³lit³dict„´³tupleµ´³named³entries´³dictof³any´³refµ„³Pattern„„„„„„„„„„³embeddedType´³refµ³ EntityRef„³Cap„„„„„
|
||||
transports´³seqof³any„„„´³named³ pathSteps´³seqof´³refµ„³PathStep„„„„„³Resolve´³rec´³lit³resolve„´³tupleµ´³named³step´³refµ„³Step„„´³named³observer´³embedded´³refµ„³Resolved„„„„„„³PathStep´³rec´³named³stepType´³atom³Symbol„„´³tupleµ´³named³detail³any„„„„³Rejected´³rec´³lit³rejected„´³tupleµ´³named³detail³any„„„„³Resolved´³orµµ±accepted´³rec´³lit³accepted„´³tupleµ´³named³responderSession´³embedded³any„„„„„„µ±Rejected´³refµ„³Rejected„„„„³Description´³rec´³named³stepType´³atom³Symbol„„´³tupleµ´³named³detail³any„„„„³ResolvePath´³rec´³lit³resolve-path„´³tupleµ´³named³route´³refµ„³Route„„´³named³addr³any„´³named³control´³embedded´³refµ„³TransportControl„„„´³named³resolved´³refµ„³Resolved„„„„„³BindObserver´³orµµ±present´³embedded´³refµ„³Bound„„„µ±absent´³lit€„„„„³ForceDisconnect´³rec´³lit³force-disconnect„´³tupleµ„„„³ResolvedPathStep´³rec´³lit³ path-step„´³tupleµ´³named³origin´³embedded´³refµ„³Resolve„„„´³named³pathStep´³refµ„³PathStep„„´³named³resolved´³refµ„³Resolved„„„„„³TransportControl´³refµ„³ForceDisconnect„³TransportConnection´³rec´³lit³connect-transport„´³tupleµ´³named³addr³any„´³named³control´³embedded´³refµ„³TransportControl„„„´³named³resolved´³refµ„³Resolved„„„„„„³embeddedType´³refµ³ EntityRef„³Cap„„„µ³transportAddress„´³schema·³version°³definitions·³Tcp´³rec´³lit³tcp„´³tupleµ´³named³host´³atom³String„„´³named³port´³atom³
SignedInteger„„„„„³Unix´³rec´³lit³unix„´³tupleµ´³named³path´³atom³String„„„„„³Stdio´³rec´³lit³stdio„´³tupleµ„„„³ WebSocket´³rec´³lit³ws„´³tupleµ´³named³url´³atom³String„„„„„„³embeddedType€„„µ³dataspacePatterns„´³schema·³version°³definitions·³AnyAtom´³orµµ±bool´³atom³Boolean„„µ±double´³atom³Double„„µ±int´³atom³
SignedInteger„„µ±string´³atom³String„„µ±bytes´³atom³
|
||||
ByteString„„µ±symbol´³atom³Symbol„„µ±embedded´³embedded³any„„„„³Pattern´³orµµ±discard´³rec´³lit³_„´³tupleµ„„„„µ±bind´³rec´³lit³bind„´³tupleµ´³named³pattern´³refµ„³Pattern„„„„„„µ±lit´³rec´³lit³lit„´³tupleµ´³named³value´³refµ„³AnyAtom„„„„„„µ±group´³rec´³lit³group„´³tupleµ´³named³type´³refµ„³ GroupType„„´³named³entries´³dictof³any´³refµ„³Pattern„„„„„„„„„³ GroupType´³orµµ±rec´³rec´³lit³rec„´³tupleµ´³named³label³any„„„„„µ±arr´³rec´³lit³arr„´³tupleµ„„„„µ±dict´³rec´³lit³dict„´³tupleµ„„„„„„„³embeddedType´³refµ³ EntityRef„³Cap„„„„„
|
|
@ -1,15 +1,23 @@
|
|||
version 1 .
|
||||
embeddedType EntityRef.Cap .
|
||||
|
||||
# Dataspace patterns: a sublanguage of attenuation patterns.
|
||||
Pattern = DDiscard / DBind / DLit / DCompound .
|
||||
# Dataspace patterns: *almost* a sublanguage of attenuation patterns.
|
||||
#
|
||||
# One key difference is that Dataspace patterns are extensible, in that
|
||||
# they ignore fields not mentioned in group patterns.
|
||||
|
||||
DDiscard = <_>.
|
||||
DBind = <bind @pattern Pattern>.
|
||||
DLit = <lit @value AnyAtom>.
|
||||
DCompound = <rec @label any @fields [Pattern ...]>
|
||||
/ <arr @items [Pattern ...]>
|
||||
/ <dict @entries { any: Pattern ...:... }> .
|
||||
Pattern =
|
||||
/ @discard <_>
|
||||
/ <bind @pattern Pattern>
|
||||
/ <lit @value AnyAtom>
|
||||
/ <group @type GroupType @entries { any: Pattern ...:... }>
|
||||
.
|
||||
|
||||
GroupType =
|
||||
/ <rec @label any>
|
||||
/ <arr>
|
||||
/ <dict>
|
||||
.
|
||||
|
||||
AnyAtom =
|
||||
/ @bool bool
|
||||
|
|
|
@ -13,8 +13,37 @@ Step = <<rec> @stepType symbol [@detail any]> .
|
|||
# ---------------------------------------------------------------------------
|
||||
# Protocol at dataspaces *associated* with gatekeeper entities
|
||||
|
||||
# Assertion. Gatekeeper will compute an appropriate PathStep from `description` pointing at
|
||||
# `target`, and will respond with a `Bound` to `observer` (if supplied).
|
||||
# ## Handling `Resolve` requests
|
||||
#
|
||||
# When the gatekeeper entity receives a `Resolve` assertion (call it R1), it
|
||||
#
|
||||
# 1. asserts a `Resolve` (call it R2) into its associated dataspace that
|
||||
# is the same as R1 except it has a different `observer`; and
|
||||
#
|
||||
# 2. observes a `Bind` with `description` matching the `step` of R1/R2
|
||||
# according to `stepType` (e.g. treatment of SturdyStepType is not the
|
||||
# same as treatment of NoiseStepType).
|
||||
#
|
||||
# Normally, an appropriate `Bind` is expected to exist. If the gatekeeper
|
||||
# sees the `Bind` first, it takes the `target` from it and does whatever
|
||||
# `stepType` mandates before replying to R1's observer.
|
||||
#
|
||||
# However, if a `Resolved` is asserted to R2's observer before a `Bind`
|
||||
# appears, that resolution is relayed on to R1's observer directly, be it
|
||||
# positive or negative, and the gatekeeper stops waiting for a `Bind`.
|
||||
#
|
||||
# This way, entities can keep an eye out for `Resolve` requests that will
|
||||
# never complete, and answer `Rejected` to them even when no matching
|
||||
# `Bind` exists. Entities could also use `Resolve` requests to synthesize a
|
||||
# `Bind` in a "just-in-time" fashion.
|
||||
#
|
||||
# ## General treatment of `Bind` assertions
|
||||
#
|
||||
# When the gatekeeper sees a `Bind`, independently of any potential
|
||||
# `Resolve` requests, it computes an appropriate PathStep from
|
||||
# `description` pointing at `target`, and responds with a `Bound` to
|
||||
# `observer` (if supplied).
|
||||
#
|
||||
Bind = <bind @description Description @target #:any @observer BindObserver> .
|
||||
Description = <<rec> @stepType symbol [@detail any]> .
|
||||
BindObserver = @present #:Bound / @absent #f .
|
||||
|
|
|
@ -39,10 +39,13 @@ HttpContext = <request @req HttpRequest @res #:HttpResponse> .
|
|||
@<TODO "trailers?">
|
||||
# Messages
|
||||
HttpResponse =
|
||||
# Assertion - frames the response. When retracted, response is considered complete.
|
||||
# If retracted before `status` is delivered, response is considered a 500.
|
||||
/ <processing>
|
||||
# Remainder are messages: +processing . (status | header)* . body* . -processing
|
||||
/ <status @code int @message string>
|
||||
/ <header @name symbol @value string>
|
||||
/ <chunk @chunk Chunk>
|
||||
/ <done @chunk Chunk>
|
||||
/ <body @chunk Chunk>
|
||||
.
|
||||
|
||||
Chunk = @string string / @bytes bytes .
|
||||
|
|
|
@ -1,4 +1,5 @@
|
|||
version 1 .
|
||||
embeddedType EntityRef.Cap .
|
||||
|
||||
# https://noiseprotocol.org/
|
||||
|
||||
|
@ -42,13 +43,30 @@ DefaultProtocol = "Noise_NK_25519_ChaChaPoly_BLAKE2s" .
|
|||
# sequence is exhausted or not supplied, an all-zeros key is used each time a PSK is needed.
|
||||
NoisePreSharedKeys = @present { preSharedKeys: [bytes ...] } / @invalid { preSharedKeys: any } / @absent {} .
|
||||
|
||||
# Sessions proceed by sending Packets to the initiatorSession and responderSession according to
|
||||
# the Noise protocol definition. Each Packet represents a complete logical unit of
|
||||
# ---------------------------------------------------------------------------
|
||||
# Handshaking and running a session
|
||||
|
||||
# 1. initiator asserts <resolve <noise ServiceSelector> #:A> at Gatekeeper
|
||||
# 2. gatekeeper asserts <accepted #:B> at #:A
|
||||
# 3. initiator asserts <initiator #:C> at #:B and then sends `Packet`s to #:B
|
||||
# 4. responder sends `Packet`s to #:C
|
||||
#
|
||||
# Sessions begin with introduction of initiator (#:C) and responder (#:B) to each other, and
|
||||
# then proceed by sending `Packet`s (from #:C) to #:B and (from #:B) to #:C according to
|
||||
# the Noise protocol definition. Each `Packet` represents a complete logical unit of
|
||||
# communication; for example, a complete Turn when layering the Syndicate protocol over Noise.
|
||||
# Note well the restriction on Noise messages: no individual complete packet or packet fragment
|
||||
# may exceed 65535 bytes (N.B. not 65536!). When `fragmented`, each portion of a Packet is a
|
||||
# may exceed 65535 bytes (N.B. not 65536!). When `fragmented`, each portion of a `Packet` is a
|
||||
# complete Noise "transport message"; when `complete`, the whole thing is likewise a complete
|
||||
# "transport message".
|
||||
#
|
||||
# Retraction of the `Initiator` ends the session from the initiator-side; retraction of the
|
||||
# `<accepted ...>` assertion ends the session from the responder-side.
|
||||
|
||||
SessionItem = Initiator / Packet .
|
||||
# Assertion
|
||||
Initiator = <initiator @initiatorSession #:Packet> .
|
||||
# Message
|
||||
Packet = @complete bytes / @fragmented [bytes ...] .
|
||||
|
||||
# When layering Syndicate protocol over noise,
|
||||
|
|
|
@ -62,7 +62,7 @@
|
|||
[(SimplePattern-Ref (Ref (ModulePath module-path) name)) `values]))
|
||||
|
||||
(define (def-pattern name def)
|
||||
(define discard `(,(N 'Pattern-DDiscard) (,(N 'DDiscard))))
|
||||
(define discard `(,(N 'Pattern-discard)))
|
||||
|
||||
(define (pat-pattern p)
|
||||
(match (unwrap p)
|
||||
|
@ -73,8 +73,8 @@
|
|||
[(SimplePattern-embedded _interface) discard]
|
||||
[(SimplePattern-lit value)
|
||||
(if (eq? value '...)
|
||||
`(,(N 'Pattern-DLit) (,(N 'DLit) (quote (... ...))))
|
||||
`(,(N 'Pattern-DLit) (,(N 'DLit) ',value)))]
|
||||
`(,(N 'Pattern-lit) (quote (... ...)))
|
||||
`(,(N 'Pattern-lit) ',value))]
|
||||
[(SimplePattern-seqof pat) discard]
|
||||
[(SimplePattern-setof pat) discard]
|
||||
[(SimplePattern-dictof key-pat value-pat) discard]
|
||||
|
|
|
@ -31,16 +31,16 @@
|
|||
;; specification of (the outline of) its shape; its silhouette.
|
||||
;; Following a skeleton's structure leads to zero or more `SkCont`s.
|
||||
;;
|
||||
;; Skeleton = (skeleton-node SkCont (AListof SkSelector (MutableHash ConstructorSpec Skeleton)))
|
||||
;; SkSelector = (skeleton-selector Nat Any)
|
||||
;; Skeleton = (skeleton-node SkCont (AListof SkMove (MutableHash ConstructorSpec Skeleton)))
|
||||
;; SkMove = (skeleton-move Nat (Listof Any))
|
||||
;;
|
||||
;; A `ConstructorSpec` specifies a record label with arity, or a list
|
||||
;; arity, or a dictionary.
|
||||
;; A `ConstructorSpec` specifies a record and its label, or a sequence,
|
||||
;; or a dictionary.
|
||||
;;
|
||||
;; ConstructorSpec = (U (cons any nat) nat 'dict)
|
||||
;; ConstructorSpec = (U (GroupType-rec any) (GroupType-arr) (GroupType-dict))
|
||||
;;
|
||||
(struct skeleton-node (continuation [edges #:mutable]) #:transparent)
|
||||
(struct skeleton-selector (pop-count key) #:transparent)
|
||||
(struct skeleton-move (pop-count path) #:transparent)
|
||||
;;
|
||||
;; A `Pattern` is a pattern over assertions, following the schema of
|
||||
;; the same name in schemas/dataspacePatterns.prs. Instances of
|
||||
|
@ -57,7 +57,8 @@
|
|||
;;
|
||||
;; SkCont = (skeleton-continuation
|
||||
;; (MutableHash Assertion #t)
|
||||
;; (MutableHash SkProj (MutableHash SkKey SkConst)))
|
||||
;; (MutableHash (constant-positions SkProj SkProj)
|
||||
;; (MutableHash SkKey SkConst)))
|
||||
;; SkConst = (skeleton-matched-constant
|
||||
;; (MutableHash Assertion #t)
|
||||
;; (MutableHash SkProj SkAcc))
|
||||
|
@ -66,6 +67,7 @@
|
|||
;; (MutableHasheq EntityRef (MutableHash SkKey Handle)))
|
||||
;;
|
||||
(struct skeleton-continuation (cache table) #:transparent)
|
||||
(struct constant-positions (with-values required-to-exist) #:transparent)
|
||||
(struct skeleton-matched-constant (cache table) #:transparent)
|
||||
(struct skeleton-accumulator (cache peers) #:transparent)
|
||||
;;
|
||||
|
@ -106,15 +108,19 @@
|
|||
|
||||
(define (skcont-add! turn c pat ref)
|
||||
(define cs (pattern->constant-paths pat))
|
||||
(define ce (pattern->check-paths pat))
|
||||
(define (classify-assertions)
|
||||
(define cvt (make-hash))
|
||||
(hash-for-each (skeleton-continuation-cache c)
|
||||
(lambda (a _)
|
||||
(define avs (apply-projection a cs))
|
||||
(define sc (hash-ref! cvt avs make-empty-matched-constant))
|
||||
(hash-set! (skeleton-matched-constant-cache sc) a #t)))
|
||||
(unless (void? (apply-projection a ce))
|
||||
(define avs (apply-projection a cs))
|
||||
(unless (void? avs)
|
||||
(define sc (hash-ref! cvt avs make-empty-matched-constant))
|
||||
(hash-set! (skeleton-matched-constant-cache sc) a #t)))))
|
||||
cvt)
|
||||
(define cvt (hash-ref! (skeleton-continuation-table c) cs classify-assertions))
|
||||
(define cvt
|
||||
(hash-ref! (skeleton-continuation-table c) (constant-positions cs ce) classify-assertions))
|
||||
(define sc (hash-ref! cvt (pattern->constant-values pat) make-empty-matched-constant))
|
||||
(define vs (pattern->capture-paths pat))
|
||||
(define (make-accumulator)
|
||||
|
@ -133,8 +139,9 @@
|
|||
(and (hash-empty? cache) (hash-empty? table)))
|
||||
|
||||
(define (skcont-remove! turn c pat ref)
|
||||
(define cs (pattern->constant-paths pat))
|
||||
(define cvt (hash-ref (skeleton-continuation-table c) cs #f))
|
||||
(define ck (constant-positions (pattern->constant-paths pat)
|
||||
(pattern->check-paths pat)))
|
||||
(define cvt (hash-ref (skeleton-continuation-table c) ck #f))
|
||||
(when cvt
|
||||
(define cv (pattern->constant-values pat))
|
||||
(define sc (hash-ref cvt cv #f))
|
||||
|
@ -150,65 +157,60 @@
|
|||
(when (skeleton-matched-constant-empty? sc)
|
||||
(hash-remove! cvt cv)))
|
||||
(when (hash-empty? cvt)
|
||||
(hash-remove! (skeleton-continuation-table c) cs))))
|
||||
(hash-remove! (skeleton-continuation-table c) ck))))
|
||||
|
||||
(define (⊖ h1 h0)
|
||||
(define-values (h1tail h0tail) (drop-common-prefix h1 h0))
|
||||
(skeleton-move (length h0tail) h1tail))
|
||||
|
||||
(define (⊕ h0 move)
|
||||
(match-define (skeleton-move n h) move)
|
||||
(append (drop-right h0 n) h))
|
||||
|
||||
(define (shape->visit s)
|
||||
(let walk ((path '()) (s s))
|
||||
(match s
|
||||
['() '()]
|
||||
[(cons (cons h ctor-spec) more)
|
||||
(cons (cons (⊖ h path) ctor-spec) (walk h more))])))
|
||||
|
||||
(define (term-matches-ctor-spec? term ctor-spec)
|
||||
(match ctor-spec
|
||||
[(cons 'rec label)
|
||||
[(GroupType-rec label)
|
||||
(and (non-object-struct? term)
|
||||
(equal? (struct-type-name (struct->struct-type term)) label))]
|
||||
['arr
|
||||
[(GroupType-arr)
|
||||
(list? term)]
|
||||
['dict
|
||||
[(GroupType-dict)
|
||||
(hash? term)]))
|
||||
|
||||
(define (subterm-matches-ctor-spec? term path ctor-spec)
|
||||
(term-matches-ctor-spec? (apply-projection-path term path) ctor-spec))
|
||||
|
||||
(define (skeleton-node-edge-table! sk move)
|
||||
(match (assoc move (skeleton-node-edges sk))
|
||||
[#f (let ((table (make-hash)))
|
||||
(set-skeleton-node-edges! sk (cons (cons move table) (skeleton-node-edges sk)))
|
||||
table)]
|
||||
[(cons _move table) table]))
|
||||
|
||||
(define (extend-skeleton! sk pat)
|
||||
(define (walk-node! rev-path sk pop-count key pat)
|
||||
(match pat
|
||||
[(Pattern-DCompound compound-pat)
|
||||
(define selector (skeleton-selector pop-count key))
|
||||
(define table
|
||||
(match (assoc selector (skeleton-node-edges sk))
|
||||
[#f (let ((table (make-hash)))
|
||||
(set-skeleton-node-edges! sk (cons (cons selector table) (skeleton-node-edges sk)))
|
||||
table)]
|
||||
[(cons _selector table) table]))
|
||||
(define ctor-spec
|
||||
(match compound-pat
|
||||
[(DCompound-rec label field-pats) (cons 'rec label)]
|
||||
[(DCompound-arr item-pats) 'arr]
|
||||
[(DCompound-dict _entries) 'dict]))
|
||||
(let visit ((h '()) (sk sk) (moves (shape->visit (pattern->shape pat))))
|
||||
(match moves
|
||||
['() sk]
|
||||
[(cons (cons move ctor-spec) moves)
|
||||
(define table (skeleton-node-edge-table! sk move))
|
||||
(define path (⊕ h move))
|
||||
(define (make-skeleton-node-with-cache)
|
||||
(define unfiltered (skeleton-continuation-cache (skeleton-node-continuation sk)))
|
||||
(define filtered (make-hash))
|
||||
(define path (reverse rev-path))
|
||||
(hash-for-each unfiltered
|
||||
(lambda (a _)
|
||||
(when (subterm-matches-ctor-spec? a path ctor-spec)
|
||||
(hash-set! filtered a #t))))
|
||||
(make-empty-skeleton/cache filtered))
|
||||
(define next (hash-ref! table ctor-spec make-skeleton-node-with-cache))
|
||||
(let-values (((pop-count sk)
|
||||
(match compound-pat
|
||||
[(or (DCompound-rec _ pats)
|
||||
(DCompound-arr pats))
|
||||
(for/fold [(pop-count 0) (sk next)]
|
||||
[(key (in-naturals)) (subpat (in-list pats))]
|
||||
(walk-node! (cons key rev-path) sk pop-count key subpat))]
|
||||
[(DCompound-dict members)
|
||||
(for/fold [(pop-count 0) (sk next)]
|
||||
[((key subpat) (in-hash members))]
|
||||
(walk-node! (cons key rev-path) sk pop-count key subpat))])))
|
||||
(values (+ pop-count 1) sk))]
|
||||
[(Pattern-DBind (DBind pat))
|
||||
(walk-node! rev-path sk pop-count key pat)]
|
||||
[_
|
||||
(values pop-count sk)]))
|
||||
(let-values (((_pop-count sk) (walk-node! '() sk 0 0 pat)))
|
||||
sk))
|
||||
(visit path next moves)])))
|
||||
|
||||
(define (add-interest! turn sk pat ref)
|
||||
(skcont-add! turn (skeleton-node-continuation (extend-skeleton! sk pat)) pat ref))
|
||||
|
@ -217,45 +219,45 @@
|
|||
(skcont-remove! turn (skeleton-node-continuation (extend-skeleton! sk pat)) pat ref))
|
||||
|
||||
(define (skeleton-modify! turn sk term0 modify-skcont! on-missing-skconst modify-skconst! modify-skacc!)
|
||||
(let walk-node! ((sk sk) (term-stack (list (list term0))))
|
||||
(let walk-node! ((sk sk) (term-stack (list term0)))
|
||||
(match-define (skeleton-node continuation edges) sk)
|
||||
(modify-skcont! continuation term0)
|
||||
|
||||
(let ((sct (skeleton-continuation-table continuation))
|
||||
(constant-projections-to-remove '()))
|
||||
(hash-for-each sct
|
||||
(lambda (constant-proj key-proj-handler)
|
||||
(define constants (apply-projection term0 constant-proj))
|
||||
(define proj-handler
|
||||
(hash-ref key-proj-handler
|
||||
constants
|
||||
(lambda () (on-missing-skconst key-proj-handler constants))))
|
||||
(when proj-handler
|
||||
(when (eq? (modify-skconst! proj-handler term0) 'remove-check)
|
||||
(when (skeleton-matched-constant-empty? proj-handler)
|
||||
(hash-remove! key-proj-handler constants)
|
||||
(when (hash-empty? key-proj-handler)
|
||||
(set! constant-projections-to-remove
|
||||
(cons constant-proj constant-projections-to-remove)))))
|
||||
(hash-for-each (skeleton-matched-constant-table proj-handler)
|
||||
(lambda (variable-proj acc)
|
||||
(define vars (apply-projection term0 variable-proj))
|
||||
(modify-skacc! turn acc vars term0))))))
|
||||
(for-each (lambda (constant-proj) (hash-remove! sct constant-proj))
|
||||
constant-projections-to-remove))
|
||||
(constant-keys-to-remove '()))
|
||||
(for [((constant-key key-proj-handler) (in-hash sct))]
|
||||
(unless (void? (apply-projection term0 (constant-positions-required-to-exist constant-key)))
|
||||
(define constants (apply-projection term0 (constant-positions-with-values constant-key)))
|
||||
(unless (void? constants)
|
||||
(define proj-handler
|
||||
(hash-ref key-proj-handler
|
||||
constants
|
||||
(lambda () (on-missing-skconst key-proj-handler constants))))
|
||||
(when proj-handler
|
||||
(when (eq? (modify-skconst! proj-handler term0) 'remove-check)
|
||||
(when (skeleton-matched-constant-empty? proj-handler)
|
||||
(hash-remove! key-proj-handler constants)
|
||||
(when (hash-empty? key-proj-handler)
|
||||
(set! constant-keys-to-remove (cons constant-key constant-keys-to-remove)))))
|
||||
(hash-for-each (skeleton-matched-constant-table proj-handler)
|
||||
(lambda (variable-proj acc)
|
||||
(define vars (apply-projection term0 variable-proj))
|
||||
(modify-skacc! turn acc vars term0)))))))
|
||||
(for [(constant-key (in-list constant-keys-to-remove))]
|
||||
(hash-remove! sct constant-key)))
|
||||
|
||||
(for [(edge (in-list edges))]
|
||||
(match-define (cons (skeleton-selector pop-count key) table) edge)
|
||||
(match-define (cons (skeleton-move pop-count path) table) edge)
|
||||
(define popped-stack (drop term-stack pop-count))
|
||||
(define old-top (car popped-stack))
|
||||
(define new-top (step-term old-top key))
|
||||
(define entry
|
||||
(hash-ref table
|
||||
(cond [(non-object-struct? new-top) (cons 'rec (struct-type-name
|
||||
(struct->struct-type new-top)))]
|
||||
[(list? new-top) 'arr]
|
||||
[(hash? new-top) 'dict]
|
||||
[else #f])
|
||||
#f))
|
||||
(define new-top (apply-projection-path old-top path))
|
||||
(define ctor-spec (cond [(non-object-struct? new-top)
|
||||
(GroupType-rec (struct-type-name
|
||||
(struct->struct-type new-top)))]
|
||||
[(list? new-top) (GroupType-arr)]
|
||||
[(hash? new-top) (GroupType-dict)]
|
||||
[else #f]))
|
||||
(define entry (hash-ref table ctor-spec #f))
|
||||
(when entry (walk-node! entry (cons new-top popped-stack))))))
|
||||
|
||||
(define (add-term-to-skcont! skcont term)
|
||||
|
@ -331,8 +333,12 @@
|
|||
|
||||
;; TODO: avoid repeated descent into `term` by factoring out prefixes of paths in `proj`
|
||||
(define (apply-projection term proj)
|
||||
(for/list [(path (in-list proj))]
|
||||
(apply-projection-path term path)))
|
||||
(let/ec return
|
||||
(for/list [(path (in-list proj))]
|
||||
(define v (apply-projection-path term path))
|
||||
(if (void? v)
|
||||
(return (void))
|
||||
v))))
|
||||
|
||||
(define (apply-projection-path term path)
|
||||
(for/fold [(term term)]
|
||||
|
|
|
@ -23,13 +23,28 @@
|
|||
|
||||
(require syndicate/schemas/dataspacePatterns)
|
||||
|
||||
(define (rec label pats) (Pattern-DCompound (DCompound-rec label pats)))
|
||||
(define (arr pats) (Pattern-DCompound (DCompound-arr pats)))
|
||||
(define (dict pats) (Pattern-DCompound (DCompound-dict pats)))
|
||||
(define (items->entries pats)
|
||||
(define-values (entries max-i)
|
||||
(for/fold [(entries (hash)) (max-i #f)]
|
||||
[(i (in-naturals)) (p (in-list pats))]
|
||||
(values (if (Pattern-discard? p) entries (hash-set entries i p))
|
||||
i)))
|
||||
(if (and max-i (not (hash-has-key? entries max-i)))
|
||||
(hash-set entries max-i (Pattern-discard))
|
||||
entries))
|
||||
|
||||
(define (rec* label pats) (rec 'rec (list (lit label) (arr pats))))
|
||||
(define (arr* pats) (rec 'arr (list (arr pats))))
|
||||
(define (dict* pats) (rec 'dict (list (dict pats))))
|
||||
(define (entries->items entries on-missing)
|
||||
(define max-key (apply max -1 (hash-keys entries)))
|
||||
(for/list [(i (in-range 0 (+ max-key 1)))]
|
||||
(hash-ref entries i on-missing)))
|
||||
|
||||
(define (rec label pats) (Pattern-group (GroupType-rec label) (items->entries pats)))
|
||||
(define (arr pats) (Pattern-group (GroupType-arr) (items->entries pats)))
|
||||
(define (dict pats) (Pattern-group (GroupType-dict) pats))
|
||||
|
||||
(define (rec* label pats) (rec 'group (list (rec 'rec (list (lit label))) (dict (items->entries pats)))))
|
||||
(define (arr* pats) (rec 'group (list (rec 'arr (list)) (dict (items->entries pats)))))
|
||||
(define (dict* pats) (rec 'group (list (rec 'dict (list)) (dict pats))))
|
||||
|
||||
(define (literal->literal-pattern v)
|
||||
(let walk ((v (->preserve v)))
|
||||
|
@ -37,18 +52,19 @@
|
|||
[(record label fs) (rec label (map walk fs))]
|
||||
[(? list? vs) (arr (map walk vs))]
|
||||
[(? dict? d) (dict (for/hash [((k v) (in-hash d))] (values k (walk v))))]
|
||||
[other (Pattern-DLit (DLit (parse-AnyAtom! other)))])))
|
||||
[other (Pattern-lit (parse-AnyAtom! other))])))
|
||||
|
||||
(define lit literal->literal-pattern)
|
||||
|
||||
(define (literal-pattern->literal p)
|
||||
(let/ec return
|
||||
(define (e->i e) (entries->items e (lambda () (return (void)))))
|
||||
(let walk ((p p))
|
||||
(match p
|
||||
[(Pattern-DDiscard (DDiscard)) (return (void))]
|
||||
[(Pattern-DBind (DBind pp)) (walk pp)]
|
||||
[(Pattern-DLit (DLit a)) (->preserve a)]
|
||||
[(Pattern-DCompound (DCompound-rec label ps)) (record label (map walk ps))]
|
||||
[(Pattern-DCompound (DCompound-arr ps)) (map walk ps)]
|
||||
[(Pattern-DCompound (DCompound-dict d)) (for/hash [((k pp) (in-hash d))]
|
||||
(values k (walk pp)))]))))
|
||||
[(Pattern-discard) (return (void))]
|
||||
[(Pattern-bind pp) (walk pp)]
|
||||
[(Pattern-lit a) (->preserve a)]
|
||||
[(Pattern-group (GroupType-rec label) ps) (record label (map walk (e->i ps)))]
|
||||
[(Pattern-group (GroupType-arr) ps) (map walk (e->i ps))]
|
||||
[(Pattern-group (GroupType-dict) d) (for/hash [((k pp) (in-hash d))]
|
||||
(values k (walk pp)))]))))
|
||||
|
|
Loading…
Reference in New Issue