contacts: write hooks and use permisssioning system

This commit is contained in:
Logan Allen 2021-01-19 15:07:11 -06:00
parent 6d95cc76a4
commit 54b64f5682
4 changed files with 187 additions and 9 deletions

View File

@ -0,0 +1,45 @@
/- *resource
/+ store=contact-store, contact, default-agent, verb, dbug, pull-hook
~% %contact-pull-hook-top ..part ~
|%
+$ card card:agent:gall
++ config
^- config:pull-hook
:* %contact-store
update:store
%contact-update
%contact-push-hook
==
--
::
%- agent:dbug
^- agent:gall
%- (agent:pull-hook config)
^- (pull-hook:pull-hook config)
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
dep ~(. (default:pull-hook this config) bowl)
con ~(. contact bowl)
::
++ on-init on-init:def
++ on-save !>(~)
++ on-load on-load:def
++ on-poke on-poke:def
++ on-peek on-peek:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
++ on-agent on-agent:def
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-pull-nack
|= [=resource =tang]
^- (quip card _this)
:_ this
?~ (get-contact:con entity.resource) ~
=- [%pass /pl-nack %agent [our.bowl %contact-store] %poke %contact-update -]~
!> ^- update:store
[%remove entity.resource]
::
++ on-pull-kick |=(=resource `/)
--

View File

@ -0,0 +1,81 @@
/+ store=contact-store, res=resource, contact, default-agent, dbug, push-hook
~% %contact-push-hook-top ..part ~
|%
+$ card card:agent:gall
++ config
^- config:push-hook
:* %contact-store
/our
update:store
%contact-update
%graph-pull-hook
==
::
+$ agent (push-hook:push-hook config)
--
::
%- agent:dbug
^- agent:gall
%- (agent:push-hook config)
^- agent
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
con ~(. contact bowl)
::
++ on-init on-init:def
++ on-save !>(~)
++ on-load on-load:def
++ on-poke on-poke:def
++ on-agent on-agent:def
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
::
++ should-proxy-update
|= =vase
^- ?
=/ =update:store !<(update:store vase)
?- -.update
%initial %.n
%add %.y
%remove %.y
%edit %.y
%allow %.n
%disallow %.n
==
::
++ resource-for-update
|= =vase
^- (unit resource:res)
=/ =update:store !<(update:store vase)
?- -.update
%initial ~
%add `[our.bowl %our]
%remove `[our.bowl %our]
%edit `[our.bowl %our]
%allow ~
%disallow `[our.bowl %our]
==
::
++ initial-watch
|= [=path =resource:res]
^- vase
?> (is-allowed:con src.bowl)
!> ^- update:store
=/ contact=(unit contact:store) (get-contact:con our.bowl)
:+ %add
our.bowl
?^ contact u.contact
*contact:store
::
++ take-update
|= =vase
^- [(list card) agent]
=/ =update:store !<(update:store vase)
?. ?=(%disallow -.update) [~ this]
:_ this
[%give %kick ~[resource+(en-path:res [our.bowl %our])] ~]~
--

View File

@ -48,6 +48,14 @@
?+ path (on-watch:def path)
[%all ~] (give [%initial rolodex])
[%updates ~] ~
::
[%our ~]
%- give
:+ %add
our.bowl
=/ contact=(unit contact:store) (~(get by rolodex) our.bowl)
?~ contact *contact:store
u.contact
==
[cards this]
::
@ -87,20 +95,19 @@
^- (quip card _state)
=. rolodex (~(uni by rolodex) rolo)
:_ state(rolodex rolodex)
(send-diff [%initial rolodex])
(send-diff [%initial rolodex] %.n)
::
++ handle-add
|= [=ship =contact:store]
^- (quip card _state)
?< (~(has by rolodex) ship)
:- (send-diff [%add ship contact])
:- (send-diff [%add ship contact] =(ship our.bowl))
state(rolodex (~(put by rolodex) ship contact))
::
++ handle-remove
|= =ship
^- (quip card _state)
?> (~(has by rolodex) ship)
:- (send-diff [%remove ship])
:- (send-diff [%remove ship] =(ship our.bowl))
state(rolodex (~(del by rolodex) ship))
::
++ handle-edit
@ -109,7 +116,7 @@
^- (quip card _state)
=/ contact (~(got by rolodex) ship)
=. contact (edit-contact contact edit-field)
:- (send-diff [%edit ship edit-field])
:- (send-diff [%edit ship edit-field] =(ship our.bowl))
state(rolodex (~(put by rolodex) ship contact))
::
++ edit-contact
@ -128,7 +135,7 @@
++ handle-allow
|= =beings:store
^- (quip card _state)
:- (send-diff [%allow beings])
:- (send-diff [%allow beings] %.n)
?- -.beings
%group state(allowed-groups (~(put in allowed-groups) resource.beings))
%ships state(allowed-ships (~(uni in allowed-ships) ships.beings))
@ -137,16 +144,20 @@
++ handle-disallow
|= =beings:store
^- (quip card _state)
:- (send-diff [%disallow beings])
:- (send-diff [%disallow beings] %.y)
?- -.beings
%group state(allowed-groups (~(del in allowed-groups) resource.beings))
%ships state(allowed-ships (~(dif in allowed-ships) ships.beings))
==
::
++ send-diff
|= =update:store
|= [=update:store our=?]
^- (list card)
[%give %fact ~[/updates] %contact-update !>(update)]~
=/ paths=(list path)
?: our
`(list path)`[/updates /our]~
~[/updates]
[%give %fact paths %contact-update !>(update)]~
--
::
++ import
@ -169,6 +180,13 @@
:- ~ :- ~ :- %contact-update
!> ^- update:store
[%add ship u.contact]
::
[%x %allowed-ship @ ~]
=/ =ship (slav %p i.t.t.path)
``noun+!>((~(has in allowed-ships) ship))
::
[%x %allowed-groups ~]
``noun+!>(allowed-groups)
==
::
++ on-leave on-leave:def

34
pkg/arvo/lib/contact.hoon Normal file
View File

@ -0,0 +1,34 @@
/- store=contact-store
/+ group
|_ =bowl:gall
++ scry-for
|* [=mold =path]
.^ mold
%gx
(scot %p our.bowl)
%contact-store
(scot %da now.bowl)
(snoc `^path`path %noun)
==
::
++ get-contact
|= =ship
^- (unit contact:store)
=/ upd (scry-for (unit update:store) /contact/(scot %p ship))
?~ upd ~
?> ?=(%add -.u.upd)
`contact.u.upd
::
++ is-allowed
|= =ship
^- ?
=/ shp (scry-for ? /allowed-ship/(scot %p ship))
?: shp %.y
=/ allowed-groups ~(tap in (scry-for (set resource) /allowed-groups))
=/ grp ~(. group bowl)
|-
?~ allowed-groups %.n
?: ~(has in (members:grp i.allowed-groups) ship)
%.y
$(allowed-groups t.allowed-groups)
--