Merge pull request #3416 from urbit/lf/app-sane

Applied schizoanalysis: Sanity checking for landscape

pkg/arvo/app/contact-hook.hoon

@@ -186,6 +186,8 @@
     ?+  path  (on-peek:def path)
         [%x %export ~]
       ``noun+!>(state)
+        [%x %synced ~]
+      ``noun+!>(~(key by synced))
     ==
   ++  on-arvo
     |=  [=wire =sign-arvo]

pkg/arvo/app/group-push-hook.hoon

@@ -36,7 +36,68 @@
 ++  on-init  on-init:def
 ++  on-save  !>(~)
 ++  on-load    on-load:def
-++  on-poke   on-poke:def
+++  on-poke   
+  |=  [=mark =vase]
+  ^-  (quip card _this)
+  |^
+  ?.  =(mark %sane)
+    (on-poke:def mark vase)
+  [sane this]
+  ::
+  ++  scry-sharing
+    .^  (set resource)
+      %gx
+      (scot %p our.bowl)
+      %group-push-hook
+      (scot %da now.bowl)
+      /sharing/noun
+    ==
+  ::
+  ++  sane
+    ^-  (list card)
+    %+  murn
+      ~(tap in scry-sharing)
+    |=  rid=resource
+    ^-  (unit card)
+    =/  u-g=(unit group)
+      (scry-group:grp rid)
+    ?~  u-g 
+      `(poke-us %remove rid)
+    =*  group  u.u-g
+    =/  subs=(set ship)
+      (get-subscribers-for-group rid)
+    =/  to-remove=(set ship)
+      (~(dif in members.group) subs)
+    ?~  to-remove  ~
+    `(poke-store %remove-members rid to-remove)
+  ::
+  ++  poke-us
+    |=  =action:push-hook
+    ^-  card
+    =-  [%pass / %agent [our.bowl %group-push-hook] %poke -]
+    push-hook-action+!>(action)
+  ::
+  ++  poke-store
+    |=  =update:store
+    ^-  card
+    =+  group-update+!>(update)
+    [%pass /sane %agent [our.bowl %group-store] %poke -]
+  ::
+  ++  get-subscribers-for-group
+    |=  rid=resource
+    ^-  (set ship)
+    =/  target=path
+      (en-path:resource rid)
+    %-  ~(gas in *(set ship))
+    %+  murn
+      ~(val by sup.bowl)
+    |=  [her=ship =path]
+    ^-  (unit ship)
+    ?.  =(path resource+target)
+      ~
+    `her
+  --
+
 ++  on-agent  on-agent:def
 ++  on-watch    on-watch:def
 ++  on-leave    on-leave:def

pkg/arvo/app/group-store.hoon

@@ -189,17 +189,7 @@
     ^-  (unit (unit cage))
     ?+  path  (on-peek:def path)
         [%y %groups ~]
-      =/  =arch
+      ``noun+!>(~(key by groups))
-        :-  ~
-        %-  malt
-        %+  turn
-          ~(tap by groups)
-        |=  [rid=resource *]
-        ^-  [@ta ~]
-        =/  group=^path
-          (en-path:resource rid)
-        [(spat group) ~]
-      ``noun+!>(arch)
     ::
         [%x %groups %ship @ @ ~]
       =/  rid=(unit resource)

pkg/arvo/app/metadata-hook.hoon

@@ -55,6 +55,8 @@
     |=  =path
     ^-  (unit (unit cage))
     ?+  path  (on-peek:def path)
+        [%x %synced ~]
+      ``noun+!>(~(key by synced))
         [%x %export ~]
       ``noun+!>(state)
     ==

pkg/arvo/app/sane.hoon

@@ -0,0 +1,309 @@
+::  %sane: sanity checker for the landscape suite of applications
+::
+::    Userspace currently uses certain identifiers as foreign keys, and
+::    expects those foreign keys to exist in a number of locations. 
+::
+::    These foreign key relationships are prone to breaking during OTAs 
+::    and there are enough of them that they rarely get tested for 
+::    manually. %sane is a gall app that will check the validity of
+::    these relationships, and fix them if asked.
+::
+::    Sane has a companion thread, -sane, which should be run instead
+::    of attempting :sane %fix directly from the dojo.
+::
+::    Pokes:
+::      %fix - Find issues and fix them
+::      %check - Find issues and print them
+::
+::    Currently validates:
+::      - Entries in {contact,metadata,group} stores are in sync with 
+::         their hooks
+::      - Each group has its associated metadata and contacts
+::      - Each graph is being synced
+::      - Each chat is being synced
+::
+/-  *metadata-store, contacts=contact-store, *group
+/+  default-agent, verb, dbug, resource, graph, mdl=metadata, group
+~%  %sane-app  ..card  ~
+|%
++$  card  card:agent:gall
+::
++$  state-zero  [%0 ~]
+::
++$  issue  
+  $%  [%lib-pull-hook-desync app=term =resource]
+      [%lib-push-hook-desync app=term =resource]
+      [%md-hook-desync =path]
+      [%contact-hook-desync =path]
+      [%dangling-md =path]
+  ==
+::
++$  issues
+  (list issue)
+::
++$  action  ?(%check %fix)
+--
+::
+=|  state-zero
+=*  state  -
+::
+%-  agent:dbug
+%+  verb  |
+^-  agent:gall
+=<
+|_  =bowl:gall
++*  this        .
+    sane-core  +>
+    sc          ~(. sane-core bowl)
+    def         ~(. (default-agent this %|) bowl)
+::
+++  on-init  
+  ^-  (quip card _this)
+  `this
+++  on-save  !>(state)
+::
+++  on-load
+  |=  =vase
+  `this
+::
+++  on-poke  
+  |=  [=mark =vase]
+  ^-  (quip card _this)
+  ?.  =(%noun mark)
+    (on-poke:def mark vase)
+  =/  act=action  !<(action vase)
+  =^  cards  state
+    ?-  act  
+      %fix  fix-sane:sc
+      %check  print-sane:sc
+    ==
+  [cards this]
+::
+++  on-agent  on-agent:def
+++  on-watch  on-watch:def
+++  on-leave  on-leave:def
+::
+++  on-peek   
+  |=  =path
+  ^-  (unit (unit cage))
+  ?.  ?=([%x %bad-path ~] path)
+    (on-peek:def path)
+  ~
+::
+++  on-arvo  on-arvo:def
+++  on-fail   on-fail:def
+--
+::
+|_  =bowl:gall
+::
+++  gra  ~(. graph bowl)
+::
+++  md   ~(. mdl bowl)
+::
+++  grp  ~(. group bowl)
+::
+++  foreign-keys
+  |_  =issues
+  ++  fk-core  .
+  ::
+  ++  abet
+    ^+  issues
+    issues
+  ::
+  ++  abet-fix
+    ^-  (list card)
+    (zing (turn issues fix-issue))
+  ::
+  ++  report
+    |=  =issue
+    fk-core(issues (snoc issues issue))
+  ::
+  ++  report-many
+    |=  many=^issues
+    fk-core(issues (weld issues many))
+  ::
+  ++  check-all
+    =>  (lib-hooks-desync %group scry-groups)
+    =>  (lib-hooks-desync %graph get-keys:gra)
+    =>  groups
+    metadata
+  ::
+  ++  groups
+    ^+  fk-core
+    =/  groups=(list resource)
+       ~(tap in scry-groups)
+    |-
+    ?~  groups
+      fk-core
+    =*  group  i.groups
+    =?  fk-core  !(~(has in scry-md-syncs) group)
+      (report %md-hook-desync (en-path:resource group))
+    =?  fk-core  &((is-managed:grp group) !(~(has in scry-contact-syncs) group))
+      (report %contact-hook-desync (en-path:resource group))
+    $(groups t.groups)
+  ::
+  ++  metadata
+    ^+  fk-core
+    =/  md-groups=(list path)
+      ~(tap in ~(key by md-group-indices))
+    |- 
+    ?~  md-groups
+      fk-core
+    =/  rid=resource
+      (de-path:resource i.md-groups)
+    =?  fk-core  !(~(has in scry-groups) rid)
+      (report %dangling-md i.md-groups)
+    $(md-groups t.md-groups)
+  ::
+  ++  lib-hooks-desync
+    |=  [app=term storing=(set resource)]
+    ^+  fk-core
+    =/  tracking
+      (tracking-pull-hook (pull-hook-name app))
+    =/  sharing
+      (sharing-push-hook (push-hook-name app))
+    =/  resources
+      ~(tap in storing)
+    |- 
+    ?~  resources
+      fk-core
+    =*  rid  i.resources
+    =?  fk-core  &(=(our.bowl entity.rid) !(~(has in sharing) rid))
+      (report %lib-push-hook-desync (push-hook-name app) rid)
+    =?  fk-core  &(!=(our.bowl entity.rid) !(~(has in tracking) rid))
+      (report %lib-pull-hook-desync (pull-hook-name app) rid)
+    $(resources t.resources)
+  --
+::
+++  pull-hook-name
+  |=  app=term
+  :(join-cord app '-' %pull-hook)
+::
+++  push-hook-name
+  |=  app=term
+  :(join-cord app '-' %push-hook)
+::
+++  fix-sane
+  ^-  (quip card _state)
+  =/  cards=(list card)
+    =>  foreign-keys
+    =>  check-all
+    abet-fix
+  [cards state]
+::
+++  print-sane
+  ^-  (quip card _state)
+  =/  =issues
+    =>  foreign-keys
+    =>  check-all
+    abet
+  ~&  issues
+  `state
+::
+++  fix-issue
+  |=  =issue
+  |^
+  ^-  (list card)
+  ?-   -.issue 
+    ::
+      %lib-pull-hook-desync
+    =*  rid  resource.issue
+    (poke-our app.issue pull-hook-action+!>([%add entity.rid rid]))^~
+    ::
+      %lib-push-hook-desync
+    (poke-our app.issue push-hook-action+!>([%add resource.issue]))^~
+    ::
+      %md-hook-desync
+    =/  rid=resource
+      (de-path:resource path.issue)
+    =/  act
+      ?:  =(entity.rid our.bowl)
+        [%add-owned path.issue]
+      [%add-synced entity.rid path.issue]
+    (poke-our %metadata-hook metadata-hook-action+!>(act))^~
+    ::
+      %contact-hook-desync
+    =/  rid=resource
+      (de-path:resource path.issue)
+    =/  act
+      ?:  =(entity.rid our.bowl)
+        [%add-owned path.issue]
+      [%add-synced entity.rid path.issue]
+    (poke-our %contact-hook contact-hook-action+!>(act))^~
+    :: 
+      %dangling-md
+    =/  app-indices
+      (~(get ju md-group-indices) path.issue)
+    %+  turn
+      ~(tap in app-indices)
+    |=  =md-resource
+    ^-  card
+    (poke-our %metadata-store metadata-action+!>([%remove path.issue md-resource]))
+  ==
+  ::
+  ++  poke-our
+    |=  [app=term =cage]
+    ^-  card
+    [%pass /fix %agent [our.bowl app] %poke cage]
+  --
+::
+++  join-cord
+  (cury cat 3)
+::
+++  scry-groups
+  (scry ,(set resource) /y/group-store/groups)
+::
+++  tracking-pull-hook
+  |=  hook=term
+  %+  scry
+    ,(set resource)
+  /x/[hook]/tracking/noun
+::
+++  sharing-push-hook
+  |=  hook=term
+  %+  scry
+    ,(set resource)
+  /x/[hook]/sharing/noun
+::
+++  scry-md-syncs
+  ^-  (set resource)
+  =-  (~(run in -) de-path:resource)
+  %+  scry
+    ,(set path)
+  /x/metadata-hook/synced/noun
+::
+++  scry-contact-syncs
+  ^-  (set resource)
+  =-  (~(run in -) de-path:resource)
+  %+  scry
+    ,(set path)
+  /x/contact-hook/synced/noun
+::
+++  scry-chat-syncs
+  ^-  (set path)
+  %+  scry
+    ,(set path)
+  /x/chat-hook/synced/noun
+::
+++  scry-chats
+  ^-  (set path)
+  %+  scry
+    ,(set path)
+  /x/chat-store/keys/noun
+::
+++  md-group-indices
+  (scry (jug group-path md-resource) /y/metadata-store/group-indices)
+::
+++  scry
+  |*  [=mold =path]
+  ^-  mold
+  ?>  ?=(^ path)
+  ?>  ?=(^ t.path)
+  .^  mold
+    (cat 3 %g i.path)
+    (scot %p our.bowl)
+    i.t.path
+    (scot %da now.bowl)
+    t.t.path
+  ==
+--

