shrub/lib/tapp.hoon

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