shrub/pkg/arvo/app/dm-hook.hoon

282 lines
6.7 KiB
Plaintext
Raw Normal View History

2021-05-03 09:11:57 +03:00
:: dm-hook [landscape]: receive and send DMs
::
/+ default-agent, dbug, store=graph-store, graphlib=graph, agentio, resource
2021-05-03 09:11:57 +03:00
/+ sig=signatures, hook=dm-hook
::
|%
2021-05-03 09:11:57 +03:00
::
+$ base-state-0
$: screening=?
screened=(jug ship [=index:store =node:store])
pending=(jar ship atom)
==
::
+$ state-0 [%0 base-state-0]
+$ card card:agent:gall
2021-05-03 09:11:57 +03:00
+$ nodes (map index:store node:store)
--
::
=| state-0
=* state -
%- agent:dbug
^- agent:gall
::
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
gra ~(. graphlib bowl)
io ~(. agentio bowl)
pass pass:io
::
++ on-init
:_ this
:_ ~
2021-05-04 09:08:08 +03:00
=/ dms=(list resource)
2021-05-04 09:18:47 +03:00
?. .^(? (scry:io %gu %graph-store ~))
~
2021-05-04 09:08:08 +03:00
%+ skim ~(tap in get-keys:gra)
|=([ship name=term] ?=(^ (rush name ;~(pfix (jest 'dm--') (star next)))))
|^
%+ poke-our:pass %graph-store
%+ update:cg:gra now.bowl
:+ %add-graph [our.bowl %inbox]
2021-05-04 09:08:08 +03:00
[graph `%graph-validator-dm %.n]
::
++ dm-parser
;~(pfix (jest 'dm--') fed:ag)
::
++ counterparty
|= rid=resource
=/ =ship (rash name.rid dm-parser)
?. =(our.bowl ship) ship
entity.rid
::
++ graph
%+ roll dms
|= [rid=resource =graph:store]
=/ =ship (counterparty rid)
=| =post:store
=: author.post our.bowl
index.post [ship ~]
time-sent.post now.bowl
==
(put:orm:store graph `@`ship [%& post] %graph graph)
--
::
++ on-save !>(state)
++ on-load
|= old=vase
^- (quip card _this)
2021-04-30 07:16:03 +03:00
`this(state !<(state-0 old))
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
|^
?+ mark (on-poke:def mark vase)
2021-05-03 09:11:57 +03:00
%dm-hook-action
=+ !<(=action:hook vase)
=^ cards state
?+ -.action !!
%accept (accept-screen ship.action)
%decline (decline-screen ship.action)
%screen (set-screen screen.action)
==
[cards this]
::
2021-05-03 05:41:43 +03:00
%graph-update-2
=+ !<(=update:store vase)
2021-05-04 08:10:47 +03:00
?+ -.q.update !!
%add-nodes
?> ?=([@ %inbox] resource.q.update)
2021-04-30 07:16:03 +03:00
=^ cards state
?: =(our.bowl src.bowl)
2021-05-04 08:10:47 +03:00
(outgoing-add (hash-and-sign nodes.q.update))
2021-05-03 09:11:57 +03:00
?: &(screening !(dm-exists src.bowl))
(screen-add nodes.q.update)
2021-04-30 07:16:03 +03:00
(incoming-add nodes.q.update)
[cards this]
==
==
::
2021-05-04 08:10:47 +03:00
++ hash-and-sign
|= =nodes
%- ~(gas by *^nodes)
%+ turn ~(tap by nodes)
|= [=index:store =node:store]
^- [index:store node:store]
:- index
?> ?=(%& -.post.node)
=* p post.node
=/ =hash:store
`@ux`(sham [~ author time-sent contents]:p.p)
%_ node
hash.p.post `hash
::
signatures.p.post
%- ~(gas in *signatures:store)
[(sign:sig our.bowl now.bowl hash)]~
==
::
2021-05-03 09:11:57 +03:00
++ give
|= =action:hook
^- card
(fact:io dm-hook-action+!>(action) ~[/updates])
::
++ accept-screen
|= =ship
^- (quip card _state)
=/ unscreened=nodes
%- ~(gas by *nodes)
~(tap in (~(get ju screened) ship))
:_ state(screened (~(del by screened) ship))
%+ welp (add-missing-root ship)
:~ %+ poke-our:pass %graph-store
(update:cg:gra now.bowl %add-nodes [our.bowl %inbox] unscreened)
::
(give %accept ship)
==
::
++ set-screen
|= screen=?
:_ state(screening screen)
(give %screen screen)^~
::
++ decline-screen
|= =ship
^- (quip card _state)
:_ state(screened (~(del by screened) ship))
(give %decline ship)^~
::
++ screen-add
|= =nodes
?> =(1 ~(wyt by nodes))
=/ ship-screen (~(get ju screened) src.bowl)
=. ship-screen (~(uni in ship-screen) (normalize-incoming nodes))
`state(screened (~(put by screened) src.bowl ship-screen))
::
++ dm-exists
|= =ship
=/ =index:store
[ship ~]
(check-node-existence:gra [our.bowl %inbox] index)
::
2021-04-23 07:14:47 +03:00
++ add-node
|= [=index:store =node:store]
^- update:store
:^ now.bowl %add-nodes [our.bowl %inbox]
2021-05-03 09:11:57 +03:00
(~(gas by *nodes) [index node] ~)
2021-04-23 07:14:47 +03:00
::
++ add-missing-root
|= =ship
^- (list card)
2021-05-03 09:11:57 +03:00
?: (dm-exists ship) ~
2021-04-23 07:14:47 +03:00
=/ =index:store
[ship ~]
2021-05-03 05:41:43 +03:00
=| =post:store
=: author.post our.bowl
index.post index
time-sent.post now.bowl
2021-04-23 07:14:47 +03:00
==
2021-05-03 05:41:43 +03:00
=/ =node:store
[%&^post %empty ~]
2021-04-30 07:16:03 +03:00
(poke-our:pass %graph-store (update:cg:gra (add-node index node)))^~
2021-04-23 07:14:47 +03:00
::
2021-04-23 04:39:29 +03:00
++ outgoing-add
2021-05-03 09:11:57 +03:00
|= =nodes
2021-04-30 07:16:03 +03:00
^- (quip card _state)
=/ nodes=(list [=index:store =node:store])
~(tap by nodes)
=| cards=(list card)
|- ^- (quip card _state)
?~ nodes [cards state]
?> ?=([@ @ ~] index.i.nodes)
=/ =ship i.index.i.nodes
=/ =dock [ship %dm-hook]
=/ =wire /dm/(scot %p ship)
2021-04-23 07:14:47 +03:00
=/ =cage
2021-04-30 07:16:03 +03:00
(update:cg:gra (add-node [index node]:i.nodes))
%= $
nodes t.nodes
pending (~(add ja pending) ship now.bowl)
2021-04-23 07:14:47 +03:00
::
2021-04-30 07:16:03 +03:00
cards
;: welp
cards
(add-missing-root ship)
:~ (~(poke pass wire) dock cage)
(poke-our:pass %graph-store cage)
==
==
==
::
2021-05-03 09:11:57 +03:00
++ normalize-incoming
|= =nodes
^- ^nodes
%- ~(gas by *^nodes)
%+ turn ~(tap by nodes)
|= [=index:store =node:store]
?> ?=([@ @ ~] index)
?> ?=(%empty -.children.node)
2021-05-03 05:41:43 +03:00
?> ?=(%& -.post.node)
=/ new-index=index:store
2021-05-03 09:11:57 +03:00
[src.bowl now.bowl ~]
2021-05-03 05:41:43 +03:00
=. index.p.post.node
new-index
[new-index node]
2021-05-03 09:11:57 +03:00
::
++ incoming-add
|= =nodes
^- (quip card _state)
:_ state
?> =(1 ~(wyt by nodes))
=* ship src.bowl
%+ snoc (add-missing-root ship)
%+ poke-our:pass %graph-store
%+ update:cg:gra now.bowl
[%add-nodes [our.bowl %inbox] (normalize-incoming nodes)]
--
::
2021-05-03 09:11:57 +03:00
++ on-watch
|= =path
?. ?=([%updates ~] path)
(on-watch:def path)
:_ this
:~ (fact-init:io dm-hook-action+!>([%pendings ~(key by screened)]))
(fact-init:io dm-hook-action+!>([%screen screening]))
==
::
++ on-peek on-peek:def
++ on-leave on-leave:def
2021-04-30 07:16:03 +03:00
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
|^
?. ?=([%dm @ ~] wire)
(on-agent:def wire sign)
?> ?=(%poke-ack -.sign)
=/ =ship
(slav %p i.t.wire)
=^ acked=atom state
(remove-pending ship)
?~ p.sign
`this
:_ this
:_ ~
=+ indices=(~(gas in *(set index:store)) ~[ship acked] ~)
%+ poke-our:pass %graph-store
2021-05-03 05:41:43 +03:00
(update:cg:gra now.bowl %remove-posts [our.bowl %inbox] indices)
2021-04-30 07:16:03 +03:00
::
++ remove-pending
|= =ship
^- [atom _state]
=/ pend-ship=(list atom)
(flop (~(get ja pending) ship))
?> ?=(^ pend-ship)
[i.pend-ship state(pending (~(put by pending) ship (flop t.pend-ship)))]
--
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--