pkg/arvo/lib/pull-hook.hoon

@@ -233,13 +233,21 @@
       |=  [=mark =vase]
       ^-  [(list card:agent:gall) agent:gall]
       ?>  (team:title our.bowl src.bowl)
-      ?.  =(mark %pull-hook-action)
+        ?+   mark
-        =^  cards  pull-hook
+          =^  cards  pull-hook
-          (on-poke:og mark vase)
+            (on-poke:og mark vase)
-        [cards this]
+          [cards this]
-      =^  cards  state
+        ::
-        (poke-hook-action:hc !<(action vase))
+            %sane
-      [cards this]
+          =^  cards  state
+            poke-sane:hc
+          [cards this]
+        ::
+            %pull-hook-action
+          =^  cards  state
+            (poke-hook-action:hc !<(action vase))
+          [cards this]
+        ==
     ::
     ++  on-watch
       |=  =path
@@ -309,10 +317,47 @@
       ++  on-peek   
         |=  =path
         ^-  (unit (unit cage))
-        (on-peek:og path)
+        ?.  =(/x/tracking path)
+          (on-peek:og path)
+        ``noun+!>(~(key by tracking))
     --
   |_  =bowl:gall
   +*  og   ~(. pull-hook bowl)
+  ++  poke-sane
+    ^-  (quip card:agent:gall _state)
+    =/  cards
+      restart-subscriptions
+    ~?  >  ?=(^ cards)
+      "Fixed subscriptions in {<dap.bowl>}"
+    :_  state
+    restart-subscriptions
+  ::
+  ++  check-subscription
+    |=  [rid=resource =ship]
+    ^-  ?
+    %+  lien
+      ~(tap in ~(key by wex.bowl))
+    |=  [=wire her=^ship app=term]
+    ^-  ?
+    ?&  =(app push-hook-name.config)
+        =(ship her)
+        =((scag 4 wire) /helper/pull-hook/pull/resource)
+        =(`rid (de-path-soft:resource (slag 4 wire)))
+    ==
+  ::
+  ++  restart-subscriptions
+    ^-  (list card:agent:gall)
+    %-  zing
+    %+  turn
+      ~(tap by tracking)
+    |=  [rid=resource =ship] 
+    ^-  (list card:agent:gall)
+    ?:  (check-subscription rid ship)  ~
+    ~&  >>  "restarting: {<rid>}"
+    =/  pax=(unit path)
+      (on-pull-kick:og rid)
+    ?~  pax  ~
+    (watch-resource rid u.pax)
   ::
   ++  mule-scry
     |=  [ref=* raw=*]

pkg/arvo/lib/push-hook.hoon

@@ -284,7 +284,12 @@
         =^  cards  push-hook
           (on-fail:og term tang)
         [cards this]
-      ++  on-peek   on-peek:og
+      ++  on-peek   
+        |=  =path
+        ^-  (unit (unit cage))
+        ?.  =(/x/sharing path)
+          (on-peek:og path)
+        ``noun+!>(sharing)
     --
   |_  =bowl:gall
   +*  og   ~(. push-hook bowl)

pkg/arvo/mar/contact-hook-action.hoon

@@ -0,0 +1,10 @@
+/-  *contact-hook
+|_  act=contact-hook-action
+++  grab  |%
+          ++  noun  contact-hook-action
+          --
+++  grow  |%
+          ++  noun  act
+          --
+++  grad  %noun
+--

pkg/arvo/mar/metadata-hook-action.hoon

@@ -0,0 +1,10 @@
+/-  *metadata-hook
+|_  act=metadata-hook-action
+++  grab  |%
+          ++  noun  metadata-hook-action
+          --
+++  grow  |%
+          ++  noun  act
+          --
+++  grad  %noun
+--

pkg/arvo/ted/sane.hoon

@@ -0,0 +1,31 @@
+/-  spider
+/+  *strandio
+=>  
+|%
+++  strand  strand:spider
+::
+++  supported-apps
+  ^-  (list term)
+  :~  %graph-pull-hook
+      %group-pull-hook
+      %group-push-hook
+  ==
+::
+++  poke-all-sane
+  =/  m  (strand ,~)
+  ^-  form:m
+  =/  apps  supported-apps
+  |-  =*  loop  $
+  ?~  apps
+    (pure:m ~)
+  =*  app  i.apps
+  ;<  ~   bind:m  (poke-our app sane+!>(%sane))
+  loop(apps t.apps)
+--
+::
+^-  thread:spider
+|=  vase
+=/  m  (strand ,vase)
+;<  ~  bind:m  poke-all-sane 
+;<  ~  bind:m  (poke-our %sane noun+!>(%fix))
+(pure:m !>("Done"))