mirror of
https://github.com/urbit/shrub.git
synced 2024-12-21 01:41:37 +03:00
1154 lines
34 KiB
Plaintext
1154 lines
34 KiB
Plaintext
:: graph-store [landscape]
|
|
::
|
|
::
|
|
/+ store=graph-store, sigs=signatures, res=resource, default-agent, dbug, verb,
|
|
*migrate
|
|
~% %graph-store-top ..part ~
|
|
|%
|
|
+$ card card:agent:gall
|
|
+$ versioned-state
|
|
$% state-0
|
|
state-1
|
|
state-2
|
|
==
|
|
::
|
|
+$ state-0 [%0 network:store]
|
|
+$ state-1 [%1 network:store]
|
|
+$ state-2 [%2 network:store]
|
|
::
|
|
++ orm orm:store
|
|
++ orm-log orm-log:store
|
|
+$ debug-input [%validate-graph =resource:store]
|
|
--
|
|
::
|
|
=| state-2
|
|
=* state -
|
|
::
|
|
%- agent:dbug
|
|
%+ verb |
|
|
^- agent:gall
|
|
~% %graph-store-agent ..card ~
|
|
|_ =bowl:gall
|
|
+* this .
|
|
def ~(. (default-agent this %|) bowl)
|
|
::
|
|
++ on-init [~ this]
|
|
++ on-save !>(state)
|
|
++ on-load
|
|
|= =old=vase
|
|
^- (quip card _this)
|
|
=+ !<(old=versioned-state old-vase)
|
|
=| cards=(list card)
|
|
|^
|
|
?- -.old
|
|
%0
|
|
%_ $
|
|
-.old %1
|
|
::
|
|
validators.old
|
|
(~(put in validators.old) %graph-validator-link)
|
|
::
|
|
cards
|
|
%+ weld cards
|
|
%+ turn
|
|
~(tap in (~(put in validators.old) %graph-validator-link))
|
|
|= validator=@t
|
|
^- card
|
|
=/ =wire /validator/[validator]
|
|
=/ =rave:clay [%sing %b [%da now.bowl] /[validator]]
|
|
[%pass wire %arvo %c %warp our.bowl [%home `rave]]
|
|
::
|
|
graphs.old
|
|
%- ~(run by graphs.old)
|
|
|= [=graph:store q=(unit mark)]
|
|
^- [graph:store (unit mark)]
|
|
:- (convert-unix-timestamped-graph graph)
|
|
?^ q q
|
|
`%graph-validator-link
|
|
::
|
|
update-logs.old
|
|
%- ~(run by update-logs.old)
|
|
|=(a=* *update-log:store)
|
|
==
|
|
::
|
|
%1
|
|
%_ $
|
|
-.old %2
|
|
graphs.old (~(run by graphs.old) change-revision-graph)
|
|
::
|
|
update-logs.old
|
|
%- ~(run by update-logs.old)
|
|
|=(a=* *update-log:store)
|
|
==
|
|
::
|
|
%2 [cards this(state old)]
|
|
==
|
|
::
|
|
++ change-revision-graph
|
|
|= [=graph:store q=(unit mark)]
|
|
^- [graph:store (unit mark)]
|
|
|^
|
|
:_ q
|
|
?+ q graph
|
|
[~ %graph-validator-link] convert-links
|
|
[~ %graph-validator-publish] convert-publish
|
|
==
|
|
::
|
|
++ convert-links
|
|
%+ gas:orm *graph:store
|
|
%+ turn (tap:orm graph)
|
|
|= [=atom =node:store]
|
|
^- [^atom node:store]
|
|
:: top-level
|
|
::
|
|
:+ atom post.node
|
|
?: ?=(%empty -.children.node)
|
|
[%empty ~]
|
|
:- %graph
|
|
%+ gas:orm *graph:store
|
|
%+ turn (tap:orm p.children.node)
|
|
|= [=^atom =node:store]
|
|
^- [^^atom node:store]
|
|
:: existing comments get turned into containers for revisions
|
|
::
|
|
:^ atom
|
|
post.node(contents ~, hash ~)
|
|
%graph
|
|
%+ gas:orm *graph:store
|
|
:_ ~ :- %1
|
|
:_ [%empty ~]
|
|
post.node(index (snoc index.post.node atom), hash ~)
|
|
::
|
|
++ convert-publish
|
|
%+ gas:orm *graph:store
|
|
%+ turn (tap:orm graph)
|
|
|= [=atom =node:store]
|
|
^- [^atom node:store]
|
|
:: top-level
|
|
::
|
|
:+ atom post.node
|
|
?: ?=(%empty -.children.node)
|
|
[%empty ~]
|
|
:- %graph
|
|
%+ gas:orm *graph:store
|
|
%+ turn (tap:orm p.children.node)
|
|
|= [=^atom =node:store]
|
|
^- [^^atom node:store]
|
|
:: existing container for publish note revisions
|
|
::
|
|
?+ atom !!
|
|
%1 [atom node]
|
|
%2
|
|
:+ atom post.node
|
|
?: ?=(%empty -.children.node)
|
|
[%empty ~]
|
|
:- %graph
|
|
%+ gas:orm *graph:store
|
|
%+ turn (tap:orm p.children.node)
|
|
|= [=^^atom =node:store]
|
|
^- [^^^atom node:store]
|
|
:+ atom post.node(contents ~, hash ~)
|
|
:- %graph
|
|
%+ gas:orm *graph:store
|
|
:_ ~ :- %1
|
|
:_ [%empty ~]
|
|
post.node(index (snoc index.post.node atom), hash ~)
|
|
==
|
|
--
|
|
::
|
|
++ maybe-unix-to-da
|
|
|= =atom
|
|
^- @
|
|
:: (bex 127) is roughly 226AD
|
|
?. (lte atom (bex 127))
|
|
atom
|
|
(add ~1970.1.1 (div (mul ~s1 atom) 1.000))
|
|
::
|
|
++ convert-unix-timestamped-node
|
|
|= =node:store
|
|
^- node:store
|
|
=. index.post.node
|
|
(convert-unix-timestamped-index index.post.node)
|
|
?. ?=(%graph -.children.node)
|
|
node
|
|
:+ post.node
|
|
%graph
|
|
(convert-unix-timestamped-graph p.children.node)
|
|
::
|
|
++ convert-unix-timestamped-index
|
|
|= =index:store
|
|
(turn index maybe-unix-to-da)
|
|
::
|
|
++ convert-unix-timestamped-graph
|
|
|= =graph:store
|
|
%+ gas:orm *graph:store
|
|
%+ turn
|
|
(tap:orm graph)
|
|
|= [=atom =node:store]
|
|
^- [^atom node:store]
|
|
:- (maybe-unix-to-da atom)
|
|
(convert-unix-timestamped-node node)
|
|
--
|
|
::
|
|
++ on-watch
|
|
~/ %graph-store-watch
|
|
|= =path
|
|
^- (quip card _this)
|
|
|^
|
|
?> (team:title our.bowl src.bowl)
|
|
=/ cards=(list card)
|
|
?+ path (on-watch:def path)
|
|
[%updates ~] ~
|
|
[%keys ~] (give [%keys ~(key by graphs)])
|
|
[%tags ~] (give [%tags ~(key by tag-queries)])
|
|
==
|
|
[cards this]
|
|
::
|
|
++ give
|
|
|= =update-0:store
|
|
^- (list card)
|
|
[%give %fact ~ [%graph-update !>([%0 now.bowl update-0])]]~
|
|
--
|
|
::
|
|
++ on-poke
|
|
~/ %graph-store-poke
|
|
|= [=mark =vase]
|
|
^- (quip card _this)
|
|
|^
|
|
?> (team:title our.bowl src.bowl)
|
|
=^ cards state
|
|
?+ mark (on-poke:def mark vase)
|
|
%graph-update (graph-update !<(update:store vase))
|
|
%noun (debug !<(debug-input vase))
|
|
%import (poke-import q.vase)
|
|
==
|
|
[cards this]
|
|
::
|
|
++ graph-update
|
|
|= =update:store
|
|
^- (quip card _state)
|
|
|^
|
|
?> ?=(%0 -.update)
|
|
=? p.update =(p.update *time) now.bowl
|
|
?- -.q.update
|
|
%add-graph (add-graph p.update +.q.update)
|
|
%remove-graph (remove-graph +.q.update)
|
|
%add-nodes (add-nodes p.update +.q.update)
|
|
%remove-nodes (remove-nodes p.update +.q.update)
|
|
%add-signatures (add-signatures p.update +.q.update)
|
|
%remove-signatures (remove-signatures p.update +.q.update)
|
|
%add-tag (add-tag +.q.update)
|
|
%remove-tag (remove-tag +.q.update)
|
|
%archive-graph (archive-graph +.q.update)
|
|
%unarchive-graph (unarchive-graph +.q.update)
|
|
%run-updates (run-updates +.q.update)
|
|
%keys ~|('cannot send %keys as poke' !!)
|
|
%tags ~|('cannot send %tags as poke' !!)
|
|
%tag-queries ~|('cannot send %tag-queries as poke' !!)
|
|
==
|
|
::
|
|
++ add-graph
|
|
|= $: =time
|
|
=resource:store
|
|
=graph:store
|
|
mark=(unit mark:store)
|
|
overwrite=?
|
|
==
|
|
^- (quip card _state)
|
|
?> ?| overwrite
|
|
?& !(~(has by archive) resource)
|
|
!(~(has by graphs) resource)
|
|
== ==
|
|
?> (validate-graph graph mark)
|
|
=/ =logged-update:store
|
|
[%0 time %add-graph resource graph mark overwrite]
|
|
=/ =update-log:store
|
|
(gas:orm-log ~ [time logged-update] ~)
|
|
:_ %_ state
|
|
graphs (~(put by graphs) resource [graph mark])
|
|
update-logs (~(put by update-logs) resource update-log)
|
|
archive (~(del by archive) resource)
|
|
::
|
|
validators
|
|
?~ mark validators
|
|
(~(put in validators) u.mark)
|
|
==
|
|
%- zing
|
|
:~ (give [/keys ~] %keys (~(put in ~(key by graphs)) resource))
|
|
(give [/updates ~] %add-graph resource *graph:store mark overwrite)
|
|
?~ mark ~
|
|
?: (~(has in validators) u.mark) ~
|
|
=/ wire /validator/[u.mark]
|
|
=/ =rave:clay [%sing %b [%da now.bowl] /[u.mark]]
|
|
[%pass wire %arvo %c %warp our.bowl [%home `rave]]~
|
|
==
|
|
::
|
|
++ remove-graph
|
|
|= =resource:store
|
|
^- (quip card _state)
|
|
?< (~(has by archive) resource)
|
|
?> (~(has by graphs) resource)
|
|
:- (give [/updates /keys ~] [%remove-graph resource])
|
|
%_ state
|
|
graphs (~(del by graphs) resource)
|
|
update-logs (~(del by update-logs) resource)
|
|
==
|
|
::
|
|
++ add-nodes
|
|
|= $: =time
|
|
=resource:store
|
|
nodes=(map index:store node:store)
|
|
==
|
|
^- (quip card _state)
|
|
|^
|
|
=/ [=graph:store mark=(unit mark:store)]
|
|
(~(got by graphs) resource)
|
|
~| "cannot add duplicate nodes to {<resource>}"
|
|
?< (check-for-duplicates graph ~(key by nodes))
|
|
=/ =update-log:store (~(got by update-logs) resource)
|
|
=. update-log
|
|
(put:orm-log update-log time [%0 time [%add-nodes resource nodes]])
|
|
::
|
|
:- (give [/updates]~ [%add-nodes resource nodes])
|
|
%_ state
|
|
update-logs (~(put by update-logs) resource update-log)
|
|
graphs
|
|
%+ ~(put by graphs)
|
|
resource
|
|
:_ mark
|
|
(add-node-list resource graph mark (sort-nodes nodes))
|
|
==
|
|
::
|
|
++ check-for-duplicates
|
|
|= [=graph:store nodes=(set index:store)]
|
|
^- ?
|
|
=/ node-list ~(tap in nodes)
|
|
|-
|
|
?~ node-list %.n
|
|
?: (has-node graph i.node-list) %.y
|
|
$(node-list t.node-list)
|
|
::
|
|
++ has-node
|
|
|= [=graph:store =index:store]
|
|
^- ?
|
|
=/ node=(unit node:store) ~
|
|
|-
|
|
?~ index
|
|
?=(^ node)
|
|
?~ t.index
|
|
?=(^ (get:orm graph i.index))
|
|
=. node (get:orm graph i.index)
|
|
?~ node %.n
|
|
?- -.children.u.node
|
|
%empty %.n
|
|
%graph $(graph p.children.u.node, index t.index)
|
|
==
|
|
::
|
|
++ sort-nodes
|
|
|= nodes=(map index:store node:store)
|
|
^- (list [index:store node:store])
|
|
%+ sort ~(tap by nodes)
|
|
|= [p=[=index:store *] q=[=index:store *]]
|
|
^- ?
|
|
(lth (lent index.p) (lent index.q))
|
|
::
|
|
++ add-node-list
|
|
|= $: =resource:store
|
|
=graph:store
|
|
mark=(unit mark:store)
|
|
node-list=(list [index:store node:store])
|
|
==
|
|
^- graph:store
|
|
?~ node-list graph
|
|
=* index -.i.node-list
|
|
=* node +.i.node-list
|
|
%_ $
|
|
node-list t.node-list
|
|
graph (add-node-at-index graph index node mark)
|
|
==
|
|
::
|
|
++ add-node-at-index
|
|
=| parent-hash=(unit hash:store)
|
|
|= $: =graph:store
|
|
=index:store
|
|
=node:store
|
|
mark=(unit mark:store)
|
|
==
|
|
^- graph:store
|
|
?< ?=(~ index)
|
|
~| "validation of node failed using mark {<mark>}"
|
|
?> (validate-graph (gas:orm ~ [i.index node]~) mark)
|
|
=* atom i.index
|
|
%^ put:orm
|
|
graph
|
|
atom
|
|
:: add child
|
|
::
|
|
?~ t.index
|
|
=* p post.node
|
|
?~ hash.p node(signatures.post *signatures:store)
|
|
=/ =validated-portion:store
|
|
[parent-hash author.p time-sent.p contents.p]
|
|
=/ =hash:store `@ux`(sham validated-portion)
|
|
~| "hash of post does not match calculated hash"
|
|
?> =(hash u.hash.p)
|
|
~| "signatures do not match the calculated hash"
|
|
?> (are-signatures-valid:sigs our.bowl signatures.p hash now.bowl)
|
|
node
|
|
:: recurse children
|
|
::
|
|
=/ parent=node:store
|
|
~| "index does not exist to add a node to!"
|
|
(need (get:orm graph atom))
|
|
%_ parent
|
|
children
|
|
^- internal-graph:store
|
|
:- %graph
|
|
%_ $
|
|
index t.index
|
|
parent-hash hash.post.parent
|
|
graph
|
|
?: ?=(%graph -.children.parent)
|
|
p.children.parent
|
|
(gas:orm ~ ~)
|
|
==
|
|
==
|
|
--
|
|
::
|
|
++ remove-nodes
|
|
|= [=time =resource:store indices=(set index:store)]
|
|
^- (quip card _state)
|
|
|^
|
|
=/ [=graph:store mark=(unit mark:store)]
|
|
(~(got by graphs) resource)
|
|
=/ =update-log:store (~(got by update-logs) resource)
|
|
=. update-log
|
|
(put:orm-log update-log time [%0 time [%remove-nodes resource indices]])
|
|
=/ [affected-indices=(set index:store) new-graph=graph:store]
|
|
(remove-indices resource graph (sort ~(tap in indices) by-lent))
|
|
::
|
|
:- (give [/updates]~ [%remove-nodes resource (~(uni in indices) affected-indices)])
|
|
%_ state
|
|
update-logs (~(put by update-logs) resource update-log)
|
|
graphs
|
|
%+ ~(put by graphs)
|
|
resource
|
|
[new-graph mark]
|
|
==
|
|
::
|
|
:: we always want to remove the deepest node first,
|
|
:: so we don't remove parents before children
|
|
++ by-lent
|
|
|* [a=(list) b=(list)]
|
|
^- ?
|
|
(gth (lent a) (lent b))
|
|
::
|
|
++ remove-indices
|
|
=| affected=(set index:store)
|
|
|= [=resource:store =graph:store indices=(list index:store)]
|
|
^- [(set index:store) graph:store]
|
|
?~ indices [affected graph]
|
|
=^ new-affected graph
|
|
(remove-index graph i.indices)
|
|
%_ $
|
|
indices t.indices
|
|
affected (~(uni in affected) new-affected)
|
|
==
|
|
::
|
|
++ get-descendants
|
|
|= =graph:store
|
|
=| indices=(list index:store)
|
|
=/ nodes (tap:orm:store graph)
|
|
%- ~(gas in *(set index:store))
|
|
|- =* tap-nodes $
|
|
^+ indices
|
|
%- zing
|
|
%+ turn nodes
|
|
|= [atom =node:store]
|
|
^- (list index:store)
|
|
%+ welp
|
|
index.post.node^~
|
|
?. ?=(%graph -.children.node)
|
|
~
|
|
%_ tap-nodes
|
|
nodes (tap:orm p.children.node)
|
|
==
|
|
::
|
|
++ remove-index
|
|
=| indices=(set index:store)
|
|
|= [=graph:store =index:store]
|
|
^- [(set index:store) graph:store]
|
|
?~ index [indices graph]
|
|
=* atom i.index
|
|
:: last index in list
|
|
::
|
|
?~ t.index
|
|
=^ rm-node graph (del:orm graph atom)
|
|
?~ rm-node `graph
|
|
?. ?=(%graph -.children.u.rm-node)
|
|
`graph
|
|
=/ new-indices
|
|
(get-descendants p.children.u.rm-node)
|
|
[(~(uni in indices) new-indices) graph]
|
|
=/ =node:store
|
|
~| "parent index does not exist to remove a node from!"
|
|
(need (get:orm graph atom))
|
|
~| "child index does not exist to remove a node from!"
|
|
?> ?=(%graph -.children.node)
|
|
=^ new-indices p.children.node
|
|
$(graph p.children.node, index t.index)
|
|
:- (~(uni in indices) new-indices)
|
|
(put:orm graph atom node)
|
|
--
|
|
::
|
|
++ add-signatures
|
|
|= [=time =uid:store =signatures:store]
|
|
^- (quip card _state)
|
|
|^
|
|
=* resource resource.uid
|
|
=/ [=graph:store mark=(unit mark:store)]
|
|
(~(got by graphs) resource)
|
|
=/ =update-log:store (~(got by update-logs) resource)
|
|
=. update-log
|
|
(put:orm-log update-log time [%0 time [%add-signatures uid signatures]])
|
|
::
|
|
:- (give [/updates]~ [%add-signatures uid signatures])
|
|
%_ state
|
|
update-logs (~(put by update-logs) resource update-log)
|
|
graphs
|
|
%+ ~(put by graphs) resource
|
|
[(add-at-index graph index.uid signatures) mark]
|
|
==
|
|
::
|
|
++ add-at-index
|
|
|= [=graph:store =index:store =signatures:store]
|
|
^- graph:store
|
|
?~ index graph
|
|
=* atom i.index
|
|
=/ =node:store
|
|
~| "node does not exist to add signatures to!"
|
|
(need (get:orm graph atom))
|
|
:: last index in list
|
|
::
|
|
%^ put:orm
|
|
graph
|
|
atom
|
|
?~ t.index
|
|
~| "cannot add signatures to a node missing a hash"
|
|
?> ?=(^ hash.post.node)
|
|
~| "signatures did not match public keys!"
|
|
?> (are-signatures-valid:sigs our.bowl signatures u.hash.post.node now.bowl)
|
|
node(signatures.post (~(uni in signatures) signatures.post.node))
|
|
~| "child graph does not exist to add signatures to!"
|
|
?> ?=(%graph -.children.node)
|
|
node(p.children $(graph p.children.node, index t.index))
|
|
--
|
|
::
|
|
++ remove-signatures
|
|
|= [=time =uid:store =signatures:store]
|
|
^- (quip card _state)
|
|
|^
|
|
=* resource resource.uid
|
|
=/ [=graph:store mark=(unit mark:store)]
|
|
(~(got by graphs) resource)
|
|
=/ =update-log:store (~(got by update-logs) resource)
|
|
=. update-log
|
|
%^ put:orm-log update-log
|
|
time
|
|
[%0 time [%remove-signatures uid signatures]]
|
|
::
|
|
:- (give [/updates]~ [%remove-signatures uid signatures])
|
|
%_ state
|
|
update-logs (~(put by update-logs) resource update-log)
|
|
graphs
|
|
%+ ~(put by graphs) resource
|
|
[(remove-at-index graph index.uid signatures) mark]
|
|
==
|
|
::
|
|
++ remove-at-index
|
|
|= [=graph:store =index:store =signatures:store]
|
|
^- graph:store
|
|
?~ index graph
|
|
=* atom i.index
|
|
=/ =node:store
|
|
~| "node does not exist to add signatures to!"
|
|
(need (get:orm graph atom))
|
|
:: last index in list
|
|
::
|
|
%^ put:orm
|
|
graph
|
|
atom
|
|
?~ t.index
|
|
node(signatures.post (~(dif in signatures) signatures.post.node))
|
|
~| "child graph does not exist to add signatures to!"
|
|
?> ?=(%graph -.children.node)
|
|
node(p.children $(graph p.children.node, index t.index))
|
|
--
|
|
::
|
|
++ add-tag
|
|
|= [=term =resource:store]
|
|
^- (quip card _state)
|
|
?> (~(has by graphs) resource)
|
|
:- (give [/updates /tags ~] [%add-tag term resource])
|
|
%_ state
|
|
tag-queries (~(put ju tag-queries) term resource)
|
|
==
|
|
::
|
|
++ remove-tag
|
|
|= [=term =resource:store]
|
|
^- (quip card _state)
|
|
?> (~(has by graphs) resource)
|
|
:- (give [/updates /tags ~] [%remove-tag term resource])
|
|
%_ state
|
|
tag-queries (~(del ju tag-queries) term resource)
|
|
==
|
|
::
|
|
++ archive-graph
|
|
|= =resource:store
|
|
^- (quip card _state)
|
|
?< (~(has by archive) resource)
|
|
?> (~(has by graphs) resource)
|
|
:- (give [/updates /keys /tags ~] [%archive-graph resource])
|
|
%_ state
|
|
archive (~(put by archive) resource (~(got by graphs) resource))
|
|
graphs (~(del by graphs) resource)
|
|
update-logs (~(del by update-logs) resource)
|
|
tag-queries
|
|
%- ~(run by tag-queries)
|
|
|= =resources:store
|
|
(~(del in resources) resource)
|
|
==
|
|
::
|
|
++ unarchive-graph
|
|
|= =resource:store
|
|
^- (quip card _state)
|
|
?> (~(has by archive) resource)
|
|
?< (~(has by graphs) resource)
|
|
:- (give [/updates /keys ~] [%unarchive-graph resource])
|
|
%_ state
|
|
archive (~(del by archive) resource)
|
|
graphs (~(put by graphs) resource (~(got by archive) resource))
|
|
update-logs (~(put by update-logs) resource (gas:orm-log ~ ~))
|
|
==
|
|
::
|
|
++ run-updates
|
|
|= [=resource:store =update-log:store]
|
|
^- (quip card _state)
|
|
?< (~(has by archive) resource)
|
|
?> (~(has by graphs) resource)
|
|
=/ updates=(list [=time upd=logged-update:store])
|
|
:: updates are time-ordered with most recent first
|
|
:: process with earliest first
|
|
(bap:orm-log update-log)
|
|
=| cards=(list card)
|
|
|- ^- (quip card _state)
|
|
?~ updates
|
|
[cards state]
|
|
=* update upd.i.updates
|
|
=^ crds state
|
|
%- graph-update
|
|
^- update:store
|
|
?- -.q.update
|
|
%add-graph update(resource.q resource)
|
|
%add-nodes update(resource.q resource)
|
|
%remove-nodes update(resource.q resource)
|
|
%add-signatures update(resource.uid.q resource)
|
|
%remove-signatures update(resource.uid.q resource)
|
|
==
|
|
$(cards (weld cards crds), updates t.updates)
|
|
::
|
|
++ give
|
|
|= [paths=(list path) update=update-0:store]
|
|
^- (list card)
|
|
[%give %fact paths [%graph-update !>([%0 now.bowl update])]]~
|
|
--
|
|
::
|
|
++ debug
|
|
|= =debug-input
|
|
^- (quip card _state)
|
|
=/ [=graph:store mark=(unit mark:store)]
|
|
(~(got by graphs) resource.debug-input)
|
|
?> (validate-graph graph mark)
|
|
[~ state]
|
|
::
|
|
++ validate-graph
|
|
|= [=graph:store mark=(unit mark:store)]
|
|
^- ?
|
|
?~ mark %.y
|
|
?~ graph %.y
|
|
=/ =dais:clay
|
|
.^ =dais:clay
|
|
%cb
|
|
/(scot %p our.bowl)/[q.byk.bowl]/(scot %da now.bowl)/[u.mark]
|
|
==
|
|
%+ roll (tap:orm graph)
|
|
|= [[=atom =node:store] out=?]
|
|
?& out
|
|
=(%& -:(mule |.((vale:dais [atom post.node]))))
|
|
?- -.children.node
|
|
%empty %.y
|
|
%graph ^$(graph p.children.node)
|
|
==
|
|
==
|
|
::
|
|
++ poke-import
|
|
|= arc=*
|
|
^- (quip card _state)
|
|
|^
|
|
=/ sty=state-2 [%2 (remake-network ;;(tree-network +.arc))]
|
|
:_ sty
|
|
%+ turn ~(tap by graphs.sty)
|
|
|= [rid=resource:store =marked-graph:store]
|
|
^- card
|
|
?: =(our.bowl entity.rid)
|
|
=/ =cage [%push-hook-action !>([%add rid])]
|
|
[%pass / %agent [our.bowl %graph-push-hook] %poke cage]
|
|
(try-rejoin rid 0)
|
|
::
|
|
+$ tree-network
|
|
$: graphs=tree-graphs
|
|
tag-queries=(tree [term (tree resource:store)])
|
|
update-logs=tree-update-logs
|
|
archive=tree-graphs
|
|
validators=(tree ^mark)
|
|
==
|
|
+$ tree-graphs (tree [resource:store tree-marked-graph])
|
|
+$ tree-marked-graph [p=tree-graph q=(unit ^mark)]
|
|
+$ tree-graph (tree [atom tree-node])
|
|
+$ tree-node [post=tree-post children=tree-internal-graph]
|
|
+$ tree-internal-graph
|
|
$~ [%empty ~]
|
|
$% [%graph p=tree-graph]
|
|
[%empty ~]
|
|
==
|
|
+$ tree-update-logs (tree [resource:store tree-update-log])
|
|
+$ tree-update-log (tree [time tree-logged-update])
|
|
+$ tree-logged-update
|
|
$: %0
|
|
p=time
|
|
$= q
|
|
$% [%add-graph =resource:store =tree-graph mark=(unit ^mark) ow=?]
|
|
[%add-nodes =resource:store nodes=(tree [index:store tree-node])]
|
|
[%remove-nodes =resource:store indices=(tree index:store)]
|
|
[%add-signatures =uid:store signatures=tree-signatures]
|
|
[%remove-signatures =uid:store signatures=tree-signatures]
|
|
==
|
|
==
|
|
+$ tree-signatures (tree signature:store)
|
|
+$ tree-post
|
|
$: author=ship
|
|
=index:store
|
|
time-sent=time
|
|
contents=(list content:store)
|
|
hash=(unit hash:store)
|
|
signatures=tree-signatures
|
|
==
|
|
::
|
|
++ remake-network
|
|
|= t=tree-network
|
|
^- network:store
|
|
:* (remake-graphs graphs.t)
|
|
(remake-jug tag-queries.t)
|
|
(remake-update-logs update-logs.t)
|
|
(remake-graphs archive.t)
|
|
(remake-set validators.t)
|
|
==
|
|
::
|
|
++ remake-graphs
|
|
|= t=tree-graphs
|
|
^- graphs:store
|
|
%- remake-map
|
|
(~(run by t) remake-marked-graph)
|
|
::
|
|
++ remake-marked-graph
|
|
|= t=tree-marked-graph
|
|
^- marked-graph:store
|
|
[(remake-graph p.t) q.t]
|
|
::
|
|
++ remake-graph
|
|
|= t=tree-graph
|
|
^- graph:store
|
|
%+ gas:orm *graph:store
|
|
%+ turn ~(tap by t)
|
|
|= [a=atom tn=tree-node]
|
|
^- [atom node:store]
|
|
[a (remake-node tn)]
|
|
::
|
|
++ remake-internal-graph
|
|
|= t=tree-internal-graph
|
|
^- internal-graph:store
|
|
?: ?=(%empty -.t)
|
|
[%empty ~]
|
|
[%graph (remake-graph p.t)]
|
|
::
|
|
++ remake-node
|
|
|= t=tree-node
|
|
^- node:store
|
|
:- (remake-post post.t)
|
|
(remake-internal-graph children.t)
|
|
::
|
|
++ remake-update-logs
|
|
|= t=tree-update-logs
|
|
^- update-logs:store
|
|
%- remake-map
|
|
(~(run by t) remake-update-log)
|
|
::
|
|
++ remake-update-log
|
|
|= t=tree-update-log
|
|
^- update-log:store
|
|
=/ ulm ((ordered-map time logged-update:store) gth)
|
|
%+ gas:ulm *update-log:store
|
|
%+ turn ~(tap by t)
|
|
|= [=time tlu=tree-logged-update]
|
|
^- [^time logged-update:store]
|
|
[time (remake-logged-update tlu)]
|
|
::
|
|
++ remake-logged-update
|
|
|= t=tree-logged-update
|
|
^- logged-update:store
|
|
:+ %0 p.t
|
|
?- -.q.t
|
|
%add-graph
|
|
:* %add-graph
|
|
resource.q.t
|
|
(remake-graph tree-graph.q.t)
|
|
mark.q.t
|
|
ow.q.t
|
|
==
|
|
::
|
|
%add-nodes
|
|
:- %add-nodes
|
|
:- resource.q.t
|
|
%- remake-map
|
|
(~(run by nodes.q.t) remake-node)
|
|
::
|
|
%remove-nodes
|
|
[%remove-nodes resource.q.t (remake-set indices.q.t)]
|
|
::
|
|
%add-signatures
|
|
[%add-signatures uid.q.t (remake-set signatures.q.t)]
|
|
::
|
|
%remove-signatures
|
|
[%remove-signatures uid.q.t (remake-set signatures.q.t)]
|
|
==
|
|
::
|
|
++ remake-post
|
|
|= t=tree-post
|
|
^- post:store
|
|
t(signatures (remake-set signatures.t))
|
|
--
|
|
::
|
|
++ try-rejoin
|
|
|= [rid=resource:store nack-count=@]
|
|
^- card
|
|
=/ res-path (en-path:res rid)
|
|
=/ wire [%try-rejoin (scot %ud nack-count) res-path]
|
|
[%pass wire %agent [entity.rid %graph-push-hook] %watch resource+res-path]
|
|
--
|
|
::
|
|
++ on-peek
|
|
~/ %graph-store-peek
|
|
|= =path
|
|
^- (unit (unit cage))
|
|
|^
|
|
?> (team:title our.bowl src.bowl)
|
|
?+ path (on-peek:def path)
|
|
[%x %graph-mark @ @ ~]
|
|
=/ =ship (slav %p i.t.t.path)
|
|
=/ =term i.t.t.t.path
|
|
=/ result=(unit marked-graph:store)
|
|
(~(get by graphs) [ship term])
|
|
?~ result [~ ~]
|
|
``noun+!>(q.u.result)
|
|
::
|
|
[%x %keys ~]
|
|
:- ~ :- ~ :- %graph-update
|
|
!>(`update:store`[%0 now.bowl [%keys ~(key by graphs)]])
|
|
::
|
|
[%x %tags ~]
|
|
:- ~ :- ~ :- %graph-update
|
|
!>(`update:store`[%0 now.bowl [%tags ~(key by tag-queries)]])
|
|
::
|
|
[%x %tag-queries ~]
|
|
:- ~ :- ~ :- %graph-update
|
|
!>(`update:store`[%0 now.bowl [%tag-queries tag-queries]])
|
|
::
|
|
[%x %graph @ @ ~]
|
|
=/ =ship (slav %p i.t.t.path)
|
|
=/ =term i.t.t.t.path
|
|
=/ result=(unit marked-graph:store)
|
|
(~(get by graphs) [ship term])
|
|
?~ result [~ ~]
|
|
:- ~ :- ~ :- %graph-update
|
|
!> ^- update:store
|
|
:+ %0
|
|
now.bowl
|
|
[%add-graph [ship term] `graph:store`p.u.result q.u.result %.y]
|
|
::
|
|
:: note: near-duplicate of /x/graph
|
|
::
|
|
[%x %archive @ @ ~]
|
|
=/ =ship (slav %p i.t.t.path)
|
|
=/ =term i.t.t.t.path
|
|
=/ result=(unit marked-graph:store)
|
|
(~(get by archive) [ship term])
|
|
?~ result
|
|
~& no-archived-graph+[ship term]
|
|
[~ ~]
|
|
:- ~ :- ~ :- %graph-update
|
|
!> ^- update:store
|
|
:+ %0
|
|
now.bowl
|
|
[%add-graph [ship term] `graph:store`p.u.result q.u.result %.y]
|
|
::
|
|
[%x %export ~]
|
|
``noun+!>(state)
|
|
::
|
|
[%x %graph-subset @ @ @ @ ~]
|
|
=/ =ship (slav %p i.t.t.path)
|
|
=/ =term i.t.t.t.path
|
|
=/ start=(unit atom) (rush i.t.t.t.t.path dem:ag)
|
|
=/ end=(unit atom) (rush i.t.t.t.t.t.path dem:ag)
|
|
=/ graph=(unit marked-graph:store)
|
|
(~(get by graphs) [ship term])
|
|
?~ graph [~ ~]
|
|
:- ~ :- ~ :- %graph-update
|
|
!> ^- update:store
|
|
:+ %0 now.bowl
|
|
:+ %add-nodes
|
|
[ship term]
|
|
%- ~(gas by *(map index:store node:store))
|
|
%+ turn (tap:orm `graph:store`(lot:orm p.u.graph start end))
|
|
|= [=atom =node:store]
|
|
^- [index:store node:store]
|
|
[~[atom] node]
|
|
::
|
|
[%x %node-exists @ @ @ *]
|
|
=/ =ship (slav %p i.t.t.path)
|
|
=/ =term i.t.t.t.path
|
|
=/ =index:store
|
|
(turn t.t.t.t.path (cury slav %ud))
|
|
=/ node=(unit node:store)
|
|
(get-node ship term index)
|
|
``noun+!>(?=(^ node))
|
|
::
|
|
[%x %node @ @ @ *]
|
|
=/ =ship (slav %p i.t.t.path)
|
|
=/ =term i.t.t.t.path
|
|
=/ =index:store
|
|
(turn t.t.t.t.path (cury slav %ud))
|
|
=/ node=(unit node:store) (get-node ship term index)
|
|
?~ node [~ ~]
|
|
:- ~ :- ~ :- %graph-update
|
|
!> ^- update:store
|
|
:+ %0
|
|
now.bowl
|
|
:+ %add-nodes
|
|
[ship term]
|
|
(~(gas by *(map index:store node:store)) [index u.node] ~)
|
|
::
|
|
[%x %node-siblings ?(%older %younger) @ @ @ *]
|
|
=/ older ?=(%older i.t.t.path)
|
|
=/ =ship (slav %p i.t.t.t.path)
|
|
=/ =term i.t.t.t.t.path
|
|
=/ count (slav %ud i.t.t.t.t.t.path)
|
|
=/ =index:store
|
|
(turn t.t.t.t.t.t.path (cury slav %ud))
|
|
=/ parent=index:store
|
|
(scag (dec (lent index)) index)
|
|
=/ graph
|
|
(get-node-children ship term parent)
|
|
?~ graph [~ ~]
|
|
:- ~ :- ~ :- %graph-update
|
|
!> ^- update:store
|
|
:+ %0
|
|
now.bowl
|
|
:+ %add-nodes
|
|
[ship term]
|
|
%- ~(gas by *(map index:store node:store))
|
|
:: TODO time complexity not desirable
|
|
:: replace with custom ordered map functions
|
|
%+ turn
|
|
=- ?.(older (slag (safe-sub (lent -) count) -) (scag count -))
|
|
%- tap:orm
|
|
%+ lot:orm u.graph
|
|
=/ idx
|
|
(snag (dec (lent index)) index)
|
|
?:(older [`idx ~] [~ `idx])
|
|
|= [=atom =node:store]
|
|
^- [index:store node:store]
|
|
[(snoc parent atom) node]
|
|
::
|
|
[%x ?(%newest %oldest) @ @ @ *]
|
|
=/ newest ?=(%newest i.t.path)
|
|
=/ =ship (slav %p i.t.t.path)
|
|
=/ =term i.t.t.t.path
|
|
=/ count=@ud
|
|
(slav %ud i.t.t.t.t.path)
|
|
=/ =index:store
|
|
(turn t.t.t.t.t.path (cury slav %ud))
|
|
=/ children
|
|
(get-node-children ship term index)
|
|
?~ children [~ ~]
|
|
:- ~ :- ~ :- %graph-update
|
|
!> ^- update:store
|
|
:+ %0
|
|
now.bowl
|
|
:+ %add-nodes
|
|
[ship term]
|
|
%- ~(gas by *(map index:store node:store))
|
|
%+ turn
|
|
%+ scag count
|
|
%- ?:(newest same flop)
|
|
(tap:orm u.children)
|
|
|= [=atom =node:store]
|
|
^- [index:store node:store]
|
|
[(snoc index atom) node]
|
|
::
|
|
[%x %node-children-subset @ @ @ @ @ *]
|
|
=/ =ship (slav %p i.t.t.path)
|
|
=/ =term i.t.t.t.path
|
|
=/ start=(unit atom) (rush i.t.t.t.t.path dem:ag)
|
|
=/ end=(unit atom) (rush i.t.t.t.t.t.path dem:ag)
|
|
=/ =index:store
|
|
(turn t.t.t.t.t.t.path |=(=cord (slav %ud cord)))
|
|
=/ node=(unit node:store) (get-node ship term index)
|
|
?~ node [~ ~]
|
|
?- -.children.u.node
|
|
%empty [~ ~]
|
|
%graph
|
|
:- ~ :- ~ :- %graph-update
|
|
!> ^- update:store
|
|
:+ %0
|
|
now.bowl
|
|
:+ %add-nodes
|
|
[ship term]
|
|
%- ~(gas by *(map index:store node:store))
|
|
%+ turn (tap:orm `graph:store`(lot:orm p.children.u.node end start))
|
|
|= [=atom =node:store]
|
|
^- [index:store node:store]
|
|
[(snoc index atom) node]
|
|
==
|
|
::
|
|
[%x %update-log-subset @ @ @ @ ~]
|
|
=/ =ship (slav %p i.t.t.path)
|
|
=/ =term i.t.t.t.path
|
|
=/ start=(unit time) (slaw %da i.t.t.t.t.path)
|
|
=/ end=(unit time) (slaw %da i.t.t.t.t.t.path)
|
|
=/ update-log=(unit update-log:store) (~(get by update-logs) [ship term])
|
|
?~ update-log [~ ~]
|
|
:: orm-log is ordered backwards, so swap start and end
|
|
``noun+!>((lot:orm-log u.update-log end start))
|
|
::
|
|
[%x %update-log @ @ ~]
|
|
=/ =ship (slav %p i.t.t.path)
|
|
=/ =term i.t.t.t.path
|
|
=/ update-log=(unit update-log:store) (~(get by update-logs) [ship term])
|
|
?~ update-log [~ ~]
|
|
``noun+!>(u.update-log)
|
|
::
|
|
[%x %peek-update-log @ @ ~]
|
|
=/ =ship (slav %p i.t.t.path)
|
|
=/ =term i.t.t.t.path
|
|
=/ m-update-log=(unit update-log:store) (~(get by update-logs) [ship term])
|
|
:- ~ :- ~ :- %noun
|
|
!> ^- (unit time)
|
|
%+ biff m-update-log
|
|
|= =update-log:store
|
|
=/ result=(unit [=time =update:store])
|
|
(pry:orm-log:store update-log)
|
|
(bind result |=([=time update:store] time))
|
|
==
|
|
::
|
|
++ safe-sub
|
|
|= [a=@ b=@]
|
|
^- @
|
|
?: (gte b a)
|
|
0
|
|
(sub a b)
|
|
::
|
|
++ get-node-children
|
|
|= [=ship =term =index:store]
|
|
^- (unit graph:store)
|
|
?: ?=(~ index)
|
|
=/ graph
|
|
(~(get by graphs) [ship term])
|
|
?~ graph ~
|
|
`p.u.graph
|
|
=/ node
|
|
(get-node ship term index)
|
|
?~ node ~
|
|
?: ?=(%empty -.children.u.node)
|
|
~
|
|
`p.children.u.node
|
|
::
|
|
++ get-node
|
|
|= [=ship =term =index:store]
|
|
^- (unit node:store)
|
|
=/ parent-graph=(unit marked-graph:store)
|
|
(~(get by graphs) [ship term])
|
|
?~ parent-graph ~
|
|
=/ node=(unit node:store) ~
|
|
=/ =graph:store p.u.parent-graph
|
|
|-
|
|
?~ index
|
|
node
|
|
?~ t.index
|
|
(get:orm graph i.index)
|
|
=. node (get:orm graph i.index)
|
|
?~ node ~
|
|
?- -.children.u.node
|
|
%empty ~
|
|
%graph $(graph p.children.u.node, index t.index)
|
|
==
|
|
--
|
|
::
|
|
++ on-arvo
|
|
|= [=wire =sign-arvo]
|
|
^- (quip card _this)
|
|
?+ wire (on-arvo:def wire sign-arvo)
|
|
::
|
|
:: old wire, do nothing
|
|
[%graph *] [~ this]
|
|
::
|
|
[%validator @ ~]
|
|
:_ this
|
|
=* validator i.t.wire
|
|
=/ =rave:clay [%next %b [%da now.bowl] /[validator]]
|
|
[%pass wire %arvo %c %warp our.bowl [%home `rave]]~
|
|
::
|
|
[%try-rejoin @ *]
|
|
=/ rid=resource:store (de-path:res t.t.wire)
|
|
=/ nack-count (slav %ud i.t.wire)
|
|
?> ?=([%behn %wake *] sign-arvo)
|
|
~? ?=(^ error.sign-arvo)
|
|
"behn errored in backoff timers, continuing anyway"
|
|
=/ new=^wire [%try-rejoin (scot %ud +(nack-count)) t.t.wire]
|
|
:_ this
|
|
[%pass new %agent [entity.rid %graph-push-hook] %watch resource+t.t.wire]~
|
|
==
|
|
::
|
|
++ on-agent
|
|
|= [=wire =sign:agent:gall]
|
|
^- (quip card _this)
|
|
?. ?=([%try-rejoin @ *] wire)
|
|
(on-agent:def wire sign)
|
|
?. ?=(%watch-ack -.sign)
|
|
[~ this]
|
|
=/ rid=resource:store (de-path:res t.t.wire)
|
|
?~ p.sign
|
|
=/ =cage [%pull-hook-action !>([%add entity.rid rid])]
|
|
:_ this
|
|
:~ [%pass / %agent [our.bowl %graph-pull-hook] %poke cage]
|
|
[%pass wire %agent [entity.rid %graph-push-hook] %leave ~]
|
|
==
|
|
=/ nack-count=@ud (slav %ud i.t.wire)
|
|
=/ wakeup=@da
|
|
(add now.bowl (mul ~s1 (bex (min 19 nack-count))))
|
|
:_ this
|
|
[%pass wire %arvo %b %wait wakeup]~
|
|
::
|
|
++ on-leave on-leave:def
|
|
++ on-fail on-fail:def
|
|
--
|