2019-05-23 22:26:53 +03:00
|
|
|
/+ trad
|
|
|
|
|
=, trad-lib=trad
|
|
|
|
|
|* [state-type=mold command-type=mold]
|
|
|
|
|
|%
|
|
|
|
|
::
|
|
|
|
|
:: The form of a tapp
|
|
|
|
|
::
|
|
|
|
|
++ tapp-core
|
|
|
|
|
$_ ^|
|
|
|
|
|
|_ [bowl:gall state-type]
|
|
|
|
|
++ handle-command
|
|
|
|
|
|~ command-type
|
|
|
|
|
*form:tapp-trad
|
|
|
|
|
--
|
|
|
|
|
::
|
|
|
|
|
++ trad-lib (^trad-lib sign card)
|
|
|
|
|
++ trad trad:trad-lib
|
|
|
|
|
::
|
|
|
|
|
:: Possible async calls
|
|
|
|
|
::
|
|
|
|
|
+$ card
|
|
|
|
|
$% [%hiss wire ~ %httr %hiss hiss:eyre]
|
|
|
|
|
==
|
|
|
|
|
::
|
|
|
|
|
:: Possible async responses
|
|
|
|
|
::
|
|
|
|
|
+$ sign
|
|
|
|
|
$% [%sigh =httr:eyre]
|
|
|
|
|
==
|
|
|
|
|
+$ move (pair bone card)
|
|
|
|
|
++ tapp-trad (trad state-type)
|
|
|
|
|
+$ tapp-state
|
|
|
|
|
$: waiting=(qeu command-type)
|
|
|
|
|
active=(unit eval-form:eval:tapp-trad)
|
|
|
|
|
app-state=state-type
|
|
|
|
|
==
|
|
|
|
|
++ helpers
|
|
|
|
|
=, trad-input=trad-input:trad-lib
|
|
|
|
|
|%
|
|
|
|
|
++ just-do
|
|
|
|
|
|= =card
|
|
|
|
|
=/ m (trad ,~)
|
|
|
|
|
^- form:m
|
|
|
|
|
|= trad-input
|
|
|
|
|
[[/ card]~ ~ %done ~]
|
|
|
|
|
::
|
|
|
|
|
++ send-hiss
|
|
|
|
|
|= =hiss:eyre
|
|
|
|
|
=/ m (trad ,~)
|
|
|
|
|
^- form:m
|
|
|
|
|
(just-do %hiss / ~ %httr %hiss hiss)
|
|
|
|
|
::
|
|
|
|
|
++ expect-sigh
|
|
|
|
|
=/ m (trad ,httr:eyre)
|
|
|
|
|
^- form:m
|
|
|
|
|
|= =trad-input
|
|
|
|
|
?~ trad-input
|
|
|
|
|
[~ ~ %wait ~]
|
|
|
|
|
?: ?=(%sigh -.u.trad-input)
|
|
|
|
|
[~ ~ %done httr.u.trad-input]
|
|
|
|
|
~| [%expected-sigh got=-.u.trad-input]
|
|
|
|
|
!!
|
2019-05-25 05:42:37 +03:00
|
|
|
::
|
|
|
|
|
++ extract-httr-body
|
|
|
|
|
|= =httr:eyre
|
|
|
|
|
=/ m (trad ,cord)
|
|
|
|
|
^- form:m
|
|
|
|
|
?. =(2 (div p.httr 100))
|
|
|
|
|
(trad-fail:trad-lib %httr-error >p.httr< >+.httr< ~)
|
|
|
|
|
?~ r.httr
|
|
|
|
|
(trad-fail:trad-lib %expected-httr-body >httr< ~)
|
|
|
|
|
(pure:m q.u.r.httr)
|
|
|
|
|
::
|
|
|
|
|
++ parse-json
|
|
|
|
|
|= =cord
|
|
|
|
|
=/ m (trad ,json)
|
|
|
|
|
^- form:m
|
|
|
|
|
=/ json=(unit json) (de-json:html cord)
|
|
|
|
|
?~ json
|
|
|
|
|
(trad-fail:trad-lib %json-parse-error ~)
|
|
|
|
|
(pure:m u.json)
|
|
|
|
|
::
|
|
|
|
|
++ fetch-json
|
|
|
|
|
|= url=tape
|
|
|
|
|
=/ m (trad ,json)
|
|
|
|
|
^- form:m
|
|
|
|
|
=/ =hiss:eyre
|
|
|
|
|
:* purl=(scan url auri:de-purl:html)
|
|
|
|
|
meth=%get
|
|
|
|
|
math=~
|
|
|
|
|
body=~
|
|
|
|
|
==
|
|
|
|
|
;< ~ bind:m (send-hiss hiss)
|
|
|
|
|
;< =httr:eyre bind:m expect-sigh
|
|
|
|
|
;< =cord bind:m (extract-httr-body httr)
|
|
|
|
|
(parse-json cord)
|
2019-05-23 22:26:53 +03:00
|
|
|
--
|
|
|
|
|
++ create-tapp
|
|
|
|
|
|= handler=tapp-core
|
|
|
|
|
|_ [=bowl:gall tapp-state]
|
|
|
|
|
++ this-tapp .
|
2019-05-25 05:42:37 +03:00
|
|
|
++ prep
|
|
|
|
|
|= old-state=*
|
|
|
|
|
^- (quip move _this-tapp)
|
|
|
|
|
=/ old ((soft tapp-state) old-state)
|
|
|
|
|
?~ old
|
|
|
|
|
`this-tapp
|
|
|
|
|
`this-tapp(+<+ u.old)
|
2019-05-23 22:26:53 +03:00
|
|
|
::
|
|
|
|
|
:: Start a command
|
|
|
|
|
::
|
|
|
|
|
++ poke-noun
|
|
|
|
|
|= command=command-type
|
|
|
|
|
^- (quip move _this-tapp)
|
|
|
|
|
=. waiting (~(put to waiting) command)
|
|
|
|
|
?^ active
|
|
|
|
|
~& [%waiting-until-current-trad-finishes waiting]
|
|
|
|
|
`this-tapp
|
|
|
|
|
start-trad
|
|
|
|
|
::
|
|
|
|
|
:: Pass response to trad
|
|
|
|
|
::
|
|
|
|
|
++ sigh-httr
|
|
|
|
|
|= [=wire =httr:eyre]
|
|
|
|
|
^- (quip move _this-tapp)
|
|
|
|
|
(take-trad `[%sigh httr])
|
|
|
|
|
::
|
|
|
|
|
:: Failed http request
|
|
|
|
|
::
|
|
|
|
|
++ sigh-tang
|
|
|
|
|
|= [=wire =tang]
|
|
|
|
|
^- (quip move _this-tapp)
|
|
|
|
|
(fail-trad %failed-sigh tang)
|
|
|
|
|
::
|
|
|
|
|
:: Continue computing trad
|
|
|
|
|
::
|
|
|
|
|
++ take-trad
|
|
|
|
|
|= =trad-input:trad-lib
|
|
|
|
|
^- (quip move _this-tapp)
|
|
|
|
|
=/ m tapp-trad
|
|
|
|
|
?~ active
|
|
|
|
|
~| %no-active-trad !!
|
|
|
|
|
=^ r=[moves=(list move) =eval-result:eval:m] u.active
|
|
|
|
|
(take:eval:m u.active ost.bowl /trad 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 err.eval-result.r)
|
|
|
|
|
%done (done-trad value.eval-result.r)
|
|
|
|
|
==
|
|
|
|
|
[(weld moves.r moves) this-tapp]
|
|
|
|
|
::
|
|
|
|
|
:: Called on trad failure
|
|
|
|
|
::
|
|
|
|
|
++ fail-trad
|
|
|
|
|
|= err=(pair term tang)
|
|
|
|
|
^- (quip move _this-tapp)
|
|
|
|
|
%- (slog leaf+"tapp command failed" leaf+(trip p.err) q.err)
|
|
|
|
|
finish-trad
|
|
|
|
|
::
|
|
|
|
|
:: Called on trad success
|
|
|
|
|
::
|
|
|
|
|
++ done-trad
|
|
|
|
|
|= state=state-type
|
|
|
|
|
^- (quip move _this-tapp)
|
|
|
|
|
=. app-state state
|
|
|
|
|
finish-trad
|
|
|
|
|
::
|
|
|
|
|
:: Called whether trad failed or succeeded
|
|
|
|
|
::
|
|
|
|
|
++ finish-trad
|
|
|
|
|
^- (quip move _this-tapp)
|
|
|
|
|
=. active ~
|
|
|
|
|
=. waiting +:~(get to waiting)
|
|
|
|
|
start-trad
|
|
|
|
|
::
|
|
|
|
|
:: Try to start next command
|
|
|
|
|
::
|
|
|
|
|
++ start-trad
|
|
|
|
|
^- (quip move _this-tapp)
|
|
|
|
|
?. =(~ active)
|
|
|
|
|
~| %trad-already-active !!
|
|
|
|
|
=/ next=(unit command-type) ~(top to waiting)
|
|
|
|
|
?~ next
|
|
|
|
|
`this-tapp
|
|
|
|
|
=. active
|
|
|
|
|
:- ~
|
|
|
|
|
^- eval-form:eval:tapp-trad
|
|
|
|
|
%- from-form:eval:tapp-trad
|
|
|
|
|
^- form:tapp-trad
|
|
|
|
|
(~(handle-command handler bowl app-state) u.next)
|
|
|
|
|
(take-trad ~)
|
|
|
|
|
--
|
|
|
|
|
--
|
