1
1
mirror of https://github.com/urbit/shrub.git synced 2024-12-13 16:03:36 +03:00
shrub/pkg/landscape/lib/graph-store.hoon
2022-12-08 07:53:00 -06:00

995 lines
23 KiB
Plaintext

/- sur=graph-store, pos=post, pull-hook, hark=hark-store
/+ res=resource, migrate
=< [sur .]
=< [pos .]
=, sur
=, pos
|%
++ hark-content
|= =content
^- content:hark
?- -.content
%text content
%mention ship+ship.content
%url text+url.content
%code text+'A code excerpt'
%reference text+'A reference'
==
::
++ hark-contents
|= cs=(list content)
(turn cs hark-content)
:: NOTE: move these functions to zuse
++ nu :: parse number as hex
|= jon=json
?> ?=([%s *] jon)
(rash p.jon hex)
::
++ re :: recursive reparsers
|* [gar=* sef=_|.(fist:dejs-soft:format)]
|= jon=json
^- (unit _gar)
=- ~! gar ~! (need -) -
((sef) jon)
::
++ dank :: tank
^- $-(json (unit tank))
=, ^? dejs-soft:format
%+ re *tank |. ~+
%- of :~
leaf+sa
palm+(ot style+(ot mid+sa cap+sa open+sa close+sa ~) lines+(ar dank) ~)
rose+(ot style+(ot mid+sa open+sa close+sa ~) lines+(ar dank) ~)
==
::
++ orm ((on atom node) gth)
++ orm-log ((on time logged-update) gth)
::
++ enjs
=, enjs:format
|%
::
++ signatures
|= s=^signatures
^- json
[%a (turn ~(tap in s) signature)]
::
++ signature
|= s=^signature
^- json
%- pairs
:~ [%signature s+(scot %ux p.s)]
[%ship (ship q.s)]
[%life (numb r.s)]
==
::
++ index
|= ind=^index
^- json
:- %s
?: =(~ ind)
'/'
%+ roll ind
|= [cur=@ acc=@t]
^- @t
=/ num (numb cur)
?> ?=(%n -.num)
(rap 3 acc '/' p.num ~)
::
++ uid
|= u=^uid
^- json
%- pairs
:~ [%resource (enjs:res resource.u)]
[%index (index index.u)]
==
::
++ content
|= c=^content
^- json
?- -.c
%mention (frond %mention (ship ship.c))
%text (frond %text s+text.c)
%url (frond %url s+url.c)
%reference (frond %reference (reference +.c))
%code
%+ frond %code
%- pairs
:- [%expression s+expression.c]
:_ ~
:- %output
:: virtualize output rendering, +tank:enjs:format might crash
::
=/ result=(each (list json) tang)
(mule |.((turn output.c tank)))
?- -.result
%& a+p.result
%| a+[a+[%s '[[output rendering error]]']~]~
==
==
::
++ reference
|= ref=^reference
|^
%+ frond -.ref
?- -.ref
%graph (graph +.ref)
%group (group +.ref)
%app (app +.ref)
==
::
++ graph
|= [grp=res gra=res idx=^index]
%- pairs
:~ graph+s+(enjs-path:res gra)
group+s+(enjs-path:res grp)
index+(index idx)
==
::
++ group
|= grp=res
s+(enjs-path:res grp)
::
++ app
|= [=^ship =desk p=^path]
%- pairs
:~ ship+s+(scot %p ship)
desk+s+desk
path+(path p)
==
--
::
++ maybe-post
|= mp=^maybe-post
^- json
?- -.mp
%| s+(scot %ux p.mp)
%& (post p.mp)
==
::
++ post
|= p=^post
^- json
%- pairs
:~ [%author (ship author.p)]
[%index (index index.p)]
[%time-sent (time time-sent.p)]
[%contents [%a (turn contents.p content)]]
[%hash ?~(hash.p ~ s+(scot %ux u.hash.p))]
[%signatures (signatures signatures.p)]
==
::
++ update
|= upd=^update
^- json
|^ (frond %graph-update (pairs ~[(encode q.upd)]))
::
++ encode
|= upd=action
^- [cord json]
?- -.upd
%add-graph
:- %add-graph
%- pairs
:~ [%resource (enjs:res resource.upd)]
[%graph (graph graph.upd)]
[%mark ?~(mark.upd ~ s+u.mark.upd)]
[%overwrite b+overwrite.upd]
==
::
%remove-graph
[%remove-graph (enjs:res resource.upd)]
::
%add-nodes
:- %add-nodes
%- pairs
:~ [%resource (enjs:res resource.upd)]
[%nodes (nodes nodes.upd)]
==
::
%remove-posts
:- %remove-posts
%- pairs
:~ [%resource (enjs:res resource.upd)]
[%indices (indices indices.upd)]
==
::
%add-signatures
:- %add-signatures
%- pairs
:~ [%uid (uid uid.upd)]
[%signatures (signatures signatures.upd)]
==
::
%remove-signatures
:- %remove-signatures
%- pairs
:~ [%uid (uid uid.upd)]
[%signatures (signatures signatures.upd)]
==
::
%add-tag
:- %add-tag
%- pairs
:~ [%term s+term.upd]
[%uid (uid uid.upd)]
==
::
%remove-tag
:- %remove-tag
%- pairs
:~ [%term s+term.upd]
[%uid (uid uid.upd)]
==
::
%archive-graph
[%archive-graph (enjs:res resource.upd)]
::
%unarchive-graph
[%unarchive-graph (enjs:res resource.upd)]
::
%keys
[%keys [%a (turn ~(tap in resources.upd) enjs:res)]]
::
%tags
[%tags [%a (turn ~(tap in tags.upd) |=(=term s+term))]]
::
%run-updates
[%run-updates ~]
::
%tag-queries
:- %tag-queries
%- pairs
%+ turn ~(tap by tag-queries.upd)
|= [=term uids=(set ^uid)]
^- [cord json]
[term [%a (turn ~(tap in uids) uid)]]
==
::
++ graph
|= g=^graph
^- json
%- pairs
%+ turn
(tap:orm g)
|= [a=atom n=^node]
^- [@t json]
:_ (node n)
=/ idx (numb a)
?> ?=(%n -.idx)
p.idx
::
++ node
|= n=^node
^- json
%- pairs
:~ [%post (maybe-post post.n)]
:- %children
?- -.children.n
%empty ~
%graph (graph +.children.n)
==
==
::
++ nodes
|= m=(map ^index ^node)
^- json
%- pairs
%+ turn ~(tap by m)
|= [n=^index o=^node]
^- [@t json]
:_ (node o)
=/ idx (index n)
?> ?=(%s -.idx)
p.idx
::
++ indices
|= i=(set ^index)
^- json
[%a (turn ~(tap in i) index)]
::
--
--
::
++ dejs
=, dejs:format
|%
++ update
|= jon=json
^- ^update
:- *time
^- action
=< (decode jon)
|%
++ decode
%- of
:~ [%add-nodes add-nodes]
[%remove-posts remove-posts]
[%add-signatures add-signatures]
[%remove-signatures remove-signatures]
::
[%add-graph add-graph]
[%remove-graph remove-graph]
::
[%add-tag add-tag]
[%remove-tag remove-tag]
::
[%archive-graph archive-graph]
[%unarchive-graph unarchive-graph]
[%run-updates run-updates]
::
[%keys keys]
[%tags tags]
[%tag-queries tag-queries]
==
::
++ add-graph
%- ot
:~ [%resource dejs:res]
[%graph graph]
[%mark (mu so)]
[%overwrite bo]
==
::
++ graph
|= a=json
^- ^graph
=/ or-mp ((on atom ^node) gth)
%+ gas:or-mp ~
%+ turn ~(tap by ((om node) a))
|* [b=cord c=*]
^- [atom ^node]
=> .(+< [b c]=+<)
[(rash b dem) c]
::
++ remove-graph (ot [%resource dejs:res]~)
++ archive-graph (ot [%resource dejs:res]~)
++ unarchive-graph (ot [%resource dejs:res]~)
::
++ add-nodes
%- ot
:~ [%resource dejs:res]
[%nodes nodes]
==
::
++ nodes (op ;~(pfix fas (more fas dem)) node)
::
++ node
%- ot
:~ [%post maybe-post]
[%children internal-graph]
==
::
++ internal-graph
|= jon=json
^- ^internal-graph
?~ jon
[%empty ~]
[%graph (graph jon)]
::
++ maybe-post
|= jon=json
^- ^maybe-post
?~ jon !!
?+ -.jon !!
%s [%| (nu jon)]
%o [%& (post jon)]
==
::
++ post
%- ot
:~ [%author (su ;~(pfix sig fed:ag))]
[%index index]
[%time-sent di]
[%contents (ar content)]
[%hash (mu nu)]
[%signatures (as signature)]
==
::
++ content
%- of
:~ [%mention (su ;~(pfix sig fed:ag))]
[%text so]
[%url so]
[%reference reference]
[%code eval]
==
::
++ reference
|^
%- of
:~ graph+graph
group+dejs-path:res
app+app
==
::
++ graph
%- ot
:~ group+dejs-path:res
graph+dejs-path:res
index+index
==
::
++ app
%- ot
:~ ship+(su ;~(pfix sig fed:ag))
desk+so
path+pa
==
--
::
++ tang
|= jon=^json
^- ^tang
?> ?=(%a -.jon)
%- zing
%+ turn
p.jon
|= jo=^json
^- (list tank)
?> ?=(%a -.jo)
%+ turn
p.jo
|= j=^json
?> ?=(%s -.j)
^- tank
leaf+(trip p.j)
::
++ eval
%- ot
:~ expression+so
output+tang
==
::
++ remove-posts
%- ot
:~ [%resource dejs:res]
[%indices (as index)]
==
::
++ add-signatures
%- ot
:~ [%uid uid]
[%signatures (as signature)]
==
::
++ remove-signatures
%- ot
:~ [%uid uid]
[%signatures (as signature)]
==
::
++ signature
%- ot
:~ [%hash nu]
[%ship (su ;~(pfix sig fed:ag))]
[%life ni]
==
::
++ uid
%- ot
:~ [%resource dejs:res]
[%index index]
==
::
++ index (su ;~(pfix fas (more fas dem)))
::
++ add-tag
%- ot
:~ [%term so]
[%uid uid]
==
::
++ remove-tag
%- ot
:~ [%term so]
[%uid uid]
==
::
++ keys
|= =json
*resources
::
++ tags
|= =json
*(set term)
::
++ tag-queries
|= =json
*^tag-queries
::
++ run-updates
|= a=json
^- [resource update-log]
[*resource *update-log]
--
++ pa
|= j=json
^- path
?> ?=(%s -.j)
?: =('/' p.j) /
(stab p.j)
::
--
::
++ create
|_ [our=ship now=time]
++ post
|= [=index contents=(list content)]
^- ^post
:* our
index
now
contents
~
*signatures
==
--
::
++ upgrade
|%
++ is-old-dm |=(r=resource =('dm--' (end [3 4] name.r)))
++ backup
|= =bowl:gall
|= [r=resource m=marked-graph]
^- card:agent:gall
=/ pax /(rap 3 'archive-' (scot %p entity.r) '-' name.r ~)/noun
=/ =cage drum-put+!>([pax (jam r m)])
[%pass /archive %agent [our.bowl %hood] %poke cage]
++ strip-sigs-graph
|= g=graph
^+ g
=* loop $
%+ gas:orm *graph
%+ turn (tap:orm g)
|= [key=@ val=node] :: optional: also strip out deleted messages?
=? children.val ?=(%graph -.children.val)
[%graph loop(g p.children.val)]
:- key
?. ?=(%& -.post.val)
val
val(signatures.p.post ~)
++ strip-sigs-log
|= u=update-log
%+ gas:orm-log *update-log
%+ turn (tap:orm-log u)
|= [key=@ upd=logged-update]
:- key
:- p.upd
?+ -.q.upd q.upd
%add-graph
q.upd(graph (strip-sigs-graph graph.q.upd))
::
%add-signatures
q.upd(signatures ~)
::
%remove-signatures
q.upd(signatures ~)
::
%add-nodes
%= q.upd
nodes
%- ~(run by nodes.q.upd)
|= =node
^+ node
%= node
children
?. ?=(%graph -.children.node)
children.node
[%graph (strip-sigs-graph p.children.node)]
::
post
?. ?=(%& -.post.node)
post.node
=. signatures.p.post.node ~
post.node
==
==
==
::
++ nuke-groups
|= =bowl:gall
|^ ^- (list card:agent:gall)
?. .^(? (gall-scry %u %groups))
~
=+ .^(=desk (gall-scry %d %groups))
:~ [%pass /nuke %agent [our.bowl %hood] %poke kiln-nuke+!>([desk &])]
[%pass /nuke %agent [our.bowl %docket] %poke docket-uninstall+!>(desk)]
[%pass /nuke %agent [our.bowl %docket] %poke docket-uninstall+!>(%talk)]
==
::
++ gall-scry
|= [=care:clay dap=dude:gall]
^- path
/(cat 3 %g care)/(scot %p our.bowl)/[dap]/(scot %da now.bowl)
--
::
:: +two
::
++ marked-graph-to-two
|= [=graph:one m=(unit mark)]
[(graph-to-two graph) m]
::
++ graph-to-two
|= =graph:one
(graph:(upgrade ,post:one ,maybe-post:two) graph post-to-two)
::
++ post-to-two
|= p=post:one
^- maybe-post:two
[%& p]
::
::
:: +one
::
++ update-log-to-one
|= =update-log:zero
^- update-log:one
%+ gas:orm-log:one *update-log:one
%+ turn (tap:orm-log:zero update-log)
|= [=time =logged-update:zero]
^- [^time logged-update:one]
:- time
:- p.logged-update
(logged-update-to-one q.logged-update)
::
++ logged-update-to-one
|= upd=logged-update-0:zero
^- logged-action:one
?+ -.upd upd
%add-graph upd(graph (graph-to-one graph.upd))
%add-nodes upd(nodes (~(run by nodes.upd) node-to-one))
==
::
++ node-to-one
|= =node:zero
(node:(upgrade ,post:zero ,post:one) node post-to-one)
::
++ graph-to-one
|= =graph:zero
(graph:(upgrade ,post:zero ,post:one) graph post-to-one)
::
++ marked-graph-to-one
|= [=graph:zero m=(unit mark)]
[(graph-to-one graph) m]
::
++ post-to-one
|= p=post:zero
^- post:one
p(contents (contents-to-one contents.p))
::
++ contents-to-one
|= cs=(list content:zero)
^- (list content:one)
%+ murn cs
|= =content:zero
^- (unit content:one)
?: ?=(%reference -.content) ~
`content
::
++ upgrade
|* [in-pst=mold out-pst=mold]
=>
|%
++ in-orm
((on atom in-node) gth)
+$ in-node
[post=in-pst children=in-internal-graph]
+$ in-graph
((mop atom in-node) gth)
+$ in-internal-graph
$~ [%empty ~]
$% [%graph p=in-graph]
[%empty ~]
==
::
++ out-orm
((on atom out-node) gth)
+$ out-node
[post=out-pst children=out-internal-graph]
+$ out-graph
((mop atom out-node) gth)
+$ out-internal-graph
$~ [%empty ~]
$% [%graph p=out-graph]
[%empty ~]
==
--
|%
::
++ graph
|= $: gra=in-graph
fn=$-(in-pst out-pst)
==
^- out-graph
%+ gas:out-orm *out-graph
^- (list [atom out-node])
%+ turn (tap:in-orm gra)
|= [a=atom n=in-node]
^- [atom out-node]
[a (node n fn)]
::
++ node
|= [nod=in-node fn=$-(in-pst out-pst)]
^- out-node
:- (fn post.nod)
^- out-internal-graph
?: ?=(%empty -.children.nod)
[%empty ~]
[%graph (graph p.children.nod fn)]
--
::
++ zero-load
:: =* infinitely recurses
=, store=zero
=, orm=orm:zero
=, orm-log=orm-log:zero
|%
++ 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)
--
--
++ import
|= [arc=* our=ship]
^- (quip card:agent:gall [%7 network])
|^
=/ sty [%7 (remake-network ;;(tree-network +.arc))]
:_ sty
%+ turn ~(tap by graphs.sty)
|= [rid=resource =marked-graph]
^- card:agent:gall
?: =(our entity.rid)
=/ =cage [%push-hook-action !>([%add rid])]
[%pass / %agent [our %graph-push-hook] %poke cage]
(try-rejoin rid 0)
::
+$ tree-network
$: graphs=tree-graphs
tag-queries=(tree [term (tree uid)])
update-logs=tree-update-logs
archive=tree-graphs
~
==
+$ tree-graphs (tree [resource tree-marked-graph])
+$ tree-marked-graph [p=tree-graph q=(unit ^mark)]
+$ tree-graph (tree [atom tree-node])
+$ tree-node [post=tree-maybe-post children=tree-internal-graph]
+$ tree-internal-graph
$~ [%empty ~]
$% [%graph p=tree-graph]
[%empty ~]
==
+$ tree-update-logs (tree [resource tree-update-log])
+$ tree-update-log (tree [time tree-logged-update])
+$ tree-logged-update
$: p=time
$= q
$% [%add-graph =resource =tree-graph mark=(unit ^mark) ow=?]
[%add-nodes =resource nodes=(tree [index tree-node])]
[%remove-posts =resource indices=(tree index)]
[%add-signatures =uid signatures=tree-signatures]
[%remove-signatures =uid signatures=tree-signatures]
==
==
+$ tree-signatures (tree signature)
+$ tree-maybe-post (each tree-post hash)
+$ tree-post
$: author=ship
=index
time-sent=time
contents=(list content)
hash=(unit hash)
signatures=tree-signatures
==
::
++ remake-network
|= t=tree-network
^- network
:* (remake-graphs graphs.t)
(remake-jug:migrate tag-queries.t)
(remake-update-logs update-logs.t)
(remake-graphs archive.t)
~
==
::
++ remake-graphs
|= t=tree-graphs
^- graphs
%- remake-map:migrate
(~(run by t) remake-marked-graph)
::
++ remake-marked-graph
|= t=tree-marked-graph
^- marked-graph
[(remake-graph p.t) q.t]
::
++ remake-graph
|= t=tree-graph
^- graph
%+ gas:orm *graph
%+ turn ~(tap by t)
|= [a=atom tn=tree-node]
^- [atom node]
[a (remake-node tn)]
::
++ remake-internal-graph
|= t=tree-internal-graph
^- internal-graph
?: ?=(%empty -.t)
[%empty ~]
[%graph (remake-graph p.t)]
::
++ remake-node
|= t=tree-node
^- node
:- (remake-post post.t)
(remake-internal-graph children.t)
::
++ remake-update-logs
|= t=tree-update-logs
^- update-logs
%- remake-map:migrate
(~(run by t) remake-update-log)
::
++ remake-update-log
|= t=tree-update-log
^- update-log
=/ ulm ((on time logged-update) gth)
%+ gas:ulm *update-log
%+ turn ~(tap by t)
|= [=time tlu=tree-logged-update]
^- [^time logged-update]
[time (remake-logged-update tlu)]
::
++ remake-logged-update
|= t=tree-logged-update
^- logged-update
:- 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:migrate
(~(run by nodes.q.t) remake-node)
::
%remove-posts
[%remove-posts resource.q.t (remake-set:migrate indices.q.t)]
::
%add-signatures
[%add-signatures uid.q.t (remake-set:migrate signatures.q.t)]
::
%remove-signatures
[%remove-signatures uid.q.t (remake-set:migrate signatures.q.t)]
==
::
++ remake-post
|= t=tree-maybe-post
^- maybe-post
?- -.t
%| t
%& t(signatures.p (remake-set:migrate signatures.p.t))
==
::
++ try-rejoin
|= [rid=resource nack-count=@]
^- card:agent:gall
=/ res-path (en-path:res rid)
=/ wire [%try-rejoin (scot %ud nack-count) res-path]
=/ =cage
:- %pull-hook-action
!> ^- action:pull-hook
[%add [entity .]:rid]
[%pass wire %agent [our %graph-pull-hook] %poke cage]
--
--