diff options
Diffstat (limited to 'desk/lib')
| -rw-r--r-- | desk/lib/dbug.hoon | 155 | ||||
| -rw-r--r-- | desk/lib/nostril.hoon | 23 | ||||
| -rw-r--r-- | desk/lib/server.hoon | 159 | ||||
| -rw-r--r-- | desk/lib/shim.hoon | 53 | ||||
| l--------- | desk/lib/sortug.hoon | 1 | ||||
| -rw-r--r-- | desk/lib/strand.hoon | 1 | ||||
| -rw-r--r-- | desk/lib/strandio.hoon | 965 |
7 files changed, 1357 insertions, 0 deletions
diff --git a/desk/lib/dbug.hoon b/desk/lib/dbug.hoon new file mode 100644 index 0000000..ce98619 --- /dev/null +++ b/desk/lib/dbug.hoon @@ -0,0 +1,155 @@ +:: dbug: agent wrapper for generic debugging tools +:: +:: usage: %-(agent:dbug your-agent) +:: +|% ++$ poke + $% [%bowl ~] + [%state grab=cord] + [%incoming =about] + [%outgoing =about] + == +:: ++$ about + $@ ~ + $% [%ship =ship] + [%path =path] + [%wire =wire] + [%term =term] + == +:: +++ agent + |= =agent:gall + ^- agent:gall + !. + |_ =bowl:gall + +* this . + ag ~(. agent bowl) + :: + ++ on-poke + |= [=mark =vase] + ^- (quip card:agent:gall agent:gall) + ?. ?=(%dbug mark) + =^ cards agent (on-poke:ag mark vase) + [cards this] + =/ dbug + !<(poke vase) + =; =tang + ((%*(. slog pri 1) tang) [~ this]) + ?- -.dbug + %bowl [(sell !>(bowl))]~ + :: + %state + =? grab.dbug =('' grab.dbug) '-' + =; product=^vase + [(sell product)]~ + =/ state=^vase + :: if the underlying app has implemented a /dbug/state scry endpoint, + :: use that vase in place of +on-save's. + :: + =/ result=(each ^vase tang) + (mule |.(q:(need (need (on-peek:ag /x/dbug/state))))) + ?:(?=(%& -.result) p.result on-save:ag) + %+ slap + (slop state !>([bowl=bowl ..zuse])) + (ream grab.dbug) + :: + %incoming + =; =tang + ?^ tang tang + [%leaf "no matching subscriptions"]~ + %+ murn + %+ sort ~(tap by sup.bowl) + |= [[* a=[=ship =path]] [* b=[=ship =path]]] + (aor [path ship]:a [path ship]:b) + |= [=duct [=ship =path]] + ^- (unit tank) + =; relevant=? + ?. relevant ~ + `>[path=path from=ship duct=duct]< + ?: ?=(~ about.dbug) & + ?- -.about.dbug + %ship =(ship ship.about.dbug) + %path ?=(^ (find path.about.dbug path)) + %wire %+ lien duct + |=(=wire ?=(^ (find wire.about.dbug wire))) + %term !! + == + :: + %outgoing + =; =tang + ?^ tang tang + [%leaf "no matching subscriptions"]~ + %+ murn + %+ sort ~(tap by wex.bowl) + |= [[[a=wire *] *] [[b=wire *] *]] + (aor a b) + |= [[=wire =ship =term] [acked=? =path]] + ^- (unit tank) + =; relevant=? + ?. relevant ~ + `>[wire=wire agnt=[ship term] path=path ackd=acked]< + ?: ?=(~ about.dbug) & + ?- -.about.dbug + %ship =(ship ship.about.dbug) + %path ?=(^ (find path.about.dbug path)) + %wire ?=(^ (find wire.about.dbug wire)) + %term =(term term.about.dbug) + == + == + :: + ++ on-peek + |= =path + ^- (unit (unit cage)) + ?. ?=([@ %dbug *] path) + (on-peek:ag path) + ?+ path [~ ~] + [%u %dbug ~] ``noun+!>(&) + [%x %dbug %state ~] ``noun+!>(on-save:ag) + [%x %dbug %subscriptions ~] ``noun+!>([wex sup]:bowl) + == + :: + ++ on-init + ^- (quip card:agent:gall agent:gall) + =^ cards agent on-init:ag + [cards this] + :: + ++ on-save on-save:ag + :: + ++ on-load + |= old-state=vase + ^- (quip card:agent:gall agent:gall) + =^ cards agent (on-load:ag old-state) + [cards this] + :: + ++ on-watch + |= =path + ^- (quip card:agent:gall agent:gall) + =^ cards agent (on-watch:ag path) + [cards this] + :: + ++ on-leave + |= =path + ^- (quip card:agent:gall agent:gall) + =^ cards agent (on-leave:ag path) + [cards this] + :: + ++ on-agent + |= [=wire =sign:agent:gall] + ^- (quip card:agent:gall agent:gall) + =^ cards agent (on-agent:ag wire sign) + [cards this] + :: + ++ on-arvo + |= [=wire =sign-arvo] + ^- (quip card:agent:gall agent:gall) + =^ cards agent (on-arvo:ag wire sign-arvo) + [cards this] + :: + ++ on-fail + |= [=term =tang] + ^- (quip card:agent:gall agent:gall) + =^ cards agent (on-fail:ag term tang) + [cards this] + -- +-- diff --git a/desk/lib/nostril.hoon b/desk/lib/nostril.hoon new file mode 100644 index 0000000..1392380 --- /dev/null +++ b/desk/lib/nostril.hoon @@ -0,0 +1,23 @@ +/- sur=nostril +|% +++ gen-keys |= eny=@ ^- keys:sur + =, secp256k1:secp:crypto + =/ privkey + |- + =/ k (~(rad og eny) (bex 256)) + ?. (lth k n.t) $ k + + =/ pubkey (priv-to-pub privkey) + ~& priv=privkey + ~& pub=pubkey + =/ pub (compress-point pubkey) + :: =/ pub (serialize-point pubkey) + ~& pub-hex=((x-co:co 0) pub) + [pub=pub priv=privkey] +:: +++ cards +|_ =bowl:gall + ++ shim-binding ^- card:agent:gall + [%pass /binding %arvo %e %connect [~ /nostr-shim] dap.bowl] + -- +-- diff --git a/desk/lib/server.hoon b/desk/lib/server.hoon new file mode 100644 index 0000000..f5cf8f0 --- /dev/null +++ b/desk/lib/server.hoon @@ -0,0 +1,159 @@ +=, eyre +|% ++$ request-line + $: [ext=(unit @ta) site=(list @t)] + args=(list [key=@t value=@t]) + == +:: +parse-request-line: take a cord and parse out a url +:: +++ parse-request-line + |= url=@t + ^- request-line + (fall (rush url ;~(plug apat:de-purl:html yque:de-purl:html)) [[~ ~] ~]) +:: +++ manx-to-octs + |= man=manx + ^- octs + (as-octt:mimes:html (en-xml:html man)) +:: +++ json-to-octs + |= jon=json + ^- octs + (as-octs:mimes:html (en:json:html jon)) +:: +++ app + |% + :: + :: +require-authorization: + :: redirect to the login page when unauthenticated + :: otherwise call handler on inbound request + :: + ++ require-authorization + |= $: =inbound-request:eyre + handler=$-(inbound-request:eyre simple-payload:http) + == + ^- simple-payload:http + :: + ?: authenticated.inbound-request + ~! this + ~! +:*handler + (handler inbound-request) + :: + =- [[307 ['location' -]~] ~] + %^ cat 3 + '/~/login?redirect=' + url.request.inbound-request + :: + :: +require-authorization-simple: + :: redirect to the login page when unauthenticated + :: otherwise pass through simple-paylod + :: + ++ require-authorization-simple + |= [=inbound-request:eyre =simple-payload:http] + ^- simple-payload:http + :: + ?: authenticated.inbound-request + ~! this + simple-payload + :: + =- [[307 ['location' -]~] ~] + %^ cat 3 + '/~/login?redirect=' + url.request.inbound-request + :: + ++ give-simple-payload + |= [eyre-id=@ta =simple-payload:http] + ^- (list card:agent:gall) + =/ header-cage + [%http-response-header !>(response-header.simple-payload)] + =/ data-cage + [%http-response-data !>(data.simple-payload)] + :~ [%give %fact ~[/http-response/[eyre-id]] header-cage] + [%give %fact ~[/http-response/[eyre-id]] data-cage] + [%give %kick ~[/http-response/[eyre-id]] ~] + == + -- +++ gen + |% + :: + ++ max-1-da ['cache-control' 'max-age=86400'] + ++ max-1-wk ['cache-control' 'max-age=604800'] + :: + ++ html-response + =| cache=? + |= =octs + ^- simple-payload:http + :_ `octs + [200 [['content-type' 'text/html'] ?:(cache [max-1-wk ~] ~)]] + :: + ++ css-response + =| cache=? + |= =octs + ^- simple-payload:http + :_ `octs + [200 [['content-type' 'text/css'] ?:(cache [max-1-wk ~] ~)]] + :: + ++ js-response + =| cache=? + |= =octs + ^- simple-payload:http + :_ `octs + [200 [['content-type' 'text/javascript'] ?:(cache [max-1-wk ~] ~)]] + :: + ++ png-response + =| cache=? + |= =octs + ^- simple-payload:http + :_ `octs + [200 [['content-type' 'image/png'] ?:(cache [max-1-wk ~] ~)]] + :: + ++ svg-response + =| cache=? + |= =octs + ^- simple-payload:http + :_ `octs + [200 [['content-type' 'image/svg+xml'] ?:(cache [max-1-wk ~] ~)]] + :: + ++ ico-response + |= =octs + ^- simple-payload:http + [[200 [['content-type' 'image/x-icon'] max-1-wk ~]] `octs] + :: + ++ woff2-response + =| cache=? + |= =octs + ^- simple-payload:http + [[200 [['content-type' 'font/woff2'] max-1-wk ~]] `octs] + :: + ++ json-response + =| cache=_| + |= =json + ^- simple-payload:http + :_ `(json-to-octs json) + [200 [['content-type' 'application/json'] ?:(cache [max-1-da ~] ~)]] + :: + ++ manx-response + =| cache=_| + |= man=manx + ^- simple-payload:http + :_ `(manx-to-octs man) + [200 [['content-type' 'text/html'] ?:(cache [max-1-da ~] ~)]] + :: + ++ not-found + ^- simple-payload:http + [[404 ~] ~] + :: + ++ login-redirect + |= =request:http + ^- simple-payload:http + =- [[307 ['location' -]~] ~] + %^ cat 3 + '/~/login?redirect=' + url.request + :: + ++ redirect + |= redirect=cord + ^- simple-payload:http + [[307 ['location' redirect]~] ~] + -- +-- diff --git a/desk/lib/shim.hoon b/desk/lib/shim.hoon new file mode 100644 index 0000000..ad07685 --- /dev/null +++ b/desk/lib/shim.hoon @@ -0,0 +1,53 @@ +/- sur=nostril +/+ sr=sortug +/= router /web/router +|% +++ handle + |= [eyre-id=@ta req=inbound-request:eyre] + ^- (unit event:sur) + ?~ body.request.req ~ + =/ ures (de:json:html q.u.body.request.req) + ?~ ures ~ + =/ event (event:dejs u.ures) + :: TODO log on failure or something + `event + + +++ dejs +=, dejs:format +|% +++ event + |= jon=json + ^- event:sur + %. jon + %- ot :~ + id+de-hex + pubkey+de-hex + ['created_at' ni] + kind+ni + tags+de-tags + content+so + sig+de-hex + == +++ de-hex |= jon=json ^- @ux + ?> ?=(%s -.jon) + =/ atom=(unit @) (slaw:sr %ux p.jon) + ?~ atom !! + u.atom +:: +++ de-tags |= jon=json ^- (list tag:sur) + ?> ?=(%a -.jon) %+ turn p.jon de-tag +++ de-tag |= j=json ^- tag:sur + ?> ?=(%a -.j) + =/ l=(list json) p.j + =/ key (@t ->.l) + =/ value (@t +<+.l) + =/ rest ;; (list @t) %+ turn ((list json) +>.l) |= aj=json (@t +.aj) + + [key value rest] + + + -- + +-- + diff --git a/desk/lib/sortug.hoon b/desk/lib/sortug.hoon new file mode 120000 index 0000000..dad4203 --- /dev/null +++ b/desk/lib/sortug.hoon @@ -0,0 +1 @@ +/home/y/code/urbit/sortug/lib/sortug.hoon
\ No newline at end of file diff --git a/desk/lib/strand.hoon b/desk/lib/strand.hoon new file mode 100644 index 0000000..b0db35b --- /dev/null +++ b/desk/lib/strand.hoon @@ -0,0 +1 @@ +rand diff --git a/desk/lib/strandio.hoon b/desk/lib/strandio.hoon new file mode 100644 index 0000000..48f6e0d --- /dev/null +++ b/desk/lib/strandio.hoon @@ -0,0 +1,965 @@ +/- spider +/+ libstrand=strand +=, strand=strand:libstrand +=, strand-fail=strand-fail:libstrand +|% +++ send-raw-cards + |= cards=(list =card:agent:gall) + =/ m (strand ,~) + ^- form:m + |= strand-input:strand + [cards %done ~] +:: +++ send-raw-card + |= =card:agent:gall + =/ m (strand ,~) + ^- form:m + (send-raw-cards card ~) +:: +++ ignore + |= tin=strand-input:strand + `[%fail %ignore ~] +:: +++ get-bowl + =/ m (strand ,bowl:strand) + ^- form:m + |= tin=strand-input:strand + `[%done bowl.tin] +:: +++ get-beak + =/ m (strand ,beak) + ^- form:m + |= tin=strand-input:strand + `[%done [our q.byk da+now]:bowl.tin] +:: +++ get-time + =/ m (strand ,@da) + ^- form:m + |= tin=strand-input:strand + `[%done now.bowl.tin] +:: +++ get-our + =/ m (strand ,ship) + ^- form:m + |= tin=strand-input:strand + `[%done our.bowl.tin] +:: +++ get-entropy + =/ m (strand ,@uvJ) + ^- form:m + |= tin=strand-input:strand + `[%done eny.bowl.tin] +:: +:: Convert skips to %ignore failures. +:: +:: This tells the main loop to try the next handler. +:: +++ handle + |* a=mold + =/ m (strand ,a) + |= =form:m + ^- form:m + |= tin=strand-input:strand + =/ res (form tin) + =? next.res ?=(%skip -.next.res) + [%fail %ignore ~] + res +:: +:: Wait for a poke with a particular mark +:: +++ take-poke + |= =mark + =/ m (strand ,vase) + ^- form:m + |= tin=strand-input:strand + ?+ in.tin `[%skip ~] + ~ + `[%wait ~] + :: + [~ %poke @ *] + ?. =(mark p.cage.u.in.tin) + `[%skip ~] + `[%done q.cage.u.in.tin] + == +:: +++ take-sign-arvo + =/ m (strand ,[wire sign-arvo]) + ^- form:m + |= tin=strand-input:strand + ?+ in.tin `[%skip ~] + ~ + `[%wait ~] + :: + [~ %sign *] + `[%done [wire sign-arvo]:u.in.tin] + == +:: +:: Wait for a subscription update on a wire +:: +++ take-fact-prefix + |= =wire + =/ m (strand ,[path cage]) + ^- form:m + |= tin=strand-input:strand + ?+ in.tin `[%skip ~] + ~ `[%wait ~] + [~ %agent * %fact *] + ?. =(watch+wire (scag +((lent wire)) wire.u.in.tin)) + `[%skip ~] + `[%done (slag (lent wire) wire.u.in.tin) cage.sign.u.in.tin] + == +:: +:: Wait for a subscription update on a wire +:: +++ take-fact + |= =wire + =/ m (strand ,cage) + ^- form:m + |= tin=strand-input:strand + ?+ in.tin `[%skip ~] + ~ `[%wait ~] + [~ %agent * %fact *] + ?. =(watch+wire wire.u.in.tin) + `[%skip ~] + `[%done cage.sign.u.in.tin] + == +:: +:: Wait for a subscription close +:: +++ take-kick + |= =wire + =/ m (strand ,~) + ^- form:m + |= tin=strand-input:strand + ?+ in.tin `[%skip ~] + ~ `[%wait ~] + [~ %agent * %kick *] + ?. =(watch+wire wire.u.in.tin) + `[%skip ~] + `[%done ~] + == +:: +++ echo + =/ m (strand ,~) + ^- form:m + %- (main-loop ,~) + :~ |= ~ + ^- form:m + ;< =vase bind:m ((handle ,vase) (take-poke %echo)) + =/ message=tape !<(tape vase) + %- (slog leaf+"{message}..." ~) + ;< ~ bind:m (sleep ~s2) + %- (slog leaf+"{message}.." ~) + (pure:m ~) + :: + |= ~ + ^- form:m + ;< =vase bind:m ((handle ,vase) (take-poke %over)) + %- (slog leaf+"over..." ~) + (pure:m ~) + == +:: +++ take-watch + =/ m (strand ,path) + |= tin=strand-input:strand + ?+ in.tin `[%skip ~] + ~ `[%wait ~] + [~ %watch *] + `[%done path.u.in.tin] + == +:: +++ take-wake + |= until=(unit @da) + =/ m (strand ,~) + ^- form:m + |= tin=strand-input:strand + ?+ in.tin `[%skip ~] + ~ `[%wait ~] + [~ %sign [%wait @ ~] %behn %wake *] + ?. |(?=(~ until) =(`u.until (slaw %da i.t.wire.u.in.tin))) + `[%skip ~] + ?~ error.sign-arvo.u.in.tin + `[%done ~] + `[%fail %timer-error u.error.sign-arvo.u.in.tin] + == +:: +++ take-tune + |= =wire + =/ m (strand ,[spar:ames (unit roar:ames)]) + ^- form:m + |= tin=strand-input:strand + ?+ in.tin `[%skip ~] + ~ `[%wait ~] + :: + [~ %sign * %ames %tune ^ *] + ?. =(wire wire.u.in.tin) + `[%skip ~] + `[%done +>.sign-arvo.u.in.tin] + == +:: +++ take-whey + |= =wire + =/ m (strand ,[spar:ames fragment-size=@ud num-fragments=@ud]) + ^- form:m + |= tin=strand-input:strand + ?+ in.tin `[%skip ~] + ~ `[%wait ~] + :: + [~ %sign * %ames %sage sage=*] + ?. =(wire wire.u.in.tin) + `[%skip ~] + =/ =sage:mess:ames sage.sign-arvo.u.in.tin + :^ ~ %done spar=p.sage + ?~ q.sage + [boq=13 tot=0] + =< [boq tot] + ;;([%whey boq=@ud tot=@ud] q.sage) + == +:: +++ take-sage + |= =wire + =/ m (strand ,sage:mess:ames) + ^- form:m + |= tin=strand-input:strand + ?+ in.tin `[%skip ~] + ~ `[%wait ~] + :: + [~ %sign * %ames %sage sage=*] + ?. =(wire wire.u.in.tin) + `[%skip ~] + `[%done sage.sign-arvo.u.in.tin] + == +:: +++ take-message + => |% +$ out $% [%sage sage:mess:ames] + [%tune spar:ames (unit roar:ames)] + [%page spar:ames (unit (unit page))] + == + -- + |= =wire + =/ m (strand ,out) + ^- form:m + |= tin=strand-input:strand + ?+ in.tin `[%skip ~] + ~ `[%wait ~] + :: + [~ %sign * %ames %sage sage=*] + ?. =(wire wire.u.in.tin) + `[%skip ~] + `[%done %sage sage.sign-arvo.u.in.tin] + :: + [~ %sign * %ames %tune ^ *] + ?. =(wire wire.u.in.tin) + `[%skip ~] + `[%done %tune +>.sign-arvo.u.in.tin] + :: + [~ %sign * %ames %near ^ *] + ?. =(wire wire.u.in.tin) + `[%skip ~] + `[%done %page +>.sign-arvo.u.in.tin] + == +:: +++ take-near + |= =wire + =/ m (strand ,[spar:ames (unit (unit page))]) + ^- form:m + |= tin=strand-input:strand + ?+ in.tin `[%skip ~] + ~ `[%wait ~] + :: + [~ %sign * %ames %near ^ *] + ?. =(wire wire.u.in.tin) + `[%skip ~] + `[%done +>.sign-arvo.u.in.tin] + == +:: +++ take-poke-ack + |= =wire + =/ m (strand ,~) + ^- form:m + |= tin=strand-input:strand + ?+ in.tin `[%skip ~] + ~ `[%wait ~] + [~ %agent * %poke-ack *] + ?. =(wire wire.u.in.tin) + `[%skip ~] + ?~ p.sign.u.in.tin + `[%done ~] + `[%fail %poke-fail u.p.sign.u.in.tin] + == +:: +++ take-watch-ack + |= =wire + =/ m (strand ,~) + ^- form:m + |= tin=strand-input:strand + ?+ in.tin `[%skip ~] + ~ `[%wait ~] + [~ %agent * %watch-ack *] + ?. =(watch+wire wire.u.in.tin) + `[%skip ~] + ?~ p.sign.u.in.tin + `[%done ~] + `[%fail %watch-ack-fail u.p.sign.u.in.tin] + == +:: +++ poke + |= [=dock =cage] + =/ m (strand ,~) + ^- form:m + =/ =card:agent:gall [%pass /poke %agent dock %poke cage] + ;< ~ bind:m (send-raw-card card) + (take-poke-ack /poke) +:: +++ raw-poke + |= [=dock =cage] + =/ m (strand ,~) + ^- form:m + =/ =card:agent:gall [%pass /poke %agent dock %poke cage] + ;< ~ bind:m (send-raw-card card) + =/ m (strand ,~) + ^- form:m + |= tin=strand-input:strand + ?+ in.tin `[%skip ~] + ~ + `[%wait ~] + :: + [~ %agent * %poke-ack *] + ?. =(/poke wire.u.in.tin) + `[%skip ~] + `[%done ~] + == +:: +++ raw-poke-our + |= [app=term =cage] + =/ m (strand ,~) + ^- form:m + ;< =bowl:spider bind:m get-bowl + (raw-poke [our.bowl app] cage) +:: +++ poke-our + |= [=term =cage] + =/ m (strand ,~) + ^- form:m + ;< our=@p bind:m get-our + (poke [our term] cage) +:: +++ watch + |= [=wire =dock =path] + =/ m (strand ,~) + ^- form:m + =/ =card:agent:gall [%pass watch+wire %agent dock %watch path] + ;< ~ bind:m (send-raw-card card) + (take-watch-ack wire) +:: +++ watch-one + |= [=wire =dock =path] + =/ m (strand ,cage) + ^- form:m + ;< ~ bind:m (watch wire dock path) + ;< =cage bind:m (take-fact wire) + ;< ~ bind:m (take-kick wire) + (pure:m cage) +:: +++ watch-our + |= [=wire =term =path] + =/ m (strand ,~) + ^- form:m + ;< our=@p bind:m get-our + (watch wire [our term] path) +:: +++ scry + |* [=mold =path] + =/ m (strand ,mold) + ^- form:m + ?> ?=(^ path) + ?> ?=(^ t.path) + ;< =bowl:spider bind:m get-bowl + %- pure:m + .^(mold i.path (scot %p our.bowl) i.t.path (scot %da now.bowl) t.t.path) +:: +++ leave + |= [=wire =dock] + =/ m (strand ,~) + ^- form:m + =/ =card:agent:gall [%pass watch+wire %agent dock %leave ~] + (send-raw-card card) +:: +++ leave-our + |= [=wire =term] + =/ m (strand ,~) + ^- form:m + ;< our=@p bind:m get-our + (leave wire [our term]) +:: +++ rewatch + |= [=wire =dock =path] + =/ m (strand ,~) + ;< ~ bind:m ((handle ,~) (take-kick wire)) + ;< ~ bind:m (flog-text "rewatching {<dock>} {<path>}") + ;< ~ bind:m (watch wire dock path) + (pure:m ~) +:: +++ wait + |= until=@da + =/ m (strand ,~) + ^- form:m + ;< ~ bind:m (send-wait until) + (take-wake `until) +:: +++ mass + =/ m (strand ,(list quac:dill)) + ^- form:m + =/ =card:agent:gall [%pass /mass %arvo %d %mass ~] + ;< ~ bind:m (send-raw-card card) + ;< quz=(list quac:dill) bind:m take-meme + (pure:m quz) +:: +++ take-meme + =/ m (strand ,(list quac:dill)) + ^- form:m + |= tin=strand-input:strand + ?+ in.tin `[%skip ~] + ~ `[%wait ~] + [~ %sign [%mass ~] %dill %meme *] + `[%done p.sign-arvo.u.in.tin] + == +:: +++ keen + |= [=wire =spar:ames sec=(unit [@ @])] + =/ m (strand ,~) + ^- form:m + (send-raw-card %pass wire %arvo %a %keen sec spar) +:: +++ chum + |= [=wire =spar:ames] + =/ m (strand ,~) + ^- form:m + (send-raw-card %pass wire %arvo %a %chum spar) +:: +++ keen-shut + |= [=wire =spar:ames] + =/ m (strand ,~) + ^- form:m + (send-raw-card %pass wire %keen & spar) +:: +++ yawn + |= [=wire =spar:ames] + =/ m (strand ,~) + ^- form:m + (send-raw-card %pass wire %arvo %a %yawn spar) +:: +++ whey + |= [=wire boq=@ud =spar:ames] + =/ m (strand ,~) + ^- form:m + :: encrypted using %chum namespace + :: + ;< our=@p bind:m get-our + =. path.spar + [%a %x '1' %$ %whey (scot %ud boq) (scot %p our) path.spar] + (chum wire spar) +:: +++ meta + |= [=wire =spar:ames] + =/ m (strand ,~) + ^- form:m + ?+ path.spar !! + $% [%ames bone=@ ?(%clos %cork %next %last %curr) ~] + [%flow bone=@ =dire:ames ~] + [%flow bone=@ =dire:ames ?(%clos %cork %line %lods %next %last) ~] + :: XX rewrite in terms of %whey namespace + :: + [%flow bone=@ =dire:ames %whey boq=@ ~] + [%flow bone=@ =dire:ames seq=@ %naxp ~] + == + :: encrypted using %chum namespace + :: + ;< our=@p bind:m get-our + %- send-raw-card + :* %pass wire %arvo %a %chum + spar(path [%a %x '1' %$ %meta (scot %p our) path.spar]) + == + == +:: +++ sleep + |= for=@dr + =/ m (strand ,~) + ^- form:m + ;< now=@da bind:m get-time + (wait (add now for)) +:: +++ send-wait + |= until=@da + =/ m (strand ,~) + ^- form:m + =/ =card:agent:gall + [%pass /wait/(scot %da until) %arvo %b %wait until] + (send-raw-card card) +:: +++ map-err + |* computation-result=mold + =/ m (strand ,computation-result) + |= [f=$-([term tang] [term tang]) computation=form:m] + ^- form:m + |= tin=strand-input:strand + =* loop $ + =/ c-res (computation tin) + ?: ?=(%cont -.next.c-res) + c-res(self.next ..loop(computation self.next.c-res)) + ?. ?=(%fail -.next.c-res) + c-res + c-res(err.next (f err.next.c-res)) +:: +++ set-timeout + |* computation-result=mold + =/ m (strand ,computation-result) + |= [time=@dr computation=form:m] + ^- form:m + ;< now=@da bind:m get-time + =/ when (add now time) + =/ =card:agent:gall + [%pass /timeout/(scot %da when) %arvo %b %wait when] + ;< ~ bind:m (send-raw-card card) + |= tin=strand-input:strand + =* loop $ + ?: ?& ?=([~ %sign [%timeout @ ~] %behn %wake *] in.tin) + =((scot %da when) i.t.wire.u.in.tin) + == + `[%fail %timeout ~] + =/ c-res (computation tin) + ?: ?=(%cont -.next.c-res) + c-res(self.next ..loop(computation self.next.c-res)) + ?: ?=(%done -.next.c-res) + =/ =card:agent:gall + [%pass /timeout/(scot %da when) %arvo %b %rest when] + c-res(cards [card cards.c-res]) + c-res +:: +++ send-request + |= =request:http + =/ m (strand ,~) + ^- form:m + (send-raw-card %pass /request %arvo %i %request request *outbound-config:iris) +:: +++ send-cancel-request + =/ m (strand ,~) + ^- form:m + (send-raw-card %pass /request %arvo %i %cancel-request ~) +:: +++ take-client-response + =/ m (strand ,client-response:iris) + ^- form:m + |= tin=strand-input:strand + ?+ in.tin `[%skip ~] + ~ `[%wait ~] + :: + [~ %sign [%request ~] %iris %http-response %cancel *] + ::NOTE iris does not (yet?) retry after cancel, so it means failure + :- ~ + :+ %fail + %http-request-cancelled + ['http request was cancelled by the runtime']~ + :: + [~ %sign [%request ~] %iris %http-response %finished *] + `[%done client-response.sign-arvo.u.in.tin] + == +:: +:: Wait until we get an HTTP response or cancelation and unset contract +:: +++ take-maybe-sigh + =/ m (strand ,(unit httr:eyre)) + ^- form:m + ;< rep=(unit client-response:iris) bind:m + take-maybe-response + ?~ rep + (pure:m ~) + :: XX s/b impossible + :: + ?. ?=(%finished -.u.rep) + (pure:m ~) + (pure:m (some (to-httr:iris +.u.rep))) +:: +++ take-maybe-response + =/ m (strand ,(unit client-response:iris)) + ^- form:m + |= tin=strand-input:strand + ?+ in.tin `[%skip ~] + ~ `[%wait ~] + [~ %sign [%request ~] %iris %http-response %cancel *] + `[%done ~] + [~ %sign [%request ~] %iris %http-response %finished *] + `[%done `client-response.sign-arvo.u.in.tin] + == +:: +++ extract-body + |= =client-response:iris + =/ m (strand ,cord) + ^- form:m + ?> ?=(%finished -.client-response) + %- pure:m + ?~ full-file.client-response '' + q.data.u.full-file.client-response +:: +++ fetch-cord + |= url=tape + =/ m (strand ,cord) + ^- form:m + =/ =request:http [%'GET' (crip url) ~ ~] + ;< ~ bind:m (send-request request) + ;< =client-response:iris bind:m take-client-response + (extract-body client-response) +:: +++ fetch-json + |= url=tape + =/ m (strand ,json) + ^- form:m + ;< =cord bind:m (fetch-cord url) + =/ json=(unit json) (de:json:html cord) + ?~ json + (strand-fail %json-parse-error ~) + (pure:m u.json) +:: +++ hiss-request + |= =hiss:eyre + =/ m (strand ,(unit httr:eyre)) + ^- form:m + ;< ~ bind:m (send-request (hiss-to-request:html hiss)) + take-maybe-sigh +:: +:: +build-file: build the source file at the specified $beam +:: +++ build-file + |= [[=ship =desk =case] =spur] + =* arg +< + =/ m (strand ,(unit vase)) + ^- form:m + ;< =riot:clay bind:m + (warp ship desk ~ %sing %a case spur) + ?~ riot + (pure:m ~) + ?> =(%vase p.r.u.riot) + (pure:m (some !<(vase q.r.u.riot))) +:: +++ build-file-hard + |= [[=ship =desk =case] =spur] + =* arg +< + =/ m (strand ,vase) + ^- form:m + ;< =riot:clay + bind:m + (warp ship desk ~ %sing %a case spur) + ?> ?=(^ riot) + ?> ?=(%vase p.r.u.riot) + (pure:m !<(vase q.r.u.riot)) +:: +build-mark: build a mark definition to a $dais +:: +++ build-mark + |= [[=ship =desk =case] mak=mark] + =* arg +< + =/ m (strand ,dais:clay) + ^- form:m + ;< =riot:clay bind:m + (warp ship desk ~ %sing %b case /[mak]) + ?~ riot + (strand-fail %build-mark >arg< ~) + ?> =(%dais p.r.u.riot) + (pure:m !<(dais:clay q.r.u.riot)) +:: +build-tube: build a mark conversion gate ($tube) +:: +++ build-tube + |= [[=ship =desk =case] =mars:clay] + =* arg +< + =/ m (strand ,tube:clay) + ^- form:m + ;< =riot:clay bind:m + (warp ship desk ~ %sing %c case /[a.mars]/[b.mars]) + ?~ riot + (strand-fail %build-tube >arg< ~) + ?> =(%tube p.r.u.riot) + (pure:m !<(tube:clay q.r.u.riot)) +:: +:: +build-nave: build a mark definition to a $nave +:: +++ build-nave + |= [[=ship =desk =case] mak=mark] + =* arg +< + =/ m (strand ,vase) + ^- form:m + ;< =riot:clay bind:m + (warp ship desk ~ %sing %e case /[mak]) + ?~ riot + (strand-fail %build-nave >arg< ~) + ?> =(%nave p.r.u.riot) + (pure:m q.r.u.riot) +:: +build-cast: build a mark conversion gate (static) +:: +++ build-cast + |= [[=ship =desk =case] =mars:clay] + =* arg +< + =/ m (strand ,vase) + ^- form:m + ;< =riot:clay bind:m + (warp ship desk ~ %sing %f case /[a.mars]/[b.mars]) + ?~ riot + (strand-fail %build-cast >arg< ~) + ?> =(%cast p.r.u.riot) + (pure:m q.r.u.riot) +:: +:: Read from Clay +:: +++ warp + |= [=ship =riff:clay] + =/ m (strand ,riot:clay) + ;< ~ bind:m (send-raw-card %pass /warp %arvo %c %warp ship riff) + (take-writ /warp) +:: +++ read-file + |= [[=ship =desk =case] =spur] + =* arg +< + =/ m (strand ,cage) + ;< =riot:clay bind:m (warp ship desk ~ %sing %x case spur) + ?~ riot + (strand-fail %read-file >arg< ~) + (pure:m r.u.riot) +:: +++ check-for-file + |= [[=ship =desk =case] =spur] + =/ m (strand ,?) + ;< =riot:clay bind:m (warp ship desk ~ %sing %u case spur) + ?> ?=(^ riot) + (pure:m !<(? q.r.u.riot)) +:: +++ list-tree + |= [[=ship =desk =case] =spur] + =* arg +< + =/ m (strand ,(list path)) + ;< =riot:clay bind:m (warp ship desk ~ %sing %t case spur) + ?~ riot + (strand-fail %list-tree >arg< ~) + (pure:m !<((list path) q.r.u.riot)) +:: +++ list-desk + |= [[=ship =desk =case] =spur] + =* arg +< + =/ m (strand arch) + ;< =riot:clay bind:m (warp ship desk ~ %sing %y case spur) + ?~ riot + (strand-fail %list-desk >arg< ~) + (pure:m !<(arch q.r.u.riot)) +:: Take Clay read result +:: +++ take-writ + |= =wire + =/ m (strand ,riot:clay) + ^- form:m + |= tin=strand-input:strand + ?+ in.tin `[%skip ~] + ~ `[%wait ~] + [~ %sign * ?(%behn %clay) %writ *] + ?. =(wire wire.u.in.tin) + `[%skip ~] + `[%done +>.sign-arvo.u.in.tin] + == +:: +check-online: require that peer respond before timeout +:: +++ check-online + |= [who=ship lag=@dr] + =/ m (strand ,~) + ^- form:m + %+ (map-err ,~) |=(* [%offline *tang]) + %+ (set-timeout ,~) lag + ;< ~ bind:m + (poke [who %hood] %helm-hi !>(~)) + (pure:m ~) +:: +++ eval-hoon + |= [gen=hoon bez=(list beam)] + =/ m (strand ,vase) + ^- form:m + =/ sut=vase !>(..zuse) + |- + ?~ bez + (pure:m (slap sut gen)) + ;< vax=vase bind:m (build-file-hard i.bez) + $(bez t.bez, sut (slop vax sut)) +:: +++ send-thread + |= [=bear:khan =shed:khan =wire] + =/ m (strand ,~) + ^- form:m + (send-raw-card %pass wire %arvo %k %lard bear shed) +:: +:: Queue on skip, try next on fail %ignore +:: +++ main-loop + |* a=mold + =/ m (strand ,~) + =/ m-a (strand ,a) + =| queue=(qeu (unit input:strand)) + =| active=(unit [in=(unit input:strand) =form:m-a forms=(list $-(a form:m-a))]) + =| state=a + |= forms=(lest $-(a form:m-a)) + ^- form:m + |= tin=strand-input:strand + =* top `form:m`..$ + =. queue (~(put to queue) in.tin) + |^ (continue bowl.tin) + :: + ++ continue + |= =bowl:strand + ^- output:m + ?> =(~ active) + ?: =(~ queue) + `[%cont top] + =^ in=(unit input:strand) queue ~(get to queue) + ^- output:m + =. active `[in (i.forms state) t.forms] + ^- output:m + (run bowl in) + :: + ++ run + ^- form:m + |= tin=strand-input:strand + ^- output:m + ?> ?=(^ active) + =/ res (form.u.active tin) + =/ =output:m + ?- -.next.res + %wait `[%wait ~] + %skip `[%cont ..$(queue (~(put to queue) in.tin))] + %cont `[%cont ..$(active `[in.u.active self.next.res forms.u.active])] + %done (continue(active ~, state value.next.res) bowl.tin) + %fail + ?: &(?=(^ forms.u.active) ?=(%ignore p.err.next.res)) + %= $ + active `[in.u.active (i.forms.u.active state) t.forms.u.active] + in.tin in.u.active + == + `[%fail err.next.res] + == + [(weld cards.res cards.output) next.output] + -- +:: +++ retry + |* result=mold + |= [crash-after=(unit @ud) computation=_*form:(strand (unit result))] + =/ m (strand ,result) + =| try=@ud + |- ^- form:m + =* loop $ + ?: =(crash-after `try) + (strand-fail %retry-too-many ~) + ;< ~ bind:m (backoff try ~m1) + ;< res=(unit result) bind:m computation + ?^ res + (pure:m u.res) + loop(try +(try)) +:: +++ backoff + |= [try=@ud limit=@dr] + =/ m (strand ,~) + ^- form:m + ;< eny=@uvJ bind:m get-entropy + %- sleep + %+ min limit + ?: =(0 try) ~s0 + %+ add + (mul ~s1 (bex (dec try))) + (mul ~s0..0001 (~(rad og eny) 1.000)) +:: +:: ---- +:: +:: Output +:: +++ flog + |= =flog:dill + =/ m (strand ,~) + ^- form:m + (send-raw-card %pass / %arvo %d %flog flog) +:: +++ flog-text + |= =tape + =/ m (strand ,~) + ^- form:m + (flog %text tape) +:: +++ flog-tang + |= =tang + =/ m (strand ,~) + ^- form:m + =/ =wall + (zing (turn (flop tang) (cury wash [0 80]))) + |- ^- form:m + =* loop $ + ?~ wall + (pure:m ~) + ;< ~ bind:m (flog-text i.wall) + loop(wall t.wall) +:: +++ trace + |= =tang + =/ m (strand ,~) + ^- form:m + (pure:m ((slog tang) ~)) +:: +++ app-message + |= [app=term =cord =tang] + =/ m (strand ,~) + ^- form:m + =/ msg=tape :(weld (trip app) ": " (trip cord)) + ;< ~ bind:m (flog-text msg) + (flog-tang tang) +:: +:: ---- +:: +:: Handle domains +:: +++ install-domain + |= =turf + =/ m (strand ,~) + ^- form:m + (send-raw-card %pass / %arvo %e %rule %turf %put turf) +:: +:: ---- +:: +:: Threads +:: +++ start-thread + |= file=term + =/ m (strand ,tid:spider) + ;< =bowl:spider bind:m get-bowl + (start-thread-with-args byk.bowl file *vase) +:: +++ start-thread-with-args + |= [=beak file=term args=vase] + =/ m (strand ,tid:spider) + ^- form:m + ;< =bowl:spider bind:m get-bowl + =/ tid + (scot %ta (cat 3 (cat 3 'strand_' file) (scot %uv (sham file eny.bowl)))) + =/ poke-vase !>(`start-args:spider`[`tid.bowl `tid beak file args]) + ;< ~ bind:m (poke-our %spider %spider-start poke-vase) + ;< ~ bind:m (sleep ~s0) :: wait for thread to start + (pure:m tid) +:: ++$ thread-result + (each vase [term tang]) +:: +++ await-thread + |= [file=term args=vase] + =/ m (strand ,thread-result) + ^- form:m + ;< =bowl:spider bind:m get-bowl + =/ tid (scot %ta (cat 3 'strand_' (scot %uv (sham file eny.bowl)))) + =/ poke-vase !>(`start-args:spider`[`tid.bowl `tid byk.bowl file args]) + ;< ~ bind:m (watch-our /awaiting/[tid] %spider /thread-result/[tid]) + ;< ~ bind:m (poke-our %spider %spider-start poke-vase) + ;< ~ bind:m (sleep ~s0) :: wait for thread to start + ;< =cage bind:m (take-fact /awaiting/[tid]) + ;< ~ bind:m (take-kick /awaiting/[tid]) + ?+ p.cage ~|([%strange-thread-result p.cage file tid] !!) + %thread-done (pure:m %& q.cage) + %thread-fail (pure:m %| !<([term tang] q.cage)) + == +-- |