urbit/pkg/arvo/lib/tapp.hoon

555 lines
14 KiB
Plaintext
Raw Normal View History

2019-05-28 23:23:06 +03:00
/- tapp-sur=tapp
2019-06-01 00:44:47 +03:00
/+ async
2019-05-29 01:38:14 +03:00
|* $: state-type=mold
peek-data=mold
2019-05-29 03:11:21 +03:00
in-poke-data=mold
out-poke-data=mold
2019-05-29 01:38:14 +03:00
in-peer-data=mold
2019-05-29 03:11:21 +03:00
out-peer-data=mold
2019-05-29 01:38:14 +03:00
==
2019-05-23 22:26:53 +03:00
|%
2019-05-29 03:11:21 +03:00
++ tapp-sur (^tapp-sur out-poke-data out-peer-data)
2019-05-28 23:23:06 +03:00
++ card card:tapp-sur
++ sign sign:tapp-sur
++ contract contract:tapp-sur
+$ tapp-admin-in-poke-data
[%tapp-admin tapp-admin=?(%cancel %restart)]
+$ tapp-in-poke-data
$% tapp-admin-in-poke-data
in-poke-data
==
+$ command
$% [%init ~]
[%poke =in-poke-data]
2019-05-29 01:38:14 +03:00
[%peer =path]
[%diff =dock =path =in-peer-data]
2019-05-29 03:01:18 +03:00
[%take =sign]
2019-05-29 01:38:14 +03:00
==
2019-05-23 22:26:53 +03:00
::
2019-06-01 00:44:47 +03:00
++ async-lib (^async sign card contract)
++ async async:async-lib
2019-05-23 22:26:53 +03:00
::
+$ move (pair bone card)
2019-06-01 00:44:47 +03:00
++ tapp-async (async state-type)
+$ tapp-state
$: waiting=(qeu [=bone command])
active=(unit eval-form:eval:tapp-async)
2019-05-23 22:26:53 +03:00
app-state=state-type
==
+$ tapp-peek
[%noun ?(? (set contract))]
2019-05-29 01:38:14 +03:00
::
2019-06-04 01:25:15 +03:00
:: The form of a tapp
::
+$ tapp-core-all
$_ ^|
|_ [bowl:gall state-type]
::
:: Initialization
::
++ handle-init
*form:tapp-async
::
:: Input
::
++ handle-poke
|~ in-poke-data
*form:tapp-async
::
:: Read
::
++ handle-peek
|~ path
*(unit (unit peek-data))
::
:: 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
--
::
:: Default handlers for all comands
::
++ default-tapp
=/ m tapp-async
^- tapp-core-all
|_ [=bowl:gall state=state-type]
++ handle-init
(pure:m state)
::
++ handle-poke
|=(* (async-fail:async-lib %no-poke-handler ~))
::
++ handle-peek _~
::
++ handle-peer
|= =path
^- form:m
?: ?=([%sole *] path)
~| %default-tapp-no-sole !!
(async-fail:async-lib %no-peer-handler >path< ~)
::
++ handle-diff
|=(* (async-fail:async-lib %no-diff-handler ~))
::
++ handle-take
=> |%
++ print-if-error
|= [msg=tape error=(unit tang)]
%. (pure:m state)
?~ error
same
(slog [leaf+msg u.error])
--
|= =sign
^- form:m
?: ?=(%coup -.sign)
(print-if-error "poke failed" error.sign)
?: ?=(%reap -.sign)
(print-if-error "peer {<path.sign>} failed" error.sign)
(async-fail:async-lib %no-take-handler ~)
--
::
2019-05-29 01:38:14 +03:00
:: The form of a tapp that only handles pokes
::
++ tapp-core-poke
$_ ^|
|_ [bowl:gall state-type]
2019-06-04 01:25:15 +03:00
++ handle-poke handle-poke:*tapp-core-all
2019-05-29 01:38:14 +03:00
--
::
++ create-tapp-poke
|= handler=tapp-core-poke
%- create-tapp-poke-peer
|_ [=bowl:gall state=state-type]
++ handle-peer ~(handle-peer default-tapp bowl state)
::
2019-05-29 03:11:21 +03:00
++ handle-poke ~(handle-poke handler bowl state)
2019-05-29 01:38:14 +03:00
--
::
:: The form of a tapp that only handles pokes and peers
::
++ tapp-core-poke-peer
$_ ^|
|_ [bowl:gall state-type]
2019-06-04 01:25:15 +03:00
++ handle-poke handle-poke:*tapp-core-all
++ handle-peer handle-peer:*tapp-core-all
2019-05-29 01:38:14 +03:00
--
::
++ create-tapp-poke-peer
|= handler=tapp-core-poke-peer
%- create-tapp-all
|_ [=bowl:gall state=state-type]
++ handle-init ~(handle-init default-tapp bowl state)
++ handle-peek ~(handle-peek default-tapp bowl state)
++ handle-diff ~(handle-diff default-tapp bowl state)
++ handle-take ~(handle-take default-tapp bowl state)
::
2019-05-29 03:11:21 +03:00
++ handle-poke ~(handle-poke handler bowl state)
++ handle-peer ~(handle-peer handler bowl state)
2019-05-29 01:38:14 +03:00
--
::
:: The form of a tapp that only handles pokes and diffs
::
++ tapp-core-poke-diff
$_ ^|
|_ [bowl:gall state-type]
2019-06-04 01:25:15 +03:00
++ handle-poke handle-poke:*tapp-core-all
++ handle-diff handle-diff:*tapp-core-all
2019-05-29 01:38:14 +03:00
--
::
++ create-tapp-poke-diff
|= handler=tapp-core-poke-diff
%- create-tapp-all
|_ [=bowl:gall state=state-type]
++ handle-init ~(handle-init default-tapp bowl state)
++ handle-peek ~(handle-peek default-tapp bowl state)
++ handle-peer ~(handle-peer default-tapp bowl state)
++ handle-take ~(handle-take default-tapp bowl state)
::
2019-05-29 03:11:21 +03:00
++ handle-poke ~(handle-poke handler bowl state)
++ handle-diff ~(handle-diff handler bowl state)
2019-05-29 03:01:18 +03:00
--
::
:: The form of a tapp that only handles pokes, peers, and takes
::
++ tapp-core-poke-peer-take
$_ ^|
|_ [bowl:gall state-type]
2019-06-04 01:25:15 +03:00
++ handle-poke handle-poke:*tapp-core-all
++ handle-peer handle-peer:*tapp-core-all
++ handle-take handle-take:*tapp-core-all
2019-05-29 03:01:18 +03:00
--
::
++ create-tapp-poke-peer-take
|= handler=tapp-core-poke-peer-take
%- create-tapp-all
|_ [=bowl:gall state=state-type]
++ handle-init ~(handle-init default-tapp bowl state)
++ handle-peek ~(handle-peek default-tapp bowl state)
++ handle-diff ~(handle-diff default-tapp bowl state)
::
2019-05-29 03:11:21 +03:00
++ handle-poke ~(handle-poke handler bowl state)
++ handle-peer ~(handle-peer handler bowl state)
++ handle-take ~(handle-take handler bowl state)
2019-05-29 01:38:14 +03:00
--
::
:: The form of a tapp that only handles pokes, peers, diffs, and takes
::
++ tapp-core-poke-peer-diff-take
$_ ^|
|_ [bowl:gall state-type]
2019-06-04 01:25:15 +03:00
++ handle-poke handle-poke:*tapp-core-all
++ handle-peer handle-peer:*tapp-core-all
++ handle-diff handle-diff:*tapp-core-all
++ handle-take handle-take:*tapp-core-all
--
::
++ create-tapp-poke-peer-diff-take
|= handler=tapp-core-poke-peer-diff-take
%- create-tapp-all
|_ [=bowl:gall state=state-type]
++ handle-init ~(handle-init default-tapp bowl state)
++ handle-peek ~(handle-peek default-tapp bowl state)
::
++ handle-poke ~(handle-poke handler bowl state)
++ handle-peer ~(handle-peer handler bowl state)
++ handle-diff ~(handle-diff handler bowl state)
++ handle-take ~(handle-take handler bowl state)
--
::
2019-05-29 01:38:14 +03:00
++ create-tapp-all
|= handler=tapp-core-all
2019-05-23 22:26:53 +03:00
|_ [=bowl:gall tapp-state]
++ this-tapp .
::
:: Initialize or upgrade tapp
::
:: If state is upgraded incompatibly, hard-reset and cancel if active.
:: Otherwise, upgrade, cancel and restart if active.
::
2019-05-25 05:42:37 +03:00
++ prep
|= old-state=(unit)
2019-05-25 05:42:37 +03:00
^- (quip move _this-tapp)
?~ old-state
~& [%tapp-init dap.bowl]
=. waiting (~(put to waiting) ost.bowl [%init ~])
start-async
::
=/ old ((soft tapp-state) u.old-state)
?~ old
:: XX use only for development may break contracts!
:: XX if active clam contracts only to abort transaction?
::
:: ~& [%tapp-reset dap.bowl]
:: `this-tapp
~| [%tapp-load-incompatible dap.bowl]
!!
::
:: because the clam replaces the active continuation with
:: the bunt of its mold, we must fail the transaction
::
~& [%tapp-loaded dap.bowl]
=. +<+.this-tapp u.old
?^ active
=. waiting (~(put to waiting) (need ~(top to waiting)))
(oob-fail-async %reset-restart ~)
`this-tapp
2019-05-23 22:26:53 +03:00
::
:: Start a command
::
2019-05-29 02:06:53 +03:00
++ poke
|= =tapp-in-poke-data
2019-05-23 22:26:53 +03:00
^- (quip move _this-tapp)
?: ?=(tapp-admin-in-poke-data tapp-in-poke-data)
?~ active
~& [%tapp-admin-idle dap.bowl]
`this-tapp
?- tapp-admin.tapp-in-poke-data
%cancel
(oob-fail-async %tapp-admin-cancel ~)
::
%restart
=. waiting (~(put to waiting) (need ~(top to waiting)))
(oob-fail-async %tapp-admin-restart ~)
==
::
=. waiting (~(put to waiting) ost.bowl [%poke tapp-in-poke-data])
2019-05-23 22:26:53 +03:00
?^ active
2019-06-01 00:44:47 +03:00
~& [%waiting-until-current-async-finishes waiting]
2019-05-23 22:26:53 +03:00
`this-tapp
2019-06-01 00:44:47 +03:00
start-async
2019-05-23 22:26:53 +03:00
::
:: Receive acknowledgement of outgoing poke
::
:: XX these can be distinguished by dock, but, without a wire or
:: some alternative, that's not very useful if you poke the same
:: dock multiple times. %poke wires are not currently exposed ...
:: Wat do?
::
++ coup
|= [=wire error=(unit tang)]
^- (quip move _this-tapp)
?> ?=([@ @ *] wire)
=/ her (slav %p i.wire)
=* app i.t.wire
=. waiting (~(put to waiting) ost.bowl [%take %coup [her app] error])
?^ active
`this-tapp
start-async
::
:: Read from tapp state
::
++ peek
|= =path
^- (unit (unit ?(tapp-peek peek-data)))
?- path
[%x %tapp %active ~]
[~ ~ %noun ?=(^ active)]
::
[%x %tapp %contracts ~]
[~ ~ %noun ?~(active ~ ~(key by contracts.u.active))]
::
*
(~(handle-peek handler bowl app-state) path)
==
::
2019-05-29 01:38:14 +03:00
:: Receive subscription request
::
++ peer
|= =path
^- (quip move _this-tapp)
=. waiting (~(put to waiting) ost.bowl [%peer path])
2019-05-29 01:38:14 +03:00
?^ active
`this-tapp
2019-06-01 00:44:47 +03:00
start-async
2019-05-29 01:38:14 +03:00
::
:: Receive (involuntary) unsubscription
::
++ quit
|= =wire
^- (quip move _this-tapp)
?> ?=([@ @ *] wire)
=/ her (slav %p i.wire)
=* app i.t.wire
=* pax t.t.wire
=. waiting (~(put to waiting) ost.bowl [%take %quit [her app] pax])
?^ active
`this-tapp
start-async
::
:: Receive acknowledgement of outgoing subscription request
::
++ reap
|= [=wire error=(unit tang)]
^- (quip move _this-tapp)
?> ?=([@ @ *] wire)
=/ her (slav %p i.wire)
=* app i.t.wire
=* pax t.t.wire
=. waiting (~(put to waiting) ost.bowl [%take %reap [her app] pax error])
?^ active
`this-tapp
start-async
::
2019-05-29 01:38:14 +03:00
:: 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) ost.bowl [%diff [her app] pax in-peer-data])
2019-05-29 01:38:14 +03:00
?^ active
`this-tapp
2019-06-01 00:44:47 +03:00
start-async
2019-05-29 01:38:14 +03:00
::
2019-06-01 00:44:47 +03:00
:: Pass response to async
2019-05-23 22:26:53 +03:00
::
++ http-response
|= [=wire response=client-response:iris]
2019-05-23 22:26:53 +03:00
^- (quip move _this-tapp)
(take-async bowl `[wire %http-response response])
2019-05-23 22:26:53 +03:00
::
:: Pass timer to async, or fail
::
2019-05-29 03:01:18 +03:00
++ wake-note
2019-05-26 05:17:18 +03:00
|= [=wire error=(unit tang)]
^- (quip move _this-tapp)
?^ error
2019-06-01 00:44:47 +03:00
(oob-fail-async %timer-fire-failed u.error)
(take-async bowl `[wire %wake ~])
2019-05-26 05:17:18 +03:00
::
:: Enqueue timer transaction
::
2019-05-29 03:01:18 +03:00
++ wake-effect
|= [=wire error=(unit tang)]
^- (quip move _this-tapp)
=. waiting (~(put to waiting) ost.bowl [%take %wake error])
2019-05-29 03:01:18 +03:00
?^ active
`this-tapp
2019-06-01 00:44:47 +03:00
start-async
2019-05-29 03:01:18 +03:00
::
:: Receive route binding notification
::
++ bound
|= [=wire success=? =binding:eyre]
^- (quip move _this-tapp)
(take-async bowl `[wire %bound success binding])
::
2019-08-07 01:42:37 +03:00
:: Receive source update from jael
2019-07-19 03:08:01 +03:00
::
++ source
2019-08-07 01:42:37 +03:00
|= [=wire whos=(set ship) =source:jael]
2019-07-19 03:08:01 +03:00
^- (quip move _this-tapp)
=. waiting (~(put to waiting) ost.bowl [%take %source whos source])
?^ active
`this-tapp
start-async
::
2019-06-01 00:44:47 +03:00
:: Continue computing async
2019-05-23 22:26:53 +03:00
::
2019-06-01 00:44:47 +03:00
++ take-async
|= =async-input:async-lib
2019-05-23 22:26:53 +03:00
^- (quip move _this-tapp)
2019-06-01 00:44:47 +03:00
=/ m tapp-async
2019-08-12 23:50:14 +03:00
=| moves=(list move)
=| scrys=(list path)
|- ^- (quip move _this-tapp)
2019-05-23 22:26:53 +03:00
?~ active
2019-06-01 00:44:47 +03:00
~| %no-active-async
~| ?~ in.async-input
2019-05-29 03:01:18 +03:00
~
2019-06-01 00:44:47 +03:00
wire.u.in.async-input
2019-05-29 03:01:18 +03:00
!!
2019-05-23 22:26:53 +03:00
=^ r=[moves=(list move) =eval-result:eval:m] u.active
=/ out
%- mule |.
(take:eval:m u.active ost.bowl async-input)
?- -.out
%& p.out
%| [[~ [%fail contracts.u.active %crash p.out]] u.active]
==
2019-08-12 23:50:14 +03:00
=. moves (weld moves (skip moves.r |=(=move =(%scry -.q.move))))
=. scrys
%+ weld scrys
^- (list path)
%+ murn moves.r
|= =move
^- (unit path)
?. ?=(%scry -.q.move)
~
`path.q.move
?^ scrys
=/ scry-result .^(* i.scrys)
$(scrys t.scrys, in.async-input `[i.scrys %scry-result scry-result])
2019-06-01 00:44:47 +03:00
=> .(active `(unit eval-form:eval:tapp-async)`active) :: TMI
2019-08-12 23:50:14 +03:00
=^ final-moves=(list move) this-tapp
2019-05-23 22:26:53 +03:00
?- -.eval-result.r
%next `this-tapp
2019-06-01 00:44:47 +03:00
%fail (fail-async [contracts err]:eval-result.r)
%done (done-async [contracts value]:eval-result.r)
2019-05-23 22:26:53 +03:00
==
2019-08-12 23:50:14 +03:00
[(weld moves final-moves) this-tapp]
2019-05-23 22:26:53 +03:00
::
2019-06-01 00:44:47 +03:00
:: Fails currently-running async
::
2019-06-01 00:44:47 +03:00
++ oob-fail-async
(cury fail-async contracts:(need active))
::
2019-06-01 00:44:47 +03:00
:: Called on async failure
2019-05-23 22:26:53 +03:00
::
2019-06-01 00:44:47 +03:00
++ fail-async
|= [contracts=(map contract bone) err=(pair term tang)]
2019-05-23 22:26:53 +03:00
^- (quip move _this-tapp)
2019-05-29 01:38:14 +03:00
%- %- slog
:* leaf+(weld "tapp command failed in app/" (trip dap.bowl))
leaf+(weld " %" (trip p.err))
2019-05-29 01:38:14 +03:00
q.err
==
2019-06-01 00:44:47 +03:00
(finish-async contracts)
2019-05-23 22:26:53 +03:00
::
2019-06-01 00:44:47 +03:00
:: Called on async success
2019-05-23 22:26:53 +03:00
::
2019-06-01 00:44:47 +03:00
++ done-async
|= [contracts=(map contract bone) state=state-type]
2019-05-23 22:26:53 +03:00
^- (quip move _this-tapp)
=. app-state state
2019-06-01 00:44:47 +03:00
(finish-async contracts)
2019-05-23 22:26:53 +03:00
::
2019-06-01 00:44:47 +03:00
:: Called whether async failed or succeeded
2019-05-23 22:26:53 +03:00
::
2019-06-01 00:44:47 +03:00
++ finish-async
|= contracts=(map contract bone)
2019-05-23 22:26:53 +03:00
^- (quip move _this-tapp)
=^ moves-1 this-tapp (cancel-contracts contracts)
2019-05-23 22:26:53 +03:00
=. active ~
=. waiting +:~(get to waiting)
2019-06-01 00:44:47 +03:00
=^ moves-2 this-tapp start-async
[(weld moves-1 moves-2) this-tapp]
::
2019-05-23 22:26:53 +03:00
:: Try to start next command
::
2019-06-01 00:44:47 +03:00
++ start-async
2019-05-23 22:26:53 +03:00
^- (quip move _this-tapp)
?. =(~ active)
2019-06-01 00:44:47 +03:00
~| %async-already-active !!
=/ next=(unit [=bone =command]) ~(top to waiting)
2019-05-23 22:26:53 +03:00
?~ next
`this-tapp
=. active
:- ~
2019-06-01 00:44:47 +03:00
%- from-form:eval:tapp-async
^- form:tapp-async
=/ out
%- mule |.
=. ost.bowl bone.u.next
=* input +.command.u.next
?- -.command.u.next
%init ~(handle-init handler bowl app-state)
%poke (~(handle-poke handler bowl app-state) input)
%peer (~(handle-peer handler bowl app-state) input)
%diff (~(handle-diff handler bowl app-state) input)
%take (~(handle-take handler bowl app-state) input)
==
?- -.out
%& p.out
%| |= async-input:async-lib
[~ ~ ~ %fail %crash p.out]
2019-05-29 01:38:14 +03:00
==
2019-06-01 00:44:47 +03:00
(take-async bowl ~)
::
:: Cancel outstanding contracts
::
++ cancel-contracts
|= contracts=(map contract bone)
^- (quip move this-tapp)
[(zing (turn ~(tap by contracts) cancel-contract)) this-tapp]
::
:: Cancel individual contract
::
++ cancel-contract
|= [=contract =bone]
^- (list move)
?- -.contract
%wait [bone %rest /note/(scot %da at.contract) at.contract]~
%request [bone %cancel-request / ~]~
==
2019-05-23 22:26:53 +03:00
--
--