mirror of
https://github.com/ilyakooo0/urbit.git
synced 2025-01-02 20:15:27 +03:00
groups: finish rewrite
This commit is contained in:
Liam Fitzgerald
parent
d2de8d72eb
commit
f60181871a
@ -1,7 +1,7 @@
|
||||
:: group-hook: allow syncing group data from foreign paths to local paths
|
||||
::
|
||||
/- *group, store=group-store, hook=group-hook
|
||||
/+ default-agent, verb, dbug
|
||||
/- *group, hook=group-hook, *invite-store
|
||||
/+ default-agent, verb, dbug, store=group-store, grpl=group
|
||||
~% %group-hook-top ..is ~
|
||||
|%
|
||||
+$ card card:agent:gall
|
||||
@ -19,7 +19,8 @@
|
||||
::
|
||||
+$ state-one
|
||||
$: %1
|
||||
synced=(map group-id ship)
|
||||
listening=(set group-id)
|
||||
proxied=(jug group-id ship)
|
||||
==
|
||||
::
|
||||
--
|
||||
@ -30,34 +31,422 @@
|
||||
%- agent:dbug
|
||||
%+ verb |
|
||||
^- agent:gall
|
||||
|_ =bowl:gall
|
||||
+* this .
|
||||
group-core +>
|
||||
gc ~(. group-core bowl)
|
||||
def ~(. (default-agent this %|) bowl)
|
||||
=<
|
||||
|_ =bowl:gall
|
||||
+* this .
|
||||
group-core +>
|
||||
gc ~(. group-core bowl)
|
||||
def ~(. (default-agent this %|) bowl)
|
||||
::
|
||||
++ on-init
|
||||
^- (quip card _this)
|
||||
:_ this
|
||||
:- [%pass /invites %agent [our.bowl %invite-store] %poke %invite-action !>([%create /groups])]
|
||||
~[watch-invites:gc watch-store:gc]
|
||||
++ on-save !>(state)
|
||||
++ on-load
|
||||
|= =vase
|
||||
^- (quip card _this)
|
||||
=/ old !<(state-one vase)
|
||||
`this(state old)
|
||||
:: %+ murn ~(tap by synced.old)
|
||||
:: |= [=path =ship]
|
||||
:: ^- (unit card)
|
||||
:: =/ =wire [(scot %p ship) %group path]
|
||||
:: =/ =term ?:(=(our.bowl ship) %group-store %group-hook)
|
||||
:: ?: (~(has by wex.bowl) [wire ship term]) ~
|
||||
:: `[%pass wire %agent [ship term] %watch [%group path]]
|
||||
::
|
||||
++ on-poke
|
||||
|= [=mark =vase]
|
||||
^- (quip card _this)
|
||||
=^ cards state
|
||||
?+ mark (on-poke:def mark vase)
|
||||
%group-action (poke-group-update:gc !<(action:store vase))
|
||||
%group-hook-action (poke-hook-action:gc !<(action:hook vase))
|
||||
==
|
||||
[cards this]
|
||||
::
|
||||
++ on-agent
|
||||
|= [=wire =sign:agent:gall]
|
||||
^- (quip card _this)
|
||||
=^ cards state
|
||||
?+ -.wire (on-agent:def:gc wire sign)
|
||||
%invites (take-invite-sign:gc wire sign)
|
||||
%store (take-store-sign:gc wire sign)
|
||||
%proxy (take-proxy-sign:gc wire sign)
|
||||
==
|
||||
[cards this]
|
||||
::
|
||||
++ on-watch
|
||||
|= =path
|
||||
^- (quip card _this)
|
||||
?< (team:title [our src]:bowl)
|
||||
?> ?=([%groups *] path)
|
||||
=/ =group-id
|
||||
(need (group-id:de-path:store t.path))
|
||||
?> (permitted:gc src.bowl group-id)
|
||||
=^ cards state
|
||||
(start-proxy:gc src.bowl group-id)
|
||||
[cards this]
|
||||
::
|
||||
++ on-leave
|
||||
|= =path
|
||||
^- (quip card _this)
|
||||
?> ?=([%groups @ @ ~] path)
|
||||
=/ =group-id
|
||||
(need (group-id:de-path:store t.path))
|
||||
=^ cards state
|
||||
(stop-proxy:gc src.bowl group-id)
|
||||
[cards this]
|
||||
++ on-peek on-peek:def
|
||||
++ on-arvo on-arvo:def
|
||||
++ on-fail on-fail:def
|
||||
--
|
||||
|_ bol=bowl:gall
|
||||
++ def ~(. (default-agent state %|) bol)
|
||||
++ grp ~(. grpl bol)
|
||||
:: +| %pokes
|
||||
::
|
||||
++ on-init on-init:def
|
||||
++ on-save !>(state)
|
||||
++ on-load
|
||||
|= =vase
|
||||
^- (quip card _this)
|
||||
=/ old !<(state-one vase)
|
||||
:_ this(state old)
|
||||
%+ murn ~(tap by synced.old)
|
||||
|= [=path =ship]
|
||||
^- (unit card)
|
||||
=/ =wire [(scot %p ship) %group path]
|
||||
=/ =term ?:(=(our.bowl ship) %group-store %group-hook)
|
||||
?: (~(has by wex.bowl) [wire ship term]) ~
|
||||
`[%pass wire %agent [ship term] %watch [%group path]]
|
||||
:: +poke-group-update: Proxy poke to %group-store
|
||||
::
|
||||
++ on-leave on-leave:def
|
||||
++ on-peek on-peek:def
|
||||
++ on-arvo on-arvo:def
|
||||
++ on-fail on-fail:def
|
||||
:: Only proxy pokes if permissions are correct and we host the group.
|
||||
::
|
||||
++ on-poke on-poke:def
|
||||
++ on-watch on-watch:def
|
||||
++ on-agent on-agent:def
|
||||
>>>>>>> 457bd4c3a... groups: begin rewrite
|
||||
++ poke-group-update
|
||||
|= =update:store
|
||||
^- (quip card _state)
|
||||
?: ?=(%initial -.update)
|
||||
[~ state]
|
||||
?> =(ship.group-id.update our.bol)
|
||||
=/ =path
|
||||
(group-id:en-path:store group-id.update)
|
||||
?> (should-proxy-poke update)
|
||||
?> (is-permitted:grp src.bol path)
|
||||
:_ state
|
||||
[%pass [%store path] %agent [our.bol %group-store] %poke %group-update !>(update)]~
|
||||
:: +poke-hook-action: Start/stop syncing a foreign group
|
||||
::
|
||||
++ poke-hook-action
|
||||
|= =action:hook
|
||||
^- (quip card _state)
|
||||
|^
|
||||
?- -.action
|
||||
%add (add +.action)
|
||||
%remove (remove +.action)
|
||||
==
|
||||
++ add
|
||||
|= =group-id
|
||||
^- (quip card _state)
|
||||
?: (~(has in listening) group-id)
|
||||
`state
|
||||
=. listening
|
||||
(~(put in listening) group-id)
|
||||
:_ state
|
||||
:~ (listen-group group-id)
|
||||
(add-self group-id)
|
||||
==
|
||||
++ remove
|
||||
|= =group-id
|
||||
^- (quip card _state)
|
||||
?. (~(has in listening) group-id)
|
||||
`state
|
||||
=. listening
|
||||
(~(del in listening) group-id)
|
||||
:_ state
|
||||
(leave-group group-id)
|
||||
--
|
||||
:: |signs: signs from agents
|
||||
::
|
||||
:: +| %signs
|
||||
++ take-invite-sign
|
||||
|= [=wire =sign:agent:gall]
|
||||
^- (quip card _state)
|
||||
|^
|
||||
?+ -.sign (on-agent:def wire sign)
|
||||
%kick [~[watch-invites] state]
|
||||
::
|
||||
%fact
|
||||
?. =(%invite-update p.cage.sign)
|
||||
[~ state]
|
||||
(fact !<(invite-update q.cage.sign))
|
||||
==
|
||||
++ fact
|
||||
|= update=invite-update
|
||||
^- (quip card _state)
|
||||
?+ -.update [~ state]
|
||||
%invite
|
||||
=* invite invite.update
|
||||
?. =(our.bol ship.invite)
|
||||
[~ state]
|
||||
=/ =group-id
|
||||
(need (group-id:de-path:store path.invite))
|
||||
=/ =cage
|
||||
:- %group-update
|
||||
!> ^- update:store
|
||||
[%change-policy group-id [%add-invites (sy recipient.invite ~)]]
|
||||
:_ state
|
||||
[%pass [%store path.invite] %agent [our.bol %group-store] %poke cage]~
|
||||
%accepted
|
||||
=* invite invite.update
|
||||
?. =(our.bol ship.invite)
|
||||
[~ state]
|
||||
=/ =group-id
|
||||
(need (group-id:de-path:store path.update))
|
||||
=/ =cage
|
||||
:- %group-update
|
||||
!> ^- update:store
|
||||
[%add-members group-id (sy recipient.invite ~) ~]
|
||||
:_ state
|
||||
[%pass [%store path.invite] %agent [our.bol %group-store] %poke cage]~
|
||||
==
|
||||
--
|
||||
:: +take-proxy-sign: take sign from foreign %group-hook
|
||||
::
|
||||
++ take-proxy-sign
|
||||
|= [=wire =sign:agent:gall]
|
||||
^- (quip card _state)
|
||||
=/ =group-id
|
||||
~| "bad proxy wire: {<wire>}"
|
||||
(need (group-id:de-path:store +.wire))
|
||||
|^
|
||||
?+ -.sign (on-agent:def wire sign)
|
||||
%kick [~[(listen-group group-id)] state]
|
||||
::
|
||||
%fact
|
||||
?. ?=(%group-update p.cage.sign)
|
||||
[~ state]
|
||||
(fact !<(update:store q.cage.sign))
|
||||
==
|
||||
::
|
||||
:: +fact: Handle new update from %group-hook
|
||||
::
|
||||
++ fact
|
||||
|= =update:store
|
||||
^- (quip card _state)
|
||||
?: ?=(%initial -.update)
|
||||
[~ state]
|
||||
:_ state
|
||||
[%pass [%store wire] %agent [our.bol %group-store] %poke %group-update !>(update)]~
|
||||
--
|
||||
:: +take-store-sign: Handle incoming sign from %group-store
|
||||
::
|
||||
:: group-store should send us all its store updates over a subscription on
|
||||
:: /groups. We also proxy pokes to it.
|
||||
::
|
||||
++ take-store-sign
|
||||
|= [=wire =sign:agent:gall]
|
||||
^- (quip card _state)
|
||||
|^
|
||||
?+ -.sign (on-agent:def wire sign)
|
||||
%kick [~[watch-store] state]
|
||||
::
|
||||
%fact
|
||||
?+ p.cage.sign ~|("{<dap.bol>} unexpected mark: {<p.cage.sign>}" !!)
|
||||
%group-initial [~ state]
|
||||
%group-update (fact !<(update:store q.cage.sign))
|
||||
==
|
||||
==
|
||||
:: +take-store-update: Handle new %fact from %group-store
|
||||
::
|
||||
:: We forward the update onto the correct path, and recalculate permissions,
|
||||
:: kicking any subscriptions whose permissions have been revoked.
|
||||
::
|
||||
++ fact
|
||||
|= =update:store
|
||||
^- (quip card _state)
|
||||
?: ?=(%initial -.update)
|
||||
`state
|
||||
=/ =path
|
||||
(group-id:en-path:store group-id.update)
|
||||
?. (~(has by proxied) group-id.update)
|
||||
[~ state]
|
||||
=^ cards state
|
||||
(handle-revocations update)
|
||||
:_ state
|
||||
:- [%give %fact [%groups path]~ %group-update !>(update)]
|
||||
cards
|
||||
--
|
||||
:: +listen-group: Start a new subscription to the proxied .group-id
|
||||
::
|
||||
++ listen-group
|
||||
|= =group-id
|
||||
^- card
|
||||
=/ pax=path
|
||||
(group-id:en-path:store group-id)
|
||||
[%pass [%proxy pax] %agent [ship.group-id %group-hook] %watch [%groups pax]]
|
||||
:: +add-self: Add self to group
|
||||
++ add-self
|
||||
|= =group-id
|
||||
^- card
|
||||
=/ pax=path
|
||||
(group-id:en-path:store group-id)
|
||||
=/ =cage
|
||||
:- %group-action
|
||||
!> ^- action:store
|
||||
[%add-members group-id (sy our.bol ~) ~]
|
||||
[%pass [%proxy pax] %agent [ship.group-id %group-hook] %poke cage]
|
||||
:: +leave-group: Leave a foreign group
|
||||
::
|
||||
++ leave-group
|
||||
|= =group-id
|
||||
^- (list card)
|
||||
=/ pax=path
|
||||
(group-id:en-path:store group-id)
|
||||
:~ [%pass [%proxy pax] %agent [ship.group-id %group-hook] %leave ~]
|
||||
[%pass [%store pax] %agent [our.bol %group-store] %poke %group-update !>([%remove-group group-id ~])]
|
||||
[%pass [%proxy pax] %agent [ship.group-id %group-hook] %poke %group-action !>([%remove-members group-id (sy our.bol ~)])]
|
||||
==
|
||||
:: +store-leave-group: Remove a foreign group from our group-store
|
||||
::
|
||||
++ store-leave-group
|
||||
|= =group-id
|
||||
^- card
|
||||
=/ pax=path
|
||||
(group-id:en-path:store group-id)
|
||||
[%pass [%store pax] %agent [our.bol %group-store] %poke %group-update !>([%remove-group group-id ~])]
|
||||
:: +should-proxy-poke: Check if poke should be proxied
|
||||
::
|
||||
:: We only allow users to add and remove themselves.
|
||||
++ should-proxy-poke
|
||||
|= =update:store
|
||||
^- ?
|
||||
?: ?=(%initial -.update)
|
||||
%.n
|
||||
|^
|
||||
=/ role=(unit role-tag)
|
||||
(role-for-ship:grp group-id.update src.bol)
|
||||
?~ role
|
||||
member
|
||||
?- u.role
|
||||
%admin admin
|
||||
%moderator moderator
|
||||
%janitor member
|
||||
==
|
||||
++ member
|
||||
?: ?=(%add-members -.update)
|
||||
=(~(tap in ships.update) ~[src.bol])
|
||||
?: ?=(%remove-members -.update)
|
||||
=(~(tap in ships.update) ~[src.bol])
|
||||
%.n
|
||||
++ admin
|
||||
!?=(?(%remove-group %add-group) -.update)
|
||||
++ moderator
|
||||
?= $? %add-members %remove-members
|
||||
%add-tag %remove-tag ==
|
||||
-.update
|
||||
--
|
||||
::
|
||||
:: +handle-revocations: Handle revoked permissions from a update:store
|
||||
::
|
||||
:: If the mutation to the group store has impacted permissions, then kick
|
||||
:: relevant subscriptions and remove them from our state
|
||||
::
|
||||
++ handle-revocations
|
||||
|= =update:store
|
||||
^- (quip card _state)
|
||||
?+ -.update [~ state]
|
||||
::
|
||||
%remove-group
|
||||
=* group-id group-id.update
|
||||
=/ =path
|
||||
(group-id:en-path:store group-id)
|
||||
=. proxied
|
||||
(~(del by proxied) group-id)
|
||||
:_ state
|
||||
[%give %kick [%groups path]~ ~]~
|
||||
::
|
||||
%remove-members
|
||||
=* group-id group-id.update
|
||||
=/ =path
|
||||
(group-id:en-path:store group-id)
|
||||
=/ to-kick=(list ship)
|
||||
~(tap in ships.update)
|
||||
=/ subs=(set ship)
|
||||
(~(gut by proxied) group-id ~)
|
||||
=| cards=(list card)
|
||||
|-
|
||||
?~ to-kick
|
||||
[cards state]
|
||||
=. proxied
|
||||
(~(del ju proxied) group-id i.to-kick)
|
||||
=. cards
|
||||
[[%give %kick [%groups path]~ `i.to-kick] cards]
|
||||
$(to-kick t.to-kick)
|
||||
==
|
||||
:: +start-proxy: Start proxying .path to .who
|
||||
::
|
||||
++ start-proxy
|
||||
|= [who=ship =group-id]
|
||||
^- (quip card _state)
|
||||
=. proxied
|
||||
(~(put ju proxied) group-id who)
|
||||
[(give-initial group-id) state]
|
||||
:: +stop-proxy: Stop proxying .path to .who
|
||||
::
|
||||
++ stop-proxy
|
||||
|= [who=ship =group-id]
|
||||
^- (quip card _state)
|
||||
=. proxied
|
||||
(~(del ju proxied) group-id who)
|
||||
`state
|
||||
:: +can-join: check if .ship can join .group-id
|
||||
::
|
||||
++ can-join
|
||||
|= [=ship =group-id]
|
||||
^- ?
|
||||
=/ =path
|
||||
(group-id:en-path:store group-id)
|
||||
=* group-id u.u-group-id
|
||||
=/ scry-path=^path
|
||||
(welp [%groups path] /join/[(scot %p ship)])
|
||||
(scry-store ? scry-path)
|
||||
:: +give-initial: give initial state for .group-id
|
||||
::
|
||||
:: Must be called in +on-watch. No-ops if the group does not exist yet
|
||||
++ give-initial
|
||||
|= =group-id
|
||||
^- (list card)
|
||||
=/ =path
|
||||
(group-id:en-path:store group-id)
|
||||
=/ u-group
|
||||
(scry-store (unit group) [%groups path])
|
||||
?~ u-group ~
|
||||
=* group u.u-group
|
||||
=/ =cage
|
||||
:- %group-update
|
||||
!> ^- update:store
|
||||
[%initial-group group-id group]
|
||||
[%give %fact ~ cage]~
|
||||
++ scry-initial
|
||||
|= =group-id
|
||||
^- (unit group)
|
||||
=/ =path
|
||||
(group-id:en-path:store group-id)
|
||||
(scry-store (unit group) [%groups path])
|
||||
::
|
||||
++ scry-role
|
||||
|= [=group-id =ship]
|
||||
%+ scry-store
|
||||
(unit role-tag)
|
||||
%+ welp
|
||||
`path`[%groups (group-id:en-path:store group-id)]
|
||||
/role/[(scot %p ship)]
|
||||
::
|
||||
++ scry-store
|
||||
|* [=mold =path]
|
||||
.^ mold
|
||||
%gx
|
||||
(scot %p our.bol)
|
||||
%group-store
|
||||
(scot %da now.bol)
|
||||
(welp path /noun)
|
||||
==
|
||||
::
|
||||
++ watch-invites
|
||||
^- card
|
||||
[%pass /invites %agent [our.bol %invite-store] %watch /invitatory/groups]
|
||||
::
|
||||
++ watch-store
|
||||
^- card
|
||||
[%pass /store %agent [our.bol %group-store] %watch /groups]
|
||||
--
|
||||
|
||||
@ -1,192 +0,0 @@
|
||||
:: group-listen-hook: receive group updates
|
||||
::
|
||||
::
|
||||
::
|
||||
/- *group, hook=group-hook
|
||||
/+ dbug, verb, store=group-store, default-agent
|
||||
|%
|
||||
+$ card card:agent:gall
|
||||
+$ versioned-state
|
||||
$% state-zero
|
||||
==
|
||||
+$ state-zero
|
||||
$: %0
|
||||
listening=(set group-id)
|
||||
==
|
||||
--
|
||||
|
||||
=| state-zero
|
||||
=* state -
|
||||
::
|
||||
%- agent:dbug
|
||||
%+ verb |
|
||||
^- agent:gall
|
||||
=<
|
||||
|_ =bowl:gall
|
||||
+* this .
|
||||
group-core +>
|
||||
gc ~(. group-core bowl)
|
||||
def ~(. (default-agent this %|) bowl)
|
||||
::
|
||||
++ on-init on-init:def
|
||||
++ on-save !>(state)
|
||||
++ on-load
|
||||
|= =vase
|
||||
^- (quip card _this)
|
||||
=/ old !<(state-zero vase)
|
||||
`this(state old)
|
||||
::
|
||||
++ on-leave on-leave:def
|
||||
++ on-peek on-peek:def
|
||||
++ on-arvo on-arvo:def
|
||||
++ on-fail on-fail:def
|
||||
::
|
||||
++ on-poke
|
||||
|= [=mark =vase]
|
||||
^- (quip card _this)
|
||||
?. ?=(%group-hook-action mark)
|
||||
(on-poke:def mark vase)
|
||||
=^ cards state
|
||||
(poke-hook-action:gc !<(action:hook vase))
|
||||
[cards this]
|
||||
::
|
||||
++ on-watch on-watch:def
|
||||
|
||||
++ on-agent
|
||||
|= [=wire =sign:agent:gall]
|
||||
^- (quip card _this)
|
||||
=^ cards state
|
||||
?+ -.wire ~|([dap.bowl %weird-agent-wire wire] !!)
|
||||
%store (take-store-sign sign)
|
||||
%proxy (take-proxy-sign +.wire sign)
|
||||
==
|
||||
[cards this]
|
||||
--
|
||||
|_ bol=bowl:gall
|
||||
:: +poke-hook-action: Start/stop syncing a foreign group
|
||||
::
|
||||
++ poke-hook-action
|
||||
|= =action:hook
|
||||
^- (quip card _state)
|
||||
|^
|
||||
?- -.action
|
||||
%add (add +.action)
|
||||
%remove (remove +.action)
|
||||
==
|
||||
++ add
|
||||
|= =group-id
|
||||
^- (quip card _state)
|
||||
?: (~(has in listening) group-id)
|
||||
`state
|
||||
=. listening
|
||||
(~(put in listening) group-id)
|
||||
=/ group-path
|
||||
(group-id:en-path:store group-id)
|
||||
:_ state
|
||||
%+ weld
|
||||
(listen-group group-id)
|
||||
(add-self group-id)
|
||||
++ remove
|
||||
|= =group-id
|
||||
^- (quip card _state)
|
||||
?. (~(has in listening) group-id)
|
||||
`state
|
||||
=. listening
|
||||
(~(del in listening) group-id)
|
||||
:_ state
|
||||
(leave-group group-id)
|
||||
--
|
||||
:: +take-store-sign: take sign from %group-store
|
||||
::
|
||||
:: We only poke %group-store to remove ourselves when we leave a channel.
|
||||
++ take-store-sign
|
||||
|= =sign:agent:gall
|
||||
^- (quip card _state)
|
||||
?- -.sign
|
||||
%watch-ack [~ state]
|
||||
%kick [~ state]
|
||||
%fact [~ state]
|
||||
%poke-ack
|
||||
?~ p.sign [~ state]
|
||||
=/ =tank
|
||||
:- %leaf
|
||||
"{(trip dap.bol)} failed poke to group-store"
|
||||
%- (slog tank u.p.sign)
|
||||
[~ state]
|
||||
==
|
||||
:: +take-proxy-sign: take sign from %group-proxy-hook
|
||||
::
|
||||
++ take-proxy-sign
|
||||
|= [=wire =sign:agent:gall]
|
||||
^- (quip card _state)
|
||||
=/ =group-id
|
||||
~| "bad proxy wire: {<wire>}"
|
||||
~| <sign>
|
||||
(need (group-id:de-path:store wire))
|
||||
?- -.sign
|
||||
%kick [(listen-group group-id) state]
|
||||
::
|
||||
%poke-ack
|
||||
?~ p.sign [~ state]
|
||||
=/ =tank
|
||||
:- %leaf
|
||||
"{(trip dap.bol)} failed poke to group-proxy!"
|
||||
%- (slog tank u.p.sign)
|
||||
[~ state]
|
||||
::
|
||||
%watch-ack
|
||||
?~ p.sign [~ state]
|
||||
=/ =tank
|
||||
:- %leaf
|
||||
"{(trip dap.bol)} failed subscribe to group-proxy!"
|
||||
%- (slog tank u.p.sign)
|
||||
[(store-leave-group group-id) state]
|
||||
::
|
||||
%fact
|
||||
?> ?=(%group-update p.cage.sign)
|
||||
(take-proxy-update wire !<(update:store q.cage.sign))
|
||||
==
|
||||
::
|
||||
:: +take-proxy-update: Handle new update from %group-proxy-hook
|
||||
::
|
||||
++ take-proxy-update
|
||||
|= [=wire =update:store]
|
||||
^- (quip card _state)
|
||||
?: ?=(%initial -.update)
|
||||
[~ state]
|
||||
:_ state
|
||||
[%pass [%listen wire] %agent [our.bol %group-store] %poke %group-update !>(update)]~
|
||||
:: +listen-group: Start a new subscription to the proxied .group-id
|
||||
::
|
||||
++ listen-group
|
||||
|= =group-id
|
||||
^- (list card)
|
||||
=/ pax=path
|
||||
(group-id:en-path:store group-id)
|
||||
[%pass [%listen pax] %agent [ship.group-id %group-proxy-hook] %watch [%groups pax]]~
|
||||
:: +add-self: Add self to group
|
||||
++ add-self
|
||||
|= =group-id
|
||||
^- (list card)
|
||||
=/ pax=path
|
||||
(group-id:en-path:store group-id)
|
||||
[%pass [%listen pax] %agent [ship.group-id %group-proxy-hook] %poke %group-action !>([%add-members group-id (sy our.bol ~) ~])]~
|
||||
:: +leave-group: Leave a foreign group
|
||||
++ leave-group
|
||||
|= =group-id
|
||||
^- (list card)
|
||||
=/ pax=path
|
||||
(group-id:en-path:store group-id)
|
||||
:~ [%pass [%listen pax] %agent [ship.group-id %group-proxy-hook] %leave ~]
|
||||
[%pass [%store pax] %agent [our.bol %group-store] %poke %group-update !>([%remove-group group-id ~])]
|
||||
[%pass [%listen pax] %agent [ship.group-id %group-proxy-hook] %poke %group-action !>([%remove-members group-id (sy our.bol ~)])]
|
||||
==
|
||||
:: +store-leave-group: Remove a foreign group from our group-store
|
||||
++ store-leave-group
|
||||
|= =group-id
|
||||
^- (list card)
|
||||
=/ pax=path
|
||||
(group-id:en-path:store group-id)
|
||||
[%pass [%store pax] %agent [our.bol %group-store] %poke %group-update !>([%remove-group group-id ~])]~
|
||||
::
|
||||
--
|
||||
@ -1,293 +0,0 @@
|
||||
:: group-proxy-hook: propagate group updates
|
||||
::
|
||||
:: This hook relays foreign subscriptions and pokes into local stores, if
|
||||
:: permissions are met.
|
||||
::
|
||||
:: Subscriptions:
|
||||
:: - /groups/[group-id]: updates for a particular group
|
||||
::
|
||||
:: Pokes:
|
||||
:: - %group-update: Proxy update to local group update. Crashes if permissions
|
||||
:: checks fail.
|
||||
::
|
||||
/- *group, hook=group-hook
|
||||
/+ dbug, verb, store=group-store, default-agent
|
||||
|%
|
||||
+$ card card:agent:gall
|
||||
+$ state-zero
|
||||
$: %0
|
||||
proxied=(jug path ship)
|
||||
==
|
||||
+$ versioned-state
|
||||
$% state-zero
|
||||
==
|
||||
--
|
||||
::
|
||||
=| state-zero
|
||||
=* state -
|
||||
%- agent:dbug
|
||||
%+ verb |
|
||||
^- agent:gall
|
||||
=<
|
||||
|_ =bowl:gall
|
||||
+* this .
|
||||
group-core +>
|
||||
gc ~(. group-core bowl)
|
||||
def ~(. (default-agent this %|) bowl)
|
||||
::
|
||||
++ on-init
|
||||
:_ this
|
||||
:~ [%pass / %arvo %d %flog %text "{(trip dap.bowl)} started"]
|
||||
[%pass /store %agent [our.bowl %group-store] %watch /groups]
|
||||
==
|
||||
++ on-save !>(state)
|
||||
++ on-load
|
||||
|= =vase
|
||||
`this(state !<(state-zero vase))
|
||||
++ on-peek on-peek:def
|
||||
++ on-arvo on-arvo:def
|
||||
++ on-fail on-fail:def
|
||||
::
|
||||
++ on-leave
|
||||
|= =path
|
||||
^- (quip card _this)
|
||||
=^ cards state
|
||||
(stop-proxy:gc src.bowl path)
|
||||
[cards this]
|
||||
::
|
||||
++ on-poke
|
||||
|= [=mark =vase]
|
||||
^- (quip card _this)
|
||||
=^ cards state
|
||||
?+ mark (on-poke:def mark vase)
|
||||
%group-action (poke-group-update:gc !<(action:store vase))
|
||||
==
|
||||
[cards this]
|
||||
::
|
||||
++ on-watch
|
||||
|= =path
|
||||
^- (quip card _this)
|
||||
?< (team:title [our src]:bowl)
|
||||
?> ?=([%groups *] path)
|
||||
?> (permitted:gc src.bowl t.path)
|
||||
=^ cards state
|
||||
(start-proxy:gc src.bowl t.path)
|
||||
[cards this]
|
||||
::
|
||||
++ on-agent
|
||||
|= [=wire =sign:agent:gall]
|
||||
^- (quip card _this)
|
||||
=^ cards state
|
||||
?+ -.wire ~|([dap.bowl %bad-agent-wire wire] !!)
|
||||
%store (take-store-sign sign)
|
||||
%listen (take-listen-sign sign)
|
||||
==
|
||||
[cards this]
|
||||
--
|
||||
|_ bol=bowl:gall
|
||||
:: +should-proxy-poke: Check if poke should be proxied
|
||||
::
|
||||
:: We only allow users to add and remove themselves.
|
||||
++ should-proxy-poke
|
||||
|= =update:store
|
||||
^- ?
|
||||
?: ?=(%add-members -.update)
|
||||
=(~(tap in ships.update) ~[src.bol])
|
||||
?: ?=(%remove-members -.update)
|
||||
=(~(tap in ships.update) ~[src.bol])
|
||||
%.n
|
||||
:: +poke-group-update: Proxy poke to %group-store
|
||||
::
|
||||
:: Only proxy pokes if permissions are correct and we host the group.
|
||||
::
|
||||
++ poke-group-update
|
||||
|= =update:store
|
||||
^- (quip card _state)
|
||||
?: ?=(%initial -.update)
|
||||
[~ state]
|
||||
?> =(ship.group-id.update our.bol)
|
||||
?> (should-proxy-poke update)
|
||||
=/ =path
|
||||
(group-id:en-path:store group-id.update)
|
||||
?> (permitted src.bol path)
|
||||
:_ state
|
||||
[%pass [%store path] %agent [our.bol %group-store] %poke %group-update !>(update)]~
|
||||
:: +take-listen-sign: Handle incoming sign from %group-listen-hook
|
||||
::
|
||||
:: group-listen-hook doesn't send us anything except pokes
|
||||
++ take-listen-sign
|
||||
|= =sign:agent:gall
|
||||
^- (quip card _state)
|
||||
?- -.sign
|
||||
%kick [~ state]
|
||||
%watch-ack [~ state]
|
||||
%fact [~ state]
|
||||
::
|
||||
%poke-ack
|
||||
?~ p.sign [~ state]
|
||||
=/ =tank
|
||||
:- %leaf
|
||||
"{(trip dap.bol)} failed poke to group-listen. very wrong!"
|
||||
%- (slog tank u.p.sign)
|
||||
[~ state]
|
||||
==
|
||||
:: +take-store-sign: Handle incoming sign from %group-store
|
||||
::
|
||||
:: group-store should send us all its store updates over a subscription on
|
||||
:: /groups. We also proxy pokes to it.
|
||||
::
|
||||
++ take-store-sign
|
||||
|= =sign:agent:gall
|
||||
^- (quip card _state)
|
||||
?- -.sign
|
||||
%kick [watch-store state]
|
||||
::
|
||||
%poke-ack
|
||||
?~ p.sign [~ state]
|
||||
=/ =tank
|
||||
:- %leaf
|
||||
"{(trip dap.bol)} failed poke to group-store"
|
||||
%- (slog tank u.p.sign)
|
||||
[~ state]
|
||||
::
|
||||
%watch-ack
|
||||
?~ p.sign [~ state]
|
||||
=/ =tank
|
||||
:- %leaf
|
||||
"{(trip dap.bol)} failed subscribe to group-store. very wrong!"
|
||||
%- (slog tank u.p.sign)
|
||||
[~ state]
|
||||
::
|
||||
%fact
|
||||
?+ p.cage.sign ~|("{<dap.bol>} unexpected mark: {<p.cage.sign>}" !!)
|
||||
%group-initial [~ state]
|
||||
%group-update (take-store-update !<(update:store q.cage.sign))
|
||||
==
|
||||
==
|
||||
:: +take-store-update: Handle new %fact from %group-store
|
||||
::
|
||||
:: We forward the update onto the correct path, and recalculate permissions,
|
||||
:: kicking any subscriptions whose permissions have been revoked.
|
||||
::
|
||||
++ take-store-update
|
||||
|= =update:store
|
||||
^- (quip card _state)
|
||||
?: ?=(%initial -.update)
|
||||
`state
|
||||
=/ =path
|
||||
(group-id:en-path:store group-id.update)
|
||||
?. (~(has by proxied) path)
|
||||
[~ state]
|
||||
=^ cards state
|
||||
(handle-revocations update path)
|
||||
:_ state
|
||||
:- [%give %fact [%groups path]~ %group-update !>(update)]
|
||||
cards
|
||||
::
|
||||
:: +handle-revocations: Handle revoked permissions from a update:store
|
||||
::
|
||||
:: If the mutation to the group store has impacted permissions, then kick
|
||||
:: relevant subscriptions and remove them from our state
|
||||
::
|
||||
++ handle-revocations
|
||||
|= [=update:store =path]
|
||||
^- (quip card _state)
|
||||
|^
|
||||
?: ?=(%remove-group -.update)
|
||||
=. proxied
|
||||
(~(del by proxied) group-id.update)
|
||||
:_ state
|
||||
[%give %kick [%groups path]~ ~]~
|
||||
?: ?=(%change-policy -.update)
|
||||
(handle-permissions-change diff.update)
|
||||
?. ?=(%remove-members -.update)
|
||||
[~ state]
|
||||
(revoked-permissions ships.update)
|
||||
::
|
||||
++ handle-permissions-change
|
||||
|= =diff:policy
|
||||
^- (quip card _state)
|
||||
?+ -.diff [~ state]
|
||||
%ban-ships (revoked-permissions ships.diff)
|
||||
==
|
||||
::
|
||||
++ revoked-permissions
|
||||
|= ships=(set ship)
|
||||
^- (quip card _state)
|
||||
=/ to-kick=(list ship)
|
||||
~(tap in ships)
|
||||
=/ subs=(set ship)
|
||||
(~(gut by proxied) path ~)
|
||||
=| cards=(list card)
|
||||
|-
|
||||
?~ to-kick
|
||||
[cards state]
|
||||
=. proxied
|
||||
(~(del ju proxied) path i.to-kick)
|
||||
=. cards
|
||||
[[%give %kick [%groups path]~ `i.to-kick] cards]
|
||||
$(to-kick t.to-kick)
|
||||
--
|
||||
:: +start-proxy: Start proxying .path to .who
|
||||
::
|
||||
++ start-proxy
|
||||
|= [who=ship =path]
|
||||
^- (quip card _state)
|
||||
=. proxied
|
||||
(~(put ju proxied) path who)
|
||||
[(give-initial path) state]
|
||||
:: +stop-proxy: Stop proxying .path to .who
|
||||
::
|
||||
++ stop-proxy
|
||||
|= [who=ship =path]
|
||||
^- (quip card _state)
|
||||
=. proxied
|
||||
(~(del ju proxied) path who)
|
||||
`state
|
||||
:: +watch-store: Watch group-store for changes
|
||||
::
|
||||
++ watch-store
|
||||
^- (list card)
|
||||
[%pass /group-store %agent [our.bol %group-store] %watch /groups]~
|
||||
:: +permitted: check if .ship can access .path
|
||||
::
|
||||
++ permitted
|
||||
|= [=ship =path]
|
||||
^- ?
|
||||
?> ?=([@ @ *] path)
|
||||
=/ u-group-id
|
||||
(group-id:de-path:store path)
|
||||
?~ u-group-id
|
||||
%.n
|
||||
=* group-id u.u-group-id
|
||||
=/ pax=^path
|
||||
(welp [%groups path] /permitted/[(scot %p ship)])
|
||||
(scry-store ? pax)
|
||||
:: +give-initial: give initial state for .path
|
||||
::
|
||||
:: Must be called in +on-watch. No-ops if the group does not exist yet
|
||||
++ give-initial
|
||||
|= =path
|
||||
^- (list card)
|
||||
=/ u-group
|
||||
(scry-store (unit group) [%groups path])
|
||||
?~ u-group ~
|
||||
=* group u.u-group
|
||||
=/ =group-id
|
||||
(need (group-id:de-path:store path))
|
||||
=/ =cage
|
||||
:- %group-update
|
||||
!> ^- update:store
|
||||
[%initial-group group-id group]
|
||||
[%give %fact ~ cage]~
|
||||
::
|
||||
++ scry-store
|
||||
|* [=mold =path]
|
||||
.^ mold
|
||||
%gx
|
||||
(scot %p our.bol)
|
||||
%group-store
|
||||
(scot %da now.bol)
|
||||
(welp path /noun)
|
||||
==
|
||||
--
|
||||
@ -5,6 +5,7 @@
|
||||
:: permissions and invites inside this store for simplicity reasons, although
|
||||
:: these should be prised apart in a future revision of group store.
|
||||
::
|
||||
::
|
||||
:: ## Scry paths
|
||||
::
|
||||
:: /y/groups:
|
||||
@ -13,11 +14,8 @@
|
||||
:: A listing of the tag queries for a group
|
||||
:: /x/groups/[group-id]:
|
||||
:: The group itself
|
||||
:: /x/groups/[group-id]/tag-queries/[tag]:
|
||||
:: The subset with tag
|
||||
:: /x/groups/[group-id]/permitted/[ship]:
|
||||
:: A flag indicated if the ship is permitted
|
||||
::
|
||||
:: /x/groups/[group-id]/join/[ship]:
|
||||
:: A flag indicated if the ship is permitted to join
|
||||
::
|
||||
:: ## Subscription paths
|
||||
::
|
||||
@ -71,9 +69,7 @@
|
||||
gc ~(. group-core bowl)
|
||||
def ~(. (default-agent this %|) bowl)
|
||||
::
|
||||
++ on-init
|
||||
:_ this
|
||||
[%pass / %arvo %d %flog %text "{(trip dap.bowl)} started"]~
|
||||
++ on-init on-init:def
|
||||
++ on-save !>(state)
|
||||
++ on-load
|
||||
|= =old=vase
|
||||
@ -87,7 +83,7 @@
|
||||
^- (quip card _this)
|
||||
?> (team:title our.bowl src.bowl)
|
||||
=^ cards state
|
||||
?: ?=(%group-update mark)
|
||||
?: ?=(?(%group-update %group-action) mark)
|
||||
(poke-group-update:gc !<(update:store vase))
|
||||
(on-poke:def mark vase)
|
||||
[cards this]
|
||||
@ -98,7 +94,7 @@
|
||||
?> (team:title our.bowl src.bowl)
|
||||
?> ?=([%groups ~] path)
|
||||
:_ this
|
||||
[%give %fact ~ %group-initial !>(groups)]~
|
||||
[%give %fact ~ %group-update !>([%initial groups])]~
|
||||
::
|
||||
++ on-leave on-leave:def
|
||||
::
|
||||
@ -106,13 +102,26 @@
|
||||
|= =path
|
||||
^- (unit (unit cage))
|
||||
?+ path (on-peek:def path)
|
||||
[%x %groups @ @ ~] ``noun+!>((peek-group t.t.path))
|
||||
[%x %groups @ @ ~]
|
||||
=/ group-id
|
||||
(group-id:de-path:store t.t.path)
|
||||
?~ group-id ~
|
||||
``noun+!>((peek-group u.group-id))
|
||||
[%x %groups @ @ %join @ ~]
|
||||
=/ group-id
|
||||
(group-id:de-path:store t.t.path)
|
||||
=/ =ship
|
||||
(slav %p i.t.t.t.t.t.path)
|
||||
?~ group-id ~
|
||||
``noun+!>((peek-group-join u.group-id ship))
|
||||
::
|
||||
[%x %groups @ @ %permitted @ ~]
|
||||
``noun+!>((peek-group-permitted t.t.path (slav %p i.t.t.t.t.t.path)))
|
||||
::
|
||||
[%x %groups @ @ %permission-role @ ~]
|
||||
``noun+!>((peek-group-permitted t.t.path (slav %p i.t.t.t.t.t.path)))
|
||||
[%x %groups @ @ %role @ ~]
|
||||
=/ group-id
|
||||
(group-id:de-path:store t.t.path)
|
||||
?~ group-id ~
|
||||
=/ =ship
|
||||
(slav %p i.t.t.t.t.t.path)
|
||||
``noun+!>((peek-group-role u.group-id ship))
|
||||
==
|
||||
::
|
||||
++ on-agent on-agent:def
|
||||
@ -133,14 +142,15 @@
|
||||
?: (lte size 8)
|
||||
%2
|
||||
%3
|
||||
++ peek-group-permitted
|
||||
|= [=path =ship]
|
||||
^- ?
|
||||
=/ maybe-group
|
||||
(peek-group path)
|
||||
?~ maybe-group
|
||||
%.n
|
||||
=* group u.maybe-group
|
||||
++ peek-group
|
||||
|= =group-id
|
||||
^- (unit group)
|
||||
(~(get by groups) group-id)
|
||||
|
||||
++ peek-group-join
|
||||
|= [=group-id =ship]
|
||||
=/ =group
|
||||
(~(gut by groups) group-id *group)
|
||||
=* policy policy.group
|
||||
?- -.policy
|
||||
%invite
|
||||
@ -148,15 +158,25 @@
|
||||
%open
|
||||
&(!(~(has in banned.policy) ship) (~(has in ranks.policy) (ship-rank ship)))
|
||||
==
|
||||
::
|
||||
++ peek-group
|
||||
|= =path
|
||||
^- (unit group)
|
||||
=/ m-group-id
|
||||
(group-id:de-path:store path)
|
||||
?~ m-group-id ~
|
||||
=* group-id u.m-group-id
|
||||
(~(get by groups) group-id)
|
||||
++ peek-group-role
|
||||
|= [=group-id =ship]
|
||||
=/ =group
|
||||
(~(got by groups) group-id)
|
||||
=* policy policy.group
|
||||
=* tag-queries tag-queries.group
|
||||
=/ admins=(set ^ship)
|
||||
(~(gut by tag-queries) %admin ~)
|
||||
?: (~(has in admins) ship)
|
||||
`%admin
|
||||
=/ mods
|
||||
(~(gut by tag-queries) %moderator ~)
|
||||
?: (~(has in mods) ship)
|
||||
`%moderator
|
||||
=/ janitors
|
||||
(~(gut by tag-queries) %janitor ~)
|
||||
?. (~(has in janitors) ship)
|
||||
~
|
||||
`%janitor
|
||||
::
|
||||
++ poke-group-update
|
||||
|= =update:store
|
||||
@ -176,17 +196,21 @@
|
||||
==
|
||||
:: +add-group: add group to store
|
||||
::
|
||||
:: no-op if group-already exists
|
||||
:: always include ship in own groups, no-op if group already exists
|
||||
::
|
||||
++ add-group
|
||||
|= [=group-id =group]
|
||||
|= [=group-id =policy]
|
||||
^- (quip card _state)
|
||||
?: (~(has by groups) group-id)
|
||||
[~ state]
|
||||
=| =group
|
||||
=. members.group
|
||||
(~(put in members.group) our.bol)
|
||||
=. policy.group policy
|
||||
=. groups
|
||||
(~(put by groups) group-id group)
|
||||
:_ state
|
||||
(send-diff %add-group group-id group)
|
||||
(send-diff %add-group group-id policy)
|
||||
:: +add-members: add members to group
|
||||
::
|
||||
:: no-op if group does not exist
|
||||
@ -200,6 +224,13 @@
|
||||
=. members.group (~(uni in members.group) new-ships)
|
||||
=. tag-queries.group
|
||||
(merge-tags tag-queries.group new-ships tags)
|
||||
=* policy policy.group
|
||||
=. policy
|
||||
?. ?=(%invite -.policy)
|
||||
policy
|
||||
=. pending.policy
|
||||
(~(dif in pending.policy) new-ships)
|
||||
policy
|
||||
=. groups
|
||||
(~(put by groups) group-id group)
|
||||
:_ state
|
||||
@ -207,7 +238,7 @@
|
||||
:: +remove-members: remove members from group
|
||||
::
|
||||
:: no-op if group does not exist
|
||||
:: TODO: remove tags as well
|
||||
::
|
||||
::
|
||||
++ remove-members
|
||||
|= [=group-id ships=(set ship)]
|
||||
@ -218,6 +249,8 @@
|
||||
(~(got by groups) group-id)
|
||||
=. members.group
|
||||
(~(dif in members.group) ships)
|
||||
=. tag-queries.group
|
||||
(remove-tags group ships)
|
||||
=. groups
|
||||
(~(put by groups) group-id group)
|
||||
:_ state
|
||||
@ -275,7 +308,8 @@
|
||||
(send-diff %initial-group group-id group)
|
||||
:: +change-policy: modify group access control
|
||||
::
|
||||
::
|
||||
:: If the change will kick members, then send a separate
|
||||
:: %remove-members diff after the %change-policy diff
|
||||
++ change-policy
|
||||
|= [=group-id =diff:policy]
|
||||
^- (quip card _state)
|
||||
@ -283,54 +317,80 @@
|
||||
[~ state]
|
||||
=/ =group
|
||||
(~(got by groups) group-id)
|
||||
=* policy policy.group
|
||||
|^
|
||||
=. policy
|
||||
=- ~& - -
|
||||
?+ -.diff !!
|
||||
%allow-ranks (allow-ranks +.diff)
|
||||
%ban-ranks (ban-ranks +.diff)
|
||||
%allow-ships (allow-ships +.diff)
|
||||
%ban-ships (ban-ships +.diff)
|
||||
=^ cards group
|
||||
?- -.diff
|
||||
%allow-ranks (allow-ranks +.diff)
|
||||
%ban-ranks (ban-ranks +.diff)
|
||||
%allow-ships (allow-ships +.diff)
|
||||
%ban-ships (ban-ships +.diff)
|
||||
%add-invites (add-invites +.diff)
|
||||
%remove-invites (remove-invites +.diff)
|
||||
%replace (replace +.diff)
|
||||
==
|
||||
=. groups
|
||||
(~(put by groups) group-id group)
|
||||
:_ state
|
||||
(send-diff %change-policy group-id diff)
|
||||
%+ weld
|
||||
(send-diff %change-policy group-id diff)
|
||||
cards
|
||||
::
|
||||
++ allow-ranks
|
||||
|= ranks=(set rank)
|
||||
^- ^policy
|
||||
?> ?=(%open -.policy)
|
||||
=. ranks.policy
|
||||
(~(uni in ranks.policy) ranks)
|
||||
policy
|
||||
^- (quip card _group)
|
||||
?> ?=(%open -.policy.group)
|
||||
=. ranks.policy.group
|
||||
(~(uni in ranks.policy.group) ranks)
|
||||
`group
|
||||
::
|
||||
++ ban-ranks
|
||||
|= ranks=(set rank)
|
||||
^- ^policy
|
||||
?> ?=(%open -.policy)
|
||||
=. ranks.policy
|
||||
(~(dif in ranks.policy) ranks)
|
||||
policy
|
||||
^- (quip card _group)
|
||||
?> ?=(%open -.policy.group)
|
||||
=. ranks.policy.group
|
||||
(~(dif in ranks.policy.group) ranks)
|
||||
`group
|
||||
::
|
||||
++ allow-ships
|
||||
|= ships=(set ship)
|
||||
^- ^policy
|
||||
?> ?=(%open -.policy)
|
||||
=. banned.policy
|
||||
(~(dif in banned.policy) ships)
|
||||
policy
|
||||
^- (quip card _group)
|
||||
?> ?=(%open -.policy.group)
|
||||
=. banned.policy.group
|
||||
(~(dif in banned.policy.group) ships)
|
||||
`group
|
||||
::
|
||||
++ ban-ships
|
||||
|= ships=(set ship)
|
||||
^- ^policy
|
||||
?> ?=(%open -.policy)
|
||||
=. banned.policy
|
||||
(~(uni in banned.policy) ships)
|
||||
=. members.group
|
||||
(~(dif in members.group) banned.policy)
|
||||
policy
|
||||
^- (quip card _group)
|
||||
?> ?=(%open -.policy.group)
|
||||
=. banned.policy.group
|
||||
(~(uni in banned.policy.group) ships)
|
||||
=/ to-remove=(set ship)
|
||||
(~(int in members.group) banned.policy.group)
|
||||
:- ~[(poke-us %remove-members group-id to-remove)]
|
||||
group
|
||||
::
|
||||
++ add-invites
|
||||
|= ships=(set ship)
|
||||
^- (quip card _group)
|
||||
?> ?=(%invite -.policy.group)
|
||||
=. pending.policy.group
|
||||
(~(uni in pending.policy.group) ships)
|
||||
`group
|
||||
::
|
||||
++ remove-invites
|
||||
|= ships=(set ship)
|
||||
^- (quip card _group)
|
||||
?> ?=(%invite -.policy.group)
|
||||
=. pending.policy.group
|
||||
(~(uni in pending.policy.group) ships)
|
||||
`group
|
||||
++ replace
|
||||
|= =policy
|
||||
^- (quip card _group)
|
||||
=. policy.group
|
||||
policy
|
||||
`group
|
||||
--
|
||||
:: +remove-group: remove group from store
|
||||
::
|
||||
@ -346,25 +406,21 @@
|
||||
(send-diff %remove-group group-id ~)
|
||||
::
|
||||
--
|
||||
:: +merge-tags: merge tags
|
||||
++ merge-tags
|
||||
|= [=tag-queries ships=(set ship) tags=(set tag)]
|
||||
^+ tag-queries
|
||||
=/ tags ~(tap in tags)
|
||||
|-
|
||||
?~ tags
|
||||
tag-queries
|
||||
=* tag i.tags
|
||||
=/ current-query=(set ship)
|
||||
(~(gut by tag-queries) tag ~)
|
||||
%= $
|
||||
tags t.tags
|
||||
::
|
||||
tag-queries
|
||||
%+ ~(put by tag-queries)
|
||||
tag
|
||||
(~(uni in current-query) ships)
|
||||
==
|
||||
++ remove-tags
|
||||
|= [=group ships=(set ship)]
|
||||
^- tag-quries
|
||||
%- malt
|
||||
%+ spin
|
||||
~(tap by tag-queries.group)
|
||||
tag-queries.group
|
||||
|= [=tag tagged=(set ship)]
|
||||
:- tag
|
||||
(~(dif in tagged) ships)
|
||||
::
|
||||
++ poke-us
|
||||
|= =action:store
|
||||
^- card
|
||||
[%pass / %agent [our.bol %group-store] %poke %group-action !>(action)]
|
||||
:: +send-diff: update subscribers of new state
|
||||
::
|
||||
:: We only allow subscriptions on /groups
|
||||
|
||||
@ -1,10 +1,10 @@
|
||||
:: group-store|join: initialize a group
|
||||
:: group-listen-hook|add: add a group
|
||||
::
|
||||
/- *group-store
|
||||
/- *group, *group-hook
|
||||
:- %say
|
||||
|= $: [now=@da eny=@uvJ =beak]
|
||||
[[=ship =term ~] ~]
|
||||
==
|
||||
:- %group-action
|
||||
:- %group-hook-action
|
||||
^- action
|
||||
[%add ship term]
|
||||
|
||||
@ -1,10 +0,0 @@
|
||||
:: group-listen-hook|add: add a group
|
||||
::
|
||||
/- *group, *group-hook
|
||||
:- %say
|
||||
|= $: [now=@da eny=@uvJ =beak]
|
||||
[[=ship =term ~] ~]
|
||||
==
|
||||
:- %group-hook-action
|
||||
^- action
|
||||
[%add ship term]
|
||||
@ -29,4 +29,265 @@
|
||||
=* term i.t.path
|
||||
`[u.ship term]
|
||||
--
|
||||
++ enjs
|
||||
=, enjs:format
|
||||
|%
|
||||
::
|
||||
++ update
|
||||
|= =^update
|
||||
^- json
|
||||
%+ frond -.update
|
||||
?- -.update
|
||||
%add-group (add-group update)
|
||||
%add-members (add-members update)
|
||||
%add-tag (add-tag update)
|
||||
%remove-members (remove-members update)
|
||||
%remove-tag (remove-tag update)
|
||||
%initial (initial update)
|
||||
%initial-group (initial-group update)
|
||||
%remove-group (remove-group update)
|
||||
%change-policy (change-policy update)
|
||||
==
|
||||
++ group-id-path
|
||||
|= =^group-id
|
||||
%- spat
|
||||
%- group-id:en-path
|
||||
group-id
|
||||
++ initial-group
|
||||
|= =^update
|
||||
?> ?=(%initial-group -.update)
|
||||
%- pairs
|
||||
:~ group-id+(group-id group-id.update)
|
||||
group+(group group.update)
|
||||
==
|
||||
::
|
||||
++ initial
|
||||
|= =^initial
|
||||
?> ?=(%initial -.initial)
|
||||
%- pairs
|
||||
%+ turn
|
||||
~(tap by groups.initial)
|
||||
|= [=^group-id grp=^group]
|
||||
^- [@t json]
|
||||
:_ (group grp)
|
||||
(group-id-path group-id)
|
||||
::
|
||||
++ group
|
||||
|= =^group
|
||||
^- json
|
||||
%- pairs
|
||||
:~ members+(set ship members.group)
|
||||
policy+(policy policy.group)
|
||||
==
|
||||
::
|
||||
++ set
|
||||
|* [item=$-(* json) sit=(^set)]
|
||||
^- json
|
||||
:- %a
|
||||
%+ turn
|
||||
~(tap in sit)
|
||||
item
|
||||
::
|
||||
++ policy
|
||||
|= =^policy
|
||||
%+ frond -.policy
|
||||
%- pairs
|
||||
?- -.policy
|
||||
%invite
|
||||
:~ pending+(set ship pending.policy)
|
||||
==
|
||||
%open
|
||||
:~ banned+(set ship banned.policy)
|
||||
ranks+(set numb ranks.policy)
|
||||
==
|
||||
==
|
||||
++ policy-diff
|
||||
|= =diff:^policy
|
||||
%+ frond -.diff
|
||||
%- pairs
|
||||
?+ -.diff !!
|
||||
%add-invites [invitees+(set ship invitees.diff) ~]
|
||||
%remove-invites [invitees+(set ship invitees.diff) ~]
|
||||
%allow-ranks [ranks+(set numb ranks.diff) ~]
|
||||
%ban-ranks [ranks+(set numb ranks.diff) ~]
|
||||
%allow-ships [ranks+(set ship ships.diff) ~]
|
||||
%ban-ships [ranks+(set ship ships.diff) ~]
|
||||
==
|
||||
::
|
||||
++ remove-group
|
||||
|= =^update
|
||||
^- json
|
||||
?> ?=(%remove-group -.update)
|
||||
(frond %group-id (group-id group-id.update))
|
||||
::
|
||||
++ group-id
|
||||
|= =^group-id
|
||||
^- json
|
||||
%- pairs
|
||||
:~ name+s+term.group-id
|
||||
ship+(ship ship.group-id)
|
||||
==
|
||||
++ add-group
|
||||
|= =action
|
||||
^- json
|
||||
?> ?=(%add-group -.action)
|
||||
%- pairs
|
||||
:~ group-id+(group-id group-id.action)
|
||||
policy+(policy policy.action)
|
||||
==
|
||||
::
|
||||
++ add-members
|
||||
|= =action
|
||||
^- json
|
||||
?> ?=(%add-members -.action)
|
||||
%- pairs
|
||||
:~ group-id+(group-id group-id.action)
|
||||
ships+(set ship ships.action)
|
||||
==
|
||||
::
|
||||
++ remove-members
|
||||
|= =action
|
||||
^- json
|
||||
?> ?=(%remove-members -.action)
|
||||
%- pairs
|
||||
:~ group-id+(group-id group-id.action)
|
||||
ships+(set ship ships.action)
|
||||
==
|
||||
::
|
||||
++ add-tag
|
||||
|= =action
|
||||
^- json
|
||||
?> ?=(%add-tag -.action)
|
||||
%- pairs
|
||||
:~ group-id+(group-id group-id.action)
|
||||
tag+s+tag.action
|
||||
ships+(set ship ships.action)
|
||||
==
|
||||
::
|
||||
++ remove-tag
|
||||
|= =action
|
||||
^- json
|
||||
?> ?=(%remove-tag -.action)
|
||||
%- pairs
|
||||
:~ group-id+(group-id group-id.action)
|
||||
tag+s+tag.action
|
||||
ships+(set ship ships.action)
|
||||
==
|
||||
::
|
||||
++ change-policy
|
||||
|= =action
|
||||
^- json
|
||||
?> ?=(%change-policy -.action)
|
||||
%- pairs
|
||||
:~ group-id+(group-id group-id.action)
|
||||
diff+(policy-diff diff.action)
|
||||
==
|
||||
--
|
||||
++ dejs
|
||||
=, dejs:format
|
||||
|%
|
||||
::
|
||||
++ action
|
||||
^- $-(json ^action)
|
||||
%- of
|
||||
:~
|
||||
add-group+add-group
|
||||
add-members+add-members
|
||||
remove-members+remove-members
|
||||
add-tag+add-tag
|
||||
remove-tag+remove-tag
|
||||
change-policy+change-policy
|
||||
remove-group+remove-group
|
||||
==
|
||||
++ rank
|
||||
|= =json
|
||||
^- ^rank
|
||||
?> ?=(%n -.json)
|
||||
%0
|
||||
:: move to zuse also
|
||||
++ oj
|
||||
|* =fist
|
||||
^- $-(json (jug cord _(fist *json)))
|
||||
(om (as fist))
|
||||
++ tag-queries
|
||||
^- $-(json ^tag-queries)
|
||||
(oj ship)
|
||||
:: TODO: move to zuse
|
||||
++ ship
|
||||
(su ;~(pfix sig fed:ag))
|
||||
++ policy
|
||||
^- $-(json ^policy)
|
||||
%- of
|
||||
:~ invite+invite-policy
|
||||
open+open-policy
|
||||
==
|
||||
++ invite-policy
|
||||
%- ot
|
||||
:~ pending+(as ship)
|
||||
==
|
||||
++ open-policy
|
||||
%- ot
|
||||
:~ ranks+(as rank)
|
||||
banned+(as ship)
|
||||
==
|
||||
++ policy-diff
|
||||
^- $-(json diff:^policy)
|
||||
%- of
|
||||
:~ add-invites+(as ship)
|
||||
remove-invites+(as ship)
|
||||
allow-ranks+(as rank)
|
||||
allow-ships+(as ship)
|
||||
ban-ranks+(as rank)
|
||||
ban-ships+(as ship)
|
||||
replace+policy
|
||||
==
|
||||
++ group-id
|
||||
%- ot
|
||||
:~ ship+ship
|
||||
name+so
|
||||
==
|
||||
::
|
||||
++ remove-group
|
||||
|= =json
|
||||
?> ?=(%o -.json)
|
||||
=/ =group-id
|
||||
(group-id (~(got by p.json) 'group-id'))
|
||||
[group-id ~]
|
||||
|
||||
++ add-group
|
||||
%- ot
|
||||
:~ group-id+group-id
|
||||
policy+policy
|
||||
==
|
||||
++ add-members
|
||||
%- ot
|
||||
:~ group-id+group-id
|
||||
ships+(as ship)
|
||||
tags+(as so)
|
||||
==
|
||||
++ remove-members
|
||||
^- $-(json [^group-id (set ^ship)])
|
||||
%- ot
|
||||
:~ group-id+group-id
|
||||
ships+(as ship)
|
||||
==
|
||||
++ add-tag
|
||||
%- ot
|
||||
:~ group-id+group-id
|
||||
tag+so
|
||||
ships+(as ship)
|
||||
==
|
||||
++ remove-tag
|
||||
%- ot
|
||||
:~ group-id+group-id
|
||||
tag+so
|
||||
ships+(as ship)
|
||||
==
|
||||
++ change-policy
|
||||
%- ot
|
||||
:~ group-id+group-id
|
||||
diff+policy-diff
|
||||
==
|
||||
--
|
||||
|
||||
--
|
||||
|
||||
69
pkg/arvo/lib/group.hoon
Normal file
69
pkg/arvo/lib/group.hoon
Normal file
@ -0,0 +1,69 @@
|
||||
/- *group, *metadata-store
|
||||
/+ store=group-store
|
||||
|_ =bowl:gall
|
||||
++ scry-for
|
||||
|* [=mold =path]
|
||||
.^ mold
|
||||
%gx
|
||||
(scot %p our.bowl)
|
||||
%group-store
|
||||
(scot %da now.bowl)
|
||||
(snoc `^path`path %noun)
|
||||
==
|
||||
::
|
||||
++ scry-group-path
|
||||
|= =path
|
||||
%+ scry-for
|
||||
(unit group)
|
||||
[%groups path]
|
||||
::
|
||||
++ scry-group
|
||||
|= =group-id
|
||||
%- scry-group-path
|
||||
(group-id:en-path group-id)
|
||||
::
|
||||
++ members-from-path
|
||||
|= =group-path
|
||||
^- (set ship)
|
||||
=- members:(fall - *group)
|
||||
(scry-group-path group-path)
|
||||
::
|
||||
++ is-permitted
|
||||
|= [=ship =group-path]
|
||||
^- ?
|
||||
=- (~(has in -) ship)
|
||||
(members-from-path group-path)
|
||||
::
|
||||
++ role-for-ship
|
||||
|= [=group-id =ship]
|
||||
^- (unit role-tag)
|
||||
=/ grp=(unit group)
|
||||
(scry-group group-id)
|
||||
?~ grp ~
|
||||
=* group u.grp
|
||||
=* policy policy.group
|
||||
=* tag-queries tag-queries.group
|
||||
=/ admins=(set ^ship)
|
||||
(~(gut by tag-queries) %admin ~)
|
||||
?: (~(has in admins) ship)
|
||||
`%admin
|
||||
=/ mods
|
||||
(~(gut by tag-queries) %moderator ~)
|
||||
?: (~(has in mods) ship)
|
||||
`%moderator
|
||||
=/ janitors
|
||||
(~(gut by tag-queries) %janitor ~)
|
||||
?: (~(has in janitors) ship)
|
||||
`%janitor
|
||||
?: (~(has in members.group) ship)
|
||||
`%member
|
||||
~
|
||||
++ can-join
|
||||
|= [=path =ship]
|
||||
%+ scry-for
|
||||
?
|
||||
%+ welp
|
||||
[%groups path]
|
||||
/join/[(scot %p ship)]
|
||||
|
||||
--
|
||||
@ -1,33 +1,9 @@
|
||||
/+ *group-store
|
||||
/+ store=group-store
|
||||
=, dejs:format
|
||||
|_ act=action
|
||||
|_ =action:store
|
||||
++ grab
|
||||
|%
|
||||
++ noun action
|
||||
:: ++ json
|
||||
:: |= jon=^json
|
||||
:: =< (parse-group-action jon)
|
||||
:: |%
|
||||
:: ++ parse-group-action
|
||||
:: %- of
|
||||
:: :~
|
||||
:: [%add add-action]
|
||||
:: [%remove remove-action]
|
||||
:: [%bundle pa]
|
||||
:: [%unbundle pa]
|
||||
:: ==
|
||||
:: ::
|
||||
:: ++ add-action
|
||||
:: %- ot
|
||||
:: :~ [%members (as (su ;~(pfix sig fed:ag)))]
|
||||
:: [%path pa]
|
||||
:: ==
|
||||
:: ::
|
||||
:: ++ remove-action
|
||||
:: %- ot
|
||||
:: :~ [%members (as (su ;~(pfix sig fed:ag)))]
|
||||
:: [%path pa]
|
||||
:: ==
|
||||
:: --
|
||||
++ noun action:store
|
||||
++ json action:dejs:store
|
||||
--
|
||||
--
|
||||
|
||||
@ -1,62 +1,13 @@
|
||||
/- *group-store
|
||||
/+ *group-store
|
||||
|_ upd=update
|
||||
++ grow
|
||||
|%
|
||||
++ json
|
||||
%+ frond:enjs:format %group-update
|
||||
(update:enjs upd)
|
||||
--
|
||||
++ grab
|
||||
|%
|
||||
++ noun update
|
||||
--
|
||||
:: ++ grow
|
||||
:: |%
|
||||
:: ++ json
|
||||
:: =, enjs:format
|
||||
:: ^- ^json
|
||||
:: %+ frond %group-update
|
||||
:: %- pairs
|
||||
:: :~
|
||||
:: ::
|
||||
:: :: %add
|
||||
:: ?: =(%add -.upd)
|
||||
:: ?> ?=(%add -.upd)
|
||||
:: :- %add
|
||||
:: %- pairs
|
||||
:: :~ [%members (set-to-array members.upd ship)]
|
||||
:: [%path (path pax.upd)]
|
||||
:: ==
|
||||
:: ::
|
||||
:: :: %remove
|
||||
:: ?: =(%remove -.upd)
|
||||
:: ?> ?=(%remove -.upd)
|
||||
:: :- %remove
|
||||
:: %- pairs
|
||||
:: :~ [%members (set-to-array members.upd ship)]
|
||||
:: [%path (path pax.upd)]
|
||||
:: ==
|
||||
:: ::
|
||||
:: :: %bundle
|
||||
:: ?: =(%bundle -.upd)
|
||||
:: ?> ?=(%bundle -.upd)
|
||||
:: [%bundle (pairs [%path (path pax.upd)]~)]
|
||||
:: ::
|
||||
:: :: %unbundle
|
||||
:: ?: =(%unbundle -.upd)
|
||||
:: ?> ?=(%unbundle -.upd)
|
||||
:: [%unbundle (pairs [%path (path pax.upd)]~)]
|
||||
:: ::
|
||||
:: :: %keys
|
||||
:: ?: =(%keys -.upd)
|
||||
:: ?> ?=(%keys -.upd)
|
||||
:: [%keys (pairs [%keys (set-to-array keys.upd path)]~)]
|
||||
:: ::
|
||||
:: :: %path
|
||||
:: ?: =(%path -.upd)
|
||||
:: ?> ?=(%path -.upd)
|
||||
:: :- %path
|
||||
:: %- pairs
|
||||
:: :~ [%members (set-to-array members.upd ship)]
|
||||
:: [%path (path pax.upd)]
|
||||
:: ==
|
||||
:: ::
|
||||
:: :: %noop
|
||||
:: [*@t *^json]
|
||||
:: ==
|
||||
:: --
|
||||
--
|
||||
|
||||
@ -13,11 +13,11 @@
|
||||
:: %remove-group: remove a group from the store
|
||||
::
|
||||
+$ action
|
||||
$% [%add-group =group-id ships=(set ship) =tag-queries =policy]
|
||||
$% [%add-group =group-id =policy]
|
||||
[%add-members =group-id ships=(set ship) tags=(set term)]
|
||||
[%remove-members =group-id ships=(set ship)]
|
||||
[%add-tag =group-id =term ships=(set ship)]
|
||||
[%remove-tag =group-id =term ships=(set ship)]
|
||||
[%add-tag =group-id =tag ships=(set ship)]
|
||||
[%remove-tag =group-id =tag ships=(set ship)]
|
||||
[%change-policy =group-id =diff:policy]
|
||||
[%remove-group =group-id ~]
|
||||
==
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
^?
|
||||
|%
|
||||
:: $group-id: unique identifier for a group
|
||||
::
|
||||
@ -14,15 +15,17 @@
|
||||
:: %admin - denotes that member can add and remove members
|
||||
::
|
||||
+$ tag term
|
||||
:: $permission-tag: a kind of $tag that identifies a privileged user
|
||||
:: $role-tag: a kind of $tag that identifies a privileged user
|
||||
::
|
||||
:: These roles are
|
||||
:: %admin: Administrator, can do everything except delete the group
|
||||
:: %moderator: Moderator, can add/remove/ban users
|
||||
:: %janitor: Has no special meaning inside group-store,
|
||||
:: but may be given additional privileges in other apps.
|
||||
+$ permission-tag
|
||||
?(%admin %moderator %janitor)
|
||||
:: %member: Ordinary member, this tag is implied if the user is not in any
|
||||
:: of the other roles
|
||||
+$ role-tag
|
||||
?(%admin %moderator %janitor %members)
|
||||
:: $tag-queries: a mapping from a $tag to the members it identifies
|
||||
::
|
||||
+$ tag-queries (jug tag ship)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user