tloncorp/landscape
1
1
Fork 0
mirror of https://github.com/tloncorp/landscape.git synced 2024-11-27 06:53:33 +03:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #283 from tloncorp/mp/contacts

Browse Source 
New %contacts agent. Implement contact book functionality with support for user-defined fields.
This commit is contained in:
Mikolaj 2024-10-11 12:00:20 +08:00 committed by GitHub
commit 9a59e2ab9b
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
29 changed files with 3547 additions and 353 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

680
desk/app/contacts.hoon
View File

@ -1,28 +1,37 @@
/- *contacts
/+ default-agent, dbug, verb
/+ default-agent, dbug, verb, neg=negotiate
/+ *contacts
::
:: performance, keep warm
/+ contacts-json
/+ j0=contacts-json-0, j1=contacts-json-1, mark-warmer
::
|%
:: conventions
::
:: .con: a contact
:: .rof: our profile
:: .rol: our full rolodex
:: .rol: [legacy] our full rolodex
:: .far: foreign peer
:: .for: foreign profile
:: .sag: foreign subscription state
::
+| %types
+$ card card:agent:gall
+$ state-0 [%0 rof=$@(~ profile) rol=rolodex]
+$ card card:agent:gall
+$ state-1 $: %1
rof=profile
=book
=peers
retry=(map ship @da) :: retry sub at time
==
--
::
%- %^ agent:neg
notify=|
[~.contacts^%1 ~ ~]
[~.contacts^[~.contacts^%1 ~ ~] ~ ~]
%- agent:dbug
%+ verb |
^- agent:gall
=| state-0
=| state-1
=* state -
::
=< |_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
@ -62,49 +71,19 @@
=^ cards state abet:(agent:cor wire sign)
[cards this]
::
++ on-arvo on-arvo:def
++ on-arvo
|= [=wire sign=sign-arvo]
=^ cards state abet:(arvo:cor wire sign)
[cards this]
::
++ on-fail on-fail:def
--
::
|%
::
+| %help
::
++ do-edit
|= [c=contact f=field]
^+ c
?- -.f
%nickname c(nickname nickname.f)
%bio c(bio bio.f)
%status c(status status.f)
%color c(color color.f)
::
%avatar ~| "cannot add a data url to avatar!"
?> ?| ?=(~ avatar.f)
!=('data:' (end 3^5 u.avatar.f))
==
c(avatar avatar.f)
::
%cover ~| "cannot add a data url to cover!"
?> ?| ?=(~ cover.f)
!=('data:' (end 3^5 u.cover.f))
==
c(cover cover.f)
::
%add-group c(groups (~(put in groups.c) flag.f))
::
%del-group c(groups (~(del in groups.c) flag.f))
==
::
++ mono
|= [old=@da new=@da]
^- @da
?: (lth old new) new
(add old ^~((div ~s1 (bex 16))))
::
+| %state
::
:: namespaced to avoid accidental direct reference
:: namespaced to avoid accidental direct reference
::
++ raw
=| out=(list card)
@ -121,10 +100,10 @@
::
+| %operations
::
:: |pub: publication mgmt
:: +pub: publication management
::
:: - /news: local updates to our profile and rolodex
:: - /contact: updates to our profile
:: - /v1/news: local updates to our profile and rolodex
:: - /v1/contact: updates to our profile
::
:: as these publications are trivial, |pub does *not*
:: make use of the +abet pattern. the only behavior of note
@ -134,74 +113,166 @@
:: /epic protocol versions are even more trivial,
:: published ad-hoc, elsewhere.
::
:: Facts are always send in the following order:
:: 1. [legacy] /news
:: 2. /v1/news
:: 3. /v1/contact
::
++ pub
=> |%
:: if this proves to be too slow, the set of paths
:: should be maintained statefully: put on +p-init:pub,
:: filtered at some interval (on +load?) to avoid a space leak.
::
:: XX number of peers is usually around 5.000.
:: this means that the number of subscribers is about the
:: same. Thus on each contact update we need to filter
:: over 5.000 elements: do some benchmarking.
::
++ subs
^- (set path)
%- ~(rep by sup.bowl)
|= [[duct ship pat=path] acc=(set path)]
?.(?=([%contact *] pat) acc (~(put in acc) pat))
::
?.(?=([%v1 %contact *] pat) acc (~(put in acc) pat))
++ fact
|= [pat=(set path) u=update]
^- gift:agent:gall
[%fact ~(tap in pat) upd:mar !>(u)]
[%fact ~(tap in pat) %contact-update-1 !>(u)]
--
::
|%
++ p-anon ?.(?=([@ ^] rof) cor (p-diff ~))
:: +p-anon: delete our profile
::
++ p-edit
|= l=(list field)
=/ old ?.(?=([@ ^] rof) *contact con.rof)
=/ new (roll l |=([f=field c=_old] (do-edit c f)))
++ p-anon ?.(?=([@ ^] rof) cor (p-commit-self ~))
:: +p-self: edit our profile
::
++ p-self
|= con=(map @tas value)
=/ old=contact
?.(?=([@ ^] rof) *contact con.rof)
=/ new=contact
(do-edit old con)
?: =(old new)
cor
(p-diff:pub new)
?> (sane-contact new)
(p-commit-self new)
:: +p-page-spot: add ship as a contact
::
++ p-diff
|= con=$@(~ contact)
=/ p=profile [?~(rof now.bowl (mono wen.rof now.bowl)) con]
(give:(p-news(rof p) our.bowl con) (fact subs full+p))
++ p-page-spot
|= [who=ship mod=contact]
?: (~(has by book) who)
~| "peer {<who>} is already a contact" !!
=/ con=contact
~| "peer {<who>} not found"
=/ far=foreign
(~(got by peers) who)
?~ for.far *contact
con.for.far
?> (sane-contact mod)
(p-commit-page who con mod)
:: +p-page: create new contact page
::
++ p-page
|= [=kip mod=contact]
?@ kip
(p-page-spot kip mod)
?: (~(has by book) kip)
~| "contact page {<cid>} already exists" !!
?> (sane-contact mod)
(p-commit-page kip ~ mod)
:: +p-edit: edit contact page overlay
::
++ p-edit
|= [=kip mod=contact]
=/ =page
~| "contact page {<kip>} does not exist"
(~(got by book) kip)
=/ old=contact
mod.page
=/ new=contact
(do-edit old mod)
?: =(old new)
cor
?> (sane-contact new)
(p-commit-edit kip con.page new)
:: +p-wipe: delete a contact page
::
++ p-wipe
|= wip=(list kip)
%+ roll wip
|= [=kip acc=_cor]
(p-commit-wipe kip)
:: +p-commit-self: publish modified profile
::
++ p-commit-self
|= con=contact
=/ p=profile [(mono wen.rof now.bowl) con]
=. rof p
::
=. cor
(p-news-0 our.bowl (contact:to-0 con))
=. cor
(p-response [%self con])
(give (fact subs [%full p]))
:: +p-commit-page: publish new contact page
::
++ p-commit-page
|= [=kip =page]
=. book (~(put by book) kip page)
(p-response [%page kip page])
:: +p-commit-edit: publish contact page update
::
++ p-commit-edit
|= [=kip =page]
=. book
(~(put by book) kip page)
(p-response [%page kip page])
:: +p-commit-wipe: publish contact page wipe
::
++ p-commit-wipe
|= =kip
=. book
(~(del by book) kip)
(p-response [%wipe kip])
:: +p-init: publish our profile
::
++ p-init
|= wen=(unit @da)
?~ rof cor
?~ wen (give (fact ~ full+rof))
?: =(u.wen wen.rof) cor
?>((lth u.wen wen.rof) (give (fact ~ full+rof))) :: no future subs
::
:: no future subs
?>((lth u.wen wen.rof) (give (fact ~ full+rof)))
:: +p-news-0: [legacy] publish news
::
++ p-news |=(n=news (give %fact [/news ~] %contact-news !>(n)))
++ p-news-0
|= n=news-0:c0
(give %fact ~[/news] %contact-news !>(n))
:: +p-response: publish response
::
++ p-response
|= r=response
(give %fact ~[/v1/news] %contact-response-0 !>(r))
--
::
:: +sub: subscription mgmt
::
:: /epic: foreign protocol versions, |si-epic:s-impl
:: /contact/*: foreign profiles, |s-impl
:: /contact/*: foreign profiles, _s-impl
::
:: subscription state is tracked per peer in .sag
::
:: ~: no subscription
:: %want: /contact/* being attempted
:: %fail: /contact/* failed, /epic being attempted
:: %lost: /epic failed
:: %chi: /contact/* established
:: %lev: we're (incompatibly) ahead of the publisher
:: %dex: we're behind the publisher
:: %want: /contact/* requested
::
:: for a given peer, we always have at most one subscription,
:: to either /contact/* or /epic.
:: to /contact/*
::
++ sub
|^ |= who=ship
^+ s-impl
?< =(our.bowl who)
=/ old (~(get by rol) who)
~(. s-impl who %live ?=(~ old) (fall old [~ ~]))
=/ old (~(get by peers) who)
~(. s-impl who %live ?=(~ old) (fall old *foreign))
::
++ s-many
|= [l=(list ship) f=$-(_s-impl _s-impl)]
@ -219,136 +290,108 @@
++ si-abet
^+ cor
?- sas
%live =. rol (~(put by rol) who for sag)
%live =. peers (~(put by peers) who [for sag])
?. new cor
:: NB: this assumes con.for is only set in +si-hear
::
?.(new cor (p-news:pub who ~))
::
=. cor (p-news-0:pub who ~)
(p-response:pub [%peer who ~])
::
%dead ?: new cor
=. rol (~(del by rol) who)
=. peers (~(del by peers) who)
::
:: this is not quite right, reflecting *total* deletion
:: as *contact* deletion. but it's close, and keeps /news simpler
::
(p-news:pub who ~)
=. cor (p-news-0:pub who ~)
(p-response:pub [%peer who ~])
==
::
++ si-take
|= =sign:agent:gall
|= [=wire =sign:agent:gall]
^+ si-cor
?- -.sign
%poke-ack ~|(strange-poke-ack+wire !!)
::
%watch-ack ~| strange-watch-ack+wire
?> ?=(%want sag)
?~ p.sign si-cor(sag [%chi ~])
?~ p.sign si-cor
%- (slog 'contact-fail' u.p.sign)
pe-peer:si-epic(sag %fail)
=/ wake=@da (add now.bowl ~m30)
=. retry (~(put by retry) who wake)
%_ si-cor cor
(pass /retry/(scot %p who) %arvo %b %wait wake)
==
::
%kick si-heed(sag ~)
%kick si-meet(sag ~)
::
:: [compat] we *should* maintain backcompat here
::
:: by either directly handling or upconverting
:: old actions. but if we don't, we'll fall back
:: to /epic and wait for our peer to upgrade.
::
:: %fact's from the future are also /epic,
:: in case our peer downgrades. if not, we'll
:: handle it on +load.
::
%fact ?+ p.cage.sign (si-odd p.cage.sign)
?(upd:base:mar %contact-update-0)
%fact ?+ p.cage.sign ~|(strange-fact+wire !!)
%contact-update-1
(si-hear !<(update q.cage.sign))
== ==
::
++ si-hear
|= u=update
^+ si-cor
?. (sane-contact con.u)
si-cor
?: &(?=(^ for) (lte wen.u wen.for))
si-cor
si-cor(for +.u, cor (p-news:pub who con.u))
%_ si-cor
for +.u
cor =. cor
(p-news-0:pub who (contact:to-0 con.u))
=/ page=(unit page) (~(get by book) who)
:: update peer contact page
::
=? cor ?=(^ page)
?: =(con.u.page con.u) cor
=. book (~(put by book) who u.page(con con.u))
(p-response:pub %page who con.u mod.u.page)
(p-response:pub %peer who con.u)
==
::
++ si-meet si-cor :: init key in +si-abet
::
++ si-heed
++ si-meet
^+ si-cor
?. ?=(~ sag)
::
:: already subscribed
?: ?=(%want sag)
si-cor
=/ pat [%contact ?~(for / /at/(scot %da wen.for))]
%= si-cor
=/ pat [%v1 %contact ?~(for / /at/(scot %da wen.for))]
%_ si-cor
cor (pass /contact %agent [who dap.bowl] %watch pat)
sag %want
==
::
++ si-retry
^+ si-cor
::
::XX this works around a gall/behn bug:
:: the timer is identified by the duct.
:: it needn't be the same when gall passes our
:: card to behn.
::
?. (~(has by retry) who)
si-cor
=. retry (~(del by retry) who)
si-meet(sag ~)
::
++ si-drop si-snub(sas %dead)
::
++ si-snub
%_ si-cor
sag ~
cor ?+ sag cor
?(%fail [?(%lev %dex) *])
(pass /epic %agent [who dap.bowl] %leave ~)
::
?(%want [%chi *])
(pass /contact %agent [who dap.bowl] %leave ~)
== ==
::
++ si-odd
|= =mark
^+ si-cor
=* upd *upd:base:mar
=* wid ^~((met 3 upd))
?. =(upd (end [3 wid] mark))
~&(fake-news+mark si-cor) :: XX unsub?
?~ ver=(slaw %ud (rsh 3^+(wid) mark))
~&(weird-news+mark si-cor) :: XX unsub?
?: =(okay u.ver)
~|(odd-not-odd+mark !!) :: oops!
=. si-cor si-snub :: unsub before .sag update
=. sag ?:((lth u.ver okay) [%lev ~] [%dex u.ver])
pe-peer:si-epic
::
++ si-epic
|%
++ pe-take
|= =sign:agent:gall
^+ si-cor
?- -.sign
%poke-ack ~|(strange-poke-ack+wire !!)
::
%watch-ack ?~ p.sign si-cor
%- (slog 'epic-fail' u.p.sign)
si-cor(sag %lost)
::
%kick ?. ?=(?(%fail [?(%dex %lev) *]) sag)
si-cor :: XX strange
pe-peer
::
%fact ?+ p.cage.sign
~&(fact-not-epic+p.cage.sign si-cor)
%epic (pe-hear !<(epic q.cage.sign))
== ==
::
++ pe-hear
|= =epic
^+ si-cor
?. ?=(?(%fail [?(%dex %lev) *]) sag)
~|(strange-epic+[okay epic] !!) :: get %kick'd
?: =(okay epic)
?: ?=(%fail sag)
si-cor(sag %lost) :: abandon hope
si-heed:si-snub
::
:: handled generically to support peer downgrade
::
si-cor(sag ?:((gth epic okay) [%dex epic] [%lev ~]))
::
++ pe-peer
si-cor(cor (pass /epic %agent [who dap.bowl] %watch /epic))
--
cor ?. ?=(%want sag) cor
:: retry is scheduled, cancel the timer
::
?^ when=(~(get by retry) who)
=. retry (~(del by retry) who)
(pass /retry/(scot %p who)/cancel %arvo %b %rest u.when)
(pass /contact %agent [who dap.bowl] %leave ~)
==
--
--
::
:: +migrate: from :contact-store
::
:: all known ships, non-default profiles, no subscriptions
@ -378,19 +421,23 @@
?. .^(? gu+(weld bas /$)) cor
=/ ful .^(rolodex:legacy gx+(weld bas /all/noun))
::
|^ cor(rof us, rol them)
++ us (biff (~(get by ful) our.bowl) convert)
|^
cor(rof us, peers them)
++ us
%+ fall
(bind (~(get by ful) our.bowl) convert)
*profile
::
++ them
^- rolodex
^- ^peers
%- ~(rep by (~(del by ful) our.bowl))
|= [[who=ship con=contact:legacy] rol=rolodex]
(~(put by rol) who (convert con) ~)
|= [[who=ship con=contact:legacy] =^peers]
(~(put by peers) who (convert con) ~)
::
++ convert
|= con=contact:legacy
^- $@(~ profile)
?: =(*contact:legacy con) ~
^- profile
%- profile:from-0
[last-updated.con con(|6 groups.con)]
--
::
@ -403,114 +450,271 @@
|= old-vase=vase
^+ cor
|^ =+ !<([old=versioned-state cool=epic] old-vase)
:: if there should be a sub (%chi saga), but there is none (in the
:: bowl), re-establish it. %kick handling used to be faulty.
:: we run this "repair" on every load, in the spirit of +inflate-io.
=? cor !=(okay cool) l-epic
?- -.old
::
=^ cards rol.old
%+ roll ~(tap by rol.old)
|= [[who=ship foreign] caz=(list card) rol=rolodex]
?. ?& =([%chi ~] sag)
%1
=. state old
=/ cards
%+ roll ~(tap by peers)
|= [[who=ship foreign] caz=(list card)]
:: intent to connect, resubscribe
::
?: ?& =(%want sag)
!(~(has by wex.bowl) [/contact who dap.bowl])
==
[caz (~(put by rol) who for sag)]
:- :_ caz
=/ =path [%contact ?~(for / /at/(scot %da wen.for))]
[%pass /contact %agent [who dap.bowl] %watch path]
(~(put by rol) who for %want)
=. state old
=. cor (emil cards)
:: [compat] if our protocol version changed
=/ =path [%v1 %contact ?~(for / /at/(scot %da wen.for))]
:_ caz
[%pass /contact %agent [who dap.bowl] %watch path]
caz
(emil cards)
::
:: we first tell the world, then see if we can now understand
:: any of our friends who were sending messages from the future.
%0
=. rof ?~(rof.old *profile (profile:from-0 rof.old))
:: migrate peers. for each peer
:: 1. leave /epic, if any
:: 2. subscribe if desired
:: 3. put into peers
::
?:(=(okay cool) cor l-bump(cor l-epic))
::
=^ caz=(list card) peers
%+ roll ~(tap by rol.old)
|= [[who=ship foreign-0:c0] caz=(list card) =_peers]
:: leave /epic if any
::
=? caz (~(has by wex.bowl) [/epic who dap.bowl])
:_ caz
[%pass /epic %agent [who dap.bowl] %leave ~]
=/ fir=$@(~ profile)
?~ for ~
(profile:from-0 for)
:: no intent to connect
::
?: =(~ sag)
:- caz
(~(put by peers) who fir ~)
:_ (~(put by peers) who fir %want)
?: (~(has by wex.bowl) [/contact who dap.bowl])
caz
=/ =path [%v1 %contact ?~(fir / /at/(scot %da wen.fir))]
:_ caz
[%pass /contact %agent [who dap.bowl] %watch path]
(emil caz)
==
+$ state-0 [%0 rof=$@(~ profile-0:c0) rol=rolodex:c0]
+$ versioned-state
$% state-0
state-1
==
::
++ l-epic (give %fact [/epic ~] epic+!>(okay))
::
++ l-bump
^+ cor
%- ~(rep by rol)
|= [[who=ship foreign] =_cor]
:: XX to fully support downgrade, we'd need to also
:: save an epic in %lev
::
?. ?& ?=([%dex *] sag)
=(okay ver.sag)
==
cor
si-abet:si-heed:si-snub:(sub:cor who)
--
::
++ poke
|= [=mark =vase]
^+ cor
:: [compat] we *should* maintain backcompat here
::
:: by either directly handling or upconverting old actions
::
?+ mark ~|(bad-mark+mark !!)
%noun
?+ q.vase !!
%migrate migrate
==
::
?(act:base:mar %contact-action-0)
$? %contact-action
%contact-action-0
%contact-action-1
==
?> =(our src):bowl
=/ act !<(action vase)
=/ act=action
?- mark
::
%contact-action-1
!<(action vase)
:: upconvert legacy %contact-action
::
?(%contact-action %contact-action-0)
=/ act-0 !<(action-0:c0 vase)
?. ?=(%edit -.act-0)
(to-action act-0)
:: v0 %edit needs special handling to evaluate
:: groups edit
::
=/ groups=(set $>(%flag value))
?~ con.rof ~
=+ set=(~(ges cy con.rof) groups+%flag)
(fall set ~)
[%self (to-self-edit p.act-0 groups)]
==
?- -.act
%anon p-anon:pub
%edit (p-edit:pub p.act)
%self (p-self:pub p.act)
:: if we add a page for someone who is not a peer,
:: we meet them first
::
%page =? cor &(?=(ship p.act) !(~(has by peers) p.act))
si-abet:si-meet:(sub p.act)
(p-page:pub p.act q.act)
%edit (p-edit:pub p.act q.act)
%wipe (p-wipe:pub p.act)
%meet (s-many:sub p.act |=(s=_s-impl:sub si-meet:s))
%heed (s-many:sub p.act |=(s=_s-impl:sub si-heed:s))
%drop (s-many:sub p.act |=(s=_s-impl:sub si-drop:s))
%snub (s-many:sub p.act |=(s=_s-impl:sub si-snub:s))
==
==
:: +peek: scry
::
:: v0 scries
::
:: /x/all -> $rolodex:c0
:: /x/contact/her=@ -> $@(~ contact-0:c0)
::
:: v1 scries
::
:: /x/v1/self -> $contact
:: /x/v1/book -> $book
:: /x/v1/book/her=@p -> $page
:: /x/v1/book/id/cid=@uv -> $page
:: /x/v1/all -> $directory
:: /x/v1/contact/her=@p -> $contact
:: /x/v1/peer/her=@p -> $contact
::
++ peek
|= pat=(pole knot)
^- (unit (unit cage))
?+ pat [~ ~]
::
[%x %all ~]
=/ lor=rolodex
?: |(?=(~ rof) ?=(~ con.rof)) rol
(~(put by rol) our.bowl rof ~)
``contact-rolodex+!>(lor)
::
=/ rol-0=rolodex:c0
%- ~(urn by peers)
|= [who=ship far=foreign]
^- foreign-0:c0
=/ mod=contact
?~ page=(~(get by book) who)
~
mod.u.page
(foreign:to-0 (foreign-mod far mod))
=/ lor-0=rolodex:c0
?: ?=(~ con.rof) rol-0
(~(put by rol-0) our.bowl (profile:to-0 rof) ~)
``contact-rolodex+!>(lor-0)
::
[%x %contact her=@ ~]
?~ who=`(unit @p)`(slaw %p her.pat)
?~ who=(slaw %p her.pat)
[~ ~]
=/ tac=?(~ contact)
?: =(our.bowl u.who) ?~(rof ~ con.rof)
=+ (~(get by rol) u.who)
?: |(?=(~ -) ?=(~ for.u.-)) ~
con.for.u.-
=/ tac=?(~ contact-0:c0)
?: =(our.bowl u.who)
?~(con.rof ~ (contact:to-0 con.rof))
=+ far=(~(get by peers) u.who)
?: |(?=(~ far) ?=(~ for.u.far)) ~
(contact:to-0 con.for.u.far)
?~ tac [~ ~]
``contact+!>(`contact`tac)
``contact+!>(`contact-0:c0`tac)
::
[%x %v1 %self ~]
``contact-1+!>(`contact`con.rof)
::
[%x %v1 %book ~]
``contact-book-0+!>(book)
::
[%u %v1 %book her=@p ~]
?~ who=(slaw %p her.pat)
[~ ~]
``loob+!>((~(has by book) u.who))
::
[%x %v1 %book her=@p ~]
?~ who=(slaw %p her.pat)
[~ ~]
=/ page=(unit page)
(~(get by book) u.who)
``contact-page-0+!>(`^page`(fall page *^page))
::
[%u %v1 %book %id =cid ~]
?~ id=(slaw %uv cid.pat)
[~ ~]
``loob+!>((~(has by book) id+u.id))
::
[%x %v1 %book %id =cid ~]
?~ id=(slaw %uv cid.pat)
[~ ~]
=/ page=(unit page)
(~(get by book) id+u.id)
``contact-page-0+!>(`^page`(fall page *^page))
::
[%x %v1 %all ~]
=| dir=directory
:: export all ship contacts
::
=. dir
%- ~(rep by book)
|= [[=kip =page] =_dir]
?^ kip
dir
(~(put by dir) kip (contact-uni page))
:: export all peers
::
=. dir
%- ~(rep by peers)
|= [[who=ship far=foreign] =_dir]
?~ for.far dir
?: (~(has by dir) who) dir
(~(put by dir) who con.for.far)
``contact-directory-0+!>(dir)
::
[%u %v1 %contact her=@p ~]
?~ who=(slaw %p her.pat)
[~ ~]
?: (~(has by book) u.who)
``loob+!>(&)
=- ``loob+!>(-)
?~ far=(~(get by peers) u.who)
|
?~ for.u.far
|
&
::
[%x %v1 %contact her=@p ~]
?~ who=(slaw %p her.pat)
[~ ~]
?^ page=(~(get by book) u.who)
``contact-1+!>((contact-uni u.page))
?~ far=(~(get by peers) u.who)
[~ ~]
?~ for.u.far
[~ ~]
``contact-1+!>(con.for.u.far)
::
[%u %v1 %peer her=@p ~]
?~ who=(slaw %p her.pat)
[~ ~]
``loob+!>((~(has by peers) u.who))
::
[%x %v1 %peer her=@p ~]
?~ who=(slaw %p her.pat)
[~ ~]
?~ far=(~(get by peers) u.who)
[~ ~]
``contact-foreign-0+!>(`foreign`u.far)
==
::
++ peer
|= pat=(pole knot)
^+ cor
?+ pat ~|(bad-watch-path+pat !!)
[%contact %at wen=@ ~] (p-init:pub `(slav %da wen.pat))
[%contact ~] (p-init:pub ~)
[%epic ~] (give %fact ~ epic+!>(okay))
::
:: v0
[%news ~] ~|(local-news+src.bowl ?>(=(our src):bowl cor))
::
:: v1
[%v1 %contact ~] (p-init:pub ~)
[%v1 %contact %at wen=@ ~] (p-init:pub `(slav %da wen.pat))
[%v1 %news ~] ~|(local-news+src.bowl ?>(=(our src):bowl cor))
::
[%epic ~] (give %fact ~ epic+!>(okay))
==
::
++ agent
|= [=wire =sign:agent:gall]
^+ cor
?+ wire ~|(evil-agent+wire !!)
[%contact ~] si-abet:(si-take:(sub src.bowl) sign)
[%epic ~] si-abet:(pe-take:si-epic:(sub src.bowl) sign)
[%contact ~]
si-abet:(si-take:(sub src.bowl) wire sign)
::
[%migrate ~]
?> ?=(%poke-ack -.sign)
@ -518,5 +722,19 @@
%- (slog leaf/"{<wire>} failed" u.p.sign)
cor
==
::
++ arvo
|= [=wire sign=sign-arvo]
^+ cor
?+ wire ~|(evil-vane+wire !!)
::
[%retry her=@p ~]
:: XX technically, the timer could fail.
:: it should be ok to still retry.
::
?> ?=([%behn %wake *] sign)
=+ who=(slav %p i.t.wire)
si-abet:si-retry:(sub who)
==
--
--

43
desk/lib/contacts-json.hoon
View File

@ -1,5 +1,6 @@
/- c=contacts, g=groups
/+ gj=groups-json
=, legacy:c
|%
++ enjs
=, enjs:format
@ -9,21 +10,21 @@
++ ship
|=(her=@p n+(rap 3 '"' (scot %p her) '"' ~))
::
++ action
|= a=action:c
++ action-0
|= a=action-0:c
^- json
%+ frond -.a
?- -.a
%anon ~
%edit a+(turn p.a field)
%edit a+(turn p.a field-0)
%meet a+(turn p.a ship)
%heed a+(turn p.a ship)
%drop a+(turn p.a ship)
%snub a+(turn p.a ship)
==
::
++ contact
|= c=contact:c
++ contact-0
|= c=contact-0:c
^- json
%- pairs
:~ nickname+s+nickname.c
@ -38,8 +39,8 @@
|=([f=flag:g j=(list json)] [s+(flag:enjs:gj f) j])
==
::
++ field
|= f=field:c
++ field-0
|= f=field-0:c
^- json
%+ frond -.f
?- -.f
@ -53,20 +54,20 @@
%del-group s+(flag:enjs:gj flag.f)
==
::
++ rolodex
|= r=rolodex:c
++ rolodex-0
|= r=rolodex-0:c
^- json
%- pairs
%- ~(rep by r)
|= [[who=@p foreign:c] j=(list [@t json])]
[[(scot %p who) ?.(?=([@ ^] for) ~ (contact con.for))] j] :: XX stale flag per sub state?
|= [[who=@p foreign-0:c] j=(list [@t json])]
[[(scot %p who) ?.(?=([@ ^] for) ~ (contact-0 con.for))] j] :: XX stale flag per sub state?
::
++ news
|= n=news:c
++ news-0
|= n=news-0:c
^- json
%- pairs
:~ who+(ship who.n)
con+?~(con.n ~ (contact con.n))
con+?~(con.n ~ (contact-0 con.n))
==
--
::
@ -92,19 +93,19 @@
(slav aur (cut 3 [1 (sub wyd 2)] p.jon))
==
::
++ action
^- $-(json action:c)
++ action-0
^- $-(json action-0:c)
%- of
:~ anon+ul
edit+(ar field)
edit+(ar field-0)
meet+(ar ship)
heed+(ar ship)
drop+(ar ship)
snub+(ar ship)
==
::
++ contact
^- $-(json contact:c)
++ contact-0
^- $-(json contact-0:c)
%- ot
:~ nickname+so
bio+so
@ -115,8 +116,8 @@
groups+(as flag:dejs:gj)
==
::
++ field
^- $-(json field:c)
++ field-0
^- $-(json field-0:c)
%- of
:~ nickname+so
bio+so

443
desk/lib/contacts.hoon Normal file
View File

@ -0,0 +1,443 @@
/- *contacts, c0=contacts-0
|%
::
+| %contact
:: +cy: contact map engine
::
++ cy
|_ c=contact
:: +get: typed get
::
++ get
|* [key=@tas typ=value-type]
^- (unit _p:*$>(_typ value))
=/ val=(unit value) (~(get by c) key)
?~ val ~
?~ u.val !!
~| "{<typ>} expected at {<key>}"
?- typ
%text ?>(?=(%text -.u.val) (some p.u.val))
%numb ?>(?=(%numb -.u.val) (some p.u.val))
%date ?>(?=(%date -.u.val) (some p.u.val))
%tint ?>(?=(%tint -.u.val) (some p.u.val))
%ship ?>(?=(%ship -.u.val) (some p.u.val))
%look ?>(?=(%look -.u.val) (some p.u.val))
%flag ?>(?=(%flag -.u.val) (some p.u.val))
%set ?>(?=(%set -.u.val) (some p.u.val))
==
:: +ges: get specialized to typed set
::
++ ges
|* [key=@tas typ=value-type]
^- (unit (set $>(_typ value)))
=/ val=(unit value) (~(get by c) key)
?~ val ~
?. ?=(%set -.u.val)
~| "set expected at {<key>}" !!
%- some
%- ~(run in p.u.val)
?- typ
%text |=(v=value ?>(?=(%text -.v) v))
%numb |=(v=value ?>(?=(%numb -.v) v))
%date |=(v=value ?>(?=(%date -.v) v))
%tint |=(v=value ?>(?=(%tint -.v) v))
%ship |=(v=value ?>(?=(%ship -.v) v))
%look |=(v=value ?>(?=(%look -.v) v))
%flag |=(v=value ?>(?=(%flag -.v) v))
%set |=(v=value ?>(?=(%set -.v) v))
==
:: +gos: got specialized to typed set
::
++ gos
|* [key=@tas typ=value-type]
^- (set $>(_typ value))
=/ val=value (~(got by c) key)
?. ?=(%set -.val)
~| "set expected at {<key>}" !!
%- ~(run in p.val)
?- typ
%text |=(v=value ?>(?=(%text -.v) v))
%numb |=(v=value ?>(?=(%numb -.v) v))
%date |=(v=value ?>(?=(%date -.v) v))
%tint |=(v=value ?>(?=(%tint -.v) v))
%ship |=(v=value ?>(?=(%ship -.v) v))
%look |=(v=value ?>(?=(%look -.v) v))
%flag |=(v=value ?>(?=(%flag -.v) v))
%set |=(v=value ?>(?=(%set -.v) v))
==
:: +gut: typed gut with default
::
++ gut
|* [key=@tas def=value]
^+ +.def
=/ val=value (~(gut by c) key ~)
?~ val
+.def
~| "{<-.def>} expected at {<key>}"
?- -.val
%text ?>(?=(%text -.def) p.val)
%numb ?>(?=(%numb -.def) p.val)
%date ?>(?=(%date -.def) p.val)
%tint ?>(?=(%tint -.def) p.val)
%ship ?>(?=(%ship -.def) p.val)
%look ?>(?=(%look -.def) p.val)
%flag ?>(?=(%flag -.def) p.val)
%set ?>(?=(%set -.def) p.val)
==
:: +gub: typed gut with bunt default
::
++ gub
|* [key=@tas typ=value-type]
^+ +:*$>(_typ value)
=/ val=value (~(gut by c) key ~)
?~ val
?+ typ !!
%text *@t
%numb *@ud
%date *@da
%tint *@ux
%ship *@p
%look *@t
%flag *flag:g
%set *(set value)
==
~| "{<typ>} expected at {<key>}"
?- typ
%text ?>(?=(%text -.val) p.val)
%numb ?>(?=(%numb -.val) p.val)
%date ?>(?=(%date -.val) p.val)
%tint ?>(?=(%tint -.val) p.val)
%ship ?>(?=(%ship -.val) p.val)
%look ?>(?=(%look -.val) p.val)
%flag ?>(?=(%flag -.val) p.val)
%set ?>(?=(%set -.val) p.val)
==
--
::
++ do-edit-0
|= [c=contact-0:c0 f=field-0:c0]
^+ c
?- -.f
%nickname c(nickname nickname.f)
%bio c(bio bio.f)
%status c(status status.f)
%color c(color color.f)
::
%avatar ~| "cannot add a data url to avatar!"
?> ?| ?=(~ avatar.f)
!=('data:' (end 3^5 u.avatar.f))
==
c(avatar avatar.f)
::
%cover ~| "cannot add a data url to cover!"
?> ?| ?=(~ cover.f)
!=('data:' (end 3^5 u.cover.f))
==
c(cover cover.f)
::
%add-group c(groups (~(put in groups.c) flag.f))
::
%del-group c(groups (~(del in groups.c) flag.f))
==
:: +sane-contact: verify contact sanity
::
:: - restrict size of the jammed noun to 10kB
:: - prohibit 'data:' URLs in image data
::
++ sane-contact
|= con=contact
^- ?
?~ ((soft contact) con)
|
:: 10kB contact ought to be enough for anybody
::
?: (gth (met 3 (jam con)) 10.000)
|
:: field restrictions
::
:: 1. %nickname field: max 64 characters
:: 2. %bio field: max 2048 characters
:: 3. data URLs in %avatar and %cover
:: are forbidden
::
=+ nickname=(~(get cy con) %nickname %text)
?: ?& ?=(^ nickname)
(gth (met 3 u.nickname) 64)
==
|
=+ bio=(~(get cy con) %bio %text)
?: ?& ?=(^ bio)
(gth (met 3 u.bio) 2.048)
==
|
=+ avatar=(~(get cy con) %avatar %text)
?: ?& ?=(^ avatar)
=('data:' (end 3^5 u.avatar))
==
|
=+ cover=(~(get cy con) %cover %text)
?: ?& ?=(^ cover)
=('data:' (end 3^5 u.cover))
==
|
&
:: +do-edit: edit contact
::
:: edit .con with .mod contact map.
:: unifies the two maps, and deletes any resulting fields
:: that are null.
::
++ do-edit
|= [con=contact mod=(map @tas value)]
^+ con
=/ don (~(uni by con) mod)
=/ del=(list @tas)
%- ~(rep by don)
|= [[key=@tas val=value] acc=(list @tas)]
?. ?=(~ val) acc
[key acc]
=? don !=(~ del)
%+ roll del
|= [key=@tas acc=_don]
(~(del by don) key)
don
:: +from-0: legacy to new type
::
++ from-0
|%
:: +contact: convert legacy to contact
::
++ contact
|= o=contact-0:c0
^- ^contact
=/ c=^contact
%- malt
^- (list (pair @tas value))
:~ nickname+text/nickname.o
bio+text/bio.o
status+text/status.o
color+tint/color.o
==
=? c ?=(^ avatar.o)
(~(put by c) %avatar text/u.avatar.o)
=? c ?=(^ cover.o)
(~(put by c) %cover text/u.cover.o)
=? c !?=(~ groups.o)
%+ ~(put by c) %groups
:- %set
%- ~(run in groups.o)
|= =flag:g
flag/flag
c
:: +profile: convert legacy to profile
::
++ profile
|= o=profile-0:c0
^- ^profile
[wen.o ?~(con.o ~ (contact con.o))]
::
--
:: +from: legacy from new type
::
++ to-0
|%
:: +contact: convert contact to legacy
::
++ contact
|= c=^contact
^- $@(~ contact-0:c0)
?~ c ~
=| o=contact-0:c0
%_ o
nickname
(~(gub cy c) %nickname %text)
bio
(~(gub cy c) %bio %text)
status
(~(gub cy c) %status %text)
color
(~(gub cy c) %color %tint)
avatar
(~(get cy c) %avatar %text)
cover
(~(get cy c) %cover %text)
groups
=/ groups
(~(get cy c) %groups %set)
?~ groups ~
^- (set flag:g)
%- ~(run in u.groups)
|= val=value
?> ?=(%flag -.val)
p.val
==
:: +profile: convert profile to legacy
::
++ profile
|= p=^profile
^- profile-0:c0
[wen.p (contact:to-0 con.p)]
:: +profile-0-mod: convert profile with contact overlay
:: to legacy
::
++ profile-mod
|= [p=^profile mod=^contact]
^- profile-0:c0
[wen.p (contact:to-0 (contact-uni con.p mod))]
:: +foreign: convert foreign to legacy
::
++ foreign
|= f=^foreign
^- foreign-0:c0
[?~(for.f ~ (profile:to-0 for.f)) sag.f]
:: foreign-mod: convert foreign with contact overlay
:: to legacy
::
++ foreign-mod
|= [f=^foreign mod=^contact]
^- foreign-0:c0
[?~(for.f ~ (profile-mod:to-0 for.f mod)) sag.f]
--
:: +contact-uni: merge contacts
::
++ contact-uni
|= [c=contact mod=contact]
^- contact
(~(uni by c) mod)
:: +foreign-contact: get foreign contact
::
++ foreign-contact
|= far=foreign
^- contact
?~(for.far ~ con.for.far)
:: +foreign-mod: modify foreign profile with user overlay
::
++ foreign-mod
|= [far=foreign mod=contact]
^- foreign
?~ for.far
far
far(con.for (contact-uni con.for.far mod))
:: +sole-field-0: sole field is a field that does
:: not modify the groups set
::
+$ sole-field-0
$~ nickname+''
$<(?(%add-group %del-group) field-0:c0)
:: +to-sole-edit: convert legacy sole field to contact edit
::
:: modify any field except for groups
::
++ to-sole-edit
|= edit-0=(list sole-field-0)
^- contact
%+ roll edit-0
|= $: fed=sole-field-0
acc=(map @tas value)
==
^+ acc
?- -.fed
::
%nickname
%+ ~(put by acc)
%nickname
text/nickname.fed
::
%bio
%+ ~(put by acc)
%bio
text/bio.fed
::
%status
%+ ~(put by acc)
%status
text/status.fed
::
%color
%+ ~(put by acc)
%color
tint/color.fed
::
%avatar
?~ avatar.fed acc
%+ ~(put by acc)
%avatar
look/u.avatar.fed
::
%cover
?~ cover.fed acc
%+ ~(put by acc)
%cover
look/u.cover.fed
==
:: +to-self-edit: convert legacy to self edit
::
++ to-self-edit
|= [edit-0=(list field-0:c0) groups=(set value)]
^- contact
:: converting v0 profile edit to v1 is non-trivial.
:: for field edits other than groups, we derive a contact
:: edition map. for group operations (%add-group, %del-group)
:: we need to operate directly on (existing?) groups field in
:: the profile.
::
:: .tid: field edit actions, no group edit
:: .gid: only group edit actions
::
=* group-type ?(%add-group %del-group)
=* sole-edits (list $<(group-type field-0:c0))
=* group-edits (list $>(group-type field-0:c0))
:: sift edits
::
=/ [sid=sole-edits gid=group-edits]
::
:: XX why is casting neccessary here?
=- [(flop `sole-edits`-<) (flop `group-edits`->)]
%+ roll edit-0
|= [f=field-0:c0 sid=sole-edits gid=group-edits]
^+ [sid gid]
?. ?=(group-type -.f)
:- [f sid]
gid
:- sid
[f gid]
:: edit favourite groups
::
=. groups
%+ roll gid
|= [ged=$>(group-type field-0:c0) =_groups]
?- -.ged
%add-group
(~(put in groups) flag/flag.ged)
%del-group
(~(del in groups) flag/flag.ged)
==
%- ~(uni by (to-sole-edit sid))
^- contact
[%groups^set/groups ~ ~]
:: +to-action: convert legacy to action
::
:: convert any action except %edit.
:: %edit must be handled separately, since we need
:: access to existing groups to be able to process group edits.
::
++ to-action
|= o=$<(%edit action-0:c0)
^- action
?- -.o
%anon [%anon ~]
::
:: old %meet is now a no-op
%meet [%meet ~]
%heed [%meet p.o]
%drop [%drop p.o]
%snub [%snub p.o]
==
:: +mono: tick time
::
++ mono
|= [old=@da new=@da]
^- @da
?: (lth old new) new
(add old ^~((rsh 3^2 ~s1)))
--

135
desk/lib/contacts/json-0.hoon Normal file
View File

@ -0,0 +1,135 @@
/- c=contacts, g=groups
/- legacy=contacts-0
/+ gj=groups-json
=, legacy
|%
++ enjs
=, enjs:format
|%
:: XX shadowed for compat, +ship:enjs removes the ~
::
++ ship
|=(her=@p n+(rap 3 '"' (scot %p her) '"' ~))
::
++ action
|= a=action-0
^- json
%+ frond -.a
?- -.a
%anon ~
%edit a+(turn p.a field)
%meet a+(turn p.a ship)
%heed a+(turn p.a ship)
%drop a+(turn p.a ship)
%snub a+(turn p.a ship)
==
::
++ contact
|= c=contact-0
^- json
%- pairs
:~ nickname+s+nickname.c
bio+s+bio.c
status+s+status.c
color+s+(scot %ux color.c)
avatar+?~(avatar.c ~ s+u.avatar.c)
cover+?~(cover.c ~ s+u.cover.c)
::
=- groups+a+-
%- ~(rep in groups.c)
|=([f=flag:g j=(list json)] [s+(flag:enjs:gj f) j])
==
::
++ field
|= f=field-0
^- json
%+ frond -.f
?- -.f
%nickname s+nickname.f
%bio s+bio.f
%status s+status.f
%color s+(rsh 3^2 (scot %ux color.f)) :: XX confirm
%avatar ?~(avatar.f ~ s+u.avatar.f)
%cover ?~(cover.f ~ s+u.cover.f)
%add-group s+(flag:enjs:gj flag.f)
%del-group s+(flag:enjs:gj flag.f)
==
::
++ rolodex
|= r=^rolodex
^- json
%- pairs
%- ~(rep by r)
|= [[who=@p foreign-0] j=(list [@t json])]
[[(scot %p who) ?.(?=([@ ^] for) ~ (contact con.for))] j] :: XX stale flag per sub state?
::
++ news
|= n=news-0
^- json
%- pairs
:~ who+(ship who.n)
con+?~(con.n ~ (contact con.n))
==
--
::
++ dejs
=, dejs:format
|%
:: for performance, @p is serialized above to json %n (no escape)
:: for mark roundtrips, ships are parsed from either %s or %n
:: XX do this elsewhere in groups?
::
++ ship (se-ne %p)
++ se-ne
|= aur=@tas
|= jon=json
?+ jon !!
[%s *] (slav aur p.jon)
:: XX this seems wrong: current JSON parser
:: would never pass a ship as a number
::
[%n *] ~| bad-n+p.jon
=/ wyd (met 3 p.jon)
?> ?& =('"' (end 3 p.jon))
=('"' (cut 3 [(dec wyd) 1] p.jon))
==
(slav aur (cut 3 [1 (sub wyd 2)] p.jon))
==
::
++ action
^- $-(json action-0)
%- of
:~ anon+ul
edit+(ar field)
meet+(ar ship)
heed+(ar ship)
drop+(ar ship)
snub+(ar ship)
==
::
++ contact
^- $-(json contact-0)
%- ot
:~ nickname+so
bio+so
status+so
color+nu
avatar+(mu so)
cover+(mu so)
groups+(as flag:dejs:gj)
==
::
++ field
^- $-(json field-0)
%- of
:~ nickname+so
bio+so
status+so
color+nu
avatar+(mu so)
cover+(mu so)
add-group+flag:dejs:gj
del-group+flag:dejs:gj
==
--
--

151
desk/lib/contacts/json-1.hoon Normal file
View File

@ -0,0 +1,151 @@
/- c=contacts, g=groups
/+ gj=groups-json
|%
++ enjs
=, enjs:format
|%
::
++ ship
|=(her=@p n+(rap 3 '"' (scot %p her) '"' ~))
::
++ cid
|= =cid:c
^- json
s+(scot %uv cid)
::
++ kip
|= =kip:c
^- json
?@ kip
(ship kip)
(cid +.kip)
::
++ value
|= val=value:c
^- json
?- -.val
%text (pairs type+s/%text value+s/p.val ~)
%numb (pairs type+s/%numb value+(numb p.val) ~)
%date (pairs type+s/%date value+s/(scot %da p.val) ~)
%tint (pairs type+s/%tint value+s/(rsh 3^2 (scot %ux p.val)) ~)
%ship (pairs type+s/%ship value+(ship p.val) ~)
%look (pairs type+s/%look value+s/p.val ~)
%flag (pairs type+s/%flag value+s/(flag:enjs:gj p.val) ~)
%set (pairs type+s/%set value+a/(turn ~(tap in p.val) value) ~)
==
::
++ contact
|= con=contact:c
^- json
o+(~(run by con) value)
::
++ page
|= =page:c
^- json
a+[(contact con.page) (contact mod.page) ~]
::
++ book
|= =book:c
^- json
=| kob=(map @ta json)
:- %o
%- ~(rep by book)
|= [[=kip:c =page:c] acc=_kob]
?^ kip
(~(put by acc) (scot %uv +.kip) (^page page))
(~(put by acc) (scot %p kip) (^page page))
::
++ directory
|= =directory:c
^- json
=| dir=(map @ta json)
:- %o
%- ~(rep by directory)
|= [[who=@p con=contact:c] acc=_dir]
(~(put by acc) (scot %p who) (contact con))
::
++ response
|= n=response:c
^- json
?- -.n
%self (frond self+(contact con.n))
%page %- pairs
:~ kip+(kip kip.n)
con+(contact con.n)
mod+(contact mod.n)
==
%wipe (frond kip+(kip kip.n))
%peer %- pairs
:~ who+(ship who.n)
con+(contact con.n)
==
==
--
::
++ dejs
=, dejs:format
|%
::
++ ship (se %p)
::
++ cid
|= jon=json
^- cid:c
?> ?=(%s -.jon)
(slav %uv p.jon)
::
++ kip
|= jon=json
^- kip:c
?> ?=(%s -.jon)
?: =('~' (end [3 1] p.jon))
(ship jon)
id+(cid jon)
:: +ta: tag .wit parsed json with .mas
::
++ ta
|* [mas=@tas wit=fist]
|= jon=json
[mas (wit jon)]
::
++ value
^- $-(json value:c)
|= jon=json
:: XX is there a way to do it in one go?
::
=/ [type=@tas val=json]
%. jon
(ot text+(se %tas) value+json ~)
?+ type !!
%text %. val (ta %text so)
%numb %. val (ta %numb ni)
%date %. val (ta %date (se %da))
%tint %. val
%+ ta %tint
%+ cu
|=(s=@t (slav %ux (cat 3 '0x' s)))
so
%ship %. val (ta %ship ship)
%look %. val (ta %look so)
%flag %. val (ta %flag flag:dejs:gj)
%set %. val (ta %set (as value))
==
::
++ contact
^- $-(json contact:c)
(om value)
::
++ action
^- $-(json action:c)
%- of
:~ anon+ul
self+contact
page+(ot kip+kip contact+contact ~)
edit+(ot kip+kip contact+contact ~)
wipe+(ar kip)
meet+(ar ship)
drop+(ar ship)
snub+(ar ship)
==
--
--

9
desk/lib/mark-warmer.hoon
View File

@ -1,9 +1,14 @@
/$ rolo %contact-rolodex %json
/$ contact %contact %json
/$ contact-0 %contact %json
/$ news-0 %contact-news %json
/$ contact-1 %contact-1 %json
/$ page-0 %contact-page-0 %json
/$ book-0 %contact-book-0 %json
/$ dir-0 %contact-directory-0 %json
/$ resp-0 %contact-response-0 %json
/$ skeins %hark-skeins %json
/$ carpet %hark-carpet %json
/$ blanket %hark-blanket %json
/$ settings %settings-data %json
/$ creds %update %json
/$ storage %storage-update %json
~

789
desk/lib/negotiate.hoon Normal file
View File

@ -0,0 +1,789 @@
:: negotiate: hands-off version negotiation
::
:: v1.0.1: greenhorn ambassador
::
:: automates negotiating poke & watch interface versions, letting the
:: underlying agent focus on talking to the outside world instead of
:: figuring out whether it can.
::
:: usage
::
:: to use this library, you must supply it with three things:
:: - a flag specifying whether the inner agent should be notified of version
:: negotiation events (matching & unmatching of external agents)
:: - a map of, per protocol your agent exposes, a version noun
:: - a map of, per agent name, a map of, per protocol, the version we expect
:: call this library's +agent arm with those three arguments, and then call
:: the resulting gate with your agent's door.
::
:: this library will "capture" watches, leaves and pokes emitted by the
:: underlying agent.
:: watches will be registered as intent to subscribe. leaves rescind that
:: intent. when first attempting to open a subscription to another agent (a
:: specific $gill:gall), the library will start version negotiation with
:: that agent for each protocol configured for it. only once it has heard a
:: matching version from the remote agent for *all* protocols will the
:: library establish the subscriptions for which intent has been signalled.
:: if it hears a changed, non-matching version from a remote agent, it will
:: automatically close the subscriptions to that agent (and re-open them
:: whenever versions match again).
:: sending pokes will crash the agent if no version match has been
:: established. to avoid crashing when trying to send pokes, the inner agent
:: must take care to call +can-poke or +read-status to check, and +initiate
:: to explicitly initiate version negotiation if necessary.
:: once the library start negotiating versions with another agent, it never
:: stops listening to their versions.
::
:: subsequent changes to the arguments given to this library will result in
:: similar subscription management behavior: we temporarily close
:: subscriptions for agents we have version mismatches with, and open ones
:: where we now do have matching versions. in upgrade scenarios, changing
:: the library arguments should generally suffice.
::
:: if the flag at the start of the sample is set to true then, whenever we
:: start to match or stop matching with a specific gill, we send a poke to
:: the inner agent, marked %negotiate-notification, containing both a flag
:: indicating whether we now match, and the gill for which the notification
:: applies.
:: (the initial state, of not having negotiated at all, counts as "not
:: matching".)
::
:: regardless of the value of the notify flag, subscription updates about
:: version compatibility will always be given on the following paths:
:: /~/negotiate/notify %negotiate-notifcation; [match=? =gill:gall]
:: /~/negotiate/notify/json %json; {'gill': '~ship/dude', 'match': true}
::
:: if an agent was previously using epic, it can trivially upgrade into
:: this library by making the following changes:
:: - change its own epic version number
:: - keep exposing that on the /epic subscription endpoint
:: - remove all other epic-related negotiation logic
:: - use this library as normal
::
|%
+$ protocol @ta
+$ version *
+$ config (map dude:gall (map protocol version))
+$ status ?(%match %clash %await %unmet)
::
++ initiate
|= =gill:gall
^- card:agent:gall
[%give %fact [/~/negotiate/initiate]~ %negotiate-initiate-version !>(gill)]
::
++ read-status
|= [bowl:gall =gill:gall]
.^ status
%gx (scot %p our) dap (scot %da now)
/~/negotiate/status/(scot %p p.gill)/[q.gill]/noun
==
::
++ can-poke
|= [=bowl:gall =gill:gall]
?=(%match (read-status bowl gill))
::
++ agent
|= [notify=? our-versions=(map protocol version) =our=config]
^- $-(agent:gall agent:gall)
|^ agent
::
+$ state-1
$: %1
ours=(map protocol version)
know=config
heed=(map [gill:gall protocol] (unit version))
want=(map gill:gall (map wire path)) :: un-packed wires
==
::
+$ card card:agent:gall
::
++ helper
|_ [=bowl:gall state-1]
+* state +<+
++ match
|= =gill:gall
^- ?
?: =([our dap]:bowl gill) &
?~ need=(~(get by know) q.gill) & :: unversioned
%- ~(rep by u.need) ::NOTE +all:by is w/o key
|= [[p=protocol v=version] o=_&]
&(o =(``v (~(get by heed) [gill p]))) :: negotiated & matches
::
++ certain-mismatch
|= =gill:gall
^- ?
?: =([our dap]:bowl gill) |
?~ need=(~(get by know) q.gill) | :: unversioned
%- ~(rep by u.need)
|= [[p=protocol v=version] o=_|]
=+ h=(~(get by heed) [gill p])
|(o &(?=([~ ~ *] h) !=(v u.u.h))) :: negotiated & non-matching
::
++ get-status
|= =gill:gall
^- status
?: =([our dap]:bowl gill) %match
=/ need (~(gut by know) q.gill ~)
?: =(~ need) %match
=/ need ~(tap in ~(key by need))
?. (levy need |=(p=protocol (~(has by heed) gill p)))
%unmet
?: (lien need |=(p=protocol =(~ (~(got by heed) gill p))))
%await
?:((match gill) %match %clash)
:: +inflate: update state & manage subscriptions to be self-consistent
::
:: get previously-unregistered subs from the bowl, put them in .want,
:: kill subscriptions for non-known-matching gills, and start version
:: negotiation where needed.
::
++ inflate
|= knew=(unit config)
^- [[caz=(list card) kik=(list [wire gill:gall])] _state]
=* boat=boat:gall wex.bowl
:: establish subs from .want where versions match
::
=/ open=(list card)
%- zing
%+ turn ~(tap by want)
|= [=gill:gall m=(map wire path)]
?. (match gill) ~
%+ murn ~(tap by m)
|= [=wire =path]
=. wire (pack-wire wire gill)
?: (~(has by boat) [wire gill]) ~ :: already established
(some %pass wire %agent gill %watch path)
:: manage subs for new or non-matching gills
::
=/ [init=(set [gill:gall protocol]) kill=(set [=wire =gill:gall])]
%+ roll ~(tap by boat)
|= $: [[=wire =gill:gall] [? =path]]
[init=(set [gill:gall protocol]) kill=(set [=wire =gill:gall])]
==
^+ [init kill]
:: all subscriptions should be fully library-managed
::
?> ?=([%~.~ %negotiate *] wire)
:: ignore library-internal subscriptions
::
?: &(?=([%~.~ %negotiate @ *] wire) !=(%inner-watch i.t.t.wire))
[init kill]
:: if we don't need a specific version, leave the sub as-is
::
?: =([our dap]:bowl gill) [init kill]
=/ need=(list [p=protocol v=version])
~(tap by (~(gut by know) q.gill ~))
|-
?~ need [init kill]
:: if we haven't negotiated yet, we should start doing so
::
=/ hail=(unit (unit version))
(~(get by heed) [gill p.i.need])
?~ hail
=. init (~(put in init) [gill p.i.need])
=. kill (~(put in kill) [wire gill])
$(need t.need)
:: kill the subscription if the versions don't match
::
=? kill !=(u.hail `v.i.need)
(~(put in kill) [wire gill])
$(need t.need)
::
=^ inis state
=| caz=(list card)
=/ inz=(list [gill:gall protocol]) ~(tap in init)
|-
?~ inz [caz state]
=^ car state (negotiate i.inz)
$(caz (weld car caz), inz t.inz)
::
=/ notes=(list card)
?~ knew ~
%- zing
%+ turn ~(tap in `(set gill:gall)`(~(run in ~(key by heed)) head))
|= =gill:gall
^- (list card)
=/ did=? (match(know u.knew) gill)
=/ now=? (match gill)
?: =(did now) ~
%+ weld (notify-outer now gill)
?. notify ~
[(notify-inner now gill)]~
::
=^ leaves=(list card) want
%^ spin ~(tap in kill) want
|= [[=wire =gill:gall] =_want]
^- [card _want]
:: kill wires come straight from the boat, so we don't modify them
:: for leaves, but _must_ trim them for .want
::
:- [%pass wire %agent gill %leave ~]
=/ wan (~(gut by want) gill ~)
=. wan (~(del by wan) +:(trim-wire wire))
?~ wan (~(del by want) gill)
(~(put by want) gill wan)
::
=/ kik=(list [wire gill:gall])
%+ turn ~(tap in kill)
|= [w=wire g=gill:gall]
[+:(trim-wire w) g]
::
[[:(weld leaves notes open inis) kik] state]
:: +play-card: handle watches, leaves and pokes specially
::
++ play-card
|= =card
^- (quip ^card _state)
=* pass [[card]~ state]
:: handle cards targetted at us (the library) first
::
?: ?=([%give %fact [[%~.~ %negotiate *] ~] *] card)
~| [%negotiate %unknown-inner-card card]
:: only supported card right now is for initiating negotiation
::
?> =([/~/negotiate/initiate]~ paths.p.card)
?> =(%negotiate-initiate-version p.cage.p.card)
=+ !<(=gill:gall q.cage.p.card)
(negotiate-missing gill)
:: only capture agent cards
::
?. ?=([%pass * %agent *] card)
pass
:: always track the subscriptions we want to have
::
=* gill=gill:gall [ship name]:q.card
=? want ?=(%watch -.task.q.card)
=/ wan (~(gut by want) gill ~)
?: (~(has by wan) p.card)
~& [%duplicate-wire dap=dap.bowl wire=p.card path=path.task.q.card]
want
%+ ~(put by want) gill
(~(put by wan) p.card path.task.q.card)
=? want ?=(%leave -.task.q.card)
=/ wan (~(gut by want) gill ~)
=. wan (~(del by wan) p.card)
?~ wan (~(del by want) gill)
(~(put by want) gill wan)
:: stick the gill in the wire for watches and leaves,
:: so we can retrieve it later if needed
::
=? p.card ?=(?(%watch %leave) -.task.q.card)
(pack-wire p.card gill)
:: if the target agent is ourselves, always let the card go
::
?: =([our dap]:bowl [ship name]:q.card)
pass
:: if we don't require versions for the target agent, let the card go
::
=* dude=dude:gall name.q.card
?. (~(has by know) dude)
pass
:: %leave is always free to happen
::
?: ?=(%leave -.task.q.card)
pass
:: if we know our versions match, we are free to emit the card
::
?: (match gill)
pass
:: pokes may not happen if we know we mismatch
::
?: ?=(?(%poke %poke-as) -.task.q.card)
?: (certain-mismatch gill)
::TODO if heed was (map gill (map protocol (u v))) we could
:: reasonably look up where the mismatch was...
~| [%negotiate %poke-to-mismatching-gill gill]
!!
:: if we aren't certain of a match, ensure we've started negotiation
::
=^ caz state (negotiate-missing gill)
[[card caz] state]
:: watches will get reestablished once our versions match, but if we
:: haven't started negotiation yet, we should do that now
::
(negotiate-missing gill)
::
++ play-cards
|= cards=(list card)
^- (quip card _state)
=| out=(list card)
|-
?~ cards [out state]
=^ caz state (play-card i.cards)
$(out (weld out caz), cards t.cards)
::
++ negotiate-missing
|= =gill:gall
^- (quip card _state)
?: =([our dap]:bowl gill) [~ state]
=/ need=(list protocol)
~(tap in ~(key by (~(gut by know) q.gill ~)))
=| out=(list card)
|-
?~ need [out state]
?: (~(has by heed) [gill i.need]) $(need t.need)
=^ caz state (negotiate gill i.need)
$(out (weld out caz), need t.need)
::
++ negotiate
|= for=[gill:gall protocol]
^- (quip card _state)
?< (~(has by heed) for)
:- [(watch-version for)]~
state(heed (~(put by heed) for ~))
::
++ ours-changed
|= [ole=(map protocol version) neu=(map protocol version)]
^- (list card)
:: kick incoming subs for protocols we no longer support
::
%+ weld
%+ turn ~(tap by (~(dif by ole) neu))
|= [=protocol =version]
[%give %kick [/~/negotiate/version/[protocol]]~ ~]
:: give updates for protocols whose supported version changed
::
%+ murn ~(tap by neu)
|= [=protocol =version]
^- (unit card)
?: =(`version (~(get by ole) protocol)) ~
`[%give %fact [/~/negotiate/version/[protocol]]~ %noun !>(version)]
::
++ heed-changed
|= [for=[=gill:gall protocol] new=(unit version)]
^- [[caz=(list card) kik=(list [wire gill:gall])] _state]
=/ hav=(unit version)
~| %unrequested-heed
(~(got by heed) for)
?: =(new hav) [[~ ~] state]
=/ did=? (match gill.for)
=. heed (~(put by heed) for new)
=/ now=? (match gill.for)
:: we need to notify subscribers,
:: and we may need to notify the inner agent
::
=/ nos=(list card)
?: =(did now) ~
%+ weld (notify-outer now gill.for)
?. notify ~
[(notify-inner now gill.for)]~
=^ a state (inflate ~)
[[(weld caz.a nos) kik.a] state]
::
++ pack-wire
|= [=wire =gill:gall]
^+ wire
[%~.~ %negotiate %inner-watch (scot %p p.gill) q.gill wire]
::
++ trim-wire
|= =wire
^- [gill=(unit gill:gall) =_wire]
?. ?=([%~.~ %negotiate %inner-watch @ @ *] wire) [~ wire]
=, t.t.t.wire
[`[(slav %p i) i.t] t.t]
::
++ simulate-kicks
|= [kik=(list [=wire gill:gall]) inner=agent:gall]
^- [[(list card) _inner] _state]
=| cards=(list card)
|-
?~ kik [[cards inner] state]
=. wex.bowl (~(del by wex.bowl) (pack-wire i.kik) +.i.kik)
=^ caz inner
%. [wire.i.kik %kick ~]
%~ on-agent inner
inner-bowl(src.bowl p.i.kik)
=^ caz state (play-cards caz)
$(kik t.kik, cards (weld cards caz))
::
++ notify-outer
|= event=[match=? =gill:gall]
^- (list card)
=/ =path /~/negotiate/notify
=/ =json
:- %o
%- ~(gas by *(map @t json))
=, event
:~ 'match'^b+match
'gill'^s+(rap 3 (scot %p p.gill) '/' q.gill ~)
==
:~ [%give %fact [path]~ %negotiate-notification !>(event)]
[%give %fact [(snoc path %json)]~ %json !>(json)]
==
::
++ notify-inner
|= event=[match=? =gill:gall]
^- card
:+ %pass /~/negotiate/notify
[%agent [our dap]:bowl %poke %negotiate-notification !>(event)]
::
++ watch-version
|= [=gill:gall =protocol]
^- card
:+ %pass /~/negotiate/heed/(scot %p p.gill)/[q.gill]/[protocol]
[%agent gill %watch /~/negotiate/version/[protocol]]
::
++ retry-timer
|= [t=@dr p=path]
^- card
:+ %pass [%~.~ %negotiate %retry p]
[%arvo %b %wait (add now.bowl t)]
:: +inner-bowl: partially-faked bowl for the inner agent
::
:: the bowl as-is, but with library-internal subscriptions removed,
:: and temporarily-held subscriptions added in artificially.
::
++ inner-bowl
%_ bowl
sup
:: hide subscriptions coming in to this library
::
%- ~(gas by *bitt:gall)
%+ skip ~(tap by sup.bowl)
|= [* * =path]
?=([%~.~ %negotiate *] path)
::
wex
%- ~(gas by *boat:gall)
%+ weld
:: make sure all the desired subscriptions are in the bowl,
:: even if that means we have to simulate an un-acked state
::
^- (list [[wire ship term] ? path])
%- zing
%+ turn ~(tap by want)
|= [=gill:gall m=(map wire path)]
%+ turn ~(tap by m)
|= [=wire =path]
:- [wire gill]
(~(gut by wex.bowl) [wire gill] [| path])
:: hide subscriptions going out from this library.
:: because these go into the +gas:by call _after_ the faked entries
:: generated above, these (the originals) take precedence in the
:: resulting bowl.
::
%+ murn ~(tap by wex.bowl)
|= a=[[=wire gill:gall] ? path]
=^ g wire.a (trim-wire wire.a)
?^ g (some a)
?:(?=([%~.~ %negotiate *] wire.a) ~ (some a))
==
--
::
++ agent
|= inner=agent:gall
=| state-1
=* state -
^- agent:gall
!. :: we hide all the "straight into the inner agent" paths from traces
|_ =bowl:gall
+* this .
up ~(. helper bowl state)
og ~(. inner inner-bowl:up)
++ on-init
^- (quip card _this)
=. ours our-versions
=. know our-config
=^ cards inner on-init:og !:
=^ cards state (play-cards:up cards)
[cards this]
::
++ on-save !>([[%negotiate state] on-save:og])
++ on-load
|= ole=vase
^- (quip card _this)
?. ?=([[%negotiate *] *] q.ole)
=. ours our-versions
=. know our-config
:: upgrade the inner agent as normal, handling any new subscriptions
:: it creates like we normally do
::
=^ cards inner (on-load:og ole) !:
=^ cards state (play-cards:up cards)
:: but then, for every subscription that was established prior to
:: using this library, simulate a kick, forcing the inner agent to
:: re-establish those subscriptions, letting us wrap them like we
:: will do for all its subs going forward.
:: this way, after this +on-load call finishes, we should never again
:: see %watch-ack, %kick or %fact signs with non-wrapped wires.
::
=/ suz=(list [[=wire =gill:gall] [ack=? =path]])
~(tap by wex.bowl)
|-
?~ suz [cards this]
=* sub i.suz
=. cards (snoc cards [%pass wire.sub %agent gill.sub %leave ~])
=. wex.bowl (~(del by wex.bowl) -.sub)
=^ caz inner
=. src.bowl p.gill.sub
(on-agent:og wire.sub %kick ~)
=^ caz state (play-cards:up caz)
$(cards (weld cards caz), suz t.suz)
::
|^ =+ !<([[%negotiate old=state-any] ile=vase] ole)
?: ?=(%0 -.old)
:: version 0 didn't wrap all subscriptions, so we must simulate
:: kicks for those that weren't wrapped.
::NOTE at the time of writing, we know the very bounded set of
:: ships running version %0 of this library, and we know no
:: version numbers are changing during this upgrade, so we
:: simply don't worry about calling +inflate, similar to the
:: "initial +on-load" case.
::TODO that means we should probably obliterate the %0 type &
:: code branch once this has been deployed to the known ships.
::
=. state old(- %1)
!:
?> =(ours our-versions)
?> =(know our-config)
=^ cards inner (on-load:og ile)
=^ cards state (play-cards:up cards)
=/ suz=(list [[=wire =gill:gall] [ack=? =path]])
~(tap by wex.bowl)
|-
?~ suz [cards this]
=* sub i.suz
?: ?=([%~.~ %negotiate *] wire.sub)
$(suz t.suz)
~& [%negotiate dap.bowl %re-doing-sub sub]
=. cards (snoc cards [%pass wire.sub %agent gill.sub %leave ~])
=. wex.bowl (~(del by wex.bowl) -.sub)
=^ caz inner (on-agent:og wire.sub %kick ~)
=^ caz state (play-cards:up caz)
$(cards (weld cards caz), suz t.suz)
?> ?=(%1 -.old)
=. state old
=/ caz1
?: =(ours our-versions) ~
(ours-changed:up ours our-versions)
=. ours our-versions
=/ knew know
=. know our-config
=^ a state (inflate:up `knew)
=^ caz2 inner (on-load:og ile) !:
=^ caz2 state (play-cards:up caz2)
=^ [caz3=(list card) nin=_inner] state
(simulate-kicks:up kik.a inner)
=. inner nin
[:(weld caz1 caz.a caz2 caz3) this]
::
+$ state-any $%(state-0 state-1)
+$ state-0
$: %0
ours=(map protocol version)
know=config
heed=(map [gill:gall protocol] (unit version))
want=(map gill:gall (map wire path)) :: unpacked wires
==
--
::
++ on-watch
|= =path
^- (quip card _this)
?. ?=([%~.~ %negotiate *] path)
=^ cards inner (on-watch:og path) !:
=^ cards state (play-cards:up cards)
[cards this]
!:
?+ t.t.path !!
[%version @ ~] :: /~/negotiate/version/[protocol]
:: it is important that we nack if we don't expose this protocol
::
[[%give %fact ~ %noun !>((~(got by ours) i.t.t.t.path))]~ this]
::
[%notify ?([%json ~] ~)] :: /~/negotiate/notify(/json)
?> =(our src):bowl
[~ this]
==
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
=^ gill=(unit gill:gall) wire
(trim-wire:up wire)
?. ?=([%~.~ %negotiate *] wire)
=? want ?=(?([%kick ~] [%watch-ack ~ *]) sign)
!: ~| wire
=/ gill (need gill)
=/ wan (~(gut by want) gill ~)
=. wan (~(del by wan) wire)
?~ wan (~(del by want) gill)
(~(put by want) gill wan)
=^ cards inner (on-agent:og wire sign) !:
=^ cards state (play-cards:up cards)
[cards this]
!:
~| wire=t.t.wire
?+ t.t.wire ~|([%negotiate %unexpected-wire] !!)
[%notify ~] [~ this]
::
[%heed @ @ @ ~]
=/ for=[=gill:gall =protocol]
=* w t.t.t.wire
[[(slav %p i.w) i.t.w] i.t.t.w]
?- -.sign
%fact
=* mark p.cage.sign
=* vase q.cage.sign
?. =(%noun mark)
~& [negotiate+dap.bowl %ignoring-unexpected-fact mark=mark]
[~ this]
=+ !<(=version vase)
=^ a state (heed-changed:up for `version)
=^ [caz=(list card) nin=_inner] state
(simulate-kicks:up kik.a inner)
=. inner nin
[(weld caz.a caz) this]
::
%watch-ack
?~ p.sign [~ this]
:: if we no longer care about this particular version, drop it
::
?. (~(has by (~(gut by know) q.gill.for ~)) protocol.for)
=. heed (~(del by heed) for)
[~ this] ::NOTE don't care, so shouldn't need to inflate
:: if we still care, consider the version "unknown" for now,
:: and try re-subscribing later
::
=^ a state (heed-changed:up for ~)
=^ [caz=(list card) nin=_inner] state
(simulate-kicks:up kik.a inner)
=. inner nin
:: 30 minutes might cost us some responsiveness but in return we
:: save both ourselves and others from a lot of needless retries.
::
[[(retry-timer:up ~m30 [%watch t.t.wire]) (weld caz.a caz)] this]
::
%kick
:_ this
:: to prevent pathological kicks from exploding, we always
:: wait a couple seconds before resubscribing.
:: perhaps this is overly careful, but we cannot tell the
:: difference between "clog" kicks and "unexpected crash" kicks,
:: so we cannot take more accurate/appropriate action here.
::
[(retry-timer:up ~s15 [%watch t.t.wire])]~
::
%poke-ack
~& [negotiate+dap.bowl %unexpected-poke-ack wire]
[~ this]
==
==
::
++ on-peek
|= =path
^- (unit (unit cage))
?: =(/x/whey path)
:+ ~ ~
:- %mass
!> ^- (list mass)
:- %negotiate^&+state
=/ dat (on-peek:og path)
?: ?=(?(~ [~ ~]) dat) ~
(fall ((soft (list mass)) q.q.u.u.dat) ~)
?: =(/x/dbug/state path)
``noun+!>((slop on-save:og !>(negotiate=state)))
?. ?=([@ %~.~ %negotiate *] path)
(on-peek:og path)
!:
?. ?=(%x i.path) [~ ~]
?+ t.t.t.path [~ ~]
[%version ~] ``noun+!>(ours)
::
[%version @ @ @ ~]
=/ for=[gill:gall protocol]
=* p t.t.t.t.path
[[(slav %p i.p) i.t.p] i.t.t.p]
:^ ~ ~ %noun
!> ^- (unit version)
(~(gut by heed) for ~)
::
[%status ?([%json ~] ~)]
:+ ~ ~
=/ stas=(list [gill:gall status])
%+ turn ~(tap in `(set gill:gall)`(~(run in ~(key by heed)) head))
|=(=gill:gall [gill (get-status:up gill)])
?~ t.t.t.t.path
noun+!>((~(gas by *(map gill:gall status)) stas))
?> ?=([%json ~] t.t.t.t.path)
:- %json
!> ^- json
:- %o
%- ~(gas by *(map @t json))
%+ turn stas
|= [=gill:gall =status]
[(rap 3 (scot %p p.gill) '/' q.gill ~) s+status]
::
[%status @ @ ?([%json ~] ~)]
=/ for=gill:gall
=* p t.t.t.t.path
[(slav %p i.p) i.t.p]
=/ res=status
(get-status:up for)
?~ t.t.t.t.t.t.path ``noun+!>(res)
?> ?=([%json ~] t.t.t.t.t.t.path)
``json+!>(`json`s+res)
::
[%matching ?(~ [%json ~])]
:+ ~ ~
=/ mats=(list [gill:gall ?])
%+ turn ~(tap in `(set gill:gall)`(~(run in ~(key by heed)) head))
|=(=gill:gall [gill (match:up gill)])
?~ t.t.t.t.path
noun+!>((~(gas by *(map gill:gall ?)) mats))
?> ?=([%json ~] t.t.t.t.path)
:- %json
!> ^- json
:- %o
%- ~(gas by *(map @t json))
%+ turn mats
|= [=gill:gall match=?]
[(rap 3 (scot %p p.gill) '/' q.gill ~) b+match]
==
::
++ on-leave
|= =path
^- (quip card _this)
?: ?=([%~.~ %negotiate *] path) !:
[~ this]
=^ cards inner (on-leave:og path) !:
=^ cards state (play-cards:up cards)
[cards this]
::
++ on-arvo
|= [=wire sign=sign-arvo:agent:gall]
^- (quip card _this)
?. ?=([%~.~ %negotiate *] wire)
=^ cards inner (on-arvo:og wire sign) !:
=^ cards state (play-cards:up cards)
[cards this]
!:
~| wire=t.t.wire
?+ t.t.wire !!
[%retry *]
?> ?=(%wake +<.sign)
?+ t.t.t.wire !!
[%watch %heed @ @ @ ~]
=/ for=[gill:gall protocol]
=* w t.t.t.t.t.wire
[[(slav %p i.w) i.t.w] i.t.t.w]
[[(watch-version:up for)]~ this]
==
==
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
=^ cards inner (on-poke:og +<) !:
=^ cards state (play-cards:up cards)
[cards this]
::
++ on-fail
|= [term tang]
^- (quip card _this)
=^ cards inner (on-fail:og +<) !:
=^ cards state (play-cards:up cards)
[cards this]
--
--
--

14
desk/mar/contact-0.hoon Normal file
View File

@ -0,0 +1,14 @@
/- c=contacts, x=contacts-0
/+ j=contacts-json-0
|_ contact=contact-0:x
++ grad %noun
++ grow
|%
++ noun contact
++ json (contact:enjs:j contact)
--
++ grab
|%
++ noun contact-0:x
--
--

16
desk/mar/contact-1.hoon Normal file
View File

@ -0,0 +1,16 @@
/+ c=contacts
/+ j=contacts-json-1
|_ contact=contact:c
++ grad %noun
++ grow
|%
++ noun contact
++ json (contact:enjs:j contact)
--
++ grab
|%
++ noun contact:c
++ json contact:dejs:j
++ contact contact:from-0:c
--
--

17
desk/mar/contact.hoon
View File

@ -1,14 +1,3 @@
/- c=contacts
/+ j=contacts-json
|_ =contact:c
++ grad %noun
++ grow
|%
++ noun contact
++ json (contact:enjs:j contact)
--
++ grab
|%
++ noun contact:c
--
--
/= contact-0 /mar/contact-0
contact-0

8
desk/mar/contact/action-0.hoon
View File

@ -1,6 +1,6 @@
/- c=contacts
/+ j=contacts-json
|_ =action:c
/- c=contacts, legacy=contacts-0
/+ j=contacts-json-0
|_ action=action-0:legacy
++ grad %noun
++ grow
|%
@ -9,7 +9,7 @@
--
++ grab
|%
++ noun action:c
++ noun action-0:legacy
++ json action:dejs:j
--
--

16
desk/mar/contact/action-1.hoon
View File

@ -1,2 +1,14 @@
/= mark /mar/dummy
mark
/- c=contacts
/+ j=contacts-json-1
|_ action=action:c
++ grad %noun
++ grow
|%
++ noun action
--
++ grab
|%
++ noun action:c
++ json action:dejs:j
--
--

14
desk/mar/contact/book-0.hoon Normal file
View File

@ -0,0 +1,14 @@
/- c=contacts
/+ j=contacts-json-1
|_ book=book:c
++ grad %noun
++ grow
|%
++ noun book
++ json (book:enjs:j book)
--
++ grab
|%
++ noun book:c
--
--

14
desk/mar/contact/book.hoon Normal file
View File

@ -0,0 +1,14 @@
/- c=contacts
/+ j=contacts-json-1
|_ book=book:c
++ grad %noun
++ grow
|%
++ noun book
++ json (book:enjs:j book)
--
++ grab
|%
++ noun book:c
--
--

14
desk/mar/contact/directory-0.hoon Normal file
View File

@ -0,0 +1,14 @@
/- c=contacts
/+ j=contacts-json-1
|_ dir=directory:c
++ grad %noun
++ grow
|%
++ noun dir
++ json (directory:enjs:j dir)
--
++ grab
|%
++ noun directory:c
--
--

14
desk/mar/contact/directory.hoon Normal file
View File

@ -0,0 +1,14 @@
/- c=contacts
/+ j=contacts-json-1
|_ dir=directory:c
++ grad %noun
++ grow
|%
++ noun dir
++ json (directory:enjs:j dir)
--
++ grab
|%
++ noun directory:c
--
--

14
desk/mar/contact/news-1.hoon Normal file
View File

@ -0,0 +1,14 @@
/- c=contacts
/+ j=contacts-json-1
|_ =news:c
++ grad %noun
++ grow
|%
++ noun news
++ json (news:enjs:j news)
--
++ grab
|%
++ noun news:c
--
--

8
desk/mar/contact/news.hoon
View File

@ -1,6 +1,6 @@
/- c=contacts
/+ j=contacts-json
|_ =news:c
/- c=contacts, x=contacts-0
/+ j=contacts-json-0
|_ news=news-0:x
++ grad %noun
++ grow
|%
@ -9,6 +9,6 @@
--
++ grab
|%
++ noun news:c
++ noun news-0:x
--
--

14
desk/mar/contact/page-0.hoon Normal file
View File

@ -0,0 +1,14 @@
/- c=contacts
/+ j=contacts-json-1
|_ =page:c
++ grad %noun
++ grow
|%
++ noun page
++ json (page:enjs:j page)
--
++ grab
|%
++ noun page:c
--
--

14
desk/mar/contact/page-1.hoon Normal file
View File

@ -0,0 +1,14 @@
/- c=contacts
/+ j=contacts-json-1
|_ =page:c
++ grad %noun
++ grow
|%
++ noun page
++ json (page:enjs:j page)
--
++ grab
|%
++ noun page:c
--
--

14
desk/mar/contact/page.hoon Normal file
View File

@ -0,0 +1,14 @@
/- c=contacts
/+ j=contacts-json-1
|_ =page:c
++ grad %noun
++ grow
|%
++ noun page
++ json (page:enjs:j page)
--
++ grab
|%
++ noun page:c
--
--

14
desk/mar/contact/response-0.hoon Normal file
View File

@ -0,0 +1,14 @@
/- c=contacts
/+ j=contacts-json-1
|_ =response:c
++ grad %noun
++ grow
|%
++ noun response
++ json (response:enjs:j response)
--
++ grab
|%
++ noun response:c
--
--

8
desk/mar/contact/rolodex.hoon
View File

@ -1,6 +1,6 @@
/- c=contacts
/+ j=contacts-json
|_ rol=rolodex:c
/- c=contacts, x=contacts-0
/+ j=contacts-json-0
|_ rol=rolodex:x
++ grad %noun
++ grow
|%
@ -9,6 +9,6 @@
--
++ grab
|%
++ noun rolodex:c
++ noun rolodex:x
--
--

6
desk/mar/contact/update-0.hoon
View File

@ -1,5 +1,5 @@
/- c=contacts
|_ =update:c
/- c=contacts, x=contacts-0
|_ update=update-0:x
++ grad %noun
++ grow
|%
@ -7,6 +7,6 @@
--
++ grab
|%
++ noun update:c
++ noun update-0:x
--
--

14
desk/mar/contact/update-1.hoon
View File

@ -1,2 +1,12 @@
/= mark /mar/dummy
mark
/- c=contacts
|_ update=update:c
++ grad %noun
++ grow
|%
++ noun update
--
++ grab
|%
++ noun update:c
--
--

60
desk/sur/contacts-0.hoon Normal file
View File

@ -0,0 +1,60 @@
/- e=epic, g=groups
|%
+$ contact-0
$: nickname=@t
bio=@t
status=@t
color=@ux
avatar=(unit @t)
cover=(unit @t)
groups=(set flag:g)
==
::
+$ foreign-0 [for=$@(~ profile-0) sag=$@(~ saga-0)]
+$ profile-0 [wen=@da con=$@(~ contact-0)]
+$ rolodex (map ship foreign-0)
::
+$ saga-0
$@ $? %want :: subscribing
%fail :: %want failed
%lost :: epic %fail
~ :: none intended
==
saga:e
::
+$ field-0
$% [%nickname nickname=@t]
[%bio bio=@t]
[%status status=@t]
[%color color=@ux]
[%avatar avatar=(unit @t)]
[%cover cover=(unit @t)]
[%add-group =flag:g]
[%del-group =flag:g]
==
::
+$ action-0
:: %anon: delete our profile
:: %edit: change our profile
:: %meet: track a peer
:: %heed: follow a peer
:: %drop: discard a peer
:: %snub: unfollow a peer
::
$% [%anon ~]
[%edit p=(list field-0)]
[%meet p=(list ship)]
[%heed p=(list ship)]
[%drop p=(list ship)]
[%snub p=(list ship)]
==
:: network
::
+$ update-0
$% [%full profile-0]
==
:: local
::
+$ news-0
[who=ship con=$@(~ contact-0)]
--

180
desk/sur/contacts.hoon
View File

@ -1,89 +1,137 @@
/- e=epic, g=groups
|%
:: [compat] protocol-versioning scheme
::
:: adopted from :groups, slightly modified.
::
:: for our action/update marks, we
:: - *must* support our version (+okay)
:: - *should* support previous versions (especially actions)
:: - but *can't* support future versions
::
:: in the case of updates at unsupported protocol versions,
:: we backoff and subscribe for version changes (/epic).
:: (this alone is unlikely to help with future versions,
:: but perhaps our peer will downgrade. in the meantime,
:: we wait to be upgraded.)
::
+| %compat
++ okay `epic`0
++ mar
|%
++ base
|%
+$ act %contact-action
+$ upd %contact-update
--
::
++ act `mark`^~((rap 3 *act:base '-' (scot %ud okay) ~))
++ upd `mark`^~((rap 3 *upd:base '-' (scot %ud okay) ~))
--
::
++ okay `epic`1
::
+| %types
+$ contact
$: nickname=@t
bio=@t
status=@t
color=@ux
avatar=(unit @t)
cover=(unit @t)
groups=(set flag:g)
==
:: $value-type: contact field value type
::
+$ foreign [for=$@(~ profile) sag=$@(~ saga)]
+$ profile [wen=@da con=$@(~ contact)]
+$ rolodex (map ship foreign)
+$ value-type
$? %text
%numb
%date
%tint
%ship
%look
%flag
%set
==
:: $value: contact field value
::
+$ value
$+ contact-value
$@ ~
$% [%text p=@t]
[%numb p=@ud]
[%date p=@da]
::
:: color
[%tint p=@ux]
[%ship p=ship]
::
:: picture
[%look p=@ta]
::
:: group
[%flag p=flag:g]
::
:: uniform set
[%set p=$|((set value) unis)]
==
:: +unis: whether set is uniformly typed
::
++ unis
|= set=(set value)
^- ?
?~ set &
=/ typ -.n.set
|-
?& =(typ -.n.set)
?~(l.set & $(set l.set))
?~(r.set & $(set r.set))
==
:: $contact: contact data
::
+$ contact (map @tas value)
:: $profile: contact profile
::
:: .wen: last updated
:: .con: contact
::
+$ profile [wen=@da con=contact]
:: $foreign: foreign profile
::
:: .for: profile
:: .sag: connection status
::
+$ foreign [for=$@(~ profile) sag=saga]
:: $page: contact page
::
:: .con: peer contact
:: .mod: user overlay
::
+$ page [con=contact mod=contact]
:: $cid: contact page id
::
+$ cid @uvF
:: $kip: contact book key
::
+$ kip $@(ship [%id cid])
:: $book: contact book
::
+$ book (map kip page)
:: $directory: merged contacts
::
+$ directory (map ship contact)
:: $peers: network peers
::
+$ peers (map ship foreign)
::
+$ epic epic:e
+$ saga
$@ $? %want :: subscribing
%fail :: %want failed
%lost :: epic %fail
~ :: none intended
==
saga:e
::
+$ field
$% [%nickname nickname=@t]
[%bio bio=@t]
[%status status=@t]
[%color color=@ux]
[%avatar avatar=(unit @t)]
[%cover cover=(unit @t)]
[%add-group =flag:g]
[%del-group =flag:g]
+$ saga
$? %want :: subscribing
~ :: none intended
==
:: %anon: delete our profile
:: %self: edit our profile
:: %page: create a new contact page
:: %edit: edit a contact overlay
:: %wipe: delete a contact page
:: %meet: track a peer
:: %drop: discard a peer
:: %snub: unfollow a peer
::
+$ action
:: %anon: delete our profile
:: %edit: change our profile
:: %meet: track a peer
:: %heed: follow a peer
:: %drop: discard a peer
:: %snub: unfollow a peer
::
$% [%anon ~]
[%edit p=(list field)]
[%self p=contact]
[%page p=kip q=contact]
[%edit p=kip q=contact]
[%wipe p=(list kip)]
[%meet p=(list ship)]
[%heed p=(list ship)]
[%drop p=(list ship)]
[%snub p=(list ship)]
==
:: network update
::
+$ update :: network
:: %full: our profile
::
+$ update
$% [%full profile]
==
:: $response: local update
::
+$ news :: local
[who=ship con=$@(~ contact)]
:: %self: profile update
:: %page: contact page update
:: %wipe: contact page delete
:: %peer: peer update
::
+$ response
$% [%self con=contact]
[%page =kip con=contact mod=contact]
[%wipe =kip]
[%peer who=ship con=contact]
==
--

1093
desk/tests/app/contacts.hoon Normal file
View File

File diff suppressed because it is too large Load Diff

84
desk/tests/lib/contacts-json-1.hoon Normal file
View File

@ -0,0 +1,84 @@
/- *contacts, g=groups
/+ *test
/+ c=contacts, j=contacts-json-1, mark-warmer
::
/= c0 /mar/contact-0
/= c1 /mar/contact
/~ mar * /mar/contact
::
|%
::
++ ex-equal
|= [a=vase b=vase]
(expect-eq b a)
::
++ jen-equal
|= [jon=json txt=@t]
%+ ex-equal
!> (en:json:html jon)
!> txt
::
++ test-ship
%+ jen-equal
(ship:enjs:j ~sampel-palnet)
'"~sampel-palnet"'
++ test-cid
%+ jen-equal
(cid:enjs:j 0v11abc)
'"0v11abc"'
++ test-kip
;: weld
%+ jen-equal
(kip:enjs:j ~sampel-palnet)
'"~sampel-palnet"'
::
%+ jen-equal
(kip:enjs:j id+0v11abc)
'"0v11abc"'
==
++ test-value
;: weld
::
%+ jen-equal
(value:enjs:j text+'the lazy fox')
'{"type":"text","value":"the lazy fox"}'
::
%+ jen-equal
(value:enjs:j numb+42)
'{"type":"numb","value":42}'
::
%+ jen-equal
(value:enjs:j date+~2024.9.11)
'{"type":"date","value":"~2024.9.11"}'
::
%+ jen-equal
(value:enjs:j [%tint 0xcafe.babe])
'{"type":"tint","value":"cafe.babe"}'
::
%+ jen-equal
(value:enjs:j [%ship ~sampel-palnet])
'{"type":"ship","value":"~sampel-palnet"}'
::
%+ jen-equal
(value:enjs:j [%look 'https://ship.io/avatar.png'])
'{"type":"look","value":"https://ship.io/avatar.png"}'
::
%+ jen-equal
(value:enjs:j [%flag [~sampel-palnet %circle]])
'{"type":"flag","value":"~sampel-palnet/circle"}'
::
%+ jen-equal
%- value:enjs:j
[%set (silt `(list value)`~[flag/[~sampel-palnet %circle] flag/[~sampel-pardux %square]])]
'{"type":"set","value":[{"type":"flag","value":"~sampel-palnet/circle"},{"type":"flag","value":"~sampel-pardux/square"}]}'
==
++ test-contact
%+ jen-equal
%- contact:enjs:j
%- malt
^- (list [@tas value])
:~ name+text/'Sampel'
surname+text/'Palnet'
==
'{"name":{"type":"text","value":"Sampel"},"surname":{"type":"text","value":"Palnet"}}'
--