mirror of
https://github.com/urbit/shrub.git
synced 2024-12-14 11:08:45 +03:00
Jared Tobin
GitHub
commit
72eac492c8
142
app/example-tapp-fetch.hoon
Normal file
142
app/example-tapp-fetch.hoon
Normal file
@ -0,0 +1,142 @@
|
||||
:: Little app to demonstrate the structure of programs written with the
|
||||
:: transaction monad.
|
||||
::
|
||||
:: Fetches the top comment of each of the top 10 stories from Hacker News
|
||||
::
|
||||
/+ tapp, stdio
|
||||
::
|
||||
:: Preamble
|
||||
::
|
||||
=>
|
||||
|%
|
||||
+$ state
|
||||
$: top-comments=(list tape)
|
||||
==
|
||||
+$ in-poke-data [%noun =cord]
|
||||
+$ out-poke-data ~
|
||||
+$ in-peer-data ~
|
||||
+$ out-peer-data
|
||||
$% [%comments (list tape)]
|
||||
==
|
||||
++ tapp (^tapp state in-poke-data out-poke-data in-peer-data out-peer-data)
|
||||
++ stdio (^stdio out-poke-data out-peer-data)
|
||||
--
|
||||
=>
|
||||
|%
|
||||
:: Helper function to print a comment
|
||||
::
|
||||
++ comment-to-tang
|
||||
|= =tape
|
||||
^- tang
|
||||
%+ welp
|
||||
%+ turn (rip 10 (crip tape))
|
||||
|= line=cord
|
||||
leaf+(trip line)
|
||||
[leaf+""]~
|
||||
::
|
||||
:: All the URLs we fetch from
|
||||
::
|
||||
++ urls
|
||||
=/ base "https://hacker-news.firebaseio.com/v0/"
|
||||
:* top-stories=(weld base "topstories.json")
|
||||
item=|=(item=@ud `tape`:(welp base "item/" +>:(scow %ui item) ".json"))
|
||||
==
|
||||
--
|
||||
=, trad=trad:tapp
|
||||
=, tapp-trad=tapp-trad:tapp
|
||||
=, stdio
|
||||
::
|
||||
:: The app
|
||||
::
|
||||
%- create-tapp-poke-peer-take:tapp
|
||||
^- tapp-core-poke-peer-take:tapp
|
||||
|_ [=bowl:gall state]
|
||||
::
|
||||
:: Main function
|
||||
::
|
||||
++ handle-poke
|
||||
|= =in-poke-data
|
||||
=/ m tapp-trad
|
||||
^- form:m
|
||||
::
|
||||
:: If requested to print, just print what we have in our state
|
||||
::
|
||||
?: =(cord.in-poke-data 'print')
|
||||
~& 'drumroll please...'
|
||||
;< now=@da bind:m get-time
|
||||
;< ~ bind:m (wait (add now ~s3))
|
||||
~& 'Top comments:'
|
||||
%- (slog (zing (turn top-comments comment-to-tang)))
|
||||
(pure:m top-comments)
|
||||
?: =(cord.in-poke-data 'poll')
|
||||
;< ~ bind:m (wait-effect (add now.bowl ~s15))
|
||||
(pure:m top-comments)
|
||||
::
|
||||
:: Otherwise, fetch the top HN stories
|
||||
::
|
||||
=. top-comments ~
|
||||
::
|
||||
:: If this whole thing takes more than 15 seconds, cancel it
|
||||
::
|
||||
%+ (set-timeout _top-comments) (add now.bowl ~s15)
|
||||
;< =top-stories=json bind:m (fetch-json top-stories:urls)
|
||||
=/ top-stories=(list @ud)
|
||||
((ar ni):dejs:format top-stories-json)
|
||||
::
|
||||
:: Loop through the first 5 stories
|
||||
::
|
||||
=. top-stories (scag 5 top-stories)
|
||||
|- ^- form:m
|
||||
=* loop $
|
||||
::
|
||||
:: If done, tell subscribers and print the results
|
||||
::
|
||||
?~ top-stories
|
||||
;< ~ bind:m (give-result /comments %comments top-comments)
|
||||
(handle-poke %noun 'print')
|
||||
::
|
||||
:: Else, fetch the story info
|
||||
::
|
||||
~& "fetching item #{+>:(scow %ui i.top-stories)}"
|
||||
;< =story-info=json bind:m (fetch-json (item:urls i.top-stories))
|
||||
=/ story-comments=(unit (list @ud))
|
||||
((ot kids+(ar ni) ~):dejs-soft:format story-info-json)
|
||||
::
|
||||
:: If no comments, say so
|
||||
::
|
||||
?: |(?=(~ story-comments) ?=(~ u.story-comments))
|
||||
=. top-comments ["<no top comment>" top-comments]
|
||||
loop(top-stories t.top-stories)
|
||||
::
|
||||
:: Else, fetch comment info
|
||||
::
|
||||
;< =comment-info=json bind:m (fetch-json (item:urls i.u.story-comments))
|
||||
=/ comment-text=(unit tape)
|
||||
((ot text+sa ~):dejs-soft:format comment-info-json)
|
||||
::
|
||||
:: If no text (eg comment deleted), record that
|
||||
::
|
||||
?~ comment-text
|
||||
=. top-comments ["<top comment has no text>" top-comments]
|
||||
loop(top-stories t.top-stories)
|
||||
::
|
||||
:: Else, add text to state
|
||||
::
|
||||
=. top-comments [u.comment-text top-comments]
|
||||
loop(top-stories t.top-stories)
|
||||
::
|
||||
++ handle-peer
|
||||
|= =path
|
||||
=/ m tapp-trad
|
||||
^- form:m
|
||||
~& [%tapp-fetch-take-peer path]
|
||||
(pure:m top-comments)
|
||||
::
|
||||
++ handle-take
|
||||
|= sign:tapp
|
||||
=/ m tapp-trad
|
||||
^- form:m
|
||||
;< =state bind:m (handle-poke %noun 'fetch')
|
||||
=. top-comments state
|
||||
(pure:m top-comments)
|
||||
--
|
||||
49
app/example-tapp-subscribe.hoon
Normal file
49
app/example-tapp-subscribe.hoon
Normal file
@ -0,0 +1,49 @@
|
||||
/+ tapp, stdio
|
||||
=>
|
||||
|%
|
||||
+$ subscription-state
|
||||
$: target=[her=ship app=term]
|
||||
=path
|
||||
==
|
||||
+$ state
|
||||
$: subscription=(unit subscription-state)
|
||||
==
|
||||
+$ in-poke-data [%noun =cord]
|
||||
+$ out-poke-data [%noun =cord]
|
||||
+$ out-peer-data ~
|
||||
+$ in-peer-data
|
||||
$% [%comments comments=(list tape)]
|
||||
==
|
||||
++ tapp (^tapp state in-poke-data out-poke-data in-peer-data out-peer-data)
|
||||
++ stdio (^stdio out-poke-data out-peer-data)
|
||||
--
|
||||
=, trad=trad:tapp
|
||||
=, tapp-trad=tapp-trad:tapp
|
||||
=, stdio
|
||||
%- create-tapp-poke-diff:tapp
|
||||
^- tapp-core-poke-diff:tapp
|
||||
|_ [=bowl:gall state]
|
||||
++ handle-poke
|
||||
|= =in-poke-data
|
||||
=/ m tapp-trad
|
||||
^- form:m
|
||||
?: =(cord.in-poke-data 'pull')
|
||||
?~ subscription
|
||||
(trad-fail %no-subscription ~)
|
||||
;< ~ bind:m (pull-app [target path]:u.subscription)
|
||||
(pure:m ~)
|
||||
=/ target [our.bowl %example-tapp-fetch]
|
||||
;< ~ bind:m (poke-app target %noun 'print')
|
||||
;< ~ bind:m (peer-app target /comments)
|
||||
=. subscription `[target /comments]
|
||||
;< ~ bind:m (wait (add now.bowl ~s3))
|
||||
(pure:m subscription)
|
||||
::
|
||||
++ handle-diff
|
||||
|= [[her=ship app=term] =path data=in-peer-data]
|
||||
=/ m tapp-trad
|
||||
^- form:m
|
||||
?> ?=(%comments -.data)
|
||||
~& subscriber-got-data=(lent comments.data)
|
||||
(pure:m subscription)
|
||||
--
|
||||
272
lib/stdio.hoon
Normal file
272
lib/stdio.hoon
Normal file
@ -0,0 +1,272 @@
|
||||
:: Standard input/output functions.
|
||||
::
|
||||
:: These are all asynchronous computations, which means they produce a
|
||||
:: form:(trad A) for some type A. You can always tell what they
|
||||
:: produce by checking their first three lines.
|
||||
::
|
||||
:: Functions with the word "raw" in their name are for internal use
|
||||
:: only because they carry a high salmonella risk. More specifcally,
|
||||
:: improper use of them may result in side effects that the tapp
|
||||
:: runtime doesn't know about and can't undo in case the transaction
|
||||
:: fails.
|
||||
::
|
||||
/- tapp-sur=tapp
|
||||
/+ trad
|
||||
|* [poke-data=mold out-peer-data=mold]
|
||||
=/ tapp-sur (tapp-sur poke-data out-peer-data)
|
||||
=, card=card:tapp-sur
|
||||
=, sign=sign:tapp-sur
|
||||
=, contract=contract:tapp-sur
|
||||
=+ (trad sign card contract)
|
||||
|%
|
||||
::
|
||||
:: Raw power
|
||||
::
|
||||
++ send-raw-card
|
||||
|= =card
|
||||
=/ m (trad ,~)
|
||||
^- form:m
|
||||
|= =trad-input
|
||||
[[card]~ ~ ~ %done ~]
|
||||
::
|
||||
:: Add or remove a contract
|
||||
::
|
||||
++ set-raw-contract
|
||||
|= [add=? =contract]
|
||||
=/ m (trad ,~)
|
||||
^- form:m
|
||||
|= trad-input
|
||||
[~ ~ (silt [add contract]~) %done ~]
|
||||
::
|
||||
:: Send effect on current bone
|
||||
::
|
||||
++ send-effect
|
||||
|= =card
|
||||
=/ m (trad ,~)
|
||||
^- form:m
|
||||
;< =bone bind:m
|
||||
|= =trad-input
|
||||
[~ ~ ~ %done ost.bowl.trad-input]
|
||||
(send-effect-on-bone bone card)
|
||||
::
|
||||
:: Send effect on particular bone
|
||||
::
|
||||
++ send-effect-on-bone
|
||||
|= [=bone =card]
|
||||
=/ m (trad ,~)
|
||||
^- form:m
|
||||
|= trad-input
|
||||
[~ [bone card]~ ~ %done ~]
|
||||
::
|
||||
:: ----
|
||||
::
|
||||
:: HTTP requests
|
||||
::
|
||||
++ send-hiss
|
||||
|= =hiss:eyre
|
||||
=/ m (trad ,~)
|
||||
^- form:m
|
||||
;< ~ bind:m (send-raw-card %hiss / ~ %httr %hiss hiss)
|
||||
(set-raw-contract & %hiss ~)
|
||||
::
|
||||
:: Wait until we get an HTTP response
|
||||
::
|
||||
++ take-sigh-raw
|
||||
=/ m (trad ,httr:eyre)
|
||||
^- form:m
|
||||
|= =trad-input
|
||||
:^ ~ ~ ~
|
||||
?~ in.trad-input
|
||||
[%wait ~]
|
||||
?. ?=(%sigh -.sign.u.in.trad-input)
|
||||
[%fail %expected-sigh >got=-.sign.u.in.trad-input< ~]
|
||||
[%done httr.sign.u.in.trad-input]
|
||||
::
|
||||
:: Wait until we get an HTTP response and unset contract
|
||||
::
|
||||
++ take-sigh
|
||||
=/ m (trad ,httr:eyre)
|
||||
^- form:m
|
||||
;< =httr:eyre bind:m take-sigh-raw
|
||||
;< ~ bind:m (set-raw-contract | %hiss ~)
|
||||
(pure:m httr)
|
||||
::
|
||||
:: Extract body from raw httr
|
||||
::
|
||||
++ extract-httr-body
|
||||
|= =httr:eyre
|
||||
=/ m (trad ,cord)
|
||||
^- form:m
|
||||
?. =(2 (div p.httr 100))
|
||||
(trad-fail %httr-error >p.httr< >+.httr< ~)
|
||||
?~ r.httr
|
||||
(trad-fail %expected-httr-body >httr< ~)
|
||||
(pure:m q.u.r.httr)
|
||||
::
|
||||
:: Parse cord to json
|
||||
::
|
||||
++ parse-json
|
||||
|= =cord
|
||||
=/ m (trad ,json)
|
||||
^- form:m
|
||||
=/ json=(unit json) (de-json:html cord)
|
||||
?~ json
|
||||
(trad-fail %json-parse-error ~)
|
||||
(pure:m u.json)
|
||||
::
|
||||
:: Fetch json at given url
|
||||
::
|
||||
++ 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 take-sigh
|
||||
;< =cord bind:m (extract-httr-body httr)
|
||||
(parse-json cord)
|
||||
::
|
||||
:: ----
|
||||
::
|
||||
:: Time is what keeps everything from happening at once
|
||||
::
|
||||
++ get-time
|
||||
=/ m (trad ,@da)
|
||||
^- form:m
|
||||
|= =trad-input
|
||||
[~ ~ ~ %done now.bowl.trad-input]
|
||||
::
|
||||
:: Set a timer
|
||||
::
|
||||
++ send-wait
|
||||
|= at=@da
|
||||
=/ m (trad ,~)
|
||||
^- form:m
|
||||
;< ~ bind:m (send-raw-card %wait /note/(scot %da at) at)
|
||||
(set-raw-contract & %wait at)
|
||||
::
|
||||
:: Wait until we get a wake event
|
||||
::
|
||||
++ take-wake-raw
|
||||
=/ m (trad ,@da)
|
||||
^- form:m
|
||||
|= =trad-input
|
||||
:^ ~ ~ ~
|
||||
?~ in.trad-input
|
||||
[%wait ~]
|
||||
?. ?=(%wake -.sign.u.in.trad-input)
|
||||
[%fail %expected-wake >got=-.sign.u.in.trad-input< ~]
|
||||
?~ wire.u.in.trad-input
|
||||
[%fail %expected-wake-time ~]
|
||||
=/ at=(unit @da) (slaw %da i.wire.u.in.trad-input)
|
||||
?~ at
|
||||
[%fail %expected-wake-time-da >wire< ~]
|
||||
[%done u.at]
|
||||
::
|
||||
:: Wait until we get a wake event and unset contract
|
||||
::
|
||||
++ take-wake
|
||||
=/ m (trad ,~)
|
||||
^- form:m
|
||||
;< at=@da bind:m take-wake-raw
|
||||
(set-raw-contract | %wait at)
|
||||
::
|
||||
:: Wait until time
|
||||
::
|
||||
++ wait
|
||||
|= until=@da
|
||||
=/ m (trad ,~)
|
||||
^- form:m
|
||||
;< ~ bind:m (send-wait until)
|
||||
take-wake
|
||||
::
|
||||
:: Wait until time then start new computation
|
||||
::
|
||||
++ wait-effect
|
||||
|= until=@da
|
||||
=/ m (trad ,~)
|
||||
^- form:m
|
||||
(send-effect %wait /effect/(scot %da until) until)
|
||||
::
|
||||
:: Cancel computation if not done by time
|
||||
::
|
||||
++ set-timeout
|
||||
|* computation-result=mold
|
||||
=/ m (trad ,computation-result)
|
||||
|= [when=@da computation=form:m]
|
||||
^- form:m
|
||||
;< ~ bind:m (send-wait when)
|
||||
|= =trad-input
|
||||
=* loop $
|
||||
?: ?& ?=([~ * %wake *] in.trad-input)
|
||||
=(/(scot %da when) wire.u.in.trad-input)
|
||||
==
|
||||
[~ ~ (silt [| %wait when]~) %fail %trad-timeout ~]
|
||||
=/ c-res (computation trad-input)
|
||||
?. ?=(%cont -.next.c-res)
|
||||
c-res
|
||||
c-res(self.next ..loop(computation self.next.c-res))
|
||||
::
|
||||
:: ----
|
||||
::
|
||||
:: Apps
|
||||
::
|
||||
++ poke-app
|
||||
|= [[her=ship app=term] =poke-data]
|
||||
=/ m (trad ,~)
|
||||
^- form:m
|
||||
(send-effect %poke / [her app] poke-data)
|
||||
::
|
||||
++ peer-app
|
||||
|= [[her=ship app=term] =path]
|
||||
=/ m (trad ,~)
|
||||
^- form:m
|
||||
=/ =wire (weld /(scot %p her)/[app] path)
|
||||
(send-effect %peer wire [her app] path)
|
||||
::
|
||||
++ pull-app
|
||||
|= [[her=ship app=term] =path]
|
||||
=/ m (trad ,~)
|
||||
^- form:m
|
||||
=/ =wire (weld /(scot %p her)/[app] path)
|
||||
(send-effect %pull wire [her app] ~)
|
||||
::
|
||||
:: ----
|
||||
::
|
||||
:: Handle subscriptions
|
||||
::
|
||||
:: Get bones at particular path; for internal use only
|
||||
::
|
||||
++ get-bones-on-path
|
||||
|= =the=path
|
||||
=/ m (trad ,(list bone))
|
||||
^- form:m
|
||||
|= =trad-input
|
||||
:^ ~ ~ ~
|
||||
:- %done
|
||||
%+ murn ~(tap by sup.bowl.trad-input)
|
||||
|= [ost=bone her=ship =sub=path]
|
||||
^- (unit bone)
|
||||
?. =(the-path sub-path)
|
||||
~
|
||||
`ost
|
||||
::
|
||||
:: Give a result to subscribers on particular path
|
||||
::
|
||||
++ give-result
|
||||
|= [=path =out-peer-data]
|
||||
=/ m (trad ,~)
|
||||
^- form:m
|
||||
;< bones=(list bone) bind:m (get-bones-on-path path)
|
||||
|- ^- form:m
|
||||
=* loop $
|
||||
?~ bones
|
||||
(pure:m ~)
|
||||
;< ~ bind:m (send-effect-on-bone i.bones %diff out-peer-data)
|
||||
loop(bones t.bones)
|
||||
--
|
||||
337
lib/tapp.hoon
Normal file
337
lib/tapp.hoon
Normal file
@ -0,0 +1,337 @@
|
||||
/- tapp-sur=tapp
|
||||
/+ trad
|
||||
|* $: 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]
|
||||
==
|
||||
::
|
||||
++ 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-poke
|
||||
|~ in-poke-data
|
||||
*form:tapp-trad
|
||||
--
|
||||
::
|
||||
++ 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 |=(* (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-poke
|
||||
|~ in-poke-data
|
||||
*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-poke ~(handle-poke handler bowl state)
|
||||
++ handle-peer ~(handle-peer handler bowl state)
|
||||
++ handle-diff |=(* (trad-fail:trad-lib %no-diff-handler >path< ~))
|
||||
++ handle-take |=(* (trad-fail:trad-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-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-poke ~(handle-poke handler bowl state)
|
||||
++ handle-peer |=(* (trad-fail:trad-lib %no-peer-handler >path< ~))
|
||||
++ handle-diff ~(handle-diff handler bowl state)
|
||||
++ handle-take |=(* (trad-fail:trad-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-trad
|
||||
::
|
||||
++ handle-peer
|
||||
|~ path
|
||||
*form:tapp-trad
|
||||
::
|
||||
++ handle-take
|
||||
|~ sign
|
||||
*form:tapp-trad
|
||||
--
|
||||
::
|
||||
++ 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 |=(* (trad-fail:trad-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-trad
|
||||
::
|
||||
:: Subscription request
|
||||
::
|
||||
++ handle-peer
|
||||
|~ path
|
||||
*form:tapp-trad
|
||||
::
|
||||
:: Receive subscription result
|
||||
::
|
||||
++ handle-diff
|
||||
|~ [dock path in-peer-data]
|
||||
*form:tapp-trad
|
||||
::
|
||||
:: Receive syscall result
|
||||
::
|
||||
++ handle-take
|
||||
|~ sign
|
||||
*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
|
||||
|= =in-poke-data
|
||||
^- (quip move _this-tapp)
|
||||
=. waiting (~(put to waiting) %poke in-poke-data)
|
||||
?^ 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-note
|
||||
|= [=wire error=(unit tang)]
|
||||
^- (quip move _this-tapp)
|
||||
?^ error
|
||||
(oob-fail-trad %timer-fire-failed u.error)
|
||||
(take-trad bowl `[wire %wake ~])
|
||||
::
|
||||
++ wake-effect
|
||||
|= [=wire error=(unit tang)]
|
||||
^- (quip move _this-tapp)
|
||||
=. waiting (~(put to waiting) %take %wake error)
|
||||
?^ active
|
||||
`this-tapp
|
||||
start-trad
|
||||
::
|
||||
:: 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
|
||||
~| ?~ in.trad-input
|
||||
~
|
||||
wire.u.in.trad-input
|
||||
!!
|
||||
=^ 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-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-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 /note/(scot %da at.contract) at.contract]~
|
||||
%hiss ~ :: can't cancel; will ignore response
|
||||
==
|
||||
--
|
||||
--
|
||||
190
lib/trad.hoon
Normal file
190
lib/trad.hoon
Normal file
@ -0,0 +1,190 @@
|
||||
|* [input-type=mold card-type=mold contract-type=mold]
|
||||
|%
|
||||
+$ trad-input [=bowl:gall in=(unit [=wire sign=input-type])]
|
||||
+$ trad-move (pair bone card-type)
|
||||
::
|
||||
:: cards: cards to send immediately. These will go out even if a
|
||||
:: later stage of the computation fails, so they shouldn't have
|
||||
:: any semantic effect on the rest of the system.
|
||||
:: Alternately, they may record an entry in contracts with
|
||||
:: enough information to undo the effect if the computation
|
||||
:: fails.
|
||||
:: effects: moves to send after the computation ends.
|
||||
:: contracts: stuff to cancel at end of computation.
|
||||
:: wait: don't move on, stay here. The next sign should come back
|
||||
:: to this same callback.
|
||||
:: cont: continue computation with new callback.
|
||||
:: fail: abort computation; don't send effects
|
||||
:: done: finish computation; send effects
|
||||
::
|
||||
++ trad-output-raw
|
||||
|* a=mold
|
||||
$~ [~ ~ ~ %done *a]
|
||||
$: cards=(list card-type)
|
||||
effects=(list trad-move)
|
||||
contracts=(set [add=? contract=contract-type])
|
||||
$= next
|
||||
$% [%wait ~]
|
||||
[%cont self=(trad-form-raw a)]
|
||||
[%fail err=(pair term tang)]
|
||||
[%done value=a]
|
||||
==
|
||||
==
|
||||
::
|
||||
++ trad-form-raw
|
||||
|* a=mold
|
||||
$-(trad-input (trad-output-raw a))
|
||||
::
|
||||
:: Abort asynchronous computation with error message
|
||||
::
|
||||
++ trad-fail
|
||||
|= err=(pair term tang)
|
||||
|= trad-input
|
||||
[~ ~ ~ %fail err]
|
||||
::
|
||||
:: Asynchronous transcaction monad.
|
||||
::
|
||||
:: Combo of four monads:
|
||||
:: - Reader on input-type
|
||||
:: - Writer on card-type
|
||||
:: - Continuation
|
||||
:: - Exception
|
||||
::
|
||||
++ trad
|
||||
|* a=mold
|
||||
|%
|
||||
++ output (trad-output-raw a)
|
||||
::
|
||||
:: Type of an asynchronous computation.
|
||||
::
|
||||
++ form (trad-form-raw a)
|
||||
::
|
||||
:: Monadic pure. Identity computation for bind.
|
||||
::
|
||||
++ pure
|
||||
|= arg=a
|
||||
^- form
|
||||
|= trad-input
|
||||
[~ ~ ~ %done arg]
|
||||
::
|
||||
:: Monadic bind. Combines two computations, associatively.
|
||||
::
|
||||
++ bind
|
||||
|* b=mold
|
||||
|= [m-b=(trad-form-raw b) fun=$-(b form)]
|
||||
^- form
|
||||
|= input=trad-input
|
||||
=/ b-res=(trad-output-raw b)
|
||||
(m-b input)
|
||||
^- output
|
||||
:^ cards.b-res effects.b-res contracts.b-res
|
||||
?- -.next.b-res
|
||||
%wait [%wait ~]
|
||||
%cont [%cont ..$(m-b self.next.b-res)]
|
||||
%fail [%fail err.next.b-res]
|
||||
%done [%cont (fun value.next.b-res)]
|
||||
==
|
||||
::
|
||||
:: The trad monad must be evaluted in a particular way to maintain
|
||||
:: its monadic character. +take:eval implements this.
|
||||
::
|
||||
++ eval
|
||||
|%
|
||||
:: Indelible state of a trad
|
||||
::
|
||||
+$ eval-form
|
||||
$: effects=(list trad-move)
|
||||
contracts=(set contract-type)
|
||||
=form
|
||||
==
|
||||
::
|
||||
:: Convert initial form to eval-form
|
||||
::
|
||||
++ from-form
|
||||
|= =form
|
||||
^- eval-form
|
||||
[~ ~ form]
|
||||
::
|
||||
:: The cases of results of +take
|
||||
::
|
||||
+$ eval-result
|
||||
$% [%next ~]
|
||||
[%fail contracts=(set contract-type) err=(pair term tang)]
|
||||
[%done contracts=(set contract-type) value=a]
|
||||
==
|
||||
::
|
||||
:: Take a new sign and run the trad against it
|
||||
::
|
||||
++ take
|
||||
:: moves: accumulate throughout recursion the moves to be
|
||||
:: produced now
|
||||
=| moves=(list trad-move)
|
||||
|= [=eval-form =bone =trad-input]
|
||||
^- [[(list trad-move) =eval-result] _eval-form]
|
||||
=* take-loop $
|
||||
:: run the trad callback
|
||||
::
|
||||
=/ =output (form.eval-form trad-input)
|
||||
:: add cards to moves
|
||||
::
|
||||
=. moves
|
||||
%+ welp
|
||||
moves
|
||||
%+ turn cards.output
|
||||
|= card=card-type
|
||||
^- trad-move
|
||||
[bone card]
|
||||
:: add effects to list to be produced when done
|
||||
::
|
||||
=. effects.eval-form
|
||||
(weld effects.eval-form effects.output)
|
||||
:: add or remove contracts
|
||||
::
|
||||
=. .
|
||||
=* loop-result .
|
||||
=/ new=(list [add=? contract=contract-type])
|
||||
~(tap in contracts.output)
|
||||
|- ^+ loop-result
|
||||
=* loop $
|
||||
?~ new
|
||||
loop-result
|
||||
?: add.i.new
|
||||
?: (~(has in contracts.eval-form) contract.i.new)
|
||||
%= loop-result
|
||||
next.output [%fail %contract-already-exists >contract.i.new< ~]
|
||||
==
|
||||
%= loop
|
||||
contracts.eval-form (~(put in contracts.eval-form) contract.i.new)
|
||||
new t.new
|
||||
==
|
||||
?: (~(has in contracts.eval-form) contract.i.new)
|
||||
%= loop
|
||||
contracts.eval-form (~(del in contracts.eval-form) contract.i.new)
|
||||
new t.new
|
||||
==
|
||||
%= loop-result
|
||||
next.output [%fail %contract-doesnt-exist >contract.i.new< ~]
|
||||
==
|
||||
:: if done, produce effects
|
||||
::
|
||||
=? moves ?=(%done -.next.output)
|
||||
%+ welp
|
||||
moves
|
||||
effects.eval-form
|
||||
:: case-wise handle next steps
|
||||
::
|
||||
?- -.next.output
|
||||
%wait [[moves %next ~] eval-form]
|
||||
%fail [[moves %fail contracts.eval-form err.next.output] eval-form]
|
||||
%done [[moves %done contracts.eval-form value.next.output] eval-form]
|
||||
%cont
|
||||
:: recurse to run continuation with initialization input
|
||||
::
|
||||
%_ take-loop
|
||||
form.eval-form self.next.output
|
||||
trad-input [bowl.trad-input ~]
|
||||
==
|
||||
==
|
||||
--
|
||||
--
|
||||
--
|
||||
30
sur/tapp.hoon
Normal file
30
sur/tapp.hoon
Normal file
@ -0,0 +1,30 @@
|
||||
|* [poke-data=mold out-peer-data=mold]
|
||||
|%
|
||||
::
|
||||
:: Possible async calls
|
||||
::
|
||||
+$ card
|
||||
$% [%hiss wire ~ %httr %hiss hiss:eyre]
|
||||
[%them wire ~]
|
||||
[%wait wire @da]
|
||||
[%rest wire @da]
|
||||
[%poke wire dock poke-data]
|
||||
[%peer wire dock path]
|
||||
[%pull wire dock ~]
|
||||
[%diff out-peer-data]
|
||||
==
|
||||
::
|
||||
:: Possible async responses
|
||||
::
|
||||
+$ sign
|
||||
$% [%sigh =httr:eyre]
|
||||
[%wake (unit tang)]
|
||||
==
|
||||
::
|
||||
:: Outstanding contracts
|
||||
::
|
||||
+$ contract
|
||||
$% [%wait at=@da]
|
||||
[%hiss ~]
|
||||
==
|
||||
--
|
||||
Loading…
Reference in New Issue
Block a user