shrub/lib/tapp.hoon

/-  tapp-sur=tapp
/+  trad
|*  $:  state-type=mold
        command-type=mold
        poke-data=mold
        out-peer-data=mold
        in-peer-data=mold
    ==
|%
++  tapp-sur  (^tapp-sur poke-data out-peer-data)
++  card  card:tapp-sur
++  sign  sign:tapp-sur
++  contract  contract:tapp-sur
++  command
  $%  [%poke command=command-type]
      [%peer =path]
      [%diff =dock =path =in-peer-data]
  ==
::
++  trad-lib  (^trad sign card contract)
++  trad  trad:trad-lib
::
+$  move  (pair bone card)
++  tapp-trad  (trad state-type)
+$  tapp-state
  $:  waiting=(qeu command)
      active=(unit eval-form:eval:tapp-trad)
      app-state=state-type
  ==
::
::  The form of a tapp that only handles pokes
::
++  tapp-core-poke
  $_  ^|
  |_  [bowl:gall state-type]
  ++  handle-command
    |~  command-type
    *form:tapp-trad
  --
::
++  create-tapp-poke
  |=  handler=tapp-core-poke
  %-  create-tapp-poke-peer
  |_  [=bowl:gall state=state-type]
  ++  handle-command  ~(handle-command handler bowl state)
  ++  handle-peer     |=(* (trad-fail:trad-lib %no-peer-handler >path< ~))
  --
::
::  The form of a tapp that only handles pokes and peers
::
++  tapp-core-poke-peer
  $_  ^|
  |_  [bowl:gall state-type]
  ++  handle-command
    |~  command-type
    *form:tapp-trad
  ::
  ++  handle-peer
    |~  path
    *form:tapp-trad
  --
::
++  create-tapp-poke-peer
  |=  handler=tapp-core-poke-peer
  %-  create-tapp-all
  |_  [=bowl:gall state=state-type]
  ++  handle-command  ~(handle-command handler bowl state)
  ++  handle-peer     ~(handle-peer handler bowl state)
  ++  handle-diff     |=(* (trad-fail:trad-lib %no-diff-handler >path< ~))
  --
::
::  The form of a tapp that only handles pokes and diffs
::
++  tapp-core-poke-diff
  $_  ^|
  |_  [bowl:gall state-type]
  ++  handle-command
    |~  command-type
    *form:tapp-trad
  ::
  ++  handle-diff
    |~  [dock path in-peer-data]
    *form:tapp-trad
  --
::
++  create-tapp-poke-diff
  |=  handler=tapp-core-poke-diff
  %-  create-tapp-all
  |_  [=bowl:gall state=state-type]
  ++  handle-command  ~(handle-command handler bowl state)
  ++  handle-peer     |=(=path (trad-fail:trad-lib %no-peer-handler >path< ~))
  ++  handle-diff     ~(handle-diff handler bowl state)
  --
::
::  The form of a tapp
::
++  tapp-core-all
  $_  ^|
  |_  [bowl:gall state-type]
  ++  handle-command
    |~  command-type
    *form:tapp-trad
  ::
  ++  handle-peer
    |~  path
    *form:tapp-trad
  ::
  ++  handle-diff
    |~  [dock path in-peer-data]
    *form:tapp-trad
  --
