urbit/pkg/arvo/app/graph-store.hoon

1164 lines
34 KiB
Plaintext
Raw Normal View History

:: graph-store [landscape]
::
::
/+ store=graph-store, sigs=signatures, res=resource, default-agent, dbug, verb,
2020-12-02 10:03:05 +03:00
*migrate
~% %graph-store-top ..part ~
2020-06-02 00:07:31 +03:00
|%
+$ card card:agent:gall
+$ versioned-state
$% state-0
2020-10-29 06:11:18 +03:00
state-1
state-2
state-3
2020-06-02 00:07:31 +03:00
==
::
+$ state-0 [%0 network:zero:store]
+$ state-1 [%1 network:zero:store]
+$ state-2 [%2 network:zero:store]
+$ state-3 [%3 network:store]
2020-10-29 06:11:18 +03:00
::
2020-06-10 23:47:18 +03:00
++ orm orm:store
++ orm-log orm-log:store
+$ debug-input [%validate-graph =resource:store]
2020-06-02 00:07:31 +03:00
--
::
=| state-3
2020-06-02 00:07:31 +03:00
=* state -
::
%- agent:dbug
%+ verb |
2020-06-02 00:07:31 +03:00
^- agent:gall
~% %graph-store-agent ..card ~
2020-06-02 00:07:31 +03:00
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
::
++ on-init [~ this]
++ on-save !>(state)
++ on-load
2020-10-29 06:11:18 +03:00
|= =old=vase
2020-06-02 00:07:31 +03:00
^- (quip card _this)
2020-10-29 06:11:18 +03:00
=+ !<(old=versioned-state old-vase)
=| cards=(list card)
|^
2020-10-29 06:11:18 +03:00
?- -.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]]
2020-10-29 06:11:18 +03:00
::
graphs.old
%- ~(run by graphs.old)
|= [=graph:zero:store q=(unit mark)]
^- [graph:zero:store (unit mark)]
:- (convert-unix-timestamped-graph:zero-load graph)
2020-10-29 06:11:18 +03:00
?^ q q
`%graph-validator-link
::
update-logs.old
%- ~(run by update-logs.old)
|=(a=* *update-log:zero:store)
2020-10-29 06:11:18 +03:00
==
::
%1
%_ $
-.old %2
graphs.old (~(run by graphs.old) change-revision-graph:zero-load)
::
update-logs.old
%- ~(run by update-logs.old)
|=(a=* *update-log:zero:store)
==
::
2021-03-18 10:02:39 +03:00
%2
%_ $
-.old %3
update-logs.old (~(run by update-logs.old) update-log-to-one:store)
graphs.old (~(run by graphs.old) marked-graph-to-one:store)
archive.old (~(run by archive.old) marked-graph-to-one:store)
==
::
%3 [cards this(state old)]
2020-10-29 06:11:18 +03:00
==
::
++ zero-load
:: =* infinitely recurses
=, store=zero:store
=, orm=orm:zero:store
=, orm-log=orm-log:zero:store
|%
++ 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
:_ ~ :- %0
:_ [%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)
--
--
2020-06-02 00:07:31 +03:00
::
++ 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
|= =action:store
^- (list card)
[%give %fact ~ [%graph-update-1 !>([now.bowl action])]]~
--
::
2020-06-02 00:07:31 +03:00
++ on-poke
~/ %graph-store-poke
2020-06-02 00:07:31 +03:00
|= [=mark =vase]
^- (quip card _this)
|^
?> (team:title our.bowl src.bowl)
=^ cards state
?+ mark (on-poke:def mark vase)
%graph-update-1 (graph-update !<(update:store vase))
%noun (debug !<(debug-input vase))
%import (poke-import q.vase)
2020-06-02 00:07:31 +03:00
==
[cards this]
::
++ graph-update
|= =update:store
2020-06-02 00:07:31 +03:00
^- (quip card _state)
|^
=? 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)
== ==
~| "validation of graph {<resource>} failed using mark {<mark>}"
?> (validate-graph graph mark)
=/ =logged-update:store
[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
2020-12-11 07:57:20 +03:00
:~ (give [/keys ~] %keys (~(put in ~(key by graphs)) resource))
2020-12-11 06:05:40 +03:00
(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 [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
2020-07-21 21:04:18 +03:00
graph (add-node-at-index graph index node mark)
==
::
++ add-node-at-index
2020-07-21 21:04:18 +03:00
=| parent-hash=(unit hash:store)
|= $: =graph:store
=index:store
=node:store
mark=(unit mark:store)
==
^- graph:store
2020-07-21 21:04:18 +03:00
?< ?=(~ 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
2020-07-21 21:04:18 +03:00
[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 [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]
==
2020-06-05 23:31:55 +03:00
::
:: 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))
::
2020-06-05 23:31:55 +03:00
++ remove-indices
=| affected=(set index:store)
2020-06-05 23:31:55 +03:00
|= [=resource:store =graph:store indices=(list index:store)]
^- [(set index:store) graph:store]
?~ indices [affected graph]
=^ new-affected graph
(remove-index graph i.indices)
2020-06-05 23:31:55 +03:00
%_ $
indices t.indices
affected (~(uni in affected) new-affected)
==
::
++ get-descendants
|= =graph:store
=| indices=(list index:store)
2021-01-12 01:15:14 +03:00
=/ nodes (tap:orm:store graph)
%- ~(gas in *(set index:store))
|- =* tap-nodes $
^+ indices
%- zing
2021-01-12 01:15:14 +03:00
%+ turn nodes
|= [atom =node:store]
^- (list index:store)
%+ welp
2021-01-12 01:15:14 +03:00
index.post.node^~
?. ?=(%graph -.children.node)
~
%_ tap-nodes
nodes (tap:orm p.children.node)
2020-06-05 23:31:55 +03:00
==
::
++ remove-index
=| indices=(set index:store)
2020-06-05 23:31:55 +03:00
|= [=graph:store =index:store]
2021-01-12 01:15:14 +03:00
^- [(set index:store) graph:store]
?~ index [indices graph]
2020-06-05 23:31:55 +03:00
=* atom i.index
:: last index in list
::
?~ t.index
2021-01-12 01:15:14 +03:00
=^ rm-node graph (del:orm graph atom)
?~ rm-node `graph
?. ?=(%graph -.children.u.rm-node)
`graph
=/ new-indices
2021-01-12 01:15:14 +03:00
(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)
2020-06-05 23:31:55 +03:00
--
::
++ 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 [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!"
2020-09-04 08:35:03 +03:00
?> (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
[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
2021-03-11 07:00:50 +03:00
%- 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=action:store]
^- (list card)
[%give %fact paths [%graph-update-1 !>([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
=/ =dais:clay
.^ =dais:clay
%cb
/(scot %p our.bowl)/[q.byk.bowl]/(scot %da now.bowl)/[u.mark]
==
|- ^- ?
?~ graph %.y
%+ roll (tap:orm graph)
|= [[=atom =node:store] out=?]
^- ?
?& ?=(^ (vale:dais [atom post.node]))
?- -.children.node
%empty %.y
%graph ^$(graph p.children.node)
== ==
2020-12-01 00:08:15 +03:00
::
++ poke-import
|= arc=*
^- (quip card _state)
2020-12-02 10:03:05 +03:00
|^
=/ sty=state-3 [%3 (remake-network ;;(tree-network +.arc))]
2020-12-01 00:08:15 +03:00
:_ 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)
2020-12-02 10:03:05 +03:00
::
+$ 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
$: p=time
2020-12-02 10:03:05 +03:00
$= q
$% [%add-graph =resource:store =tree-graph mark=(unit ^mark) ow=?]
[%add-nodes =resource:store nodes=(tree [index:store tree-node])]
2020-12-02 10:03:05 +03:00
[%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
:- p.t
2020-12-02 10:03:05 +03:00
?- -.q.t
%add-graph
:* %add-graph
resource.q.t
(remake-graph tree-graph.q.t)
mark.q.t
ow.q.t
==
::
2020-12-02 10:03:05 +03:00
%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))
--
2020-12-01 00:08:15 +03:00
::
++ 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]
2020-06-02 00:07:31 +03:00
--
::
++ on-peek
~/ %graph-store-peek
2020-06-02 00:07:31 +03:00
|= =path
^- (unit (unit cage))
|^
?> (team:title our.bowl src.bowl)
2020-06-02 00:07:31 +03:00
?+ path (on-peek:def path)
2020-10-21 08:59:39 +03:00
[%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-1
!>(`update:store`[now.bowl [%keys ~(key by graphs)]])
::
[%x %tags ~]
:- ~ :- ~ :- %graph-update-1
!>(`update:store`[now.bowl [%tags ~(key by tag-queries)]])
::
[%x %tag-queries ~]
:- ~ :- ~ :- %graph-update-1
!>(`update:store`[now.bowl [%tag-queries tag-queries]])
::
2020-06-12 21:02:52 +03:00
[%x %graph @ @ ~]
=/ =ship (slav %p i.t.t.path)
=/ =term i.t.t.t.path
2020-07-07 03:02:15 +03:00
=/ result=(unit marked-graph:store)
(~(get by graphs) [ship term])
?~ result [~ ~]
:- ~ :- ~ :- %graph-update-1
!> ^- update:store
:- now.bowl
[%add-graph [ship term] `graph:store`p.u.result q.u.result %.y]
2020-09-18 22:50:54 +03:00
::
:: 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])
2020-09-18 23:50:34 +03:00
?~ result
~& no-archived-graph+[ship term]
[~ ~]
:- ~ :- ~ :- %graph-update-1
2020-09-18 22:50:54 +03:00
!> ^- update:store
:- now.bowl
[%add-graph [ship term] `graph:store`p.u.result q.u.result %.y]
2020-12-01 00:08:15 +03:00
::
[%x %export ~]
``noun+!>(state)
::
[%x %graph-subset @ @ @ @ ~]
2020-07-07 03:02:15 +03:00
=/ =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)
2020-07-07 03:02:15 +03:00
=/ graph=(unit marked-graph:store)
(~(get by graphs) [ship term])
?~ graph [~ ~]
:- ~ :- ~ :- %graph-update-1
!> ^- update:store
:- now.bowl
:+ %add-nodes
[ship term]
%- ~(gas by *(map index:store node:store))
%+ turn (tap:orm `graph:store`(subset:orm p.u.graph start end))
|= [=atom =node:store]
^- [index:store node:store]
[~[atom] node]
2021-01-11 02:51:36 +03:00
::
[%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 @ @ @ *]
2020-07-07 03:02:15 +03:00
=/ =ship (slav %p i.t.t.path)
=/ =term i.t.t.t.path
=/ =index:store
2020-10-05 08:27:26 +03:00
(turn t.t.t.t.path (cury slav %ud))
=/ node=(unit node:store) (get-node ship term index)
?~ node [~ ~]
:- ~ :- ~ :- %graph-update-1
!> ^- update:store
:- now.bowl
:+ %add-nodes
[ship term]
(~(gas by *(map index:store node:store)) [index u.node] ~)
2020-11-24 08:39:53 +03:00
::
[%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)
2020-11-24 08:39:53 +03:00
=/ =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-1
2020-11-24 08:39:53 +03:00
!> ^- update:store
:- now.bowl
2020-11-24 08:39:53 +03:00
:+ %add-nodes
[ship term]
%- ~(gas by *(map index:store node:store))
2020-12-11 06:05:40 +03:00
:: TODO time complexity not desirable
:: replace with custom ordered map functions
%+ turn
=- ?.(older (slag (safe-sub (lent -) count) -) (scag count -))
2020-11-24 08:39:53 +03:00
%- tap:orm
%+ subset: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-1
2020-11-24 08:39:53 +03:00
!> ^- update:store
:- now.bowl
2020-11-24 08:39:53 +03:00
:+ %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 @ @ @ @ @ *]
2020-07-07 03:02:15 +03:00
=/ =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)
2020-07-07 03:02:15 +03:00
=/ =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-1
!> ^- update:store
:- now.bowl
:+ %add-nodes
[ship term]
%- ~(gas by *(map index:store node:store))
%+ turn (tap:orm `graph:store`(subset:orm p.children.u.node end start))
|= [=atom =node:store]
^- [index:store node:store]
[(snoc index atom) node]
==
2020-08-19 22:22:20 +03:00
::
[%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+!>((subset: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])
(peek:orm-log:store update-log)
(bind result |=([=time update:store] time))
==
2020-12-11 06:05:40 +03:00
::
++ safe-sub
|= [a=@ b=@]
^- @
?: (gte b a)
0
(sub a b)
::
2020-11-24 08:39:53 +03:00
++ 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)
2020-07-07 03:02:15 +03:00
=/ parent-graph=(unit marked-graph:store)
(~(get by graphs) [ship term])
2020-06-20 22:56:00 +03:00
?~ parent-graph ~
=/ node=(unit node:store) ~
2020-07-07 03:02:15 +03:00
=/ =graph:store p.u.parent-graph
|-
?~ index
node
?~ t.index
(get:orm graph i.index)
2020-06-20 22:56:00 +03:00
=. node (get:orm graph i.index)
?~ node ~
?- -.children.u.node
%empty ~
2020-06-20 22:56:00 +03:00
%graph $(graph p.children.u.node, index t.index)
==
--
2020-06-02 00:07:31 +03:00
::
++ 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
2020-10-30 03:05:59 +03:00
=/ =rave:clay [%next %b [%da now.bowl] /[validator]]
[%pass wire %arvo %c %warp our.bowl [%home `rave]]~
2020-12-01 00:08:15 +03:00
::
[%try-rejoin @ *]
=/ rid=resource:store (de-path:res t.t.wire)
=/ nack-count (slav %ud i.t.wire)
2020-12-08 03:22:26 +03:00
?> ?=([%behn %wake *] sign-arvo)
2020-12-01 00:08:15 +03:00
~? ?=(^ 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]~
==
::
2020-12-01 00:08:15 +03:00
++ 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 ~]
==
2020-12-01 00:08:15 +03:00
=/ 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]~
::
2020-06-02 00:07:31 +03:00
++ on-leave on-leave:def
++ on-fail on-fail:def
--