urbit/app/ph.hoon

::  Test the pH of your aquarium.  See if it's safe to put in real fish.
::
::  usage:
::  :aqua [%run-test %test-add]
::
::  TODO:
::  - Restore a fleet
::  - Compose tests
::
/-  aquarium
/+  ph
=,  aquarium
=,  ph
=>  $~  |%
    +$  move  (pair bone card)
    +$  card
      $%  [%poke wire dock poke-type]
          [%peer wire dock path]
          [%pull wire dock ~]
          [%diff diff-type]
      ==
    ::
    +$  poke-type
      $%  [%aqua-events (list aqua-event)]
          [%drum-start term term]
          [%aqua-vane-control ?(%subscribe %unsubscribe)]
      ==
    ::
    +$  diff-type
      $%  [%aqua-effects aqua-effects]
      ==
    ::
    +$  state
      $:  %0
          raw-test-cores=(map term raw-test-core)
          test-cores=(map term test-core-state)
          other-state
      ==
    ::
    +$  test-core-state
      $:  hers=(list ship)
          cor=raw-test-core
          effect-log=(list [who=ship uf=unix-effect])
      ==
    ::
    +$  other-state
      $~
    --
=,  gall
=/  vane-apps=(list term)
  ~[%aqua %aqua-ames %aqua-behn %aqua-dill %aqua-eyre]
|_  $:  hid=bowl
        state
    ==
++  this  .
++  test-lib  ~(. ^test-lib our.hid)
::
::  Tests that will be run automatically with :ph %run-all-tests
::
++  auto-tests
  =,  test-lib
  %-  malt
  ^-  (list (pair term raw-test-core))
  :~
    :-  %boot-bud
    (galaxy ~bud)
  ::
    :-  %add
    ^-  raw-test-core
    %+  compose-tests  (galaxy ~bud)
    %+  stateless-test
      %add
    |%
    ++  start
      |=  now=@da
      (dojo ~bud "[%test-result (add 2 3)]")
    ::
    ++  route
      |=  [now=@da who=ship uf=unix-effect]
      (expect-dojo-output ~bud who uf "[%test-result 5]")
    --
  ::
    :-  %hi
    %+  compose-tests
      %+  compose-tests
        (galaxy ~bud)
      (galaxy ~dev)
    %+  stateless-test
      %hi
    |%
    ++  start
      |=  now=@da
      (dojo ~bud "|hi ~dev")
    ::
    ++  route
      |=  [now=@da who=ship uf=unix-effect]
      (expect-dojo-output ~bud who uf "hi ~dev successful")
    --
  ::
    :-  %boot-planet
    (planet ~linnup-torsyx)
  ::
    :-  %hi-grandparent
    %+  compose-tests  (planet ~linnup-torsyx)
    %+  stateless-test
      %hi-grandparent
    |%
    ++  start
      |=  now=@da
      (dojo ~linnup-torsyx "|hi ~bud")
    ::
    ++  route
      |=  [now=@da who=ship uf=unix-effect]
      (expect-dojo-output ~linnup-torsyx who uf "hi ~bud successful")
    --
  ::
    :-  %second-cousin-hi
    %+  compose-tests
      %+  compose-tests  (planet ~mitnep-todsut)
        (planet ~haplun-todtus)
    %+  stateless-test
      %second-cousin-hi
    |%
    ++  start
      |=  now=@da
      (dojo ~haplun-todtus "|hi ~bud")
    ::
    ++  route
      |=  [now=@da who=ship uf=unix-effect]
      (expect-dojo-output ~haplun-todtus who uf "hi ~bud successful")
    --
  ::
    :-  %change-file
    %+  compose-tests  (galaxy ~bud)
    (touch-file ~bud %home)
  ::
    :-  %child-sync
    %+  compose-tests
      %+  compose-tests
        (star ~marbud)
      (touch-file ~bud %base)
    (check-file-touched ~marbud %home)
  ==