::
++  create-tapp-all
  |=  handler=tapp-core-all
  |_  [=bowl:gall tapp-state]
  ++  this-tapp  .
  ++  prep
    |=  old-state=*
    ^-  (quip move _this-tapp)
    ~&  [%tapp-loaded dap.bowl]
    =/  old  ((soft tapp-state) old-state)
    ?~  old
      `this-tapp
    `this-tapp(+<+ u.old)
  ::
  ::  Start a command
  ::
  ++  poke
    |=  command=command-type
    ^-  (quip move _this-tapp)
    =.  waiting  (~(put to waiting) %poke command)
    ?^  active
      ~&  [%waiting-until-current-trad-finishes waiting]
      `this-tapp
    start-trad
  ::
  ::  Receive subscription request
  ::
  ++  peer
    |=  =path
    ^-  (quip move _this-tapp)
    =.  waiting  (~(put to waiting) %peer path)
    ?^  active
      `this-tapp
    start-trad
  ::
  ::  Receive subscription response
  ::
  ++  diff
    |=  [=wire =in-peer-data]
    ^-  (quip move _this-tapp)
    ?>  ?=([@ @ *] wire)
    =/  her  (slav %p i.wire)
    =*  app  i.t.wire
    =*  pax  t.t.wire
    =.  waiting  (~(put to waiting) %diff [her app] pax in-peer-data)
    ?^  active
      `this-tapp
    start-trad
  ::
  ::  Pass response to trad
  ::
  ++  sigh-httr
    |=  [=wire =httr:eyre]
    ^-  (quip move _this-tapp)
    (take-trad bowl `[wire %sigh httr])
  ::
  ::  Failed http request
  ::
  ++  sigh-tang
    |=  [=wire =tang]
    ^-  (quip move _this-tapp)
    (oob-fail-trad %failed-sigh tang)
  ::
  ++  wake
    |=  [=wire error=(unit tang)]
    ^-  (quip move _this-tapp)
    ?^  error
      (oob-fail-trad %timer-fire-failed u.error)
    (take-trad bowl `[wire %wake ~])
  ::
  ::  Continue computing trad
  ::
  ++  take-trad
    |=  =trad-input:trad-lib
    ^-  (quip move _this-tapp)
    =/  m  tapp-trad
    ?~  active
      ::  Can't cancel HTTP requests, so we might get answers after end
      ::  of computation
      ::
      ?:  ?=([~ @ %sigh *] in.trad-input)
        `this-tapp
      ~|  %no-active-trad  !!
    =^  r=[moves=(list move) =eval-result:eval:m]  u.active
      (take:eval:m u.active ost.bowl trad-input)
    =>  .(active `(unit eval-form:eval:tapp-trad)`active)  :: TMI
    =^  moves=(list move)  this-tapp
      ?-  -.eval-result.r
        %next  `this-tapp
        %fail  (fail-trad [contracts err]:eval-result.r)
        %done  (done-trad [contracts value]:eval-result.r)
      ==
    [(weld moves.r moves) this-tapp]
  ::
  ::  Fails currently-running trad
  ::
  ++  oob-fail-trad
    (cury fail-trad contracts:(need active))
  ::
  ::  Called on trad failure
  ::
  ++  fail-trad
    |=  [contracts=(set contract) err=(pair term tang)]
    ^-  (quip move _this-tapp)
    %-  %-  slog
        :*  leaf+(trip dap.bowl)
            leaf+"tapp command failed"
            leaf+(trip p.err)
            q.err
        ==
    (finish-trad contracts)
  ::
  ::  Called on trad success
  ::
  ++  done-trad
    |=  [contracts=(set contract) state=state-type]
    ^-  (quip move _this-tapp)
    =.  app-state  state
    (finish-trad contracts)
  ::
  ::  Called whether trad failed or succeeded
  ::
  ++  finish-trad
    |=  contracts=(set contract)
    ^-  (quip move _this-tapp)
    =^  moves-1  this-tapp  (cancel-contracts contracts)
    =.  active   ~
    =.  waiting  +:~(get to waiting)
    =^  moves-2  this-tapp  start-trad
    [(weld moves-1 moves-2) this-tapp]
  ::
  ::
  ::  Try to start next command
  ::
  ++  start-trad
    ^-  (quip move _this-tapp)
    ?.  =(~ active)
      ~|  %trad-already-active  !!
    =/  next=(unit command)  ~(top to waiting)
    ?~  next
      `this-tapp
    =.  active
      :-  ~
      %-  from-form:eval:tapp-trad
      ^-  form:tapp-trad
      ?-  -.u.next
        %poke  (~(handle-command handler bowl app-state) command.u.next)
        %peer  (~(handle-peer handler bowl app-state) path.u.next)
        %diff  (~(handle-diff handler bowl app-state) +.u.next)
      ==
    (take-trad bowl ~)
  ::
  ::  Cancel outstanding contracts
  ::
  ++  cancel-contracts
    |=  contracts=(set contract)
    ^-  (quip move this-tapp)
    [(zing (turn ~(tap in contracts) cancel-contract)) this-tapp]
  ::
  ::  Cancel individual contract
  ::
  ++  cancel-contract
    |=  =contract
    ^-  (list move)
    ?-  -.contract
      %wait  [ost.bowl %rest /(scot %da at.contract) at.contract]~
      %hiss  ~  ::  can't cancel; will ignore response
    ==
  --
--