urbit/pkg/arvo/app/group-store.hoon

::  group-store [landscape]:
::
::  Store groups of ships
::
::    group-store stores groups of ships, so that resources in other apps can be
::    associated with a group. The current model of group-store rolls
::    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:
::      A listing of the current groups
::    /x/groups/[resource]:
::      The group itself
::    /x/groups/[resource]/join/[ship]:
::      A flag indicated if the ship is permitted to join
::
::    ## Subscription paths
::
::    /groups:
::      A stream of the current updates to the state, sending the initial state
::      upon subscribe.
::
::    ##  Pokes
::
::    %group-action:
::      Modify the group. Further documented in /sur/group-store.hoon
::
::
/-  *group, permission-store, *contact-view
/+  store=group-store, default-agent, verb, dbug, resource, *migrate
|%
+$  card  card:agent:gall
::
+$  versioned-state
  $%  state-zero
      state-one
  ==
::
+$  state-zero
  $:  %0
      =groups:state-zero:store
  ==
::
::
+$  state-one
  $:  %1
      =groups
  ==
::
+$  diff
  $%  [%group-update update:store]
      [%group-initial groups]
  ==
--
::
=|  state-one
=*  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
    |=  =old=vase
    =/  old  !<(versioned-state old-vase)
    ?:  ?=(%1 -.old)
      `this(state old)
    |^
    :-  :~  [%pass / %agent [our.bowl dap.bowl] %poke %noun !>(%perm-upgrade)]
            kick-all
        ==
    =*  paths  ~(key by groups.old)
    =/  [unmanaged=(list path) managed=(list path)]
      (skid ~(tap in paths) |=(=path =('~' (snag 0 path))))
    =.  groups  (all-unmanaged unmanaged)
    =.  groups  (all-managed managed)
    this
    ::
    ++  all-managed
      |=  paths=(list path)
      ^+  groups
      ?~  paths
        groups
      =/  [rid=resource =group]
        (migrate-group i.paths)
      %=    $
          paths  t.paths
        ::
          groups
        (~(put by groups) rid group)
      ==
    ::
    ++  all-unmanaged
      |=  paths=(list path)
      ^+  groups
      ?~  paths
        groups
      ?:  |(=(/~/default i.paths) =(4 (lent i.paths)))
        $(paths t.paths)
      =/  [=resource =group]
        (migrate-unmanaged i.paths)
      %=    $
          paths  t.paths
        ::
          groups
        (~(put by groups) resource group)
      ==
    ++  kick-all
      ^-  card
      :+  %give  %kick
      :_  ~
      %~  tap  by
      %+  roll  ~(val by sup.bowl)
      |=  [[=ship pax=path] paths=(set path)]
      (~(put in paths) pax)
    ::
    ++  migrate-unmanaged
      |=  pax=path
      ^-  [resource group]
      =/  members=(set ship)
        (~(got by groups.old) pax)
      =|  =invite:policy
      ?>  ?=(^ pax)
      =/  rid=resource
        (resource-from-old-path t.pax)
      =/  =tags
        (~(put ju *tags) %admin entity.rid)
      :-  rid
      [members tags invite %.y]
    ::
    ++  resource-from-old-path
      |=  pax=path
      ^-  resource
      ?>  ?=([@ @ *] pax)
      =/  ship
        (slav %p i.pax)
      [ship i.t.pax]
    ::
   ++  migrate-group
      |=  pax=path
      =/  members
        (~(got by groups.old) pax)
      =|  =invite:policy
      =/  rid=resource
        (resource-from-old-path pax)
      =/  =tags
        (~(put ju *tags) %admin entity.rid)
      [rid members tags invite %.n]
    ::
    --
  ::
  ++  on-poke
    |=  [=mark =vase]
    ^-  (quip card _this)
    ?>  (team:title our.bowl src.bowl)
    =^  cards  state
      ?+    mark  (on-poke:def mark vase)
          ?(%group-update %group-action)
        (poke-group-update:gc !<(update:store vase))
      ::
          %import
        (poke-import:gc q.vase)
      ==
    [cards this]
  ::
  ++  on-watch
    |=  =path
    ^-  (quip card _this)
    ?>  (team:title our.bowl src.bowl)
    ?>  ?=([%groups ~] path)
    :_  this
    [%give %fact ~ %group-update !>([%initial groups])]~
  ::
  ++  on-leave  on-leave:def
  ::
  ++  on-peek
    |=  =path
    ^-  (unit (unit cage))
    ?+  path  (on-peek:def path)
        [%y %groups ~]
      =/  =arch
        :-  ~
        %-  malt
        %+  turn
          ~(tap by groups)
        |=  [rid=resource *]
        ^-  [@ta ~]
        =/  group=^path
          (en-path:resource rid)
        [(spat group) ~]
      ``noun+!>(arch)
    ::
        [%x %groups %ship @ @ ~]
      =/  rid=(unit resource)
        (de-path-soft:resource t.t.path)
      ?~  rid   ~
      ``noun+!>((peek-group u.rid))
    ::
       [%x %groups %ship @ @ %join @ ~]
      =/  rid=(unit resource)
        (de-path-soft:resource t.t.path)
      =/  =ship
        (slav %p i.t.t.t.t.t.t.path)
      ?~  rid  ~
      ``noun+!>((peek-group-join u.rid ship))
    ::
        [%x %export ~]
      ``noun+!>(state)
    ==
  ::
  ++  on-agent
    |=  [=wire =sign:agent:gall]
    ^-  (quip card _this)
    ?.  ?=([%try-rejoin @ *] wire)
      (on-agent:def wire sign)
    ?>  ?=(%poke-ack -.sign)
    =/  rid=resource  (de-path:resource t.t.wire)
    ?~  p.sign
      =/  =cage
        [%pull-hook-action !>([%add entity.rid rid])]
      :_  this
      [%pass / %agent [our.bowl %group-pull-hook] %poke cage]~
    =/  nack-count=@ud  (slav %ud i.t.wire)
    =/  wakeup=@da
      (add now.bowl (mul ~s1 (bex (min 19 nack-count))))
    :_  this
    [%pass wire %arvo %b %wait wakeup]~
  ::
  ++  on-arvo
    |=  [=wire =sign-arvo]
    ^-  (quip card _this)
    ?.  ?=([%try-rejoin @ *] wire)
      (on-arvo:def wire sign-arvo)
    =/  =resource       (de-path:resource t.t.wire)
    =/  nack-count=@ud  (slav %ud i.t.wire)
    ?>  ?=([%b %wake *] sign-arvo)
    ~?  ?=(^ error.sign-arvo)
      "behn errored in backoff timers, continuing anyway"
    :_  this
    [(try-rejoin:gc resource +(nack-count))]~
  ::
  ++  on-fail   on-fail:def
  --
::
|_  bol=bowl:gall
++  peek-group
  |=  rid=resource
  ^-  (unit group)
  (~(get by groups) rid)
::
++  peek-group-join
  |=  [rid=resource =ship]
  =/  ugroup
    (~(get by groups) rid)
  ?~  ugroup
    %.n
  =*  group   u.ugroup
  =*  policy  policy.group
  ?-  -.policy
      %invite
    ?|  (~(has in pending.policy) ship)
        (~(has in members.group) ship)
    ==
      %open
    ?!  ?|
      (~(has in banned.policy) ship)
      (~(has in ban-ranks.policy) (clan:title ship))
    ==
  ==
::
++  poke-import
  |=  arc=*
  ^-  (quip card _state)
  |^
  =/  sty=state-one
    [%1 (remake-groups ;;((tree [resource tree-group]) +.arc))]
  :_  sty
  %+  roll  ~(tap by groups.sty)
  |=  [[rid=resource grp=group] out=(list card)]
  ?:  =(entity.rid our.bol)
    %+  weld  out
    %+  roll  ~(tap in members.grp)
    |=  [recipient=@p out=(list card)]
    ?:  =(recipient our.bol)
      out
    :_  out
    %-  poke-contact
    :*  %invite  rid  recipient
        (crip "Rejoin disconnected group {<entity.rid>}/{<name.rid>}")
    ==
  :_  out
  (try-rejoin rid 0)
  ::
  ++  remake-groups
    |=  grps=(tree [resource tree-group])
    ^-  ^groups
    %-  remake-map
    (~(run by grps) remake-group)
  ::
  ++  remake-group
    |=  grp=tree-group
    ^-  group
    %=  grp
      members  (remake-set members.grp)
      tags     (remake-jug tags.grp)
      policy   (remake-policy policy.grp)
    ==
  ::
  +$  tree-group
    $:  members=(tree ship)
        tags=(tree [tag (tree ship)])
        policy=tree-policy
        hidden=?
    ==
  ::
  +$  tree-policy
    $%  [%invite pending=(tree ship)]
        [%open ban-ranks=(tree rank:title) banned=(tree ship)]
    ==
  ::
  ++  remake-policy
    |=  pl=tree-policy
    ^-  policy
    ?-  -.pl
      %invite  [%invite (remake-set pending.pl)]
      %open    [%open (remake-set ban-ranks.pl) (remake-set banned.pl)]
    ==
  --
::
++  try-rejoin
  |=  [rid=resource nack-count=@ud]
  ^-  card
  =/  =cage
    :-  %group-update
    !>  ^-  update:store
    [%add-members rid (sy our.bol ~)]
  =/  =wire
    [%try-rejoin (scot %ud nack-count) (en-path:resource rid)]
  [%pass wire %agent [entity.rid %group-push-hook] %poke cage]
::
++  poke-group-update
  |=  =update:store
  ^-  (quip card _state)
  ?>  (team:title our.bol src.bol)
  |^
  ?-  -.update
      %add-group       (add-group +.update)
      %add-members     (add-members +.update)
      %remove-members  (remove-members +.update)
      %add-tag         (add-tag +.update)
      %remove-tag      (remove-tag +.update)
      %change-policy   (change-policy +.update)
      %remove-group    (remove-group +.update)
      %expose          (expose +.update)
      %initial-group   (initial-group +.update)
      %initial         [~ state]
  ==
  ::  +expose: unset .hidden flag
  ::
  ++  expose
    |=  [rid=resource ~]
    ^-  (quip card _state)
    =/  =group
      (~(got by groups) rid)
    =.  hidden.group  %.n
    =.  groups
      (~(put by groups) rid group)
    :_  state
    (send-diff %expose rid ~)
  ::  +add-group: add group to store
  ::
  ::    no-op if group already exists
  ::
  ++  add-group
    |=  [rid=resource =policy hidden=?]
    ^-  (quip card _state)
    ?<  (~(has by groups) rid)
    =|  =group
    =.  policy.group   policy
    =.  hidden.group   hidden
    =.  tags.group
      (~(put ju tags.group) %admin our.bol)
    =.  groups
      (~(put by groups) rid group)
    :_  state
    (send-diff %add-group rid policy hidden)
  ::  +add-members: add members to group
  ::
  ++  add-members
    |=  [rid=resource new-ships=(set ship)]
    ^-  (quip card _state)
    =.  groups
      %+  ~(jab by groups)  rid
      |=  group
      %=  +<
        members  (~(uni in members) new-ships)
      ::
          policy
        ?.  ?=(%invite -.policy)
          policy
        policy(pending (~(dif in pending.policy) new-ships))
      ==
    :_  state
    (send-diff %add-members rid new-ships)
  ::  +remove-members: remove members from group
  ::
  ::    no-op if group does not exist
  ::
  ::
  ++  remove-members
    |=  [rid=resource ships=(set ship)]
    ^-  (quip card _state)
    ?.  (~(has by groups) rid)  [~ state]
    =.  groups
      %+  ~(jab by groups)  rid
      |=  group
      %=  +<
        members  (~(dif in members) ships)
        tags  (remove-tags +< ships)
      ==
    :_   state
    (send-diff %remove-members rid ships)
  ::  +add-tag: add tag to ships
  ::
  ::    crash if ships are not in group
  ::
  ++  add-tag
    |=  [rid=resource =tag ships=(set ship)]
    ^-  (quip card _state)
    =.  groups
      %+  ~(jab by groups)  rid
      |=  group
      ?>  ?=(~ (~(dif in ships) members))
      +<(tags (merge-tags tags ships (sy tag ~)))
    :_  state
    (send-diff %add-tag rid tag ships)
  ::  +remove-tag: remove tag from ships
  ::
  ::    crash if ships are not in group or tag does not exist
  ::
  ++  remove-tag
    |=  [rid=resource =tag ships=(set ship)]
    ^-  (quip card _state)
    =.  groups
      %+  ~(jab by groups)  rid
      |=  group
      ?>  ?&  ?=(~ (~(dif in ships) members))
              (~(has by tags) tag)
          ==
      %=    +<
        ::
          tags
        %+  ~(jab by tags)  tag
        |=((set ship) (~(dif in +<) ships))
      ==
    :_  state
    (send-diff %remove-tag rid tag ships)
  ::  initial-group: initialize foreign group
  ::
  ++  initial-group
    |=  [rid=resource =group]
    ^-  (quip card _state)
    =.  groups
      (~(put by groups) rid group)
    :_  state
    (send-diff %initial-group rid 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
    |=  [rid=resource =diff:policy]
    ^-  (quip card _state)
    ?.  (~(has by groups) rid)
      [~ state]
    =/  =group
      (~(got by groups) rid)
    |^
    =^  cards  group
      ?-  -.diff
        %open     (open +.diff)
        %invite   (invite +.diff)
        %replace  (replace +.diff)
      ==
    =.  groups
      (~(put by groups) rid group)
    :_  state
    %+  weld
      (send-diff %change-policy rid diff)
    cards
    ::
    ++  open
      |=  =diff:open:policy
      ?-  -.diff
        %allow-ranks     (allow-ranks +.diff)
        %ban-ranks       (ban-ranks +.diff)
        %allow-ships     (allow-ships +.diff)
        %ban-ships       (ban-ships +.diff)
      ==
    ::
    ++  invite
      |=  =diff:invite:policy
      ?-  -.diff
        %add-invites     (add-invites +.diff)
        %remove-invites  (remove-invites +.diff)
      ==
    ::
    ++  allow-ranks
      |=  ranks=(set rank:title)
      ^-  (quip card _group)
      ?>  ?=(%open -.policy.group)
      =.  ban-ranks.policy.group
        (~(dif in ban-ranks.policy.group) ranks)
      `group
    ::
    ++  ban-ranks
      |=  ranks=(set rank:title)
      ^-  (quip card _group)
      ?>  ?=(%open -.policy.group)
      =.  ban-ranks.policy.group
        (~(uni in ban-ranks.policy.group) ranks)
      `group
    ::
    ++  allow-ships
      |=  ships=(set ship)
      ^-  (quip card _group)
      ?>  ?=(%open -.policy.group)
      =.  banned.policy.group
        (~(dif in banned.policy.group) ships)
      `group
    ::
    ++  ban-ships
      |=  ships=(set ship)
      ^-  (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 rid 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
        (~(dif in pending.policy.group) ships)
      `group
    ++  replace
      |=  =policy
      ^-  (quip card _group)
      =.  policy.group
        policy
      `group
    --
  ::  +remove-group: remove group from store
  ::
  ::    no-op if group does not exist
  ++  remove-group
    |=  [rid=resource ~]
    ^-  (quip card _state)
    ?.  (~(has by groups) rid)
      `state
    =.  groups
      (~(del by groups) rid)
    :_  state
    (send-diff %remove-group rid ~)
  ::
  --

++  merge-tags
  |=  [=tags ships=(set ship) new-tags=(set tag)]
  ^+  tags
  =/  tags-list  ~(tap in new-tags)
  |-
  ?~  tags-list
    tags
  =*  tag  i.tags-list
  =/  old-ships=(set ship)
    (~(gut by tags) tag ~)
  %=    $
    tags-list  t.tags-list
  ::
      tags
    %+  ~(put by tags)
      tag
    (~(uni in old-ships) ships)
 ==
++  remove-tags
  |=  [=group ships=(set ship)]
  ^-  tags
  %-  malt
  %+  turn
    ~(tap by tags.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)]
::
++  poke-contact
  |=  act=contact-view-action
  ^-  card
  [%pass / %agent [our.bol %contact-view] %poke %contact-view-action !>(act)]
::  +send-diff: update subscribers of new state
::
::    We only allow subscriptions on /groups
::    so just give the fact there.
++  send-diff
  |=  =update:store
  ^-  (list card)
  [%give %fact ~[/groups] %group-update !>(update)]~
::
--