ilyakooo0/urbit
1
0
Fork 0
mirror of https://github.com/ilyakooo0/urbit.git synced 2025-01-07 07:30:23 +03:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'rc' (#1996)

Browse Source 
* rc: (451 commits)
  ping: delay kick until after ames processes breach
  aqua: make faster so moon-az can finish
  ping: fix comments
  ping: avoid fragile state transitions
  ames: don't say not responding if we haven't been talking
  eth-watcher; don't start timer if already started
  chat: hotfixing a class name
  chat: fix sidebar toggle on chat update
  dojo: set prompt on watch
  gen: add comments on new generators
  chat-cli: our-self with bowl set
  keys: add +keys for diagnostics
  verb: add +verb %bowl to print bowl on every event
  azimuth-tracker: add |kick
  clay: don't make |cancel require argument
  jael: allowed skipped rifts
  ames: make life printf helpful
  Revert "|ames-verb: fix generator sample type"
  |ames-verb: fix generator sample type
  gall: correctly construct wire for ap-specific-take
  ...

Signed-off-by: Jared Tobin <jared@tlon.io>
This commit is contained in:
Jared Tobin 2019-12-04 18:50:26 +08:00
commit c2f4926cb4
No known key found for this signature in database
GPG Key ID: 0E4647D58F8A69E4
237 changed files with 16816 additions and 19973 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
bin/brass.pill
View File

@ -1,3 +1,3 @@
version https://git-lfs.github.com/spec/v1
oid sha256:1fcda8a239d9b2128901e952ca30c17a016323ffdd855c97670ac65d47ae4006
size 6686327
oid sha256:9a43b1d307aa13e04be838bcda121ee6fdce505eaf9eac0809e089e4f1d6062b
size 6836920

4
bin/ivory.pill
View File

@ -1,3 +1,3 @@
version https://git-lfs.github.com/spec/v1
oid sha256:288a89d1ac85d6a55fe34fc862fbf2358a43781de3f187bcf2e5654cdbb822b0
size 1202044
oid sha256:cc9d089fb46a2931654acbe3d663fdf7be18d8df626a01d9c38f69f9df246bf0
size 1831462

4
bin/solid.pill
View File

@ -1,3 +1,3 @@
version https://git-lfs.github.com/spec/v1
oid sha256:d0d7e3807c3159b1483220caf14fc2b96af65c05f2f761c4351c8614dc7db3cf
size 9634290
oid sha256:0dbf22758965dd37bb09d34789540ad32ed9848092e85b5185edf68c7ac27a20
size 9485905

4
nix/ops/test/builder.sh
View File

@ -43,6 +43,10 @@ herb ./ship -d '+test, =seed `@uvI`(shaz %reproducible)' |
herb ./ship -p hood -d '+hood/mass'
herb ./ship -d '~& ~ ~& %start-pack ~'
herb ./ship -p hood -d '+hood/pack'
herb ./ship -d '~& ~ ~& %finish-pack ~'
shutdown
# Collect output

2
nix/pkgs/arvo-ropsten/builder.sh
View File

@ -14,7 +14,7 @@ sed --in-place \
# increment the %ames protocol version
sed -r --in-place \
's/^(=\+ protocol\-version=)([0-9])/echo "\1$(echo "(\2+1) % 8" | bc)"/e' \
's_^(=/ protocol\-version=\?\(.*\) %)([0-7])_echo "\1$(echo "(\2+1) % 8" | bc)"_e' \
$AMES
# use the staging API in :acme

186
pkg/arvo/app/acme.hoon
View File

@ -1,5 +1,5 @@
/- asn1, hall
/+ base64, der, primitive-rsa, *pkcs, *jose
/+ base64, der, primitive-rsa, *pkcs, *jose, default-agent, verb
=, eyre
=* rsa primitive-rsa
::
@ -141,25 +141,9 @@
:::: acme state
::
|%
:: +move: output effect
::
+$ move [bone card]
:: +card: output effect payload
::
+$ card
$% [%serve wire =binding:eyre =generator:eyre]
[%http-response =http-event:http]
[%poke wire dock poke]
[%request wire request:http outbound-config:iris]
[%rule wire %cert (unit [wain wain])]
[%wait wire @da]
[%flog wire flog:dill]
==
:: +poke: outgoing app pokes
::
+$ poke
$% [%hall-action %phrase audience:hall (list speech:hall)]
==
+$ card card:agent:gall
:: +nonce-next: next effect to emit upon receiving nonce
::
+$ nonce-next
@ -338,6 +322,69 @@
challenges=(set @t)
==
--
=| acme
=* state -
=<
%+ verb |
|_ =bowl:gall
+* this .
acme-core +>
ac ~(. acme-core bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init
=/ =binding:eyre
[~ /'.well-known'/acme-challenge]
=/ =generator:eyre
[q.byk.bowl /gen/acme/domain-validation/hoon ~]
=/ =card
[%pass /acme %arvo %e %serve binding generator]
[[card ~] this]
::
++ on-save !>(state)
++ on-load |=(old=vase `this(state !<(acme old)))
++ on-poke
|= [=mark =vase]
^- (quip card _this)
=^ cards state
?+ mark (on-poke:def mark vase)
%acme-order (poke-acme-order:ac !<((set turf) vase))
%noun (poke-noun:ac !<(* vase))
%path (poke-path:ac !<(path vase))
==
[cards this]
::
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-peek
|= =path
^- (unit (unit [%noun vase]))
?+ path ~
[%x %domain-validation @t ~]
=* token i.t.t.path
:^ ~ ~ %noun !>
?. (~(has in challenges) token)
~
(some (rap 3 [token '.' (pass:thumb:jwk key.act) ~]))
==
::
++ on-agent on-agent:def
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card _this)
=^ cards state
?+ wire (on-arvo:def wire sign-arvo)
[%acme *]
?+ +<.sign-arvo (on-arvo:def wire sign-arvo)
%http-response (http-response:ac wire +>.sign-arvo)
%wake (wake:ac wire +>.sign-arvo)
%bound (bound:ac wire +>.sign-arvo)
==
==
[cards this]
::
++ on-fail on-fail:def
--
::
:::: acme app
::
@ -346,35 +393,33 @@
=/ directory-base=purl
=- (need (de-purl:html -))
'https://acme-v02.api.letsencrypt.org/directory'
:: mov: list of outgoing moves for the current transaction
:: cards: list of outgoing moves for the current transaction
::
=| mov=(list move)
=| cards=(list card)
::
|_ [bow=bowl:gall acme]
|_ bow=bowl:gall
:: +this: self
::
:: XX Should be a +* core alias, see urbit/arvo#712
::
++ this .
:: +emit: emit a move
:: +emit: emit a card
::
++ emit
|= car=card
this(mov [[ost.bow car] mov])
:: +emil: emit a list of moves
this(cards [car cards])
:: +emil: emit a list of cards
::
++ emil
|= rac=(list card)
|- ^+ this
?~ rac
this
=. mov [[ost.bow i.rac] mov]
=. cards [i.rac cards]
$(rac t.rac)
:: +abet: finalize transaction
::
++ abet
^- (quip move _this)
[(flop mov) this(mov ~)]
^- (quip card _state)
[(flop cards) state]
:: +backoff: calculate exponential backoff
::
++ backoff
@ -395,30 +440,16 @@
++ notify
|= [=cord =tang]
^- (list card)
:- [%flog / %text :(weld (trip dap.bow) ": " (trip cord))]
:- [%pass / %arvo %d %flog %text :(weld (trip dap.bow) ": " (trip cord))]
%+ turn
`wall`(zing (turn (flop tang) (cury wash [0 80])))
|=(=tape [%flog / %text tape])
:: +notify: send :hall notification
::
:: XX disabled due to :hall status
::
++ notify-disabled
|= [=cord =tang]
^- card
=/ msg=speech:hall
:+ %app dap.bow
=/ line [%lin & cord]
?~(tang line [%fat [%tank tang] line])
=/ act
[%phrase (sy [our.bow %inbox] ~) [msg ~]]
[%poke / [our.bow %hall] %hall-action act]
|=(=tape [%pass / %arvo %d %flog %text tape])
:: +request: unauthenticated http request
::
++ request
|= [wir=wire req=hiss]
^- card
[%request wir (hiss-to-request:html req) *outbound-config:iris]
[%pass wir %arvo %i %request (hiss-to-request:html req) *outbound-config:iris]
:: +signed-request: JWS JSON POST
::
++ signed-request
@ -481,7 +512,7 @@
:: too many certificates for these domains
::
?: ?=(^ (find "already issued for exact" detail))
=. ..this (retry:effect try act spur ~d7)
=. ..emit (retry:effect try act spur ~d7)
=/ msg=cord
%+ rap 3
:~ 'rate limit exceeded: '
@ -497,7 +528,7 @@
:: too many certificates for top-level-domain
::
?: ?=(^ (find "too many certificates already" detail))
=. ..this (retry:effect try act spur ~d7)
=. ..emit (retry:effect try act spur ~d7)
=/ lul=@dr
(add ~d7 (mul ~m1 (~(rad og eny.bow) (bex 10))))
=/ msg=cord
@ -637,11 +668,11 @@
::
=/ msg=cord
(cat 3 'retrying certificate request in ' (scot %dr lul))
=. ..this (emil (notify msg ~))
=. ..this (retry:effect try %new-order / lul)
=. ..emit (emil (notify msg ~))
=. ..emit (retry:effect try %new-order / lul)
:: domains might already be validated
::
=. ..this (queue-next-order +(try.order) & dom.order)
=. ..emit (queue-next-order +(try.order) & dom.order)
cancel-current-order
:: +finalize-order: finalize completed order
::
@ -693,7 +724,7 @@
~| %install-effect-fail
?> ?=(^ liv)
=/ key=wain (ring:en:pem:pkcs8 key.u.liv)
(emit %rule /install %cert `[key `wain`cer.u.liv])
(emit %pass /install %arvo %e %rule %cert `[key `wain`cer.u.liv])
:: +get-authz: get next ACME service domain authorization object
::
++ get-authz
@ -757,7 +788,7 @@
|= [try=@ud act=@tas =wire lull=@dr]
:: XX validate wire
::
(emit %wait (acme-wire +(try) act wire) (add now.bow lull))
(emit %pass (acme-wire +(try) act wire) %arvo %b %wait (add now.bow lull))
--
:: |event: accept event, emit next effect(s)
::
@ -1167,11 +1198,11 @@
--
++ http-response
|= [=wire response=client-response:iris]
^- (quip move _this)
^- (quip card _state)
:: ignore progress reports
::
?: ?=(%progress -.response)
[~ this]
[~ state]
::
?> ?=([%acme ^] wire)
=< abet
@ -1223,26 +1254,11 @@
:: XX delete-trial?
::
==
:: +peek: read from app state
::
++ peek
|= =path
^- (unit (unit [%noun (unit @t)]))
?+ path
~
::
[%x %domain-validation @t ~]
=* token i.t.t.path
:^ ~ ~ %noun
?. (~(has in challenges) token)
~
(some (rap 3 [token '.' (pass:thumb:jwk key.act) ~]))
==
:: +wake: timer wakeup event
::
++ wake
|= [wir=wire error=(unit tang)]
^- (quip move _this)
^- (quip card _state)
?^ error
%- (slog u.error)
abet
@ -1257,7 +1273,7 @@
::
++ poke-noun
|= a=*
^- (quip move _this)
^- (quip card _state)
=< abet
?+ a
this
@ -1291,7 +1307,7 @@
=/ bas=path /(scot %p our.bow)/home/(scot %da now.bow)/acme
=/ key=wain .^(wain %cx (weld bas /privkey/pem))
=/ cer=wain .^(wain %cx (weld bas /cert/pem))
(emit %rule /install %cert `[key cer])
(emit %pass /install %arvo %e %rule %cert `[key cer])
::
%init
init
@ -1309,30 +1325,16 @@
::
++ poke-path
|=(a=path abet:(add-order (sy a ~)))
:: +prep: initialize and adapt state
::
++ prep
|= old=(unit acme)
^- (quip move _this)
?~ old
=/ =binding:eyre
[~ /'.well-known'/acme-challenge]
=/ =generator:eyre
[q.byk.bow /gen/acme/domain-validation/hoon ~]
=/ =move
[ost.bow %serve /acme binding generator]
[[move ~] this]
[~ this(+<+ u.old)]
:: +bound: response to %serve binding request
::
++ bound
|= [=wire accepted=? =binding:eyre]
?: accepted
[~ this]
[~ state]
:: XX better error message
::
~& [%acme-http-path-binding-failed +<]
[~ this]
[~ state]
:: +rekey: create new 2.048 bit RSA key
::
:: XX do something about this iteration
@ -1394,11 +1396,11 @@
~|(%acme-empty-certificate-order !!)
?: ?=(?(%earl %pawn) (clan:title our.bow))
this
=. ..this (queue-next-order 1 | dom)
=. ..this cancel-current-order
=. ..emit (queue-next-order 1 | dom)
=. ..emit cancel-current-order
:: notify :hall
::
=. ..this
=. ..emit
=/ msg=cord
%+ rap 3
:~ 'requesting an https certificate for '

83
pkg/arvo/app/aqua-ames.hoon
View File

@ -1,83 +0,0 @@
:: This needs a better SDN solution. Every ship should have an IP
:: address, and we should eventually test changing those IP
:: addresses.
::
:: For now, we broadcast every packet to every ship and rely on them
:: to drop them.
::
/- aquarium
=, aquarium
=> |%
+$ move (pair bone card)
+$ card
$% [%poke wire dock %aqua-events (list aqua-event)]
[%peer wire dock path]
[%pull wire dock ~]
==
::
+$ state
$: %0
subscribed=_|
==
--
=, gall
=| moves=(list move)
=| aqua-event-list=(list aqua-event)
=| ships=(list ship)
|_ $: bowl
state
==
++ this .
++ apex %_(this moves ~, aqua-event-list ~, ships ~)
++ abet
=? this !=(~ aqua-event-list)
%- emit-moves
[ost %poke /aqua-events [our %aqua] %aqua-events aqua-event-list]~
:: ~? !?=(~ moves) [%aqua-ames-moves (lent moves)]
[moves this]
::
++ emit-moves
|= ms=(list move)
%_(this moves (weld moves ms))
::
++ emit-aqua-events
|= aes=(list aqua-event)
%_(this aqua-event-list (weld aqua-event-list aes))
::
++ poke-aqua-vane-control
|= command=?(%subscribe %unsubscribe)
:_ this(subscribed =(command %subscribe))
(aqua-vane-control-handler our ost subscribed command)
::
:: Handle effects from ships. We only react to %send effects.
::
++ diff-aqua-effects
|= [way=wire afs=aqua-effects]
^- (quip move _this)
=. this apex =< abet
|- ^+ this
?~ ufs.afs
this
=. this
?+ -.q.i.ufs.afs this
%restore (handle-restore who.afs)
%send (handle-send i.ufs.afs)
==
$(ufs.afs t.ufs.afs)
::
++ handle-restore
|= who=@p
%- emit-aqua-events
[%event who [//newt/0v1n.2m9vh %barn ~]]~
::
++ handle-send
|= [way=wire %send lan=lane:ames pac=@]
^+ this
=/ hear [//newt/0v1n.2m9vh %hear lan pac]
=? ships =(~ ships)
.^((list ship) %gx /(scot %p our)/aqua/(scot %da now)/ships/noun)
%- emit-aqua-events
%+ turn ships
|= who=ship
[%event who hear]
--

131
pkg/arvo/app/aqua-behn.hoon
View File

@ -1,131 +0,0 @@
/- aquarium
=, aquarium
=> |%
+$ move (pair bone card)
+$ card
$% [%poke wire dock %aqua-events (list aqua-event)]
[%peer wire dock path]
[%pull wire dock ~]
[%wait wire p=@da]
[%rest wire p=@da]
==
::
+$ state
$: %0
subscribed=_|
piers=(map ship pier)
==
::
+$ pier next-timer=(unit @da)
--
=, gall
=| moves=(list move)
|_ $: bowl
state
==
++ this .
++ apex %_(this moves ~)
++ abet [(flop moves) this]
++ emit-moves
|= ms=(list move)
%_(this moves (weld ms moves))
::
++ emit-aqua-events
|= aes=(list aqua-event)
%- emit-moves
[ost %poke /aqua-events [our %aqua] %aqua-events aes]~
::
++ poke-aqua-vane-control
|= command=?(%subscribe %unsubscribe)
:_ this(subscribed =(command %subscribe))
(aqua-vane-control-handler our ost subscribed command)
::
++ diff-aqua-effects
|= [way=wire afs=aqua-effects]
^- (quip move _this)
=. this apex =< abet
|- ^+ this
?~ ufs.afs
this
=. this
?+ -.q.i.ufs.afs this
%sleep abet-pe:handle-sleep:(pe who.afs)
%restore abet-pe:handle-restore:(pe who.afs)
%doze abet-pe:(handle-doze:(pe who.afs) i.ufs.afs)
==
$(ufs.afs t.ufs.afs)
::
:: Received timer wake
::
++ wake
|= [way=wire error=(unit tang)]
^- (quip move _this)
=. this apex =< abet
?> ?=([@ *] way)
=/ who (,@p (slav %p i.way))
abet-pe:(take-wake:(pe who) t.way error)
::
++ pe
|= who=ship
=+ (~(gut by piers) who *pier)
=* pier-data -
|%
++ abet-pe
^+ this
=. piers (~(put by piers) who pier-data)
this
::
++ handle-sleep
^+ ..abet-pe
=< ..abet-pe(pier-data *pier)
?~ next-timer
..abet-pe
cancel-timer
::
++ handle-restore
^+ ..abet-pe
=. this
%- emit-aqua-events
[%event who [//behn/0v1n.2m9vh %born ~]]~
..abet-pe
::
++ handle-doze
|= [way=wire %doze tim=(unit @da)]
^+ ..abet-pe
?~ tim
?~ next-timer
..abet-pe
cancel-timer
?~ next-timer
(set-timer u.tim)
(set-timer:cancel-timer u.tim)
::
++ set-timer
|= tim=@da
~? debug=| [who=who %setting-timer tim]
=. next-timer `tim
=. this (emit-moves [ost %wait /(scot %p who) tim]~)
..abet-pe
::
++ cancel-timer
~? debug=| [who=who %cancell-timer (need next-timer)]
=. this (emit-moves [ost %rest /(scot %p who) (need next-timer)]~)
=. next-timer ~
..abet-pe
::
++ take-wake
|= [way=wire error=(unit tang)]
~? debug=| [who=who %aqua-behn-wake now error=error]
=. next-timer ~
=. this
%- emit-aqua-events
:_ ~
^- aqua-event
:+ %event who
:- //behn/0v1n.2m9vh
?~ error
[%wake ~]
[%crud %fail u.error]
..abet-pe
--
--

78
pkg/arvo/app/aqua-dill.hoon
View File

@ -1,78 +0,0 @@
:: Would love to see a proper stateful terminal handler. Ideally,
:: you'd be able to ^X into the virtual ship, like the old ^W.
::
:: However, that's probably not the primary way of interacting with
:: it. In practice, most of the time you'll be running from a file
:: (eg for automated testing) or fanning the same command to multiple
:: ships or otherwise making use of the fact that we can
:: programmatically send events.
::
/- aquarium
=, aquarium
=> |%
+$ move (pair bone card)
+$ card
$% [%poke wire dock %aqua-events (list aqua-event)]
[%peer wire dock path]
[%pull wire dock ~]
==
::
+$ state
$: %0
subscribed=_|
==
--
=, gall
=| moves=(list move)
|_ $: bowl
state
==
++ this .
++ apex %_(this moves ~)
++ abet [(flop moves) this]
++ emit-moves
|= ms=(list move)
%_(this moves (weld ms moves))
::
++ emit-aqua-events
|= aes=(list aqua-event)
%- emit-moves
[ost %poke /aqua-events [our %aqua] %aqua-events aes]~
::
++ poke-aqua-vane-control
|= command=?(%subscribe %unsubscribe)
:_ this(subscribed =(command %subscribe))
(aqua-vane-control-handler our ost subscribed command)
::
++ diff-aqua-effects
|= [way=wire afs=aqua-effects]
^- (quip move _this)
=. this apex =< abet
|- ^+ this
?~ ufs.afs
this
=. this
?+ -.q.i.ufs.afs this
%blit (handle-blit who.afs i.ufs.afs)
==
$(ufs.afs t.ufs.afs)
::
++ handle-blit
|= [who=@p way=wire %blit blits=(list blit:dill)]
^+ this
=/ last-line
%+ roll blits
|= [b=blit:dill line=tape]
?- -.b
%lin (tape p.b)
%mor ~& "{<who>}: {line}" ""
%hop line
%bel line
%clr ""
%sag ~& [%save-jamfile-to p.b] line
%sav ~& [%save-file-to p.b] line
%url ~& [%activate-url p.b] line
==
~? !=(~ last-line) last-line
this
--

157
pkg/arvo/app/aqua-eyre.hoon
View File

@ -1,157 +0,0 @@
:: Pass-through Eyre driver
::
/- aquarium
=, aquarium
=> |%
+$ move (pair bone card)
+$ card
$% [%poke wire dock %aqua-events (list aqua-event)]
[%peer wire dock path]
[%pull wire dock ~]
[%hiss wire p=(unit user:eyre) q=mark r=(cask hiss:eyre)]
==
::
+$ state
$: %0
subscribed=_|
piers=(map ship pier)
==
::
+$ pier http-requests=(set @ud)
--
=, gall
=| moves=(list move)
|_ $: bowl
state
==
++ this .
++ apex %_(this moves ~)
++ abet [(flop moves) this]
++ emit-moves
|= ms=(list move)
%_(this moves (weld ms moves))
::
++ emit-aqua-events
|= aes=(list aqua-event)
%- emit-moves
[ost %poke /aqua-events [our %aqua] %aqua-events aes]~
::
++ poke-aqua-vane-control
|= command=?(%subscribe %unsubscribe)
:_ this(subscribed =(command %subscribe))
(aqua-vane-control-handler our ost subscribed command)
::
++ diff-aqua-effects
|= [way=wire afs=aqua-effects]
^- (quip move _this)
=. this apex =< abet
|- ^+ this
?~ ufs.afs
this
=. this
?+ -.q.i.ufs.afs this
%sleep abet-pe:handle-sleep:(pe who.afs)
%restore abet-pe:handle-restore:(pe who.afs)
%thus abet-pe:(handle-thus:(pe who.afs) i.ufs.afs)
==
$(ufs.afs t.ufs.afs)
::
:: Received inbound HTTP response
::
++ sigh-httr
|= [way=wire res=httr:eyre]
^- (quip move _this)
=. this apex =< abet
?> ?=([@ *] way)
=/ who (,@p (slav %p i.way))
~& [%received-httr who]
abet-pe:(take-sigh-httr:(pe who) t.way res)
::
:: Received inbound HTTP response error
::
++ sigh-tang
|= [way=wire tan=tang]
^- (quip move _this)
=. this apex =< abet
?> ?=([@ *] way)
=/ who (,@p (slav %p i.way))
~& [%received-httr who]
abet-pe:(take-sigh-tang:(pe who) t.way tan)
::
++ pe
|= who=ship
=+ (~(gut by piers) who *pier)
=* pier-data -
|%
++ abet-pe
^+ this
=. piers (~(put by piers) who pier-data)
this
::
++ handle-sleep
^+ ..abet-pe
..abet-pe(pier-data *pier)
::
++ handle-restore
^+ ..abet-pe
=. this
%- emit-aqua-events
[%event who [//http/0v1n.2m9vh %born ~]]~
..abet-pe
::
++ handle-thus
|= [way=wire %thus num=@ud req=(unit hiss:eyre)]
^+ ..abet-pe
?~ req
?. (~(has in http-requests) num)
..abet-pe
:: Eyre doesn't support cancelling HTTP requests from userspace,
:: so we remove it from our state so we won't pass along the
:: response.
::
~& [who=who %aqua-eyre-cant-cancel-thus num=num]
=. http-requests (~(del in http-requests) num)
..abet-pe
~& [who=who %aqua-eyre-requesting u.req]
=. http-requests (~(put in http-requests) num)
=. this
%- emit-moves :_ ~
:* ost
%hiss
/(scot %p who)/(scot %ud num)
~
%httr
[%hiss u.req]
==
..abet-pe
::
:: Pass HTTP response back to virtual ship
::
++ take-sigh-httr
|= [way=wire res=httr:eyre]
^+ ..abet-pe
?> ?=([@ ~] way)
=/ num (slav %ud i.way)
?. (~(has in http-requests) num)
~& [who=who %ignoring-httr num=num]
..abet-pe
=. http-requests (~(del in http-requests) num)
=. this
(emit-aqua-events [%event who [//http/0v1n.2m9vh %receive num [%start [p.res q.res] r.res &]]]~)
..abet-pe
::
:: Got error in HTTP response
::
++ take-sigh-tang
|= [way=wire tan=tang]
^+ ..abet-pe
?> ?=([@ ~] way)
=/ num (slav %ud i.way)
?. (~(has in http-requests) num)
~& [who=who %ignoring-httr num=num]
..abet-pe
=. http-requests (~(del in http-requests) num)
%- (slog tan)
..abet-pe
--
--

311
pkg/arvo/app/aqua.hoon
View File

@ -21,23 +21,10 @@
:: We get ++unix-event and ++pill from /-aquarium
::
/- aquarium
/+ pill
/+ pill, default-agent
=, pill-lib=pill
=, aquarium
=> $~ |%
+$ move (pair bone card)
+$ card
$% [%diff diff-type]
==
::
:: Outgoing subscription updates
::
+$ diff-type
$% [%aqua-effects aqua-effects]
[%aqua-events aqua-events]
[%aqua-boths aqua-boths]
==
::
+$ state
$: %0
pil=pill
@ -54,7 +41,60 @@
processing-events=?
==
--
=, gall
::
=| state
=* all-state -
=<
^- agent:gall
|_ =bowl:gall
+* this .
aqua-core +>
ac ~(. aqua-core bowl)
def ~(. (default-agent this %|) bowl)
++ on-init `this
++ on-save !>(all-state)
++ on-load
|= old-state=vase
^- step:agent:gall
~& prep=%aqua
=+ new=((soft state) !<(* old-state))
?~ new
`this
`this(all-state u.new)
::
++ on-poke
|= [=mark =vase]
^- step:agent:gall
=^ cards all-state
?+ mark ~|([%aqua-bad-mark mark] !!)
%aqua-events (poke-aqua-events:ac !<((list aqua-event) vase))
%pill (poke-pill:ac !<(pill vase))
%noun (poke-noun:ac !<(* vase))
==
[cards this]
::
++ on-watch
|= =path
^- step:agent:gall
?: ?=([?(%effects %effect) ~] path)
`this
?: ?=([%effect @ ~] path)
`this
?. ?=([?(%effects %effect %evens %boths) @ ~] path)
~| [%aqua-bad-subscribe-path path]
!!
?~ (slaw %p i.t.path)
~| [%aqua-bad-subscribe-path-ship path]
!!
`this
::
++ on-leave on-leave:def
++ on-peek peek:ac
::
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
:: unix-{effects,events,boths}: collect jar of effects and events to
:: brodcast all at once to avoid gall backpressure
@ -63,10 +103,8 @@
=| unix-effects=(jar ship unix-effect)
=| unix-events=(jar ship unix-timed-event)
=| unix-boths=(jar ship unix-both)
=| moves=(list move)
|_ $: hid=bowl
state
==
=| cards=(list card:agent:gall)
|_ hid=bowl:gall
::
:: Represents a single ship's state.
::
@ -99,11 +137,11 @@
=. next-events (~(gas to next-events) ues)
..abet-pe
::
:: Send moves to host arvo
:: Send cards to host arvo
::
++ emit-moves
|= ms=(list move)
=. this (^emit-moves ms)
++ emit-cards
|= ms=(list card:agent:gall)
=. this (^emit-cards ms)
..abet-pe
::
:: Process the events in our queue.
@ -200,7 +238,7 @@
::
++ apex-aqua
^+ this
=: moves ~
=: cards ~
unix-effects ~
unix-events ~
unix-boths ~
@ -208,46 +246,63 @@
this
::
++ abet-aqua
^- (quip move _this)
^- (quip card:agent:gall state)
=. this
%- emit-moves
%- zing ^- (list (list move))
%+ turn ~(tap by sup.hid)
|= [b=bone her=ship pax=path]
^- (list move)
?+ pax ~
[%effects @ ~]
=/ who (slav %p i.t.pax)
=/ ufs (~(get ja unix-effects) who)
?~ ufs
~
[b %diff %aqua-effects who (flop ufs)]~
::
[%effects ~]
%+ turn
~(tap by unix-effects)
|= [who=ship ufs=(list unix-effect)]
[b %diff %aqua-effects who (flop ufs)]
::
[%events @ ~]
=/ who (slav %p i.t.pax)
=/ ve (~(get ja unix-events) who)
?~ ve
~
[b %diff %aqua-events who (flop ve)]~
::
[%boths @ ~]
=/ who (slav %p i.t.pax)
=/ bo (~(get ja unix-boths) who)
?~ bo
~
[b %diff %aqua-boths who (flop bo)]~
=/ =path /effect
%- emit-cards
%- zing
%+ turn ~(tap by unix-effects)
|= [=ship ufs=(list unix-effect)]
%- zing
%+ turn ufs
|= uf=unix-effect
:~ [%give %fact `/effect %aqua-effect !>(`aqua-effect`[ship uf])]
[%give %fact `/effect/[-.q.uf] %aqua-effect !>(`aqua-effect`[ship uf])]
==
[(flop moves) this]
::
=. this
=/ =path /effects
%- emit-cards
%+ turn ~(tap by unix-effects)
|= [=ship ufs=(list unix-effect)]
[%give %fact `path %aqua-effects !>(`aqua-effects`[ship (flop ufs)])]
::
=. this
%- emit-cards
%- zing
%+ turn ~(tap by unix-effects)
|= [=ship ufs=(list unix-effect)]
=/ =path /effect/(scot %p ship)
%+ turn ufs
|= uf=unix-effect
[%give %fact `path %aqua-effect !>(`aqua-effect`[ship uf])]
::
=. this
%- emit-cards
%+ turn ~(tap by unix-effects)
|= [=ship ufs=(list unix-effect)]
=/ =path /effects/(scot %p ship)
[%give %fact `path %aqua-effects !>(`aqua-effects`[ship (flop ufs)])]
::
=. this
%- emit-cards
%+ turn ~(tap by unix-events)
|= [=ship ve=(list unix-timed-event)]
=/ =path /events/(scot %p ship)
[%give %fact `path %aqua-events !>(`aqua-events`[ship (flop ve)])]
::
=. this
%- emit-cards
%+ turn ~(tap by unix-boths)
|= [=ship bo=(list unix-both)]
=/ =path /boths/(scot %p ship)
[%give %fact `path %aqua-boths !>(`aqua-boths`[ship (flop bo)])]
::
[(flop cards) all-state]
::
++ emit-moves
|= ms=(list move)
=. moves (weld ms moves)
++ emit-cards
|= ms=(list card:agent:gall)
=. cards (weld ms cards)
this
::
::
@ -269,51 +324,12 @@
=. this abet-pe:plow:(pe u.who)
$
::
:: Subscribe to effects from a ship
::
++ peer-effects
|= pax=path
^- (quip move _this)
?. ?=([@ *] pax)
~& [%aqua-bad-peer-effects pax]
`this
?~ (slaw %p i.pax)
~& [%aqua-bad-peer-effects-ship pax]
!!
`this
::
:: Subscribe to events to a ship
::
++ peer-events
|= pax=path
^- (quip move _this)
?. ?=([@ ~] pax)
~& [%aqua-bad-peer-events pax]
`this
?~ (slaw %p i.pax)
~& [%aqua-bad-peer-events-ship pax]
!!
`this
::
:: Subscribe to both events and effects of a ship
::
++ peer-boths
|= pax=path
^- (quip move _this)
?. ?=([@ ~] pax)
~& [%aqua-bad-peer-boths pax]
`this
?~ (slaw %p i.pax)
~& [%aqua-bad-peer-boths-ship pax]
!!
`this
::
:: Load a pill and assemble arvo. Doesn't send any of the initial
:: events.
::
++ poke-pill
|= p=pill
^- (quip move _this)
^- (quip card:agent:gall state)
=. this apex-aqua =< abet-aqua
=. pil p
~& lent=(met 3 (jam boot-ova.pil))
@ -344,7 +360,7 @@
::
++ poke-noun
|= val=*
^- (quip move _this)
^- (quip card:agent:gall state)
=. this apex-aqua =< abet-aqua
^+ this
:: Could potentially factor out the three lines of turn-ships
@ -355,8 +371,8 @@
?> ?=([[%7 * %1 installed=*] ~] boot-ova.pil)
=. installed.boot-ova.pil
%+ roll (,(list term) vs.val)
|= [v=term _installed.boot-ova.pil]
%^ slum installed.boot-ova.pil now.hid
|= [v=term =_installed.boot-ova.pil]
%^ slum installed now.hid
=/ vane
?+ v ~|([%unknown-vane v] !!)
%a %ames
@ -367,25 +383,26 @@
%f %ford
%g %gall
%j %jael
%g %gall
==
=/ pax
/(scot %p our.hid)/home/(scot %da now.hid)/sys/vane/[vane]
=/ txt .^(@ %cx (weld pax /hoon))
[/vane/[vane] [%veer v pax txt]]
=> .(this ^+(this this))
=^ ms this (poke-pill pil)
(emit-moves ms)
=^ ms all-state (poke-pill pil)
(emit-cards ms)
::
[%swap-files ~]
=. userspace-ova.pil
=/ slim-dirs
`(list path)`~[/app /gen /lib /mar /sur /hoon/sys /arvo/sys /zuse/sys]
=/ slim-dirs=(list path)
~[/app /ted /gen /lib /mar /sur /hoon/sys /arvo/sys /zuse/sys]
:_ ~
%- unix-event
%- %*(. file-ovum:pill-lib directories slim-dirs)
/(scot %p our.hid)/home/(scot %da now.hid)
=^ ms this (poke-pill pil)
(emit-moves ms)
=^ ms all-state (poke-pill pil)
(emit-cards ms)
::
[%wish hers=* p=@t]
%+ turn-ships ((list ship) hers.val)
@ -414,7 +431,7 @@
::
++ poke-aqua-events
|= events=(list aqua-event)
^- (quip move _this)
^- (quip card:agent:gall state)
=. this apex-aqua =< abet-aqua
%+ turn-events events
|= [ae=aqua-event thus=_this]
@ -428,7 +445,7 @@
^- (list unix-event)
:~ [/ %wack 0] :: eny
[/ %whom who.ae] :: eny
[//newt/0v1n.2m9vh %barn ~]
[//newt/0v1n.2m9vh %born ~]
[//behn/0v1n.2m9vh %born ~]
:^ //term/1 %boot &
?~ keys.ae
@ -514,63 +531,23 @@
::
:: Check whether we have a snapshot
::
++ peek-x-fleet-snap
|= pax=path
^- (unit (unit [%noun noun]))
?. ?=([@ ~] pax)
~
:^ ~ ~ %noun
(~(has by fleet-snaps) i.pax)
::
:: Pass scry into child ship
::
++ peek-x-i
|= pax=path
^- (unit (unit [%noun noun]))
?. ?=([@ @ @ @ @ *] pax)
~
=/ who (slav %p i.pax)
=/ pier (~(get by piers) who)
?~ pier
~
:^ ~ ~ %noun
(peek:(pe who) t.pax)
::
:: Get all created ships
::
++ peek-x-ships
|= pax=path
^- (unit (unit [%noun (list ship)]))
?. ?=(~ pax)
~
:^ ~ ~ %noun
`(list ship)`(turn ~(tap by piers) head)
::
::
::
++ peek-x-pill
|= pax=path
^- (unit (unit [%pill pill]))
=/ pill-size (met 3 (jam pil))
?: (lth pill-size 100)
~& [%no-pill size=pill-size]
[~ ~]
``pill+pil
++ peek
|= =path
^- (unit (unit cage))
?+ path ~
[%x %fleet-snap @ ~] ``noun+!>((~(has by fleet-snaps) i.t.t.path))
[%x %ships ~] ``noun+!>((turn ~(tap by piers) head))
[%x %pill ~] ``pill+!>(pil)
[%x %i @ @ @ @ @ *]
=/ who (slav %p i.t.t.path)
=/ pier (~(get by piers) who)
?~ pier
~
:^ ~ ~ %noun !>
(peek:(pe who) t.t.t.path)
==
::
:: Trivial scry for mock
::
++ scry |=([* *] ~)
::
:: Throw away old state if it doesn't soft to new state.
::
++ prep
|= old/(unit noun)
^- [(list move) _+>.$]
~& prep=%aqua
?~ old
`+>.$
=+ new=((soft state) u.old)
?~ new
`+>.$
`+>.$(+<+ u.new)
--

345
pkg/arvo/app/azimuth-tracker.hoon
View File

@ -1,225 +1,134 @@
/- eth-watcher
/+ tapp, stdio
/+ default-agent, verb
=, able:jael
=> |%
+$ app-state
$: %3
url=@ta
whos=(set ship)
==
+$ peek-data ~
+$ in-poke-data
$: %azimuth-tracker-poke
$% :: %listen
::
[%listen whos=(list ship) =source:jael]
:: %watch: configure node url
::
[%watch url=@ta]
==
==
+$ out-poke-data
$: %eth-watcher-poke
poke:eth-watcher
==
+$ in-peer-data
$: %eth-watcher-diff
diff:eth-watcher
==
+$ out-peer-data
[%azimuth-udiff =ship =udiff:point]
++ tapp
%: ^tapp
app-state
peek-data
in-poke-data
out-poke-data
in-peer-data
out-peer-data
==
++ tapp-async tapp-async:tapp
++ stdio (^stdio out-poke-data out-peer-data)
--
::
:: Async helpers
::
=> |%
++ topics
|= ships=(set ship)
^- (list ?(@ux (list @ux)))
:: The first topic should be one of these event types
|%
++ app-state
$: %0
url=@ta
whos=(set ship)
==
+$ poke-data
$% :: %listen
::
:- => azimuth-events:azimuth
:~ broke-continuity
changed-keys
lost-sponsor
escape-accepted
==
:: If we're looking for a specific set of ships, specify them as
:: the second topic. Otherwise don't specify the second topic so
:: we will match all ships.
[%listen whos=(list ship) =source:jael]
:: %watch: configure node url
::
?: =(~ ships)
~
[(turn ~(tap in ships) ,@) ~]
::
++ event-logs-to-udiffs
|= event-logs=(list =event-log:rpc:ethereum)
^- =udiffs:point
%+ murn event-logs
|= =event-log:rpc:ethereum
^- (unit [=ship =udiff:point])
?~ mined.event-log
~
?: removed.u.mined.event-log
~& [%removed-log event-log]
~
=/ =id:block [block-hash block-number]:u.mined.event-log
=, azimuth-events:azimuth
=, abi:ethereum
?: =(broke-continuity i.topics.event-log)
=/ who=@ (decode-topics t.topics.event-log ~[%uint])
=/ num=@ (decode-results data.event-log ~[%uint])
`[who id %rift num]
?: =(changed-keys i.topics.event-log)
=/ who=@ (decode-topics t.topics.event-log ~[%uint])
=+ ^- [enc=octs aut=octs sut=@ud rev=@ud]
%+ decode-results data.event-log
~[[%bytes-n 32] [%bytes-n 32] %uint %uint]
`[who id %keys rev sut (pass-from-eth:azimuth enc aut sut)]
?: =(lost-sponsor i.topics.event-log)
=+ ^- [who=@ pos=@]
(decode-topics t.topics.event-log ~[%uint %uint])
`[who id %spon ~]
?: =(escape-accepted i.topics.event-log)
=+ ^- [who=@ wer=@]
(decode-topics t.topics.event-log ~[%uint %uint])
`[who id %spon `wer]
~& [%bad-topic event-log]
~
::
++ jael-update
|= =udiffs:point
=/ m (async:stdio ,~)
|- ^- form:m
=* loop $
?~ udiffs
(pure:m ~)
=/ =path /(scot %p ship.i.udiffs)
;< ~ bind:m (give-result:stdio / %azimuth-udiff i.udiffs)
;< ~ bind:m (give-result:stdio path %azimuth-udiff i.udiffs)
loop(udiffs t.udiffs)
--
[%watch url=@ta]
==
--
::
:: Main loop
::
=> |%
::
:: Send %listen to jael
::
++ listen
|= [state=app-state whos=(list ship) =source:jael]
=/ m (async:stdio ,app-state)
^- form:m
;< ~ bind:m (send-effect:stdio %listen /lo (silt whos) source)
(pure:m state)
::
:: Start watching a node
::
++ start
|= [state=app-state our=ship dap=term]
=/ m (async:stdio ,app-state)
^- form:m
;< ~ bind:m
%+ poke-app:stdio
[our %eth-watcher]
:+ %eth-watcher-poke %watch
:- /[dap]
:* url.state
launch:contracts:azimuth
~[azimuth:contracts:azimuth]
(topics whos.state)
==
(pure:m state)
::
:: +history: Tell subscribers about many changes
::
++ history
|= =loglist:eth-watcher
=/ m (async:stdio ,~)
|- ^- form:m
%- jael-update
(event-logs-to-udiffs loglist)
::
:: +log: Tell subscribers about a new change
::
++ log
|= =event-log:rpc:ethereum
=/ m (async:stdio ,~)
(history [event-log ~])
::
:: +disavow: Tell subscribers there was a deep reorg
::
++ disavow
|= =id:block
=/ m (async:stdio ,~)
^- form:m
(jael-update [*ship id %disavow ~]~)
--
::
:: Main
::
=* default-tapp default-tapp:tapp
%- create-tapp-all:tapp
^- tapp-core-all:tapp
|_ [=bowl:gall state=app-state]
++ handle-init
=/ m tapp-async
^- form:m
:: set up subscription once, listen forever
|%
++ topics
|= ships=(set ship)
^- (list ?(@ux (list @ux)))
:: The first topic should be one of these event types
::
;< ~ bind:m
%+ peer-app:stdio
[our.bowl %eth-watcher]
/logs/[dap.bowl]
(pure:m state)
:- => azimuth-events:azimuth
:~ broke-continuity
changed-keys
lost-sponsor
escape-accepted
==
:: If we're looking for a specific set of ships, specify them as
:: the second topic. Otherwise don't specify the second topic so
:: we will match all ships.
::
?: =(~ ships)
~
[(turn ~(tap in ships) ,@) ~]
::
++ handle-peek handle-peek:default-tapp
++ handle-take handle-take:default-tapp
++ event-logs-to-udiffs
|= event-logs=(list =event-log:rpc:ethereum)
^- =udiffs:point
%+ murn event-logs
|= =event-log:rpc:ethereum
^- (unit [=ship =udiff:point])
?~ mined.event-log
~
?: removed.u.mined.event-log
~& [%removed-log event-log]
~
=/ =id:block [block-hash block-number]:u.mined.event-log
=, azimuth-events:azimuth
=, abi:ethereum
?: =(broke-continuity i.topics.event-log)
=/ who=@ (decode-topics t.topics.event-log ~[%uint])
=/ num=@ (decode-results data.event-log ~[%uint])
`[who id %rift num]
?: =(changed-keys i.topics.event-log)
=/ who=@ (decode-topics t.topics.event-log ~[%uint])
=+ ^- [enc=octs aut=octs sut=@ud rev=@ud]
%+ decode-results data.event-log
~[[%bytes-n 32] [%bytes-n 32] %uint %uint]
`[who id %keys rev sut (pass-from-eth:azimuth enc aut sut)]
?: =(lost-sponsor i.topics.event-log)
=+ ^- [who=@ pos=@]
(decode-topics t.topics.event-log ~[%uint %uint])
`[who id %spon ~]
?: =(escape-accepted i.topics.event-log)
=+ ^- [who=@ wer=@]
(decode-topics t.topics.event-log ~[%uint %uint])
`[who id %spon `wer]
~& [%bad-topic event-log]
~
::
++ handle-poke
|= in=in-poke-data
=/ m tapp-async
^- form:m
?- +<.in
%listen (listen state +>.in)
%watch (start state(url url.in) [our dap]:bowl)
++ jael-update
|= =udiffs:point
^- (list card:agent:gall)
?~ udiffs
~
=/ =path /(scot %p ship.i.udiffs)
:* [%give %fact `/ %azimuth-udiff !>(i.udiffs)]
[%give %fact `path %azimuth-udiff !>(i.udiffs)]
$(udiffs t.udiffs)
==
::
++ handle-diff
|= [=dock =path in=in-peer-data]
=/ m tapp-async
^- form:m
;< ~ bind:m
?- +<.in
%history (history +>.in)
%log (log +>.in)
%disavow (disavow +>.in)
++ start
|= [state=app-state our=ship dap=term]
^- card:agent:gall
=/ args=vase !>
:* %watch /[dap]
url.state ~m5 launch:contracts:azimuth
~[azimuth:contracts:azimuth]
(topics whos.state)
==
(pure:m state)
[%pass /wa %agent [our %eth-watcher] %poke %eth-watcher-poke args]
--
::
:: +handle-peer: handle incoming subscriptions (generally from jael)
=| state=app-state
%+ verb |
^- agent:gall
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
::
:: /~some-ship: listen to events for this ship
:: /: listen to events for all ships azimuth-tracker is observing
++ on-init
^- (quip card:agent:gall agent:gall)
:_ this :_ ~
^- card:agent:gall
[%pass /eth-watcher %agent [our.bowl %eth-watcher] %watch /logs/[dap.bowl]]
::
:: note that incoming subscriptions affect application state.
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(app-state old))
::
++ handle-peer
++ on-poke
|= [=mark =vase]
?. ?=(%azimuth-tracker-poke mark)
(on-poke:def mark vase)
=+ !<(poke=poke-data vase)
?- -.poke
%listen [[%pass /lo %arvo %j %listen (silt whos.poke) source.poke]~ this]
%watch
=. url.state url.poke
[[(start state [our dap]:bowl) ~] this]
==
++ on-watch
|= =path
=/ m tapp-async
^- form:m
?. ?=(?(~ [@ ~]) path) !!
^- (quip card:agent:gall _this)
?< =(/sole/drum path)
?> ?=(?(~ [@ ~]) path)
=/ who=(unit ship)
?~ path ~
`(slav %p i.path)
@ -227,5 +136,29 @@
?~ who
~
(~(put in whos.state) u.who)
:_ this :_ ~
(start state [our dap]:bowl)
::
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-agent
|= [=wire =sign:agent:gall]
?. ?=([%eth-watcher ~] wire)
(on-agent:def wire sign)
?. ?=(%fact -.sign)
(on-agent:def wire sign)
?. ?=(%eth-watcher-diff p.cage.sign)
(on-agent:def wire sign)
=+ !<(diff=diff:eth-watcher q.cage.sign)
:_ this
^- (list card:agent:gall)
%- jael-update
?- -.diff
%history (event-logs-to-udiffs loglist.diff)
%log (event-logs-to-udiffs event-log.diff ~)
%disavow [*ship id.diff %disavow ~]~
==
::
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--

369
pkg/arvo/app/chat-cli.hoon
View File

@ -12,9 +12,10 @@
/- *chat-store, *chat-view, *chat-hook,
*permission-store, *group-store, *invite-store,
sole-sur=sole
/+ sole-lib=sole, chat-eval
/+ sole-lib=sole, chat-eval, default-agent, verb
::
|%
+$ card card:agent:gall
+$ state
$: grams=(list mail) :: all messages
known=(set [target serial]) :: known message lookup
@ -25,7 +26,8 @@
settings=(set term) :: frontend flags
width=@ud :: display width
timez=(pair ? @ud) :: timezone adjustment
cli=[=bone state=sole-share:sole-sur] :: console id & state
cli=state=sole-share:sole-sur :: console state
eny=@uvJ :: entropy
==
::
+$ mail [source=target envelope]
@ -64,41 +66,92 @@
[%help ~] :: print usage info
== ::
::
+$ move [bone card]
+$ card
$% [%diff %sole-effect sole-effect:sole-sur]
[%poke wire dock out-action]
[%peer wire dock path]
==
::
+$ out-action
$% [%chat-action chat-action]
[%chat-view-action chat-view-action]
[%chat-hook-action chat-hook-action]
[%group-action group-action]
[%invite-action invite-action]
==
--
=| state
=* all-state -
=<
%+ verb |
^- agent:gall
|_ =bowl:gall
+* this .
talk-core +>
tc ~(. talk-core(eny eny.bowl) bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init
^- (quip card _this)
:- [connect:tc]~
%_ this
audience [[our-self:tc /] ~ ~]
settings (sy %showtime %notify ~)
width 80
==
::
++ on-save !>(all-state)
::
++ on-load
|= old-state=vase
^- (quip card _this)
=/ old !<(state old-state)
=^ cards all-state (prep:tc `old)
[cards this]
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
=^ cards all-state
?+ mark (on-poke:def mark vase)
%noun (poke-noun:tc mark !<(* vase))
%sole-action (poke-sole-action:tc !<(sole-action:sole-sur vase))
==
[cards this]
::
++ on-watch
|= =path
^- (quip card _this)
=^ cards all-state (peer:tc path)
[cards this]
::
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
=^ cards all-state
?- -.sign
%poke-ack [- all-state]:(on-agent:def wire sign)
%watch-ack [- all-state]:(on-agent:def wire sign)
%kick ~& %chat-cli-kicked `all-state
%fact
?+ p.cage.sign ~|([%chat-cli-bad-sub-mark wire p.cage.sign] !!)
%chat-update (diff-chat-update:tc wire !<(chat-update q.cage.sign))
==
==
[cards this]
::
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
|_ [=bowl:gall state]
++ this .
|_ =bowl:gall
:: +prep: setup & state adapter
::
++ prep
|= old=(unit state)
^- (quip card state)
?^ old
[~ this(+<+ u.old)]
=^ moves this
[~ u.old]
=^ cards all-state
%_ catch-up
audience [[our-self /] ~ ~]
settings (sy %showtime %notify ~)
width 80
==
[[connect moves] this]
[[connect cards] all-state]
:: +catch-up: process all chat-store state
::
++ catch-up
^- (quip move _this)
^- (quip card state)
=/ =inbox
.^ inbox
%gx
@ -107,20 +160,20 @@
(scot %da now.bowl)
/all/noun
==
|- ^- (quip move _this)
?~ inbox [~ this]
|- ^- (quip card state)
?~ inbox [~ all-state]
=* path p.n.inbox
=* mailbox q.n.inbox
=/ =target (path-to-target path)
=^ moves-n this (read-envelopes target envelopes.mailbox)
=^ moves-l this $(inbox l.inbox)
=^ moves-r this $(inbox r.inbox)
[:(weld moves-n moves-l moves-r) this]
=^ cards-n all-state (read-envelopes target envelopes.mailbox)
=^ cards-l all-state $(inbox l.inbox)
=^ cards-r all-state $(inbox r.inbox)
[:(weld cards-n cards-l cards-r) all-state]
:: +connect: connect to the chat-store
::
++ connect
^- move
[ost.bowl %peer /chat-store [our-self %chat-store] /updates]
^- card
[%pass /chat-store %agent [our-self %chat-store] %watch /updates]
::
++ our-self (name:title our.bowl)
:: +target-to-path: prepend ship to the path
@ -144,73 +197,67 @@
::
++ poke-noun
|= a=*
^- (quip move _this)
^- (quip card state)
?: ?=(%connect a)
[[connect ~] this]
[[connect ~] all-state]
?: ?=(%catch-up a)
catch-up
[~ this]
[~ all-state]
:: +poke-sole-action: handle cli input
::
++ poke-sole-action
|= act=sole-action:sole-sur
^- (quip move _this)
?. =(bone.cli ost.bowl)
~|(%strange-sole !!)
::TODO use id.act to support multiple separate sessions
|= [act=sole-action:sole-sur]
^- (quip card state)
(sole:sh-in act)
:: +peer: accept only cli subscriptions from ourselves
::
++ peer
|= =path
^- (quip move _this)
^- (quip card state)
?. (team:title our-self src.bowl)
~| [%peer-talk-stranger src.bowl]
!!
?. ?=([%sole *] path)
~| [%peer-talk-strange path]
!!
=. bone.cli ost.bowl
:: display a fresh prompt
:- [prompt:sh-out ~]
:: start with fresh sole state
this(state.cli *sole-share:sole-sur)
::
++ diff-chat-two-update
|= [=wire upd=chat-two-update]
^- (quip move _this)
(read-envelopes (path-to-target path.upd) envelopes.upd)
all-state(state.cli *sole-share:sole-sur)
:: +diff-chat-update: get new mailboxes & messages
::
++ diff-chat-update
|= [=wire upd=chat-update]
^- (quip move _this)
?+ -.upd [~ this]
%create (notice-create +.upd)
%delete [[(show-delete:sh-out (path-to-target path.upd)) ~] this]
%message (read-envelope (path-to-target path.upd) envelope.upd)
^- (quip card state)
?+ -.upd [~ all-state]
%create (notice-create +.upd)
%delete [[(show-delete:sh-out (path-to-target path.upd)) ~] all-state]
%message (read-envelope (path-to-target path.upd) envelope.upd)
%messages (read-envelopes (path-to-target path.upd) envelopes.upd)
==
::
++ read-envelopes
|= [=target envs=(list envelope)]
^- (quip move _this)
?~ envs [~ this]
=^ moves-i this (read-envelope target i.envs)
=^ moves-t this $(envs t.envs)
[(weld moves-i moves-t) this]
^- (quip card state)
?~ envs [~ all-state]
=^ cards-i all-state (read-envelope target i.envs)
=^ cards-t all-state $(envs t.envs)
[(weld cards-i cards-t) all-state]
::
++ notice-create
|= =target
^- (quip move _this)
=^ moves this
^- (quip card state)
=^ cards all-state
?: (~(has by bound) target)
[~ this]
[~ all-state]
(bind-default-glyph target)
[[(show-create:sh-out target) moves] this]
[[(show-create:sh-out target) cards] all-state]
:: +bind-default-glyph: bind to default, or random available
::
++ bind-default-glyph
|= =target
^- (quip move _this)
^- (quip card state)
=; =glyph (bind-glyph glyph target)
|^ =/ g=glyph (choose glyphs)
?. (~(has by binds) g) g
@ -228,7 +275,7 @@
::
++ bind-glyph
|= [=glyph =target]
^- (quip move _this)
^- (quip card state)
::TODO should send these to settings store eventually
:: if the target was already bound to another glyph, un-bind that
::
@ -236,16 +283,16 @@
(~(del ju binds) (~(got by bound) target) target)
=. bound (~(put by bound) target glyph)
=. binds (~(put ju binds) glyph target)
[(show-glyph:sh-out glyph `target) this]
[(show-glyph:sh-out glyph `target) all-state]
:: +unbind-glyph: remove all binding for glyph
::
++ unbind-glyph
|= [=glyph targ=(unit target)]
^- (quip move _this)
^- (quip card state)
?^ targ
=. binds (~(del ju binds) glyph u.targ)
=. bound (~(del by bound) u.targ)
[(show-glyph:sh-out glyph ~) this]
[(show-glyph:sh-out glyph ~) all-state]
=/ ole=(set target)
(~(get ju binds) glyph)
=. binds (~(del by binds) glyph)
@ -255,7 +302,7 @@
=. bound $(ole l.ole)
=. bound $(ole r.ole)
(~(del by bound) n.ole)
[(show-glyph:sh-out glyph ~) this]
[(show-glyph:sh-out glyph ~) all-state]
:: +decode-glyph: find the target that matches a glyph, if any
::
++ decode-glyph
@ -278,12 +325,12 @@
::
++ read-envelope
|= [=target =envelope]
^- (quip move _this)
^- (quip card state)
?: (~(has in known) [target uid.envelope])
::NOTE we no-op only because edits aren't possible
[~ this]
[~ all-state]
:- (show-envelope:sh-out target envelope)
%_ this
%_ all-state
known (~(put in known) [target uid.envelope])
grams [[target envelope] grams]
count +(count)
@ -298,12 +345,12 @@
::
++ sole
|= act=sole-action:sole-sur
^- (quip move _this)
?- -.act
%det (edit +.act)
%clr [~ this]
^- (quip card state)
?- -.dat.act
%det (edit +.dat.act)
%clr [~ all-state]
%ret obey
%tab [~ this]
%tab [~ all-state]
==
:: +edit: apply sole edit
::
@ -312,17 +359,17 @@
::
++ edit
|= cal=sole-change:sole-sur
^- (quip move _this)
^- (quip card state)
=^ inv state.cli (~(transceive sole-lib state.cli) cal)
=+ fix=(sanity inv buf.state.cli)
?~ lit.fix
[~ this]
[~ all-state]
:: just capital correction
?~ err.fix
(slug fix)
:: allow interior edits and deletes
?. &(?=($del -.inv) =(+(p.inv) (lent buf.state.cli)))
[~ this]
[~ all-state]
(slug fix)
:: +sanity: check input sanity
::
@ -339,13 +386,13 @@
::
++ slug
|= [lit=(list sole-edit:sole-sur) err=(unit @u)]
^- (quip move _this)
?~ lit [~ this]
^- (quip card state)
?~ lit [~ all-state]
=^ lic state.cli
%- ~(transmit sole-lib state.cli)
^- sole-edit:sole-sur
?~(t.lit i.lit [%mor lit])
:_ this
:_ all-state
:_ ~
%+ effect:sh-out %mor
:- [%det lic]
@ -542,22 +589,22 @@
:: the command (if any) gets echoed to the user.
::
++ obey
^- (quip move _this)
^- (quip card state)
=+ buf=buf.state.cli
=+ fix=(sanity [%nop ~] buf)
?^ lit.fix
(slug fix)
=+ jub=(rust (tufa buf) read)
?~ jub [[(effect:sh-out %bel ~) ~] this]
?~ jub [[(effect:sh-out %bel ~) ~] all-state]
=^ cal state.cli (~(transmit sole-lib state.cli) [%set ~])
=^ moves this (work u.jub)
:_ this
=^ cards all-state (work u.jub)
:_ all-state
%+ weld
^- (list move)
^- (list card)
:: echo commands into scrollback
?. =(`0 (find ";" buf)) ~
[(note:sh-out (tufa `(list @)`buf)) ~]
:_ moves
:_ cards
%+ effect:sh-out %mor
:~ [%nex ~]
[%det cal]
@ -566,7 +613,7 @@
::
++ work
|= job=command
^- (quip move _this)
^- (quip card state)
|^ ?- -.job
%target (set-target +.job)
%say (say +.job)
@ -594,28 +641,31 @@
%chats chats
%help help
==
:: +act: build action move
:: +act: build action card
::
++ act
|= [what=term app=term =out-action]
^- move
:* ost.bowl
%poke
|= [what=term app=term =cage]
^- card
:* %pass
/cli-command/[what]
%agent
[our-self app]
out-action
==
:: +invite-move: build invite move
::
++ invite-move
|= [where=path who=ship]
^- move
:* ost.bowl
%poke
cage
==
:: +invite-card: build invite card
::
++ invite-card
|= [where=path who=ship]
^- card
:* %pass
/cli-command/invite
%agent
[who %invite-hook] ::NOTE only place chat-cli pokes others
%poke
%invite-action
::
!>
^- invite-action
:^ %invite /chat
(shax (jam [our-self where] who))
@ -631,23 +681,24 @@
::
++ set-target
|= tars=(set target)
^- (quip move _this)
^- (quip card state)
=. audience tars
[[prompt:sh-out ~] this]
[[prompt:sh-out ~] all-state]
:: +create: new local mailbox
::
++ create
|= [security=rw-security =path gyf=(unit char) allow-history=(unit ?)]
^- (quip move _this)
^- (quip card state)
::TODO check if already exists
=/ =target [our-self path]
=. audience [target ~ ~]
=^ moz this
?. ?=(^ gyf) [~ this]
=^ moz all-state
?. ?=(^ gyf) [~ all-state]
(bind-glyph u.gyf target)
=- [[- moz] this]
=- [[- moz] all-state]
%^ act %do-create %chat-view
:- %chat-view-action
!>
:* %create
path
security
@ -669,22 +720,23 @@
::
++ delete
|= =path
^- (quip move _this)
=- [[- ~] this]
^- (quip card state)
=- [[- ~] all-state]
%^ act %do-delete %chat-view
:- %chat-view-action
!>
[%delete (target-to-path our-self path)]
:: +change-permission: modify permissions on a local chat
::
++ change-permission
|= [allow=? rw=?(%r %w %rw) =path ships=(set ship)]
^- (quip move _this)
:_ this
=; moves=(list move)
?. allow moves
%+ weld moves
^- (quip card state)
:_ all-state
=; cards=(list card)
?. allow cards
%+ weld cards
%+ turn ~(tap in ships)
(cury invite-move path)
(cury invite-card path)
%+ murn
^- (list term)
?- rw
@ -693,7 +745,7 @@
%rw [%read %write ~]
==
|= =term
^- (unit move)
^- (unit card)
=. path
=- (snoc `^path`- term)
[%chat (target-to-path our-self path)]
@ -716,8 +768,8 @@
~
%- some
%^ act %do-permission %group-store
^- out-action
:- %group-action
!>
?: =(u.whitelist allow)
[%add ships path]
[%remove ships path]
@ -725,42 +777,46 @@
::
++ join
|= [=target gyf=(unit char) ask-history=(unit ?)]
^- (quip move _this)
=^ moz this
?. ?=(^ gyf) [~ this]
^- (quip card state)
=^ moz all-state
?. ?=(^ gyf) [~ all-state]
(bind-glyph u.gyf target)
=. audience [target ~ ~]
=; =move
[[move prompt:sh-out moz] this]
=; =card
[[card prompt:sh-out moz] all-state]
::TODO ideally we'd check permission first. attempting this and failing
:: gives ugly %chat-hook-reap
%^ act %do-join %chat-view
:- %chat-view-action
!>
[%join ship.target path.target (fall ask-history %.y)]
:: +leave: unsync & destroy mailbox
::
::TODO allow us to "mute" local chats using this
++ leave
|= =target
=- [[- ~] this]
=- [[- ~] all-state]
?: =(our-self ship.target)
%- print:sh-out
"can't ;leave local chats, maybe use ;delete instead"
%^ act %do-leave %chat-hook
:- %chat-hook-action
!>
[%remove (target-to-path target)]
:: +say: send messages
::
++ say
|= =letter
^- (quip move _this)
^- (quip card state)
~! bowl
=/ =serial (shaf %msg-uid eny.bowl)
:_ this(eny.bowl (shax eny.bowl))
^- (list move)
:_ all-state(eny (shax eny.bowl))
^- (list card)
%+ turn ~(tap in audience)
|= =target
%^ act %out-message %chat-hook
:- %chat-action
!>
:+ %message (target-to-path target)
[serial *@ our-self now.bowl letter]
:: +eval: run hoon, send code and result as message
@ -774,8 +830,8 @@
::
++ lookup-glyph
|= qur=(unit $@(glyph target))
^- (quip move _this)
=- [[- ~] this]
^- (quip card state)
=- [[- ~] all-state]
?^ qur
?^ u.qur
=+ gyf=(~(get by bound) u.qur)
@ -799,8 +855,8 @@
:: +show-settings: print enabled flags, timezone and width settings
::
++ show-settings
^- (quip move _this)
:_ this
^- (quip card state)
:_ all-state
:~ %- print:sh-out
%- zing
^- (list tape)
@ -820,24 +876,24 @@
::
++ set-setting
|= =term
^- (quip move _this)
[~ this(settings (~(put in settings) term))]
^- (quip card state)
[~ all-state(settings (~(put in settings) term))]
:: +unset-setting: disable settings flag
::
++ unset-setting
|= =term
^- (quip move _this)
[~ this(settings (~(del in settings) term))]
^- (quip card state)
[~ all-state(settings (~(del in settings) term))]
:: +set-width: configure cli printing width
::
++ set-width
|= w=@ud
[~ this(width w)]
[~ all-state(width w)]
:: +set-timezone: configure timestamp printing adjustment
::
++ set-timezone
|= tz=[? @ud]
[~ this(timez tz)]
[~ all-state(timez tz)]
:: +select: expand message from number reference
::
++ select
@ -846,7 +902,7 @@
:: (with leading zeros used for precision)
::
|= num=$@(rel=@ud [zeros=@u abs=@ud])
^- (quip move _this)
^- (quip card state)
|^ ?@ num
=+ tum=(scow %s (new:si | +(num)))
?: (gte rel.num count)
@ -860,11 +916,11 @@
(activate (scow %ud msg) (sub count +(msg)))
%- just-print
"…{(reap zeros.num '0')}{(scow %ud abs.num)}: no such telegram"
:: +just-print: full [moves state] output with a single print move
:: +just-print: full [cards state] output with a single print card
::
++ just-print
|= txt=tape
[[(print:sh-out txt) ~] this]
[[(print:sh-out txt) ~] all-state]
:: +index: get message index from absolute reference
::
++ index
@ -878,11 +934,11 @@
::
++ activate
|= [number=tape index=@ud]
^- (quip move _this)
^- (quip card state)
=+ gam=(snag index grams)
=. audience [source.gam ~ ~]
:_ this
^- (list move)
:_ all-state
^- (list card)
:~ (print:sh-out ['?' ' ' number])
(effect:sh-out ~(render-activate mr gam))
prompt:sh-out
@ -891,8 +947,8 @@
:: +chats: display list of local mailboxes
::
++ chats
^- (quip move _this)
:_ this
^- (quip card state)
:_ all-state
:_ ~
%- print-more:sh-out
=/ all
@ -909,8 +965,8 @@
:: +help: print (link to) usage instructions
::
++ help
^- (quip move _this)
=- [[- ~] this]
^- (quip card state)
=- [[- ~] all-state]
(print:sh-out "see https://urbit.org/using/operations/using-your-ship/#messaging")
--
--
@ -919,30 +975,31 @@
::
++ sh-out
|%
:: +effect: console effect move
:: +effect: console effect card
::
++ effect
|= fec=sole-effect:sole-sur
^- move
[bone.cli %diff %sole-effect fec]
^- card
::TODO don't hard-code session id 'drum' here
[%give %fact `/sole/drum %sole-effect !>(fec)]
:: +print: puts some text into the cli as-is
::
++ print
|= txt=tape
^- move
^- card
(effect %txt txt)
:: +print-more: puts lines of text into the cli
::
++ print-more
|= txs=(list tape)
^- move
^- card
%+ effect %mor
(turn txs |=(t=tape [%txt t]))
:: +note: prints left-padded ---| txt
::
++ note
|= txt=tape
^- move
^- card
=+ lis=(simple-wrap txt (sub width 16))
%- print-more
=+ ?:((gth (lent lis) 0) (snag 0 lis) "")
@ -952,7 +1009,7 @@
:: +prompt: update prompt to display current audience
::
++ prompt
^- move
^- card
%+ effect %pro
:+ & %talk-line
^- tape
@ -978,9 +1035,9 @@
::
++ show-envelope
|= [=target =envelope]
^- (list move)
^- (list card)
%+ weld
^- (list move)
^- (list card)
?. =(0 (mod count 5)) ~
:_ ~
=+ num=(scow %ud count)
@ -1002,19 +1059,19 @@
::
++ show-create
|= =target
^- move
^- card
(note "new: {~(phat tr target)}")
:: +show-delete: print mailbox deletion notification
::
++ show-delete
|= =target
^- move
^- card
(note "del: {~(phat tr target)}")
:: +show-glyph: print glyph un/bind notification
::
++ show-glyph
|= [=glyph target=(unit target)]
^- (list move)
^- (list card)
:_ [prompt ~]
%- note
%+ weld "set: {[glyph ~]} "

511
pkg/arvo/app/chat-hook.hoon
View File

@ -3,41 +3,17 @@
:: allow sending chat messages to foreign paths based on write perms
::
/- *permission-store, *chat-hook, *invite-store
/+ *chat-json
/+ *chat-json, default-agent, verb
|%
+$ move [bone card]
::
+$ card
$% [%diff diff]
[%quit ~]
[%poke wire dock poke]
[%pull wire dock ~]
[%peer wire dock path]
==
+$ card card:agent:gall
::
+$ versioned-state
$% state-zero
state-one
state-two
==
::
+$ state-zero
$: %0
synced=(map path ship)
boned=(map wire (list bone))
==
::
+$ state-one
$: %1
synced=(map path ship)
boned=(map wire (list bone))
invite-created=_|
==
::
+$ state-two
$: %2
synced=(map path ship)
boned=(map wire (list bone))
invite-created=_|
allow-history=(map path ?)
==
@ -49,70 +25,111 @@
[%chat-view-action chat-view-action]
==
::
+$ diff
+$ fact
$% [%chat-update chat-update]
[%chat-two-update chat-two-update]
==
--
::
|_ [bol=bowl:gall state-two]
::
++ this .
::
++ prep
|= old=(unit versioned-state)
|^ ^- (quip move _this)
?~ old
=| state-zero
=* state -
%+ verb |
^- agent:gall
=<
|_ bol=bowl:gall
+* this .
chat-core +>
cc ~(. chat-core bol)
def ~(. (default-agent this %|) bol)
::
++ on-init
^- (quip card _this)
:_ this(invite-created %.y)
:~ (invite-poke [%create /chat])
[ost.bol %peer /invites [our.bol %invite-store] /invitatory/chat]
[ost.bol %peer /permissions [our.bol %permission-store] /updates]
:~ (invite-poke:cc [%create /chat])
[%pass /invites %agent [our.bol %invite-store] %watch /invitatory/chat]
[%pass /permissions %agent [our.bol %permission-store] %watch /updates]
==
?- -.u.old
%2 [~ this(+<+ u.old)]
%1 [~ (migrate-state synced.u.old boned.u.old)]
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(state-zero old))
::
%0
:_ (migrate-state synced.u.old boned.u.old)
:~ (invite-poke [%create /chat])
[ost.bol %peer /invites [our.bol %invite-store] /invitatory/chat]
++ on-poke
|= [=mark =vase]
^- (quip card _this)
=^ cards state
?+ mark (on-poke:def mark vase)
%json (poke-json:cc !<(json vase))
%chat-action (poke-chat-action:cc !<(chat-action vase))
%chat-hook-action (poke-chat-hook-action:cc !<(chat-hook-action vase))
==
[cards this]
::
++ on-watch
|= =path
^- (quip card _this)
?+ path (on-watch:def path)
[%backlog *] [(watch-backlog:cc t.path) this]
[%mailbox *] [(watch-mailbox:cc t.path) this]
==
==
::
++ migrate-state
|= [synced=(map path ship) boned=(map wire (list bone))]
^- _this
=/ sta *state-two
=: boned.sta boned
synced.sta synced
allow-history.sta (create-allow-history synced)
invite-created %.y
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
?+ -.sign (on-agent:def wire sign)
%watch-ack
=^ cards state
(watch-ack:cc wire p.sign)
[cards this]
::
%kick
=^ cards state
(kick:cc wire)
[cards this]
::
%fact
?+ p.cage.sign (on-agent:def wire sign)
%chat-update
=^ cards state
(fact-chat-update:cc wire !<(chat-update q.cage.sign))
[cards this]
::
%invite-update
=^ cards state
(fact-invite-update:cc wire !<(invite-update q.cage.sign))
[cards this]
::
%permission-update
=^ cards state
(fact-permission-update:cc wire !<(permission-update q.cage.sign))
[cards this]
==
==
this(+<+ sta)
::
++ create-allow-history
|= synced=(map path ship)
^- (map path ?)
(~(run by synced) |=(* %.n))
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
::
|_ bol=bowl:gall
::
++ poke-json
|= jon=json
^- (quip move _this)
^- (quip card _state)
(poke-chat-action (json-to-action jon))
::
++ poke-chat-action
|= act=chat-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%message -.act)
:: local
:_ this
:_ state
?: (team:title our.bol src.bol)
?. (~(has by synced) path.act)
~
=/ ship (~(got by synced) path.act)
=/ appl ?:(=(ship our.bol) %chat-store %chat-hook)
[ost.bol %poke / [ship appl] [%chat-action act]]~
[%pass / %agent [ship appl] %poke %chat-action !>(act)]~
:: foreign
=/ ship (~(get by synced) path.act)
?~ ship
@ -125,106 +142,116 @@
=: author.envelope.act src.bol
when.envelope.act now.bol
==
[ost.bol %poke / [our.bol %chat-store] [%chat-action act]]~
[%pass / %agent [our.bol %chat-store] %poke %chat-action !>(act)]~
::
++ poke-chat-hook-action
|= act=chat-hook-action
^- (quip move _this)
^- (quip card _state)
?- -.act
%add-owned
?> (team:title our.bol src.bol)
=/ chat-path [%mailbox path.act]
?: (~(has by synced) path.act)
[~ this]
[~ state]
=: synced (~(put by synced) path.act our.bol)
allow-history (~(put by allow-history) path.act allow-history.act)
==
:_ (track-bone chat-path)
:_ state
%+ weld
[ost.bol %peer chat-path [our.bol %chat-store] chat-path]~
[%pass chat-path %agent [our.bol %chat-store] %watch chat-path]~
(create-permission [%chat path.act] security.act)
::
%add-synced
?> (team:title our.bol src.bol)
=/ chat-path=path [%mailbox (scot %p ship.act) path.act]
?: (~(has by synced) [(scot %p ship.act) path.act])
[~ this]
[~ state]
=. synced (~(put by synced) [(scot %p ship.act) path.act] ship.act)
=/ history=path ?:(ask-history.act /0 /~)
:_ (track-bone chat-path)
[ost.bol %peer chat-path [ship.act %chat-hook] (weld chat-path history)]~
?. ask-history.act
=/ chat-path [%mailbox (scot %p ship.act) path.act]
:_ state
[%pass chat-path %agent [ship.act %chat-hook] %watch chat-path]~
:: TODO: only ask for backlog from previous point
=/ chat-history [%backlog (scot %p ship.act) (weld path.act /0)]
:_ state
[%pass chat-history %agent [ship.act %chat-hook] %watch chat-history]~
::
%remove
=/ ship (~(get by synced) path.act)
?~ ship
[~ this]
[~ state]
?: &(=(u.ship our.bol) (team:title our.bol src.bol))
:: delete one of our.bol own paths
:_ %_ this
synced (~(del by synced) path.act)
boned (~(del by boned) [%mailbox path.act])
==
:_ state(synced (~(del by synced) path.act))
%- zing
:~ (pull-wire [%mailbox path.act])
:~ (pull-wire [%backlog (weld path.act /0)])
(pull-wire [%mailbox path.act])
(delete-permission [%chat path.act])
^- (list move)
%+ turn (prey:pubsub:userlib [%mailbox path.act] bol)
|= [=bone *]
[bone %quit ~]
[%give %kick `[%mailbox path.act] ~]~
==
?. |(=(u.ship src.bol) (team:title our.bol src.bol))
:: if neither ship = source or source = us, do nothing
[~ this]
[~ state]
:: delete a foreign ship's path
:- (pull-wire [%mailbox path.act])
%_ this
synced (~(del by synced) path.act)
boned (~(del by boned) [%mailbox path.act])
==
state(synced (~(del by synced) path.act))
==
::
++ peer-mailbox
++ watch-mailbox
|= pax=path
^- (quip move _this)
^- (list card)
?> ?=(^ pax)
?> (~(has by synced) pax)
:: scry permissions to check if read is permitted
?> (permitted-scry [(scot %p src.bol) %chat (weld pax /read)])
=/ box (chat-scry pax)
?~ box !!
[%give %fact ~ %chat-update !>([%create (slav %p i.pax) pax])]~
::
++ watch-backlog
|= pax=path
^- (list card)
?> ?=(^ pax)
=/ last (dec (lent pax))
=/ backlog-start=(unit @ud)
%+ rush
(snag last `(list @ta)`pax)
dem:ag
=> .(pax `path`(oust [last 1] `(list @ta)`pax))
?> ?=([* ^] pax)
?> (~(has by synced) pax)
=/ pas `path`(oust [last 1] `(list @ta)`pax)
?> ?=([* ^] pas)
?> (~(has by synced) pas)
:: scry permissions to check if read is permitted
?> (permitted-scry [(scot %p src.bol) %chat (weld pax /read)])
=/ box (chat-scry pax)
?> (permitted-scry [(scot %p src.bol) %chat (weld pas /read)])
=/ box (chat-scry pas)
?~ box !!
:_ this
:- [ost.bol %diff %chat-update [%create (slav %p i.pax) pax]]
?: ?&(?=(^ backlog-start) (~(got by allow-history) pax))
(paginate-messages pax u.box u.backlog-start)
~
:- [%give %fact ~ %chat-update !>([%create (slav %p i.pas) pas])]
%- zing
:~
?: ?&(?=(^ backlog-start) (~(got by allow-history) pas))
(paginate-messages pas u.box u.backlog-start)
~
[%give %kick `[%backlog pax] `src.bol]~
==
::
++ paginate-messages
|= [=path =mailbox start=@ud]
^- (list move)
=/ moves=(list move) ~
^- (list card)
=/ cards=(list card) ~
=/ end (lent envelopes.mailbox)
?: |((gte start end) =(end 0))
moves
cards
=. envelopes.mailbox (slag start `(list envelope)`envelopes.mailbox)
|- ^- (list move)
|- ^- (list card)
?~ envelopes.mailbox
moves
cards
?: (lte end 5.000)
=. moves
%+ snoc moves
%- messages-move
=. cards
%+ snoc cards
%- messages-fact
[path start (lent envelopes.mailbox) envelopes.mailbox]
$(envelopes.mailbox ~)
=. moves
%+ snoc moves
%- messages-move
=. cards
%+ snoc cards
%- messages-fact
:^ path start
(add start 5.000)
(scag 5.000 `(list envelope)`envelopes.mailbox)
@ -233,168 +260,161 @@
==
$(envelopes.mailbox (slag 5.000 `(list envelope)`envelopes.mailbox))
::
++ messages-move
|= [=path start=@ud end=@ud envelopes=(list envelope)]
^- move
[ost.bol %diff %chat-two-update [%messages path start end envelopes]]
::
++ diff-invite-update
|= [wir=wire diff=invite-update]
^- (quip move _this)
?+ -.diff
[~ this]
++ fact-invite-update
|= [wir=wire fact=invite-update]
^- (quip card _state)
?+ -.fact
[~ state]
::
%accepted
=/ ask-history
?~ (chat-scry [(scot %p ship.invite.diff) path.invite.diff])
?~ (chat-scry [(scot %p ship.invite.fact) path.invite.fact])
%.y
%.n
:_ this
[(chat-view-poke [%join ship.invite.diff path.invite.diff ask-history])]~
:_ state
[(chat-view-poke [%join ship.invite.fact path.invite.fact ask-history])]~
==
::
++ diff-permission-update
|= [wir=wire diff=permission-update]
^- (quip move _this)
:_ this
?- -.diff
++ fact-permission-update
|= [wir=wire fact=permission-update]
^- (quip card _state)
:_ state
?- -.fact
%create ~
%delete ~
%add (handle-permissions [%add path.diff who.diff])
%remove (handle-permissions [%remove path.diff who.diff])
%add (handle-permissions [%add path.fact who.fact])
%remove (handle-permissions [%remove path.fact who.fact])
==
::
++ handle-permissions
|= [kind=?(%add %remove) pax=path who=(set ship)]
^- (list move)
^- (list card)
?> ?=([* *] pax)
?. =(%chat i.pax) ~
:: check path to see if this is a %read permission
?. =(%read (snag (dec (lent pax)) `(list @t)`pax))
~
=/ sup
%- ~(gas by *(map [ship path] bone))
%+ turn ~(tap by sup.bol)
|=([=bone anchor=[ship path]] [anchor bone])
%- zing
%+ turn ~(tap in who)
|= check-ship=ship
?: (permitted-scry [(scot %p check-ship) pax])
|= =ship
?: (permitted-scry [(scot %p ship) pax])
~
:: if ship is not permitted, quit their subscription
:: if ship is not permitted, kick their subscription
=/ mail-path
(oust [(dec (lent t.pax)) (lent t.pax)] `(list @t)`t.pax)
=/ bne (~(get by sup) [check-ship [%mailbox mail-path]])
?~(bne ~ [u.bne %quit ~]~)
[%give %kick `[%mailbox mail-path] `ship]~
::
++ diff-chat-two-update
|= [wir=wire diff=chat-two-update]
^- (quip move _this)
:: local
++ fact-chat-update
|= [wir=wire fact=chat-update]
^- (quip card _state)
?: (team:title our.bol src.bol)
:_ this
%+ turn (prey:pubsub:userlib [%mailbox path.diff] bol)
|= [=bone *]
^- move
[bone %diff [%chat-two-update diff]]
:: foreign
:_ this
?> ?=([* ^] path.diff)
=/ shp (~(get by synced) path.diff)
?~ shp ~
?. =(src.bol u.shp) ~
[(chat-poke [%messages path.diff envelopes.diff])]~
::
++ diff-chat-update
|= [wir=wire diff=chat-update]
^- (quip move _this)
?: (team:title our.bol src.bol)
(handle-local diff)
(handle-foreign diff)
(handle-local fact)
(handle-foreign fact)
::
++ handle-local
|= diff=chat-update
^- (quip move _this)
?- -.diff
%keys [~ this]
%config [~ this]
%create [~ this]
%read [~ this]
|= fact=chat-update
^- (quip card _state)
?- -.fact
%keys [~ state]
%read [~ state]
%config [~ state]
%create [~ state]
%delete
?. (~(has by synced) path.diff)
[~ this]
:_ this(synced (~(del by synced) path.diff))
[ost.bol %pull [%mailbox path.diff] [our.bol %chat-store] ~]~
?. (~(has by synced) path.fact)
[~ state]
:_ state(synced (~(del by synced) path.fact))
[%pass [%mailbox path.fact] %agent [our.bol %chat-store] %leave ~]~
::
%message
:_ this
%+ turn (prey:pubsub:userlib [%mailbox path.diff] bol)
|= [=bone *]
^- move
[bone %diff [%chat-update diff]]
:_ state
[%give %fact `[%mailbox path.fact] %chat-update !>(fact)]~
::
%messages
:_ state
[%give %fact `[%mailbox path.fact] %chat-update !>(fact)]~
==
::
++ handle-foreign
|= diff=chat-update
^- (quip move _this)
?- -.diff
%keys [~ this]
%config [~ this]
%read [~ this]
|= fact=chat-update
^- (quip card _state)
?- -.fact
%keys [~ state]
%read [~ state]
%config [~ state]
%create
:_ this
?> ?=([* ^] path.diff)
=/ shp (~(get by synced) path.diff)
:_ state
?> ?=([* ^] path.fact)
=/ shp (~(get by synced) path.fact)
?~ shp ~
?. =(src.bol u.shp) ~
[(chat-poke [%create ship.diff t.path.diff])]~
[(chat-poke [%create ship.fact t.path.fact])]~
::
%delete
?> ?=([* ^] path.diff)
=/ shp (~(get by synced) path.diff)
?> ?=([* ^] path.fact)
=/ shp (~(get by synced) path.fact)
?~ shp
[~ this]
[~ state]
?. =(u.shp src.bol)
[~ this]
:_ this(synced (~(del by synced) path.diff))
:- (chat-poke [%delete path.diff])
[ost.bol %pull [%mailbox path.diff] [src.bol %chat-hook] ~]~
[~ state]
:_ state(synced (~(del by synced) path.fact))
:- (chat-poke [%delete path.fact])
[%pass [%mailbox path.fact] %agent [src.bol %chat-hook] %leave ~]~
::
%message
:_ this
?> ?=([* ^] path.diff)
=/ shp (~(get by synced) path.diff)
:_ state
?> ?=([* ^] path.fact)
=/ shp (~(get by synced) path.fact)
?~ shp ~
?. =(src.bol u.shp) ~
[(chat-poke [%message path.diff envelope.diff])]~
[(chat-poke [%message path.fact envelope.fact])]~
::
%messages
:_ state
?> ?=([* ^] path.fact)
=/ shp (~(get by synced) path.fact)
?~ shp ~
?. =(src.bol u.shp) ~
[(chat-poke [%messages path.fact envelopes.fact])]~
==
::
++ quit
++ kick
|= wir=wire
^- (quip move _this)
~& chat-hook-quit+wir
^- (quip card _state)
?: =(wir /permissions)
:_ this
[ost.bol %peer /permissions [our.bol %permission-store] /updates]~
?> ?=([* ^] wir)
?. (~(has by synced) t.wir)
:: no-op
[~ this]
=/ mailbox (chat-scry t.wir)
?~ mailbox [~ this]
~& %chat-hook-resubscribe
=/ pax=path (weld wir /(scot %ud (lent envelopes.u.mailbox)))
~& pax
:_ (track-bone wir)
[ost.bol %peer wir [(slav %p i.t.wir) %chat-hook] pax]~
:_ state
[%pass /permissions %agent [our.bol %permission-store] %watch /updates]~
::
?: ?=([%mailbox @ *] wir)
~& mailbox-kick+wir
?. (~(has by synced) t.wir)
:: no-op
[~ state]
~& %chat-hook-resubscribe
=/ =ship (~(got by synced) t.wir)
=/ mailbox=(unit mailbox) (chat-scry t.wir)
=/ chat-history
%+ welp backlog+t.wir
?~ mailbox
/0
/(scot %ud (lent envelopes.u.mailbox))
:_ state
[%pass chat-history %agent [ship %chat-hook] %watch chat-history]~
::
?: ?=([%backlog @ *] wir)
=/ pax `path`(oust [(dec (lent t.wir)) 1] `(list @ta)`t.wir)
=/ mailbox=(unit mailbox) (chat-scry pax)
=. pax ?~(mailbox wir [%mailbox pax])
:_ state
[%pass pax %agent [(slav %p i.t.wir) %chat-hook] %watch pax]~
!!
::
++ reap
++ watch-ack
|= [wir=wire saw=(unit tang)]
^- (quip move _this)
^- (quip card _state)
?~ saw
[~ this]
[~ state]
?> ?=(^ wir)
:_ this(synced (~(del by synced) t.wir))
:_ state(synced (~(del by synced) t.wir))
%. ~
%- slog
:* leaf+"chat-hook failed subscribe on {(spud t.wir)}"
@ -404,27 +424,32 @@
::
++ chat-poke
|= act=chat-action
^- move
[ost.bol %poke / [our.bol %chat-store] [%chat-action act]]
^- card
[%pass / %agent [our.bol %chat-store] %poke %chat-action !>(act)]
::
++ chat-view-poke
|= act=chat-view-action
^- move
[ost.bol %poke / [our.bol %chat-view] [%chat-view-action act]]
^- card
[%pass / %agent [our.bol %chat-view] %poke %chat-view-action !>(act)]
::
++ permission-poke
|= act=permission-action
^- move
[ost.bol %poke / [our.bol %permission-store] [%permission-action act]]
^- card
[%pass / %agent [our.bol %permission-store] %poke %permission-action !>(act)]
::
++ invite-poke
|= act=invite-action
^- move
[ost.bol %poke / [our.bol %invite-store] [%invite-action act]]
^- card
[%pass / %agent [our.bol %invite-store] %poke %invite-action !>(act)]
::
++ messages-fact
|= [=path start=@ud end=@ud envelopes=(list envelope)]
^- card
[%give %fact ~ %chat-update !>([%messages path start end envelopes])]
::
++ create-permission
|= [pax=path sec=rw-security]
^- (list move)
^- (list card)
=/ read-perm (weld pax /read)
=/ write-perm (weld pax /write)
?- sec
@ -451,7 +476,7 @@
::
++ delete-permission
|= pax=path
^- (list move)
^- (list card)
=/ read-perm (weld pax /read)
=/ write-perm (weld pax /write)
:~ (permission-poke [%delete read-perm])
@ -480,27 +505,13 @@
^- ?
.^(? %gx ;:(weld /=permission-store/(scot %da now.bol)/permitted pax /noun))
::
++ track-bone
|= wir=wire
^+ this
=/ bnd (~(get by boned) wir)
?^ bnd
this(boned (~(put by boned) wir (snoc u.bnd ost.bol)))
this(boned (~(put by boned) wir [ost.bol]~))
::
++ pull-wire
|= pax=path
^- (list move)
^- (list card)
?> ?=(^ pax)
=/ bnd (~(get by boned) pax)
?~ bnd ~
=/ shp (~(get by synced) t.pax)
?~ shp ~
%+ turn u.bnd
|= =bone
^- move
?: =(u.shp our.bol)
[bone %pull pax [our.bol %chat-store] ~]
[bone %pull pax [u.shp %chat-hook] ~]
::
[%pass pax %agent [our.bol %chat-store] %leave ~]~
[%pass pax %agent [u.shp %chat-hook] %leave ~]~
--

251
pkg/arvo/app/chat-store.hoon
View File

@ -1,80 +1,115 @@
:: chat-store: data store that holds linear sequences of chat messages
::
/+ *chat-json, *chat-eval
/+ *chat-json, *chat-eval, default-agent
|%
+$ move [bone card]
::
+$ card
$% [%diff diff]
[%quit ~]
==
::
+$ state
$% [%0 state-zero]
+$ card card:agent:gall
+$ versioned-state
$% state-zero
==
::
+$ state-zero
$: =inbox
$: %0
=inbox
==
::
+$ diff
$% [%chat-initial inbox]
[%chat-configs chat-configs]
[%chat-update chat-update]
[%chat-two-update chat-two-update]
==
--
::
|_ [bol=bowl:gall state]
=| state-zero
=* state -
^- agent:gall
=<
|_ =bowl:gall
+* this .
chat-core +>
cc ~(. chat-core bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(state-zero old))
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?> (team:title our.bowl src.bowl)
=^ cards state
?+ mark (on-poke:def mark vase)
%json (poke-json:cc !<(json vase))
%chat-action (poke-chat-action:cc !<(chat-action vase))
==
[cards this]
::
++ on-watch
|= =path
^- (quip card _this)
?> (team:title our.bowl src.bowl)
|^
=/ cards=(list card)
?+ path (on-watch:def path)
[%keys ~] (give %chat-update !>([%keys ~(key by inbox)]))
[%all ~] (give %chat-initial !>(inbox))
[%configs ~] (give %chat-configs !>((inbox-to-configs inbox)))
[%updates ~] ~
[%mailbox @ *]
?> (~(has by inbox) t.path)
=/ =ship (slav %p i.t.path)
(give %chat-update !>([%create ship t.t.path]))
==
[cards this]
::
++ give
|= =cage
^- (list card)
[%give %fact ~ cage]~
--
::
++ on-leave on-leave:def
++ on-peek
|= =path
^- (unit (unit cage))
?+ path (on-peek:def path)
[%x %all ~] ``noun+!>(inbox)
[%x %configs ~] ``noun+!>((inbox-to-configs inbox))
[%x %keys ~] ``noun+!>(~(key by inbox))
[%x %envelopes ~] (peek-x-envelopes:cc t.t.path)
[%x %mailbox *]
?~ t.t.path
~
``noun+!>((~(get by inbox) t.t.path))
::
[%x %config *]
?~ t.t.path
~
=/ mailbox (~(get by inbox) t.t.path)
?~ mailbox
~
``noun+!>(config.u.mailbox)
==
::
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
++ this .
::
++ prep
|= old=(unit state)
^- (quip move _this)
[~ ?~(old this this(+<+ u.old))]
::
++ peek-x-all
|= pax=path
^- (unit (unit [%noun (map path mailbox)]))
[~ ~ %noun inbox]
::
++ peek-x-configs
|= pax=path
^- (unit (unit [%noun chat-configs]))
:^ ~ ~ %noun
(inbox-to-configs inbox)
::
++ peek-x-keys
|= pax=path
^- (unit (unit [%noun (set path)]))
[~ ~ %noun ~(key by inbox)]
::
++ peek-x-mailbox
|= pax=path
^- (unit (unit [%noun (unit mailbox)]))
?~ pax ~
=/ mailbox=(unit mailbox) (~(get by inbox) pax)
[~ ~ %noun mailbox]
::
++ peek-x-config
|= pax=path
^- (unit (unit [%noun config]))
?~ pax ~
=/ mailbox (~(get by inbox) pax)
?~ mailbox ~
:^ ~ ~ %noun
config.u.mailbox
|_ bol=bowl:gall
::
++ peek-x-envelopes
|= pax=path
^- (unit (unit [%noun (list envelope)]))
^- (unit (unit [%noun vase]))
?+ pax ~
[@ @ *]
=/ mail-path t.t.pax
=/ mailbox (~(get by inbox) mail-path)
?~ mailbox
[~ ~ %noun ~]
[~ ~ %noun !>(~)]
=* envelopes envelopes.u.mailbox
=/ sign-test=[?(%neg %pos) @]
%- need
@ -94,66 +129,24 @@
=* start +.sign-test
?: =(-.sign-test %neg)
?: (gth start length)
[~ ~ %noun envelopes]
[~ ~ %noun (swag [(sub length start) start] envelopes)]
[~ ~ %noun !>(envelopes)]
[~ ~ %noun !>((swag [(sub length start) start] envelopes))]
::
=/ end (slav %ud i.t.pax)
?. (lte start end)
~
=. end ?:((lth end length) end length)
[~ ~ %noun (swag [start (sub end start)] envelopes)]
[~ ~ %noun !>((swag [start (sub end start)] envelopes))]
==
::
++ peer-keys
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
:: we send the list of keys then send events when they change
:_ this
[ost.bol %diff %chat-update [%keys ~(key by inbox)]]~
::
++ peer-all
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
:_ this
[ost.bol %diff %chat-initial inbox]~
::
++ peer-configs
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
:_ this
[ost.bol %diff %chat-configs (inbox-to-configs inbox)]~
::
++ peer-updates
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
:: we now proxy all events to this path
[~ this]
::
++ peer-mailbox
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
?> (~(has by inbox) pax)
=^ =ship pax
?> ?=([* ^] pax)
[(slav %p i.pax) t.pax]
:_ this
[ost.bol %diff %chat-update [%create ship pax]]~
::
++ poke-json
|= jon=json
^- (quip move _this)
?> (team:title our.bol src.bol)
^- (quip card _state)
(poke-chat-action (json-to-action jon))
::
++ poke-chat-action
|= action=chat-action
^- (quip move _this)
?> (team:title our.bol src.bol)
^- (quip card _state)
?- -.action
%create (handle-create action)
%delete (handle-delete action)
@ -164,48 +157,48 @@
::
++ handle-create
|= act=chat-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%create -.act)
=/ pax [(scot %p ship.act) path.act]
?: (~(has by inbox) pax)
[~ this]
[~ state]
:- (send-diff pax act)
this(inbox (~(put by inbox) pax *mailbox))
state(inbox (~(put by inbox) pax *mailbox))
::
++ handle-delete
|= act=chat-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%delete -.act)
=/ mailbox=(unit mailbox) (~(get by inbox) path.act)
?~ mailbox
[~ this]
[~ state]
:- (send-diff path.act act)
this(inbox (~(del by inbox) path.act))
state(inbox (~(del by inbox) path.act))
::
++ handle-message
|= act=chat-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%message -.act)
=/ mailbox=(unit mailbox) (~(get by inbox) path.act)
?~ mailbox
[~ this]
[~ state]
=. letter.envelope.act (evaluate-letter letter.envelope.act)
=. u.mailbox (append-envelope u.mailbox envelope.act)
:- (send-diff path.act act)
this(inbox (~(put by inbox) path.act u.mailbox))
state(inbox (~(put by inbox) path.act u.mailbox))
::
++ handle-messages
|= act=chat-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%messages -.act)
=/ mailbox=(unit mailbox) (~(get by inbox) path.act)
?~ mailbox
[~ this]
[~ state]
=/ evaluated-envelopes=(list envelope) ~
|- ^- (quip move _this)
|- ^- (quip card _state)
?~ envelopes.act
:_ this(inbox (~(put by inbox) path.act u.mailbox))
%+ send-two-diff path.act
:_ state(inbox (~(put by inbox) path.act u.mailbox))
%+ send-diff path.act
:* %messages
path.act
(sub length.config.u.mailbox (lent evaluated-envelopes))
@ -219,14 +212,14 @@
::
++ handle-read
|= act=chat-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%read -.act)
=/ mailbox=(unit mailbox) (~(get by inbox) path.act)
?~ mailbox
[~ this]
[~ state]
=. read.config.u.mailbox length.config.u.mailbox
:- (send-diff path.act act)
this(inbox (~(put by inbox) path.act u.mailbox))
state(inbox (~(put by inbox) path.act u.mailbox))
::
++ evaluate-letter
|= =letter
@ -246,15 +239,13 @@
mailbox
::
++ update-subscribers
|= [pax=path upd=chat-update]
^- (list move)
%+ turn (prey:pubsub:userlib pax bol)
|= [=bone *]
[bone %diff %chat-update upd]
|= [pax=path update=chat-update]
^- (list card)
[%give %fact `pax %chat-update !>(update)]~
::
++ send-diff
|= [pax=path upd=chat-update]
^- (list move)
^- (list card)
%- zing
:~ (update-subscribers /all upd)
(update-subscribers /updates upd)
@ -266,20 +257,4 @@
~
(update-subscribers /keys upd)
==
::
++ send-two-diff
|= [pax=path upd=chat-two-update]
^- (list move)
%- zing
:~ (update-two-subscribers /all upd)
(update-two-subscribers /updates upd)
(update-two-subscribers [%mailbox pax] upd)
==
::
++ update-two-subscribers
|= [pax=path upd=chat-two-update]
^- (list move)
%+ turn (prey:pubsub:userlib pax bol)
|= [=bone *]
[bone %diff %chat-two-update upd]
--

311
pkg/arvo/app/chat-view.hoon
View File

@ -6,7 +6,7 @@
*group-store,
*permission-group-hook,
*chat-hook
/+ *server, *chat-json
/+ *server, *chat-json, default-agent
/= index
/^ octs
/; as-octs:mimes:html
@ -40,17 +40,7 @@
/: /===/app/chat/img /_ /png/
::
|%
::
+$ move [bone card]
::
+$ card
$% [%http-response =http-event:http]
[%connect wire binding:eyre term]
[%peer wire dock path]
[%poke wire dock poke]
[%diff %json json]
[%quit ~]
==
+$ card card:agent:gall
::
+$ poke
$% [%launch-action [@tas path @t]]
@ -61,103 +51,155 @@
[%permission-group-hook-action permission-group-hook-action]
==
--
::
|_ [bol=bowl:gall ?]
::
++ this .
::
++ prep
|= old=(unit ?)
^- (quip move _this)
?~ old
^- agent:gall
=<
|_ bol=bowl:gall
+* this .
chat-core +>
cc ~(. chat-core bol)
def ~(. (default-agent this %|) bol)
::
++ on-init
^- (quip card _this)
=/ launcha [%launch-action !>([%chat-view /configs '/~chat/js/tile.js'])]
:_ this
:~ [ost.bol %peer / [our.bol %chat-store] /updates]
[ost.bol %connect / [~ /'~chat'] %chat-view]
(launch-poke [/configs '/~chat/js/tile.js'])
:~ [%pass /updates %agent [our.bol %chat-store] %watch /updates]
[%pass / %arvo %e %connect [~ /'~chat'] %chat-view]
[%pass /chat-view %agent [our.bol %launch] %poke launcha]
==
[~ this(+<+ u.old)]
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?> (team:title our.bol src.bol)
?+ mark (on-poke:def mark vase)
%handle-http-request
=+ !<([eyre-id=@ta =inbound-request:eyre] vase)
:_ this
%+ give-simple-payload:app eyre-id
%+ require-authorization:app inbound-request
poke-handle-http-request:cc
::
%json
:_ this
(poke-chat-view-action:cc (json-to-view-action !<(json vase)))
::
%chat-view-action
:_ this
(poke-chat-view-action:cc !<(chat-view-action vase))
==
::
++ on-watch
|= =path
^- (quip card _this)
?> (team:title our.bol src.bol)
|^
?: ?=([%http-response *] path)
[~ this]
?: =(/primary path)
:: create inbox with 100 messages max per mailbox and send that along
:: then quit the subscription
:_ this
[%give %fact ~ %json !>((inbox-to-json truncated-inbox-scry))]~
?: =(/configs path)
[[%give %fact ~ %json !>(*json)]~ this]
(on-watch:def path)
::
++ truncated-inbox-scry
^- inbox
=/ =inbox .^(inbox %gx /=chat-store/(scot %da now.bol)/all/noun)
%- ~(run by inbox)
|= =mailbox
^- ^mailbox
[config.mailbox (truncate-envelopes envelopes.mailbox)]
::
++ truncate-envelopes
|= envelopes=(list envelope)
^- (list envelope)
=/ length (lent envelopes)
?: (lth length 100)
envelopes
(swag [(sub length 100) 100] envelopes)
--
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
?+ -.sign (on-agent:def wire sign)
%kick
:_ this
[%pass / %agent [our.bol %chat-store] %watch /updates]~
::
%fact
?+ p.cage.sign (on-agent:def wire sign)
%chat-update
:_ this
(diff-chat-update:cc !<(chat-update q.cage.sign))
==
==
::
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card _this)
?. ?=(%bound +<.sign-arvo)
(on-arvo:def wire sign-arvo)
[~ this]
::
++ on-save on-save:def
++ on-load on-load:def
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-fail on-fail:def
--
::
++ bound
|= [wir=wire success=? binding=binding:eyre]
^- (quip move _this)
[~ this]
::
|_ bol=bowl:gall
::
++ poke-handle-http-request
%- (require-authorization:app ost.bol move this)
|= =inbound-request:eyre
^- (quip move _this)
::
^- simple-payload:http
=+ url=(parse-request-line url.request.inbound-request)
=/ name=@t
=+ back-path=(flop site.url)
?~ back-path
''
i.back-path
?: =(name 'tile')
[[ost.bol %http-response (js-response:app tile-js)]~ this]
?+ site.url
:_ this
[ost.bol %http-response not-found:app]~
?+ site.url not-found:gen
[%'~chat' %css %index ~] (css-response:gen style)
[%'~chat' %js %tile ~] (js-response:gen tile-js)
[%'~chat' %js %index ~] (js-response:gen script)
::
:: styling
[%'~chat' %img @t *]
=/ name=@t i.t.t.site.url
=/ img (~(get by chat-png) name)
?~ img
not-found:gen
(png-response:gen (as-octs:mimes:html u.img))
::
[%'~chat' %css %index ~]
:_ this
[ost.bol %http-response (css-response:app style)]~
::
:: javascript
::
[%'~chat' %js %index ~]
:_ this
[ost.bol %http-response (js-response:app script)]~
::
:: images
::
[%'~chat' %img *]
=/ img (as-octs:mimes:html (~(got by chat-png) `@ta`name))
:_ this
[ost.bol %http-response (png-response:app img)]~
::
[%'~chat' %paginate @t @t *]
[%'~chat' %paginate @t @t *]
=/ start (need (rush i.t.t.site.url dem))
=/ end (need (rush i.t.t.t.site.url dem))
=/ pax t.t.t.t.site.url
=/ envelopes (envelope-scry [(scot %ud start) (scot %ud end) pax])
:_ this
:~
:+ ost.bol
%http-response
%- json-response:app
%- json-to-octs
%- two-update-to-json
[%messages pax start end envelopes]
==
%- json-response:gen
%- json-to-octs
%- update-to-json
[%messages pax start end envelopes]
::
:: inbox page
::
[%'~chat' *]
:_ this
[ost.bol %http-response (html-response:app index)]~
[%'~chat' *] (html-response:gen index)
==
::
++ poke-json
|= jon=json
^- (quip move _this)
^- (list card)
?. =(src.bol our.bol)
[~ this]
~
(poke-chat-view-action (json-to-view-action jon))
::
++ poke-chat-view-action
|= act=chat-view-action
^- (quip move _this)
^- (list card)
?. =(src.bol our.bol)
[~ this]
~
?- -.act
%create
=/ pax [(scot %p our.bol) path.act]
=/ group-read=path [%chat (weld pax /read)]
=/ group-write=path [%chat (weld pax /write)]
:_ this
%- zing
:~ :~ (group-poke [%bundle group-read])
(group-poke [%bundle group-write])
@ -175,7 +217,6 @@
%delete
=/ group-read [%chat (weld path.act /read)]
=/ group-write [%chat (weld path.act /write)]
:_ this
:~ (chat-hook-poke [%remove path.act])
(permission-hook-poke [%remove group-read])
(permission-hook-poke [%remove group-write])
@ -187,97 +228,51 @@
%join
=/ group-read [%chat (scot %p ship.act) (weld path.act /read)]
=/ group-write [%chat (scot %p ship.act) (weld path.act /write)]
:_ this
:~ (chat-hook-poke [%add-synced ship.act path.act ask-history.act])
(permission-hook-poke [%add-synced ship.act group-write])
(permission-hook-poke [%add-synced ship.act group-read])
==
::
==
::
++ peer-primary
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
:: create inbox with 100 messages max per mailbox and send that along
:: then quit the subscription
:_ this
[ost.bol %diff %json (inbox-to-json (truncate-inbox all-scry))]~
::
++ peer-configs
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
:_ this
[ost.bol %diff %json *json]~
::
++ diff-chat-update
|= [wir=wire upd=chat-update]
^- (quip move _this)
|= upd=chat-update
^- (list card)
=/ updates-json (update-to-json upd)
=/ configs-json (configs-to-json configs-scry)
:_ this
%+ weld
%+ turn (prey:pubsub:userlib /primary bol)
|= [=bone *]
[bone %diff %json updates-json]
%+ turn (prey:pubsub:userlib /configs bol)
|= [=bone *]
[bone %diff %json configs-json]
::
++ diff-chat-two-update
|= [wir=wire upd=chat-two-update]
^- (quip move _this)
=/ updates-json (two-update-to-json upd)
=/ configs-json (configs-to-json configs-scry)
:_ this
%+ weld
%+ turn (prey:pubsub:userlib /primary bol)
|= [=bone *]
[bone %diff %json updates-json]
%+ turn (prey:pubsub:userlib /configs bol)
|= [=bone *]
[bone %diff %json configs-json]
::
++ quit
|= wir=wire
^- (quip move _this)
:_ this
[ost.bol %peer / [our.bol %chat-store] /updates]~
:~ [%give %fact `/primary %json !>(updates-json)]
[%give %fact `/configs %json !>(configs-json)]
==
::
:: +utilities
::
++ launch-poke
|= [=path =cord]
^- move
[ost.bol %poke / [our.bol %launch] [%launch-action %chat-view path cord]]
::
++ chat-poke
|= act=chat-action
^- move
[ost.bol %poke / [our.bol %chat-store] [%chat-action act]]
^- card
[%pass / %agent [our.bol %chat-store] %poke %chat-action !>(act)]
::
++ group-poke
|= act=group-action
^- move
[ost.bol %poke / [our.bol %group-store] [%group-action act]]
^- card
[%pass / %agent [our.bol %group-store] %poke %group-action !>(act)]
::
++ chat-hook-poke
|= act=chat-hook-action
^- move
[ost.bol %poke / [our.bol %chat-hook] [%chat-hook-action act]]
^- card
[%pass / %agent [our.bol %chat-hook] %poke %chat-hook-action !>(act)]
::
++ permission-hook-poke
|= act=permission-hook-action
^- move
[ost.bol %poke / [our.bol %permission-hook] [%permission-hook-action act]]
^- card
:* %pass / %agent [our.bol %permission-hook]
%poke %permission-hook-action !>(act)
==
::
++ perm-group-hook-poke
|= act=permission-group-hook-action
^- move
=/ pok [%permission-group-hook-action act]
[ost.bol %poke / [our.bol %permission-group-hook] pok]
^- card
:* %pass / %agent [our.bol %permission-group-hook]
%poke %permission-group-hook-action !>(act)
==
::
++ envelope-scry
|= pax=path
@ -285,17 +280,13 @@
=. pax ;:(weld /=chat-store/(scot %da now.bol)/envelopes pax /noun)
.^((list envelope) %gx pax)
::
++ all-scry
^- inbox
.^(inbox %gx /=chat-store/(scot %da now.bol)/all/noun)
::
++ configs-scry
^- chat-configs
.^(chat-configs %gx /=chat-store/(scot %da now.bol)/configs/noun)
::
++ create-security
|= [pax=path sec=rw-security]
^- (list move)
^- (list card)
=/ read (weld pax /read)
=/ write (weld pax /write)
?- sec
@ -318,23 +309,5 @@
:~ (perm-group-hook-poke [%associate read [[read %white] ~ ~]])
(perm-group-hook-poke [%associate write [[write %black] ~ ~]])
==
::
==
::
++ truncate-envelopes
|= envelopes=(list envelope)
^- (list envelope)
=/ length (lent envelopes)
?: (lth length 100)
envelopes
(swag [(sub length 100) 100] envelopes)
::
++ truncate-inbox
|= box=inbox
^- inbox
%- ~(run by box)
|= mail=mailbox
^- mailbox
:- config.mail
(truncate-envelopes envelopes.mail)
--

3
pkg/arvo/app/chat/css/index.css
View File

File diff suppressed because one or more lines are too long

BIN
pkg/arvo/app/chat/img/ChatSwitcherClosed.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 866 B

BIN
pkg/arvo/app/chat/img/ChatSwitcherLink.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 861 B

BIN
pkg/arvo/app/chat/img/popout.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 854 B

BIN
pkg/arvo/app/chat/img/touch_icon.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 10 KiB

13
pkg/arvo/app/chat/index.html
View File

@ -5,8 +5,21 @@
<meta charset="utf-8" />
<meta name="viewport"
content="width=device-width, initial-scale=1, shrink-to-fit=no"/>
<meta name="apple-mobile-web-app-capable" content="yes" />
<meta name="apple-touch-fullscreen" content="yes" />
<meta name="apple-mobile-web-app-status-bar-style" content="default" />
<link rel="apple-touch-icon" href="/~chat/img/touch_icon.png">
<link rel="stylesheet" href="/~chat/css/index.css" />
<link rel="icon" type="image/png" href="/~launch/img/Favicon.png">
<link rel="manifest"
href='data:application/manifest+json,{
"name": "Chat",
"short_name": "Chat",
"description": "A%20Chat%20application%20for%20your%20Urbit%20ship.",
"display": "standalone",
"background_color": "%23FFFFFF",
"theme_color": "%23000000"}' />
</head>
<body>
<div id="root" />

2
pkg/arvo/app/chat/js/index.js
View File

File diff suppressed because one or more lines are too long

2
pkg/arvo/app/chat/js/tile.js
View File

File diff suppressed because one or more lines are too long

1150
pkg/arvo/app/claz.hoon
View File

File diff suppressed because it is too large Load Diff

99
pkg/arvo/app/clock.hoon
View File

@ -1,4 +1,4 @@
/+ *server
/+ *server, default-agent, verb
/= tile-js
/^ octs
/; as-octs:mimes:html
@ -8,61 +8,32 @@
==
=, format
::
|%
:: +move: output effect
%+ verb |
^- agent:gall
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
::
+$ move [bone card]
:: +card: output effect payload
::
+$ poke
$% [%launch-action [@tas path @t]]
==
::
+$ card
$% [%poke wire dock poke]
[%http-response =http-event:http]
[%connect wire binding:eyre term]
[%diff %json json]
==
::
--
::
|_ [bol=bowl:gall ~]
::
++ this .
::
++ bound
|= [wir=wire success=? binding=binding:eyre]
^- (quip move _this)
[~ this]
::
++ prep
|= old=(unit ~)
^- (quip move _this)
++ on-init
^- (quip card:agent:gall _this)
=/ launcha
[%launch-action [%clock /tile '/~clock/js/tile.js']]
[%launch-action !>([%clock /tile '/~clock/js/tile.js'])]
:_ this
:~
[ost.bol %connect / [~ /'~clock'] %clock]
[ost.bol %poke /clock [our.bol %launch] launcha]
:~ [%pass / %arvo %e %connect [~ /'~clock'] %clock]
[%pass /clock %agent [our.bowl %launch] %poke launcha]
==
::
++ peer-tile
|= pax=path
^- (quip move _this)
[[ost.bol %diff %json *json]~ this]
::
++ send-tile-diff
|= jon=json
^- (list move)
%+ turn (prey:pubsub:userlib /tile bol)
|= [=bone ^]
[bone %diff %json jon]
::
++ poke-handle-http-request
%- (require-authorization:app ost.bol move this)
++ on-save on-save:def
++ on-load on-load:def
++ on-poke
|= [=mark =vase]
^- (quip card:agent:gall _this)
?. ?=(%handle-http-request mark)
(on-poke:def mark vase)
=+ !<([eyre-id=@ta =inbound-request:eyre] vase)
:_ this
%+ give-simple-payload:app eyre-id
%+ require-authorization:app inbound-request
|= =inbound-request:eyre
^- (quip move _this)
=/ request-line (parse-request-line url.request.inbound-request)
=/ back-path (flop site.request-line)
=/ name=@t
@ -72,9 +43,29 @@
i.back-path
::
?~ back-path
[[ost.bol %http-response not-found:app]~ this]
not-found:gen
?: =(name 'tile')
[[ost.bol %http-response (js-response:app tile-js)]~ this]
[[ost.bol %http-response not-found:app]~ this]
(js-response:gen tile-js)
not-found:gen
::
++ on-watch
|= =path
^- (quip card:agent:gall _this)
?: ?=([%http-response *] path)
`this
?. =(/tile path)
(on-watch:def path)
[[%give %fact ~ %json !>(*json)]~ this]
::
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-agent on-agent:def
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card:agent:gall _this)
?. ?=(%bound +<.sign-arvo)
(on-arvo:def wire sign-arvo)
[~ this]
::
++ on-fail on-fail:def
--

923
pkg/arvo/app/dns-bind.hoon
View File

@ -1,923 +0,0 @@
/- *dns-bind, dns, hall
/+ tapp, stdio
::
:: tapp types and boilerplate
::
=> |%
++ collector-app `dock`[~zod %dns-collector]
+$ app-state
$: %0
:: nem: authoritative state
::
nem=(unit nameserver)
==
+$ peek-data _!!
+$ in-poke-data
$% [%dns-authority =authority]
[%dns-bind =ship =target]
[%handle-http-request =inbound-request:eyre]
[%handle-http-cancel =inbound-request:eyre]
[%noun noun=*]
==
+$ out-poke-data
$% [%dns-bind =ship =target]
[%dns-complete =ship =binding:dns]
[%drum-unlink =dock]
==
+$ in-peer-data
$% [%dns-request =request:dns]
==
+$ out-peer-data ~
++ tapp
%: ^tapp
app-state
peek-data
in-poke-data
out-poke-data
in-peer-data
out-peer-data
==
++ tapp-async tapp-async:tapp
++ stdio (^stdio out-poke-data out-peer-data)
--
::
:: oauth2 implementation
::
=> |%
:: +oauth2-config: as one would expect
::
+$ oauth2-config
$: auth-url=@t
exchange-url=@t
domain=turf
initial-path=path
redirect-path=path
scopes=(list @t)
==
:: +oauth2: library core
::
++ oauth2
|_ [our=@p now=@da config=oauth2-config code=@t =hart:eyre secrets=@t]
::
++ local-uri
|= [our=ship =path]
^- @t
:: XX can't scry in +mule
::
:: =/ =hart:eyre .^(hart:eyre %e /(scot %p our)/host/real)
(crip (en-purl:html [hart [~ path] ~]))
::
:: XX can't scry in +mule
::
:: ++ code
:: ^- @t
:: %- crip
:: +:(scow %p .^(@p %j /(scot %p our)/code/(scot %da now)/(scot %p our)))
::
:: to initialize these values: |init-oauth2 /com/googleapis
::
++ oauth2-secrets
^- [client-id=@t client-secret=@t]
=; =wain
?> ?=([@t @t ~] wain)
[i.wain i.t.wain]
::
%- to-wain:format
%- need
%+ de:crub:crypto code
%+ slav %uw
:: XX can't scry in +mule
::
:: .^(@ %cx :(weld /(scot %p our)/home/(scot %da now)/sec domain.config /atom))
secrets
::
++ initial-uri (local-uri our initial-path.config)
++ redirect-uri (local-uri our redirect-path.config)
::
++ redirect-to-provider
^- @t
=/ url (need (de-purl:html auth-url.config))
=. r.url
:* ['access_type' 'offline']
['response_type' 'code']
['prompt' 'consent']
['client_id' client-id:oauth2-secrets]
['redirect_uri' redirect-uri]
['scope' (rap 3 (join ' ' scopes.config))]
r.url
==
(crip (en-purl:html url))
::
++ retrieve-access-token
|= code=@t
^- request:http
=/ hed
:~ ['Accept' 'application/json']
['Content-Type' 'application/x-www-form-urlencoded']
==
=/ bod
%- some %- as-octt:mimes:html
%- tail %- tail:en-purl:html
:~ ['client_id' client-id:oauth2-secrets]
:: note: required, unused parameter
::
['redirect_uri' redirect-uri]
['client_secret' client-secret:oauth2-secrets]
['grant_type' 'authorization_code']
['code' code]
==
[%'POST' exchange-url.config hed bod]
::
++ parse-token-response
|= =octs
^- (unit [access=@t expires=@u refresh=@t])
%. q.octs
;~ biff
de-json:html
=, dejs-soft:format
(ot 'access_token'^so 'expires_in'^ni 'refresh_token'^so ~)
==
:: XX implement
::
++ refresh-token !!
--
--
::
:: helpers
::
=> |%
:: +name: fully-qualified domain name for :ship
::
++ name
|= [=ship =turf]
(cat 3 (en-turf:html (weld turf /(crip +:(scow %p ship)))) '.')
:: +lame: domain name for :ship (without trailing '.')
::
++ lame
|= [=ship =turf]
(en-turf:html (weld turf /(crip +:(scow %p ship))))
:: +endpoint: append :path to :purl
::
++ endpoint
|= [=purl:eyre =path]
^+ purl
purl(q.q (weld q.q.purl path))
:: +params: append :params to :purl
::
++ params
|= [=purl:eyre =quay:eyre]
^+ purl
purl(r (weld r.purl quay))
:: +json-octs: deserialize json and apply reparser
::
++ json-octs
|* [bod=octs wit=fist:dejs:format]
=/ jon (de-json:html q.bod)
?~ jon ~
(wit u.jon)
:: +ship-turf: parse ship from first subdomain
::
++ ship-turf
|= [nam=@t aut-dom=turf]
^- (unit ship)
=/ dom=(unit host:eyre)
(rush nam ;~(sfix thos:de-purl:html dot))
?: ?| ?=(~ dom)
?=(%| -.u.dom)
?=(~ p.u.dom)
==
~
=/ who
(rush (head (flop p.u.dom)) fed:ag)
?~ who ~
?. =(aut-dom (flop (tail (flop p.u.dom))))
~
:: galaxies always excluded
::
?: ?=(%czar (clan:title u.who))
~
who
--
::
:: service providers
::
=> |%
:: +provider: initialize provider-specific core
::
++ provider
|= aut=authority
?- -.pro.aut
%fcloud ~(. fcloud aut)
%gcloud ~(. gcloud aut)
==
:: |fcloud: Cloudflare provider
::
++ fcloud
=> |%
++ parse-raw-record
|= aut-dom=turf
^- $- json
(unit [=ship id=@ta tar=target])
=, dejs:format
%+ cu
|= [id=@t typ=@t nam=@t dat=@t]
^- (unit [=ship id=@ta tar=target])
:: XX fix this
::
=/ him (ship-turf (cat 3 nam '.') aut-dom)
?: ?=(~ him)
~
?+ typ
~
::
%'A'
=/ adr (rush dat lip:ag)
?~ adr ~
`[u.him `@ta`id %direct %if u.adr]
::
%'CNAME'
:: XX fix this
::
=/ for (ship-turf (cat 3 dat '.') aut-dom)
?~ for ~
`[u.him `@ta`id %indirect u.for]
==
:: XX parse dates, proxied, ttl?
::
%- ot :~
'id'^so
'type'^so
'name'^so
'content'^so
==
--
::
|_ aut=authority
:: +base: provider service endpoint
::
++ base
^- purl:eyre
(need (de-purl:html 'https://api.cloudflare.com/client/v4'))
:: +headers: standard HTTP headers for all |fcloud requests
::
++ headers
|= aut=authority
?> ?=(%fcloud -.pro.aut)
%- ~(gas by *math:eyre)
:~ ['Content-Type' ['application/json' ~]]
['X-Auth-Email' [email.auth.pro.aut ~]]
['X-Auth-Key' [key.auth.pro.aut ~]]
==
:: +zone: provider-specific zone info request
::
++ zone
^- hiss:eyre
?> ?=(%fcloud -.pro.aut)
[(endpoint base /zones/[zone.pro.aut]) %get (headers aut) ~]
:: +record: JSON-formatted provider-specific dns record
::
++ record
|= [him=ship tar=target]
^- json
?> ?=(%fcloud -.pro.aut)
=/ type
?:(?=(%direct -.tar) 'A' 'CNAME')
=/ data
?: ?=(%direct -.tar)
(crip +:(scow %if p.tar))
(lame p.tar dom.aut)
:- %o
%- ~(gas by *(map @t json))
:~ ['name' %s (lame him dom.aut)]
['type' %s type]
['content' %s data]
:: XX make configureable?
::
['ttl' %n ~.1]
['proxied' %b %.n]
==
:: +create: provider-specific record-creation request
::
++ create
|= [him=ship tar=target pre=(unit [id=@ta tar=target])]
^- hiss:eyre
?> ?=(%fcloud -.pro.aut)
=/ bod=octs
%- as-octt:mimes:html
%- en-json:html
(record him tar)
?~ pre
:- (endpoint base /zones/[zone.pro.aut]/['dns_records'])
[%post (headers aut) `bod]
:- (endpoint base /zones/[zone.pro.aut]/['dns_records']/[id.u.pre])
[%put (headers aut) `bod]
:: +existing: list existing records stored by provider
::
++ existing
|= page=(unit @t)
^- hiss:eyre
?> ?=(%fcloud -.pro.aut)
:: XX more url params:
:: ?type ?per-page ?order ?direction
::
:- %+ params
(endpoint base /zones/[zone.pro.aut]/['dns_records'])
?~(page ~ ['page' u.page]~)
[%get (headers aut) ~]
:: +parse-list: existing records stored by provider
::
++ parse-list
^- $- json
(pair (list [=ship id=@ta tar=target]) (unit @t))
?> ?=(%fcloud -.pro.aut)
=, dejs:format
%+ cu
|= $: success=?
response=(list (unit [=ship id=@ta tar=target]))
paginate=[page=@ud per-page=@ud count=@ud total-count=@ud]
==
^- (pair (list [=ship id=@ta tar=target]) (unit @t))
?. success [~ ~]
:- (murn response same)
:: XX calculate next page number if applicable
::
~
:: XX parse errors and messages?
::
%- ot :~
'success'^bo
'result'^(ar (parse-raw-record dom.aut))
:- 'result_info'
%- ot :~
'page'^ni
'per_page'^ni
'count'^ni
'total_count'^ni
==
==
:: +parse-record: single record stored by provider
::
++ parse-record
^- $- json
(unit [=ship id=@ta tar=target])
?> ?=(%fcloud -.pro.aut)
=, dejs:format
%+ cu
|= [success=? response=(unit [=ship id=@ta tar=target])]
^- (unit [=ship id=@ta tar=target])
?. success ~
response
:: XX parse errors and messages?
::
%- ot :~
'success'^bo
'result'^(parse-raw-record dom.aut)
==
--
:: |gcloud: GCP provider
::
++ gcloud
|_ aut=authority
:: +base: provider service endpoint
::
++ base
^- purl:eyre
(need (de-purl:html 'https://www.googleapis.com/dns/v1/projects'))
:: +headers: standard HTTP headers for all |gcloud requests
::
++ headers
|= aut=authority
?> ?=(%gcloud -.pro.aut)
?. ?=(^ auth.pro.aut)
~| %gcloud-missing-auth !!
%- ~(gas by *math:eyre)
:~ ['Content-Type' ['application/json' ~]]
['Authorization' [`@t`(cat 3 'Bearer ' access.u.auth.pro.aut) ~]]
==
:: +zone: provider-specific zone info request
::
++ zone
^- hiss:eyre
?> ?=(%gcloud -.pro.aut)
:- (endpoint base /[project.pro.aut]/['managedZones']/[zone.pro.aut])
[%get (headers aut) ~]
:: +record: JSON-formatted provider-specific dns record
::
++ record
|= [him=ship tar=target]
^- json
?> ?=(%gcloud -.pro.aut)
=/ type
?:(?=(%direct -.tar) 'A' 'CNAME')
=/ data
?: ?=(%direct -.tar)
[%s (crip +:(scow %if p.tar))]
[%s (name p.tar dom.aut)]
:- %o
%- ~(gas by *(map @t json))
:~ ['name' %s (name him dom.aut)]
['type' %s type]
:: XX make configureable?
::
['ttl' %n ~.300]
['rrdatas' %a data ~]
==
:: +create: provider-specific record-creation request
::
++ create
=, eyre
|= [him=ship tar=target pre=(unit [id=@ta tar=target])]
^- hiss
?> ?=(%gcloud -.pro.aut)
=/ url=purl
%+ endpoint base
/[project.pro.aut]/['managedZones']/[zone.pro.aut]/changes
=/ bod=octs
%- as-octt:mimes:html
%- en-json:html
:- %o
%- ~(gas by *(map @t json))
:- ['additions' %a (record him tar) ~]
?~ pre ~
[['deletions' %a (record him tar.u.pre) ~] ~]
[url %post (headers aut) `bod]
:: +existing: list existing records stored by provider
::
++ existing
=, eyre
|= page=(unit @t)
^- hiss
?> ?=(%gcloud -.pro.aut)
=/ url=purl
%+ endpoint base
/[project.pro.aut]/['managedZones']/[zone.pro.aut]/rrsets
=/ hed=math (headers aut)
=? hed ?=(^ page)
(~(put by hed) 'pageToken' [u.page]~)
[url %get hed ~]
:: +parse-list: existing records stored by provider
::
++ parse-list
^- $- json
(pair (list [=ship id=@ta tar=target]) (unit @t))
?> ?=(%gcloud -.pro.aut)
=, dejs:format
=> |%
++ page (uf ~ (mu so))
++ records
%+ uf ~
%+ cu
|*(a=(list (unit)) (murn a same))
(ar parse-record)
--
:: XX parse but don't produce
:: 'kind'^(su (jest "dns#resourceRecordSetsListResponse'))
::
(ou 'rrsets'^records 'nextPageToken'^page ~)
:: +parse-record: single record stored by provider
::
++ parse-record
^- $- json
(unit [=ship id=@ta tar=target])
?> ?=(%gcloud -.pro.aut)
=, dejs:format
%+ cu
|= [typ=@t nam=@t dat=(list @t)]
^- (unit [=ship id=@ta tar=target])
:: gcloud doesn't expose UUIDs for bindings
::
=/ id %$
=/ him (ship-turf nam dom.aut)
?: |(?=(~ him) ?=(~ dat) ?=(^ t.dat))
~
?+ typ
~
::
%'A'
=/ adr (rush i.dat lip:ag)
?~ adr ~
`[u.him id %direct %if u.adr]
::
%'CNAME'
=/ for (ship-turf i.dat dom.aut)
?~ for ~
`[u.him id %indirect u.for]
==
::
%- ot :~
:: 'kind'^(su (jest "dns#resourceRecordSet'))
::
'type'^so
'name'^so
'rrdatas'^(ar so)
==
--
--
::
:: monadic helpers (XX move to stdio?)
::
=> |%
:: +backoff: exponential backoff timer
::
++ backoff
|= [try=@ud limit=@dr]
=/ m (async:stdio ,~)
^- form:m
;< eny=@uvJ bind:m get-entropy:stdio
;< now=@da bind:m get-time:stdio
%- wait:stdio
%+ add now
%+ min limit
?: =(0 try) ~s0
%+ add
(mul ~s1 (bex (dec try)))
(mul ~s0..0001 (~(rad og eny) 1.000))
::
++ request
|= =hiss:eyre
=/ m (async:stdio (unit httr:eyre))
^- form:m
;< ~ bind:m (send-hiss:stdio hiss)
take-maybe-sigh:stdio
::
++ request-retry
|= [=hiss:eyre max=@ud limit=@dr]
=/ m (async:stdio (unit httr:eyre))
=/ try=@ud 0
|- ^- form:m
=* loop $
?: =(try max)
(pure:m ~)
;< ~ bind:m (backoff try limit)
;< rep=(unit httr:eyre) bind:m (request hiss)
:: XX needs a better predicate. LTE will make this easier
::
?: &(?=(^ rep) =(200 p.u.rep))
(pure:m (some u.rep))
loop(try +(try))
--
::
:: application actions
::
=> |%
++ confirm-authority
|= =authority
=/ m (async:stdio ?)
^- form:m
;< rep=(unit httr:eyre) bind:m
(request-retry zone:(provider authority) 5 ~m10)
(pure:m &(?=(^ rep) =(200 p.u.rep)))
::
++ retrieve-existing
|= =authority
=/ m (async:stdio (map ship bound))
^- form:m
=| existing=(map ship bound)
=| next-page=(unit @t)
;< now=@da bind:m get-time:stdio
|- ^- form:m
=* loop $
;< rep=(unit httr:eyre) bind:m
(request-retry (existing:(provider authority) next-page) 5 ~m10)
?: ?| ?=(~ rep)
?=(~ r.u.rep)
==
(pure:m existing)
::
=* octs u.r.u.rep
=+ ^- [dat=(list [=ship id=@ta =target]) page=(unit @t)]
:: XX gross
::
=- ?~(- [~ ~] -)
(json-octs octs parse-list:(provider authority))
=. existing
|- ^+ existing
?~ dat
existing
=/ =bound [now id.i.dat target.i.dat ~]
$(dat t.dat, existing (~(put by existing) ship.i.dat bound))
?~ page
(pure:m existing)
loop(next-page page)
::
++ create-binding
|= [=authority =ship =target existing=(unit bound)]
=/ m (async:stdio (unit bound))
^- form:m
?: &(?=(^ existing) =(target cur.u.existing))
(pure:m existing)
::
=/ pre=(unit [@ta ^target])
?~(existing ~ (some [id cur]:u.existing))
;< rep=(unit httr:eyre) bind:m
(request (create:(provider authority) ship target pre))
:: XX retryable?
::
?. &(?=(^ rep) =(200 p.u.rep))
?: &(?=(^ rep) =(401 p.u.rep))
:: XX automate
::
~& %authentication-failure
~& (skim q.u.rep |=((pair @t @t) ?=(%www-authenticate p)))
(pure:m ~)
::
~& [%create-bind-failed rep]
(pure:m ~)
::
=* httr u.rep
=/ id=@ta
?. ?=(%fcloud -.pro.authority) ~.
?. ?=(^ r.httr)
~| [%authority-create-confirm-id rep] !!
=/ dat=(unit [^ship id=@ta ^target])
(json-octs u.r.httr parse-record:(provider authority))
?~(dat ~. id.u.dat)
::
;< now=@da bind:m get-time:stdio
=/ =bound
[now id target ?~(existing ~ [[wen cur] hit]:u.existing)]
(pure:m (some bound))
::
++ initialize-authority
|= [aut=authority state=app-state]
=/ m tapp-async
^- form:m
?> ?=(^ nem.state)
=* nam u.nem.state
;< good=? bind:m (confirm-authority aut)
?. good
~& %dns-authority-failed
(pure:m state(nem ~))
::
:: XX wait-effect
::
;< existing=(map ship bound) bind:m (retrieve-existing aut)
=. bon.nam (~(uni by bon.nam) existing)
=. nem.state (some nam)
::
:: XX wait-effect
::
;< ~ bind:m (peer-app:stdio collector-app /requests)
(pure:m state)
--
::
:: |oauth2-core: configured oauth functionality (for |gcloud only)
::
=> |%
++ oauth2-core
|= [=bowl:gall code=@t =hart:eyre secrets=@t]
=/ =oauth2-config
:* auth-url='https://accounts.google.com/o/oauth2/v2/auth'
exchange-url='https://www.googleapis.com/oauth2/v4/token'
domain=/com/googleapis
redirect-path=/dns/oauth
initial-path=/dns/oauth/result
:~ 'https://www.googleapis.com/auth/ndev.clouddns.readwrite'
'https://www.googleapis.com/auth/cloud-platform.read-only'
== ==
~(. oauth2 our.bowl now.bowl oauth2-config code hart secrets)
--
::
:: the app itself
::
=* default-tapp default-tapp:tapp
%- create-tapp-all:tapp
^- tapp-core-all:tapp
|_ [=bowl:gall state=app-state]
::
++ handle-peek handle-peek:default-tapp
++ handle-peer handle-peer:default-tapp
::
++ handle-init
=/ m tapp-async
^- form:m
;< success=? bind:m (bind-route:stdio [~ /dns/oauth] dap.bowl)
~| %dns-unable-to-bind-route
?> success
;< ~ bind:m (poke-app:stdio [[our %hood] [%drum-unlink our dap]]:bowl)
(pure:m state)
::
++ handle-poke
|= =in-poke-data
=/ m tapp-async
^- form:m
?. (team:title [our src]:bowl)
~| %bind-yoself !!
?- -.in-poke-data
%noun
?: ?=(%debug noun.in-poke-data)
~& bowl
:: XX redact secrets
::
~& state
(pure:m state)
::
:: XX heavy-handed, will duplicate subscriptions
:: should track bones
::
?: ?=(%resubscribe noun.in-poke-data)
;< ~ bind:m (peer-app:stdio collector-app /requests)
(pure:m state)
::
~& %poke-unknown
(pure:m state)
::
%dns-authority
?. =(~ nem.state)
~| %authority-reset-wat-do !!
=* aut authority.in-poke-data
=/ nam=nameserver [aut ~ ~]
=. nem.state (some nam)
:: XX move this into the provider interface
::
?: ?& ?=(%gcloud -.pro.aut)
?=(~ auth.pro.aut)
==
~& %do-the-oauth-thing
~& initial-uri:(oauth2-core bowl scry.pro.aut)
(pure:m state)
::
(initialize-authority aut state)
::
%dns-bind
?~ nem.state
~| %bind-not-authority !!
=* nam u.nem.state
=* who ship.in-poke-data
=* tar target.in-poke-data
?: ?=(%indirect -.tar)
~| %indirect-unsupported !!
:: defer %indirect where target isn't yet bound
::
:: ?: ?& ?=(%indirect -.tar)
:: !(~(has by bon.nam) p.tar)
:: ==
:: =. dep.nam (~(put ju dep.nam) p.tar [who tar])
:: =. nem.state (some nam)
:: (pure:m state)
=/ existing (~(get by bon.nam) who)
;< new=(unit bound) bind:m (create-binding aut.nam who tar existing)
?~ new
~& [%bind-failed in-poke-data]
(pure:m state)
=/ =turf
(weld dom.aut.nam /(crip +:(scow %p who)))
;< ~ bind:m
(poke-app:stdio collector-app [%dns-complete who +.tar turf])
=. bon.nam (~(put by bon.nam) who u.new)
=. nem.state (some nam)
::
:: XX wait-effect
::
=/ dep=(list [=ship =target])
~(tap in (~(get ju dep.nam) who))
|- ^- form:m
=* loop $
?~ dep
=. dep.nam (~(del by dep.nam) who)
=. nem.state (some nam)
(pure:m state)
;< ~ bind:m (poke-app:stdio [our dap]:bowl [%dns-bind ship target]:i.dep)
loop(dep t.dep)
::
%handle-http-cancel
~& %tapp-http-cant-cancel
(pure:m state)
::
%handle-http-request
:: always stash request bone for giving response
::
=/ =bone ost.bowl
:: XX maybe always (set-raw-contract %request) so transaction failure is captured?
::
=* inbound-request inbound-request.in-poke-data
?~ nem.state
~& :* %not-an-authority
%http-request
=> inbound-request
[authenticated secure address [method url]:request]
==
;< ~ bind:m
(send-effect-on-bone:stdio bone [%http-response %start [%403 ~] ~ %.y])
(pure:m state)
::
=* nam u.nem.state
?> ?=(%gcloud -.pro.aut.nam)
::
=/ parsed=(unit (pair pork:eyre quay:eyre))
%+ rush
url.request.inbound-request
;~(plug ;~(pose apat:de-purl:html (easy *pork:eyre)) yque:de-purl:html)
::
?. ?=(^ parsed)
~| [%invalid-url url.request.inbound-request] !!
=* url q.p.u.parsed
=* ext p.p.u.parsed
=* params q.u.parsed
::
?+ url
;< ~ bind:m
(send-effect-on-bone:stdio bone [%http-response %start [%404 ~] ~ %.y])
(pure:m state)
::
[%dns %oauth ~]
=/ link (trip redirect-to-provider:(oauth2-core bowl scry.pro.aut.nam))
=/ bod=(unit octs)
%- some
%- as-octt:mimes:html
%- en-xml:html
;html
;head
;title: :dns oauth
==
;body
;p make sure that the oauth credential is configured
with a redirect uri of {(trip redirect-uri:(oauth2-core bowl scry.pro.aut.nam))}
==
;a(href link): {link}
==
==
;< ~ bind:m
(send-effect-on-bone:stdio bone [%http-response %start [%200 ~] bod %.y])
(pure:m state)
::
[%dns %oauth %result ~]
=/ code (~(got by (my params)) %code)
:: XX make path configurable
::
=/ hed [['Location' '/dns/oauth/success'] ~]
::
;< ~ bind:m
(send-request:stdio (retrieve-access-token:(oauth2-core bowl scry.pro.aut.nam) code))
;< rep=(unit client-response:iris) bind:m
take-maybe-response:stdio
:: XX retry
::
?> ?& ?=(^ rep)
?=(%finished -.u.rep)
?=(^ full-file.u.rep)
==
=/ data (parse-token-response:oauth2 data.u.full-file.u.rep)
=. auth.pro.aut.nam (some [access refresh]:(need data))
=. nem.state (some nam)
:: XX use expiry to set refresh timer
::
:: XX may need to send this as a card so we don't wait
::
;< ~ bind:m
(send-effect-on-bone:stdio bone [%http-response %start [%301 hed] ~ %.y])
(initialize-authority aut.nam state)
::
[%dns %oauth %success ~]
=/ bod=(unit octs)
%- some
%- as-octt:mimes:html
%- en-xml:html
;html
;head
;title: :dns oauth
==
;body
;p: you may close the browser window
;p
;span: XX remove me
:: XX make path configurable
::
;a(href "/dns/oauth"): again
==
==
==
;< ~ bind:m (send-effect:stdio %http-response %start [%201 ~] bod %.y)
(pure:m state)
==
==
::
++ handle-diff
|= [=dock =path =in-peer-data]
=/ m tapp-async
^- form:m
?. =(dock collector-app)
(pure:m state)
=* req request.in-peer-data
=/ =target [%direct address.req]
;< ~ bind:m (poke-app:stdio [our dap]:bowl [%dns-bind ship.req target])
(pure:m state)
::
++ handle-take
|= =sign:tapp
=/ m tapp-async
^- form:m
?. ?=(%quit -.sign)
:: XX handle stuff
::
(pure:m state)
::
?. ?& =(dock.sign collector-app)
=(path.sign /requests)
==
~& [%unexpected-quit-wat-do [dock path]:sign]
(pure:m state)
::
;< ~ bind:m (peer-app:stdio collector-app /requests)
(pure:m state)
--

176
pkg/arvo/app/dns-collector.hoon
View File

@ -1,8 +1,10 @@
/- dns
/+ default-agent, verb
::
:: app types and boilerplate
::
=> |%
+$ card card:agent:gall
+$ app-state
$: %0
requested=(map ship address:dns)
@ -17,83 +19,56 @@
[%dns-complete =ship =binding:dns]
[%noun noun=*]
==
+$ out-poke-data
$% [%drum-unlink =dock]
==
+$ out-peer-data
$% [%dns-binding =binding:dns]
[%dns-request =request:dns]
==
+$ card
$% [%diff out-peer-data]
[%poke wire =dock out-poke-data]
==
+$ move [bone card]
--
::
=| moves=(list move)
|_ [=bowl:gall state=app-state]
::
++ this .
::
++ abet
^- (quip move _this)
[(flop moves) this(moves ~)]
::
++ emit
|= mov=move
^+ this
this(moves [mov moves])
::
++ emil
|= moz=(list move)
|- ^+ this
?~ moz
this
$(moz t.moz, ..this (emit i.moz))
::
++ poke-app
|= [=wire =dock =out-poke-data]
^+ this
(emit [ost.bowl %poke wire dock out-poke-data])
::
|%
++ give-result
|= [=the=path =out-peer-data]
^+ this
%- emil
%+ turn
^- (list bone)
%+ murn ~(tap by sup.bowl)
|= [ost=bone =ship =sub=path]
`(unit bone)`?.(=(the-path sub-path) ~ (some ost))
|= =bone
[bone %diff out-peer-data]
|= [=the=path =cage]
^- card
[%give %fact `the-path cage]
--
::
++ prep
|= old=(unit app-state)
^- (quip move _this)
=< abet
?~ old
(poke-app /unlink [[our %hood] [%drum-unlink our dap]]:bowl)
this(state u.old)
^- agent:gall
=| state=app-state
%+ verb |
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
::
++ poke
|= =in-poke-data
^- (quip move _this)
=< abet
?- -.in-poke-data
%noun
?: ?=(%debug noun.in-poke-data)
~& bowl
~& state
this
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(app-state old))
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
|^
?+ mark (on-poke:def mark vase)
%noun (handle-noun !<(noun vase))
%dns-address (handle-dns-address !<(address:dns vase))
%dns-complete (handle-dns-complete !<([ship binding:dns] vase))
==
::
++ handle-noun
|= noun=*
^- (quip card _this)
?: ?=(%debug noun)
~& bowl=bowl
~& state=state
`this
::
~& %poke-unknown
this
`this
::
%dns-address
++ handle-dns-address
|= adr=address:dns
^- (quip card _this)
=* who src.bowl
=* adr address.in-poke-data
=/ rac (clan:title who)
?. ?=(?(%king %duke) rac)
~| [%dns-collector-bind-invalid who] !!
@ -104,23 +79,26 @@
=/ dun=(unit binding:dns) (~(get by completed.state) who)
?: &(?=(^ dun) =(adr address.u.dun))
=. requested.state (~(del by requested.state) who)
(give-result /(scot %p who) %dns-binding u.dun)
:_ this :_ ~
(give-result /(scot %p who) %dns-binding !>(u.dun))
::
?: &(?=(^ req) =(adr u.req))
this
`this
:: XX check address?
=/ =request:dns [who adr]
=. requested.state (~(put by requested.state) request)
(give-result /requests %dns-request request)
:_ this :_ ~
(give-result /requests %dns-request !>(request))
::
%dns-complete
++ handle-dns-complete
|= [who=ship =binding:dns]
^- (quip card _this)
:: XX or confirm valid binding?
::
?. (team:title [our src]:bowl)
~| %complete-yoself !!
=* who ship.in-poke-data
=* adr address.binding.in-poke-data
=* tuf turf.binding.in-poke-data
=* adr address.binding
=* tuf turf.binding
=/ req=(unit address:dns) (~(get by requested.state) who)
:: ignore established bindings that don't match requested
::
@ -128,47 +106,49 @@
!=(adr u.req)
==
~& %unknown-complete
this
`this
=: requested.state (~(del by requested.state) who)
completed.state (~(put by completed.state) who [adr tuf])
==
(give-result /(scot %p who) %dns-binding adr tuf)
==
:_ this :_ ~
(give-result /(scot %p who) %dns-binding !>([adr tuf]))
--
::
++ peek
++ on-watch
|= =path
^- (unit (unit peek-data))
?+ path [~ ~]
[%x %requested ~]
[~ ~ %requested ~(tap by requested.state)]
::
[%x %completed ~]
[~ ~ %completed ~(tap by completed.state)]
==
::
++ peer
|= =path
^- (quip move _this)
=< abet
:: will be immediately unlinked, see +prep
::
^- (quip card _this)
?: ?=([%sole *] path)
this
!!
?. ?=([@ ~] path)
~| %invalid-path !!
?: ?=(%requests i.path)
=/ requests ~(tap by requested.state)
|- ^+ this
|- ^- (quip card _this)
=* loop $
?~ requests
this
=. ..this (give-result path %dns-request i.requests)
loop(requests t.requests)
`this
=/ card (give-result path %dns-request !>(i.requests))
=^ cards this loop(requests t.requests)
[[card cards] this]
::
=/ who=(unit @p) (slaw %p i.path)
?~ who
~| %invalid-path !!
?~ dun=(~(get by completed.state) u.who)
this
(give-result path %dns-binding u.dun)
`this
:_ this :_ ~
(give-result path %dns-binding !>(u.dun))
::
++ on-leave on-leave:def
++ on-peek
|= =path
^- (unit (unit cage))
?+ path [~ ~]
[%x %requested ~] [~ ~ %requested !>(~(tap by requested.state))]
[%x %completed ~] [~ ~ %completed !>(~(tap by completed.state))]
==
::
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--

303
pkg/arvo/app/dns.hoon
View File

@ -1,303 +0,0 @@
/- dns, hall
/+ tapp, stdio
::
:: tapp types and boilerplate
::
=> |%
++ collector-app `dock`[~zod %dns-collector]
+$ app-state
$: %0
requested=(unit address:dns)
completed=(unit binding:dns)
==
+$ peek-data _!!
+$ in-poke-data
$% :: XX ames-domains unused, remove
::
[%dns-auto ames-domains=(list turf)]
[%dns-address =address:dns]
==
+$ out-poke-data
$% [%dns-address =address:dns]
[%hall-action %phrase audience:hall (list speech:hall)]
==
+$ in-peer-data
$% [%dns-binding =binding:dns]
==
+$ out-peer-data ~
++ tapp
%: ^tapp
app-state
peek-data
in-poke-data
out-poke-data
in-peer-data
out-peer-data
==
++ stdio (^stdio out-poke-data out-peer-data)
--
::
:: monadic helpers (XX move to stdio?)
::
=> |%
:: +backoff: exponential backoff timer
::
++ backoff
|= [try=@ud limit=@dr]
=/ m (async:stdio ,~)
^- form:m
;< eny=@uvJ bind:m get-entropy:stdio
;< now=@da bind:m get-time:stdio
%- wait:stdio
%+ add now
%+ min limit
?: =(0 try) ~s0
%+ add
(mul ~s1 (bex (dec try)))
(mul ~s0..0001 (~(rad og eny) 1.000))
::
++ request
|= =hiss:eyre
=/ m (async:stdio (unit httr:eyre))
^- form:m
;< ~ bind:m (send-hiss:stdio hiss)
take-maybe-sigh:stdio
::
:: +self-check-http: confirm our availability at .host on port 80
::
:: XX needs better success/failure predicates
:: XX bind route to self and handle request inside tx?
::
++ self-check-http
|= [=host:eyre max=@ud]
=/ m (async:stdio ?)
^- form:m
:: XX also scry into eyre
:: q:.^(hart:eyre %e /(scot %p our)/host/real)
=/ =hiss:eyre
=/ url=purl:eyre
[[sec=| por=~ host] [ext=`~.udon path=/static] query=~]
[url %get ~ ~]
=/ try=@ud 0
|- ^- form:m
=* loop $
?: =(try max)
(pure:m |)
;< ~ bind:m (backoff try ~h1)
;< rep=(unit httr:eyre) bind:m (request hiss)
?: ?& ?=(^ rep)
|(=(200 p.u.rep) =(307 p.u.rep))
==
(pure:m &)
?. ?| ?=(~ rep)
=(504 p.u.rep)
==
(pure:m |)
loop(try +(try))
::
++ app-message
|= [app=term =cord =tang]
=/ m (async:stdio ,~)
^- form:m
=/ msg=tape :(weld (trip app) ": " (trip cord))
;< ~ bind:m (flog-text:stdio msg)
(flog-tang:stdio tang)
::
:: XX disabled due to :hall's status
::
++ hall-app-message-disabled
|= [app=term =cord =tang]
=/ m (async:stdio ,~)
^- form:m
=/ msg=speech:hall
:+ %app app
=/ line [%lin & cord]
?~(tang line [%fat [%tank tang] line])
;< our=@p bind:m get-identity:stdio
=/ act
[%phrase (sy [our %inbox] ~) [msg ~]]
(poke-app:stdio [our %hall] %hall-action act)
--
::
:: application actions
::
=> |%
:: +turf-confirm-install: self check and install domain
::
++ turf-confirm-install
|= =turf
=/ m (async:stdio ?)
^- form:m
;< good=? bind:m (self-check-http &+turf 5)
?. good
(pure:m |)
;< ~ bind:m (install-domain:stdio turf)
(pure:m &)
::
:: +galaxy-domains
::
++ galaxy-domains
=/ m (async:stdio ,~)
^- form:m
;< our=@p bind:m get-identity:stdio
;< now=@da bind:m get-time:stdio
=/ ames-domains=(list turf)
.^((list turf) %j /(scot %p our)/turf/(scot %da now))
|- ^- form:m
=* loop $
?~ ames-domains
(pure:m ~)
=/ =turf
(weld i.ames-domains /(crip +:(scow %p our)))
;< good=? bind:m (turf-confirm-install turf)
=/ msg=(pair cord tang)
?: good
[(cat 3 'confirmed access via ' (en-turf:html turf)) ~]
:- (cat 3 'unable to access via ' (en-turf:html turf))
:~ leaf+"XX check via nslookup"
leaf+"XX confirm port 80"
==
;< ~ bind:m (app-message %dns msg)
loop(ames-domains t.ames-domains)
::
:: +request-by-ip
::
++ request-by-ip
|= if=@if
=/ m (async:stdio ?)
^- form:m
;< good=? bind:m (self-check-http |+if 5)
?. good
:: XX details
~& %bail-early
(pure:m |)
;< ~ bind:m (poke-app:stdio collector-app [%dns-address %if if])
;< our=@p bind:m get-identity:stdio
;< ~ bind:m (peer-app:stdio collector-app /(scot %p our))
(pure:m &)
--
::
=* tapp-async tapp-async:tapp
=* default-tapp default-tapp:tapp
%- create-tapp-all:tapp
^- tapp-core-all:tapp
|_ [=bowl:gall state=app-state]
::
++ handle-init handle-init:default-tapp
++ handle-peek handle-peek:default-tapp
++ handle-peer handle-peer:default-tapp
::
++ handle-poke
|= =in-poke-data
=/ m tapp-async
^- form:m
?. (team:title [our src]:bowl)
~| %configure-yoself !!
?- -.in-poke-data
::
:: "automatic" dns binding -- currently only for galaxies
::
:: XX could be in +handle-init
:: XX use ip reflection for other classes
::
%dns-auto
?. ?=(%czar (clan:title our.bowl))
:: XX details
::
~& %galaxy-only
(pure:m state)
;< ~ bind:m galaxy-domains
(pure:m state)
::
:: manual dns binding -- by explicit ipv4
::
%dns-address
=* adr address.in-poke-data
=/ rac (clan:title our.bowl)
?. ?=(?(%king %duke) rac)
~| [%dns-collector-bind-invalid rac] !!
?: (reserved:eyre if.adr)
~| [%dns-collector-reserved-address if.adr] !!
;< requested=? bind:m (request-by-ip if.adr)
:: XX save failure?
::
~? =(requested.state (some address.in-poke-data))
%re-requesting
=? requested.state requested
(some address.in-poke-data)
(pure:m state)
==
::
++ handle-diff
|= [=dock =path =in-peer-data]
=/ m tapp-async
^- form:m
?. =(dock collector-app)
~| [%unexpected-diff-dock-wat-do dock] !!
?. =(path /(scot %p our.bowl))
~| [%unexpected-diff-path-wat-do path] !!
?- -.in-peer-data
%dns-binding
=* binding binding.in-peer-data
?~ requested.state
~| %unexpected-binding-wat-do !!
?. =(u.requested.state address.binding)
~| %mismatch-binding-wat-do !!
;< good=? bind:m (turf-confirm-install turf.binding)
=/ msg=(pair cord tang)
?: good
[(cat 3 'confirmed access via ' (en-turf:html turf.binding)) ~]
:- (cat 3 'unable to access via ' (en-turf:html turf.binding))
:~ leaf+"XX check via nslookup"
leaf+"XX confirm port 80"
==
;< ~ bind:m (app-message %dns msg)
=? completed.state good (some binding)
:: XX save failure?s
:: XX unsubscribe?
(pure:m state)
==
::
++ handle-take
|= =sign:tapp
=/ m tapp-async
^- form:m
?+ -.sign
~| [%unexpected-sign sign] !!
:: print %poke nacks
::
%coup
?. =(collector-app dock.sign)
(pure:m state)
?~ error.sign
=/ msg=cord
(cat 3 'request for DNS sent to ' (scot %p p:collector-app))
;< ~ bind:m (app-message %dns msg ~)
(pure:m state)
:: XX details
~& %dns-ip-request-failed
%- (slog u.error.sign)
(pure:m state(requested ~))
:: re-subscribe if (involuntarily) unsubscribed
::
%quit
?. =(path.sign /(scot %p our.bowl))
~| [%unexpected-quit-path-wat-do path.sign] !!
;< ~ bind:m (peer-app:stdio collector-app /(scot %p our.bowl))
(pure:m state)
:: print %peer nacks
::
%reap
?. =(path.sign /(scot %p our.bowl))
~| [%unexpected-reap-path-wat-do path.sign] !!
?~ error.sign
=/ msg=cord
(cat 3 'awaiting response from ' (scot %p p:collector-app))
;< ~ bind:m (app-message %dns msg ~)
(pure:m state)
:: XX details
~& %dns-domain-subscription-failed
%- (slog u.error.sign)
(pure:m state)
==
--

362
pkg/arvo/app/dojo.hoon
View File

@ -2,7 +2,7 @@
:::: /hoon/dojo/app :: ::::
:: :: ::
/? 309 :: arvo kelvin
/- *sole, lens ::
/- *sole, lens :: console structures
/+ sole, pprint, ::
auto=language-server-complete, ::
easy-print=language-server-easy-print ::
@ -10,10 +10,11 @@
:::: :: ::::
:: :: ::
=> |% :: external structures
++ id @tasession :: session id
++ house :: all state
$: $5
egg/@u :: command count
hoc/(map bone session) :: conversations
hoc/(map id session) :: conversations
== ::
++ session :: per conversation
$: say/sole-share :: command-line state
@ -30,7 +31,7 @@
old/(set term) :: used TLVs
buf/tape :: multiline buffer
== ::
++ monkey :: per conversation
++ monkey :: per conversation
$: say/sole-share :: command-line state
dir/beam :: active path
poy/(unit dojo-project) :: working
@ -63,6 +64,7 @@
$~ [%ex *hoon]
$% {$ur p/@t} :: http GET request
{$ge p/dojo-model} :: generator
{$te p/term q/(list dojo-source)} :: thread
{$dv p/path} :: core from source
{$ex p/hoon} :: hoon expression
{$sa p/mark} :: example mark value
@ -94,45 +96,6 @@
== ::
++ bead {p/(set beam) q/cage} :: computed result
++ goal {p/ship q/term} :: flat application
++ clap :: action, user
$% {$peer p/path} :: subscribe
{$poke p/(cask)} :: apply
{$pull ~} :: unsubscribe
== ::
++ club :: action, system
$% {$peer p/path} :: subscribe
{$poke p/cage} :: apply
{$pull ~} :: unsubscribe
== ::
++ card :: general card
$% {$diff $sole-effect sole-effect} ::
{$send wire {ship term} clap} ::
[%request wire request:http outbound-config:iris] :: %l
[%build wire ? schematic:ford]
[%kill wire ~]
{$deal wire sock term club} ::
{$info wire toro:clay} ::
== ::
++ move (pair bone card) :: user-level move
++ sign ::
$% :: %made: build result; response to %build +task
::
$: %made
:: date: formal date of the build
::
date=@da
:: result: result of the build; either complete build, or error
::
$= result
$% :: %complete: contains the result of the completed build
::
[%complete build-result=build-result:ford]
:: %incomplete: couldn't finish build; contains error message
::
[%incomplete =tang]
== ==
{$unto p/internal-gift:gall}
==
--
=>
|%
@ -242,6 +205,7 @@
;~ pose
;~(plug (cold %ur lus) parse-url)
;~(plug (cold %ge lus) parse-model)
;~(plug (cold %te hep) sym (star ;~(pfix ace parse-source)))
;~(plug (cold %as pad) sym ;~(pfix ace parse-source))
;~(plug (cold %do cab) parse-hoon ;~(pfix ace parse-source))
parse-value
@ -331,17 +295,15 @@
:: ::
=, gall
=+ foo=*monkey
|_ $: hid/bowl :: system state
house :: program state
== ::
::
:: pretty-printer aliases
=| house :: program state
=* state -
=> |%
::
++ xskol `$-(type tank)`type-to-tank:pprint
++ xsell `$-(vase tank)`vase-to-tank:pprint
::
++ he :: per session
|_ {moz/(list move) session} ::
|_ {hid/bowl:gall =id moz/(list card:agent:gall) session}
::
++ he-beam
^- beam
@ -364,20 +326,28 @@
?> ?=($~ pux)
:: pin all builds to :now.hid so they don't get cached forever
::
(he-card(poy `+>+<(pux `way)) %build way live=%.n schematic)
%- he-card(poy `+>+<(pux `way))
[%pass way %arvo %f %build live=%.n schematic]
::
++ dy-request
|= [way=wire =request:http]
^+ +>+>
?> ?=(~ pux)
(he-card(poy `+>+<(pux `way)) %request way request *outbound-config:iris)
%- he-card(poy `+>+<(pux `way))
[%pass way %arvo %i %request request *outbound-config:iris]
::
++ dy-stop :: stop work
^+ +>
=. poy ~
?~ pux +>
%. [%txt "! cancel {<u.pux>}"]
he-diff:(he-card [%kill u.pux ~])
=< he-diff
%- he-card
?: =(/wool u.pux)
:: really shoud stop the thread as well
::
[%pass u.pux %agent [our.hid %spider] %leave ~]
[%pass u.pux %arvo %f %kill ~]
::
++ dy-slam :: call by ford
|= {way/wire gat/vase sam/vase}
@ -434,14 +404,9 @@
$as =^(mor +>.$ (dy-init-source q.bul) [bul(q mor) +>.$])
$do =^(mor +>.$ (dy-init-source q.bul) [bul(q mor) +>.$])
$ge =^(mod +>.$ (dy-init-model p.bul) [[%ge mod] +>.$])
$te =^(mod +>.$ (dy-init-ordered q.bul) [bul(q mod) +>.$])
$ur [bul +>.$]
$tu =^ dof +>.$
|- ^+ [p.bul +>.^$]
?~ p.bul [~ +>.^$]
=^ dis +>.^$ (dy-init-source i.p.bul)
=^ mor +>.^$ $(p.bul t.p.bul)
[[dis mor] +>.^$]
[[%tu dof] +>.$]
$tu =^(dof +>.$ (dy-init-ordered p.bul) [[%tu dof] +>.$])
==
::
++ dy-init-model :: ++dojo-model
@ -572,19 +537,18 @@
::
$poke
%- he-card(poy ~)
:* %deal
/poke
[our.hid p.p.p.mad]
q.p.p.mad
:* %pass
/poke
%agent
p.p.mad
%poke
cay
==
::
$file
%- he-card(poy ~) :*
%info
/file
(foal:space:userlib (en-beam:format p.p.mad) cay)
%- he-card(poy ~)
:* %pass /file %arvo %c
%info (foal:space:userlib (en-beam:format p.p.mad) cay)
==
::
$flat
@ -676,8 +640,8 @@
::
++ dy-type :: sole action
|= act/sole-action
?- -.act
$det (dy-edit +.act)
?- -.dat.act
$det (dy-edit +.dat.act)
$ret (dy-done (tufa buf.say))
$clr dy-stop
$tab +>+>
@ -685,15 +649,18 @@
::
++ dy-cage |=(num/@ud (~(got by rez) num)) :: known cage
++ dy-vase |=(num/@ud q:(dy-cage num)) :: known vase
++ dy-sore
|= src/(list dojo-source)
^- vase
?~ src
!>(~)
(slop (dy-vase p.i.src) $(src t.src))
::
++ dy-silk-vase |=(vax/vase [%$ %noun vax]) :: vase to silk
++ dy-silk-sources :: arglist to silk
|= src/(list dojo-source)
^- schematic:ford
::
:+ %$ %noun
|-
?~ src !>(~)
(slop (dy-vase p.i.src) $(src t.src))
[%$ %noun (dy-sore src)]
::
++ dy-silk-config :: configure
|= {cay/cage cig/dojo-config}
@ -757,12 +724,28 @@
|= cag/cage
(dy-hand %noun q.cag)
::
++ dy-wool-poke
|= [fil=term src=(list dojo-source)]
^+ +>+>
?> ?=(~ pux)
=/ tid (scot %ta (cat 3 'dojo_' (scot %uv (sham eny.hid))))
=. poy `+>+<.$(pux `/wool)
=. +>+>.$
%- he-card
[%pass /wool %agent [our.hid %spider] %watch /thread-result/[tid]]
%- he-card
=/ =cage :: also sub
[%spider-start !>([~ `tid fil (dy-sore src)])]
[%pass /wool %agent [our.hid %spider] %poke cage]
::
++ dy-make :: build step
^+ +>
?> ?=(^ cud)
=+ bil=q.u.cud :: XX =*
?: ?=($ur -.bil)
(dy-request /hand `request:http`[%'GET' p.bil ~ ~])
?: ?=($te -.bil)
(dy-wool-poke p.bil q.bil)
%- dy-ford
^- [path schematic:ford]
?- -.bil
@ -835,33 +818,27 @@
==
::
++ he-abet :: resolve
[(flop moz) %_(+> hoc (~(put by hoc) ost.hid +<+))]
::
++ he-abut :: discard
=> he-stop
[(flop moz) %_(+> hoc (~(del by hoc) ost.hid))]
[(flop moz) %_(state hoc (~(put by hoc) id +<+>+))]
::
++ he-card :: emit gift
|= cad/card
|= =card:agent:gall
^+ +>
%_(+> moz [[ost.hid cad] moz])
::
++ he-send
|= {way/wire him/ship dap/term cop/clap}
^+ +>
(he-card %send way [him dap] cop)
=? card ?=(%pass -.card)
card(p [id p.card])
%_(+> moz [card moz])
::
++ he-diff :: emit update
|= fec/sole-effect
^+ +>
(he-card %diff %sole-effect fec)
(he-card %give %fact `/sole/[id] %sole-effect !>(fec))
::
++ he-stop :: abort work
^+ .
?~(poy . ~(dy-stop dy u.poy))
::
++ he-peer :: subscribe to
|=(pax/path ?>(=(~ pax) he-prom))
|= pax/path
?>(=(~ pax) he-prom)
::
++ he-pine :: restore prompt
^+ .
@ -930,15 +907,44 @@
(he-diff(poy ~) %tan message.build-result.result)
== ==
::
++ he-unto :: result from behn
|= {way/wire cit/internal-gift:gall}
++ he-unto :: result from agent
|= {way/wire cit/sign:agent:gall}
^+ +>
?. ?=($coup -.cit)
?. ?=($poke-ack -.cit)
~& [%strange-unto cit]
+>
?~ p.cit
(he-diff %txt ">=")
(he-diff %tan u.p.cit)
::
++ he-wool
|= [way=wire =sign:agent:gall]
^+ +>
?- -.sign
%poke-ack
?~ p.sign
+>.$
=. +>.$ (he-diff(poy ~) %tan u.p.sign)
(he-card %pass /wool %agent [our.hid %spider] %leave ~)
::
%watch-ack
?~ p.sign
+>.$
(he-diff(poy ~) %tan u.p.sign)
::
%fact
?+ p.cage.sign ~|([%dojo-thread-bad-mark-result p.cage.sign] !!)
%thread-fail
=+ !<([=term =tang] q.cage.sign)
(he-diff(poy ~) %tan leaf+"thread failed: {<term>}" tang)
::
%thread-done
?> ?=(^ poy)
(~(dy-hand dy u.poy(pux ~)) %noun q.cage.sign)
==
::
%kick +>.$
==
:: +he-http-response: result from http-client
::
++ he-http-response
@ -1166,11 +1172,11 @@
^+ +>
?^ poy
he-pine:(~(dy-type dy u.poy) act)
?- -.act
$det (he-stir +.act)
?- -.dat.act
$det (he-stir +.dat.act)
$ret (he-done (tufa buf.say))
$clr he-pine(buf "")
$tab (he-tab +.act)
$tab (he-tab +.dat.act)
==
::
++ he-lame :: handle error
@ -1198,74 +1204,116 @@
(sloop b(p face+[a p.b]) c)
!>([our=our now=now eny=eny]:hid)
--
--
^- agent:gall
|_ hid=bowl:gall
++ on-init
`..on-init
::
++ prep
|= old/(unit house)
^+ [~ ..prep]
?~ old `..prep
`..prep(+<+ u.old)
++ on-save
!>(state)
::
:: pattern: ++ foo |=(data he-abet:(~(he-foo he (~(got by hoc) ost)) data))
++ arm (arm-session ~ (~(got by hoc) ost.hid))
++ arm-session
|= {moz/(list move) ses/session}
=> ~(. he moz ses)
=- [wrap=- +]
=+ he-arm=he-type
|@ ++ $
|: +<.he-arm
^- (quip move _..he)
he-abet:(he-arm +<)
--
++ on-load
|= =old-state=vase
=/ old-state !<(house old-state-vase)
`..on-init(state old-state)
::
++ peer-sole
~? !=(our.hid src.hid) [%dojo-peer-stranger ost.hid src.hid]
?> (team:title our.hid src.hid)
=^ moz .
?. (~(has by hoc) ost.hid) [~ .]
~& [%dojo-peer-replaced ost.hid]
~(he-abut he ~ (~(got by hoc) ost.hid))
=+ ses=%*(. *session -.dir [our.hid %home ud+0])
(wrap he-peer):(arm-session moz ses)
::
++ poke-sole-action
|= act/sole-action ~| poke+act %. act
(wrap he-type):arm
::
++ poke-lens-command
|= com/command:lens ~| poke-lens+com %. com
(wrap he-lens):arm
::
++ poke-json
|= jon=json
^- [(list move) _+>.$]
~& jon=jon
[~ +>.$]
:: +poke-wipe: clear all dojo sessions
::
++ poke-wipe
|= *
^- [(list move) _+>.$]
~& %dojo-wipe
=. hoc
%- ~(run by hoc)
|= =session
%_ session
sur ~
lib ~
var ~
old ~
++ on-poke
|= [=mark =vase]
^- (quip card:agent:gall _..on-init)
=^ moves state
^- (quip card:agent:gall house)
?+ mark ~|([%dojo-poke-bad-mark mark] !!)
%sole-action
=/ act !<(sole-action vase)
he-abet:(~(he-type he hid id.act ~ (~(got by hoc) id.act)) act)
::
%lens-command
=+ !<([=id =command:lens] vase)
he-abet:(~(he-lens he hid id ~ (~(got by hoc) id)) command)
::
%json
~& jon=!<(json vase)
`state
::
%wipe
~& %dojo-wipe
=. hoc
%- ~(run by hoc)
|= =session
%_ session
sur ~
lib ~
var ~
old ~
==
[~ state]
==
::
[~ +>.$]
[moves ..on-init]
::
++ made (wrap he-made):arm
++ http-response (wrap he-http-response):arm
++ lame (wrap he-lame):arm
++ unto (wrap he-unto):arm
++ pull
|= {pax/path}
^- (quip move _+>)
=^ moz +> ~(he-abut he ~ (~(got by hoc) ost.hid))
[moz +>.$(hoc (~(del by hoc) ost.hid))]
++ on-watch
|= =path
^- (quip card:agent:gall _..on-init)
~? !=(our.hid src.hid) [%dojo-peer-stranger src.hid]
?> (team:title our.hid src.hid)
?> ?=([%sole @ ~] path)
=/ id i.t.path
=? hoc (~(has by hoc) id)
~& [%dojo-peer-replaced id]
(~(del by hoc) id)
=/ =session %*(. *session -.dir [our.hid %home ud+0])
=^ moves state
he-abet:~(he-prom he hid id ~ session)
[moves ..on-init]
::
++ on-leave
|= =path
?> ?=([%sole *] path)
=. hoc (~(del by hoc) t.path)
[~ ..on-init]
::
++ on-peek
|= path
*(unit (unit cage))
::
++ on-agent
|= [=wire =sign:agent:gall]
?> ?=([@ @ *] wire)
=/ =session (~(got by hoc) i.wire)
=/ he-full ~(. he hid i.wire ~ session)
=^ moves state
=< he-abet
^+ he
?+ i.t.wire ~|([%dojo-bad-on-agent wire -.sign] !!)
%poke (he-unto:he-full t.wire sign)
%wool (he-wool:he-full t.wire sign)
==
[moves ..on-init]
::
++ on-arvo
|= [=wire =sign-arvo]
?> ?=([@ *] wire)
=/ =session (~(got by hoc) i.wire)
=/ he-full ~(. he hid i.wire ~ session)
=^ moves state
=< he-abet
?+ +<.sign-arvo ~|([%dojo-bad-take +<.sign-arvo] !!)
%made (he-made:he-full t.wire +>.sign-arvo)
%http-response (he-http-response:he-full t.wire +>.sign-arvo)
==
[moves ..on-init]
:: if dojo fails unexpectedly, kill whatever each session is working on
::
++ on-fail
|= [=term =tang]
=/ sessions=(list (pair id session)) ~(tap by hoc)
|- ^- (quip card:agent:gall _..on-init)
?~ sessions
[~ ..on-init]
=^ cards-1 state
he-abet:(~(he-lame he hid p.i.sessions ~ q.i.sessions) term tang)
=^ cards-2 ..on-init
$(sessions t.sessions)
[(weld cards-1 cards-2) ..on-init]
--

63
pkg/arvo/app/eth-manage.hoon
View File

@ -1,63 +0,0 @@
:: usage:
:: :eth-manage %look
:: kick polling from eth mainnet node
:: :eth-manage [%wind 1.000.000]
:: rewind to block 1.000.000
=> $~ |%
++ move (pair bone card)
++ card
$% [%turf wire ~]
[%vein wire]
[%look wire src=(each ship purl:eyre)]
[%wind wire p=@ud]
==
++ state
$: a/@
==
--
=, gall
|_ $: hid/bowl
state
==
++ poke
|= [mar=@tas val=*]
^- (quip move _+>)
:_ +>.$
?+ val ~&(%oops ~)
%turf [ost.hid %turf /hi ~]~
%vein [ost.hid %vein /hi]~
[%wind @ud] [ost.hid %wind /hi +.val]~
::
%look-ethnode
:_ ~
=/ pul
(need (de-purl:html 'http://eth-mainnet.urbit.org:8545'))
[ost.hid %look /hi |+pul]
::
[%look-kick who=@p]
:_ ~
[ost.hid %look /hi %& who.val]
==
::
++ vein
|= [wir/wire =life ven=(map life ring)]
^- (quip move _+>)
~& [%pierc life ven]
`+>.$
::
++ turf
|= [wir/wire pax=(list path)]
^- (quip move _+>)
~& [%slurp pax]
`+>.$
::
++ prep
|= old/(unit noun)
^- [(list move) _+>.$]
?~ old
`+>.$
=+ new=((soft state) u.old)
?~ new
`+>.$
`+>.$(+<+ u.new)
--

586
pkg/arvo/app/eth-watcher.hoon
View File

@ -1,23 +1,21 @@
:: eth-watcher: ethereum event log collector
::
/- *eth-watcher
/+ tapp, stdio, ethio
/- *eth-watcher, spider
/+ default-agent, verb
=, ethereum-types
=, able:jael
::
=> |%
++ refresh-rate ~m5
--
::
=> |%
+$ card card:agent:gall
+$ app-state
$: %0
$: %2
dogs=(map path watchdog)
==
::
+$ context [=path dog=watchdog]
+$ watchdog
$: config
running=(unit =tid:spider)
=number:block
=pending-logs
=history
@ -26,298 +24,356 @@
::
:: history: newest block first, oldest event first
+$ history (list loglist)
+$ pending-logs (map number:block loglist)
::
+$ peek-data
[%atom =next-block=number:block]
+$ in-poke-data
$: %eth-watcher-poke
poke
==
+$ out-poke-data ~
+$ in-peer-data ~
+$ out-peer-data
$: %eth-watcher-diff
diff
==
++ tapp
%: ^tapp
app-state
peek-data
in-poke-data
out-poke-data
in-peer-data
out-peer-data
==
++ tapp-async tapp-async:tapp
++ stdio (^stdio out-poke-data out-peer-data)
++ ethio (^ethio out-poke-data out-peer-data)
--
::
:: Async helpers
:: Helpers
::
=> |%
++ send-logs
|= [=path =loglist]
=/ m (async:stdio ,~)
|- ^- form:m
=* loop $
?~ loglist
(pure:m ~)
;< ~ bind:m (send-update path %log i.loglist)
loop(loglist t.loglist)
++ wait
|= [=path now=@da time=@dr]
^- card
[%pass [%timer path] %arvo %b %wait (add now time)]
::
++ send-update
|= [=path =diff]
=/ m (async:stdio ,~)
^- form:m
=. path [%logs path]
(give-result:stdio path %eth-watcher-diff diff)
--
::
:: Main loop
::
=> |%
++ wait-shortcut
|= [=path now=@da]
^- card
[%pass [%timer path] %arvo %b %wait now]
::
:: Update watchdog configuration, then look for updates
++ poke-spider
|= [=path our=@p =cage]
^- card
[%pass [%running path] %agent [our %spider] %poke cage]
::
++ configure
|= [context =config]
=/ m (async:stdio ,watchdog)
^- form:m
%+ get-updates path
%_ dog
- config
number from.config
==
++ watch-spider
|= [=path our=@p =sub=path]
^- card
[%pass [%running path] %agent [our %spider] %watch sub-path]
::
:: Get updates since last checked
::
++ get-updates
|= context
=/ m (async:stdio ,watchdog)
^- form:m
;< =latest=block bind:m (get-latest-block:ethio url.dog)
;< dog=watchdog bind:m (zoom [path dog] number.id.latest-block)
|- ^- form:m
=* loop $
?: (gth number.dog number.id.latest-block)
(pure:m dog)
;< =block bind:m (get-block-by-number:ethio url.dog number.dog)
;< dog=watchdog bind:m
(take-block [path dog] block)
loop(dog dog)
::
:: Process a block, detecting and handling reorgs
::
++ take-block
|= [context =block]
=/ m (async:stdio ,watchdog)
^- form:m
:: if this next block isn't direct descendant of our logs, reorg happened
?: &(?=(^ blocks.dog) !=(parent-hash.block hash.id.i.blocks.dog))
(rewind [path dog] block)
;< [=new=pending-logs =released=loglist] bind:m
(release-old-events path pending-logs.dog number.id.block)
;< =new=loglist bind:m :: oldest first
(get-logs-by-hash:ethio url.dog hash.id.block contracts.dog topics.dog)
=. new-pending-logs
(~(put by new-pending-logs) number.id.block new-loglist)
%- pure:m
%_ dog
number +(number.id.block)
pending-logs new-pending-logs
history [released-loglist history.dog]
blocks [block blocks.dog]
==
::
:: Release events if they're more than 30 blocks ago
::
++ release-old-events
|= [=path =pending-logs =number:block]
=/ m (async:stdio ,[^pending-logs loglist])
^- form:m
?: (lth number 30) (pure:m pending-logs ~)
=/ rel-number (sub number 30)
=/ =loglist (~(get ja pending-logs) rel-number)
;< ~ bind:m (send-logs path loglist)
(pure:m (~(del by pending-logs) rel-number) loglist)
::
:: Reorg detected, so rewind until we're back in sync
::
++ rewind
:: block: wants to be head of blocks.dog, but might not match
|= [context =block]
=/ m (async:stdio ,watchdog)
=* blocks blocks.dog
|- ^- form:m
=* loop $
:: if we have no further history to rewind, we're done
?~ blocks
(pure:m dog(blocks [block blocks]))
:: if target block is directly after "latest", we're done
?: =(parent-hash.block hash.id.i.blocks)
(pure:m dog(blocks [block blocks]))
:: next-block: the new target block
;< =next=^block bind:m
(get-block-by-number:ethio url.dog number.id.i.blocks)
:: remove from either pending-logs or history
?: =(~ pending-logs.dog)
:: if no more pending logs, start deleting from history instead
::NOTE this assumes there's one history entry per item in blocks.
:: while +zoom breaks that assumption by clearing blocks, we won't
:: run out of history before running out of blocks, allowing us to
:: skip the =(number.id.block number.id.i.i.history) check.
?~ history.dog
loop(block next-block, blocks t.blocks)
;< ~ bind:m
:: don't bother sending a disavow if there were no logs there
?~ i.history.dog (pure:(async:stdio ,~) ~)
(disavow path block)
loop(block next-block, blocks t.blocks, history.dog t.history.dog)
=. pending-logs.dog
(~(del by pending-logs.dog) number.id.block)
loop(block next-block, blocks t.blocks)
::
:: Tell subscribers there was a deep reorg
::
++ disavow
|= [=path =block]
=/ m (async:stdio ,~)
^- form:m
(send-update path %disavow id.block)
::
:: Zoom forward to near a given block number.
::
:: Zooming doesn't go forward one block at a time. As a
:: consequence, it cannot detect and handle reorgs. Only use it
:: at a safe distance -- 500 blocks ago is probably sufficient.
::
++ zoom
|= [context =latest=number:block]
=/ m (async:stdio ,watchdog)
^- form:m
=/ zoom-margin=number:block 100
?: (lth latest-number (add number.dog zoom-margin))
(pure:m dog)
=/ to-number=number:block (sub latest-number zoom-margin)
;< =loglist bind:m :: oldest first
%: get-logs-by-range:ethio
url.dog
contracts.dog
topics.dog
number.dog
to-number
==
;< ~ bind:m (send-logs path loglist)
=. number.dog +(to-number)
=. blocks.dog ~
=. history.dog [loglist history.dog]
(pure:m dog)
++ leave-spider
|= [=path our=@p]
^- card
[%pass [%running path] %agent [our %spider] %leave ~]
--
::
:: Main
::
=* default-tapp default-tapp:tapp
%- create-tapp-all:tapp
^- tapp-core-all:tapp
|_ [=bowl:gall state=app-state]
++ handle-init
=/ m tapp-async
^- form:m
:: start update timer loop
;< now=@da bind:m get-time:stdio
;< ~ bind:m (wait-effect:stdio (add now refresh-rate))
(pure:m state)
^- agent:gall
=| state=app-state
%+ verb |
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
::
++ handle-diff handle-diff:default-tapp
++ on-init
^- (quip card _this)
[~ this]
::
++ handle-poke
|= in=in-poke-data
=/ m tapp-async
^- form:m
?- +<.in
++ on-save !>(state)
++ on-load
|= old=vase
|^
=+ !<(old-state=app-states old)
=? old-state ?=(%0 -.old-state)
%- (slog leaf+"upgrading eth-watcher from %0" ~)
^- app-state-1
%= old-state
- %1
dogs
%- ~(run by dogs.old-state)
|= dog=watchdog-0
%= dog
-> [~m5 ->.dog]
==
==
::
=^ cards-1=(list card) old-state
?. ?=(%1 -.old-state)
`old-state
%- (slog leaf+"upgrading eth-watcher from %1" ~)
:_ old-state(- %2)
%+ turn ~(tap by dogs.old-state)
|= [=path dog=watchdog]
(wait-shortcut path now.bowl)
::
[cards-1 this(state ?>(?=(%2 -.old-state) old-state))]
::
+$ app-states
$%(app-state-0 app-state-1 app-state)
::
+$ app-state-1
$: %1
dogs=(map path watchdog)
==
::
+$ app-state-0
$: %0
dogs=(map path watchdog-0)
==
::
+$ watchdog-0
$: config-0
running=(unit =tid:spider)
=number:block
=pending-logs
=history
blocks=(list block)
==
::
+$ config-0
$: url=@ta
from=number:block
contracts=(list address:ethereum)
=topics
==
--
::
++ on-poke
|= [=mark =vase]
?: ?=(%noun mark)
~& state
`this
?. ?=(%eth-watcher-poke mark)
(on-poke:def mark vase)
::
=+ !<(=poke vase)
?- -.poke
%watch
:: fully restart the watchdog if it doesn't exist yet,
:: or if the new config changes more than just the url.
:: or if the new config changes more than just the url or refresh rate.
=/ restart=?
?| !(~(has by dogs.state) path.in)
?! .= ->:(~(got by dogs.state) path.in)
+.config.in
?| !(~(has by dogs.state) path.poke)
?! .= ->+:(~(got by dogs.state) path.poke)
+>.config.poke
==
~? &((~(has by dogs.state) path.in) restart)
[dap.bowl 'overwriting existing watchdog on' path.in]
;< dog=watchdog bind:m
::
=/ already (~(has by dogs.state) path.poke)
~? &(already restart)
[dap.bowl 'overwriting existing watchdog on' path.poke]
=/ wait-cards
?: already
~
[(wait-shortcut path.poke now.bowl) ~]
::
=/ restart-cards
=/ dog (~(get by dogs.state) path.poke)
?. ?& restart
?=(^ dog)
?=(^ running.u.dog)
==
~
=/ =cage [%spider-stop !>([u.running.u.dog &])]
[%pass [%starting path] %agent [our.bowl %spider] %poke cage]
=/ new-dog
=/ dog=watchdog
?: restart *watchdog
(~(got by dogs.state) path.in)
(configure [path.in dog] config.in)
=. dogs.state (~(put by dogs.state) path.in dog)
(pure:m state)
(~(got by dogs.state) path.poke)
%_ dog
- config.poke
number from.config.poke
==
=. dogs.state (~(put by dogs.state) path.poke new-dog)
[wait-cards this]
::
%clear
=. dogs.state (~(del by dogs.state) path.in)
(pure:m state)
=. dogs.state (~(del by dogs.state) path.poke)
[~ this]
==
::
++ handle-take
|= =sign:tapp
=/ m tapp-async
^- form:m
?+ -.sign ~|([%strange-sign -.sign] !!)
%wake
;< ~ bind:m
;< now=@da bind:(async:tapp ,~) get-time:stdio
=/ next=@da (add now refresh-rate)
::NOTE we use +send-raw-card here to ensure we always set a new timer,
:: regardless of what happens further on in the flow.
(send-raw-card:stdio %wait /effect/(scot %da next) next)
::TODO ideally we'd process these in parallel. this seems possible,
:: but requires non-trivial work, as it deviates from tapp's flow.
:: (when making that change, take note of rpc request id's.)
=/ dogs=(list [=path dog=watchdog]) ~(tap by dogs.state)
|- ^- form:m
=* loop $
?~ dogs
(pure:m state)
=, i.dogs
;< dog=watchdog bind:m (get-updates path dog)
=. dogs.state (~(put by dogs.state) path dog)
loop(dogs t.dogs)
==
::
:: +handle-peer: subscribe & get initial subscription data
:: +on-watch: subscribe & get initial subscription data
::
:: /logs/some-path:
::
++ handle-peer
++ on-watch
|= =path
=/ m tapp-async
^- form:m
^- (quip card agent:gall)
?. ?=([%logs ^] path)
~| [%invalid-subscription-path path]
!!
;< ~ bind:m
%+ send-effect-on-bone:stdio ost.bowl
:+ %diff %eth-watcher-diff
:- %history
^- loglist
%- zing
%- flop
=< history
(~(gut by dogs.state) t.path *watchdog)
(pure:m state)
:_ this :_ ~
:* %give %fact ~ %eth-watcher-diff !>
:- %history
^- loglist
%- zing
%- flop
=< history
(~(gut by dogs.state) t.path *watchdog)
==
::
:: +handle-peek: get diagnostics data
++ on-leave on-leave:def
::
:: +on-peek: get diagnostics data
::
:: /block/some-path: get next block number to check for /some-path
::
++ handle-peek
++ on-peek
|= =path
^- (unit (unit peek-data))
?. ?=([%x %block ^] path) ~
?. (~(has by dogs.state) t.t.path) ~
:+ ~ ~
:- %atom
number:(~(got by dogs.state) t.t.path)
^- (unit (unit cage))
?+ path ~
[%x %block ^]
?. (~(has by dogs.state) t.t.path) ~
:+ ~ ~
:- %atom
!>(number:(~(got by dogs.state) t.t.path))
::
[%x %dogs ~]
``noun+!>(~(key by dogs.state))
==
::
++ on-agent
|= [=wire =sign:agent:gall]
|^
^- (quip card agent:gall)
?. ?=([%running *] wire)
(on-agent:def wire sign)
?- -.sign
%poke-ack
?~ p.sign
[~ this]
%- (slog leaf+"eth-watcher couldn't start thread" u.p.sign)
:_ (clear-running t.wire) :_ ~
(leave-spider t.wire our.bowl)
::
%watch-ack
?~ p.sign
[~ this]
%- (slog leaf+"eth-watcher couldn't start listen to thread" u.p.sign)
[~ (clear-running t.wire)]
::
%kick [~ (clear-running t.wire)]
%fact
=* path t.wire
=/ dog (~(get by dogs.state) path)
?~ dog
[~ this]
?+ p.cage.sign (on-agent:def wire sign)
%thread-fail
=+ !<([=term =tang] q.cage.sign)
%- (slog leaf+"eth-watcher failed; will retry" leaf+<term> tang)
[~ this(dogs.state (~(put by dogs.state) path u.dog(running ~)))]
::
%thread-done
=+ !<([vows=disavows pup=watchpup] q.cage.sign)
=. u.dog
%_ u.dog
- -.pup
number number.pup
blocks blocks.pup
pending-logs pending-logs.pup
==
=^ cards-1 u.dog (disavow path u.dog vows)
=^ cards-2 u.dog (release-logs path u.dog)
=. dogs.state (~(put by dogs.state) path u.dog(running ~))
[(weld cards-1 cards-2) this]
==
==
::
++ clear-running
|= =path
=/ dog (~(get by dogs.state) path)
?~ dog
this
this(dogs.state (~(put by dogs.state) path u.dog(running ~)))
::
++ disavow
|= [=path dog=watchdog vows=disavows]
^- (quip card watchdog)
=/ history-ids=(list [id:block loglist])
%+ murn history.dog
|= logs=loglist
^- (unit [id:block loglist])
?~ logs
~
`[[block-hash block-number]:(need mined.i.logs) logs]
=/ actual-vows=disavows
%+ skim vows
|= =id:block
(lien history-ids |=([=history=id:block *] =(id history-id)))
=/ actual-history=history
%+ murn history-ids
|= [=id:block logs=loglist]
^- (unit loglist)
?: (lien actual-vows |=(=vow=id:block =(id vow-id)))
~
`logs
:_ dog(history actual-history)
%+ turn actual-vows
|= =id:block
[%give %fact `[%logs path] %eth-watcher-diff !>([%disavow id])]
::
++ release-logs
|= [=path dog=watchdog]
^- (quip card watchdog)
?: (lth number.dog 30)
`dog
=/ rel-number (sub number.dog 30)
=/ numbers=(list number:block) ~(tap in ~(key by pending-logs.dog))
=. numbers (sort numbers lth)
|- ^- (quip card watchdog)
?~ numbers
`dog
?: (gth i.numbers rel-number)
$(numbers t.numbers)
=^ cards-1 dog
=/ =loglist (~(get ja pending-logs.dog) i.numbers)
=. pending-logs.dog (~(del by pending-logs.dog) i.numbers)
?~ loglist
`dog
=. history.dog [loglist history.dog]
:_ dog
%+ turn loglist
|= =event-log:rpc:ethereum
^- card
[%give %fact `[%logs path] %eth-watcher-diff !>([%log event-log])]
=^ cards-2 dog $(numbers t.numbers)
[(weld cards-1 cards-2) dog]
--
::
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card agent:gall)
?+ +<.sign-arvo ~|([%strange-sign-arvo -.sign-arvo] !!)
%wake
?. ?=([%timer *] wire) ~& weird-wire=wire [~ this]
=* path t.wire
?. (~(has by dogs.state) path)
[~ this]
=/ dog=watchdog
(~(got by dogs.state) path)
?^ error.sign-arvo
:: failed, try again. maybe should tell user if fails more than
:: 5 times.
::
%- (slog leaf+"eth-watcher failed; will retry" ~)
[[(wait path now.bowl refresh-rate.dog)]~ this]
:: start a new thread that checks for updates
::
=^ cards-1=(list card) dog
:: if still running, kill it and restart
::
?~ running.dog
`dog
::
%- (slog leaf+"eth-watcher still running; will restart" ~)
=/ =cage [%spider-stop !>([u.running.dog |])]
:_ dog(running ~)
:~ (leave-spider path our.bowl)
[%pass [%starting path] %agent [our.bowl %spider] %poke cage]
==
::
=^ cards-2=(list card) dog
=/ new-tid=@ta
(cat 3 'eth-watcher--' (scot %uv eny.bowl))
:_ dog(running `new-tid)
=/ args
:^ ~ `new-tid %eth-watcher
!>(`watchpup`[- number pending-logs blocks]:dog)
:~ (watch-spider path our.bowl /thread-result/[new-tid])
(poke-spider path our.bowl %spider-start !>(args))
==
::
:- [(wait path now.bowl refresh-rate.dog) (weld cards-1 cards-2)]
this(dogs.state (~(put by dogs.state) path dog))
==
::
++ on-fail on-fail:def
--

147
pkg/arvo/app/example-tapp-fetch.hoon
View File

@ -1,147 +0,0 @@
:: 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)
==
+$ peek-data _!!
+$ in-poke-data [%noun =cord]
+$ out-poke-data ~
+$ in-peer-data ~
+$ out-peer-data
$% [%comments (list tape)]
==
++ tapp (^tapp state peek-data 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"))
==
--
=, async=async:tapp
=, tapp-async=tapp-async: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-async
^- 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-async
^- form:m
~& [%tapp-fetch-take-peer path]
(pure:m top-comments)
::
++ handle-take
|= =sign:tapp
=/ m tapp-async
^- form:m
:: ignore %poke/peer acknowledgements
::
?. ?=(%wake -.sign)
(pure:m top-comments)
;< =state bind:m (handle-poke %noun 'fetch')
=. top-comments state
(pure:m top-comments)
--

50
pkg/arvo/app/example-tapp-subscribe.hoon
View File

@ -1,50 +0,0 @@
/+ tapp, stdio
=>
|%
+$ subscription-state
$: target=[her=ship app=term]
=path
==
+$ state
$: subscription=(unit subscription-state)
==
+$ peek-data _!!
+$ in-poke-data [%noun =cord]
+$ out-poke-data [%noun =cord]
+$ out-peer-data ~
+$ in-peer-data
$% [%comments comments=(list tape)]
==
++ tapp (^tapp state peek-data in-poke-data out-poke-data in-peer-data out-peer-data)
++ stdio (^stdio out-poke-data out-peer-data)
--
=, async=async:tapp
=, tapp-async=tapp-async:tapp
=, stdio
%- create-tapp-poke-diff:tapp
^- tapp-core-poke-diff:tapp
|_ [=bowl:gall state]
++ handle-poke
|= =in-poke-data
=/ m tapp-async
^- form:m
?: =(cord.in-poke-data 'pull')
?~ subscription
(async-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-async
^- form:m
?> ?=(%comments -.data)
~& subscriber-got-data=(lent comments.data)
(pure:m subscription)
--

493
pkg/arvo/app/gaze.hoon
View File

@ -1,493 +0,0 @@
:: gaze: azimuth statistics
::
/- eth-watcher
=, ethereum
=, azimuth
::
|%
++ state
$: :: qued: event logs waiting on block timestamp, oldest first
:: time: timstamps of block numbers
:: seen: events sorted by timestamp, newest first
:: days: stats by day, newest first
::
qued=loglist
time=(map @ud @da)
seen=(list [wen=@da wat=event])
days=(list [day=@da sat=stats])
==
::
++ loglist loglist:eth-watcher
++ event
$% [%azimuth who=ship dif=diff-point]
::TODO [%invites *]
==
::
++ stats
$: spawned=(list @p)
activated=(list @p)
transfer-p=(list @p)
transferred=(list @p)
configured=(list @p)
breached=(list @p)
request=(list @p)
sponsor=(list @p)
management-p=(list @p)
voting-p=(list @p)
spawn-p=(list @p)
==
::
::
++ move (pair bone card)
++ card
$% [%poke wire [ship %eth-watcher] %eth-watcher-poke poke:eth-watcher]
[%peer wire [ship %eth-watcher] path]
[%hiss wire (unit user:eyre) mark %hiss hiss:eyre]
[%wait wire @da]
[%info wire desk nori:clay]
==
--
::
|_ [bowl:gall state]
++ node-url 'http://eth-mainnet.urbit.org:8545'
++ export-frequency ~h1
::
++ prep
|= old=(unit state)
?~ old
:_ ..prep
[ost %wait /export (add now export-frequency)]~
[~ ..prep(+<+ u.old)]
::
:: +poke-noun: do a thing
::
:: %kick-watcher: reset, tell %eth-watcher to look for events for us
:: %regaze: reset (but keep timestamps), subscribe to eth-watcher
:: %debug: print debug info
::
++ poke-noun
|= a=?(%kick-watcher %regaze %debug)
^- (quip move _+>)
?- a
%kick-watcher
:_ +>.$(qued ~, seen ~, days ~, time ~)
:~
:- ost
:* %poke
/look
[our %eth-watcher]
%eth-watcher-poke
::
^- poke:eth-watcher
:+ %watch /[dap]
:* node-url
public:contracts
~[azimuth:contracts]
~
==
==
==
::
%regaze
:_ +>.$(qued ~, seen ~, days ~)
:~
:- ost
:* %peer
/look
[our %eth-watcher]
/[dap]
==
==
::
%debug
~& latest=(turn (scag 5 seen) head)
~& oldest=(turn (slag (sub (lent seen) 5) seen) head)
~& :- 'order is'
=- ?:(sane 'sane' 'insane')
%+ roll seen
|= [[this=@da *] last=@da sane=?]
:- this
?: =(*@da last) &
(lte this last)
~& time=~(wyt by time)
~& qued=(lent qued)
~& days=(lent days)
[~ +>.$]
==
::
:: +diff-eth-watcher-diff: process new logs, clear state on rollback
::
++ diff-eth-watcher-diff
|= [=wire =diff:eth-watcher]
^- (quip move _+>)
=^ logs +>.$
^- [loglist _+>.$]
?- -.diff
%history ~& [%got-history (lent loglist.diff)]
[loglist.diff +>.$(qued ~, seen ~)]
%log ~& %got-log
[[event-log.diff ~] +>.$]
%disavow ~& %disavow-unimplemented
[~ +>.$]
==
?~ logs [~ +>.$]
=- =^ moz +>.$ (queue-logs mistime) :: oldest first
=. +>.$ (process-logs havtime) :: oldest first
[moz +>.$]
:: sort based on timstamp known, throw out lockup logs
::
%+ roll `loglist`logs
|= [log=event-log:rpc havtime=loglist mistime=loglist]
^+ [havtime mistime]
=+ bon=block-number:(need mined.log)
?: (is-lockup-block bon) [havtime mistime]
?: (~(has by time) bon)
[[log havtime] mistime]
[havtime [log mistime]]
::
:: +is-lockup-block: whether the block contains lockup/ignorable transactions
::
:: this is the stupid dumb equivalent to actually identifying lockup
:: transactions procedurally, which is still in git history, but didn't
:: work quite right for unidentified reasons
::
++ is-lockup-block
|= num=@ud
^- ?
%+ roll
^- (list [@ud @ud])
:~ [7.050.978 7.051.038]
==
|= [[start=@ud end=@ud] in=_|]
?: in &
&((gte num start) (lte num end))
::
:: +queue-logs: hold on to new logs, requesting timestamps for them
::
++ queue-logs
|= logs=loglist :: oldest first
^- (quip move _+>)
?~ logs [~ +>]
:- [(request-timestamps logs) ~]
+>(qued (weld qued logs))
::
:: +request-timestamps: request block timestamps for the logs as necessary
::
++ request-timestamps
|= logs=loglist
^- move
=- [ost %hiss /timestamps ~ %json-rpc-response %hiss -]
^- hiss:eyre
%+ json-request:rpc
(need (de-purl:html node-url))
:- %a
^- (list json)
%+ turn
^- (list @ud)
=- ~(tap in -)
%- ~(gas in *(set @ud))
^- (list @ud)
%+ turn logs
|= log=event-log:rpc
block-number:(need mined.log)
|= num=@ud
^- json
~! *request:rpc
%+ request-to-json:rpc
`(scot %ud num)
[%eth-get-block-by-number num |]
::
:: +sigh-json-rpc-response: get block details, extract timestamps
::
++ sigh-json-rpc-response
|= [=wire =response:rpc:jstd]
^- (quip move _+>)
?> ?=([%timestamps ~] wire)
?: ?=(?(%error %fail) -.response)
~? ?=(%error -.response) [%rpc-error +.response]
~? ?=(%fail -.response) [%httr-fail hit.response]
~& %retrying-timestamps
[[(request-timestamps qued) ~] +>]
?> ?=(%batch -.response)
=- [~ (process-logs(time -, qued ~) qued)]
%- ~(gas by time)
=/ max=@ud
(roll ~(tap in ~(key by time)) max)
:: for every result, get the block number and timestamp
::
%+ turn bas.response
|= res=response:rpc:jstd
^- (pair @ud @da)
~| res
?> ?=(%result -.res)
~| id.res
:- (slav %ud id.res)
%- from-unix:chrono:userlib
%- parse-hex-result:rpc
?> ?=(%o -.res.res)
(~(got by p.res.res) 'timestamp')
::
:: +process logs that are in the queue
::
++ process-logs
|= logs=loglist :: oldest first
^+ +>
?~ logs +>
=- %_ +>.$
qued (flop rest) :: oldest first
seen (weld logs seen) :: newest first
days (count-events (flop logs)) :: oldest first
==
%+ roll `loglist`logs
|= [log=event-log:rpc rest=loglist logs=(list [wen=@da wat=event])]
:: to ensure logs are processed in sane order,
:: stop processing as soon as we skipped one
::
?^ rest [[log rest] logs]
=/ tim=(unit @da)
%- ~(get by time)
block-number:(need mined.log)
?~ tim [[log rest] logs]
:- rest
=+ ven=(event-log-to-event log)
?~ ven logs
[[u.tim u.ven] logs]
::
:: +event-log-to-event: turn raw log into gaze noun
::
++ event-log-to-event
|= log=event-log:rpc
^- (unit event)
?: =(azimuth:contracts address.log)
=+ (event-log-to-point-diff log)
?~ - ~
`azimuth+u
::TODO delegated sending support
~
::
:: +count-events: add events to the daily stats
::
++ count-events
|= logs=_seen :: oldest first
^+ days
=/ head=[day=@da sat=stats]
?^ days i.days
*[@da stats]
=+ tail=?~(days ~ t.days)
|-
:: when done, store updated head, but only if it's set
::
?~ logs
?: =(*[@da stats] head) tail
[head tail]
=* log i.logs
:: calculate day for current event, set head if unset
::
=/ day=@da
(sub wen.log (mod wen.log ~d1))
=? day.head =(*@da day.head) day
:: same day as head, so add to it
::
?: =(day day.head)
%_ $
sat.head (count-event wat.log sat.head)
logs t.logs
==
~| [%weird-new-day old=day.head new=day]
?> (gth day day.head)
:: newer day than head of days, so start new head
::
%_ $
tail [head tail]
head [day *stats]
==
::
:: +count-event: add event to the stats, if it's relevant
::
++ count-event
|= [eve=event sat=stats]
^- stats
?> ?=(%azimuth -.eve)
?+ -.dif.eve sat
%spawned sat(spawned [who.dif.eve spawned.sat])
%activated sat(activated [who.eve activated.sat])
%transfer-proxy ?: =(0x0 new.dif.eve) sat
sat(transfer-p [who.eve transfer-p.sat])
%owner sat(transferred [who.eve transferred.sat])
%keys sat(configured [who.eve configured.sat])
%continuity sat(breached [who.eve breached.sat])
%escape ?~ new.dif.eve sat
sat(request [who.eve request.sat])
%sponsor ?. has.new.dif.eve sat
sat(sponsor [who.eve sponsor.sat])
%management-proxy sat(management-p [who.eve management-p.sat])
%voting-proxy sat(voting-p [who.eve voting-p.sat])
%spawn-proxy sat(spawn-p [who.eve spawn-p.sat])
==
::
::
:: +wake-export: periodically export data
::
++ wake-export
|= [=wire ~]
^- (quip move _+>)
:_ +>
:~ [ost %wait /export (add now export-frequency)]
(export-move %days (export-days days))
(export-move %months (export-months days))
(export-move %events export-raw)
==
::
:: +export-move: %info move to write exported .txt
::
++ export-move
|= [nom=@t dat=(list @t)]
^- move
:^ ost %info /export/[nom]
%+ foal:space:userlib
/(scot %p our)/home/(scot %da now)/gaze-exports/[nom]/txt
[%txt !>(dat)]
::
:: +peek-x: accept gall scry
::
:: %/days/txt: per day, digest stats
:: %/months/txt: per month, digest stats
:: %/raw/txt: all observed events
::
++ peek-x
|= pax=path
^- (unit (unit (pair mark *)))
?~ pax ~
?: =(%days i.pax)
:^ ~ ~ %txt
(export-days days)
?: =(%months i.pax)
:^ ~ ~ %txt
(export-months days)
?: =(%raw i.pax)
``txt+export-raw
~
::
:: +export-months: generate a csv of stats per month
::
++ export-months
|= =_days
%- export-days
^+ days
%+ roll (flop days)
|= [[day=@da sat=stats] mos=(list [mod=@da sat=stats])]
^+ mos
=/ mod=@da
%- year
=+ (yore day)
-(d.t 1)
?~ mos [mod sat]~
?: !=(mod mod.i.mos)
[[mod sat] mos]
:_ t.mos
:- mod
::TODO this is hideous. can we make a wet gate do this?
:* (weld spawned.sat spawned.sat.i.mos)
(weld activated.sat activated.sat.i.mos)
(weld transfer-p.sat transfer-p.sat.i.mos)
(weld transferred.sat transferred.sat.i.mos)
(weld configured.sat configured.sat.i.mos)
(weld breached.sat breached.sat.i.mos)
(weld request.sat request.sat.i.mos)
(weld sponsor.sat sponsor.sat.i.mos)
(weld management-p.sat management-p.sat.i.mos)
(weld voting-p.sat voting-p.sat.i.mos)
(weld spawn-p.sat spawn-p.sat.i.mos)
==
::
:: +export-days: generate a csv of stats per day
::
++ export-days
|= =_days
:- %- crip
;: weld
"date,"
"spawned,"
"activated,"
"transfer proxy,"
"transferred,"
"transferred (unique),"
"configured,"
"configured (unique),"
"escape request,"
"sponsor change"
==
|^ ^- (list @t)
%+ turn days
|= [day=@da stats]
%- crip
;: weld
(scow %da day) ","
(count spawned) ","
(count activated) ","
(count transfer-p) ","
(unique transferred) ","
(unique configured) ","
(count request) ","
(count sponsor)
==
::
++ count
|* l=(list)
(num (lent l))
::
++ unique
|* l=(list)
;: weld
(count l)
","
(num ~(wyt in (~(gas in *(set)) l)))
==
::
++ num (d-co:co 1)
--
::
:: +export-raw: generate a csv of individual transactions
::
++ export-raw
:- %- crip
;: weld
"date,"
"point,"
"event,"
"field 1"
==
|^ ^- (list @t)
%+ turn seen
|= [wen=@da wat=event]
%- crip
;: weld
(scow %da wen) ","
(pon who.wat) ","
(point-diff-to-row dif.wat)
==
::
++ point-diff-to-row
|= dif=diff-point
?- -.dif
%full "full,"
%owner "owner,{(adr new.dif)}"
%activated "activated,"
%spawned "spawned,{(pon who.dif)}"
%keys "keys,{(num life.dif)}"
%continuity "breached,{(num new.dif)}"
%sponsor "sponsor,{(spo has.new.dif)} {(pon who.new.dif)}"
%escape "escape-req,{(req new.dif)}"
%management-proxy "management-p,{(adr new.dif)}"
%voting-proxy "voting-p,{(adr new.dif)}"
%spawn-proxy "spawn-p,{(adr new.dif)}"
%transfer-proxy "transfer-p,{(adr new.dif)}"
==
::
++ num (d-co:co 1)
++ pon (cury scow %p)
++ adr |=(a=@ ['0' 'x' ((x-co:co (mul 2 20)) a)])
++ spo |=(h=? ?:(h "escaped to" "detached from"))
++ req |=(r=(unit @p) ?~(r "canceled" (pon u.r)))
--
--

7
pkg/arvo/app/goad.hoon
View File

@ -1,7 +0,0 @@
|_ [=bowl:gall ~]
++ poke-noun
|= a=*
:_ ..poke-noun
=/ force ?=(%force a)
[[ost.bowl %goad /goad force ~] ~]
--

267
pkg/arvo/app/group-hook.hoon
View File

@ -1,128 +1,169 @@
:: group-hook: allow syncing group data from foreign paths to local paths
::
/- *group-store, *group-hook
/+ default-agent
|%
+$ move [bone card]
+$ card card:agent:gall
::
+$ card
$% [%diff [%group-update group-update]]
[%quit ~]
[%poke wire dock [%group-action group-action]]
[%pull wire dock ~]
[%peer wire dock path]
++ versioned-state
$% state-zero
==
::
+$ state
$% [%0 state-zero]
==
::
+$ state-zero
$: synced=(map path ship)
boned=(map wire (list bone))
$: %0
synced=(map path ship)
==
::
--
::
|_ [bol=bowl:gall state]
=| state-zero
=* state -
^- agent:gall
=<
|_ =bowl:gall
+* this .
group-core +>
gc ~(. group-core bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(state-zero old))
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?. ?=(%group-hook-action mark)
(on-poke:def mark vase)
=^ cards state
(poke-group-hook-action:gc !<(group-hook-action vase))
[cards this]
::
++ on-watch
|= =path
^- (quip card _this)
?. ?=([%group @ *] path)
(on-watch:def path)
?. (~(has by synced.state) t.path)
(on-watch:def path)
=/ scry-path=^path
:(welp /=group-store/(scot %da now.bowl) t.path /noun)
=/ grp=(unit group)
.^((unit group) %mx scry-path)
?~ grp
(on-watch:def path)
:_ this
[%give %fact ~ %group-update !>([%path u.grp t.path])]~
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
?+ -.sign (on-agent:def wire sign)
::
%watch-ack
?~ p.sign
[~ this]
%- (slog u.p.sign)
?> ?=([@ @ *] wire)
=/ =ship (slav %p i.wire)
=. synced.state (~(del by synced.state) t.t.wire)
[~ this]
::
%kick
?> ?=([@ @ *] wire)
=/ =ship (slav %p i.wire)
?. (~(has by synced.state) wire)
[~ this]
=/ group-path [%group wire]
=/ group-wire [i.wire group-path]
:_ this
[%pass group-wire %agent [ship %group-hook] %watch group-path]~
::
%fact
?. ?=(%group-update p.cage.sign)
(on-agent:def wire sign)
=^ cards state
?: (team:title our.bowl src.bowl)
(handle-local:gc !<(group-update q.cage.sign))
(handle-foreign:gc !<(group-update q.cage.sign))
[cards this]
==
--
::
++ this .
::
++ prep
|= old=(unit state)
^- (quip move _this)
?~ old
[~ this]
[~ this(+<+ u.old)]
|_ bol=bowl:gall
::
++ poke-group-hook-action
|= act=group-hook-action
^- (quip move _this)
^- (quip card _state)
?- -.act
%add
?. (team:title our.bol src.bol)
[~ this]
[~ state]
=/ group-path [%group path.act]
=/ group-wire [(scot %p ship.act) group-path]
?: (~(has by synced) path.act)
[~ this]
=. synced (~(put by synced) path.act ship.act)
:_ (track-bone group-wire)
?: (~(has by synced.state) path.act)
[~ state]
=. synced.state (~(put by synced.state) path.act ship.act)
:_ state
?: =(ship.act our.bol)
[ost.bol %peer group-wire [ship.act %group-store] group-path]~
[ost.bol %peer group-wire [ship.act %group-hook] group-path]~
[%pass group-wire %agent [ship.act %group-store] %watch group-path]~
[%pass group-wire %agent [ship.act %group-hook] %watch group-path]~
::
%remove
=/ ship (~(get by synced) path.act)
=/ ship (~(get by synced.state) path.act)
?~ ship
[~ this]
[~ state]
?: &(=(u.ship our.bol) (team:title our.bol src.bol))
:: delete one of our own paths
=/ group-wire [(scot %p our.bol) %group path.act]
:_ this(synced (~(del by synced) path.act))
%+ weld
:_ state(synced (~(del by synced.state) path.act))
%+ snoc
(pull-wire group-wire path.act)
^- (list move)
%+ turn (prey:pubsub:userlib [%group path.act] bol)
|= [=bone *]
^- move
[bone %quit ~]
[%give %kick `[%group path.act] ~]
?: |(=(u.ship src.bol) (team:title our.bol src.bol))
:: delete a foreign ship's path
=/ group-wire [(scot %p u.ship) %group path.act]
:_ this(synced (~(del by synced) path.act))
:_ state(synced (~(del by synced.state) path.act))
(pull-wire group-wire path.act)
:: don't allow
[~ this]
[~ state]
==
::
++ peer-group
|= pax=path
^- (quip move _this)
?~ pax !!
?> (~(has by synced) pax)
=/ grp (group-scry pax)
?~ grp !!
:_ this
[ost.bol %diff [%group-update [%path u.grp pax]]]~
::
++ diff-group-update
|= [wir=wire diff=group-update]
^- (quip move _this)
?: (team:title our.bol src.bol)
(handle-local diff)
(handle-foreign diff)
::
++ handle-local
|= diff=group-update
^- (quip move _this)
^- (quip card _state)
?- -.diff
%keys [~ this]
%path [~ this]
%bundle [~ this]
%add [(update-subscribers [%group pax.diff] diff) this]
%remove [(update-subscribers [%group pax.diff] diff) this]
%keys [~ state]
%path [~ state]
%bundle [~ state]
%add [(update-subscribers [%group pax.diff] diff) state]
%remove [(update-subscribers [%group pax.diff] diff) state]
::
%unbundle
:_ this(synced (~(del by synced) pax.diff))
%+ weld
:_ state(synced (~(del by synced.state) pax.diff))
%+ snoc
(update-subscribers [%group pax.diff] diff)
^- (list move)
%+ turn (prey:pubsub:userlib [%group pax.diff] bol)
|= [=bone *]
[bone %quit ~]
[%give %kick `[%group pax.diff] ~]
==
::
++ handle-foreign
|= diff=group-update
^- (quip move _this)
^- (quip card _state)
?- -.diff
%keys [~ this]
%bundle [~ this]
%keys [~ state]
%bundle [~ state]
::
%path
:_ this
:_ state
?~ pax.diff ~
=/ ship (~(get by synced) pax.diff)
=/ ship (~(get by synced.state) pax.diff)
?~ ship ~
?. =(src.bol u.ship) ~
:~ (group-poke pax.diff [%unbundle pax.diff])
@ -131,98 +172,56 @@
==
::
%add
:_ this
:_ state
?~ pax.diff ~
=/ ship (~(get by synced) pax.diff)
=/ ship (~(get by synced.state) pax.diff)
?~ ship ~
?. =(src.bol u.ship) ~
[(group-poke pax.diff diff)]~
::
%remove
:_ this
:_ state
?~ pax.diff ~
=/ ship (~(get by synced) pax.diff)
=/ ship (~(get by synced.state) pax.diff)
?~ ship ~
?. =(src.bol u.ship) ~
[(group-poke pax.diff diff)]~
::
%unbundle
?~ pax.diff
[~ this]
=/ ship (~(get by synced) pax.diff)
[~ state]
=/ ship (~(get by synced.state) pax.diff)
?~ ship
[~ this]
[~ state]
?. =(src.bol u.ship)
[~ this]
:_ this(synced (~(del by synced) pax.diff))
[~ state]
:_ state(synced (~(del by synced.state) pax.diff))
[(group-poke pax.diff diff)]~
==
::
++ quit
|= wir=wire
^- (quip move _this)
=^ =ship wir
?> ?=([* ^] wir)
[(slav %p i.wir) t.t.wir]
?. (~(has by synced) wir)
[~ this]
=/ group-path [%group wir]
=/ group-wire [(scot %p ship) group-path]
:_ (track-bone group-wire)
[ost.bol %peer group-wire [ship %group-hook] group-path]~
::
++ reap
|= [wir=wire saw=(unit tang)]
^- (quip move _this)
?~ saw
[~ this]
=^ =ship wir
?> ?=([* ^] wir)
[(slav %p i.wir) t.t.wir]
~& %insufficient-permissions-for-group
[((slog u.saw) ~) this(synced (~(del by synced) wir))]
::
++ group-poke
|= [pax=path action=group-action]
^- move
[ost.bol %poke pax [our.bol %group-store] [%group-action action]]
^- card
[%pass pax %agent [our.bol %group-store] %poke %group-action !>(action)]
::
++ group-scry
|= pax=path
^- (unit group)
.^((unit group) %gx ;:(weld /=group-store/(scot %da now.bol) pax /noun))
.^((unit group) %mx ;:(weld /=group-store/(scot %da now.bol) pax /noun))
::
++ update-subscribers
|= [pax=path diff=group-update]
^- (list move)
%+ turn (prey:pubsub:userlib pax bol)
|= [=bone *]
^- move
[bone %diff [%group-update diff]]
::
++ track-bone
|= wir=wire
^+ this
=/ bnd (~(get by boned) wir)
?^ bnd
this(boned (~(put by boned) wir (snoc u.bnd ost.bol)))
this(boned (~(put by boned) wir [ost.bol]~))
^- (list card)
[%give %fact `pax %group-update !>(diff)]~
::
++ pull-wire
|= [wir=wire pax=path]
^- (list move)
=/ bnd (~(get by boned) wir)
?~ bnd
~
=/ shp (~(get by synced) pax)
^- (list card)
=/ shp (~(get by synced.state) pax)
?~ shp
~
%+ turn u.bnd
|= ost=bone
^- move
?: =(u.shp our.bol)
[ost %pull wir [our.bol %group-store] ~]
[ost %pull wir [u.shp %group-hook] ~]
[%pass wir %agent [our.bol %group-store] %leave ~]~
[%pass wir %agent [u.shp %group-hook] %leave ~]~
::
--

156
pkg/arvo/app/group-store.hoon
View File

@ -1,15 +1,17 @@
:: group-store: data store for groups of ships
::
/- *group-store
/+ default-agent
|%
+$ move [bone [%diff diff]]
+$ card card:agent:gall
::
+$ state
$% [%0 state-zero]
+$ versioned-state
$% state-zero
==
::
+$ state-zero
$: =groups
$: %0
=groups
==
::
+$ diff
@ -18,50 +20,71 @@
==
--
::
|_ [bol=bowl:gall state]
=| state-zero
=* state -
^- agent:gall
=<
|_ =bowl:gall
+* this .
group-core +>
gc ~(. group-core bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(state-zero old))
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?> (team:title our.bowl src.bowl)
=^ cards state
?: ?=(%group-action mark)
(poke-group-action:gc !<(group-action vase))
(on-poke:def mark vase)
[cards this]
::
++ on-watch
|= =path
^- (quip card _this)
?> (team:title our.bowl src.bowl)
|^
=/ cards=(list card)
?+ path (on-watch:def path)
[%all ~] (give %group-initial !>(groups))
[%keys ~] (give %group-update !>([%keys ~(key by groups)]))
[%group *]
(give %group-update !>([%path (~(got by groups) t.path) t.path]))
==
[cards this]
::
++ give
|= =cage
^- (list card)
[%give %fact ~ cage]~
--
::
++ on-leave on-leave:def
::
++ on-peek
|= =path
^- (unit (unit cage))
?+ path (on-peek:def path)
[%x *] ``noun+!>((~(get by groups) t.path))
==
::
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
++ this .
::
++ prep
|= old=(unit state)
^- (quip move _this)
[~ ?~(old this this(+<+ u.old))]
::
++ peek-x
|= pax=path
^- (unit (unit [%noun (unit group)]))
?~ pax
[~ ~ %noun ~]
=/ grp=(unit group) (~(get by groups) pax)
[~ ~ %noun grp]
::
++ peer-all
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
:: we now proxy all events to this path
:_ this
[ost.bol %diff %group-initial groups]~
::
++ peer-keys
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
:: we send the list of keys then send events when they change
:_ this
[ost.bol %diff %group-update [%keys ~(key by groups)]]~
::
++ peer-group
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
=/ grp (~(got by groups) pax)
:_ this
[ost.bol %diff %group-update [%path grp pax]]~
|_ bol=bowl:gall
::
++ poke-group-action
|= action=group-action
^- (quip move _this)
^- (quip card _state)
?> (team:title our.bol src.bol)
?- -.action
%add (handle-add action)
@ -72,66 +95,64 @@
::
++ handle-add
|= act=group-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%add -.act)
?~ pax.act
[~ this]
[~ state]
?. (~(has by groups) pax.act)
[~ this]
[~ state]
=/ members (~(got by groups) pax.act)
=. members (~(uni in members) members.act)
?: =(members (~(got by groups) pax.act))
[~ this]
[~ state]
:- (send-diff pax.act act)
this(groups (~(put by groups) pax.act members))
state(groups (~(put by groups) pax.act members))
::
++ handle-remove
|= act=group-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%remove -.act)
?~ pax.act
[~ this]
[~ state]
?. (~(has by groups) pax.act)
[~ this]
[~ state]
=/ members (~(got by groups) pax.act)
=. members (~(dif in members) members.act)
?: =(members (~(got by groups) pax.act))
[~ this]
[~ state]
:- (send-diff pax.act act)
this(groups (~(put by groups) pax.act members))
state(groups (~(put by groups) pax.act members))
::
++ handle-bundle
|= act=group-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%bundle -.act)
?~ pax.act
[~ this]
[~ state]
?: (~(has by groups) pax.act)
[~ this]
[~ state]
:- (send-diff pax.act act)
this(groups (~(put by groups) pax.act *group))
state(groups (~(put by groups) pax.act *group))
::
++ handle-unbundle
|= act=group-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%unbundle -.act)
?~ pax.act
[~ this]
[~ state]
?. (~(has by groups) pax.act)
[~ this]
[~ state]
:- (send-diff pax.act act)
this(groups (~(del by groups) pax.act))
state(groups (~(del by groups) pax.act))
::
++ update-subscribers
|= [pax=path act=group-action]
^- (list move)
%+ turn (prey:pubsub:userlib pax bol)
|= [=bone *]
[bone %diff %group-update act]
^- (list card)
[%give %fact `pax %group-update !>(act)]~
::
++ send-diff
|= [pax=path act=group-action]
^- (list move)
^- (list card)
%- zing
:~ (update-subscribers /all act)
(update-subscribers [%group pax] act)
@ -141,4 +162,3 @@
==
::
--

263
pkg/arvo/app/hood.hoon
View File

@ -2,6 +2,7 @@
:::: /hoon/hood/app :: ::
:: :: ::
/? 310 :: zuse version
/- *sole
/+ sole, :: libraries
:: XX these should really be separate apps, as
:: none of them interact with each other in
@ -21,13 +22,18 @@
=> |%
+$ part [%module %0 pith]
+$ pith ~
::
+$ move [bone card]
+$ card $% [%fake ~]
==
++ take
|~ [wire sign-arvo]
*(quip card:agent:gall part)
++ take-agent
|~ [wire gift:agent:gall]
*(quip card:agent:gall part)
++ poke
|~ [mark vase]
*(quip card:agent:gall part)
--
|= [bowl:gall own=part]
|_ moz=(list move)
|_ moz=(list card:agent:gall)
++ abet [(flop moz) own]
--
--
@ -77,131 +83,136 @@
:: :: ::
:::: :: :: app proper
:: :: ::
=, gall
|_ $: hid/bowl :: gall environment
hood-1 :: module states
== ::
++ able :: find+make part
=+ hed=$:hood-head
|@ ++ $
=+ rep=(~(get by lac) hed)
=+ par=?^(rep u.rep `hood-part`(hood-make our.hid hed))
((hood-good hed) par)
--
^- agent:gall
=| hood-1 :: module states
=> |%
++ help
|= hid/bowl:gall
|%
++ able :: find+make part
=+ hed=$:hood-head
|@ ++ $
=+ rep=(~(get by lac) hed)
=+ par=?^(rep u.rep `hood-part`(hood-make our.hid hed))
((hood-good hed) par)
--
::
++ ably :: save part
=+ $:{(list) hood-part}
|@ ++ $
[+<- (~(put by lac) +<+< +<+)]
--
:: :: ::
:::: :: :: generic handling
:: :: ::
++ prep
|= old/(unit hood-old) ^- (quip _!! _+>)
:- ~
?~ old +>
+>(lac (~(run by lac.u.old) hood-port))
::
++ poke-hood-load :: recover lost brain
|= dat/hood-part
?> =(our.hid src.hid)
~& loaded+-.dat
[~ (~(put by lac) -.dat dat)]
::
::
++ from-module :: create wrapper
|* _[identity=%module start=..$ finish=_abet]:(hood-module)
=- [wrap=- *start] :: usage (wrap handle-arm):from-foo
|* handle/_finish
|= a=_+<.handle
=. +>.handle (start hid (able identity))
^- (quip card:agent:gall _lac)
%- ably
^- (quip card:agent:gall hood-part)
(handle a)
:: per-module interface wrappers
++ from-drum (from-module %drum [..$ _se-abet]:(hood-drum))
++ from-helm (from-module %helm [..$ _abet]:(hood-helm))
++ from-kiln (from-module %kiln [..$ _abet]:(hood-kiln))
++ from-write (from-module %write [..$ _abet]:(hood-write))
--
--
|_ hid/bowl:gall :: gall environment
++ on-init
`..on-init
::
++ ably :: save part
=+ $:{(list) hood-part}
|@ ++ $
[(flop +<-) %_(+> lac (~(put by lac) +<+< +<+))]
--
:: :: ::
:::: :: :: generic handling
:: :: ::
++ prep
|= old/(unit hood-old) ^- (quip _!! _+>)
:- ~
?~ old +>
+>(lac (~(run by lac.u.old) hood-port))
++ on-save
!>([%1 lac])
::
++ poke-hood-load :: recover lost brain
|= dat/hood-part
?> =(our.hid src.hid)
~& loaded+-.dat
[~ %_(+> lac (~(put by lac) -.dat dat))]
++ on-load
|= =old-state=vase
=/ old-state !<(hood-1 old-state-vase)
`..on-init(lac lac.old-state)
::
++ on-poke
|= [=mark =vase]
^- (quip card:agent:gall agent:gall)
=/ h (help hid)
=^ cards lac
?: =(%helm (end 3 4 mark))
((wrap poke):from-helm:h mark vase)
?: =(%drum (end 3 4 mark))
((wrap poke):from-drum:h mark vase)
?: =(%kiln (end 3 4 mark))
((wrap poke):from-kiln:h mark vase)
?: =(%write (end 3 5 mark))
((wrap poke):from-write:h mark vase)
:: XX should rename and move to libs
::
?+ mark ~|([%poke-hood-bad-mark mark] !!)
%hood-load (poke-hood-load:h !<(hood-part vase))
%atom ((wrap poke-atom):from-helm:h !<(@ vase))
%dill-belt ((wrap poke-dill-belt):from-drum:h !<(dill-belt:dill vase))
%dill-blit ((wrap poke-dill-blit):from-drum:h !<(dill-blit:dill vase))
%hood-sync ((wrap poke-sync):from-kiln:h !<([desk ship desk] vase))
==
[cards ..on-init]
::
++ from-module :: create wrapper
|* _[identity=%module start=..$ finish=_abet]:(hood-module)
=- [wrap=- *start] :: usage (wrap handle-arm):from-foo
|* handle/_finish
|= a=_+<.handle
=. +>.handle (start hid (able identity))
(ably (handle a))
++ on-watch
|= =path
=/ h (help hid)
=^ cards lac
?+ path ~|([%hood-bad-path wire] !!)
[%drum *] ((wrap peer):from-drum:h t.path)
==
[cards ..on-init]
::
:: per-module interface wrappers
++ from-drum (from-module %drum [..$ _se-abet]:(hood-drum))
++ from-helm (from-module %helm [..$ _abet]:(hood-helm))
++ from-kiln (from-module %kiln [..$ _abet]:(hood-kiln))
++ from-write (from-module %write [..$ _abet]:(hood-write))
++ on-leave
|= path
`..on-init
::
:: :: ::
:::: :: :: switchboard
:: :: ::
++ coup-drum-phat (wrap take-coup-phat):from-drum
++ coup-helm-hi (wrap coup-hi):from-helm
++ coup-kiln-fancy (wrap take-coup-fancy):from-kiln
++ coup-kiln-reload (wrap take-coup-reload):from-kiln
++ coup-kiln-spam (wrap take-coup-spam):from-kiln
++ diff-sole-effect-drum-phat (wrap diff-sole-effect-phat):from-drum
++ init-helm |=({way/wire *} [~ +>])
++ mack-kiln (wrap mack):from-kiln
++ made-write (wrap made):from-write
++ made-kiln (wrap take-made):from-kiln
++ mere-kiln (wrap take-mere):from-kiln
++ mere-kiln-sync (wrap take-mere-sync):from-kiln
++ wake-kiln-autocommit (wrap take-wake-autocommit):from-kiln
++ wake-kiln-overload (wrap take-wake-overload):from-kiln
++ wake-helm-automass (wrap take-wake-automass):from-helm
++ onto-drum (wrap take-onto):from-drum
++ peer-drum (wrap peer):from-drum
++ poke-atom (wrap poke-atom):from-helm
++ poke-dill-belt (wrap poke-dill-belt):from-drum
++ poke-dill-blit (wrap poke-dill-blit):from-drum
++ poke-drum-put (wrap poke-put):from-drum
++ poke-drum-link (wrap poke-link):from-drum
++ poke-drum-unlink (wrap poke-unlink):from-drum
++ poke-drum-exit (wrap poke-exit):from-drum
++ poke-drum-start (wrap poke-start):from-drum
++ poke-drum-set-boot-apps (wrap poke-set-boot-apps):from-drum
++ poke-helm-hi (wrap poke-hi):from-helm
::++ poke-helm-invite (wrap poke-invite):from-helm
++ poke-helm-knob (wrap poke-knob):from-helm
++ poke-helm-mass (wrap poke-mass):from-helm
++ poke-helm-reload (wrap poke-reload):from-helm
++ poke-helm-reload-desk (wrap poke-reload-desk):from-helm
++ poke-helm-reset (wrap poke-reset):from-helm
++ poke-helm-serve (wrap poke-serve):from-helm
++ poke-helm-send-hi (wrap poke-send-hi):from-helm
++ poke-helm-verb (wrap poke-verb):from-helm
++ poke-helm-rekey (wrap poke-rekey):from-helm
++ poke-helm-moon (wrap poke-moon):from-helm
++ poke-helm-nuke (wrap poke-nuke):from-helm
++ poke-helm-automass (wrap poke-automass):from-helm
++ poke-helm-cancel-automass (wrap poke-cancel-automass):from-helm
++ poke-helm-bonk (wrap poke-bonk):from-helm
++ poke-hood-sync (wrap poke-sync):from-kiln
++ poke-kiln-commit (wrap poke-commit):from-kiln
++ poke-kiln-info (wrap poke-info):from-kiln
++ poke-kiln-label (wrap poke-label):from-kiln
++ poke-kiln-merge (wrap poke-merge):from-kiln
++ poke-kiln-cancel (wrap poke-cancel):from-kiln
++ poke-kiln-cancel-autocommit (wrap poke-cancel-autocommit):from-kiln
++ poke-kiln-mount (wrap poke-mount):from-kiln
++ poke-kiln-rm (wrap poke-rm):from-kiln
++ poke-kiln-schedule (wrap poke-schedule):from-kiln
++ poke-kiln-track (wrap poke-track):from-kiln
++ poke-kiln-sync (wrap poke-sync):from-kiln
++ poke-kiln-syncs (wrap poke-syncs):from-kiln
++ poke-kiln-start-autoload (wrap poke-start-autoload):from-kiln
++ poke-kiln-wipe-ford (wrap poke-wipe-ford):from-kiln
++ poke-kiln-keep-ford (wrap poke-keep-ford):from-kiln
++ poke-kiln-autoload (wrap poke-autoload):from-kiln
++ poke-kiln-overload (wrap poke-overload):from-kiln
++ poke-kiln-goad-gall (wrap poke-goad-gall):from-kiln
++ poke-kiln-wash-gall (wrap poke-wash-gall):from-kiln
++ poke-kiln-unmount (wrap poke-unmount):from-kiln
++ poke-kiln-unsync (wrap poke-unsync):from-kiln
++ poke-kiln-permission (wrap poke-permission):from-kiln
++ poke-write-sec-atom (wrap poke-sec-atom):from-write
++ poke-write-paste (wrap poke-paste):from-write
++ poke-write-tree (wrap poke-tree):from-write
++ poke-write-wipe (wrap poke-wipe):from-write
++ quit-drum-phat (wrap quit-phat):from-drum
++ reap-drum-phat (wrap reap-phat):from-drum
++ woot-helm (wrap take-woot):from-helm
++ writ-kiln-autoload (wrap take-writ-autoload):from-kiln
++ writ-kiln-find-ship (wrap take-writ-find-ship):from-kiln
++ writ-kiln-sync (wrap take-writ-sync):from-kiln
++ bound (wrap take-bound):from-helm
++ on-peek
|= path
*(unit (unit cage))
::
++ on-agent
|= [=wire =sign:agent:gall]
=/ h (help hid)
=^ cards lac
?+ wire ~|([%hood-bad-wire wire] !!)
[%helm *] ((wrap take-agent):from-helm:h wire sign)
[%kiln *] ((wrap take-agent):from-kiln:h wire sign)
[%drum *] ((wrap take-agent):from-drum:h wire sign)
[%write *] ((wrap take-agent):from-write:h wire sign)
==
[cards ..on-init]
::
++ on-arvo
|= [=wire =sign-arvo]
=/ h (help hid)
=^ cards lac
?+ wire ~|([%hood-bad-wire wire] !!)
[%helm *] ((wrap take):from-helm:h t.wire sign-arvo)
[%drum *] ((wrap take):from-drum:h t.wire sign-arvo)
[%kiln *] ((wrap take-general):from-kiln:h t.wire sign-arvo)
[%write *] ((wrap take):from-write:h t.wire sign-arvo)
==
[cards ..on-init]
::
++ on-fail
|= [term tang]
`..on-init
--

123
pkg/arvo/app/invite-hook.hoon
View File

@ -1,61 +1,114 @@
:: invite-hook: receive invites from any source
::
/+ *invite-json
:: only handles %invite actions. accepts json, but only from the host team.
:: can be poked by the host team to send an invite out to someone.
:: can be poked by foreign ships to send an invite to us.
::
/+ *invite-json, default-agent, verb
::
|%
+$ move [bone [%poke wire dock [%invite-action invite-action]]]
+$ state-0 [%0 ~]
::
+$ card card:agent:gall
--
::
|_ [bol=bowl:gall ~]
=| state-0
=* state -
::
++ this .
::
++ poke-json
|= =json
^- (quip move _this)
?> (team:title our.bol src.bol)
=/ act (json-to-action json)
?> ?=(%invite -.act)
:_ this
[(invite-hook-poke recipient.invite.act act)]~
::
++ poke-invite-action
|= act=invite-action
^- (quip move _this)
:_ this
?+ -.act
~
%+ verb |
^- agent:gall
=<
|_ =bowl:gall
+* this .
do ~(. +> bowl)
def ~(. (default-agent this %|) bowl)
::
%invite
?: (team:title our.bol src.bol)
?> !(team:title our.bol ship.invite.act)
[(invite-hook-poke recipient.invite.act act)]~
?> ?=(^ (invitatory-scry path.act))
?> ?=(~ (invite-scry path.act uid.act))
[(invite-poke path.act act)]~
==
++ on-init
^- (quip card _this)
[~ this]
::
++ on-save !>(state)
++ on-load
|= old=vase
^- (quip card _this)
[~ this(state !<(state-0 old))]
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
:_ this
?+ mark (on-poke:def mark vase)
%json
:: only accept json from ourselves.
::
?> (team:title our.bowl src.bowl)
=/ act (json-to-action !<(json vase))
?> ?=(%invite -.act)
[(invite-hook-poke:do recipient.invite.act act)]~
::
%invite-action
=/ act=invite-action !<(invite-action vase)
?. ?=(%invite -.act) ~
:: if the sender is us,
::
?: (team:title our.bowl src.bowl)
:: outgoing. we must be inviting another ship. send them the invite.
::
?> !(team:title our.bowl ship.invite.act)
[(invite-hook-poke:do recipient.invite.act act)]~
:: else incoming. ensure invitatory exists and invite is not a duplicate.
::
?> ?=(^ (invitatory-scry:do path.act))
?> ?=(~ (invite-scry:do path.act uid.act))
[(invite-poke:do path.act act)]~
==
::
++ on-peek on-peek:def
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
|_ =bowl:gall
::
++ invite-hook-poke
|= [=ship action=invite-action]
^- move
[ost.bol %poke /invite-hook [ship %invite-hook] [%invite-action action]]
^- card
:* %pass
/invite-hook
%agent
[ship %invite-hook]
%poke
%invite-action
!>(action)
==
::
++ invite-poke
|= [pax=path action=invite-action]
^- move
[ost.bol %poke pax [our.bol %invite-store] [%invite-action action]]
|= [=path action=invite-action]
^- card
:* %pass
path
%agent
[our.bowl %invite-store]
%poke
%invite-action
!>(action)
==
::
++ invitatory-scry
|= pax=path
^- (unit invitatory)
=. pax
;:(weld /=invite-store/(scot %da now.bol)/invitatory pax /noun)
;:(weld /=invite-store/(scot %da now.bowl)/invitatory pax /noun)
.^((unit invitatory) %gx pax)
::
++ invite-scry
|= [pax=path uid=serial]
^- (unit invite)
=. pax
;:(weld /=invite-store/(scot %da now.bol)/invite pax /(scot %uv uid)/noun)
;:(weld /=invite-store/(scot %da now.bowl)/invite pax /(scot %uv uid)/noun)
.^((unit invite) %gx pax)
--

166
pkg/arvo/app/invite-store.hoon
View File

@ -1,48 +1,89 @@
/+ *invite-json
/+ *invite-json, default-agent
|%
+$ move [bone card]
+$ card card:agent:gall
::
+$ card
$% [%diff invite-diff]
[%quit ~]
==
::
+$ state
$% [%0 state-zero]
+$ versioned-state
$% state-zero
==
::
+$ state-zero
$: =invites
$: %0
=invites
==
--
::
|_ [bol=bowl:gall state]
=| state-zero
=* state -
^- agent:gall
=<
|_ bol=bowl:gall
+* this .
inv-core +>
ic ~(. inv-core bol)
def ~(. (default-agent this %|) bol)
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(state-zero old))
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?> (team:title our.bol src.bol)
=^ cards state
?+ mark (on-poke:def mark vase)
%json (poke-invite-action:ic (json-to-action !<(json vase)))
%invite-action (poke-invite-action:ic !<(invite-action vase))
==
[cards this]
::
++ on-watch
|= =path
^- (quip card _this)
=/ cards=(list card)
?+ path (on-watch:def path)
[%all ~] [%give %fact ~ %invite-initial !>(invites)]~
[%updates ~] ~
[%invitatory *]
=/ inv=invitatory (~(got by invites) t.path)
[%give %fact ~ %invite-update !>([%invitatory inv])]~
==
[cards this]
::
++ on-leave on-leave:def
++ on-peek
|= =path
^- (unit (unit cage))
?+ path (on-peek:def path)
[%x %all ~] (peek-x-all:ic t.t.path)
[%x %invitatory *] (peek-x-invitatory:ic t.t.path)
[%x %invite *] (peek-x-invite:ic t.t.path)
==
::
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
++ this .
::
++ prep
|= old=(unit state)
^- (quip move _this)
?~ old
[~ this]
[~ this(+<+ u.old)]
|_ bol=bowl:gall
::
++ peek-x-all
|= pax=path
^- (unit (unit [%noun (map path invitatory)]))
[~ ~ %noun invites]
^- (unit (unit cage))
[~ ~ %noun !>(invites)]
::
++ peek-x-invitatory
|= pax=path
^- (unit (unit [%noun (unit invitatory)]))
^- (unit (unit cage))
?~ pax
~
=/ invitatory=(unit invitatory) (~(get by invites) pax)
[~ ~ %noun invitatory]
[~ ~ %noun !>(invitatory)]
::
++ peek-x-invite
|= pax=path
^- (unit (unit [%noun (unit invite)]))
^- (unit (unit cage))
:: /:path/:uid
=/ pas (flop pax)
?~ pas
@ -53,41 +94,11 @@
?~ invitatory
~
=/ invite=(unit invite) (~(get by u.invitatory) uid)
[~ ~ %noun invite]
::
++ peer-all
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
:: send all updates from now on
:_ this
[ost.bol %diff %invite-initial invites]~
::
++ peer-updates
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
:: send all updates from now on
[~ this]
::
++ peer-invitatory
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
=/ inv=(unit invitatory) (~(get by invites) pax)
?~ inv !!
:_ this
[ost.bol %diff %invite-update [%invitatory u.inv]]~
::
++ poke-json
|= =json
^- (quip move _this)
?> (team:title our.bol src.bol)
(poke-invite-action (json-to-action json))
[~ ~ %noun !>(invite)]
::
++ poke-invite-action
|= action=invite-action
^- (quip move _this)
^- (quip card _state)
?> (team:title our.bol src.bol)
?- -.action
%create (handle-create action)
@ -99,73 +110,70 @@
::
++ handle-create
|= act=invite-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%create -.act)
?: (~(has by invites) path.act)
[~ this]
[~ state]
:- (send-diff path.act act)
this(invites (~(put by invites) path.act *invitatory))
state(invites (~(put by invites) path.act *invitatory))
::
++ handle-delete
|= act=invite-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%delete -.act)
?. (~(has by invites) path.act)
[~ this]
[~ state]
:- (send-diff path.act act)
this(invites (~(del by invites) path.act))
state(invites (~(del by invites) path.act))
::
++ handle-invite
|= act=invite-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%invite -.act)
?. (~(has by invites) path.act)
[~ this]
[~ state]
=/ container (~(got by invites) path.act)
=. uid.act (sham eny.bol)
=. container (~(put by container) uid.act invite.act)
:- (send-diff path.act act)
this(invites (~(put by invites) path.act container))
state(invites (~(put by invites) path.act container))
::
++ handle-accept
|= act=invite-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%accept -.act)
?. (~(has by invites) path.act)
[~ this]
[~ state]
=/ container (~(got by invites) path.act)
=/ invite (~(get by container) uid.act)
?~ invite
[~ this]
[~ state]
=. container (~(del by container) uid.act)
:- (send-diff path.act [%accepted path.act uid.act u.invite])
this(invites (~(put by invites) path.act container))
state(invites (~(put by invites) path.act container))
::
++ handle-decline
|= act=invite-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%decline -.act)
?. (~(has by invites) path.act)
[~ this]
[~ state]
=/ container (~(got by invites) path.act)
=/ invite (~(get by container) uid.act)
?~ invite
[~ this]
[~ state]
=. container (~(del by container) uid.act)
:- (send-diff path.act act)
this(invites (~(put by invites) path.act container))
state(invites (~(put by invites) path.act container))
::
++ update-subscribers
|= [pax=path upd=invite-update]
^- (list move)
%+ turn (prey:pubsub:userlib pax bol)
|= [=bone *]
[bone %diff %invite-update upd]
^- card
[%give %fact `pax %invite-update !>(upd)]
::
++ send-diff
|= [pax=path upd=invite-update]
^- (list move)
%- zing
^- (list card)
:~ (update-subscribers /all upd)
(update-subscribers /updates upd)
(update-subscribers [%invitatory pax] upd)

107
pkg/arvo/app/invite-view.hoon
View File

@ -1,49 +1,72 @@
:: invite-view: provide a json interface to invite-store
::
/+ *invite-json
:: accepts subscriptions at the /primary path.
:: passes through all invites and their updates.
:: only accepts subcriptions from the host's team.
::
::TODO could maybe use /lib/proxy-hook, be renamed invite-proxy-hook
::
/+ *invite-json, default-agent
::
|%
+$ move [bone card]
+$ card card:agent:gall
--
::
+$ card
$% [%peer wire dock path]
[%diff %json json]
=>
|%
++ watch-updates
|= our=ship
^- card
[%pass /store %agent [our %invite-store] %watch /updates]
--
^- agent:gall
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
::
++ on-init
^- (quip card _this)
[[(watch-updates our.bowl)]~ this]
::
++ on-save on-save:def
++ on-load
|= old=vase
^- (quip card _this)
[~ this]
::
++ on-watch
|= =path
^- (quip card _this)
?> (team:title our.bowl src.bowl)
?. =(/primary path)
(on-watch:def path)
:_ this
=/ =invites
.^(invites %gx /=invite-store/(scot %da now.bowl)/all/noun)
[%give %fact ~ %json !>((invites-to-json invites))]~
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
:_ this
?- -.sign
%poke-ack ~|([dap.bowl %unexpected-poke-ack] !!)
%watch-ack ~
%kick [(watch-updates our.bowl)]~
::
%fact
~| [dap.bowl %unexpected-fact-mark p.cage.sign]
?> ?=(%invite-update p.cage.sign)
:~ :*
%give %fact
`/primary %json
!>((update-to-json !<(invite-update q.cage.sign)))
== ==
==
--
::
|_ [bol=bowl:gall ~]
::
++ this .
::
++ prep
|= old=*
^- (quip move _this)
:_ this
[ost.bol %peer / [our.bol %invite-store] /updates]~
::
++ peer-primary
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
:_ this
[ost.bol %diff %json (invites-to-json invites-scry)]~
::
++ diff-invite-update
|= [wir=wire upd=invite-update]
^- (quip move _this)
=/ updates-json (update-to-json upd)
:_ this
%+ turn (prey:pubsub:userlib /primary bol)
|= [=bone *]
[bone %diff %json updates-json]
::
++ quit
|= wir=wire
^- (quip move _this)
:_ this
[ost.bol %peer / [our.bol %invite-store] /updates]~
::
++ invites-scry
^- invites
.^(invites %gx /=invite-store/(scot %da now.bol)/all/noun)
::
++ on-poke on-poke:def
++ on-peek on-peek:def
++ on-leave on-leave:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--

176
pkg/arvo/app/language-server.hoon
View File

@ -2,23 +2,11 @@
auto=language-server-complete,
lsp-parser=language-server-parser,
easy-print=language-server-easy-print,
rune-snippet=language-server-rune-snippet
rune-snippet=language-server-rune-snippet,
default-agent
|%
:: +move: output effect
::
+$ move [bone card]
:: +card: output effect payload
::
+$ card
$% [%connect wire binding:eyre term]
[%disconnect wire binding:eyre]
[%http-response =http-event:http]
[%poke wire dock out-pokes]
==
::
+$ out-pokes [%kiln-commit term _|]
::
+$ lsp-req
+$ card card:agent:gall
+$ lsp-req
$: uri=@t
$% [%sync changes=(list change)]
[%completion position]
@ -41,29 +29,69 @@
+$ position
[row=@ud col=@ud]
::
+$ state bufs=(map uri=@t buf=wall)
+$ all-state bufs=(map uri=@t buf=wall)
--
^- agent:gall
=| all-state
=* state -
=<
|_ =bowl:gall
+* this .
lsp-core +>
lsp ~(. lsp-core bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init
^+ on-init:*agent:gall
^- (quip card _this)
~& > %lsp-init
:_ this :_ ~
:* %pass /connect
%arvo %e
%connect [~ /'~language-server-protocol'] %language-server
==
::
++ on-save !>(state)
++ on-load
^+ on-load:*agent:gall
|= old-state=vase
^- (quip card _this)
~& > %lsp-upgrade
[~ this(state !<(all-state old-state))]
::
++ on-poke
^+ on-poke:*agent:gall
|= [=mark =vase]
^- (quip card _this)
=^ cards state
?+ mark (on-poke:def mark vase)
%handle-http-request
(handle-http-request:lsp !<([eyre-id=@ta inbound-request:eyre] vase))
==
[cards this]
::
++ on-watch
|= =path
?. ?=([%http-response @ ~] path)
(on-watch:def path)
`this
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-agent on-agent:def
++ on-arvo
^+ on-arvo:*agent:gall
|= [=wire =sign-arvo]
^- (quip card _this)
=^ cards state
?+ wire (on-arvo:def wire sign-arvo)
[%connect ~] ?>(?=(%bound +<.sign-arvo) `state)
==
[cards this]
::
++ on-fail on-fail:def
--
::
|_ [bow=bowl:gall state]
::
++ this .
++ prep
|= old=(unit state)
^- (quip move _this)
~& > %lsp-prep
?~ old
:_ this
[ost.bow %connect / [~ /'~language-server-protocol'] %language-server]~
[~ this(bufs u.old)]
::
:: alerts us that we were bound.
::
++ bound
|= [wir=wire success=? binding=binding:eyre]
^- (quip move _this)
[~ this]
::
:: +poke-handle-http-request: received on a new connection established
|_ bow=bowl:gall
::
++ parser
=, dejs:format
@ -105,40 +133,30 @@
--
::
++ json-response
|= jon=json
^- (list move)
:_ ~
:*
ost.bow
%http-response
(json-response:app (json-to-octs jon))
==
|= [eyre-id=@ta jon=json]
^- (list card)
(give-simple-payload:app eyre-id (json-response:gen (json-to-octs jon)))
::
++ coup
|= [=wire saw=(unit tang)]
^- (quip move _this)
:_ this
~
:: +handle-http-request: received on a new connection established
::
++ poke-handle-http-request
%- (require-authorization:app ost.bow move this)
|= =inbound-request:eyre
^- (quip move _this)
++ handle-http-request
|= [eyre-id=@ta =inbound-request:eyre]
^- (quip card _state)
?> ?=(^ body.request.inbound-request)
=/ =lsp-req
%- parser
(need (de-json:html q.u.body.request.inbound-request))
=/ buf (~(gut by bufs) uri.lsp-req *wall)
=^ moves buf
=^ cards buf
?- +<.lsp-req
%sync (handle-sync buf +>.lsp-req)
%completion (handle-completion buf +>.lsp-req)
%commit (handle-commit buf uri.lsp-req)
%hover (handle-hover buf +>.lsp-req)
%sync (handle-sync buf eyre-id +>.lsp-req)
%completion (handle-completion buf eyre-id +>.lsp-req)
%commit (handle-commit buf eyre-id uri.lsp-req)
%hover (handle-hover buf eyre-id +>.lsp-req)
==
=. bufs
(~(put by bufs) uri.lsp-req buf)
[moves this]
[cards state]
::
++ regen-diagnostics
|= buf=wall
@ -170,34 +188,34 @@
==
::
++ handle-commit
|= [buf=wall uri=@t]
^- [(list move) wall]
|= [buf=wall eyre-id=@ta uri=@t]
^- [(list card) wall]
:_ buf
=/ jon
(regen-diagnostics buf)
:_ (json-response jon)
:_ (json-response eyre-id jon)
:*
ost.bow
%poke
%pass
/commit
%agent
[our.bow %hood]
%poke
%kiln-commit
q.byk.bow
|
!>([q.byk.bow |])
==
::
++ handle-hover
|= [buf=wall row=@ud col=@ud]
^- [(list move) wall]
|= [buf=wall eyre-id=@ta row=@ud col=@ud]
^- [(list card) wall]
=/ txt
(zing (join "\0a" buf))
=+ (get-id:auto (get-pos buf row col) txt)
?~ id
[(json-response *json) buf]
[(json-response eyre-id *json) buf]
=/ match=(unit [=term =type])
(search-exact:auto u.id (get-identifiers:auto -:!>(..zuse)))
?~ match
[(json-response *json) buf]
[(json-response eyre-id *json) buf]
=/ contents
%- crip
;: weld
@ -206,13 +224,13 @@
"`"
==
:_ buf
%- json-response
%+ json-response eyre-id
%- pairs:enjs:format
[contents+s+contents ~]
::
++ handle-sync
|= [buf=wall changes=(list change)]
:- (json-response *json)
|= [buf=wall eyre-id=@ta changes=(list change)]
:- (json-response eyre-id *json)
|- ^- wall
?~ changes
buf
@ -260,8 +278,8 @@
(sub a b)
::
++ handle-completion
|= [buf=wall row=@ud col=@ud]
^- [(list move) wall]
|= [buf=wall eyre-id=@ta row=@ud col=@ud]
^- [(list card) wall]
=/ =tape (zing (join "\0a" buf))
=/ pos (get-pos buf row col)
:_ buf
@ -269,17 +287,17 @@
::
=/ rune (swag [(safe-sub pos 2) 2] tape)
?: (~(has by runes:rune-snippet) rune)
(json-response (rune-snippet rune))
(json-response eyre-id (rune-snippet rune))
:: Don't run on large files because it's slow
::
?: (gth (lent buf) 1.000)
=, enjs:format
(json-response (pairs good+b+& result+~ ~))
(json-response eyre-id (pairs good+b+& result+~ ~))
::
=/ tl
(tab-list-tape:auto -:!>(..zuse) pos tape)
=, enjs:format
%- json-response
%+ json-response eyre-id
?: ?=(%| -.tl)
(format-diagnostic p.tl)
?~ p.tl

230
pkg/arvo/app/launch.hoon
View File

@ -1,5 +1,5 @@
/- launch
/+ *server
/+ *server, default-agent
::
/= index
/^ $-(marl manx)
@ -22,129 +22,143 @@
/^ (map knot @)
/: /===/app/launch/img /_ /png/
::
=, launch
::
|%
+$ state
$% [%0 tiles=(set tile) data=tile-data path-to-tile=(map path @tas)]
+$ versioned-state
$% state-zero
==
+$ state-zero
$: %0
tiles=(set tile:launch)
data=tile-data:launch
path-to-tile=(map path @tas)
==
::
+$ move [bone card]
::
+$ card
$% [%http-response =http-event:http]
[%connect wire binding:eyre term]
[%peer wire dock path]
[%diff %json json]
==
+$ card card:agent:gall
--
::
|_ [bol=bowl:gall sta=state]
=| state-zero
=* state -
^- agent:gall
|_ bol=bowl:gall
+* this .
def ~(. (default-agent this %|) bol)
++ on-init
^- (quip card _this)
:_ this
[%pass / %arvo %e %connect [~ /] %launch]~
::
++ this .
++ on-save !>(state)
::
++ prep
|= old=(unit state)
^- (quip move _this)
?~ old
++ on-load
|= old=vase
`this(state !<(state-zero old))
::
++ on-poke
|= [mar=mark vas=vase]
^- (quip card _this)
?+ mar (on-poke:def mar vas)
::
%launch-action
=/ act !<(action:launch vas)
=/ beforedata (~(get by data) name.act)
=/ newdata
?~ beforedata
(~(put by data) name.act [*json url.act])
(~(put by data) name.act [jon.u.beforedata url.act])
=/ new-tile `tile:launch`[`@tas`name.act `path`subscribe.act]
:- [%pass subscribe.act %agent [our.bol name.act] %watch subscribe.act]~
%= this
tiles (~(put in tiles) new-tile)
data newdata
path-to-tile (~(put by path-to-tile) subscribe.act name.act)
==
::
%handle-http-request
=+ !<([eyre-id=@ta =inbound-request:eyre] vas)
:_ this
[ost.bol %connect / [~ /] %launch]~
[~ this(sta u.old)]
::
++ poke-launch-action
|= act=action
^- (quip move _this)
=/ beforedata (~(get by data.sta) name.act)
=/ newdata
?~ beforedata
(~(put by data.sta) name.act [*json url.act])
(~(put by data.sta) name.act [jon.u.beforedata url.act])
:- [ost.bol %peer subscribe.act [our.bol name.act] subscribe.act]~
%= this
tiles.sta (~(put in tiles.sta) [name.act subscribe.act])
data.sta newdata
path-to-tile.sta (~(put by path-to-tile.sta) subscribe.act name.act)
%+ give-simple-payload:app eyre-id
%+ require-authorization:app inbound-request
|= =inbound-request:eyre
^- simple-payload:http
=/ request-line (parse-request-line url.request.inbound-request)
=/ name=@t
=/ back-path (flop site.request-line)
?~ back-path
''
i.back-path
?+ site.request-line
not-found:gen
::
~
=/ hym=manx
%- index
^- marl
%+ turn ~(tap by data)
|= [key=@tas [jon=json url=@t]]
^- manx
;script@"{(trip url)}";
(manx-response:gen hym)
::
[%'~launch' %css %index ~] :: styling
(css-response:gen style)
::
[%'~launch' %js %index ~] :: javascript
(js-response:gen script)
::
[%'~launch' %img *] :: images
=/ img=(unit @) (~(get by launch-png) `@ta`name)
?~ img
not-found:gen
(png-response:gen (as-octs:mimes:html u.img))
::
[%'~modulo' %session ~]
=/ session-js
%- as-octt:mimes:html
;: weld
"window.ship = '{+:(scow %p our.bol)}';"
"window.urb = new Channel();"
==
(js-response:gen session-js)
==
==
::
++ peer-main
|= [pax=path]
^- (quip move _this)
=/ data/json
++ on-watch
|= pax=path
^- (quip card _this)
?: ?=([%http-response *] pax)
[~ this]
?. ?=([%main *] pax)
(on-watch:def pax)
=/ data=json
%- pairs:enjs:format
%+ turn ~(tap by data.sta)
%+ turn ~(tap by data)
|= [key=@tas [jon=json url=@t]]
[key jon]
:_ this
[ost.bol %diff %json data]~
[%give %fact ~ %json !>(data)]~
::
++ diff-json
|= [pax=path jon=json]
^- (quip move _this)
=/ name/@tas (~(got by path-to-tile.sta) pax)
=/ data/(unit [json url=@t]) (~(get by data.sta) name)
?~ data
[~ this]
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-fail on-fail:def
++ on-agent
|= [wir=wire sin=sign:agent:gall]
^- (quip card _this)
?. ?=(%fact -.sin)
(on-agent:def wir sin)
?. ?=(%json p.cage.sin)
(on-agent:def wir sin)
::
:-
%+ turn (prey:pubsub:userlib /main bol)
|= [=bone *]
[bone %diff %json (frond:enjs:format name jon)]
::
%= this
data.sta (~(put by data.sta) name [jon url.u.data])
==
=/ jon=json !<(json q.cage.sin)
=/ name=@tas (~(got by path-to-tile) wir)
=/ dat=(unit [json url=@t]) (~(get by data) name)
?~ dat [~ this]
:_ this(data (~(put by data) name [jon url.u.dat]))
[%give %fact `/main %json !>((frond:enjs:format name jon))]~
::
++ generate-script-marl
|= data=tile-data
^- marl
%+ turn ~(tap by data)
|= [key=@tas [jon=json url=@t]]
^- manx
;script@"{(trip url)}";
::
++ poke-handle-http-request
%- (require-authorization:app ost.bol move this)
|= =inbound-request:eyre
^- (quip move _this)
::
=/ request-line (parse-request-line url.request.inbound-request)
=/ name=@t
=/ back-path (flop site.request-line)
?~ back-path
''
i.back-path
=/ site (flop site.request-line)
?~ site
=/ hym=manx (index (generate-script-marl data.sta))
:_ this
[ost.bol %http-response (manx-response:app hym)]~
?+ site.request-line
:_ this
[ost.bol %http-response not-found:app]~
::
:: styling
::
[%'~launch' %css %index ~]
:_ this
[ost.bol %http-response (css-response:app style)]~
::
:: javascript
::
[%'~launch' %js %index ~]
:_ this
[ost.bol %http-response (js-response:app script)]~
::
:: images
::
[%'~launch' %img *]
=/ img (as-octs:mimes:html (~(got by launch-png) `@ta`name))
:_ this
[ost.bol %http-response (png-response:app img)]~
==
::
++ bound
|= [wir=wire success=? binding=binding:eyre]
^- (quip move _this)
++ on-arvo
|= [wir=wire sin=sign-arvo]
^- (quip card:agent:gall _this)
?. ?=(%bound +<.sin)
(on-arvo:def wir sin)
[~ this]
::
--

345
pkg/arvo/app/lens.hoon
View File

@ -1,5 +1,5 @@
/- lens, *sole
/+ base64, *server
/- lens, *sole
/+ base64, *server, default-agent
/= lens-mark /: /===/mar/lens/command
/!noun/
=, format
@ -10,57 +10,32 @@
$% [%json =json]
[%mime =mime]
==
:: +move: output effect
::
+$ move [bone card]
:: +card: output effect payload
::
+$ card
$% [%connect wire binding:eyre term]
[%http-response =http-event:http]
[%peer wire dock path]
[%peer wire dock path]
[%poke wire dock poke]
[%pull wire dock ~]
==
::
+$ poke
$% [%lens-command command:lens]
[%import *]
==
::
+$ state
$% $: %0
job=(unit [=bone com=command:lens])
job=(unit [eyre-id=@ta com=command:lens])
==
==
::
--
::
|_ [bow=bowl:gall state=state]
=| =state
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
::
++ this .
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(^state old))
::
++ prep
|= old=(unit *)
^- (quip move _this)
[~ this]
::
:: alerts us that we were bound. we need this because the vane calls back.
::
++ bound
|= [wir=wire success=? binding=binding:eyre]
^- (quip move _this)
[~ this]
::
++ poke-handle-http-request
%- (require-authorization:app ost.bow move this)
|= =inbound-request:eyre
^- (quip move _this)
::
?^ job.state
:_ this
[ost.bow %http-response %start [%500 ~] ~ %.y]~
++ on-poke
|= [=mark =vase]
^- (quip card:agent:gall _this)
?. ?=(%handle-http-request mark)
(on-poke:def mark vase)
=+ !<([eyre-id=@ta =inbound-request:eyre] vase)
?> ?=(~ job.state)
::
=/ request-line (parse-request-line url.request.inbound-request)
=/ site (flop site.request-line)
@ -72,77 +47,151 @@
::
?: ?=(%export -.source.com)
~& [%export app.source.com]
:_ this(job.state (some [ost.bow com]))
[ost.bow %peer /export [our.bow app.source.com] /export]~
:_ this(job.state (some [eyre-id com]))
[%pass /export %agent [our.bowl app.source.com] %watch /export]~
::
?: ?=(%import -.source.com)
?~ enc=(de:base64 base64-jam.source.com)
:_ this
[ost.bow %http-response %start [%500 ~] ~ %.y]~
!!
::
=/ c=* (cue q.u.enc)
::
:_ this(job.state (some [ost.bow com]))
[ost.bow %poke /import [our.bow app.source.com] %import c]~
:_ this(job.state (some [eyre-id com]))
[%pass /import %agent [our.bowl app.source.com] %poke %import !>(c)]~
::
:_ this(job.state (some [ost.bow com]))
[ost.bow %peer /sole [our.bow %dojo] /sole]~
:_ this(job.state (some [eyre-id com]))
[%pass /sole %agent [our.bowl %dojo] %watch /sole/[eyre-id]]~
::
++ diff-sole-effect
|= [=wire fec=sole-effect]
^- (quip move _this)
=/ out
|- ^- (unit lens-out)
=* loop $
?+ -.fec
~
++ on-watch
|= =path
^- (quip card:agent:gall _this)
?: ?=([%http-response *] path)
`this
(on-watch:def path)
::
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card:agent:gall _this)
|^
?+ wire (on-agent:def wire sign)
[%import ~]
?> ?=(%poke-ack -.sign)
?> ?=(^ job.state)
:_ this(job.state ~)
%+ give-simple-payload:app eyre-id.u.job.state
[[200 ~] `(as-octt:mimes:html "\"Imported data\"")]
::
[%export ~]
?+ -.sign (on-agent:def wire sign)
%watch-ack
?~ p.sign
`this
?> ?=(^ job.state)
:_ this(job.state ~)
(give-simple-payload:app eyre-id.u.job.state not-found:gen)
::
%tan
%- some
:- %json
%- wall:enjs:format
(turn (flop p.fec) |=(=tank ~(ram re tank)))
::
%txt
(some %json s+(crip p.fec))
::
%sag
%- some
[%mime p.fec (as-octs:mimes:html (jam q.fec))]
::
%sav
:: XX use +en:base64 or produce %mime a la %sag
::
%- some
:- %json
%- pairs:enjs:format
:~ file+s+(crip <`path`p.fec>)
data+s+(crip (en-base64:mimes:html q.fec))
==
::
%mor
=/ all `(list lens-out)`(murn p.fec |=(a=sole-effect loop(fec a)))
?~ all ~
~| [%multiple-effects all]
?> ?=(~ t.all)
(some i.all)
%fact
=^ cards this (take-export !<(* q.cage.sign))
:_ this :_ cards
?> ?=(^ job.state)
?> ?=(%export -.source.com.u.job.state)
[%pass /export %agent [our.bowl app.source.com.u.job.state] %leave ~]
==
::
?~ out
[~ this]
?> ?=(^ job.state)
:_ this(job.state ~)
:_ ~
:+ bone.u.job.state
%http-response
?- -.u.out
%json
(json-response:app (json-to-octs json.u.out))
[%sole ~]
?+ -.sign (on-agent:def wire sign)
%watch-ack
?> ?=(^ job.state)
?^ p.sign
:_ this(job.state ~)
(give-simple-payload:app eyre-id.u.job.state not-found:gen)
:_ this :_ ~
:* %pass /sole
%agent [our.bowl %dojo]
%poke %lens-command !>
[eyre-id.u.job.state com.u.job.state]
==
::
%fact
?> ?=(%sole-effect p.cage.sign)
=^ cards this (take-sole-effect !<(sole-effect q.cage.sign))
[[[%pass /sole %agent [our.bowl %dojo] %leave ~] cards] this]
==
==
::
%mime
:* %start
:~ 200
['content-type' 'application/octet-stream']
++ take-export
|= data=*
^- (quip card:agent:gall _this)
?> ?=(^ job.state)
?> ?=(%export -.source.com.u.job.state)
=/ app-name=tape (trip app.source.com.u.job.state)
=/ output=@t (crip "/{app-name}/jam")
::
=/ jon=json
=/ =atom (jam data)
=/ =octs [(met 3 atom) atom]
=/ enc (en:base64 octs)
(pairs:enjs:format file+s+output data+s+enc ~)
::
:_ this(job.state ~)
%+ give-simple-payload:app eyre-id.u.job.state
(json-response:gen (json-to-octs jon))
::
++ take-sole-effect
|= fec=sole-effect
^- (quip card:agent:gall _this)
=/ out
|- ^- (unit lens-out)
=* loop $
?+ -.fec
~
::
%tan
%- some
:- %json
%- wall:enjs:format
(turn (flop p.fec) |=(=tank ~(ram re tank)))
::
%txt
(some %json s+(crip p.fec))
::
%sag
%- some
[%mime p.fec (as-octs:mimes:html (jam q.fec))]
::
%sav
:: XX use +en:base64 or produce %mime a la %sag
::
%- some
:- %json
%- pairs:enjs:format
:~ file+s+(crip <`path`p.fec>)
data+s+(crip (en-base64:mimes:html q.fec))
==
::
%mor
=/ all `(list lens-out)`(murn p.fec |=(a=sole-effect loop(fec a)))
?~ all ~
~| [%multiple-effects all]
?> ?=(~ t.all)
(some i.all)
==
::
?~ out
[~ this]
::
?> ?=(^ job.state)
:_ this(job.state ~)
%+ give-simple-payload:app eyre-id.u.job.state
?- -.u.out
%json
(json-response:gen (json-to-octs json.u.out))
::
%mime
=/ headers
:~ ['content-type' 'application/octet-stream']
?> ?=([@ @ ~] p.mime.u.out)
:- 'content-disposition'
^- @t
@ -150,90 +199,16 @@
'attachment; filename='
(rap 3 '"' i.p.mime.u.out '.' i.t.p.mime.u.out '"' ~)
==
(some q.mime.u.out)
%.y
[[200 headers] (some q.mime.u.out)]
==
==
--
::
++ diff-export
|= [=wire data=*]
^- (quip move _this)
::
?> ?=(^ job.state)
:: herb will do whatever we tell it to, so by convention have it write to an
:: app name based on the file name.
::
?> ?=(%export -.source.com.u.job.state)
=/ app-name=tape (trip app.source.com.u.job.state)
=/ output=@t (crip "/{app-name}/jam")
::
=/ jon=json
=/ =atom (jam data)
=/ =octs [(met 3 atom) atom]
=/ enc (en:base64 octs)
(pairs:enjs:format file+s+output data+s+enc ~)
::
:_ this(job.state ~)
:~ [bone.u.job.state %http-response (json-response:app (json-to-octs jon))]
[ost.bow %pull /export [our.bow app.source.com.u.job.state] ~]
==
::
++ quit
|= =wire
^- (quip move _this)
~& [%quit wire]
[~ this]
::
++ reap
|= [=wire saw=(unit tang)]
^- (quip move _this)
::
?: =([%export ~] wire)
[~ this]
::
?^ saw
[((slog u.saw) ~) this]
?> ?=(^ job.state)
:_ this
:~ [ost.bow %poke /sole [our.bow %dojo] %lens-command com.u.job.state]
:: XX move to +diff-sole-effect?
::
[ost.bow %pull /sole [our.bow %dojo] ~]
==
::
++ coup
|= [=wire saw=(unit tang)]
^- (quip move _this)
::
?: =([%import ~] wire)
?> ?=(^ job.state)
:_ this(job.state ~)
:_ ~
:* bone.u.job.state
%http-response
%start
[%200 ~]
[~ (as-octt:mimes:html "\"Imported data\"")]
%.y
==
::
?^ saw
[((slog u.saw) ~) this]
[~ this]
::
:: +poke-handle-http-cancel: received when a connection was killed
::
++ poke-handle-http-cancel
|= =inbound-request:eyre
^- (quip move _this)
:: the only long lived connections we keep state about are the stream ones.
::
[~ this]
::
++ poke-noun
|= a=*
^- (quip move _this)
~& poke+a
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card:agent:gall _this)
?. ?=(%bound +<.sign-arvo)
(on-arvo:def wire sign-arvo)
[~ this]
::
++ on-fail on-fail:def
--

51
pkg/arvo/app/modulo.hoon
View File

@ -1,51 +0,0 @@
/+ *server
|%
:: +move: output effect
::
+$ move [bone card]
:: +card: output effect payload
::
+$ card
$% [%connect wire binding:eyre term]
[%disconnect wire binding:eyre]
[%http-response =http-event:http]
==
::
--
::
|_ [bow=bowl:gall ~]
::
++ this .
::
++ prep
|= old=(unit *)
^- (quip move _this)
?~ old
:_ this
[ost.bow %connect / [~ /'~modulo'] %modulo]~
[~ this]
::
:: alerts us that we were bound. we need this because the vane calls back.
::
++ bound
|= [wir=wire success=? binding=binding:eyre]
^- (quip move _this)
[~ this]
::
++ session-js
^- octs
%- as-octt:mimes:html
;: weld
"window.ship = '{+:(scow %p our.bow)}';"
"window.urb = new Channel();"
==
::
:: +poke-handle-http-request: received on a new connection established
::
++ poke-handle-http-request
%- (require-authorization:app ost.bow move this)
|= =inbound-request:eyre
^- (quip move _this)
[[ost.bow %http-response (js-response:app session-js)]~ this]
::
--

240
pkg/arvo/app/permission-group-hook.hoon
View File

@ -1,111 +1,161 @@
:: permission-group-hook:
:: mirror the ships in some group to some set of permission paths
:: permission-group-hook: groups into permissions
::
:: mirror the ships in specified groups to specified permission paths
::
/- *group-store, *permission-group-hook
/+ *permission-json
/+ *permission-json, default-agent, verb
::
|%
+$ move [bone card]
::
+$ card
$% [%diff [%group-update group-update]]
[%poke wire dock poke]
[%pull wire dock ~]
[%peer wire dock path]
==
::
+$ state
$% [%0 state-zero]
$% [%0 state-0]
==
::
+$ group-path path
::
+$ permission-path path
::
+$ state-zero
+$ state-0
$: relation=(map group-path (set permission-path))
==
::
+$ poke
$% [%permission-action permission-action]
==
::
+$ card card:agent:gall
--
::
|_ [bol=bowl:gall state]
=| state-0
=* state -
::
++ this .
%+ verb |
^- agent:gall
=<
|_ =bowl:gall
+* this .
do ~(. +> bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
^- (quip card _this)
[~ this(state !<(state-0 old))]
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?+ mark (on-poke:def mark vase)
%json
:: only accept json from the host team
::
?> (team:title our.bowl src.bowl)
=^ cards state
%- handle-action:do
%- json-to-perm-group-hook-action
!<(json vase)
[cards this]
::
%permission-group-hook-action
=^ cards state
%- handle-action:do
!<(permission-group-hook-action vase)
[cards this]
==
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
?. ?=([%group *] wire)
(on-agent:def wire sign)
?- -.sign
%poke-ack ~|([dap.bowl %unexpected-poke-ack wire] !!)
::
%kick
:_ this
[(watch-group:do t.wire)]~
::
%watch-ack
?~ p.sign [~ this]
=/ =tank leaf+"{(trip dap.bowl)} failed subscribe at {(spud wire)}"
%- (slog tank u.p.sign)
[~ this(relation (~(del by relation) t.wire))]
::
%fact
?. ?=(%group-update p.cage.sign)
(on-agent:def wire sign)
=^ cards state
%- handle-group-update:do
!<(group-update q.cage.sign)
[cards this]
==
::
++ on-peek on-peek:def
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
++ prep
|= old=(unit state)
^- (quip move _this)
[~ ?~(old this this(+<+ u.old))]
::
++ poke-json
|= =json
^- (quip move _this)
?> (team:title our.bol src.bol)
(poke-permission-group-hook-action (json-to-perm-group-hook-action json))
::
++ poke-permission-group-hook-action
|_ =bowl:gall
++ handle-action
|= act=permission-group-hook-action
^- (quip move _this)
?> (team:title our.bol src.bol)
^- (quip card _state)
?> (team:title our.bowl src.bowl)
?- -.act
%associate (handle-associate group.act permissions.act)
%dissociate (handle-dissociate group.act permissions.act)
==
::
++ handle-associate
|= [group=path permission-paths=(set [path kind])]
^- (quip move _this)
|= [group=group-path associate=(set [permission-path kind])]
^- (quip card _state)
=/ perms (~(get by relation) group)
:: if relation does not exist, create it and subscribe.
=/ permissions=(set path)
%- ~(run in permission-paths)
|=([=path =kind] path)
=/ perm-paths=(set path)
(~(run in associate) head)
?~ perms
=/ group-path [%group group]
:_ this(relation (~(put by relation) group permissions))
[ost.bol %peer group-path [our.bol %group-store] group-path]~
:- [(watch-group group)]~
state(relation (~(put by relation) group perm-paths))
::
=. u.perms (~(uni in u.perms) permissions)
:_ this(relation (~(put by relation) group u.perms))
=. u.perms (~(uni in u.perms) perm-paths)
:_ state(relation (~(put by relation) group u.perms))
%+ weld
%+ turn ~(tap in permissions)
|=(=path (permission-poke path [%delete path]))
%+ turn ~(tap in permission-paths)
%+ turn ~(tap in perm-paths)
|= =path
(permission-poke path [%delete path])
%+ turn ~(tap in associate)
|= [=path =kind]
=/ pem *permission
=| pem=permission
=. kind.pem kind
(permission-poke path [%create path pem])
::
++ handle-dissociate
|= [group=path permissions=(set path)]
^- (quip move _this)
=/ perms (~(get by relation) group)
?~ perms
[~ this]
|= [group=path remove=(set permission-path)]
^- (quip card _state)
=/ perms=(set permission-path)
(fall (~(get by relation) group) *(set permission-path))
?: =(~ perms)
[~ state]
:: remove what we must. if that means we are no longer mirroring this group
:: into any permissions, remove it from state entirely.
::
=. permissions (~(del in u.perms) permissions)
?~ permissions
:_ this(relation (~(del by relation) group))
[(group-pull [%group group])]~
[~ this(relation (~(put by relation) group permissions))]
=. perms (~(del in perms) remove)
?~ perms
:_ state(relation (~(del by relation) group))
[(group-pull group)]~
[~ state(relation (~(put by relation) group perms))]
::
++ diff-group-update
|= [wir=wire diff=group-update]
^- (quip move _this)
++ handle-group-update
|= diff=group-update
^- (quip card _state)
?- -.diff
%keys
[~ this]
%bundle
[~ this]
%keys [~ state]
%bundle [~ state]
::
%path
:: set all permissions paths
=/ perms (~(get by relation) pax.diff)
?~ perms
[~ this]
:_ this
[~ state]
:_ state
%+ turn ~(tap in u.perms)
|= =path
(permission-poke path [%add path members.diff])
@ -114,8 +164,8 @@
:: set all permissions paths
=/ perms (~(get by relation) pax.diff)
?~ perms
[~ this]
:_ this
[~ state]
:_ state
%+ turn ~(tap in u.perms)
|= =path
(permission-poke path [%add path members.diff])
@ -124,8 +174,8 @@
:: set all permissions paths
=/ perms (~(get by relation) pax.diff)
?~ perms
[~ this]
:_ this
[~ state]
:_ state
%+ turn ~(tap in u.perms)
|= =path
(permission-poke path [%remove path members.diff])
@ -134,38 +184,34 @@
:: pull subscriptions
=/ perms (~(get by relation) pax.diff)
?~ perms
:_ this(relation (~(del by relation) pax.diff))
[(group-pull [%group pax.diff])]~
:_ this(relation (~(del by relation) pax.diff))
:- (group-pull [%group pax.diff])
:_ state(relation (~(del by relation) pax.diff))
[(group-pull pax.diff)]~
:_ state(relation (~(del by relation) pax.diff))
:- (group-pull pax.diff)
%+ turn ~(tap in u.perms)
|= =path
(permission-poke path [%delete path])
==
::
++ quit
|= wir=wire
^- (quip move _this)
:: no-op
[~ this]
::
++ reap
|= [wir=wire saw=(unit tang)]
^- (quip move _this)
?~ saw
[~ this]
=. wir ?^(wir t.wir ~)
~& %reap-permission-group-hook
[((slog u.saw) ~) this(relation (~(del by relation) wir))]
::
++ permission-poke
|= [pax=path action=permission-action]
^- move
[ost.bol %poke pax [our.bol %permission-store] [%permission-action action]]
|= [=wire action=permission-action]
^- card
:* %pass
[%write wire]
%agent
[our.bowl %permission-store]
%poke
[%permission-action !>(action)]
==
::
++ watch-group
|= =group-path
^- card
=. group-path [%group group-path]
[%pass group-path %agent [our.bowl %group-store] %watch group-path]
::
++ group-pull
|= =path
^- move
[ost.bol %pull [%group path] [our.bol %group-store] ~]
::
|= =group-path
^- card
[%pass [%group group-path] %agent [our.bowl %group-store] %leave ~]
--

432
pkg/arvo/app/permission-hook.hoon
View File

@ -1,281 +1,329 @@
:: permission-hook: allows mirroring permissions between local and foreign
:: ships. access control to an owned permission path is specified by the
:: access-control path.
:: permission-hook: mirror remote permissions
::
:: allows mirroring permissions between local and foreign ships.
:: local permission path are exposed according to the permssion paths
:: configured for them as `access-control`.
::
/- *permission-hook
/+ *permission-json
/+ *permission-json, default-agent
::
|%
+$ move [bone card]
::
+$ card
$% [%diff [%permission-update permission-update]]
[%quit ~]
[%poke wire dock [%permission-action permission-action]]
[%pull wire dock ~]
[%peer wire dock path]
==
::
+$ state
$% [%0 state-zero]
$% [%0 state-0]
==
::
+$ owner-access [ship=ship access-control=path]
::
+$ state-zero
+$ state-0
$: synced=(map path owner-access)
access-control=(map path (set path))
boned=(map wire (list bone))
==
::
+$ card card:agent:gall
--
::
|_ [bol=bowl:gall state]
=| state-0
=* state -
::
++ this .
^- agent:gall
=<
|_ =bowl:gall
+* this .
do ~(. +> bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
^- (quip card _this)
[~ this(state !<(state-0 old))]
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?+ mark (on-poke:def mark vase)
%permission-hook-action
=^ cards state
(handle-permission-hook-action:do !<(permission-hook-action vase))
[cards this]
==
::
++ on-watch
|= =path
^- (quip card _this)
?. ?=([%permission ^] path) (on-watch:def path)
=^ cards state
(handle-watch-permission:do t.path)
[cards this]
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
?- -.sign
%poke-ack (on-agent:def wire sign)
::
%fact
?. ?=(%permission-update p.cage.sign)
(on-agent:def wire sign)
=^ cards state
(handle-permission-update:do wire !<(permission-update q.cage.sign))
[cards this]
::
%watch-ack
?~ p.sign [~ this]
?> ?=(^ wire)
:_ this(synced (~(del by synced) t.wire))
::NOTE we could've gotten rejected for permission reasons, so we don't
:: try to resubscribe automatically.
%. ~
%- slog
:* leaf+"permission-hook failed subscribe on {(spud t.wire)}"
leaf+"stack trace:"
u.p.sign
==
::
%kick
?> ?=([* ^] wire)
:: if we're not actively using it, we can safely ignore the %kick.
::
?. (~(has by synced) t.wire)
[~ this]
:: otherwise, resubscribe.
::
=/ =owner-access (~(got by synced) t.wire)
:_ this
[%pass wire %agent [ship.owner-access %permission-hook] %watch wire]~
==
::
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
++ prep
|= old=(unit state)
^- (quip move _this)
[~ ?~(old this this(+<+ u.old))]
::
++ poke-permission-hook-action
|_ =bowl:gall
++ handle-permission-hook-action
|= act=permission-hook-action
^- (quip move _this)
^- (quip card _state)
?- -.act
%add-owned
?> (team:title our.bol src.bol)
?> (team:title our.bowl src.bowl)
?: (~(has by synced) owned.act)
[~ this]
=. synced (~(put by synced) owned.act [our.bol access.act])
=/ access-paths
?. (~(has by access-control) access.act)
[owned.act ~ ~]
(~(put in (~(got by access-control) access.act)) owned.act)
[~ state]
=. synced (~(put by synced) owned.act [our.bowl access.act])
=. access-control
(~(put by access-control) access.act access-paths)
(~(put ju access-control) access.act owned.act)
=/ perm-path [%permission owned.act]
:_ (track-bone perm-path)
[ost.bol %peer perm-path [our.bol %permission-store] perm-path]~
:_ state
[%pass perm-path %agent [our.bowl %permission-store] %watch perm-path]~
::
%add-synced
?> (team:title our.bol src.bol)
?> (team:title our.bowl src.bowl)
?: (~(has by synced) path.act)
[~ this]
[~ state]
=. synced (~(put by synced) path.act [ship.act ~])
=/ perm-path [%permission path.act]
:_ (track-bone perm-path)
[ost.bol %peer perm-path [ship.act %permission-hook] perm-path]~
:_ state
[%pass perm-path %agent [ship.act %permission-hook] %watch perm-path]~
::
%remove
=/ owner-access=(unit owner-access) (~(get by synced) path.act)
=/ owner-access=(unit owner-access)
(~(get by synced) path.act)
?~ owner-access
[~ this]
?: &(=(ship.u.owner-access our.bol) (team:title our.bol src.bol))
:: delete one of our.bol own paths
:_ %_ this
synced (~(del by synced) path.act)
boned (~(del by boned) [%permission path.act])
::
access-control
(~(del by access-control) access-control.u.owner-access)
==
%- zing
:~ (pull-wire [%permission path.act])
^- (list move)
%+ turn (prey:pubsub:userlib [%permission path.act] bol)
|= [=bone *]
[bone %quit ~]
==
?. |(=(ship.u.owner-access src.bol) (team:title our.bol src.bol))
:: if neither ship = source or source = us, do nothing
[~ this]
:: delete a foreign ship's path
:_ %_ this
synced (~(del by synced) path.act)
boned (~(del by boned) [%permission path.act])
[~ state]
:: if we own it, and it's us asking,
::
?: ?& =(ship.u.owner-access our.bowl)
(team:title our.bowl src.bowl)
==
(pull-wire [%permission path.act])
:: delete the permission path and its subscriptions from this hook.
::
:- :- [%give %kick `[%permission path.act] ~]
(leave-permission path.act)
%_ state
synced (~(del by synced) path.act)
::
access-control
(~(del by access-control) access-control.u.owner-access)
==
:: else, if either source = ship or source = us,
::
?: |(=(ship.u.owner-access src.bowl) (team:title our.bowl src.bowl))
:: delete a foreign ship's path.
::
:- (leave-permission path.act)
%_ state
synced (~(del by synced) path.act)
boned (~(del by boned) [%permission path.act])
==
:: else, ignore action entirely.
::
[~ state]
==
::
++ peer-permission
|= pax=path
^- (quip move _this)
?> ?=([* ^] pax)
=/ =owner-access (~(got by synced) pax)
?> =(our.bol ship.owner-access)
++ handle-watch-permission
|= =path
^- (quip card _state)
=/ =owner-access (~(got by synced) path)
?> =(our.bowl ship.owner-access)
:: scry permissions to check if subscriber is allowed
?> (permitted-scry (scot %p src.bol) access-control.owner-access)
=/ pem (permission-scry pax)
:_ this
[ost.bol %diff %permission-update [%create pax pem]]~
::
?> (permitted src.bowl access-control.owner-access)
=/ pem (permission-scry path)
:_ state
[%give %fact ~ %permission-update !>([%create path pem])]~
::
++ diff-permission-update
|= [wir=wire diff=permission-update]
^- (quip move _this)
?: (team:title our.bol src.bol)
++ handle-permission-update
|= [=wire diff=permission-update]
^- (quip card _state)
?: (team:title our.bowl src.bowl)
(handle-local diff)
(handle-foreign diff)
::
++ handle-local
|= diff=permission-update
^- (quip move _this)
^- (quip card _state)
?- -.diff
%create [~ this]
%add (change-local-permission [%add path.diff who.diff])
%remove (change-local-permission [%remove path.diff who.diff])
%create [~ state]
%add (change-local-permission %add [path who]:diff)
%remove (change-local-permission %remove [path who]:diff)
::
%delete
?. (~(has by synced) path.diff)
[~ this]
:_ this(synced (~(del by synced) path.diff))
[ost.bol %pull [%permission path.diff] [our.bol %permission-store] ~]~
[~ state]
:_ state(synced (~(del by synced) path.diff))
:_ ~
:* %pass
[%permission path.diff]
%agent
[our.bowl %permission-store]
[%leave ~]
==
==
::
++ change-local-permission
|= [kind=?(%add %remove) pax=path who=(set ship)]
^- (quip move _this)
:_ this
%+ weld
?- kind
%add (update-subscribers [%permission pax] [%add pax who])
%remove (update-subscribers [%permission pax] [%remove pax who])
==
^- (quip card _state)
:_ state
:- ?- kind
%add (update-subscribers [%permission pax] [%add pax who])
%remove (update-subscribers [%permission pax] [%remove pax who])
==
=/ access-paths=(unit (set path)) (~(get by access-control) pax)
:: check if this path changes the access permissions for other paths
?~ access-paths
~
?~ access-paths ~
(quit-subscriptions kind pax who u.access-paths)
::
++ handle-foreign
|= diff=permission-update
^- (quip move _this)
^- (quip card _state)
?- -.diff
%create (change-foreign-permission path.diff diff)
%add (change-foreign-permission path.diff diff)
%remove (change-foreign-permission path.diff diff)
?(%create %add %remove)
(change-foreign-permission path.diff diff)
::
%delete
?> ?=([* ^] path.diff)
=/ owner-access=(unit owner-access) (~(get by synced) path.diff)
=/ owner-access=(unit owner-access)
(~(get by synced) path.diff)
?~ owner-access
[~ this]
?. =(ship.u.owner-access src.bol)
[~ this]
:_ this(synced (~(del by synced) path.diff))
[~ state]
?. =(ship.u.owner-access src.bowl)
[~ state]
:_ state(synced (~(del by synced) path.diff))
:~ (permission-poke diff)
[ost.bol %pull [%permission path.diff] [src.bol %permission-hook] ~]
::
:* %pass
[%permission path.diff]
%agent
[src.bowl %permission-hook]
[%leave ~]
==
==
==
::
++ change-foreign-permission
|= [pax=path diff=permission-update]
^- (quip move _this)
?> ?=([* ^] pax)
=/ owner-access=(unit owner-access) (~(get by synced) pax)
:_ this
|= [=path diff=permission-update]
^- (quip card _state)
?> ?=([* ^] path)
=/ owner-access=(unit owner-access)
(~(get by synced) path)
:_ state
?~ owner-access ~
?. =(src.bol ship.u.owner-access) ~
?. =(src.bowl ship.u.owner-access) ~
[(permission-poke diff)]~
::
++ quit-subscriptions
|= [kind=?(%add %remove) pax=path who=(set ship) access-paths=(set path)]
^- (list move)
=/ perm (permission-scry pax)
?. ?|
?&(=(kind.perm %black) =(kind %add))
?&(=(kind.perm %white) =(kind %remove))
|= $: kind=?(%add %remove)
perm-path=path
who=(set ship)
access-paths=(set path)
==
:: if allow, do nothing
~
=/ sup
%- ~(gas by *(map [ship path] bone))
%+ turn ~(tap by sup.bol)
|=([=bone anchor=[ship path]] [anchor bone])
:: if ban, iterate through
:: all ships that have been banned
:: and all affected paths that have had their permissions changed
:: then quit their subscriptions
^- (list card)
=/ perm (permission-scry perm-path)
:: if the change resolves to "allow",
::
?. ?| ?&(=(%black kind.perm) =(%add kind))
?&(=(%white kind.perm) =(%remove kind))
==
:: do nothing.
~
:: else, it resolves to "deny"/"ban".
:: kick subscriptions for all ships, at all affected paths.
::
%- zing
%+ turn ~(tap in who)
|= check-ship=ship
^- (list move)
%+ murn ~(tap in access-paths)
^- (list card)
%+ turn ~(tap in access-paths)
|= access-path=path
^- (unit move)
=/ bne (~(get by sup) [check-ship [%permission access-path]])
?~(bne ~ `[u.bne %quit ~])
::
++ quit
|= wir=wire
^- (quip move _this)
~& permission-hook-quit+wir
?> ?=([* ^] wir)
?. (~(has by synced) t.wir)
:: no-op
[~ this]
=/ =owner-access (~(got by synced) t.wir)
~& %permission-hook-resubscribe
:_ (track-bone wir)
[ost.bol %peer wir [ship.owner-access %permission-hook] wir]~
::
++ reap
|= [wir=wire saw=(unit tang)]
^- (quip move _this)
?~ saw
[~ this]
?> ?=(^ wir)
:_ this(synced (~(del by synced) t.wir))
%. ~
%- slog
:* leaf+"permission-hook failed subscribe on {(spud t.wir)}"
leaf+"stack trace:"
u.saw
==
[%give %kick `[%permission access-path] `check-ship]
::
++ permission-scry
|= pax=path
^- permission
=. pax ;:(weld /=permission-store/(scot %da now.bol)/permission pax /noun)
=. pax ;:(weld /=permission-store/(scot %da now.bowl)/permission pax /noun)
(need .^((unit permission) %gx pax))
::
++ permitted-scry
|= pax=path
^- ?
.^(? %gx ;:(weld /=permission-store/(scot %da now.bol)/permitted pax /noun))
++ permitted
|= [who=ship =path]
.^ ?
%gx
(scot %p our.bowl)
%permission-store
(scot %da now.bowl)
%permitted
(scot %p src.bowl)
(snoc path %noun)
==
::
++ permission-poke
|= act=permission-action
^- move
[ost.bol %poke / [our.bol %permission-store] [%permission-action act]]
^- card
:* %pass
/permission-action
%agent
[our.bowl %permission-store]
%poke
%permission-action
!>(act)
==
::
++ update-subscribers
|= [pax=path upd=permission-update]
^- (list move)
%+ turn (prey:pubsub:userlib pax bol)
|= [=bone *]
[bone %diff %permission-update upd]
|= [=path upd=permission-update]
^- card
[%give %fact `path %permission-update !>(upd)]
::
++ track-bone
|= wir=wire
^+ this
=/ bnd (~(get by boned) wir)
?^ bnd
this(boned (~(put by boned) wir (snoc u.bnd ost.bol)))
this(boned (~(put by boned) wir [ost.bol]~))
::
++ pull-wire
|= pax=path
^- (list move)
?> ?=([* ^] pax)
=/ bnd (~(get by boned) pax)
?~ bnd ~
=/ owner-access=(unit owner-access) (~(get by synced) t.pax)
++ leave-permission
|= =path
^- (list card)
=/ owner-access=(unit owner-access)
(~(get by synced) path)
?~ owner-access ~
%+ turn u.bnd
|= =bone
?: =(ship.u.owner-access our.bol)
[bone %pull pax [our.bol %permission-store] ~]
[bone %pull pax [ship.u.owner-access %permission-hook] ~]
::
:_ ~
=/ perm-path [%permission path]
?: =(ship.u.owner-access our.bowl)
[%pass perm-path %agent [our.bowl %permission-store] %leave ~]
[%pass perm-path %agent [ship.u.owner-access %permission-hook] %leave ~]
--

195
pkg/arvo/app/permission-store.hoon
View File

@ -1,79 +1,95 @@
:: permission-store: data store for keeping track of permissions
:: permissions are white lists or black lists of ships
:: permission-store: track black- and whitelists of ships
::
/- *permission-store
/+ default-agent
::
|%
+$ move [bone [%diff diff]]
+$ card card:agent:gall
::
+$ diff
$% [%permission-initial =permission-map]
[%permission-update =permission-update]
+$ versioned-state
$% state-zero
==
::
+$ state
$: permissions=permission-map
+$ state-zero
$: %0
permissions=permission-map
==
--
=| state-zero
=* state -
^- agent:gall
=<
|_ =bowl:gall
+* this .
permission-core +>
pc ~(. permission-core bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(state-zero old))
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?> (team:title our.bowl src.bowl)
=^ cards state
?: ?=(%permission-action mark)
(poke-permission-action:pc !<(permission-action vase))
(on-poke:def mark vase)
[cards this]
::
++ on-watch
|= =path
^- (quip card _this)
?> (team:title our.bowl src.bowl)
|^
=/ cards=(list card)
?+ path (on-watch:def path)
[%all ~] (give %permission-initial !>(permissions))
[%updates ~] ~
[%permission @ *]
=/ =vase !>([%create t.path (~(got by permissions) t.path)])
(give %permission-update vase)
==
[cards this]
::
++ give
|= =cage
^- (list card)
[%give %fact ~ cage]~
--
::
++ on-leave on-leave:def
++ on-peek
|= =path
^- (unit (unit cage))
?+ path (on-peek:def path)
[%x %keys ~] ``noun+!>(~(key by permissions))
[%x %permission *]
?~ t.t.path ~
``noun+!>((~(get by permissions) t.t.path))
::
[%x %permitted @ *]
?~ t.t.t.path ~
=/ pem (~(get by permissions) t.t.t.path)
?~ pem ~
=/ who (slav %p i.t.t.path)
=/ has (~(has in who.u.pem) who)
``noun+!>(?-(kind.u.pem %black !has, %white has))
==
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
|_ [bol=bowl:gall %v0 state]
::
++ this .
::
:: gall interface
::
++ peer-all
|= =path
^- (quip move _this)
?> (team:title our.bol src.bol)
:: we now proxy all events to this path
:_ this
[ost.bol %diff %permission-initial permissions]~
::
++ peer-updates
|= =path
^- (quip move _this)
?> (team:title our.bol src.bol)
:: we now proxy all events to this path
[~ this]
::
++ peer-permission
|= =path
^- (quip move _this)
?~ path !!
?> (team:title our.bol src.bol)
?> (~(has by permissions) path)
:_ this
[ost.bol %diff %permission-update [%create path (~(got by permissions) path)]]~
::
++ peek-x-keys
|= pax=path
^- (unit (unit [%noun (set path)]))
[~ ~ %noun ~(key by permissions)]
::
++ peek-x-permission
|= =path
^- (unit (unit [%noun (unit permission)]))
?~ path
~
[~ ~ %noun (~(get by permissions) path)]
::
++ peek-x-permitted
|= =path
^- (unit (unit [%noun ?]))
?~ path
~
=/ pem (~(get by permissions) t.path)
?~ pem
~
=/ who (slav %p i.path)
=/ has (~(has in who.u.pem) who)
:^ ~ ~ %noun
?-(kind.u.pem %black !has, %white has)
|_ bol=bowl:gall
::
++ poke-permission-action
|= action=permission-action
^- (quip move _this)
^- (quip card _state)
?> (team:title our.bol src.bol)
?- -.action
%add (handle-add action)
@ -86,99 +102,96 @@
::
++ handle-add
|= act=permission-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%add -.act)
?~ path.act
[~ this]
[~ state]
:: TODO: calculate diff
:: =+ new=(~(dif in who.what.action) who.u.pem)
:: ?~(new ~ `what.action(who new))
?. (~(has by permissions) path.act)
[~ this]
[~ state]
:- (send-diff path.act act)
=/ perm (~(got by permissions) path.act)
=. who.perm (~(uni in who.perm) who.act)
this(permissions (~(put by permissions) path.act perm))
state(permissions (~(put by permissions) path.act perm))
::
++ handle-remove
|= act=permission-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%remove -.act)
?~ path.act
[~ this]
[~ state]
?. (~(has by permissions) path.act)
[~ this]
[~ state]
=/ perm (~(got by permissions) path.act)
=. who.perm (~(dif in who.perm) who.act)
:: TODO: calculate diff
:: =+ new=(~(int in who.what.action) who.u.pem)
:: ?~(new ~ `what.action(who new))
:- (send-diff path.act act)
this(permissions (~(put by permissions) path.act perm))
state(permissions (~(put by permissions) path.act perm))
::
++ handle-create
|= act=permission-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%create -.act)
?~ path.act
[~ this]
[~ state]
?: (~(has by permissions) path.act)
[~ this]
[~ state]
:: TODO: calculate diff
:- (send-diff path.act act)
this(permissions (~(put by permissions) path.act permission.act))
state(permissions (~(put by permissions) path.act permission.act))
::
++ handle-delete
|= act=permission-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%delete -.act)
?~ path.act
[~ this]
[~ state]
?. (~(has by permissions) path.act)
[~ this]
[~ state]
:- (send-diff path.act act)
this(permissions (~(del by permissions) path.act))
state(permissions (~(del by permissions) path.act))
::
++ handle-allow
|= act=permission-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%allow -.act)
?~ path.act
[~ this]
[~ state]
=/ perm (~(get by permissions) path.act)
?~ perm
[~ this]
[~ state]
?: =(kind.u.perm %white)
(handle-add [%add +.act])
(handle-remove [%remove +.act])
::
++ handle-deny
|= act=permission-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%deny -.act)
?~ path.act
[~ this]
[~ state]
=/ perm (~(get by permissions) path.act)
?~ perm
[~ this]
[~ state]
?: =(kind.u.perm %black)
(handle-add [%add +.act])
(handle-remove [%remove +.act])
::
++ update-subscribers
|= [pax=path upd=permission-update]
^- (list move)
%+ turn (prey:pubsub:userlib pax bol)
|= [=bone *]
[bone %diff %permission-update upd]
^- (list card)
[%give %fact `pax %permission-update !>(upd)]~
::
++ send-diff
|= [pax=path upd=permission-update]
^- (list move)
^- (list card)
%- zing
:~ (update-subscribers /all upd)
(update-subscribers /updates upd)
(update-subscribers [%permission pax] upd)
==
::
--

619
pkg/arvo/app/ph.hoon
View File

@ -1,619 +0,0 @@
:: Test the pH of your aquarium. See if it's safe to put in real fish.
::
:: usage:
:: :aqua [%run-test %test-add]
::
:: TODO:
:: - Restore a fleet
:: - Compose tests
::
/- aquarium, ph
/+ ph, ph-tests, ph-azimuth, ph-philter
=, ph-sur=^ph
=, aquarium
=, ph
=, ph-philter
=> $~ |%
+$ move (pair bone card)
+$ card
$% [%poke wire dock poke-type]
[%peer wire dock path]
[%pull wire dock ~]
[%diff diff-type]
==
::
+$ poke-type
$% [%aqua-events (list aqua-event)]
[%drum-start term term]
[%aqua-vane-control ?(%subscribe %unsubscribe)]
==
::
+$ diff-type
$% [%aqua-effects aqua-effects]
==
::
+$ state
$: %0
test-core=(unit test-core-state)
tests=(map term [(list ship) _*form:(ph ,~)])
other-state
==
::
+$ test-core-state
$: lab=term
hers=(list ship)
test=_*form:(ph ,~)
==
::
+$ other-state
$: test-qeu=(qeu term)
results=(list (pair term ?))
effect-log=(list [who=ship uf=unix-effect])
==
--
=, gall
=/ vane-apps=(list term)
~[%aqua-ames %aqua-behn %aqua-dill %aqua-eyre]
|_ $: hid=bowl
state
==
++ this .
++ manual-tests
^- (list (pair term [(list ship) _*form:(ph ,~)]))
=+ (ph-tests our.hid)
=+ ph-azimuth=(ph-azimuth our.hid)
=/ eth-node (spawn:ph-azimuth ~bud)
=/ m (ph ,~)
:~ :+ %boot-bud
~[~bud]
(raw-ship ~bud ~)
::
:+ %add
~[~bud]
;< ~ bind:m (raw-ship ~bud ~)
|= pin=ph-input
?: =(%init -.q.uf.pin)
[& (dojo ~bud "[%test-result (add 2 3)]") %wait ~]
?: (is-dojo-output ~bud who.pin uf.pin "[%test-result 5]")
[& ~ %done ~]
[& ~ %wait ~]
::
:+ %hi
~[~bud ~dev]
;< ~ bind:m (raw-ship ~bud ~)
~& > "BUD DONE"
;< ~ bind:m (raw-ship ~dev ~)
~& > "DEV DONE"
(send-hi ~bud ~dev)
::
:+ %boot-planet
~[~bud ~marbud ~linnup-torsyx]
(planet ~linnup-torsyx)
::
:+ %second-cousin-hi
~[~bud ~marbud ~linnup-torsyx ~dev ~mardev ~mitnep-todsut]
;< ~ bind:m (planet ~linnup-torsyx)
;< ~ bind:m (planet ~mitnep-todsut)
(send-hi ~linnup-torsyx ~mitnep-todsut)
::
:+ %change-file
~[~bud]
;< ~ bind:m (raw-ship ~bud ~)
;< file=@t bind:m (touch-file ~bud %home)
(check-file-touched ~bud %home file)
::
:+ %child-sync
~[~bud ~marbud]
;< ~ bind:m (star ~marbud)
;< file=@t bind:m (touch-file ~bud %base)
(check-file-touched ~marbud %home file)
::
:+ %boot-az
~[~bud]
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
(raw-real-ship:eth-node ~bud)
(pure:m ~)
::
:+ %hi-az
~[~bud ~dev]
=. eth-node (spawn:eth-node ~dev)
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~dev)
~& > %dev-done
;< ~ bind:m (raw-real-ship:eth-node ~bud)
~& > %bud-done
(send-hi ~bud ~dev)
(pure:m ~)
::
:+ %moon-az
~[~bud ~marbud ~linnup-torsyx ~linnup-torsyx-linnup-torsyx ~dev]
=. eth-node (spawn:eth-node ~marbud)
=. eth-node (spawn:eth-node ~linnup-torsyx)
=. eth-node (spawn:eth-node ~dev)
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~bud)
~& > 'BUD DONE'
;< ~ bind:m (raw-real-ship:eth-node ~marbud)
~& > 'MARBUD DONE'
;< ~ bind:m (raw-real-ship:eth-node ~linnup-torsyx)
~& > 'LINNUP DONE'
;< ~ bind:m (raw-real-ship:eth-node ~linnup-torsyx-linnup-torsyx)
~& > 'MOON LINNUP DONE'
;< ~ bind:m (send-hi ~bud ~linnup-torsyx-linnup-torsyx)
~& > 'HI DOWN DONE'
;< ~ bind:m (send-hi ~linnup-torsyx-linnup-torsyx ~marbud)
~& > 'HI UP DONE'
;< ~ bind:m (raw-real-ship:eth-node ~dev)
~& > 'DEV DONE'
;< ~ bind:m (send-hi ~linnup-torsyx-linnup-torsyx ~dev)
~& > 'HI OVER UP DONE'
;< ~ bind:m (send-hi ~dev ~linnup-torsyx-linnup-torsyx)
~& > 'HI OVER DOWN DONE'
(pure:m ~)
(pure:m ~)
::
:+ %breach-hi
~[~bud ~dev]
=. eth-node (spawn:eth-node ~dev)
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~bud)
~& > 'BUD DONE'
;< ~ bind:m (raw-real-ship:eth-node ~dev)
~& > 'DEV DONE'
(send-hi ~bud ~dev)
~& > 'HI DONE'
;< eth-node=_eth-node bind:m
(breach-and-hear:eth-node our.hid ~dev ~bud)
~& > 'BREACH DONE'
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (send-hi-not-responding ~bud ~dev)
~& > 'HI NOT RESPONDING DONE'
;< ~ bind:m (raw-real-ship:eth-node ~dev)
~& > 'REBOOT DEV DONE'
(wait-for-dojo ~bud "hi ~dev successful")
~& > 'DONE'
(pure:m ~)
::
:+ %breach-hi-cousin
~[~bud ~dev ~marbud ~mardev]
=. eth-node (spawn:eth-node ~dev)
=. eth-node (spawn:eth-node ~marbud)
=. eth-node (spawn:eth-node ~mardev)
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~bud)
;< ~ bind:m (raw-real-ship:eth-node ~dev)
;< ~ bind:m (raw-real-ship:eth-node ~marbud)
;< ~ bind:m (raw-real-ship:eth-node ~mardev)
(send-hi ~marbud ~mardev)
;< eth-node=_eth-node bind:m
(breach-and-hear:eth-node our.hid ~mardev ~marbud)
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (send-hi-not-responding ~marbud ~mardev)
;< ~ bind:m (raw-real-ship:eth-node ~mardev)
(wait-for-dojo ~marbud "hi ~mardev successful")
(pure:m ~)
::
:+ %breach-sync
~[~bud ~marbud]
=. eth-node (spawn:eth-node ~marbud)
=. eth-node (spawn:eth-node ~fipfes)
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~bud)
~& > 'BUD DONE'
;< ~ bind:m (raw-real-ship:eth-node ~marbud)
~& > 'MARBUD DONE'
;< file=@t bind:m (touch-file ~bud %base)
~& > 'TOUCH FILE DONE'
(check-file-touched ~marbud %home file)
~& > 'TOUCH FILE CHECK DONE'
;< eth-node=_eth-node bind:m
(breach-and-hear:eth-node our.hid ~bud ~marbud)
~& > 'BREACH DONE'
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~bud)
~& > 'BUD RE DONE'
;< ~ bind:m (just-events (dojo ~bud "|merge %base ~marbud %kids, =gem %this"))
~& > 'THIS MERGE STARTED DONE'
;< file=@t bind:m (touch-file ~bud %base)
~& > 'TOUCH-1 DONE'
;< file=@t bind:m (touch-file ~bud %base)
~& > 'TOUCH-2 DONE'
(check-file-touched ~marbud %home file)
~& > 'DONE DONE'
(pure:m ~)
::
:+ %breach-multiple
~[~bud ~marbud]
=. eth-node (spawn:eth-node ~marbud)
=. eth-node (spawn:eth-node ~fipfes)
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~bud)
~& > 'BUD DONE'
;< ~ bind:m (raw-real-ship:eth-node ~marbud)
~& > 'MARBUD DONE'
;< file=@t bind:m (touch-file ~bud %base)
~& > 'TOUCH DONE'
(check-file-touched ~marbud %home file)
;< eth-node=_eth-node bind:m
(breach-and-hear:eth-node our.hid ~bud ~marbud)
~& > 'BREACH-1 DONE'
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
(raw-real-ship:eth-node ~bud)
~& > 'BUD RE DONE'
;< eth-node=_eth-node bind:m
(breach-and-hear:eth-node our.hid ~marbud ~bud)
~& > 'BREACH-2 DONE'
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~marbud)
~& > 'MARBUD RE DONE'
;< file=@t bind:m (touch-file ~bud %base)
~& > 'TOUCH-1 DONE'
;< file=@t bind:m (touch-file ~bud %base)
~& > 'TOUCH-2 DONE'
(check-file-touched ~marbud %home file)
~& > 'DONE DONE'
(pure:m ~)
::
:+ %breach-sudden
~[~bud ~marbud]
=. eth-node (spawn:eth-node ~marbud)
=. eth-node (spawn:eth-node ~fipfes)
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~bud)
~& > 'BUD DONE'
;< ~ bind:m (raw-real-ship:eth-node ~marbud)
~& > 'MARBUD DONE'
;< file=@t bind:m (touch-file ~bud %base)
~& > 'TOUCH FILE DONE'
(check-file-touched ~marbud %home file)
~& > 'TOUCH FILE CHECK DONE'
=. eth-node (breach:eth-node ~bud)
~& > 'BREACH EXECUTED'
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~bud)
~& > 'BUD RE DONE'
;< ~ bind:m (just-events (dojo ~bud "|merge %base ~marbud %kids, =gem %this"))
~& > 'THIS MERGE STARTED DONE'
;< file=@t bind:m (touch-file ~bud %base)
~& > 'TOUCH-1 DONE'
;< file=@t bind:m (touch-file ~bud %base)
~& > 'TOUCH-2 DONE'
(check-file-touched ~marbud %home file)
~& > 'DONE DONE'
(pure:m ~)
::
:: Doesn't succeed because success is hard to define, just make
:: sure it doesn't crash in Gall
::
:+ %breach-gall
~[~bud ~dev]
=. eth-node (spawn:eth-node ~dev)
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~bud)
~& > 'BUD DONE'
;< ~ bind:m (raw-real-ship:eth-node ~dev)
~& > 'DEV DONE'
;< ~ bind:m (just-events (dojo ~bud "|start %hall"))
;< ~ bind:m (just-events (dojo ~bud "|start %talk"))
;< ~ bind:m (just-events (dojo ~dev "|start %hall"))
;< ~ bind:m (just-events (dojo ~dev "|start %talk"))
;< ~ bind:m (just-events (dojo ~bud ";create channel %hi 'desc'"))
;< ~ bind:m (just-events (dojo ~dev ";join ~bud/hi"))
;< ~ bind:m (just-events (dojo ~bud "heyya"))
(wait-for-dojo ~dev "heyya")
~& > 'CHANNEL DONE'
;< eth-node=_eth-node bind:m
(breach-and-hear:eth-node our.hid ~dev ~bud)
~& > 'BREACH DONE'
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~dev)
~& > 'REBOOT DEV DONE'
(send-hi ~bud ~dev)
~& > 'DONE'
stall
==
::
++ install-tests
^+ this
=. tests (malt manual-tests)
this
::
++ prep
|= old=(unit [@ tests=* rest=*])
^- (quip move _this)
~& prep=%ph
=. this install-tests
`this
:: ?~ old
:: `this
:: =/ new ((soft other-state) rest.u.old)
:: ?~ new
:: `this
:: `this(+<+>+> u.new)
::
++ publish-aqua-effects
|= afs=aqua-effects
^- (list move)
%+ murn ~(tap by sup.hid)
|= [b=bone her=ship pax=path]
^- (unit move)
?. ?=([%effects ~] pax)
~
`[b %diff %aqua-effects afs]
::
++ run-events
|= [lab=term what=(list ph-event)]
^- (quip move _this)
?: =(~ what)
`this
=/ res
|- ^- (each (list aqua-event) ?)
?~ what
[%& ~]
?: ?=(%test-done -.i.what)
[%| p.i.what]
=/ nex $(what t.what)
?: ?=(%| -.nex)
nex
[%& `aqua-event`i.what p.nex]
?: ?=(%| -.res)
=^ moves-1 this (finish-test lab p.res)
=^ moves-2 this run-test
[(weld moves-1 moves-2) this]
[[ost.hid %poke /running [our.hid %aqua] %aqua-events p.res]~ this]
::
:: Cancel subscriptions to ships
::
++ finish-test
|= [lab=term success=?]
^- (quip move _this)
?~ test-core
`this
~& ?: success
"TEST {(trip lab)} SUCCESSFUL"
"TEST {(trip lab)} FAILED"
:_ this(test-core ~, results [[lab success] results])
%- zing
%+ turn hers.u.test-core
|= her=ship
^- (list move)
:~ [ost.hid %pull /[lab]/(scot %p her) [our.hid %aqua] ~]
:* ost.hid
%poke
/cancelling
[our.hid %aqua]
%aqua-events
[%pause-events her]~
==
==
::
:: Start another test if one is in the queue
::
++ run-test
^- (quip move _this)
?^ test-core
`this
?: =(~ test-qeu)
?~ results
`this
=/ throw-away print-results
`this(results ~)
=^ lab test-qeu ~(get to test-qeu)
~& [running-test=lab test-qeu]
=. effect-log ~
=+ ^- [ships=(list ship) test=_*form:(ph ,~)]
(~(got by tests) lab)
=> .(test-core `(unit test-core-state)`test-core)
=. test-core `[lab ships test]
=^ moves-1 this (subscribe-to-effects lab ships)
=^ moves-2 this
(diff-aqua-effects /[lab]/(scot %p -.ships) -.ships [/ %init ~]~)
[:(weld init-vanes pause-fleet subscribe-vanes moves-1 moves-2) this]
::
:: Print results with ~&
::
++ print-results
~& "TEST REPORT:"
=/ throw-away
%+ turn
results
|= [lab=term success=?]
~& "{?:(success "SUCCESS" "FAILURE")}: {(trip lab)}"
~
~& ?: (levy results |=([term s=?] s))
"ALL TESTS SUCCEEDED"
"FAILURES"
~
::
:: Should check whether we're already subscribed
::
++ subscribe-to-effects
|= [lab=@tas hers=(list ship)]
:_ this
%+ turn hers
|= her=ship
^- move
:* ost.hid
%peer
/[lab]/(scot %p her)
[our.hid %aqua]
/effects/(scot %p her)
==
::
:: Start the vane drivers
::
++ init-vanes
^- (list move)
%+ murn
`(list term)`[%aqua vane-apps]
|= vane-app=term
^- (unit move)
=/ app-started
.^(? %gu /(scot %p our.hid)/[vane-app]/(scot %da now.hid))
?: app-started
~
`[ost.hid %poke /start [our.hid %hood] %drum-start %home vane-app]
::
:: Restart the vane drivers' subscriptions
::
++ subscribe-vanes
^- (list move)
%+ turn
vane-apps
|= vane-app=term
[ost.hid %poke /init [our.hid vane-app] %aqua-vane-control %subscribe]
::
:: Pause all existing ships
::
++ pause-fleet
^- (list move)
:_ ~
:* ost.hid %poke /pause-fleet [our.hid %aqua] %aqua-events
%+ turn
.^((list ship) %gx /(scot %p our.hid)/aqua/(scot %da now.hid)/ships/noun)
|= who=ship
[%pause-events who]
==
::
:: User interface
::
++ poke-ph-command
|= com=cli:ph-sur
^- (quip move _this)
?- -.com
%init [init-vanes this]
%run
?. (~(has by tests) lab.com)
~& [%no-test lab.com]
`this
=. test-qeu (~(put to test-qeu) lab.com)
run-test
::
%cancel
=^ moves-1 this (finish-test %last |)
=. test-qeu ~
=^ moves-2 this run-test
[:(weld moves-1 moves-2) this]
::
%run-all
=. test-qeu
%- ~(gas to test-qeu)
(turn manual-tests head)
run-test
::
%print
~& lent=(lent effect-log)
~& %+ roll effect-log
|= [[who=ship uf=unix-effect] ~]
?: ?=(?(%blit %doze) -.q.uf)
~
?: ?=(%ergo -.q.uf)
~& [who [- +<]:uf %omitted-by-ph]
~
~& [who uf]
~
`this
==
::
:: Receive effects back from aqua
::
++ diff-aqua-effects
|= [way=wire afs=aqua-effects]
^- (quip move _this)
:: ~& [%diff-aqua-effect way who.afs]
?> ?=([@tas @ ~] way)
=/ lab i.way
?~ test-core
~& [%ph-dropping-done lab]
[[ost.hid %pull way [our.hid %aqua] ~]~ this]
?. =(lab lab.u.test-core)
~& [%ph-dropping-strange lab]
[[ost.hid %pull way [our.hid %aqua] ~]~ this]
=+ |- ^- $: thru-effects=(list unix-effect)
events=(list ph-event)
log=_effect-log
done=(unit ?)
test=_test.u.test-core
==
?~ ufs.afs
[~ ~ ~ ~ test.u.test-core]
=/ m-res=_*output:(ph ,~)
(test.u.test-core now.hid who.afs i.ufs.afs)
=? ufs.afs =(%cont -.next.m-res)
[i.ufs.afs [/ %init ~] t.ufs.afs]
=^ done=(unit ?) test.u.test-core
?- -.next.m-res
%wait [~ test.u.test-core]
%cont [~ self.next.m-res]
%fail [`| test.u.test-core]
%done [`& test.u.test-core]
==
=+ ^- _$
?~ done
$(ufs.afs t.ufs.afs)
[~ ~ ~ done test.u.test-core]
:^ ?: thru.m-res
[i.ufs.afs thru-effects]
thru-effects
(weld events.m-res events)
[[who i.ufs]:afs log]
[done test]
=. test.u.test-core test
=. effect-log (weld log effect-log)
=> .(test-core `(unit test-core-state)`test-core)
?^ done
=^ moves-1 this (finish-test lab u.done)
=^ moves-2 this run-test
[(weld moves-1 moves-2) this]
=/ moves-1 (publish-aqua-effects who.afs thru-effects)
=^ moves-2 this (run-events lab events)
[(weld moves-1 moves-2) this]
::
:: Subscribe to effects
::
++ peer-effects
|= pax=path
^- (quip move _this)
?. ?=(~ pax)
~& [%ph-bad-peer-effects pax]
`this
`this
::
:: Subscription cancelled
::
++ pull
|= pax=path
`+>.$
--

225
pkg/arvo/app/ping.hoon Normal file
View File

@ -0,0 +1,225 @@
:: Ping our sponsorship tree regularly for routing.
::
:: To traverse NAT, we need the response to come back from someone
:: we've sent a message to. We ping our sponsor so that they know
:: where we are. However, we also need to ping our galaxy because if
:: the other ship tries to respond directly, it may be blocked by our
:: firewall or NAT. Thus, the response must come from a ship we've
:: messaged directly, and the only one we can guarantee is our galaxy.
:: Note this issue manifests itself even for bootstrapping a planet to
:: talk to its own star.
::
/+ default-agent, verb
=* point point:able:kale
::
|%
+$ card card:agent:gall
+$ ship-state
$% [%idle ~]
[%poking ~]
[%waiting until=@da]
==
--
::
=| state=[%0 ships=(map ship [=rift =ship-state])]
=> |%
:: +print-error: maybe +slog
::
++ print-error
|= [=tape error=(unit tang)]
^+ same
?~ error same
%- (slog leaf+tape u.error) same
:: +set-timer: send a card to behn to set a timer
::
++ set-timer
|= [now=@da =ship]
^- (quip card _state)
=/ s (~(get by ships.state) ship)
?~ s
`state
?. ?=(%poking -.ship-state.u.s)
%- (slog leaf+"ping: strange state {<ship s>}" ~)
`state
=/ until (add ~s30 now)
=. ships.state
(~(put by ships.state) ship u.s(ship-state [%waiting until]))
:_ state
=/ =wire /ping-wait/(scot %p ship)/(scot %da until)
[%pass wire %arvo %b %wait `@da`until]~
:: +send-ping: poke their %ping app
::
++ send-ping
|= [our=@p now=@da =ship]
^- (quip card _state)
::
?: =(our ship)
`state
=/ s (~(get by ships.state) ship)
?~ s
`state
?. ?=(%idle -.ship-state.u.s)
`state
:_ state(ships (~(put by ships.state) ship u.s(ship-state [%poking ~])))
[%pass /ping-send/(scot %p ship) %agent [ship %ping] %poke %noun !>(~)]~
:: +stop-ping-ship: stop listening to jael if not sponsor or old rift
::
++ stop-ping-ship
|= [our=@p now=@da =ship =old=rift =ship-state]
^- (quip card _state)
=+ .^(=new=rift %j /=rift/(scot %da now)/(scot %p ship))
:: if nothing's changed about us, don't cancel
::
?: ?& =(old-rift new-rift)
(~(has in (silt (saxo:title our now our))) ship)
==
`state
:: otherwise, kill jael subscription and timer
::
:_ state(ships (~(del by ships.state) ship))
[%pass /jael/(scot %p ship) %arvo %j %nuke (silt ship ~)]~
:: +start-ping-ship: start listening to jael updates if not already
::
:: While %public-keys is idempotent in most senses, it does
:: trigger a response, and this function is called on that
:: response, so we need a guard to avoid an infinite loop.
::
++ start-ping-ship
|= [our=@p now=@da =ship]
^- (quip card _state)
::
?: (~(has by ships.state) ship)
(send-ping our now ship)
::
;< new-state=_state (rind card state)
=+ .^(=rift %j /=rift/(scot %da now)/(scot %p ship))
:_ state(ships (~(put by ships.state) ship rift %idle ~))
[%pass /jael/(scot %p ship) %arvo %j %public-keys (silt ship ~)]~
=. state new-state
::
(send-ping our now ship)
:: +kick: idempotent operation to make clean start for all pings
::
++ kick
|= [our=@p now=@da]
^- (quip card _state)
?: =(%czar (clan:title our))
`state
::
=/ old-ships=(list [=ship =rift =ship-state]) ~(tap by ships.state)
|- ^- (quip card _state)
=* loop $
?^ old-ships
;< new-state=_state (rind card state)
(stop-ping-ship our now i.old-ships)
=. state new-state
loop(old-ships t.old-ships)
::
=/ new-ships (saxo:title our now our)
|- ^- (quip card _state)
=* loop $
?^ new-ships
;< new-state=_state (rind card state)
(start-ping-ship our now i.new-ships)
=. state new-state
loop(new-ships t.new-ships)
::
`state
:: +rind: bind for the the writer monad on (quip effect state)
::
++ rind
|* [effect=mold state=*]
|* state-type=mold
|= $: m-b=(quip effect state-type)
fun=$-(state-type (quip effect state-type))
==
^- (quip effect state-type)
=^ effects-1=(list effect) state m-b
=^ effects-2=(list effect) state (fun state)
[(weld effects-1 effects-2) state]
::
--
%+ verb |
^- agent:gall
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
::
:: +on-init: initializing on startup
::
++ on-init
^- [(list card) _this]
=^ cards state (kick our.bowl now.bowl)
[cards this]
::
++ on-save !>(state)
++ on-load
|= old=vase
=. state !<(_state old)
(on-poke %noun !>(%kick))
:: +on-poke: positively acknowledge pokes
::
++ on-poke
|= [=mark =vase]
?: =(q.vase %kick)
=. ships.state
%- ~(run by ships.state)
|= [=rift =ship-state]
[999.999 ship-state]
on-init
`this
::
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-peek
|= =path
^- (unit (unit cage))
``noun+!>(state)
:: +on-agent: handle ames ack
::
++ on-agent
|= [=wire =sign:agent:gall]
^- [(list card) _this]
?> ?=([%ping-send @ ~] wire)
?> ?=(%poke-ack -.sign)
::
%- (print-error "ping: ack" p.sign)
=^ cards state
(set-timer now.bowl (slav %p i.t.wire))
[cards this]
:: +on-arvo: handle timer firing
::
++ on-arvo
|= [=wire =sign-arvo]
^- [(list card) _this]
?+ wire !!
[%ping-wait @ @ ~]
?> ?=(%wake +<.sign-arvo)
=/ =ship (slav %p i.t.wire)
=/ until=@da (slav %da i.t.t.wire)
=/ s (~(get by ships.state) ship)
?~ s
`this
?. =([%waiting until] ship-state.u.s)
`this
=. ships.state (~(put by ships.state) ship u.s(ship-state [%idle ~]))
%- (print-error "ping: wake" error.sign-arvo)
=^ cards state
(send-ping our.bowl now.bowl ship)
[cards this]
::
[%jael @ ~]
:: whenever we get an update from Jael, kick
::
?> ?=(%public-keys +<.sign-arvo)
:_ this
[%pass /delay %arvo %b %wait now.bowl]~
:: Delayed until next event so that ames can clear its state
::
[%delay ~]
?> ?=(%wake +<.sign-arvo)
on-init
==
::
++ on-fail on-fail:def
--

309
pkg/arvo/app/pool-group-hook.hoon
View File

@ -1,7 +1,9 @@
:: pool-group-hook: maintain groups based on invite pool
::
/- group-store
/+ tapp, stdio, ethio
:: looks at our invite tree, adds our siblings to group at +group-path
::
/- group-store, spider
/+ default-agent, verb
=, ethereum-types
=, able:jael
::
@ -13,150 +15,185 @@
=> |%
+$ app-state
$: %0
running=(unit =tid:spider)
url=_'http://eth-mainnet.urbit.org:8545'
inviter=ship
inviter=(unit ship)
invited=(set ship)
==
::
+$ peek-data ~
+$ in-poke-data ~
+$ out-poke-data
[%group-action group-action:group-store]
+$ in-peer-data ~
+$ out-peer-data ~
++ tapp
%: ^tapp
app-state
peek-data
in-poke-data
out-poke-data
in-peer-data
out-peer-data
==
++ tapp-async tapp-async:tapp
++ stdio (^stdio out-poke-data out-peer-data)
++ ethio (^ethio out-poke-data out-peer-data)
--
::
:: Async helpers
::
=> |%
++ get-invited-by
|= [url=@t who=ship]
=/ m (async:stdio ,ship)
^- form:m
;< res=@t bind:m
%+ read-contract:ethio url
:+ `'invitedBy'
delegated-sending:contracts:azimuth
:- 'invitedBy(uint32)'
:~ [%uint `@`who]
==
%- pure:m
^- ship ^- @
%+ decode-results:abi:ethereum res
[%uint]~
::
++ get-invited
|= [url=@ta who=ship]
=/ m (async:stdio ,(list ship))
^- form:m
;< res=@t bind:m
%+ read-contract:ethio url
:+ `'getInvited'
delegated-sending:contracts:azimuth
:- 'getInvited(uint32)'
:~ [%uint `@`who]
==
%- pure:m
;; (list ship)
%+ decode-results:abi:ethereum res
[%array %uint]~
::
++ send-poke
|= [our=ship =group-action:group-store]
=/ m (async:stdio ,~)
^- form:m
%+ poke-app:stdio
[our %group-store]
[%group-action group-action]
--
::
:: Main loop
::
=> |%
++ start
|= [state=app-state our=ship]
=/ m tapp-async
^- form:m
;< inviter=ship bind:m (get-invited-by url.state our)
?: =(0 inviter)
:: we're done here, don't do anything ever again
(pure:m state)
=. inviter.state inviter
:: create the group
;< ~ bind:m (send-poke our %bundle group-path)
:: start update timer loop
;< ~ bind:m set-timer
:: go ahead and update for the first time
(update state our)
::
:: Get updates since last checked
::
++ update
|= [state=app-state our=ship]
=/ m tapp-async
^- form:m
;< invited=(list ship) bind:m (get-invited [url inviter]:state)
=/ new=(list ship)
%+ skip invited
~(has in invited.state)
;< ~ bind:m
?: =(~ new) (pure:(async:stdio ,~) ~)
(send-poke our %add (sy new) group-path)
%- pure:m
state(invited (~(gas in invited.state) new))
::
:: Set update timer
::
++ set-timer
=/ m (async:tapp ,~)
^- form:m
;< now=@da bind:m get-time:stdio
=/ next=@da (add now refresh-rate)
::NOTE we use +send-raw-card here to ensure we always set a new timer,
:: regardless of what happens further on in the flow.
(send-raw-card:stdio %wait /effect/(scot %da next) next)
+$ card card:agent:gall
--
::
:: Main
::
=* default-tapp default-tapp:tapp
%- create-tapp-all:tapp
|_ [=bowl:gall state=app-state]
++ handle-init
=/ m tapp-async
^- form:m
(start state our.bowl)
=| state=app-state
::
++ handle-take
|= =sign:tapp
=/ m tapp-async
^- form:m
?+ -.sign ~|([%strange-sign -.sign] !!)
%coup
?~ error.sign (pure:m state)
%- (slog [leaf+"pool-group-hook effect failed" u.error.sign])
(pure:m state)
%+ verb |
^- agent:gall
=<
|_ =bowl:gall
+* this .
do ~(. +> bowl)
def ~(. (default-agent this %|) bowl)
::
%wake
;< ~ bind:m
set-timer
(update state our.bowl)
++ on-init
^- (quip card _this)
=^ cards state
poll-inviter:do
[cards this]
::
++ on-save !>(state)
++ on-load
|= old=vase
^- (quip card _this)
[~ this(state !<(app-state old))]
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card agent:gall)
?. ?=([%running *] wire)
(on-agent:def wire sign)
?- -.sign
%poke-ack
?~ p.sign
[~ this]
%- (slog leaf+"{(trip dap.bowl)} couldn't start thread" u.p.sign)
:_ this(running.state ~)
~[(leave-spider:do t.wire) set-timer:do]
::
%watch-ack
?~ p.sign
[~ this]
=/ =tank leaf+"{(trip dap.bowl)} couldn't start listen to thread"
%- (slog tank u.p.sign)
[[set-timer:do]~ this(running.state ~)]
::
%kick [~ this(running.state ~)]
%fact
?+ p.cage.sign (on-agent:def wire sign)
%thread-fail
=+ !<([=term =tang] q.cage.sign)
%- (slog leaf+"{(trip dap.bowl)} failed; will retry" leaf+<term> tang)
[[set-timer:do]~ this(running.state ~)]
::
%thread-done
?+ t.wire ~|([dap.bowl %unexpected-thread-done wire] !!)
[%inviter ~]
=+ !<(res=@t q.cage.sign)
=/ inviter=ship
`@`(decode-results:abi:ethereum res [%uint]~)
:: if we weren't invited by anyone, don't do anything anymore.
::
?: =(0 inviter) [~ this(state state(running ~, inviter ~))]
=. inviter.state `inviter
=^ cards state
poll-invited:do
[cards this]
::
[%invited ~]
=+ !<(res=@t q.cage.sign)
=/ invited=(list ship)
;; (list ship)
(decode-results:abi:ethereum res [%array %uint]~)
=^ cards state
(process-invited:do invited)
[cards this(running.state ~)]
==
==
==
::
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card _this)
?+ +<.sign-arvo ~|([dap.bowl %strange-arvo-sign +<.sign-arvo] !!)
%wake
=^ cards state
?~ inviter.state
poll-inviter:do
poll-invited:do
[cards this]
==
::
++ on-poke on-poke:def
++ on-peek on-peek:def
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-fail on-fail:def
--
::
|_ =bowl:gall
++ poke-spider
|= [=path =cage]
^- card
[%pass [%running path] %agent [our.bowl %spider] %poke cage]
::
++ watch-spider
|= [=path =sub=path]
^- card
[%pass [%running path] %agent [our.bowl %spider] %watch sub-path]
::
++ leave-spider
|= [=path]
^- card
[%pass [%running path] %agent [our.bowl %spider] %leave ~]
::
++ new-tid
|= eny=@uv
^- @t
%+ scot %ta
:((cury cat 3) dap.bowl '_' (scot %uv eny))
::
++ start-contract-read
|= [=wire req=proto-read-request:rpc:ethereum]
^- (quip card _state)
=/ new-tid (new-tid eny.bowl)
=/ args
[~ `new-tid %eth-read-contract !>([url.state req])]
:_ state(running `new-tid)
:~ (watch-spider wire /thread-result/[new-tid])
(poke-spider wire %spider-start !>(args))
==
::
++ handle-poke handle-poke:default-tapp
++ handle-diff handle-diff:default-tapp
++ handle-peer handle-peer:default-tapp
++ handle-peek handle-peek:default-tapp
++ poll-inviter
^- (quip card _state)
%+ start-contract-read /inviter
:+ `'invitedBy'
delegated-sending:contracts:azimuth
:- 'invitedBy(uint32)'
:~ [%uint `@`our.bowl]
==
::
++ poll-invited
^- (quip card _state)
?~ inviter.state
~& [dap.bowl %skipping-poll-invited]
[~ state]
%+ start-contract-read /invited
:+ `'getInvited'
delegated-sending:contracts:azimuth
:- 'getInvited(uint32)'
:~ [%uint `@`u.inviter.state]
==
::
++ process-invited
|= invited=(list ship)
=/ new=(list ship)
%+ skip invited
~(has in invited.state)
:_ state(invited (~(gas in invited.state) new))
:~ set-timer
::
:* %pass
/write
%agent
[our.bowl %group-store]
%poke
%group-action
!>([%add (sy new) group-path])
==
==
::
++ set-timer
^- card
[%pass /timer %arvo %b %wait (add now.bowl refresh-rate)]
--

1075
pkg/arvo/app/publish.hoon
View File

File diff suppressed because it is too large Load Diff

385
pkg/arvo/app/send-txs.hoon
View File

@ -1,385 +0,0 @@
::
:: there's a small state machine here that goes like this (happy path):
:: =/ wen ~
:: apex
:: -> [if =(~ wen)]
:: -> apex
:: [else]
:: -> wen=`(add now ~s10)
:: -> send-next-batch
:: [n times]
:: -> eth-send-raw-transaction
:: -> sigh-send
:: -> wait 30s in behn
:: -> wake-see
:: [n times]
:: -> wen=~
:: -> eth-get-transaction-receipt
:: -> sigh-see
:: -> apex
::
|%
++ state
$: txs=(list @ux)
see=(set @ux)
wen=(unit @da)
outstanding-send=_|
==
::
++ move (pair bone card)
++ card
$% [%hiss wire ~ mark %hiss hiss:eyre]
[%info wire ship desk nori:clay]
[%rest wire @da]
[%wait wire @da]
==
--
::
|_ [bol=bowl:gall state]
::
++ this .
++ pretty-see (turn (sort (turn ~(tap in see) mug) lth) @p)
::
++ prep
|= old=(unit *)
?: ?=([~ * * ~ @da] old)
~& [%cancelling +>+>.old]
[[ost.bol %rest /see +>+>.old]~ ..prep]
[~ ..prep]
::
:: usage:
::
:: generate txs starting from nonce 0 on fake chain at 11 gwei
:: from address; store at path
:: :send-txs [%gen %/txs/eth-txs %fake 0 11 '0x0000000']
::
:: sign txs for gasses of 2 and 11 gwei; (~ for default gwei set)
:: store at path
:: :send-txs [%sign %/txs %/txs/eth-txs %/pk/txt ~[2 0]]
::
:: read nonce range from signed transactions at path
:: :send-txs [%read %txs/txt]
::
:: send all but first 50 txs from path
:: :send-txs [%send %/txs/txt 50]
::
++ poke-noun
|= $% [%sign bout=path in=path key=path gasses=(list @ud)]
::
[%read pax=path]
::
$: %send
pax=path
how=?(%nonce %number) :: tx nonce / index in file
range=(unit $@(@ud (pair @ud @ud))) :: inclusive. end optional
==
==
^- [(list move) _this]
?- +<-
%sign
:_ this
%+ turn
?. =(~ gasses) gasses
:: default gwei set
~[3 4 6 9 11 21 31]
|= gas=@ud
%+ write-file-wain
:: add gas amount to path
=+ end=(dec (lent bout))
=- (weld (scag end bout) -)
?: =(0 gas) [(snag end bout) /txt]
:_ /txt
(cat 3 (snag end bout) (crip '-' ((d-co:co 1) gas)))
::
%- sign
:+ in key
:: modify tx gas if non-zero gwei specified
?: =(0 gas) ~
`(mul gas 1.000.000.000)
::
%read
=+ tox=.^((list cord) %cx pax)
=+ [first last]=(read-nonces tox)
~& %+ weld
"Found nonces {(scow %ud first)} through {(scow %ud last)}"
" in {(scow %ud (lent tox))} transactions."
[~ this]
::
%send
~& 'loading txs...'
=. see ~
=/ tox=(list cord) .^((list cord) %cx pax)
=. tox
?~ range tox
=* r u.range
?: ?=(%number how)
?@ r
(slag r tox)
%+ slag p.r
(scag q.r tox)
=+ [first last]=(read-nonces tox)
?: !=((lent tox) +((sub last first)))
~| 'woah, probably non-contiguous set of transactions'
!!
?@ r
(slag (sub r first) tox)
(slag (sub p.r first) (scag (sub +(q.r) first) tox))
=. txs
%+ turn tox
(cork trip tape-to-ux)
~& [(lent txs) 'loaded txs']
~& [%clearing-see ~(wyt in see)]
=. see ~
=. outstanding-send |
apex
==
::
++ get-file
|= pax=path
~| pax
.^ (list cord) %cx
(weld /(scot %p our.bol)/home/(scot %da now.bol) pax)
==
::
:: sign pre-generated transactions
++ sign
=, rpc:ethereum
|= [in=path key=path gas=(unit @ud)]
^- (list cord)
?> ?=([@ @ @ *] key)
=/ pkf (get-file t.t.t.key)
?> ?=(^ pkf)
=/ pk (rash i.pkf ;~(pfix (jest '0x') hex))
=/ txs .^((list transaction) %cx in)
=/ enumerated
=/ n 1
|- ^- (list [@ud transaction])
?~ txs
~
[[n i.txs] $(n +(n), txs t.txs)]
%+ turn enumerated
|= [n=@ud tx=transaction]
~? =(0 (mod n 100)) [%signing n]
=? gas-price.tx ?=(^ gas) u.gas
(crip '0' 'x' ((x-co:co 0) (sign-transaction:key:ethereum tx pk)))
::
++ read-nonces
|= tox=(list cord)
^- [@ud @ud]
?: =(~ tox) :: not ?~ because fucking tmi
[0 0]
:- (read-nonce (snag 0 tox))
(read-nonce (snag (dec (lent tox)) tox))
::
++ read-nonce
|= tex=cord
^- @ud
::NOTE this is profoundly stupid but should work well enough
=+ (find "82" (trip tex))
?> ?=(^ -)
(rash (rsh 3 (add u 2) (end 3 (add u 6) tex)) hex)
::
++ write-file-wain
|= [pax=path tox=(list cord)]
^- move
?> ?=([@ desk @ *] pax)
:* ost.bol
%info
(weld /write pax)
our.bol
i.t.pax
=- &+[t.t.t.pax -]~
=/ y .^(arch %cy pax)
?~ fil.y
ins+txt+!>(tox)
mut+txt+!>(tox)
==
::
++ write-file-transactions
|= [pax=path tox=(list transaction:rpc:ethereum)]
^- move
?> ?=([@ desk @ *] pax)
:* ost.bol
%info
(weld /write pax)
our.bol
i.t.pax
=- &+[t.t.t.pax -]~
=/ y .^(arch %cy pax)
?~ fil.y
ins+eth-txs+!>(tox)
mut+eth-txs+!>(tox)
==
::
++ fan-requests
|= [wir=wire nodes=(list [tag=@tas url=purl:eyre]) jon=json]
:: =- ~& [batch=((list ,[bone * wire]) (turn - |=(* [- +< +>-]:+<))) jon=jon] -
^- (list move)
%+ turn nodes
|= [tag=@tas url=purl:eyre]
^- move
:- ost.bol
:^ %hiss (weld wir ~[tag]) ~
:+ %json-rpc-response %hiss
(json-request:rpc:ethereum url jon)
::
++ batch-requests
|= [wir=wire req=(list [(unit @t) request:rpc:ethereum])]
^- (list move)
%^ fan-requests
wir
:~ => (need (de-purl:html 'http://35.226.110.143:8545'))
geth+.(p.p |)
::
=> (need (de-purl:html 'http://104.198.35.227:8545'))
parity+.(p.p |)
==
a+(turn req request-to-json:rpc:ethereum)
::
++ send-next-batch
^- [(list move) _this]
?: outstanding-send
~& 'waiting for previous send to complete'
`this
?: =(0 (lent txs))
~& 'all sent!'
[~ this(txs ~, see ~, wen ~, outstanding-send |)]
:: ~& send-next-batch=pretty-see
=/ new-count (sub 500 ~(wyt in see))
?: =(0 new-count)
~& %no-new-txs-yet
`this
:_ this(txs (slag new-count txs), outstanding-send &)
~& ['remaining txs: ' (lent txs)]
~& ['sending txs...' new-count]
%+ batch-requests /send
%+ turn (scag new-count txs)
|= tx=@ux
:- `(crip 'id-' (scot %ux (end 3 10 tx)) ~)
[%eth-send-raw-transaction tx]
::
++ sigh-json-rpc-response-send
|= [wir=wire res=response:rpc:jstd]
^- [(list move) _this]
?: ?=(%fail -.res)
~& %send-failed
`this
?> ?=(%batch -.res)
:: ~& sigh-send-a=pretty-see
=. see
%- ~(uni in see)
%- silt
^- (list @ux)
%+ murn bas.res
|= r=response:rpc:jstd
^- (unit @ux)
?: ?=(%error -.r)
?: ?| =('known transaction' (end 3 17 message.r))
=('Known transaction' (end 3 17 message.r))
=('Transaction with the same ' (end 3 26 message.r))
==
~& [%sent-a-known-transaction--skipping wir]
~
?: =('Nonce too low' message.r)
~& %nonce-too-low--skipping
~
~| :- 'transaction send failed, game over'
[code.r message.r]
!!
?> ?=(%result -.r)
:- ~
%- tape-to-ux
(sa:dejs:format res.r)
=. outstanding-send |
:: ~& sigh-send-b=pretty-see
`this
::
++ apex
^- [(list move) _this]
~& :_ ~(wyt in see)
'waiting for transaction confirms... '
?. =(~ wen) [~ this]
=. wen `(add now.bol ~s30)
:: ~& apex=[wen pretty-see]
=^ moves this send-next-batch
:: timer got un-set, meaning we're done here
?~ wen [moves this]
[[[ost.bol %wait /see (need wen)] moves] this]
::
++ wake-see
|= [wir=wire ~]
^- [(list move) _this]
=. wen ~
:: ~& wake-see=[wen pretty-see]
?: =(~ see)
apex
:_ this
%+ batch-requests /see
%+ turn ~(tap in see)
|= txh=@ux
:- `(crip 'see-0x' ((x-co:co 64) txh))
[%eth-get-transaction-receipt txh]
::
++ sigh-json-rpc-response-see
|= [wir=wire res=response:rpc:jstd]
^- [(list move) _this]
?: ?| ?=(%error -.res)
?=(%fail -.res)
==
~& [%bad-rpc-response--kicking res]
apex
:: `this
?> ?=(%batch -.res)
?: =(~ see)
apex
?: =(0 (lent bas.res))
::TODO node lost our txs?
~& [%txs-lost-tmp wir '!!']
apex
:: ~& sigh-see-a=pretty-see
=. see
%- ~(dif in see)
%- silt
^- (list @ux)
%+ murn bas.res
|= r=response:rpc:jstd
^- (unit @ux)
?< ?=(%batch -.r)
?< ?=(%fail -.r)
~| [id.r res]
=+ txh=(tape-to-ux (trip (rsh 3 4 id.r)))
:: ~& see-tx=[(@p (mug txh)) `@ux`txh]
=* done `txh
=* wait ~
?: ?=(%error -.r)
~& :- 'receipt fetch error'
[code.r message.r]
wait
?~ res.r wait
?> ?=(%o -.res.r)
=/ status
%- tape-to-ux
%- sa:dejs:format
(~(got by p.res.r) 'status')
?: =(1 status)
done
~& [%see-bad-status status]
wait
:: ~& sigh-see-b=pretty-see
apex
::
++ sigh-tang
|= [wir=wire err=tang]
~& [%sigh-tang wir]
~& (slog err)
?: =(~ wen) [~ this]
=. wen `(add now.bol ~s30)
[[ost.bol %wait /see (need wen)]~ this]
::
++ tape-to-ux
|= t=tape
(scan t zero-ux)
::
++ zero-ux
;~(pfix (jest '0x') hex)
--

191
pkg/arvo/app/soto.hoon
View File

@ -3,7 +3,7 @@
:: Relays sole-effects to subscribers and forwards sole-action pokes
::
/- sole
/+ *server, *soto
/+ *server, *soto, default-agent
/= index
/^ octs
/; as-octs:mimes:html
@ -37,135 +37,96 @@
/: /===/app/soto/img /_ /png/
::
|%
+$ state
:: bon: bone from Dojo peer
::
$% [%0 bon=bone]
==
::
+$ move [bone card]
::
+$ poke
$% [%launch-action [@tas path @t]]
[%sole-action sole-action]
[%json json]
==
::
+$ card
$% [%poke wire dock poke]
[%peer wire dock path]
[%http-response =http-event:http]
[%connect wire binding:eyre term]
[%diff diff]
==
::
+$ diff
$% [%json json]
[%sole-effect sole-effect]
==
+$ card card:agent:gall
+$ state-zero ~
::
--
=| state-zero
=* state -
^- agent:gall
|_ bol=bowl:gall
+* this .
soto-core +>
sc ~(. soto-core bol)
def ~(. (default-agent this %|) bol)
::
|_ [bol=bowl:gall sta=state]
::
++ this .
::
++ prep
|= old=(unit state)
^- (quip move _this)
=/ launcha=poke
[%launch-action [%soto /sototile '/~dojo/js/tile.js']]
?~ old
:_ this
:~
[ost.bol %connect / [~ /'~dojo'] %soto]
[ost.bol %poke /soto [our.bol %launch] launcha]
==
[~ this(sta u.old)]
::
++ peer-sototile
|= wir=wire
^- (quip move _this)
++ on-init
:_ this
[ost.bol %diff %json *json]~
:~ [%pass /bind/soto %arvo %e %connect [~ /'~dojo'] %soto]
:* %pass /launch/soto %agent [our.bol %launch] %poke
%launch-action !>([%soto /sototile '/~dojo/js/tile.js'])
==
==
++ on-save !>(state)
::
:: Peering Dojo when peered by front-end, initiating the session
++ on-load
|= old=vase
[~ this(state !<(state-zero old))]
::
++ peer-primary
|= wir=wire
^- (quip move _this)
++ on-poke
|= [mar=mark vas=vase]
^- (quip card _this)
?> (team:title our.bol src.bol)
:: poke/peer need same wire
::
:_ this(bon.sta ost.bol)
[ost.bol %peer / [our.bol %dojo] /sole]~
::
++ poke-json
|= =json
^- (quip move _this)
?> (team:title our.bol src.bol)
(poke-sole-action (json-to-action json))
::
++ poke-sole-action
|= act=sole-action
^- (quip move _this)
:: poke/peer need same wire
::
?. ?=(%handle-http-request mar)
(on-poke:def mar vas)
=+ !<([id=@ta req=inbound-request:eyre] vas)
:_ this
[bon.sta %poke / [our.bol %dojo] [%sole-action act]]~
::
++ diff-sole-effect
|= [=wire fec=sole-effect]
^- (quip move _this)
:_ this
[bon.sta %diff %json (effect-to-json fec)]~
::
++ bound
|= [wir=wire success=? binding=binding:eyre]
^- (quip move _this)
[~ this]
::
++ poke-handle-http-request
%- (require-authorization:app ost.bol move this)
%+ give-simple-payload:app id
%+ require-authorization:app req
|= =inbound-request:eyre
^- (quip move _this)
^- simple-payload:http
=/ request-line (parse-request-line url.request.inbound-request)
?+ request-line
not-found:gen
:: main page
::
=+ request-line=(parse-request-line url.request.inbound-request)
=/ name=@t
=+ back-path=(flop site.request-line)
?~ back-path
''
i.back-path
?: =(name 'tile')
[[ost.bol %http-response (js-response:app tile-js)]~ this]
?+ site.request-line
:_ this
[ost.bol %http-response not-found:app]~
[[~ [%'~dojo' *]] *]
(html-response:gen index)
:: main js
::
[[[~ %js] [%'~dojo' %js %index ~]] ~]
(js-response:gen script)
:: tile js
::
[[[~ %js] [%'~dojo' %js %tile ~]] ~]
(js-response:gen tile-js)
:: styling
::
[%'~dojo' %css %index ~]
:_ this
[ost.bol %http-response (css-response:app style)]~
::
:: javascript
::
[%'~dojo' %js %index ~]
:_ this
[ost.bol %http-response (js-response:app script)]~
::
[[[~ %css] [%'~dojo' %css %index ~]] ~]
(css-response:gen style)
:: images
::
[%'~dojo' %img *]
=/ img (as-octs:mimes:html (~(got by soto-png) `@ta`name))
:_ this
[ost.bol %http-response (png-response:app img)]~
::
:: index page
::
[%'~dojo' *]
:_ this
[ost.bol %http-response (html-response:app index)]~
[[[~ %png] [%'~dojo' %img @t ~]] ~]
=/ filename=@t i.t.t.site.request-line
=/ img (~(get by soto-png) filename)
?~ img
not-found:gen
(png-response:gen (as-octs:mimes:html u.img))
==
::
++ on-watch
|= pax=path
^- (quip card _this)
?+ pax (on-watch:def pax)
[%http-response *]
[~ this]
::
[%sototile ~]
:_ this
[%give %fact ~ %json !>(~)]~
==
::
++ on-agent on-agent:def
::
++ on-arvo
|= [wir=wire sin=sign-arvo]
^- (quip card _this)
?: ?=(%bound +<.sin)
[~ this]
(on-arvo:def wir sin)
::
++ on-fail on-fail:def
++ on-leave on-leave:def
++ on-peek on-peek:def
::
--

2
pkg/arvo/app/soto/js/index.js
View File

File diff suppressed because one or more lines are too long

2
pkg/arvo/app/soto/js/tile.js
View File

File diff suppressed because one or more lines are too long

478
pkg/arvo/app/spider.hoon Normal file
View File

@ -0,0 +1,478 @@
:: Thread manager
::
/- spider
/+ libstrand=strand, default-agent, verb
=, strand=strand:libstrand
|%
+$ card card:agent:gall
+$ thread thread:spider
+$ tid tid:spider
+$ input input:spider
+$ yarn (list tid)
+$ thread-form _*eval-form:eval:(strand ,vase)
+$ trie
$~ [*thread-form ~]
[=thread-form kid=(map tid trie)]
::
+$ trying ?(%find %build %none)
+$ state
$: starting=(map yarn [=trying =vase])
running=trie
tid=(map tid yarn)
==
::
+$ clean-slate
$: starting=(map yarn [=trying =vase])
running=(list yarn)
tid=(map tid yarn)
==
::
+$ start-args
[parent=(unit tid) use=(unit tid) file=term =vase]
--
::
:: Trie operations
::
|%
++ get-yarn
|= [=trie =yarn]
^- (unit =thread-form)
?~ yarn
`thread-form.trie
=/ son (~(get by kid.trie) i.yarn)
?~ son
~
$(trie u.son, yarn t.yarn)
::
++ get-yarn-children
|= [=trie =yarn]
^- (list ^yarn)
?~ yarn
(turn (tap-yarn trie) head)
=/ son (~(get by kid.trie) i.yarn)
?~ son
~
$(trie u.son, yarn t.yarn)
::
::
++ has-yarn
|= [=trie =yarn]
!=(~ (get-yarn trie yarn))
::
++ put-yarn
|= [=trie =yarn =thread-form]
^+ trie
?~ yarn
trie(thread-form thread-form)
=/ son (~(gut by kid.trie) i.yarn [*^thread-form ~])
%= trie
kid
%+ ~(put by kid.trie) i.yarn
$(trie son, yarn t.yarn)
==
::
++ del-yarn
|= [=trie =yarn]
^+ trie
?~ yarn
trie
|-
?~ t.yarn
trie(kid (~(del by kid.trie) i.yarn))
=/ son (~(get by kid.trie) i.yarn)
?~ son
trie
%= trie
kid
%+ ~(put by kid.trie) i.yarn
$(trie u.son, yarn t.yarn)
==
::
++ tap-yarn
=| =yarn
|= =trie
^- (list [=^yarn =thread-form])
%+ welp
?~ yarn
~
[(flop yarn) thread-form.trie]~
=/ kids ~(tap by kid.trie)
|- ^- (list [=^yarn =thread-form])
?~ kids
~
=/ next-1 ^$(yarn [p.i.kids yarn], trie q.i.kids)
=/ next-2 $(kids t.kids)
(welp next-1 next-2)
--
::
^- agent:gall
=| =state
=<
%+ verb |
|_ =bowl:gall
+* this .
spider-core +>
sc ~(. spider-core bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init on-init:def
++ on-save clean-state:sc
++ on-load
|= old-state=vase
=+ !<(=clean-slate old-state)
=. tid.state tid.clean-slate
=/ yarns=(list yarn)
%+ welp running.clean-slate
~(tap in ~(key by starting.clean-slate))
|- ^- (quip card _this)
?~ yarns
`this
?. ?=([@ ~] i.yarns)
$(yarns t.yarns)
~| killing=i.yarns
=^ cards-1 state
(handle-stop-thread:sc (yarn-to-tid i.yarns) |)
=^ cards-2 this
$(yarns t.yarns)
[(weld cards-1 cards-2) this]
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?: ?=(%spider-kill mark)
(on-load on-save)
=^ cards state
?+ mark (on-poke:def mark vase)
%spider-input (on-poke-input:sc !<(input vase))
%spider-start (handle-start-thread:sc !<(start-args vase))
%spider-stop (handle-stop-thread:sc !<([tid ?] vase))
==
[cards this]
::
++ on-watch
|= =path
^- (quip card _this)
=^ cards state
?+ path (on-watch:def path)
[%thread @ *] (on-watch:sc t.path)
[%thread-result @ ~] (on-watch-result:sc i.t.path)
==
[cards this]
::
++ on-leave on-leave:def
++ on-peek
|= =path
^- (unit (unit cage))
?+ path (on-peek:def path)
[%x %tree ~]
``noun+!>((turn (tap-yarn running.state) head))
::
[%x %starting @ ~]
``noun+!>((has-yarn running.state (~(got by tid.state) i.t.t.path)))
::
[%x %saxo @ ~]
``noun+!>((~(got by tid.state) i.t.t.path))
==
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
=^ cards state
?+ wire !!
[%thread @ *] (on-agent:sc i.t.wire t.t.wire sign)
==
[cards this]
::
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card _this)
=^ cards state
?+ wire (on-arvo:def wire sign-arvo)
[%thread @ *] (handle-sign:sc i.t.wire t.t.wire sign-arvo)
[%find @ ~] (handle-find:sc i.t.wire sign-arvo)
[%build @ ~] (handle-build:sc i.t.wire sign-arvo)
==
[cards this]
:: On unexpected failure, kill all outstanding strands
::
++ on-fail
|= [=term =tang]
^- (quip card _this)
%- (slog leaf+"spider crashed, killing all strands: {<term>}" tang)
(on-load on-save)
--
::
|_ =bowl:gall
++ on-poke-input
|= input
=/ yarn (~(got by tid.state) tid)
(take-input yarn ~ %poke cage)
::
++ on-watch
|= [=tid =path]
(take-input (~(got by tid.state) tid) ~ %watch path)
::
++ on-watch-result
|= =tid
^- (quip card ^state)
`state
::
++ handle-sign
|= [=tid =wire =sign-arvo]
=/ yarn (~(get by tid.state) tid)
?~ yarn
%- (slog leaf+"spider got sign for non-existent {<tid>}" ~)
`state
(take-input u.yarn ~ %sign wire sign-arvo)
::
++ on-agent
|= [=tid =wire =sign:agent:gall]
=/ yarn (~(get by tid.state) tid)
?~ yarn
%- (slog leaf+"spider got agent for non-existent {<tid>}" ~)
`state
(take-input u.yarn ~ %agent wire sign)
::
++ handle-start-thread
|= [parent-tid=(unit tid) use=(unit tid) file=term =vase]
^- (quip card ^state)
=/ parent-yarn=yarn
?~ parent-tid
/
(~(got by tid.state) u.parent-tid)
=/ new-tid (fall use (scot %uv (sham eny.bowl)))
=/ =yarn (snoc parent-yarn new-tid)
::
?: (has-yarn running.state yarn)
~| [%already-started yarn]
!!
?: (~(has by starting.state) yarn)
~| [%already-starting yarn]
!!
::
=: starting.state (~(put by starting.state) yarn [%find vase])
tid.state (~(put by tid.state) new-tid yarn)
==
=/ =card
=/ =schematic:ford [%path [our.bowl %home] %ted file]
[%pass /find/[new-tid] %arvo %f %build live=%.n schematic]
[[card ~] state]
::
++ handle-find
|= [=tid =sign-arvo]
^- (quip card ^state)
=/ =yarn (~(got by tid.state) tid)
=. starting.state
(~(jab by starting.state) yarn |=([=trying =vase] [%none vase]))
?> ?=([%f %made *] sign-arvo)
?: ?=(%incomplete -.result.sign-arvo)
(thread-fail-not-running tid %find-thread-incomplete tang.result.sign-arvo)
=/ =build-result:ford build-result.result.sign-arvo
?: ?=(%error -.build-result)
(thread-fail-not-running tid %find-thread-error message.build-result)
?. ?=([%path *] +.build-result)
(thread-fail-not-running tid %find-thread-strange ~)
=. starting.state
(~(jab by starting.state) yarn |=([=trying =vase] [%build vase]))
=/ =card
=/ =schematic:ford [%core rail.build-result]
[%pass /build/[tid] %arvo %f %build live=%.n schematic]
[[card ~] state]
::
++ handle-build
|= [=tid =sign-arvo]
^- (quip card ^state)
=/ =yarn (~(got by tid.state) tid)
=. starting.state
(~(jab by starting.state) yarn |=([=trying =vase] [%none vase]))
?> ?=([%f %made *] sign-arvo)
?: ?=(%incomplete -.result.sign-arvo)
(thread-fail-not-running tid %build-thread-incomplete tang.result.sign-arvo)
=/ =build-result:ford build-result.result.sign-arvo
?: ?=(%error -.build-result)
(thread-fail-not-running tid %build-thread-error message.build-result)
=/ =cage (result-to-cage:ford build-result)
?. ?=(%noun p.cage)
(thread-fail-not-running tid %build-thread-strange >p.cage< ~)
=/ maybe-thread (mule |.(!<(thread q.cage)))
?: ?=(%| -.maybe-thread)
(thread-fail-not-running tid %thread-not-thread ~)
(start-thread yarn p.maybe-thread)
::
++ start-thread
|= [=yarn =thread]
^- (quip card ^state)
=/ =vase vase:(~(got by starting.state) yarn)
?< (has-yarn running.state yarn)
=/ m (strand ,^vase)
=/ res (mule |.((thread vase)))
?: ?=(%| -.res)
(thread-fail-not-running (yarn-to-tid yarn) %false-start p.res)
=/ =eval-form:eval:m
(from-form:eval:m p.res)
=: starting.state (~(del by starting.state) yarn)
running.state (put-yarn running.state yarn eval-form)
==
(take-input yarn ~)
::
++ handle-stop-thread
|= [=tid nice=?]
^- (quip card ^state)
=/ =yarn (~(got by tid.state) tid)
?: (has-yarn running.state yarn)
?: nice
(thread-done yarn *vase)
(thread-fail yarn %cancelled ~)
?: (~(has by starting.state) yarn)
(thread-fail-not-running tid %stopped-before-started ~)
~& [%thread-not-started yarn]
?: nice
(thread-done yarn *vase)
(thread-fail yarn %cancelled ~)
::
++ take-input
|= [=yarn input=(unit input:strand)]
^- (quip card ^state)
=/ m (strand ,vase)
?. (has-yarn running.state yarn)
%- (slog leaf+"spider got input for non-existent {<yarn>} 2" ~)
`state
=/ =eval-form:eval:m
thread-form:(need (get-yarn running.state yarn))
=| cards=(list card)
|- ^- (quip card ^state)
=^ r=[cards=(list card) =eval-result:eval:m] eval-form
=/ out
%- mule |.
(take:eval:m eval-form (convert-bowl yarn bowl) input)
?- -.out
%& p.out
%| [[~ [%fail %crash p.out]] eval-form]
==
=. running.state (put-yarn running.state yarn eval-form)
=/ =tid (yarn-to-tid yarn)
=. cards.r
%+ turn cards.r
|= =card
^- ^card
?+ card card
[%pass * *] [%pass [%thread tid p.card] q.card]
[%give %fact *]
?~ path.p.card
card
card(path.p `[%thread tid u.path.p.card])
::
[%give %kick *]
?~ path.p.card
card
card(path.p `[%thread tid u.path.p.card])
==
=. cards (weld cards cards.r)
=^ final-cards=(list card) state
?- -.eval-result.r
%next `state
%fail (thread-fail yarn err.eval-result.r)
%done (thread-done yarn value.eval-result.r)
==
[(weld cards final-cards) state]
::
++ thread-fail-not-running
|= [=tid =term =tang]
=/ =yarn (~(got by tid.state) tid)
:_ state(starting (~(del by starting.state) yarn))
%- welp :_ (thread-say-fail tid term tang)
=/ =trying trying:(~(got by starting.state) yarn)
?- trying
%find [%pass /find/[tid] %arvo %f %kill ~]~
%build [%pass /build/[tid] %arvo %f %kill ~]~
%none ~
==
::
++ thread-say-fail
|= [=tid =term =tang]
^- (list card)
:~ [%give %fact `/thread-result/[tid] %thread-fail !>([term tang])]
[%give %kick `/thread-result/[tid] ~]
==
::
++ thread-fail
|= [=yarn =term =tang]
^- (quip card ^state)
%- (slog leaf+"strand {<yarn>} failed" leaf+<term> tang)
=/ =tid (yarn-to-tid yarn)
=/ fail-cards (thread-say-fail tid term tang)
=^ cards state (thread-clean yarn)
[(weld fail-cards cards) state]
::
++ thread-done
|= [=yarn =vase]
^- (quip card ^state)
:: %- (slog leaf+"strand {<yarn>} finished" (sell vase) ~)
=/ =tid (yarn-to-tid yarn)
=/ done-cards=(list card)
:~ [%give %fact `/thread-result/[tid] %thread-done vase]
[%give %kick `/thread-result/[tid] ~]
==
=^ cards state (thread-clean yarn)
[(weld done-cards cards) state]
::
++ thread-clean
|= =yarn
^- (quip card ^state)
=/ children=(list ^yarn)
[yarn (get-yarn-children running.state yarn)]
|- ^- (quip card ^state)
?~ children
`state
=^ cards-children state $(children t.children)
=^ cards-our state
=/ =^yarn i.children
=/ =tid (yarn-to-tid yarn)
=: running.state (del-yarn running.state yarn)
tid.state (~(del by tid.state) tid)
==
:_ state
%+ murn ~(tap by wex.bowl)
|= [[=wire =ship =term] [acked=? =path]]
^- (unit card)
?. ?& ?=([%thread @ *] wire)
=(tid i.t.wire)
==
~
`[%pass wire %agent [ship term] %leave ~]
[(welp cards-children cards-our) state]
::
++ convert-bowl
|= [=yarn =bowl:gall]
^- bowl:spider
:* our.bowl
src.bowl
(yarn-to-tid yarn)
(yarn-to-parent yarn)
wex.bowl
sup.bowl
eny.bowl
now.bowl
byk.bowl
==
::
++ yarn-to-tid
|= =yarn
^- tid
=/ nary (flop yarn)
?> ?=([@ *] nary)
i.nary
::
++ yarn-to-parent
|= =yarn
^- (unit tid)
=/ nary (flop yarn)
?> ?=([@ *] nary)
?~ t.nary
~
`i.t.nary
::
++ clean-state
!> ^- clean-slate
state(running (turn (tap-yarn running.state) head))
--

252
pkg/arvo/app/test.hoon
View File

@ -1,6 +1,8 @@
/+ default-agent
::
|%
++ test
+$ card card:agent:gall
+$ test
$% [%arvo ~] ::UNIMPLEMENTED
[%marks ~] ::UNIMPLEMENTED
[%cores p=path]
@ -17,39 +19,98 @@
(rap 3 |-([i.b ?~(t.b ~ [a $(b t.b)])]))
::
++ fake-fcgi [%many [%blob *cred:eyre] $+[%n ~] ~]
++ build-core
|= [=disc:ford a=spur b=(list spur)]
^- card
~& >> (flop a)
:* %pass a-core+a
%arvo %f %build
live=|
^- schematic:ford
:- [%core disc %hoon a]
[%$ %cont !>(b)]
==
--
::
=, gall
=, ford
=, format
|_ {bowl $~}
^- agent:gall
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
::
++ peek _~
::
++ report-error
|= [=spur bud=build-result]
^- tang
=/ should-fail (~(get by failing) (flop spur))
?- -.bud
%success
?~ should-fail ~
:~ leaf+"warn: expected failure, {<`tape`u.should-fail>}"
leaf+"warn: built succesfully"
?: ?=(%bake +<.bud)
(sell q.cage.bud)
?> ?=(%core +<.bud)
(sell vase.bud)
==
::
%error
?^ should-fail
~[>[%failed-known `tape`(weld "TODO: " u.should-fail)]<]
(flop message.bud)
++ on-init on-init:def
++ on-save on-save:def
++ on-load on-load:def
++ on-poke
|= [=mark =vase]
:_ this
|^
=+ !<(a=test vase)
?- -.a
%arvo ~|(%stub !!) ::basically double solid?
%hoons ~&((list-hoons p.a ~) ~)
%names ~&((list-names p.a) ~)
%marks ~|(%stub !!) ::TODO restore historical handler
%renders ~&(%all-renderers-are-disabled ~)
%cores
=/ spurs [- +]:(list-hoons p.a skip=(sy /sys /ren /tests ~))
[(build-core [p q]:byk.bowl spurs) ~]
==
::
++ now-beak %_(byk.bowl r [%da now.bowl])
++ list-hoons
|= [under=path skipping=(set spur)] ^- (list spur)
=/ sup (flop under)
~& [%findining-hoons under=under]
|- ^- (list spur)
%- zing
%+ turn
=- (sort ~(tap by -) aor)
dir:.^(arch %cy (en-beam now-beak sup))
|= [a=knot ~] ^- (list spur)
=. sup [a sup]
?: (~(has in skipping) (flop sup))
~&(> [(flop sup) %out-of-scope] ~)
=/ ded (~(get by skip-completely) (flop sup))
?^ ded
~&(> [(flop sup) %skipped `tape`u.ded] ~)
?~ [fil:.^(arch %cy (en-beam now-beak [%hoon sup]))]
^$
~& (flop sup)
[sup ^$]
::
++ list-names
|= a/path ^- (list term)
=/ hon (list-hoons a ~)
%+ turn hon
|= b=spur
(join '-' (slag 1 (flop b)))
::
++ skip-completely
^~ ^- (map path tape)
%- my :~ ::TODO don't hardcode
:- /ren/run "not meant to be called except on a (different) hoon file"
:- /ren/test-gen "temporarily disabled"
==
--
::
++ made-a-core
|= [=spur @da res=made-result]
:_ +>.$
::
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-agent on-agent:def
++ on-arvo
|= [=wire =sign-arvo]
|^
:_ this
^- (list card)
?. ?=([%a-core *] wire)
(on-arvo:def wire sign-arvo)
?. ?=(%made +<.sign-arvo)
(on-arvo:def wire sign-arvo)
=/ =spur t.wire
=/ res result.sign-arvo
?: ?=([%incomplete *] res)
~& incomplete-core+spur
((slog tang.res) ~)
@ -63,108 +124,41 @@
;; [%success %$ %cont * p=(list ^spur)]
tail.build-result.res
?~ nex ~&(%cores-tested ~)
[ost (build-core nex)]~
::
++ build-core
|= [a=spur b=(list spur)]
~& >> (flop a)
:- %build
:+ a-core+a
live=|
^- schematic:ford
:- [%core now-disc %hoon a]
[%$ %cont !>(b)]
::
++ made-a-rend
|= [=spur @da res=made-result]
:_ +>.$
?> ?=([ren=term ~] spur)
=+ `[ren=term pax=path]`?~(spur !! spur)
?: ?=([%incomplete *] res)
~& incomplete-core+spur
((slog tang.res) ~)
?. ?=([%complete %success *] res)
~& unsuccessful-core+spur
((slog message.build-result.res) ~)
?> ?=(^ +<.build-result.res)
%- (slog (report-error /[ren]/ren head.build-result.res))
=/ nex=(list term)
=< p
;; [%success %$ %cont * p=(list term)]
tail.build-result.res
?~ nex ~&(%rens-tested ~)
[ost (build-rend nex)]~
::
++ build-rend
|= [a=term b=(list term)]
~& >> [%ren a]
:- %build
:+ a-rend+/[a]
live=|
^- schematic:ford
=/ bem=beam (need (de-beam %/example))
=/ =rail [[p q] s]:bem
:- [%bake a fake-fcgi rail]
[%$ %cont !>(b)]
::
++ poke-noun
|= a=test
:_ +>
?- -.a
%arvo ~|(%stub !!) ::basically double solid?
%hoons ~&((list-hoons p.a ~) ~)
%cores [ost (build-core [- +]:(list-hoons p.a skip=(sy /sys /ren /tests ~)))]~
%names ~&((list-names p.a) ~)
%marks ~|(%stub !!) ::TODO restore historical handler
%renders ~&(%all-renderers-are-disabled ~)
==
::
++ list-names
|= a/path ^- (list term)
=/ hon (list-hoons a ~)
%+ turn hon
|= b=spur
(join '-' (slag 1 (flop b)))
::
++ list-hoons
|= [under=path skipping=(set spur)] ^- (list spur)
=/ sup (flop under)
~& [%findining-hoons under=under]
|- ^- (list spur)
%- zing
%+ turn
=- (sort ~(tap by -) aor)
dir:.^(arch %cy (en-beam now-beak sup))
|= [a=knot ~] ^- (list spur)
=. sup [a sup]
?: (~(has in skipping) (flop sup))
~&(> [(flop sup) %out-of-scope] ~)
=/ ded (~(get by skip-completely) (flop sup))
?^ ded
~&(> [(flop sup) %skipped `tape`u.ded] ~)
?~ [fil:.^(arch %cy (en-beam now-beak [%hoon sup]))]
^$
~& (flop sup)
[sup ^$]
::
++ now-beak %_(byk r [%da now])
++ now-disc `disc:ford`[p.byk q.byk]
++ skip-completely
^~ ^- (map path tape)
%- my :~ ::TODO don't hardcode
:- /ren/run "not meant to be called except on a (different) hoon file"
:- /ren/test-gen "temporarily disabled"
==
::
++ failing
^~ ^- (map path tape)
%- my :~ ::TODO don't hardcode
[(build-core [p q]:byk.bowl nex) ~]
::
:- /gen/al "compiler types out-of-date"
:- /gen/musk "compiler types out-of-date"
++ report-error
|= [=spur bud=build-result]
^- tang
=/ should-fail (~(get by failing) (flop spur))
?- -.bud
%success
?~ should-fail ~
:~ leaf+"warn: expected failure, {<`tape`u.should-fail>}"
leaf+"warn: built succesfully"
?: ?=(%bake +<.bud)
(sell q.cage.bud)
?> ?=(%core +<.bud)
(sell vase.bud)
==
::
%error
?^ should-fail
~[>[%failed-known `tape`(weld "TODO: " u.should-fail)]<]
(flop message.bud)
==
::
:- /gen/cosmetic "incomplete"
:- /gen/lust "incomplete"
:- /gen/scantastic "incomplete"
==
++ failing
^~ ^- (map path tape)
%- my :~ ::TODO don't hardcode
::
:- /gen/al "compiler types out-of-date"
:- /gen/musk "compiler types out-of-date"
::
:- /gen/cosmetic "incomplete"
:- /gen/lust "incomplete"
:- /gen/scantastic "incomplete"
==
--
::
++ on-fail on-fail:def
--

23
pkg/arvo/app/time.hoon
View File

@ -1,23 +0,0 @@
::
:::: /hoon/time/app
::
/? 310
|%
++ card {$wait wire @da}
--
|_ {bowl:gall ~}
++ poke-noun
|= *
:_ +>.$ :_ ~
[ost %wait /(scot %da now) +(now)]
::
++ wake
|= {wir/wire error=(unit tang)}
?> ?=({@ ~} wir)
?^ error
%- (slog u.error)
~& %time-behn-failed
[~ +>.$]
~& [%took `@dr`(sub now (slav %da i.wir))]
[~ +>.$]
--

205
pkg/arvo/app/weather.hoon
View File

@ -1,4 +1,4 @@
/+ *server
/+ *server, *server, default-agent
/= tile-js
/^ octs
/; as-octs:mimes:html
@ -12,127 +12,139 @@
=, format
::
|%
:: +move: output effect
::
+$ move [bone card]
:: +card: output effect payload
::
+$ card
$% [%poke wire dock poke]
[%http-response =http-event:http]
[%diff %json json]
[%connect wire binding:eyre term]
[%request wire request:http outbound-config:iris]
[%wait wire @da]
==
+$ poke
$% [%launch-action [@tas path @t]]
==
+$ state
$% [%0 data=json time=@da location=@t timer=(unit @da)]
+$ card card:agent:gall
+$ versioned-state
$% state-zero
==
+$ state-zero [%0 data=json time=@da location=@t timer=(unit @da)]
--
=| state-zero
=* state -
^- agent:gall
=<
|_ bol=bowl:gall
+* this .
weather-core +>
wc ~(. weather-core bol)
def ~(. (default-agent this %|) bol)
++ on-init
:_ this
:~ [%pass /bind/weather %arvo %e %connect [~ /'~weather'] %weather]
:* %pass /launch/weather %agent [our.bol %launch] %poke
%launch-action !>([%weather /weathertile '/~weather/js/tile.js'])
==
==
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(state-zero old))
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
=^ cards state
?+ mark (on-poke:def mark vase)
%json
(poke-json:wc !<(json vase))
%handle-http-request
=+ !<([eyre-id=@ta =inbound-request:eyre] vase)
:_ state
%+ give-simple-payload:app eyre-id
%+ require-authorization:app inbound-request
poke-handle-http-request:wc
==
[cards this]
::
++ on-watch
|= =wire
^- (quip card _this)
?: ?=([%weathertile ~] wire)
:_ this
[%give %fact ~ %json !>(data)]~
?: ?=([%http-response *] wire)
[~ this]
(on-watch:def wire)
::
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card:agent:gall _this)
?: ?=(%bound +<.sign-arvo)
[~ this]
?: ?=(%wake +<.sign-arvo)
=^ cards state
(wake:wc wire error.sign-arvo)
[cards this]
?: ?=(%http-response +<.sign-arvo)
=^ cards state
(http-response:wc wire client-response.sign-arvo)
[cards this]
(on-arvo:def wire sign-arvo)
::
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-agent on-agent:def
++ on-fail on-fail:def
--
::
|_ [bol=bowl:gall state]
::
++ this .
::
++ bound
|= [wir=wire success=? binding=binding:eyre]
^- (quip move _this)
[~ this]
::
++ prep
|= old=(unit state)
^- (quip move _this)
=/ launcha
[%launch-action [%weather /weathertile '/~weather/js/tile.js']]
:-
:~
[ost.bol %connect / [~ /'~weather'] %weather]
[ost.bol %poke /weather [our.bol %launch] launcha]
==
?~ old
this
%= this
data data.u.old
time time.u.old
==
::
++ peer-weathertile
|= pax=path
^- (quip move _this)
[[ost.bol %diff %json data]~ this]
|_ bol=bowl:gall
::
++ poke-json
|= jon=json
^- (quip move _this)
^- (quip card _state)
?. ?=(%s -.jon)
[~ this]
=/ str/@t +.jon
=/ req/request:http (request-darksky str)
[~ state]
=/ str=@t +.jon
=/ req=request:http (request-darksky str)
=/ out *outbound-config:iris
=/ lismov [ost.bol %request /[(scot %da now.bol)] req out]~
=/ lismov [%pass /[(scot %da now.bol)] %arvo %i %request req out]~
?~ timer
:- [[ost.bol %wait /timer (add now.bol ~h3)] lismov]
%= this
:- [[%pass /timer %arvo %b %wait (add now.bol ~h3)] lismov]
%= state
location str
timer `(add now.bol ~h3)
timer `(add now.bol ~h3)
==
:- lismov
%= this
location str
==
[lismov state(location str)]
::
++ request-darksky
|= location=@t
^- request:http
=/ base
"https://api.darksky.net/forecast/634639c10670c7376dc66b6692fe57ca/"
=/ url/@t %- crip
:(weld base (trip location) "?units=auto")
=/ base 'https://api.darksky.net/forecast/634639c10670c7376dc66b6692fe57ca/'
=/ url=@t (cat 3 (cat 3 base location) '?units=auto')
=/ hed [['Accept' 'application/json']]~
[%'GET' url hed *(unit octs)]
::
++ send-tile-diff
|= jon=json
^- (list move)
%+ turn (prey:pubsub:userlib /weathertile bol)
|= [=bone ^]
[bone %diff %json jon]
::
++ http-response
|= [=wire response=client-response:iris]
^- (quip move _this)
^- (quip card _state)
:: ignore all but %finished
?. ?=(%finished -.response)
[~ this]
=/ data/(unit mime-data:iris) full-file.response
[~ state]
=/ data=(unit mime-data:iris) full-file.response
?~ data
:: data is null
[~ this]
=/ ujon/(unit json) (de-json:html q.data.u.data)
[~ state]
=/ ujon=(unit json) (de-json:html q.data.u.data)
?~ ujon
[~ this]
[~ state]
?> ?=(%o -.u.ujon)
?: (gth 200 status-code.response-header.response)
~& weather+u.ujon
~& weather+location
[~ this]
=/ jon/json %- pairs:enjs:format :~
[~ state]
=/ jon=json %- pairs:enjs:format :~
currently+(~(got by p.u.ujon) 'currently')
daily+(~(got by p.u.ujon) 'daily')
==
:- (send-tile-diff jon)
%= this
:- [%give %fact `/weathertile %json !>(jon)]~
%= state
data jon
time now.bol
==
::
++ poke-handle-http-request
%- (require-authorization:app ost.bol move this)
|= =inbound-request:eyre
^- (quip move _this)
^- simple-payload:http
::
=/ request-line (parse-request-line url.request.inbound-request)
=/ back-path (flop site.request-line)
=/ name=@t
@ -142,28 +154,27 @@
i.back-path
::
?~ back-path
:_ this ~
not-found:gen
?: =(name 'tile')
[[ost.bol %http-response (js-response:app tile-js)]~ this]
(js-response:gen tile-js)
?: (lte (lent back-path) 1)
[[ost.bol %http-response not-found:app]~ this]
not-found:gen
?: =(&2:site.request-line 'img')
=/ img (as-octs:mimes:html (~(got by weather-png) `@ta`name))
[[ost.bol %http-response (png-response:app img)]~ this]
[~ this]
(png-response:gen img)
not-found:gen
::
++ wake
|= [wir=wire err=(unit tang)]
^- (quip move _this)
^- (quip card _state)
?~ err
=/ req/request:http (request-darksky location)
=/ out *outbound-config:iris
:_ this(timer `(add now.bol ~h3))
:~
[ost.bol %request /[(scot %da now.bol)] req out]
[ost.bol %wait /timer (add now.bol ~h3)]
:_ state(timer `(add now.bol ~h3))
:~ [%pass /[(scot %da now.bol)] %arvo %i %request req out]
[%pass /timer %arvo %b %wait (add now.bol ~h3)]
==
~& err
[~ this]
%- (slog u.err)
[~ state]
::
--

6
pkg/arvo/gen/aqua/file.hoon
View File

@ -1,9 +1,11 @@
/- aquarium
=, aquarium
:- %say
|= [* [her=ship pax=path] ~]
|= [* [her=ship pax=path ~] ~]
:- %aqua-events :_ ~
^- aqua-event:aquarium
:+ %event her
?> ?=([@ @ @ *] pax)
=/ file [/text/plain (as-octs:mimes:html .^(@ %cx pax))]
[//sync/0v1n.2m9vh %into i.t.pax | [t.t.t.pax `file]~]~
:- //sync/0v1n.2m9vh
[%into `desk`i.t.pax | `mode:clay`[t.t.t.pax `file]~]

9
pkg/arvo/gen/azimuth-block.hoon Normal file
View File

@ -0,0 +1,9 @@
:: Print most recently seen ethereum block
::
:: Note we require 30 confirmation blocks, so we should expect to have
:: processed only those blocks which are this number minus 30.
::
:- %say
|= [[now=@da *] *]
:- %tang
[>.^(@ud %gx /=eth-watcher/(scot %da now)/block/azimuth-tracker/noun)< ~]

3
pkg/arvo/gen/azimuth-tracker/kick.hoon Normal file
View File

@ -0,0 +1,3 @@
:- %say
|= *
[%azimuth-tracker-poke %listen ~ %| %azimuth-tracker]

13
pkg/arvo/gen/hood/ames-verb.hoon Normal file
View File

@ -0,0 +1,13 @@
:: Helm: Adjust Ames verbosity
::
:: List of diagnostic flags is in verb:ames in zuse.hoon, documented in
:: ames.hoon
::
/? 310
::
::::
::
:- %say
|= [^ veb=(list verb:ames) ~]
:- %helm-ames-verb
veb

7
pkg/arvo/gen/hood/bonk.hoon
View File

@ -1,7 +0,0 @@
:: Helm: bonk ames
::
:::: /hoon/bonk/hood/gen
::
/? 310
:- %say
|=({^ ~ ~} helm-bonk+~)

7
pkg/arvo/gen/hood/cancel.hoon
View File

@ -7,8 +7,5 @@
::::
::
:- %say
|= $: {now/@da eny/@uvJ bec/beak}
{{syd/@tas ~} ~}
==
:- %kiln-cancel
syd
|= *
[%kiln-cancel ~]

2
pkg/arvo/gen/hood/load.hoon
View File

@ -12,4 +12,4 @@
==
:- %hood-load
~| %hood-load-stub
!!
!!

13
pkg/arvo/gen/hood/pack.hoon Normal file
View File

@ -0,0 +1,13 @@
:: Helm: compact memory
::
:::: /hoon/pack/hood/gen
::
/? 310
::
::::
::
:- %say
|= $: {now/@da eny/@uvJ bec/beak}
{arg/~ ~}
==
[%helm-pack ~]

8
pkg/arvo/gen/keys.hoon Normal file
View File

@ -0,0 +1,8 @@
:: Print keys for a ship
::
:- %say
|= [[now=time *] [=ship ~] ~]
:* %noun
life=.^((unit @ud) %j /=lyfe/(scot %da now)/(scot %p ship))
rift=.^((unit @ud) %j /=ryft/(scot %da now)/(scot %p ship))
==

8
pkg/arvo/gen/publish/serve.hoon Normal file
View File

@ -0,0 +1,8 @@
:: serve a notebook in your filesystem
::
:- %say
|= $: [now=@da eny=@uvJ =beak]
[[name=term ~] ~]
==
:- %publish-action
[%serve name]

1
pkg/arvo/gen/publish/subscribe.hoon
View File

@ -6,4 +6,3 @@
==
:- %publish-action
[%subscribe ship name]

3
pkg/arvo/gen/spider/kill.hoon Normal file
View File

@ -0,0 +1,3 @@
:- %say
|= *
[%spider-kill ~]

3
pkg/arvo/gen/spider/poke.hoon Normal file
View File

@ -0,0 +1,3 @@
:- %say
|= [* [=@ta =mark =vase ~] ~]
[%spider-input ta mark vase]

3
pkg/arvo/gen/spider/start.hoon Normal file
View File

@ -0,0 +1,3 @@
:- %say
|= [* [name=term vase=$@(~ [vase ~])] ~]
[%spider-start ~ ~ name ?~(vase *^vase -.vase)]

3
pkg/arvo/gen/spider/stop.hoon Normal file
View File

@ -0,0 +1,3 @@
:- %say
|= [* [tid=@ta ~] ~]
[%spider-stop tid |]

9
pkg/arvo/gen/spider/tree.hoon Normal file
View File

@ -0,0 +1,9 @@
/- spider
:- %say
|= [[now=@da *] ~ *]
:- %tang
=/ tree
.^((list (list tid:spider)) %gx /=spider/(scot %da now)/tree/noun)
%+ turn tree
|= yarn=(list tid:spider)
>`path`yarn<

3
pkg/arvo/gen/tapp-admin/cancel.hoon
View File

@ -1,3 +0,0 @@
:- %say
|= [[now=@da eny=@uvJ bec=beak] ~ ~]
[%tapp-admin %cancel]

3
pkg/arvo/gen/tapp-admin/restart.hoon
View File

@ -1,3 +0,0 @@
:- %say
|= [[now=@da eny=@uvJ bec=beak] ~ ~]
[%tapp-admin %restart]

4
pkg/arvo/gen/timers.hoon Normal file
View File

@ -0,0 +1,4 @@
:- %say
|= *
:- %tang
[.^(tank %b %) ~]

12
pkg/arvo/gen/trouble.hoon
View File

@ -1,3 +1,5 @@
:: Print useful diagnostic information
::
:- %say
|= [[now=time * bec=beak] ~ ~]
=* our p.bec
@ -24,14 +26,18 @@
=/ o=@ta (scot %p our)
=/ n=@ta (scot %da now)
?~ b ~[o a n]
~[o a n (scot %p u.b)]
~[o a n (scot %p u.b)]
::
++ info
|= [=term =ship]
:: unitized life and rift
=/ lyfe .^((unit @ud) %j (pathify ~.lyfe `ship))
=/ ryft .^((unit @ud) %j (pathify ~.ryft `ship))
:* term
ship=ship
point=(crip (slag 2 (scow %ui ship)))
life=.^(* %j (pathify ~.life `ship))
rift=.^(* %j (pathify ~.rift `ship))
:: report as units
life=lyfe
rift=ryft
==
--

7
pkg/arvo/gen/verb.hoon Normal file
View File

@ -0,0 +1,7 @@
:: Tell app to print what it's doing
::
:: For apps that use lib/verb, :app +verb toggles verbosity.
::
:- %say
|= [* arg=?(~ [%bowl ~]) ~]
[%verb ?~(arg %loud %bowl)]

67
pkg/arvo/lib/aqua-vane-thread.hoon Normal file
View File

@ -0,0 +1,67 @@
/- spider, *aquarium
/+ ph-io, strandio
=, strand=strand:spider
|%
++ vane-handler
$_ ^|
|_ bowl:spider
++ handle-unix-effect
|~ [ship unix-effect]
*(quip card:agent:gall _^|(..handle-unix-effect))
::
++ handle-arvo-response
|~ [wire sign-arvo]
*(quip card:agent:gall _^|(..handle-unix-effect))
--
--
::
=; core
|= [effect-filter=(list term) handler=vane-handler]
^- thread:spider
|= vase
=/ m (strand ,vase)
^- form:m
=* loop $
?^ effect-filter
=/ =path /effect/[i.effect-filter]
;< ~ bind:m (watch-our:strandio path %aqua path)
loop(effect-filter t.effect-filter)
;< ~ bind:m
%- (main-loop:strandio ,_handler)
:~ handle-unix-effect:core
handle-arvo-response:core
pure:(strand ,vane-handler)
==
(pure:m *vase)
::
|%
++ handle-unix-effect
|= handler=vane-handler
=/ m (strand ,vane-handler)
^- form:m
;< [her=ship =unix-effect] bind:m
((handle:strandio ,[ship unix-effect]) take-unix-effect:ph-io)
;< =bowl:spider bind:m get-bowl:strandio
=^ cards handler
(~(handle-unix-effect handler bowl) her unix-effect)
?~ cards
(pure:m handler)
:: send in next event to avoid inverting subscription flow. real
:: solution is probably for gall to drip subscription updates.
::
;< ~ bind:m (sleep:strandio ~s0)
;< ~ bind:m (send-raw-cards:strandio cards)
(pure:m handler)
::
++ handle-arvo-response
|= handler=vane-handler
=/ m (strand ,vane-handler)
^- form:m
;< [=wire =sign-arvo] bind:m
((handle:strandio ,[wire sign-arvo]) take-sign-arvo:strandio)
;< =bowl:spider bind:m get-bowl:strandio
=^ cards handler
(~(handle-arvo-response handler bowl) wire sign-arvo)
;< ~ bind:m (send-raw-cards:strandio cards)
(pure:m handler)
--

204
pkg/arvo/lib/async.hoon
View File

@ -1,204 +0,0 @@
|* [input-type=mold card-type=mold contract-type=mold]
|%
+$ async-input [=bowl:gall in=(unit [=wire sign=input-type])]
+$ async-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
::
+$ contract-delta
$% [%gain =bone]
[%lose ~]
==
::
++ async-output-raw
|* a=mold
$~ [~ ~ ~ %done *a]
$: cards=(list card-type)
effects=(list async-move)
contracts=(map contract-type contract-delta)
$= next
$% [%wait ~]
[%cont self=(async-form-raw a)]
[%fail err=(pair term tang)]
[%done value=a]
==
==
::
++ async-form-raw
|* a=mold
$-(async-input (async-output-raw a))
::
:: Abort asynchronous computation with error message
::
++ async-fail
|= err=(pair term tang)
|= async-input
[~ ~ ~ %fail err]
::
:: Asynchronous transcaction monad.
::
:: Combo of four monads:
:: - Reader on input-type
:: - Writer on card-type
:: - Continuation
:: - Exception
::
++ async
|* a=mold
|%
++ output (async-output-raw a)
::
:: Type of an asynchronous computation.
::
++ form (async-form-raw a)
::
:: Monadic pure. Identity computation for bind.
::
++ pure
|= arg=a
^- form
|= async-input
[~ ~ ~ %done arg]
::
:: Monadic bind. Combines two computations, associatively.
::
++ bind
|* b=mold
|= [m-b=(async-form-raw b) fun=$-(b form)]
^- form
|= input=async-input
=/ b-res=(async-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 async monad must be evaluted in a particular way to maintain
:: its monadic character. +take:eval implements this.
::
++ eval
|%
:: Indelible state of a async
::
+$ eval-form
$: effects=(list async-move)
contracts=(map contract-type bone)
=form
==
::
:: Convert initial form to eval-form
::
++ from-form
|= =form
^- eval-form
[~ ~ form]
::
:: The cases of results of +take
::
+$ eval-result
$% [%next ~]
[%fail contracts=(map contract-type bone) err=(pair term tang)]
[%done contracts=(map contract-type bone) value=a]
==
::
:: Take a new sign and run the async against it
::
++ take
:: moves: accumulate throughout recursion the moves to be
:: produced now
=| moves=(list async-move)
|= [=eval-form =bone =async-input]
^- [[(list async-move) =eval-result] _eval-form]
=* take-loop $
:: run the async callback
::
=/ =output (form.eval-form async-input)
:: add cards to moves
::
=. moves
%+ welp
moves
%+ turn cards.output
|= card=card-type
^- async-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 [contract=contract-type delta=contract-delta])
~(tap by contracts.output)
|- ^+ loop-result
=* loop $
?~ new
loop-result
=/ exists=?
(~(has by contracts.eval-form) contract.i.new)
?- -.delta.i.new
:: add contract and bone
::
%gain
?: exists
%= loop-result
next.output [%fail %contract-already-exists >contract.i.new< ~]
==
%= loop
contracts.eval-form (~(put by contracts.eval-form) [contract bone.delta]:i.new)
new t.new
==
:: remove contract
::
%lose
?: exists
%= loop
contracts.eval-form (~(del by 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
async-input [bowl.async-input ~]
==
==
--
--
--

145
pkg/arvo/lib/azimuth.hoon Normal file
View File

@ -0,0 +1,145 @@
/+ strandio
=, strand=strand:strandio
=, able:jael
|%
++ tract azimuth:contracts:azimuth
++ fetch-point
|= [url=@ta who=ship]
=/ m (strand ,point:azimuth)
^- form:m
=/ =request:rpc:ethereum
:+ %eth-call
=- [from=~ to=tract gas=~ price=~ value=~ data=-]
(encode-call:rpc:ethereum 'points(uint32)' [%uint `@`who]~)
[%label %latest]
;< jon=json bind:m (request-rpc url `'point' request)
=/ res=cord (so:dejs:format jon)
=/ =point:eth-noun:azimuth
(decode-results:abi:ethereum res point:eth-type:azimuth)
::
=/ =request:rpc:ethereum
:+ %eth-call
=- [from=~ to=tract gas=~ price=~ value=~ data=-]
(encode-call:rpc:ethereum 'rights(uint32)' [%uint `@`who]~)
[%label %latest]
;< jon=json bind:m (request-rpc url `'deed' request)
=/ res=cord (so:dejs:format jon)
=/ =deed:eth-noun:azimuth
(decode-results:abi:ethereum res deed:eth-type:azimuth)
::
(pure:m (point-from-eth:azimuth who point deed))
::
++ request-rpc
|= [url=@ta id=(unit @t) req=request:rpc:ethereum]
=/ m (strand ,json)
^- form:m
%+ (retry json) `10
=/ m (strand ,(unit json))
^- form:m
|^
=/ =request:http
:* method=%'POST'
url=url
header-list=['Content-Type'^'application/json' ~]
^= body
%- some %- as-octt:mimes:html
%- en-json:html
(request-to-json:rpc:ethereum id req)
==
;< ~ bind:m (send-request:strandio request)
;< rep=(unit client-response:iris) bind:m
take-maybe-response:strandio
?~ rep
(pure:m ~)
(parse-response u.rep)
::
++ parse-response
|= =client-response:iris
=/ m (strand ,(unit json))
^- form:m
?> ?=(%finished -.client-response)
?~ full-file.client-response
(pure:m ~)
=/ body=@t q.data.u.full-file.client-response
=/ jon=(unit json) (de-json:html body)
?~ jon
(pure:m ~)
=, dejs-soft:format
=/ array=(unit (list response:rpc:jstd))
((ar parse-one-response) u.jon)
?~ array
=/ res=(unit response:rpc:jstd) (parse-one-response u.jon)
?~ res
(strand-fail:strandio %request-rpc-parse-error >id< ~)
?: ?=(%error -.u.res)
(strand-fail:strandio %request-rpc-error >id< >+.res< ~)
?. ?=(%result -.u.res)
(strand-fail:strandio %request-rpc-fail >u.res< ~)
(pure:m `res.u.res)
(strand-fail:strandio %request-rpc-batch >%not-implemented< ~)
:: (pure:m `[%batch u.array])
::
++ parse-one-response
|= =json
^- (unit response:rpc:jstd)
=/ res=(unit [@t ^json])
%. json
=, dejs-soft:format
(ot id+so result+some ~)
?^ res `[%result u.res]
~| parse-one-response=json
:+ ~ %error %- need
%. json
=, dejs-soft:format
(ot id+so error+(ot code+no message+so ~) ~)
--
::
++ 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:strandio %retry-too-many ~)
;< ~ bind:m (backoff:strandio try ~m1)
;< res=(unit result) bind:m computation
?^ res
(pure:m u.res)
loop(try +(try))
::
++ get-latest-block
|= url=@ta
=/ m (strand ,block)
^- form:m
;< =json bind:m (request-rpc url `'block number' %eth-block-number ~)
(get-block-by-number url (parse-eth-block-number:rpc:ethereum json))
::
++ get-block-by-number
|= [url=@ta =number:block]
=/ m (strand ,block)
^- form:m
|^
;< =json bind:m
(request-rpc url `'block by number' %eth-get-block-by-number number |)
=/ =block (parse-block json)
?. =(number number.id.block)
(strand-fail:strandio %reorg-detected >number< >block< ~)
(pure:m block)
::
++ parse-block
|= =json
^- block
=< [[&1 &2] |2]
^- [@ @ @]
~| json
%. json
=, dejs:format
%- ot
:~ hash+parse-hex-result:rpc:ethereum
number+parse-hex-result:rpc:ethereum
'parentHash'^parse-hex-result:rpc:ethereum
==
--
--

43
pkg/arvo/lib/chat-json.hoon
View File

@ -118,25 +118,6 @@
[%config (conf config.mailbox)]
==
::
++ two-update-to-json
|= upd=chat-two-update
=, enjs:format
^- json
%+ frond %chat-update
%- pairs
:~
?: =(%messages -.upd)
?> ?=(%messages -.upd)
:- %messages
%- pairs
:~ [%path (path path.upd)]
[%start (numb start.upd)]
[%end (numb end.upd)]
[%envelopes [%a (turn envelopes.upd enve)]]
==
[*@t *^json]
==
::
++ update-to-json
|= upd=chat-update
=, enjs:format
@ -144,28 +125,31 @@
%+ frond %chat-update
%- pairs
:~
?: =(%message -.upd)
?> ?=(%message -.upd)
?: ?=(%message -.upd)
:- %message
%- pairs
:~ [%path (path path.upd)]
[%envelope (enve envelope.upd)]
==
?: =(%read -.upd)
?> ?=(%read -.upd)
?: ?=(%messages -.upd)
:- %messages
%- pairs
:~ [%path (path path.upd)]
[%start (numb start.upd)]
[%end (numb end.upd)]
[%envelopes [%a (turn envelopes.upd enve)]]
==
?: ?=(%read -.upd)
[%read (pairs [%path (path path.upd)]~)]
?: =(%create -.upd)
?> ?=(%create -.upd)
?: ?=(%create -.upd)
:- %create
%- pairs
:~ [%ship (ship ship.upd)]
[%path (path path.upd)]
==
?: =(%delete -.upd)
?> ?=(%delete -.upd)
?: ?=(%delete -.upd)
[%delete (pairs [%path (path path.upd)]~)]
?: =(%config -.upd)
?> ?=(%config -.upd)
?: ?=(%config -.upd)
:- %config
%- pairs
:~ [%path (path path.upd)]
@ -270,4 +254,3 @@
(su (perk %channel %village %journal %mailbox ~))
--
--

81
pkg/arvo/lib/csv.hoon Normal file
View File

@ -0,0 +1,81 @@
:: Parse CSV files with a known schema, then perform queries on the
:: results.
::
|%
++ text
%+ cook
|= =tape
(crip tape)
;~ pose
(cook tape soil:vast)
non-quote-text
==
::
++ non-quote-text
(star ;~(less com qit))
::
++ parse
|* cols=(list rule)
%+ ifix
:- ;~(sfix ;~(less (just `@`10) (star prn)) (just `@`10))
(just `@`10)
(more (just `@`10) (parse-line cols))
::
++ parse-line
|* cols=(list rule)
?~ cols
(easy ~)
?~ t.cols
i.cols
;~ plug
i.cols
;~(pfix com $(cols t.cols))
==
::
:: inner join
::
++ join
=/ name-side (ream '[left=- right=+]')
|= [left=(list vase) rite=(list vase) =hoon]
^- (list vase)
|- ^- (list vase)
=* left-loop $
?~ left
~
=/ rote rite
|- ^- (list vase)
=* rite-loop $
?~ rite
left-loop(left t.left, rite rote)
=/ slopped-row (slap (slop i.left i.rite) name-side)
=/ val (slap (slop slopped-row !>(..zuse)) hoon)
?. =(%& q.val)
rite-loop(rite t.rite)
:- slopped-row
rite-loop(rite t.rite)
::
:: filter
::
++ where
|= [rows=(list vase) =hoon]
^- (list vase)
%+ skim rows
|= =vase
=/ val (slap vase hoon)
=(%& q.val)
::
:: select
::
++ select
|= [=hoon rows=(list vase)]
^- (list vase)
%+ turn rows
|= =vase
(slap (slop vase !>(..zuse)) hoon)
::
:: pretty-print rows
::
++ print-rows
|= rows=(list vase)
(slog (turn rows sell))
--

69
pkg/arvo/lib/default-agent.hoon Normal file
View File

@ -0,0 +1,69 @@
/+ skeleton
|* [agent=* help=*]
?: ?=(%& help)
~| %default-agent-helpfully-crashing
skeleton
|_ =bowl:gall
++ on-init
`agent
::
++ on-save
!>(~)
::
++ on-load
|= old-state=vase
`agent
::
++ on-poke
|= =cage
~| "unexpected poke to {<dap.bowl>} with mark {<p.cage>}"
!!
::
++ on-watch
|= =path
~| "unexpected subscription to {<dap.bowl>} on path {<path>}"
!!
::
++ on-leave
|= path
`agent
::
++ on-peek
|= =path
~| "unexpected scry into {<dap.bowl>} on path {<path>}"
!!
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card:agent:gall _agent)
?- -.sign
%poke-ack
?~ p.sign
`agent
%- (slog leaf+"poke failed from {<dap.bowl>} on wire {<wire>}" u.p.sign)
`agent
::
%watch-ack
?~ p.sign
`agent
=/ =tank leaf+"subscribe failed from {<dap.bowl>} on wire {<wire>}"
%- (slog tank u.p.sign)
`agent
::
%kick `agent
%fact
~| "unexpected subscription update to {<dap.bowl>} on wire {<wire>}"
~| "with mark {<p.cage.sign>}"
!!
==
::
++ on-arvo
|= [=wire =sign-arvo]
~| "unexpected system response {<-.sign-arvo>} to {<dap.bowl>} on wire {<wire>}"
!!
::
++ on-fail
|= [=term =tang]
%- (slog leaf+"error in {<dap.bowl>}" >term< tang)
`agent
--

47
pkg/arvo/lib/dns.hoon Normal file
View File

@ -0,0 +1,47 @@
/+ strandio
=, strand=strand:strandio
|%
:: +turf-confirm-install: self check and install domain
::
++ turf-confirm-install
|= =turf
=/ m (strand ,?)
^- form:m
;< good=? bind:m (self-check-http &+turf 5)
?. good
(pure:m |)
;< ~ bind:m (install-domain:strandio turf)
(pure:m &)
::
:: +self-check-http: confirm our availability at .host on port 80
::
:: XX needs better success/failure predicates
:: XX bind route to self and handle request inside tx?
::
++ self-check-http
|= [=host:eyre max=@ud]
=/ m (strand ,?)
^- form:m
:: XX also scry into eyre
:: q:.^(hart:eyre %e /(scot %p our)/host/real)
=/ =hiss:eyre
=/ url=purl:eyre
[[sec=| por=~ host] [ext=`~.udon path=/static] query=~]
[url %get ~ ~]
=/ try=@ud 0
|- ^- form:m
=* loop $
?: =(try max)
(pure:m |)
;< ~ bind:m (backoff:strandio try ~h1)
;< rep=(unit httr:eyre) bind:m (hiss-request:strandio hiss)
?: ?& ?=(^ rep)
|(=(200 p.u.rep) =(307 p.u.rep))
==
(pure:m &)
?. ?| ?=(~ rep)
=(504 p.u.rep)
==
(pure:m |)
loop(try +(try))
--

138
pkg/arvo/lib/ethio.hoon
View File

@ -1,12 +1,10 @@
:: ethio: Asynchronous Ethereum input/output functions.
::.
/+ stdio
/+ strandio
=, ethereum-types
=, able:jael
::
|* [out-poke-data=mold out-peer-data=mold]
=> |%
++ stdio (^stdio out-poke-data out-peer-data)
+$ topics (list ?(@ux (list @ux)))
--
|%
@ -14,60 +12,52 @@
::
++ request-rpc
|= [url=@ta id=(unit @t) req=request:rpc:ethereum]
=/ m (async:stdio ,json)
=/ m (strand:strandio ,json)
^- form:m
|^ %+ (retry json) `10
=/ m (async:stdio ,(unit json))
^- form:m
=/ =request:http
:* method=%'POST'
url=url
header-list=['Content-Type'^'application/json' ~]
^= body
%- some %- as-octt:mimes:html
%- en-json:html
(request-to-json:rpc:ethereum id req)
==
;< ~ bind:m (send-request:stdio request)
;< rep=(unit client-response:iris) bind:m
take-maybe-response:stdio
?~ rep
(pure:m ~)
(parse-response u.rep)
;< res=(list [id=@t =json]) bind:m
(request-batch-rpc-strict url [id req]~)
?: ?=([* ~] res)
(pure:m json.i.res)
~| [%ethio %unexpected-results (lent res)]
!!
:: +request-batch-rpc-strict: send rpc request, with retry
::
:: sends a batch requests. produces results for all requests in the batch,
:: but only if all of them are successful.
::
++ request-batch-rpc-strict
|= [url=@ta reqs=(list [id=(unit @t) req=request:rpc:ethereum])]
|^ %+ (retry:strandio results)
`10
attempt-request
::
++ retry
|* result=mold
|= [crash-after=(unit @ud) computation=_*form:(async:stdio (unit result))]
=/ m (async:stdio ,result)
=| try=@ud
|^ |- ^- form:m
=* loop $
?: =(crash-after `try)
(async-fail:stdio %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 (async:stdio ,~)
^- form:m
;< eny=@uvJ bind:m get-entropy:stdio
;< now=@da bind:m get-time:stdio
%- wait:stdio
%+ add now
%+ min limit
?: =(0 try) ~s0
%+ add
(mul ~s1 (bex (dec try)))
(mul ~s0..0001 (~(rad og eny) 1.000))
--
+$ result [id=@t =json]
+$ results (list result)
::
++ parse-response
++ attempt-request
=/ m (strand:strandio ,(unit results))
^- form:m
=/ =request:http
:* method=%'POST'
url=url
header-list=['Content-Type'^'application/json' ~]
::
^= body
%- some %- as-octt:mimes:html
%- en-json:html
a+(turn reqs request-to-json:rpc:ethereum)
==
;< ~ bind:m
(send-request:strandio request)
;< rep=(unit client-response:iris) bind:m
take-maybe-response:strandio
?~ rep
(pure:m ~)
(parse-responses u.rep)
::
++ parse-responses
|= =client-response:iris
=/ m (async:stdio ,(unit json))
=/ m (strand:strandio ,(unit results))
^- form:m
?> ?=(%finished -.client-response)
?~ full-file.client-response
@ -76,20 +66,24 @@
=/ jon=(unit json) (de-json:html body)
?~ jon
(pure:m ~)
=, dejs-soft:format
=/ array=(unit (list response:rpc:jstd))
((ar parse-one-response) u.jon)
((ar:dejs-soft:format parse-one-response) u.jon)
?~ array
=/ res=(unit response:rpc:jstd) (parse-one-response u.jon)
?~ res
(async-fail:stdio %request-rpc-parse-error >id< ~)
?: ?=(%error -.u.res)
(async-fail:stdio %request-rpc-error >id< >+.res< ~)
?. ?=(%result -.u.res)
(async-fail:stdio %request-rpc-fail >u.res< ~)
(pure:m `res.u.res)
(async-fail:stdio %request-rpc-batch >%not-implemented< ~)
:: (pure:m `[%batch u.array])
~& %incomplete-batch
(strand-fail:strandio %rpc-result-incomplete-batch >u.jon< ~)
=- ?~ err
(pure:m `res)
~& [%error-results err]
(pure:m ~)
%+ roll u.array
|= $: rpc=response:rpc:jstd
[res=results err=(list [id=@t code=@t message=@t])]
==
?: ?=(%error -.rpc)
[res [+.rpc err]]
?. ?=(%result -.rpc)
[res [['' 'ethio-rpc-fail' (crip <rpc>)] err]]
[[+.rpc res] err]
::
++ parse-one-response
|= =json
@ -109,19 +103,19 @@
::
++ read-contract
|= [url=@t proto-read-request:rpc:ethereum]
=/ m (async:stdio ,@t)
=/ m (strand:strandio ,@t)
;< =json bind:m
%^ request-rpc url id
:+ %eth-call
^- call:rpc:ethereum
[~ to ~ ~ ~ `tape`(encode-call:rpc:ethereum function arguments)]
[%label %latest]
?. ?=(%s -.json) (async-fail:stdio %request-rpc-fail >json< ~)
?. ?=(%s -.json) (strand-fail:strandio %request-rpc-fail >json< ~)
(pure:m p.json)
::
++ get-latest-block
|= url=@ta
=/ m (async:stdio ,block)
=/ m (strand:strandio ,block)
^- form:m
;< =json bind:m
(request-rpc url `'block number' %eth-block-number ~)
@ -129,7 +123,7 @@
::
++ get-block-by-number
|= [url=@ta =number:block]
=/ m (async:stdio ,block)
=/ m (strand:strandio ,block)
^- form:m
|^
;< =json bind:m
@ -138,7 +132,7 @@
[%eth-get-block-by-number number |]
=/ =block (parse-block json)
?. =(number number.id.block)
(async-fail:stdio %reorg-detected >number< >block< ~)
(strand-fail:strandio %reorg-detected >number< >block< ~)
(pure:m block)
::
++ parse-block
@ -158,7 +152,7 @@
::
++ get-logs-by-hash
|= [url=@ta =hash:block contracts=(list address) =topics]
=/ m (async:stdio (list event-log:rpc:ethereum))
=/ m (strand:strandio (list event-log:rpc:ethereum))
^- form:m
;< =json bind:m
%+ request-rpc url
@ -178,7 +172,7 @@
=from=number:block
=to=number:block
==
=/ m (async:stdio (list event-log:rpc:ethereum))
=/ m (strand:strandio (list event-log:rpc:ethereum))
^- form:m
;< =json bind:m
%+ request-rpc url

171
pkg/arvo/lib/hood/drum.hoon
View File

@ -20,8 +20,7 @@
|:($:source +<(mir ((pair @ud (list @c))))) :: style-less mir
:: ::
++ pith-2 ::
$: sys/(unit bone) :: local console
eel/(set gill:gall) :: connect to
$: eel/(set gill:gall) :: connect to
ray/(set well:gall) ::
fur/(map dude:gall (unit server)) :: servers
bin/(map bone source) :: terminals
@ -44,7 +43,7 @@
off/@ud :: window offset
kil/kill :: kill buffer
inx/@ud :: ring index
fug/(map gill:gall (unit target)) :: connections
fug/(map gill:gall (unit target)) :: connections
mir/(pair @ud stub) :: mirrored terminal
== ::
++ history :: past input
@ -80,24 +79,20 @@
::
=- (turn - |=(a=term home+a))
^- (list term)
?: lit
:~ %dojo
%eth-watcher
%azimuth-tracker
==
%+ welp
?: ?=(%pawn (clan:title our)) ~
:~ %acme
%dns
:~ %dojo
%spider
%eth-watcher
%azimuth-tracker
%ping
==
?: lit
~
:~ %lens
%clock
%dojo
%modulo
%launch
%publish
%clock
%weather
%group-store
%group-hook
@ -118,14 +113,13 @@
|= our/ship
%- ~(gas in *(set gill:gall))
^- (list gill:gall)
[[our %chat-cli] [our %dojo] ~]
[[our %dojo] [our %chat-cli]~]
::
++ make :: initial part
|= our/ship
^- part
:* %drum
%2
sys=~
eel=(deft-fish our)
ray=~
fur=~
@ -146,25 +140,10 @@
::::
::
|= {hid/bowl:gall part} :: main drum work
=+ (~(gut by bin) ost.hid *source)
=/ ost 0
=+ (~(gut by bin) ost *source)
=* dev -
=> |% :: arvo structures
++ pear :: request
$% {$sole-action p/sole-action} ::
== ::
++ lime :: update
$% {$dill-blit dill-blit:dill} ::
== ::
++ card :: general card
$% {$conf wire dock ship term} ::
{$diff lime} ::
{$peer wire dock path} ::
{$poke wire dock pear} ::
{$pull wire dock ~} ::
== ::
++ move (pair bone card) :: user-level move
--
|_ {moz/(list move) biz/(list dill-blit:dill)}
|_ {moz/(list card:agent:gall) biz/(list dill-blit:dill)}
++ diff-sole-effect-phat :: app event
|= {way/wire fec/sole-effect}
=< se-abet =< se-view
@ -181,7 +160,7 @@
::
++ poke-set-boot-apps ::
|= lit/?
^- (quip move part)
^- (quip card:agent:gall part)
:: We do not run se-abet:se-view here because that starts the apps,
:: and some apps are not ready to start (eg Talk crashes because the
:: terminal has width 0). It appears the first message to drum must
@ -211,7 +190,7 @@
++ poke-unlink :: disconnect app
|= gyl/gill:gall
=< se-abet =< se-view
(se-klin gyl)
(se-drop:(se-pull gyl) & gyl)
::
++ poke-exit :: shutdown
|= ~
@ -221,13 +200,33 @@
|= {pax/path txt/@}
se-abet:(se-blit-sys [%sav pax txt]) ::
::
++ poke
|= [=mark =vase]
?+ mark ~|([%poke-drum-bad-mark mark] !!)
%drum-put =;(f (f !<(_+<.f vase)) poke-put)
%drum-link =;(f (f !<(_+<.f vase)) poke-link)
%drum-unlink =;(f (f !<(_+<.f vase)) poke-unlink)
%drum-exit =;(f (f !<(_+<.f vase)) poke-exit)
%drum-start =;(f (f !<(_+<.f vase)) poke-start)
%drum-set-boot-apps =;(f (f !<(_+<.f vase)) poke-set-boot-apps)
==
::
++ reap-phat :: ack connect
|= {way/wire saw/(unit tang)}
=< se-abet =< se-view
=+ gyl=(de-gill way)
?~ saw
(se-join gyl)
(se-dump:(se-drop & gyl) u.saw)
:: Don't print stack trace because we probably just crashed to
:: indicate we don't connect to the console.
::
(se-drop & gyl)
::
++ take ::
|= [=wire =sign-arvo]
%+ take-onto wire
?> ?=(%onto +<.sign-arvo)
+>.sign-arvo
::
++ take-coup-phat :: ack poke
|= {way/wire saw/(unit tang)}
@ -235,9 +234,9 @@
?~ saw +>
=+ gyl=(de-gill way)
?: (se-aint gyl) +>.$
%- se-dump:(se-drop & gyl)
%- se-dump:(se-drop:(se-pull gyl) & gyl)
:_ u.saw
>[%drum-coup-fail src.hid ost.hid gyl]<
>[%drum-coup-fail src.hid gyl]<
::
++ take-onto :: ack start
|= {way/wire saw/(each suss:gall tang)}
@ -252,42 +251,46 @@
+>.$(fur (~(put by fur) q.wel `[p.wel %da r.p.saw]))
==
::
++ take-agent
|= [=wire =sign:agent:gall]
?+ wire ~|([%drum-bad-take-agent wire -.sign] !!)
[%drum %phat *]
?- -.sign
%poke-ack (take-coup-phat t.t.wire p.sign)
%watch-ack (reap-phat t.t.wire p.sign)
%kick (quit-phat t.t.wire)
%fact
%+ diff-sole-effect-phat t.t.wire
?> ?=(%sole-effect p.cage.sign)
!<(sole-effect q.cage.sign)
==
==
::
++ quit-phat ::
|= way/wire
=< se-abet =< se-view
=+ gyl=(de-gill way)
~& [%drum-quit src.hid ost.hid gyl]
~& [%drum-quit src.hid gyl]
(se-drop %| gyl)
:: :: ::
:::: :: ::
:: :: ::
++ se-abet :: resolve
^- (quip move part)
^- (quip card:agent:gall part)
=* pith +<+.$
?. se-ably
=. . se-adit
[(flop moz) pith]
=. sys ?^(sys sys `ost.hid)
=. . se-subze:se-adze:se-adit
:_ pith(bin (~(put by bin) ost.hid dev))
%- flop
^- (list move)
?~ biz moz
:_ moz
[ost.hid %diff %dill-blit ?~(t.biz i.biz [%mor (flop biz)])]
::
++ se-ably (~(has by sup.hid) ost.hid) :: caused by console
:_ pith(bin (~(put by bin) ost dev))
^- (list card:agent:gall)
?~ biz (flop moz)
:_ (flop moz)
=/ =dill-blit:dill ?~(t.biz i.biz [%mor (flop biz)])
[%give %fact `/drum %dill-blit !>(dill-blit)]
::
++ se-adit :: update servers
^+ .
%+ roll
:: ensure dojo is first in the list,
:: guaranteeing its display on-boot.
::
%+ sort ~(tap in ray)
|= [a=well:gall b=well:gall]
?: |(=(%dojo q.a) =(%dojo q.b)) =(%dojo q.a)
(aor a b)
:: ensure dojo connects after talk
=* dojo-on-top aor
%+ roll (sort ~(tap in ray) dojo-on-top)
=< .(con +>)
|: $:{wel/well:gall con/_..se-adit} ^+ con
=. +>.$ con
@ -295,7 +298,8 @@
?: &(?=(^ hig) |(?=(~ u.hig) =(p.wel syd.u.u.hig))) +>.$
=. +>.$ (se-text "activated app {(trip p.wel)}/{(trip q.wel)}")
%- se-emit(fur (~(put by fur) q.wel ~))
[ost.hid %conf [%drum p.wel q.wel ~] [our.hid q.wel] our.hid p.wel]
=/ =wire [%drum p.wel q.wel ~]
[%pass wire %arvo %g %conf [our.hid q.wel] our.hid p.wel]
::
++ se-adze :: update connections
^+ .
@ -308,14 +312,14 @@
(se-peer gil)
::
++ se-subze :: downdate connections
=< .(dev (~(got by bin) ost.hid))
=. bin (~(put by bin) ost.hid dev)
=< .(dev (~(got by bin) ost))
=. bin (~(put by bin) ost dev)
^+ .
%- ~(rep by bin)
=< .(con +>)
|: $:{{ost/bone dev/source} con/_.} ^+ con
=+ xeno=se-subze-local:%_(con ost.hid ost, dev dev)
xeno(ost.hid ost.hid.con, dev dev.con, bin (~(put by bin) ost dev.xeno))
=+ xeno=se-subze-local:%_(con ost ost, dev dev)
xeno(ost ost.con, dev dev.con, bin (~(put by bin) ost dev.xeno))
::
++ se-subze-local
^+ .
@ -330,7 +334,7 @@
++ se-aint :: ignore result
|= gyl/gill:gall
^- ?
?. (~(has by bin) ost.hid) &
?. (~(has by bin) ost) &
=+ gyr=(~(get by fug) gyl)
|(?=(~ gyr) ?=(~ u.gyr))
::
@ -357,6 +361,7 @@
^- (unit gill:gall)
=+ wag=se-amor
?~ wag ~
~| [inx=inx wag=wag fug=fug eel=eel]
`(snag inx `(list gill:gall)`wag)
::
++ se-belt :: handle input
@ -431,7 +436,6 @@
++ se-dump :: print tanks
|= tac/(list tank)
^+ +>
?. se-ably ((slog tac) +>.$)
=/ wol/wall
(zing (turn (flop tac) |=(a/tank (~(win re a) [0 edg]))))
|- ^+ +>.^$
@ -467,8 +471,7 @@
::
++ se-blit-sys :: output to system
|= bil/dill-blit:dill ^+ +>
?~ sys ~&(%se-blit-no-sys +>)
(se-emit [u.sys %diff %dill-blit bil])
(se-emit %give %fact `/drum %dill-blit !>(bil))
::
++ se-show :: show buffer, raw
|= lin/(pair @ud stub)
@ -505,9 +508,9 @@
?: |(?=(~ gul) (se-aint u.gul)) +
(se-just ta-vew:(se-tame u.gul))
::
++ se-emit :: emit move
|= mov/move
%_(+> moz [mov moz])
++ se-emit
|= card:agent:gall
%_(+> moz [+< moz])
::
++ se-text :: return text
|= txt/tape
@ -515,21 +518,20 @@
?. ((sane %t) (crip txt)) :: XX upstream validation
~& bad-text+<`*`txt>
+>
?. se-ably ((slog [%leaf txt]~) +>.$)
(se-blit %out (tuba txt))
::
++ se-poke :: send a poke
|= {gyl/gill:gall par/pear}
(se-emit [ost.hid %poke (en-gill gyl) gyl par])
|= {gyl/gill:gall par/cage}
(se-emit %pass (en-gill gyl) %agent gyl %poke par)
::
++ se-peer :: send a peer
|= gyl/gill:gall
%- se-emit(fug (~(put by fug) gyl ~))
[ost.hid %peer (en-gill gyl) gyl /sole]
[%pass (en-gill gyl) %agent gyl %watch /sole/drum]
::
++ se-pull :: cancel subscription
|= gyl/gill:gall
(se-emit [ost.hid %pull (en-gill gyl) gyl ~])
(se-emit %pass (en-gill gyl) %agent gyl %leave ~)
::
++ se-tame :: switch connection
|= gyl/gill:gall
@ -547,12 +549,12 @@
^+ ..ta
..ta(fug (~(put by fug) gyl ``target`+<+))
::
++ ta-poke |=(a/pear +>(..ta (se-poke gyl a))) :: poke gyl
++ ta-poke |=(a/cage +>(..ta (se-poke gyl a))) :: poke gyl
::
++ ta-act :: send action
|= act/sole-action
^+ +>
(ta-poke %sole-action act)
(ta-poke %sole-action !>(act))
::
++ ta-aro :: hear arrow
|= key/?($d $l $r $u)
@ -593,7 +595,10 @@
++ ta-det :: send edit
|= ted/sole-edit
^+ +>
(ta-act %det [[his.ven.say.inp own.ven.say.inp] (sham buf.say.inp) ted])
%^ ta-act
%drum
%det
[[his.ven.say.inp own.ven.say.inp] (sham buf.say.inp) ted]
::
++ ta-bac :: hear backspace
^+ .
@ -603,7 +608,7 @@
.(str.u.ris (scag (dec (lent str.u.ris)) str.u.ris))
?: =(0 pos.inp)
?~ buf.say.inp
(ta-act %clr ~)
(ta-act %drum %clr ~)
ta-bel
(ta-hom %del (dec pos.inp))
::
@ -891,10 +896,10 @@
==
::
++ ta-ret :: hear return
(ta-act %ret ~)
(ta-act %drum %ret ~)
::
++ ta-tab :: hear tab
(ta-act %tab pos.inp)
(ta-act %drum %tab pos.inp)
::
++ ta-ser :: reverse search
|= ext/(list @c)

146
pkg/arvo/lib/hood/helm.hoon
View File

@ -34,36 +34,23 @@
:::: :: ::
:: :: ::
|: $:{bowl:gall part} :: main helm work
=/ ost 0
=+ sez=(~(gut by hoc) ost $:session)
=> |% :: arvo structures
++ card ::
$% [%bonk wire ~] ::
{$conf wire dock ship term} ::
{$flog wire flog:dill} ::
[%knob wire @tas ?(%hush %soft %loud)] ::
{$nuke wire ship} ::
[%serve wire binding:eyre generator:eyre] ::
{$poke wire dock pear} ::
{$rest wire @da} ::
{$wait wire @da} ::
{$rekey wire life ring} ::
{$moon wire ship udiff:point:able:jael} ::
== ::
++ move (pair bone card) :: user-level move
++ pear :: poke fruit
$% {$hood-unsync desk ship desk} ::
{$helm-hi cord} ::
{$drum-start well:gall} ::
== ::
--
=+ moz=((list move))
=| moz=(list card:agent:gall)
|%
++ abet :: resolve
++ abet
[(flop moz) %_(+<+.$ hoc (~(put by hoc) ost sez))]
::
++ emit |=(card %_(+> moz [[ost +<] moz])) :: return card
++ emit
|= card:agent:gall
%_(+> moz [+< moz])
::
++ flog
|= =flog:dill
(emit %pass /di %arvo %d %flog flog)
::
++ emil :: return cards
|= (list card)
|= (list card:agent:gall)
^+ +>
?~(+< +> $(+< t.+<, +> (emit i.+<)))
::
@ -80,38 +67,32 @@
?. =(our who.u.sed)
~& [%wrong-private-key-ship who.u.sed]
+>.$
(emit %rekey / lyf.u.sed key.u.sed)
(emit %pass / %arvo %j %rekey lyf.u.sed key.u.sed)
::
++ poke-moon :: rotate moon keys
|= sed=(unit [=ship =udiff:point:able:jael])
=< abet
?~ sed
+>.$
(emit %moon / u.sed)
::
++ poke-nuke :: initialize
|= him/ship =< abet
(emit %nuke /helm him)
(emit %pass / %arvo %j %moon u.sed)
::
++ poke-mass
|= ~ =< abet
(emit %flog /heft %crud %hax-heft ~)
(emit %pass /heft %arvo %d %flog %heft ~)
::
++ poke-automass
|= recur=@dr
=. mass-timer.sez
[/helm/automass (add now recur) recur]
abet:(emit %wait way.mass-timer.sez nex.mass-timer.sez)
abet:(emit %pass way.mass-timer.sez %arvo %b %wait nex.mass-timer.sez)
::
++ poke-cancel-automass
|= ~
abet:(emit %rest way.mass-timer.sez nex.mass-timer.sez)
abet:(emit %pass way.mass-timer.sez %arvo %b %rest nex.mass-timer.sez)
::
++ poke-bonk
|= ~
~& .^((unit @da) %a /(scot %p our)/time/(scot %da now)/(scot %p our))
%- %- slog :_ ~ .^(tank %b /(scot %p our)/timers/(scot %da now))
abet:(emit %bonk /bonk ~)
++ poke-pack
|= ~ =< abet
(emit %pass /pack %arvo %d %flog %pack ~)
::
++ take-wake-automass
|= [way=wire error=(unit tang)]
@ -122,14 +103,17 @@
=. nex.mass-timer.sez (add now tim.mass-timer.sez)
=< abet
%- emil
:~ [%flog /heft %crud %hax-heft ~]
[%wait way.mass-timer.sez nex.mass-timer.sez]
:~ [%pass /heft %arvo %d %flog %crud %hax-heft ~]
[%pass way.mass-timer.sez %arvo %b %wait nex.mass-timer.sez]
==
::
++ poke-send-hi
|= {her/ship mes/(unit tape)} =< abet
%^ emit %poke /helm/hi/(scot %p her)
[[her %hood] %helm-hi ?~(mes '' (crip u.mes))]
%- emit
:* %pass /helm/hi/(scot %p her)
%agent [her %hood] %poke
%helm-hi !>(?~(mes '' (crip u.mes)))
==
::
::
++ poke-hi
@ -138,25 +122,24 @@
?: =(%fail mes)
~& %poke-hi-fail
!!
abet:(emit %flog /di %text "< {<src>}: {(trip mes)}")
abet:(flog %text "< {<src>}: {(trip mes)}")
::
++ poke-atom
|= ato/@
=+ len=(scow %ud (met 3 ato))
=+ gum=(scow %p (mug ato))
=< abet
(emit %flog /di %text "< {<src>}: atom: {len} bytes, mug {gum}")
(flog %text "< {<src>}: atom: {len} bytes, mug {gum}")
::
++ coup-hi
|= {pax/path cop/(unit tang)} =< abet
?> ?=({@t ~} pax)
(emit %flog ~ %text "hi {(trip i.pax)} {?~(cop "" "un")}successful")
(flog %text "hi {(trip i.pax)} {?~(cop "" "un")}successful")
::
++ poke-reload |=(all/(list term) (poke-reload-desk %home all))
++ poke-reload-desk :: reload vanes
|: $:{syd/desk all/(list term)} =< abet
%- emil
%- flop
%+ turn all
=+ top=`path`/(scot %p our)/[syd]/(scot %da now)
=/ van/(list {term ~})
@ -174,7 +157,7 @@
=+ zus==('z' tip)
=+ way=?:(zus (welp top /sys/[nam]) (welp top /sys/vane/[nam]))
=+ fil=.^(@ %cx (welp way /hoon))
[%flog /reload [%veer ?:(=('z' tip) %$ tip) way fil]]
[%pass /reload %arvo %d %flog %veer ?:(=('z' tip) %$ tip) way fil]
:: +poke-reset: send %lyra to initiate kernel upgrade
::
:: And reinstall %zuse and the vanes with %veer.
@ -183,42 +166,69 @@
++ poke-reset
|= hood-reset
=< abet
%- emil %- flop
^- (list card)
%- emil
^- (list card:agent:gall)
=/ top=path /(scot %p our)/home/(scot %da now)/sys
=/ hun .^(@ %cx (welp top /hoon/hoon))
=/ arv .^(@ %cx (welp top /arvo/hoon))
:- [%flog /reset [%lyra `@t`hun `@t`arv]]
:- [%pass /reset %arvo %d %flog %lyra `@t`hun `@t`arv]
%+ turn
(module-ova:pill top)
|=(a=[wire flog:dill] [%flog a])
|=([=wire =flog:dill] [%pass wire %arvo %d %flog flog])
::
++ poke-verb :: toggle verbose
|= ~ =< abet
(emit %flog /helm %verb ~)
(flog %verb ~)
::
++ poke-ames-verb
|= veb=(list verb:ames) =< abet
(emit %pass /helm %arvo %a %spew veb)
::
++ poke-knob
|= [error-tag=@tas level=?(%hush %soft %loud)] =< abet
(emit %knob /helm error-tag level)
::
++ take-onto :: result of %conf
|= saw/(each suss:gall tang) =< abet
%- emit
?- -.saw
%| [%flog ~ %crud %onto `tang`p.saw]
%& [%flog ~ %text "<{<p.saw>}>"]
==
::
++ take-woot :: result of %want
|= {way/wire her/ship cop/coop} =< abet
(emit %flog ~ %text "woot: {<[way cop]>}")
(emit %pass /helm %arvo %d %knob error-tag level)
::
++ poke-serve
|= [=binding:eyre =generator:eyre] =< abet
(emit %serve /helm/serv binding generator)
(emit %pass /helm/serv %arvo %e %serve binding generator)
::
++ poke
|= [=mark =vase]
?+ mark ~|([%poke-helm-bad-mark mark] !!)
%helm-hi =;(f (f !<(_+<.f vase)) poke-hi)
%helm-mass =;(f (f !<(_+<.f vase)) poke-mass)
%helm-pack =;(f (f !<(_+<.f vase)) poke-pack)
%helm-reload =;(f (f !<(_+<.f vase)) poke-reload)
%helm-reload-desk =;(f (f !<(_+<.f vase)) poke-reload-desk)
%helm-reset =;(f (f !<(_+<.f vase)) poke-reset)
%helm-send-hi =;(f (f !<(_+<.f vase)) poke-send-hi)
%helm-ames-verb =;(f (f !<(_+<.f vase)) poke-ames-verb)
%helm-verb =;(f (f !<(_+<.f vase)) poke-verb)
%helm-knob =;(f (f !<(_+<.f vase)) poke-knob)
%helm-rekey =;(f (f !<(_+<.f vase)) poke-rekey)
%helm-automass =;(f (f !<(_+<.f vase)) poke-automass)
%helm-cancel-automass =;(f (f !<(_+<.f vase)) poke-cancel-automass)
%helm-moon =;(f (f !<(_+<.f vase)) poke-moon)
%helm-serve =;(f (f !<(_+<.f vase)) poke-serve)
==
::
++ take-agent
|= [=wire =sign:agent:gall]
?+ wire ~|([%helm-bad-take-agent wire -.sign] !!)
[%helm %hi *] ?> ?=(%poke-ack -.sign)
(coup-hi t.t.wire p.sign)
==
::
++ take-bound
|= [wir=wire success=? binding=binding:eyre] =< abet
(emit %flog ~ %text "bound: {<success>}")
(flog %text "bound: {<success>}")
::
++ take
|= [=wire =sign-arvo]
?+ wire ~|([%helm-bad-take-wire wire +<.sign-arvo] !!)
[%automass *] %+ take-wake-automass t.wire
?>(?=(%wake +<.sign-arvo) +>.sign-arvo)
[%serv *] %+ take-bound t.wire
?>(?=(%bound +<.sign-arvo) +>.sign-arvo)
==
--

201
pkg/arvo/lib/hood/kiln.hoon
View File

@ -12,7 +12,7 @@
++ part {$kiln $0 pith} :: kiln state
++ pith :: ::
$: rem/(map desk per-desk) ::
syn/(map kiln-sync {let/@ud ust/bone}) ::
syn/(map kiln-sync let/@ud) ::
autoload-on/? ::
cur-hoon/@uvI ::
cur-arvo/@uvI ::
@ -59,39 +59,16 @@
:: :: ::
|= {bowl:gall part} :: main kiln work
?> =(src our)
=> |% :: arvo structures
++ card ::
$% {$build wire ? schematic:ford} ::
{$drop wire @tas} ::
[%goad wire force=? agent=(unit dude:gall)] ::
{$info wire @tas nori} ::
{$mont wire @tas beam} ::
{$dirk wire @tas} ::
{$ogre wire $@(@tas beam)} ::
{$merg wire @tas @p @tas case germ} ::
{$perm wire desk path rite} ::
{$poke wire dock pear} ::
[%wash wire ~]
{$wipe wire @ud} ::
[%keep wire compiler-cache-size=@ud build-cache-size=@ud]
{$wait wire @da} ::
{$rest wire @da} ::
{$warp wire ship riff} ::
== ::
++ pear :: poke fruit
$% {$kiln-merge kiln-merge} ::
{$helm-reload (list term)} ::
{$helm-reset ~} ::
== ::
++ move (pair bone card) :: user-level move
--
|_ moz/(list move)
|_ moz/(list card:agent:gall)
++ abet :: resolve
[(flop moz) `part`+<+.$]
::
++ emit |=(card %_(+> moz [[ost +<] moz])) :: return card
++ emil :: return cards
|= (list card)
++ emit
|= card:agent:gall
%_(+> moz [+< moz])
::
++ emil :: return cards
|= (list card:agent:gall)
^+ +>
?~(+< +> $(+< t.+<, +> (emit i.+<)))
::
@ -103,17 +80,17 @@
++ poke-commit
|= [mon/kiln-commit auto=?]
=< abet
=. +>.$ (emit %dirk /commit mon)
=. +>.$ (emit %pass /commit %arvo %c [%dirk mon])
?. auto
+>.$
=/ recur ~s1
=. commit-timer
[/kiln/autocommit (add now recur) recur mon]
(emit %wait way.commit-timer nex.commit-timer)
(emit %pass way.commit-timer %arvo %b [%wait nex.commit-timer])
::
++ poke-cancel-autocommit
|= ~
abet:(emit %rest way.commit-timer nex.commit-timer)
abet:(emit %pass way.commit-timer %arvo %b [%rest nex.commit-timer])
::
++ poke-mount
|= kiln-mount
@ -121,7 +98,7 @@
?~ bem
=+ "can't mount bad path: {<pax>}"
abet:(spam leaf+- ~)
abet:(emit %mont /mount pot u.bem)
abet:(emit %pass /mount %arvo %c [%mont pot u.bem])
::
++ poke-unmount
|= mon/kiln-unmount
@ -130,8 +107,8 @@
?~ bem
=+ "can't unmount bad path: {<mon>}"
abet:(spam leaf+- ~)
abet:(emit %ogre /unmount-beam [[p q r] s]:u.bem)
abet:(emit %ogre /unmount-point mon)
abet:(emit %pass /unmount-beam %arvo %c [%ogre [[p q r] s]:u.bem])
abet:(emit %pass /unmount-point %arvo %c [%ogre mon])
::
++ poke-track ::
|= hos/kiln-sync
@ -166,14 +143,14 @@
abet:abet:(merge:(work syd) ali sud cas gim)
::
++ poke-cancel
|= syd/desk
abet:(emit %drop /cancel syd)
|= ~
abet:(emit %pass /cancel %arvo %c [%drop %foo])
::
++ poke-info
|= {mez/tape tor/(unit toro)}
?~ tor
abet:(spam leaf+mez ~)
abet:(emit:(spam leaf+mez ~) %info /kiln u.tor)
abet:(emit:(spam leaf+mez ~) %pass /kiln %arvo %c [%info u.tor])
::
++ poke-rm
|= a/path
@ -199,14 +176,44 @@
|= {syd/desk pax/path pub/?}
=< abet
%- emit
[%perm /kiln/permission syd pax %r ~ ?:(pub %black %white) ~]
=/ =rite [%r ~ ?:(pub %black %white) ~]
[%pass /kiln/permission %arvo %c [%perm syd pax rite]]
::
++ poke-autoload |=(lod/(unit ?) abet:(poke:autoload lod))
++ poke-start-autoload |=(~ abet:start:autoload)
++ poke
|= [=mark =vase]
?+ mark ~|([%poke-kiln-bad-mark mark] !!)
%kiln-commit =;(f (f !<(_+<.f vase)) poke-commit)
%kiln-info =;(f (f !<(_+<.f vase)) poke-info)
%kiln-label =;(f (f !<(_+<.f vase)) poke-label)
%kiln-cancel =;(f (f !<(_+<.f vase)) poke-cancel)
%kiln-mount =;(f (f !<(_+<.f vase)) poke-mount)
%kiln-rm =;(f (f !<(_+<.f vase)) poke-rm)
%kiln-schedule =;(f (f !<(_+<.f vase)) poke-schedule)
%kiln-track =;(f (f !<(_+<.f vase)) poke-track)
%kiln-sync =;(f (f !<(_+<.f vase)) poke-sync)
%kiln-syncs =;(f (f !<(_+<.f vase)) poke-syncs)
%kiln-wipe-ford =;(f (f !<(_+<.f vase)) poke-wipe-ford)
%kiln-keep-ford =;(f (f !<(_+<.f vase)) poke-keep-ford)
%kiln-autoload =;(f (f !<(_+<.f vase)) poke-autoload)
%kiln-overload =;(f (f !<(_+<.f vase)) poke-overload)
%kiln-goad-gall =;(f (f !<(_+<.f vase)) poke-overload)
%kiln-wash-gall =;(f (f !<(_+<.f vase)) poke-wash-gall)
%kiln-unmount =;(f (f !<(_+<.f vase)) poke-unmount)
%kiln-unsync =;(f (f !<(_+<.f vase)) poke-unsync)
%kiln-permission =;(f (f !<(_+<.f vase)) poke-permission)
%kiln-cancel-autocommit =;(f (f !<(_+<.f vase)) poke-cancel-autocommit)
%kiln-start-autoload =;(f (f !<(_+<.f vase)) poke-start-autoload)
%kiln-merge =;(f (f !<(_+<.f vase)) poke-merge)
==
::
++ autoload
|%
++ emit |=(a/card +>(..autoload (^emit a)))
++ emit
|= a/card:agent:gall
+>(..autoload (^emit a))
::
++ tracked-vanes
^- (list @tas)
~[%ames %behn %clay %dill %eyre %ford %gall %iris %jael]
@ -238,8 +245,7 @@
::
++ subscribe-next
%- emit
^- card
[%warp /kiln/autoload our %home `[%next %z da+now /sys]]
[%pass /kiln/autoload %arvo %c [%warp our %home `[%next %z da+now /sys]]]
::
++ writ =>(check-new subscribe-next)
++ check-new
@ -251,13 +257,14 @@
=. cur-hoon new-hoon
=. cur-arvo new-arvo
=. cur-vanes rehash-vanes
(emit %poke /kiln/reload/hoon [our %hood] %helm-reset ~)
(emit %pass /kiln/reload/hoon %agent [our %hood] %poke %helm-reset !>(~))
:: XX updates cur-vanes?
=/ new-zuse (sys-hash /zuse/hoon)
?: !=(new-zuse cur-zuse)
=. cur-zuse new-zuse
=. cur-vanes rehash-vanes
(emit %poke /kiln/reload/zuse [our %hood] %helm-reload [%zuse tracked-vanes])
=/ =cage [%helm-reload !>([%zuse tracked-vanes])]
(emit [%pass /kiln/reload/zuse %agent [our %hood] %poke cage])
(roll tracked-vanes load-vane)
::
++ load-vane
@ -268,7 +275,8 @@
?: =(`new-vane (~(get by cur-vanes) syd))
+>.$
=. cur-vanes (~(put by cur-vanes) syd new-vane)
(emit [%poke /kiln/reload/[syd] [our %hood] %helm-reload ~[syd]])
=/ =cage [%helm-reload !>(~[syd])]
(emit %pass /kiln/reload/[syd] %agent [our %hood] %poke cage)
::
++ coup-reload
|= {way/wire saw/(unit tang)}
@ -280,26 +288,63 @@
:: +poke-overload: wipes ford cache at {start}, and then every {recur}.
|= [recur=@dr start=@da]
?> (gte start now)
abet:(emit %wait /kiln/overload/(scot %dr recur) start)
abet:(emit %pass /kiln/overload/(scot %dr recur) %arvo %b [%wait start])
::
++ poke-wipe-ford
|=(percent=@ud abet:(emit %wipe /kiln percent))
|=(percent=@ud abet:(emit %pass /kiln %arvo %f [%wipe percent]))
::
++ poke-keep-ford
|= [compiler-cache-size=@ud build-cache-size=@ud]
abet:(emit %keep /kiln compiler-cache-size build-cache-size)
=< abet
(emit %pass /kiln %arvo %f [%keep compiler-cache-size build-cache-size])
::
++ poke-goad-gall
|= [force=? agent=(unit dude:gall)]
abet:(emit %goad /kiln force agent)
abet:(emit %pass /kiln %arvo %g %goad force agent)
::
++ poke-wash-gall |=(* abet:(emit %wash /kiln ~))
++ poke-wash-gall |=(* abet:(emit %pass /kiln %arvo %g [%wash ~]))
::
++ mack
|= {way/wire saw/(unit tang)}
++ done
|= {way/wire saw/(unit error:ames)}
~? ?=(^ saw) [%kiln-nack u.saw]
abet
::
++ take-agent
|= [=wire =sign:agent:gall]
?+ wire ~|([%kiln-bad-take-agent wire -.sign] !!)
[%kiln %fancy *] ?> ?=(%poke-ack -.sign)
(take-coup-fancy t.t.wire p.sign)
[%kiln %reload *] ?> ?=(%poke-ack -.sign)
(take-coup-reload t.t.wire p.sign)
[%kiln %spam *] ?> ?=(%poke-ack -.sign)
(take-coup-spam t.t.wire p.sign)
==
::
++ take-general
|= [=wire =sign-arvo]
?- wire
[%sync %merg *] %+ take-mere-sync t.t.wire
?>(?=(%mere +<.sign-arvo) +>.sign-arvo)
[%autoload *] %+ take-writ-autoload t.wire
?>(?=(%writ +<.sign-arvo) +>.sign-arvo)
[%find-ship *] %+ take-writ-find-ship t.wire
?>(?=(%writ +<.sign-arvo) +>.sign-arvo)
[%sync *] %+ take-writ-sync t.wire
?>(?=(%writ +<.sign-arvo) +>.sign-arvo)
[%overload *] %+ take-wake-overload t.wire
?>(?=(%wake +<.sign-arvo) +>.sign-arvo)
[%autocommit *] %+ take-wake-autocommit t.wire
?>(?=(%wake +<.sign-arvo) +>.sign-arvo)
*
?+ +<.sign-arvo ~|([%kiln-bad-take-card +<.sign-arvo] !!)
%done %+ done wire
?>(?=(%done +<.sign-arvo) +>.sign-arvo)
%made %+ take-made wire
?>(?=(%made +<.sign-arvo) +>.sign-arvo)
%mere %+ take-mere wire
?>(?=(%mere +<.sign-arvo) +>.sign-arvo)
==
==
++ take |=(way/wire ?>(?=({@ ~} way) (work i.way))) :: general handler
++ take-mere ::
|= {way/wire are/(each (set path) (pair term tang))}
@ -386,8 +431,8 @@
=. nex.commit-timer (add now tim.commit-timer)
=< abet
%- emil
:~ [%dirk /commit mon.commit-timer]
[%wait way.commit-timer nex.commit-timer]
:~ [%pass /commit %arvo %c [%dirk mon.commit-timer]]
[%pass way.commit-timer %arvo %b [%wait nex.commit-timer]]
==
::
::
@ -397,39 +442,43 @@
::
++ auto
|= kiln-sync
=+ (~(gut by syn) [syd her sud] [let=*@ud ust=ost])
=+ (~(gut by syn) [syd her sud] let=*@ud)
|%
++ abet
..auto(syn (~(put by syn) [syd her sud] let ust))
..auto(syn (~(put by syn) [syd her sud] let))
::
++ blab
|= new/(list move)
|= new/(list card:agent:gall)
^+ +>
+>.$(moz (welp new moz))
::
++ warp
|= [=wire =ship =riff]
(blab [%pass wire %arvo %c [%warp ship riff]] ~)
::
++ spam |*(* %_(+> ..auto (^spam +<)))
++ stop
=> (spam (render "ended autosync" sud her syd) ~)
=/ =wire /kiln/sync/[syd]/(scot %p her)/[sud]
(blab [ust %warp wire her sud ~] ~)
(warp wire her sud ~)
:: XX duplicate of start-sync? see |track
::
++ start-track
=> (spam (render "activated track" sud her syd) ~)
=. let 1
=/ =wire /kiln/sync/[syd]/(scot %p her)/[sud]
(blab [ost %warp wire her sud `[%sing %y ud+let /]] ~)
(warp wire her sud `[%sing %y ud+let /])
::
++ start-sync
=> (spam (render "finding ship and desk" sud her syd) ~)
=/ =wire /kiln/find-ship/[syd]/(scot %p her)/[sud]
(blab [ost %warp wire her sud `[%sing %y ud+1 /]] ~)
(warp wire her sud `[%sing %y ud+1 /])
::
++ take-find-ship
|= rot=riot
=> (spam (render "activated sync" sud her syd) ~)
=/ =wire /kiln/sync/[syd]/(scot %p her)/[sud]
(blab [ost %warp wire her sud `[%sing %w [%da now] /]] ~)
(warp wire her sud `[%sing %w [%da now] /])
::
++ writ
|= rot=riot
@ -441,7 +490,7 @@
~
start-sync
=. let ?. ?=($w p.p.u.rot) let ud:;;(cass:clay q.q.r.u.rot)
=/ =wire /kiln/sync/[syd]/(scot %p her)/[sud]
=/ =wire /kiln/sync/merg/[syd]/(scot %p her)/[sud]
:: germ: merge mode for sync merges
::
:: Initial merges from any source must use the %init germ.
@ -464,7 +513,7 @@
=< %- spam
?: =(our her) ~
[(render "beginning sync" sud her syd) ~]
(blab [ost %merg wire syd her sud ud+let germ] ~)
(blab [%pass wire %arvo %c [%merg syd her sud ud+let germ]] ~)
::
++ mere
|= mes=(each (set path) (pair term tang))
@ -495,7 +544,7 @@
==
==
=/ =wire /kiln/sync/[syd]/(scot %p her)/[sud]
(blab [ost %warp wire her sud `[%sing %y ud+let /]] ~)
(warp wire her sud `[%sing %y ud+let /])
--
::
++ work :: state machine
@ -509,7 +558,7 @@
..work(rem (~(put by rem) syd auto gem her sud cas))
::
++ blab
|= new/(list move)
|= new/(list card:agent:gall)
^+ +>
+>.$(moz (welp new moz))
::
@ -530,13 +579,14 @@
::
++ perform ::
^+ .
(blab [ost %merg /kiln/[syd] syd her sud cas gem] ~)
(blab [%pass /kiln/[syd] %arvo %c [%merg syd her sud cas gem]] ~)
::
++ fancy-merge :: send to self
|= {syd/desk her/@p sud/desk gem/?($auto germ)}
^+ +>
=/ =cage [%kiln-merge !>([syd her sud cas gem])]
%- blab :_ ~
[ost %poke /kiln/fancy/[^syd] [our %hood] %kiln-merge [syd her sud cas gem]]
[%pass /kiln/fancy/[^syd] %agent [our %hood] %poke cage]
::
++ spam ::|=(tang ((slog +<) ..spam))
|*(* +>(..work (^spam +<)))
@ -556,7 +606,8 @@
?~ saw
=> (spam leaf+"%melding %{(trip sud)} into scratch space" ~)
%- blab :_ ~
[ost %merg /kiln/[syd] (cat 3 syd '-scratch') her sud cas gem]
=/ note [%merg (cat 3 syd '-scratch') her sud cas gem]
[%pass /kiln/[syd] %arvo %c note]
=+ :- "failed to set up conflict resolution scratch space"
"I'm out of ideas"
lose:(spam leaf+-< leaf+-> u.saw)
@ -575,7 +626,8 @@
=+ tic=(cat 3 syd '-scratch')
%- blab :_ ~
=, ford
:* ost %build /kiln/[syd] live=%.n
:* %pass /kiln/[syd] %arvo %f
:* %build live=%.n
^- schematic
:- %list
^- (list schematic)
@ -597,7 +649,7 @@
?~(- %$ i.-)
^- schematic
[%mash [our tic] for [[her sud] for dali] [[our syd] for dbob]]
==
== ==
=+ "failed to merge with strategy meld"
lose:(spam leaf+- >p.p.are< q.p.are)
?: ?=(%& -.are)
@ -704,11 +756,12 @@
=< win
%- blab:(spam tan)
:_ ~
:* ost %info /kiln/[syd]
:* %pass /kiln/[syd] %arvo %c
:* %info
(cat 3 syd '-scratch') %&
%+ murn can
|= {p/path q/(unit miso)}
`(unit (pair path miso))`?~(q ~ `[p u.q])
==
== ==
--
--

43
pkg/arvo/lib/hood/write.hoon
View File

@ -15,25 +15,25 @@
::
|%
++ data $%({$json json} {$mime mime})
++ card $% {$build wire ? schematic:ford}
{$info wire toro:clay}
==
--
::
::::
::
|= {bowl:gall part}
=* par +<+
|_ moz/(list {bone card})
|_ moz/(list card:agent:gall)
++ abet [(flop moz) `part`par]
++ emit |=(a/card %_(+> moz :_(moz [ost a])))
++ emit
|= =card:agent:gall
%_(+> moz :_(moz card))
::
++ beak-now byk(r [%da now])
++ poke-wipe
|= sup/path ^+ abet :: XX determine extension, beak
=+ ext=%md
?~ (file (en-beam beak-now [ext sup]))
~|(not-found+[ext `path`(flop sup)] !!)
=- abet:(emit %info write+~ -)
=- abet:(emit %pass /write %arvo %c %info -)
(fray (en-beam beak-now [ext sup]))
::
++ poke-tree
@ -94,12 +94,21 @@
(made pax now [%complete %success %$ cay])
=< abet
%- emit :*
%pass write+pax %arvo %f
%build
write+pax
live=%.n :: XX defer %nice
^- schematic:ford :: SYNTAX ERROR AT START OF LINE?
=/ =beak beak-now
[%cast [p q]:beak u.ext [%$ cay]]
live=%.n :: XX defer %nice
^- schematic:ford :: SYNTAX ERROR AT START OF LINE?
=/ =beak beak-now
[%cast [p q]:beak u.ext [%$ cay]]
==
::
++ poke
|= [=mark =vase]
?+ mark ~|([%poke-write-bad-mark mark] !!)
%write-sec-atom =;(f (f !<(_+<.f vase)) poke-sec-atom)
%write-paste =;(f (f !<(_+<.f vase)) poke-paste)
%write-tree =;(f (f !<(_+<.f vase)) poke-tree)
%write-wipe =;(f (f !<(_+<.f vase)) poke-wipe)
==
::
++ made
@ -118,7 +127,17 @@
::
=/ =cage (result-to-cage:ford build-result)
::
=- abet:(emit %info write+~ -)
=- abet:(emit %pass /write %arvo %c %info -)
::
(foal :(welp (en-beam beak-now ~) pax /[-.cage]) cage)
::
++ take ::
|= [=wire =sign-arvo]
%+ made wire
?> ?=(%made +<.sign-arvo)
+>.sign-arvo
::
++ take-agent
|= [=wire =sign:agent:gall]
~|([%write-bad-take-agent wire -.sign] !!)
--

5
pkg/arvo/lib/language-server/rune-snippet.hoon
View File

@ -389,8 +389,7 @@
"""
:- "=^"
"""
$\{1:face}
$\{2:wing}
$\{1:face} $\{2:wing}
$\{3:computation}
$\{4:body}
"""
@ -454,7 +453,7 @@
$\{1:assertion}
$\{2:body}
"""
:- "?-"
:- "?+"
"""
$\{1:case} $\{2:else}
$\{3:type} $\{4:value}

86
pkg/arvo/lib/ph.hoon
View File

@ -1,86 +0,0 @@
:: Defines the ph monad.
::
:: A complete ph test has type data:(ph ,~). This is a function that
:: accepts a new unix-effect and produces a list of ph-events to inject
:: back into the system. It also produces one of four "next steps":
::
:: %wait: no change; on next unix-effect call this same function.
:: %cont: swap out this test for another one. Mainly useful for
:: the implementation of +bind.
:: %fail: the test has failed.
:: %done: the test has finished successfully.
::
:: When producing %done, you may specify a value. The ph app assumes
:: the value of each whole test will be ~. During the test, though, it
:: may be useful to produce intermediate values.
::
:: We define two additional functions. +return takes a value and
:: produces a test which immediately produces a %done with that value.
::
:: +bind takes a test and a function from the output type of that test
:: to another test. This is useful to link tests together. See
:: lib/ph/tests.hoon for examples of usage.
::
:: You may recognize monad terminology. These functions satisfy the
:: monad laws: If `f` and `g` are the sort of function that go in the
:: second argument to bind and `m` is a test, then:
::
:: (cork pure (curr bind f)) = f
:: (bind m pure) = m
:: ((bind m f) g) = (bind m (bind f g))
::
:: Maintaining these laws requires a particular interpretation of the
:: monad, which the ph app implements in +diff-aqua-effects. Thus,
:: within the ph app the monad laws hold.
::
/- aquarium
=, aquarium
|%
+$ ph-input
[now=@da who=ship uf=unix-effect]
::
++ ph-output-raw
|* a=mold
$~ [& ~ %done *a]
$: thru=?
events=(list ph-event)
$= next
$% [%wait ~]
[%cont self=(ph-form-raw a)]
[%fail ~]
[%done value=a]
==
==
::
++ ph-form-raw
|* a=mold
$-(ph-input (ph-output-raw a))
::
++ ph
|* a=mold
|%
++ output (ph-output-raw a)
++ form (ph-form-raw a)
++ pure
|= arg=a
^- form
|= ph-input
[& ~ %done arg]
::
++ bind
|* b=mold
|= [m-b=(ph-form-raw b) fun=$-(b form)]
^- form
|= input=ph-input
=/ b-res=(ph-output-raw b)
(m-b input)
^- output
:+ thru.b-res events.b-res
?- -.next.b-res
%wait [%wait ~]
%cont [%cont ..$(m-b self.next.b-res)]
%fail [%fail ~]
%done [%cont (fun value.next.b-res)]
==
--
--

457
pkg/arvo/lib/ph/azimuth.hoon
View File

@ -1,457 +0,0 @@
:: Mock Azimuth
::
/+ ph, ph-util, ph-philter, ph-tests
=, ph
=, ph-util
=, ph-philter
|= our=ship
=> |%
+$ az-log [topics=(lest @) data=@t]
--
=| logs=(list az-log) :: oldest logs first
=| lives=(map ship [lyfe=life rut=rift])
=| $= eth-filters
$: next=_1 :: jael assumes != 0
all=(map @ud [from-block=@ud last-block=@ud address=@ux])
==
|%
++ this-az .
++ add-logs
|= new-logs=(list az-log)
^+ this-az
=. logs (weld logs new-logs)
this-az
::
++ router
=/ n (philter ,_this-az)
^- form:n
|%
++ stay this-az
++ run
|= pin=ph-input
^- output:n
=, enjs:format
=/ ask (extract-request uf.pin 'http://localhost:8545/')
?~ ask
[& ~ %wait ~]
?~ body.request.u.ask
[& ~ %wait ~]
=/ req q.u.body.request.u.ask
|^ ^- output:n
=/ method (get-method req)
:: =; a ~& [%give-azimuth-response a] -
?: =(method 'eth_blockNumber')
:- | :_ [%wait ~]
%+ answer-request req
s+(crip (num-to-hex:ethereum latest-block))
?: =(method 'eth_getBlockByNumber')
:- | :_ [%wait ~]
%+ answer-request req
:- %o
=/ number (hex-to-num:ethereum (get-first-param req))
=/ hash (number-to-hash number)
=/ parent-hash (number-to-hash ?~(number number (dec number)))
%- malt
^- (list (pair term json))
:~ hash+s+(crip (prefix-hex:ethereum (render-hex-bytes:ethereum 32 hash)))
number+s+(crip (num-to-hex:ethereum number))
'parentHash'^s+(crip (num-to-hex:ethereum parent-hash))
==
?: =(method 'eth_getLogs')
:- | :_ [%wait ~]
%+ answer-request req
?^ (get-param-obj-maybe req 'blockHash')
%- logs-by-hash
(get-param-obj req 'blockHash')
%+ logs-by-range
(get-param-obj req 'fromBlock')
(get-param-obj req 'toBlock')
?: =(method 'eth_newFilter')
:+ |
(answer-request req s+(scot %ux next.eth-filters))
=. all.eth-filters
%+ ~(put by all.eth-filters)
next.eth-filters
:+
(get-param-obj req 'fromBlock')
(get-param-obj req 'fromBlock')
(get-param-obj req 'address')
=. next.eth-filters +(next.eth-filters)
[%cont ..stay]
?: =(method 'eth_getFilterLogs')
=/ fil (~(get by all.eth-filters) (get-filter-id req))
?~ fil
~|(%no-filter-not-implemented !!)
:+ |
%+ answer-request req
~| [eth-filters latest-block]
(logs-by-range from-block.u.fil latest-block)
=. last-block.u.fil latest-block
[%cont ..stay]
?: =(method 'eth_getFilterChanges')
=/ fil-id (get-filter-id req)
=/ fil (~(get by all.eth-filters) fil-id)
?~ fil
~|(%no-filter-not-implemented !!)
:+ |
%+ answer-request req
(logs-by-range last-block.u.fil latest-block)
=. all.eth-filters
%+ ~(put by all.eth-filters)
fil-id
u.fil(last-block latest-block)
[%cont ..stay]
~& [%ph-azimuth-miss req]
[& ~ %wait ~]
::
++ latest-block
(add launch:contracts:azimuth (dec (lent logs)))
::
++ get-id
|= req=@t
=, dejs:format
%. (need (de-json:html req))
(ot id+so ~)
::
++ get-method
|= req=@t
=, dejs:format
%. (need (de-json:html req))
(ot method+so ~)
::
++ get-param-obj
|= [req=@t param=@t]
=, dejs:format
%- hex-to-num:ethereum
=/ array
%. (need (de-json:html req))
(ot params+(ar (ot param^so ~)) ~)
?> ?=([* ~] array)
i.array
::
++ get-param-obj-maybe
|= [req=@t param=@t]
^- (unit @ud)
=, dejs-soft:format
=/ array
%. (need (de-json:html req))
(ot params+(ar (ot param^so ~)) ~)
?~ array
~
:- ~
?> ?=([* ~] u.array)
%- hex-to-num:ethereum
i.u.array
::
++ get-filter-id
|= req=@t
=, dejs:format
%- hex-to-num:ethereum
=/ id
%. (need (de-json:html req))
(ot params+(ar so) ~)
?> ?=([* ~] id)
i.id
::
++ get-first-param
|= req=@t
=, dejs:format
=/ id
%. (need (de-json:html req))
(ot params+(at so bo ~) ~)
-.id
::
++ answer-request
|= [req=@t result=json]
^- (list ph-event)
=/ resp
%- crip
%- en-json:html
%- pairs
:~ id+s+(get-id req)
jsonrpc+s+'2.0'
result+result
==
:_ ~
:* %event
who.pin
//http-client/0v1n.2m9vh
%receive
num.u.ask
[%start [200 ~] `(as-octs:mimes:html resp) &]
==
::
++ number-to-hash
|= =number:block:able:jael
^- @
?: (lth number launch:contracts:azimuth)
(cat 3 0x5364 (sub launch:contracts:azimuth number))
(cat 3 0x5363 (sub number launch:contracts:azimuth))
::
++ hash-to-number
|= =hash:block:able:jael
(add launch:contracts:azimuth (div hash 0x1.0000))
::
++ logs-by-range
|= [from-block=@ud to-block=@ud]
%+ logs-to-json (max launch:contracts:azimuth from-block)
?: (lth to-block launch:contracts:azimuth)
~
%+ swag
?: (lth from-block launch:contracts:azimuth)
[0 +((sub to-block launch:contracts:azimuth))]
:- (sub from-block launch:contracts:azimuth)
+((sub to-block from-block))
logs
::
++ logs-by-hash
|= =hash:block:able:jael
=/ =number:block:able:jael (hash-to-number hash)
(logs-by-range number number)
::
++ logs-to-json
|= [count=@ud selected-logs=(list az-log)]
^- json
:- %a
|- ^- (list json)
?~ selected-logs
~
:_ $(selected-logs t.selected-logs, count +(count))
%- pairs
:~ 'logIndex'^s+'0x0'
'transactionIndex'^s+'0x0'
:+ 'transactionHash' %s
(crip (prefix-hex:ethereum (render-hex-bytes:ethereum 32 `@`0x5362)))
::
:+ 'blockHash' %s
=/ hash (number-to-hash count)
(crip (prefix-hex:ethereum (render-hex-bytes:ethereum 32 hash)))
::
:+ 'blockNumber' %s
(crip (num-to-hex:ethereum count))
::
:+ 'address' %s
(crip (address-to-hex:ethereum azimuth:contracts:azimuth))
::
'type'^s+'mined'
::
'data'^s+data.i.selected-logs
:+ 'topics' %a
%+ turn topics.i.selected-logs
|= topic=@ux
^- json
:- %s
%- crip
%- prefix-hex:ethereum
(render-hex-bytes:ethereum 32 `@`topic)
==
--
--
::
++ raw-real-ship
|= who=ship
=/ m (ph ,~)
^- form:m
?. =(%earl (clan:title who))
(raw-ship:(ph-tests our) who `(dawn who ~))
=/ spon=ship (^sein:title who)
=/ cub (pit:nu:crub:crypto 512 (shaz (jam who life=1 %entropy)))
=/ =seed:able:jael
[who 1 sec:ex:cub ~]
=/ =pass pub:ex:cub
=/ com=tape "|moon {(scow %p who)}, =public-key {(scow %uw pass)}"
;< ~ bind:m (just-events:(ph-tests our) (dojo spon com))
(raw-ship:(ph-tests our) who `(dawn who `seed))
::
++ dawn
|= [who=ship seed=(unit seed:able:jael)]
^- dawn-event:able:jael
=/ spon=(list [ship point:azimuth])
|- ^- (list [ship point:azimuth])
=/ =ship (^sein:title who)
=/ a-point=[^ship point:azimuth]
=/ spon-spon [& (^sein:title ship)]
=/ life-rift ~|([ship lives] (~(got by lives) ship))
=/ =life lyfe.life-rift
=/ =rift rut.life-rift
=/ =pass
%^ pass-from-eth:azimuth
(as-octs:mimes:html (get-public ship life %crypt))
(as-octs:mimes:html (get-public ship life %auth))
1
:^ ship
*[address address address address]:azimuth
`[life=life pass rift spon-spon ~]
~
?: ?=(%czar (clan:title ship))
[a-point]~
[a-point $(who ship)]
=/ =seed:able:jael
?^ seed
u.seed
=/ life-rift (~(got by lives) who)
=/ =life lyfe.life-rift
[who life sec:ex:(get-keys who life) ~]
:* seed
spon
get-czars
~[~['arvo' 'netw' 'ork']]
0
`(need (de-purl:html 'http://localhost:8545'))
==
::
:: Should only do galaxies
::
++ get-czars
^- (map ship [rift life pass])
%- malt
%+ murn
~(tap by lives)
|= [who=ship lyfe=life rut=rift]
?. =(%czar (clan:title who))
~
%- some
:^ who rut lyfe
%^ pass-from-eth:azimuth
(as-octs:mimes:html (get-public who lyfe %crypt))
(as-octs:mimes:html (get-public who lyfe %auth))
1
::
++ spawn
|= who=@p
?< (~(has by lives) who)
=. lives (~(put by lives) who [1 0])
=. this-az
%- add-logs
:~ %- changed-keys:lo
:* who
(get-public who 1 %crypt)
(get-public who 1 %auth)
1
1
==
==
(spam-logs 30)
::
:: our: host ship
:: who: cycle keys
:: her: wait until hears about cycle
::
++ cycle-keys-and-hear
|= [our=@p who=@p her=@p]
=. this-az (cycle-keys who)
=/ new-lyfe lyfe:(~(got by lives) who)
=/ m (ph ,_this-az)
;< [this-az=_this-az ~] bind:m
%+ (wrap-philter ,_this-az ,~)
router:this-az
^+ *form:(ph ,~)
|= pin=ph-input
:+ & ~
=/ aqua-pax
:- %i
/(scot %p her)/j/(scot %p her)/life/(scot %da now.pin)/(scot %p who)/noun
=/ lyfe (scry-aqua noun our now.pin aqua-pax)
~& [new-lyfe=[0 new-lyfe] lyfe=lyfe]
?: =([~ new-lyfe] lyfe)
[%done ~]
[%wait ~]
(pure:m this-az)
::
++ cycle-keys
|= who=@p
=/ prev (~(got by lives) who)
=/ lyfe +(lyfe.prev)
=. lives (~(put by lives) who [lyfe rut.prev])
%- add-logs
:_ ~
%- changed-keys:lo
:* who
(get-public who lyfe %crypt)
(get-public who lyfe %auth)
1
lyfe
==
::
:: our: host ship
:: who: breachee
:: her: wait until hears about breach
::
++ breach-and-hear
|= [our=@p who=@p her=@p]
=. this-az (breach who)
=/ new-rut rut:(~(got by lives) who)
=/ m (ph ,_this-az)
;< [this-az=_this-az ~] bind:m
%+ (wrap-philter ,_this-az ,~)
router:this-az
^+ *form:(ph ,~)
|= pin=ph-input
:+ & ~
=/ aqua-pax
:- %i
/(scot %p her)/j/(scot %p her)/rift/(scot %da now.pin)/(scot %p who)/noun
=/ rut (scry-aqua noun our now.pin aqua-pax)
?: =([~ new-rut] rut)
[%done ~]
[%wait ~]
(pure:m this-az)
::
++ breach
|= who=@p
=. this-az (cycle-keys who)
=/ prev (~(got by lives) who)
=/ rut +(rut.prev)
=. lives (~(put by lives) who [lyfe.prev rut])
=. this-az
(add-logs (broke-continuity:lo who rut) ~)
(spam-logs 30)
::
++ spam-logs
|= n=@
?: =(n 0)
this-az
=. this-az ?:((~(has by lives) ~fes) (cycle-keys ~fes) (spawn ~fes))
$(n (dec n))
::
++ get-keys
|= [who=@p lyfe=life]
^- acru:ames
%+ pit:nu:crub:crypto 32
(can 5 [1 (scot %p who)] [1 (scot %ud lyfe)] ~)
::
++ get-public
|= [who=@p lyfe=life typ=?(%auth %crypt)]
=/ bod (rsh 3 1 pub:ex:(get-keys who lyfe))
=+ [enc=(rsh 8 1 bod) aut=(end 8 1 bod)]
?: =(%auth typ)
aut
enc
::
:: Generate logs
::
++ lo
=, azimuth-events:azimuth
|%
++ broke-continuity
|= [who=ship rut=rift]
^- az-log
:- ~[^broke-continuity who]
%- crip
%- prefix-hex:ethereum
(render-hex-bytes:ethereum 32 `@`rut)
::
++ changed-keys
|= [who=ship enc=@ux aut=@ux crypto=@ud lyfe=life]
^- az-log
:- ~[^changed-keys who]
%- crip
%- prefix-hex:ethereum
;: welp
(render-hex-bytes:ethereum 32 `@`enc)
(render-hex-bytes:ethereum 32 `@`aut)
(render-hex-bytes:ethereum 32 `@`crypto)
(render-hex-bytes:ethereum 32 `@`lyfe)
==
--
--

263
pkg/arvo/lib/ph/io.hoon Normal file
View File

@ -0,0 +1,263 @@
/- *aquarium, spider
/+ libstrand=strand, *strandio, util=ph-util
=, strand=strand:libstrand
|%
++ send-events
|= events=(list aqua-event)
=/ m (strand ,~)
^- form:m
(poke-our %aqua %aqua-events !>(events))
::
++ take-unix-effect
=/ m (strand ,[ship unix-effect])
^- form:m
;< [=path =cage] bind:m (take-fact-prefix /effect)
?> ?=(%aqua-effect p.cage)
(pure:m !<([aqua-effect] q.cage))
::
++ start-simple
(start-test %aqua-ames %aqua-behn %aqua-dill %aqua-eyre ~)
++ end-simple
(end-test %aqua-ames %aqua-behn %aqua-dill %aqua-eyre ~)
::
++ start-azimuth
=/ m (strand ,tid:spider)
^- form:m
;< ~ bind:m (start-test %aqua-ames %aqua-behn %aqua-dill ~)
(start-thread %aqua-eyre-azimuth)
::
++ end-azimuth
(end-test %aqua-ames %aqua-behn %aqua-dill %aqua-eyre-azimuth ~)
::
++ start-test
|= vane-threads=(list term)
=/ m (strand ,~)
^- form:m
~& > "starting"
;< ~ bind:m (start-threads vane-threads)
;< ~ bind:m (watch-our /effect %aqua /effect)
:: Get our very own event with no mistakes in it... yet.
::
:: We want to wait for the vane threads to actually start and get
:: their subscriptions started. Other ways to do this are delaying
:: the ack from spider until the build is finished (does that
:: guarantee the subscriptions have started?) or subscribe to the
:: threads themselves for a notification when they're done. This is
:: probably the best option because the thread can delay until it
:: gets a positive ack on the subscription.
::
;< ~ bind:m (sleep ~s0)
(pure:m ~)
::
++ end-test
|= vane-threads=(list term)
=/ m (strand ,~)
^- form:m
~& > "done"
;< ~ bind:m (stop-threads vane-threads)
;< ~ bind:m (leave-our /effect %aqua)
(pure:m ~)
::
++ start-threads
|= threads=(list term)
=/ m (strand ,~)
^- form:m
;< =bowl:spider bind:m get-bowl
|- ^- form:m
=* loop $
?~ threads
(pure:m ~)
=/ poke-vase !>([`tid.bowl ~ i.threads *vase])
;< ~ bind:m (poke-our %spider %spider-start poke-vase)
loop(threads t.threads)
::
++ stop-threads
|= threads=(list term)
=/ m (strand ,~)
^- form:m
(pure:m ~)
::
++ spawn
|= [=tid:spider =ship]
~& > "spawning {<ship>}"
=/ m (strand ,~)
=/ =vase !>(`input:spider`[tid %azimuth-command !>([%spawn ship])])
(poke-our %spider %spider-input vase)
::
++ breach
|= [=tid:spider who=ship]
=/ m (strand ,~)
~& > "breaching {<who>}"
=/ =vase
!>([tid %azimuth-command !>([%breach who])])
(poke-our %spider %spider-input vase)
::
:: who: breachee
:: her: wait until hears about breach
::
++ breach-and-hear
|= [=tid:spider who=ship her=ship]
=/ m (strand ,~)
~& > "breaching {<who>} for {<her>}"
;< =bowl:spider bind:m get-bowl
=/ aqua-pax
:- %i
/(scot %p her)/j/(scot %p her)/rift/(scot %da now.bowl)/(scot %p who)/noun
=/ old-rut ;;((unit @) (scry-aqua:util noun our.bowl now.bowl aqua-pax))
=/ new-rut
?~ old-rut
1
+(+.old-rut)
=/ =vase
!>([tid %azimuth-command !>([%breach who])])
;< ~ bind:m (poke-our %spider %spider-input vase)
|- ^- form:m
=* loop $
;< [him=ship =unix-effect] bind:m take-unix-effect
;< =bowl:spider bind:m get-bowl
=/ aqua-pax
:- %i
/(scot %p her)/j/(scot %p her)/rift/(scot %da now.bowl)/(scot %p who)/noun
=/ rut (scry-aqua:util noun our.bowl now.bowl aqua-pax)
?: =([~ new-rut] rut)
(pure:m ~)
loop
::
++ real-ship
|= [=tid:spider =ship]
~& > "booting real {<ship>}"
=/ m (strand ,~)
=/ =vase !>([tid %azimuth-command !>([%create-ship ship])])
;< ~ bind:m (poke-our %spider %spider-input vase)
(check-ship-booted ship)
::
++ raw-ship
|= [=ship keys=(unit dawn-event:able:jael)]
=/ m (strand ,~)
^- form:m
~& > "starting {<ship>}"
;< ~ bind:m (send-events (init:util ship keys))
(check-ship-booted ship)
::
++ check-ship-booted
|= =ship
=/ m (strand ,~)
^- form:m
=* loop $
;< [her=^ship =unix-effect] bind:m take-unix-effect
=/ f |=(=tape (is-dojo-output:util ship her unix-effect tape))
:: This is a pretty bad heuristic, but in general galaxies will
:: hit the first of these cases, and other ships will hit the
:: second.
::
?: ?| (f "clay: committed initial filesystem (all)")
(f "is your neighbor")
==
(pure:m ~)
loop
::
++ dojo
|= [=ship =tape]
=/ m (strand ,~)
^- form:m
~& > "dojo: {tape}"
(send-events (dojo:util ship tape))
::
++ wait-for-output
|= [=ship =tape]
=/ m (strand ,~)
^- form:m
~& > "waiting for output: {tape}"
|- ^- form:m
=* loop $
;< [her=^ship =unix-effect] bind:m take-unix-effect
?: (is-dojo-output:util ship her unix-effect tape)
(pure:m ~)
loop
::
:: Send "|hi" from one ship to another
::
++ send-hi
|= [from=@p to=@p]
=/ m (strand ,~)
^- form:m
;< ~ bind:m (dojo from "|hi {(scow %p to)}")
(wait-for-output from "hi {(scow %p to)} successful")
::
:: Send "|hi" and wait for "not responding" message
::
++ send-hi-not-responding
|= [from=@p to=@p]
=/ m (strand ,~)
;< ~ bind:m (dojo from "|hi {(scow %p to)}")
(wait-for-output from "{(scow %p to)} not responding still trying")
::
:: Mount a desk.
::
++ mount
|= [=ship =desk]
=/ m (strand ,~)
^- form:m
;< ~ bind:m (dojo ship "|mount /={(trip desk)}=")
|- ^- form:m
=* loop $
;< [her=^ship =unix-effect] bind:m take-unix-effect
?: (is-ergo:util ship her unix-effect)
(pure:m ~)
loop
::
:: Modify /sur/aquarium/hoon on the given ship
::
++ touch-file
|= [her=ship =desk extra=@t]
=/ m (strand ,@t)
^- form:m
~& > "touching file on {<her>}/{<desk>}"
;< ~ bind:m (mount her desk)
;< our=@p bind:m get-our
;< now=@da bind:m get-time
=/ host-pax
/(scot %p our)/home/(scot %da now)/sur/aquarium/hoon
=/ pax /sur/aquarium/hoon
=/ aqua-pax
;: weld
/i/(scot %p her)/cx/(scot %p her)/[desk]/(scot %da now)
pax
/noun
==
=/ warped
%^ cat 3 '=> . '
%^ cat 3 extra
(need (scry-aqua:util (unit @) our now aqua-pax))
;< ~ bind:m (send-events (insert-file:util her desk host-pax warped))
(pure:m warped)
::
:: Check /sur/aquarium/hoon on the given has the given contents.
::
++ check-file-touched
|= [=ship =desk warped=@t]
=/ m (strand ,~)
~& > "checking file touched on {<ship>}/{<desk>}"
;< ~ bind:m (mount ship desk)
^- form:m
|- ^- form:m
=* loop $
;< [her=^ship =unix-effect] bind:m take-unix-effect
;< our=@p bind:m get-our
;< now=@da bind:m get-time
:: %ergo is no longer sufficient because .^ is pinned to beginning of
:: the event. So we hope somebody sets a timer for something.
::
?. &(=(ship her) ?=(?(%init %ergo %doze) -.q.unix-effect))
loop
=/ pax /sur/aquarium/hoon
=/ aqua-pax
;: weld
/i/(scot %p ship)/cx/(scot %p ship)/[desk]/(scot %da now)
pax
/noun
==
?: =(warped (need (scry-aqua:util (unit @) our now aqua-pax)))
(pure:m ~)
loop
--

76
pkg/arvo/lib/ph/philter.hoon
View File

@ -1,76 +0,0 @@
:: Wrap tests in stateful philters
::
/+ ph
=, ph
|%
::
:: A philter is similar to a test in structure, but they don't
:: terminate and have a ++stay arm for saving their state.
::
:: They may be wrappped around a test with +wrap-philter.
::
++ philter
|* o=mold
|%
++ output
$~ [& ~ %wait ~]
$: thru=?
events=(list ph-event)
$= next
$% [%wait ~]
[%cont self=form]
==
==
++ form
$_ ^?
|%
++ stay *o
++ run |~(ph-input *output)
--
--
::
:: Run the inner test wrapped in the outer philter. The philter may
:: respond to any event that the test didn't consume. One use is to
:: mock outside services, like an Ethereum node or LetsEncrypt.
::
++ wrap-philter
|* [o=mold i=mold]
|= [outer=_*form:(philter o) inner=_*form:(ph i)]
^+ *form:(ph ,[o i])
|= input=ph-input
=/ res-i=_*output:(ph i)
(inner input)
?. thru.res-i
:+ thru.res-i events.res-i
?- -.next.res-i
%wait [%wait ~]
%cont [%cont ..$(inner self.next.res-i)]
%fail [%fail ~]
%done [%done stay:outer value.next.res-i]
==
=/ res-o=_*output:(philter o)
(run:outer input)
^+ *output:(ph ,[o i])
:+ thru.res-o (welp events.res-i events.res-o)
?- -.next.res-i
%wait
?- -.next.res-o
%wait [%wait ~]
%cont [%cont ..$(outer self.next.res-o)]
==
::
%cont
=. inner self.next.res-i
?- -.next.res-o
%wait [%cont ..$]
%cont [%cont ..$(outer self.next.res-o)]
==
::
%fail [%fail ~]
%done
?- -.next.res-o
%wait [%done stay:outer value.next.res-i]
%cont [%done stay:self.next.res-o value.next.res-i]
==
==
--

177
pkg/arvo/lib/ph/tests.hoon
View File

@ -1,177 +0,0 @@
:: Useful tests for testing things
::
/+ ph, ph-util
=, ph
=, ph-util
|= our=ship
::
:: Useful tests
::
|%
::
:: Never-ending test, for development.
::
++ stall
|= ph-input
[& ~ %wait ~]
::
:: Stall until you run :aqua|dojo ~ship "%go" on any ship.
::
++ please-press-enter
^+ *form:(ph ,~)
|= pin=ph-input
:+ & ~
?: (is-dojo-output who.pin who.pin uf.pin "%go")
[%done ~]
[%wait ~]
::
:: Test to produce events unconditionally.
::
++ just-events
|= events=(list ph-event)
=/ m (ph ,~)
^- form:m
|= ph-input
[& events %done ~]
::
::
::
++ wait-for-dojo
|= [her=@p what=tape]
=/ m (ph ,~)
^- form:m
|= pin=ph-input
:+ & ~
?. (is-dojo-output her who.pin uf.pin what)
[%wait ~]
[%done ~]
::
:: Boot ship; don't check it succeeded.
::
++ boot-ship
|= [her=ship keys=(unit dawn-event:able:jael)]
^+ *form:(ph ,~)
|= ph-input
[& (init her keys) %done ~]
::
:: Wait until ship has finished booting.
::
++ check-ship-booted
|= her=ship
^+ *form:(ph ,~)
|= ph-input
=; done=?
:+ & ~
?: done
[%done ~]
[%wait ~]
:: This is a pretty bad heuristic, but in general galaxies will
:: hit the first of these cases, and other ships will hit the
:: second.
::
?|
%^ is-dojo-output her who :- uf
"clay: committed initial filesystem (all)"
::
%^ is-dojo-output her who :- uf
"is your neighbor"
==
::
:: Send "|hi" from one ship to another
::
++ send-hi
|= [from=@p to=@p]
=/ m (ph ,~)
;< ~ bind:m (just-events (dojo from "|hi {(scow %p to)}"))
(wait-for-dojo from "hi {(scow %p to)} successful")
::
:: Send "|hi" and wait for "not responding" message
::
++ send-hi-not-responding
|= [from=@p to=@p]
=/ m (ph ,~)
;< ~ bind:m (just-events (dojo from "|hi {(scow %p to)}"))
(wait-for-dojo from "{(scow %p to)} not responding still trying")
::
:: Boot a ship and verify it booted. Parent must already be booted.
::
++ raw-ship
|= [her=ship keys=(unit dawn-event:able:jael)]
=/ m (ph ,~)
^- form:m
;< ~ bind:m (boot-ship her keys)
(check-ship-booted her)
::
:: Boot a fake star and its parent.
::
++ star
|= her=ship
=/ m (ph ,~)
^- form:m
;< ~ bind:m (raw-ship (^sein:title her) ~)
(raw-ship her ~)
::
:: Boot a fake planet, its parent, and its grandparent.
::
++ planet
|= her=ship
=/ m (ph ,~)
^- form:m
;< ~ bind:m (star (^sein:title her))
(raw-ship her ~)
::
:: Mount a desk.
::
++ mount
|= [her=ship des=desk]
=/ m (ph ,~)
^- form:m
;< ~ bind:m (just-events (dojo her "|mount /={(trip des)}="))
|= pin=ph-input
?: (is-ergo her who.pin uf.pin)
[& ~ %done ~]
[& ~ %wait ~]
::
:: Modify /sur/aquarium/hoon on the given ship
::
++ touch-file
|= [her=ship des=desk]
=/ m (ph ,@t)
^- form:m
;< ~ bind:m (mount her des)
|= pin=ph-input
=/ host-pax
/(scot %p our)/home/(scot %da now.pin)/sur/aquarium/hoon
=/ pax /sur/aquarium/hoon
=/ aqua-pax
;: weld
/i/(scot %p her)/cx/(scot %p her)/[des]/(scot %da now.pin)
pax
/noun
==
=/ warped
%^ cat 3 '=> . '
(need (scry-aqua (unit @) our now.pin aqua-pax))
[& (insert-file her des host-pax warped) %done warped]
::
:: Check /sur/aquarium/hoon on the given has the given contents.
::
++ check-file-touched
|= [her=ship des=desk warped=@t]
=/ m (ph ,~)
;< ~ bind:m (mount her des)
^- form:m
|= pin=ph-input
?. &(=(her who.pin) ?=(?(%init %ergo) -.q.uf.pin))
[& ~ %wait ~]
=/ pax /sur/aquarium/hoon
=/ aqua-pax
;: weld
/i/(scot %p her)/cx/(scot %p her)/[des]/(scot %da now.pin)
pax
/noun
==
?: =(warped (need (scry-aqua (unit @) our now.pin aqua-pax)))
[& ~ %done ~]
[& ~ %wait ~]
--

Some files were not shown because too many files have changed in this diff Show More