::
::  Tests that will not be run automatically.
::
::    Some valid reasons for not running a test automatically:
::    - Nondeterministic
::    - Depends on external services
::    - Is very slow
::
++  manual-tests
  =,  test-lib
  %-  malt
  ^-  (list (pair term raw-test-core))
  :~  :-  %boot-from-azimuth
      %+  compose-tests
        %+  compose-tests
          (raw-ship ~bud `(dawn:azimuth ~bud))
        (touch-file ~bud %home)
      ::  %-  assert-happens
      ::  :~
      ::  ==
      *raw-test-core
  ==
::
++  install-tests
  ^+  this
  =.  raw-test-cores
    (~(uni by auto-tests) manual-tests)
  this
::
++  prep
  |=  old=(unit [@ tests=* rest=*])
  ^-  (quip move _this)
  ~&  jael=.^(noun %j /(scot %p our.hid)/code/(scot %da now.hid)/(scot %p our.hid))
  =.  this  install-tests
  ?~  old
    `this
  =/  new  ((soft other-state) rest.u.old)
  ?~  new
    `this
  `this(+<+>+> u.new)
::
++  publish-aqua-effects
  |=  afs=aqua-effects
  ^-  (list move)
  %+  murn  ~(tap by sup.hid)
  |=  [b=bone her=ship pax=path]
  ^-  (unit move)
  ?.  ?=([%effects ~] pax)
    ~
  `[b %diff %aqua-effects afs]
::
++  run-events
  |=  [lab=term what=(list ph-event)]
  ^-  (quip move _this)
  ?:  =(~ what)
    `this
  =/  res
    |-  ^-  (each (list aqua-event) $~)
    ?~  what
      [%& ~]
    ?:  ?=(%test-done -.i.what)
      ~&  ?~(p.i.what "TEST SUCCESSFUL" "TEST FAILED")
      [%| ~]
    =/  nex  $(what t.what)
    ?:  ?=(%| -.nex)
      nex
    [%& `aqua-event`i.what p.nex]
  ?:  ?=(%| -.res)
    (cancel-test lab)
  [[ost.hid %poke /running [our.hid %aqua] %aqua-events p.res]~ this]
::
::  Cancel subscriptions to ships
::
++  cancel-test
  |=  lab=term
  ^-  (quip move _this)
  =/  test  (~(get by test-cores) lab)
  ?~  test
    `this
  =.  test-cores  (~(del by test-cores) lab)
  :_  this
  %-  zing
  %+  turn  hers.u.test
  |=  her=ship
  ^-  (list move)
  :~  [ost.hid %pull /[lab]/(scot %p her) [our.hid %aqua] ~]
      :*  ost.hid
          %poke
          /cancelling
          [our.hid %aqua]
          %aqua-events
          [%pause-events her]~
      ==
  ==
::
::  Should check whether we're already subscribed
::
++  subscribe-to-effects
  |=  [lab=@tas hers=(list ship)]
  :_  this
  %+  turn  hers
  |=  her=ship
  ^-  move
  :*  ost.hid
      %peer
      /[lab]/(scot %p her)
      [our.hid %aqua]
      /effects/(scot %p her)
  ==
::
::  Start the vane drivers
::
++  init-vanes
  ^-  (list move)
  %+  murn
    `(list term)`[%aqua vane-apps]
  |=  vane-app=term
  ^-  (unit move)
  =/  app-started
    .^(? %gu /(scot %p our.hid)/[vane-app]/(scot %da now.hid))
  ?:  app-started
    ~
  `[ost.hid %poke /start [our.hid %hood] %drum-start %home vane-app]
::
::  Restart the vane drivers' subscriptions
::
++  subscribe-vanes
  ^-  (list move)
  %+  turn
    vane-apps
  |=  vane-app=term
  [ost.hid %poke /init [our.hid vane-app] %aqua-vane-control %subscribe]
::
::  Pause all existing ships
::
++  pause-fleet
  ^-  (list move)
  :_  ~
  :*  ost.hid  %poke  /pause-fleet  [our.hid %aqua]  %aqua-events
      %+  turn
        .^((list ship) %gx /(scot %p our.hid)/aqua/(scot %da now.hid)/ships/noun)
      |=  who=ship
      [%pause-events who]
  ==
::
::  User interface
::
++  poke-noun
  |=  arg=*
  ^-  (quip move _this)
  ?+  arg  ~|(%bad-noun-arg !!)
      %init
    [init-vanes this]
  ::
      [%run-test lab=@tas]
    =/  res=[events=(list ph-event) new-state=raw-test-core]
      (start:(~(got by raw-test-cores) lab.arg) now.hid)
    =.  test-cores  (~(put by test-cores) lab.arg [ships . ~]:new-state.res)
    =^  moves-1  this  (subscribe-to-effects lab.arg ships.new-state.res)
    =^  moves-2  this  (run-events lab.arg events.res)
    [:(weld init-vanes pause-fleet subscribe-vanes moves-1 moves-2) this]
  ::
      [%print lab=@tas]
    =/  log  effect-log:(~(got by test-cores) lab.arg)
    ~&  lent=(lent log)
    ~&  %+  roll  log
        |=  [[who=ship uf=unix-effect] ~]
        ?:  ?=(?(%blit %doze) -.q.uf)
          ~
        ?:  ?=(%ergo -.q.uf)
          ~&  [who [- +<]:uf %omitted-by-ph]
          ~
        ~&  [who uf]
        ~
    `this
  ==
::
::  Receive effects back from aqua
::
++  diff-aqua-effects
  |=  [way=wire afs=aqua-effects]
  ^-  (quip move _this)
  ::  ~&  [%diff-aqua-effect way who.afs]
  ?>  ?=([@tas @ ~] way)
  =/  lab  i.way
  =/  test-cor  (~(get by test-cores) lab)
  ?~  test-cor
    ~&  [%ph-dropping lab]
    `this
  =+  |-  ^-  $:  thru-effects=(list unix-effect)
                  events=(list ph-event)
                  cor=_u.test-cor
              ==
      ?~  ufs.afs
        [~ ~ u.test-cor]
      =.  effect-log.u.test-cor
        [[who i.ufs]:afs effect-log.u.test-cor]
      =+  ^-  [thru=? events-1=(list ph-event) cor=_cor.u.test-cor]
          (route:cor.u.test-cor now.hid who.afs i.ufs.afs)
      =.  cor.u.test-cor  cor
      =+  $(ufs.afs t.ufs.afs)
      :+  ?:  thru
            [i.ufs.afs thru-effects]
          thru-effects
        (weld events-1 events)
      cor
  =.  u.test-cor  cor
  =.  test-cores  (~(put by test-cores) lab u.test-cor)
  =/  moves-1  (publish-aqua-effects who.afs thru-effects)
  =^  moves-2  this  (run-events lab events)
  [(weld moves-1 moves-2) this]
::
::  Subscribe to effects
::
++  peer-effects
  |=  pax=path
  ^-  (quip move _this)
  ?.  ?=(~ pax)
    ~&  [%ph-bad-peer-effects pax]
    `this
  `this
::
::  Subscription cancelled
::
++  pull
  |=  pax=path
  ~&  [%ph-unsubscribed pax ost.hid]
  `+>.$
--