mirror of
https://github.com/ilyakooo0/urbit.git
synced 2024-11-28 19:55:53 +03:00
mall: rm old apps for easier merging
This commit is contained in:
Philip Monk
parent
bcd7c5e82d
commit
ae295d445a
@ -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]
|
||||
--
|
||||
@ -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
|
||||
--
|
||||
--
|
||||
@ -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
|
||||
--
|
||||
@ -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
|
||||
--
|
||||
--
|
||||
@ -1,577 +0,0 @@
|
||||
:: An aquarium of virtual ships. Put in some fish and watch them!
|
||||
::
|
||||
:: usage:
|
||||
:: |start %aqua
|
||||
:: /- aquarium
|
||||
:: :aqua &pill .^(pill:aquarium %cx %/urbit/pill)
|
||||
:: OR
|
||||
:: :aqua &pill +solid
|
||||
::
|
||||
:: Then try stuff:
|
||||
:: :aqua [%init ~[~bud ~dev]]
|
||||
:: :aqua [%dojo ~[~bud ~dev] "[our eny (add 3 5)]"]
|
||||
:: :aqua [%dojo ~[~bud] "|hi ~dev"]
|
||||
:: :aqua [%wish ~[~bud ~dev] '(add 2 3)']
|
||||
:: :aqua [%peek ~[~bud] /cx/~bud/home/(scot %da now)/app/curl/hoon]
|
||||
:: :aqua [%dojo ~[~bud ~dev] '|mount %']
|
||||
:: :aqua [%file ~[~bud ~dev] %/sys/vane]
|
||||
:: :aqua [%pause-events ~[~bud ~dev]]
|
||||
::
|
||||
::
|
||||
:: We get ++unix-event and ++pill from /-aquarium
|
||||
::
|
||||
/- aquarium
|
||||
/+ pill
|
||||
=, 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
|
||||
assembled=*
|
||||
tym=@da
|
||||
fleet-snaps=(map term (map ship pier))
|
||||
piers=(map ship pier)
|
||||
==
|
||||
::
|
||||
+$ pier
|
||||
$: snap=*
|
||||
event-log=(list unix-timed-event)
|
||||
next-events=(qeu unix-event)
|
||||
processing-events=?
|
||||
==
|
||||
--
|
||||
=, gall
|
||||
::
|
||||
:: unix-{effects,events,boths}: collect jar of effects and events to
|
||||
:: brodcast all at once to avoid gall backpressure
|
||||
:: moves: Hoist moves into state for cleaner state management
|
||||
::
|
||||
=| 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
|
||||
==
|
||||
::
|
||||
:: Represents a single ship's state.
|
||||
::
|
||||
++ pe
|
||||
|= who=ship
|
||||
=+ (~(gut by piers) who *pier)
|
||||
=* pier-data -
|
||||
|%
|
||||
::
|
||||
:: Done; install data
|
||||
::
|
||||
++ abet-pe
|
||||
^+ this
|
||||
=. piers (~(put by piers) who pier-data)
|
||||
this
|
||||
::
|
||||
:: Initialize new ship
|
||||
::
|
||||
++ apex
|
||||
=. pier-data *pier
|
||||
=. snap assembled
|
||||
~& pill-size=(met 3 (jam snap))
|
||||
..abet-pe
|
||||
::
|
||||
:: Enqueue events to child arvo
|
||||
::
|
||||
++ push-events
|
||||
|= ues=(list unix-event)
|
||||
^+ ..abet-pe
|
||||
=. next-events (~(gas to next-events) ues)
|
||||
..abet-pe
|
||||
::
|
||||
:: Send moves to host arvo
|
||||
::
|
||||
++ emit-moves
|
||||
|= ms=(list move)
|
||||
=. this (^emit-moves ms)
|
||||
..abet-pe
|
||||
::
|
||||
:: Process the events in our queue.
|
||||
::
|
||||
++ plow
|
||||
|- ^+ ..abet-pe
|
||||
?: =(~ next-events)
|
||||
..abet-pe
|
||||
?. processing-events
|
||||
..abet-pe
|
||||
=^ ue next-events ~(get to next-events)
|
||||
=/ poke-arm (mox +47.snap)
|
||||
?> ?=(%0 -.poke-arm)
|
||||
=/ poke p.poke-arm
|
||||
=. tym (max +(tym) now.hid)
|
||||
=/ poke-result (mule |.((slum poke tym ue)))
|
||||
?: ?=(%| -.poke-result)
|
||||
%- (slog >%aqua-crash< >guest=who< p.poke-result)
|
||||
$
|
||||
=. snap +.p.poke-result
|
||||
=. ..abet-pe (publish-event tym ue)
|
||||
=. ..abet-pe (handle-effects ((list ovum) -.p.poke-result))
|
||||
$
|
||||
::
|
||||
:: Peek
|
||||
::
|
||||
++ peek
|
||||
|= p=*
|
||||
=/ res (mox +46.snap)
|
||||
?> ?=(%0 -.res)
|
||||
=/ peek p.res
|
||||
=/ pax (path p)
|
||||
?> ?=([@ @ @ @ *] pax)
|
||||
=. i.t.t.t.pax (scot %da tym)
|
||||
=/ pek (slum peek [tym pax])
|
||||
pek
|
||||
::
|
||||
:: Wish
|
||||
::
|
||||
++ wish
|
||||
|= txt=@t
|
||||
=/ res (mox +22.snap)
|
||||
?> ?=(%0 -.res)
|
||||
=/ wish p.res
|
||||
~& [who=who %wished (slum wish txt)]
|
||||
..abet-pe
|
||||
::
|
||||
++ mox |=(* (mock [snap +<] scry))
|
||||
::
|
||||
:: Start/stop processing events. When stopped, events are added to
|
||||
:: our queue but not processed.
|
||||
::
|
||||
++ start-processing-events .(processing-events &)
|
||||
++ stop-processing-events .(processing-events |)
|
||||
::
|
||||
:: Handle all the effects produced by a single event.
|
||||
::
|
||||
++ handle-effects
|
||||
|= effects=(list ovum)
|
||||
^+ ..abet-pe
|
||||
?~ effects
|
||||
..abet-pe
|
||||
=. ..abet-pe
|
||||
=/ sof ((soft unix-effect) i.effects)
|
||||
?~ sof
|
||||
~? aqua-debug=& [who=who %unknown-effect i.effects]
|
||||
..abet-pe
|
||||
(publish-effect u.sof)
|
||||
$(effects t.effects)
|
||||
::
|
||||
:: Give effect to our subscribers
|
||||
::
|
||||
++ publish-effect
|
||||
|= uf=unix-effect
|
||||
^+ ..abet-pe
|
||||
=. unix-effects (~(add ja unix-effects) who uf)
|
||||
=. unix-boths (~(add ja unix-boths) who [%effect uf])
|
||||
..abet-pe
|
||||
::
|
||||
:: Give event to our subscribers
|
||||
::
|
||||
++ publish-event
|
||||
|= ute=unix-timed-event
|
||||
^+ ..abet-pe
|
||||
=. event-log [ute event-log]
|
||||
=. unix-events (~(add ja unix-events) who ute)
|
||||
=. unix-boths (~(add ja unix-boths) who [%event ute])
|
||||
..abet-pe
|
||||
--
|
||||
::
|
||||
++ this .
|
||||
::
|
||||
:: ++apex-aqua and ++abet-aqua must bookend calls from gall
|
||||
::
|
||||
++ apex-aqua
|
||||
^+ this
|
||||
=: moves ~
|
||||
unix-effects ~
|
||||
unix-events ~
|
||||
unix-boths ~
|
||||
==
|
||||
this
|
||||
::
|
||||
++ abet-aqua
|
||||
^- (quip move _this)
|
||||
=. 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)]~
|
||||
==
|
||||
[(flop moves) this]
|
||||
::
|
||||
++ emit-moves
|
||||
|= ms=(list move)
|
||||
=. moves (weld ms moves)
|
||||
this
|
||||
::
|
||||
::
|
||||
:: Run all events on all ships until all queues are empty
|
||||
::
|
||||
++ plow-all
|
||||
|- ^+ this
|
||||
=/ who
|
||||
=/ pers ~(tap by piers)
|
||||
|- ^- (unit ship)
|
||||
?~ pers
|
||||
~
|
||||
?: &(?=(^ next-events.q.i.pers) processing-events.q.i.pers)
|
||||
`p.i.pers
|
||||
$(pers t.pers)
|
||||
~? aqua-debug=| plowing=who
|
||||
?~ who
|
||||
this
|
||||
=. 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)
|
||||
=. this apex-aqua =< abet-aqua
|
||||
=. pil p
|
||||
~& lent=(met 3 (jam boot-ova.pil))
|
||||
=/ res=toon :: (each * (list tank))
|
||||
(mock [boot-ova.pil [2 [0 3] [0 2]]] scry)
|
||||
=. fleet-snaps ~
|
||||
?- -.res
|
||||
%0
|
||||
~& %suc
|
||||
=. assembled +7.p.res
|
||||
this
|
||||
::
|
||||
%1
|
||||
~& [%vere-blocked p.res]
|
||||
this
|
||||
::
|
||||
%2
|
||||
~& %vere-fail
|
||||
%- (slog p.res)
|
||||
this
|
||||
==
|
||||
::
|
||||
:: Handle commands from CLI
|
||||
::
|
||||
:: Should put some thought into arg structure, maybe make a mark.
|
||||
::
|
||||
:: Should convert some of these to just rewrite into ++poke-events.
|
||||
::
|
||||
++ poke-noun
|
||||
|= val=*
|
||||
^- (quip move _this)
|
||||
=. this apex-aqua =< abet-aqua
|
||||
^+ this
|
||||
:: Could potentially factor out the three lines of turn-ships
|
||||
:: boilerplate
|
||||
::
|
||||
?+ val ~|(%bad-noun-arg !!)
|
||||
[%swap-vanes vs=*]
|
||||
?> ?=([[%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
|
||||
=/ vane
|
||||
?+ v ~|([%unknown-vane v] !!)
|
||||
%a %ames
|
||||
%b %behn
|
||||
%c %clay
|
||||
%d %dill
|
||||
%e %eyre
|
||||
%f %ford
|
||||
%g %gall
|
||||
%j %jael
|
||||
%m %mall
|
||||
==
|
||||
=/ 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)
|
||||
::
|
||||
[%swap-files ~]
|
||||
=. userspace-ova.pil
|
||||
=/ slim-dirs=(list path)
|
||||
~[/app /gen /lib /mar /sur /hoon/sys /arvo/sys /zuse/sys /age]
|
||||
:_ ~
|
||||
%- 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)
|
||||
::
|
||||
[%wish hers=* p=@t]
|
||||
%+ turn-ships ((list ship) hers.val)
|
||||
|= [who=ship thus=_this]
|
||||
=. this thus
|
||||
(wish:(pe who) p.val)
|
||||
::
|
||||
[%unpause-events hers=*]
|
||||
%+ turn-ships ((list ship) hers.val)
|
||||
|= [who=ship thus=_this]
|
||||
=. this thus
|
||||
start-processing-events:(pe who)
|
||||
::
|
||||
[%pause-events hers=*]
|
||||
%+ turn-ships ((list ship) hers.val)
|
||||
|= [who=ship thus=_this]
|
||||
=. this thus
|
||||
stop-processing-events:(pe who)
|
||||
::
|
||||
[%clear-snap lab=@tas]
|
||||
=. fleet-snaps ~ :: (~(del by fleet-snaps) lab.val)
|
||||
this
|
||||
==
|
||||
::
|
||||
:: Apply a list of events tagged by ship
|
||||
::
|
||||
++ poke-aqua-events
|
||||
|= events=(list aqua-event)
|
||||
^- (quip move _this)
|
||||
=. this apex-aqua =< abet-aqua
|
||||
%+ turn-events events
|
||||
|= [ae=aqua-event thus=_this]
|
||||
=. this thus
|
||||
?- -.ae
|
||||
%init-ship
|
||||
=. this abet-pe:(publish-effect:(pe who.ae) [/ %sleep ~])
|
||||
=/ initted
|
||||
=< plow
|
||||
%- push-events:apex:(pe who.ae)
|
||||
^- (list unix-event)
|
||||
:~ [/ %wack 0] :: eny
|
||||
[/ %whom who.ae] :: eny
|
||||
[//newt/0v1n.2m9vh %barn ~]
|
||||
[//behn/0v1n.2m9vh %born ~]
|
||||
:^ //term/1 %boot &
|
||||
?~ keys.ae
|
||||
[%fake who.ae]
|
||||
[%dawn u.keys.ae]
|
||||
-.userspace-ova.pil
|
||||
[//http-client/0v1n.2m9vh %born ~]
|
||||
[//http-server/0v1n.2m9vh %born ~]
|
||||
[//http-server/0v1n.2m9vh %live 8.080 `8.445]
|
||||
==
|
||||
=. this abet-pe:initted
|
||||
(pe who.ae)
|
||||
::
|
||||
%pause-events
|
||||
stop-processing-events:(pe who.ae)
|
||||
::
|
||||
%snap-ships
|
||||
=. fleet-snaps
|
||||
%+ ~(put by fleet-snaps) lab.ae
|
||||
%- malt
|
||||
%+ murn hers.ae
|
||||
|= her=ship
|
||||
^- (unit (pair ship pier))
|
||||
=+ per=(~(get by piers) her)
|
||||
?~ per
|
||||
~
|
||||
`[her u.per]
|
||||
(pe -.hers.ae)
|
||||
::
|
||||
%restore-snap
|
||||
=. this
|
||||
%+ turn-ships (turn ~(tap by piers) head)
|
||||
|= [who=ship thus=_this]
|
||||
=. this thus
|
||||
(publish-effect:(pe who) [/ %sleep ~])
|
||||
=. piers (~(uni by piers) (~(got by fleet-snaps) lab.ae))
|
||||
=. this
|
||||
%+ turn-ships (turn ~(tap by piers) head)
|
||||
|= [who=ship thus=_this]
|
||||
=. this thus
|
||||
(publish-effect:(pe who) [/ %restore ~])
|
||||
(pe ~bud) :: XX why ~bud? need an example
|
||||
::
|
||||
%event
|
||||
~? &(aqua-debug=| !?=(?(%belt %hear) -.q.ue.ae))
|
||||
raw-event=[who.ae -.q.ue.ae]
|
||||
~? &(debug=| ?=(%receive -.q.ue.ae))
|
||||
raw-event=[who.ae ue.ae]
|
||||
(push-events:(pe who.ae) [ue.ae]~)
|
||||
==
|
||||
::
|
||||
:: Run a callback function against a list of ships, aggregating state
|
||||
:: and plowing all ships at the end.
|
||||
::
|
||||
:: I think we should use patterns like this more often. Because we
|
||||
:: don't, here's some points to be aware.
|
||||
::
|
||||
:: `fun` must take `this` as a parameter, since it needs to be
|
||||
:: downstream of previous state changes. You could use `state` as
|
||||
:: the state variable, but it muddles the code and it's not clear
|
||||
:: whether it's better. You could use the `_(pe)` core if you're
|
||||
:: sure you'll never need to refer to anything outside of your pier,
|
||||
:: but I don't think we can guarantee that.
|
||||
::
|
||||
:: The callback function must start with `=. this thus`, or else
|
||||
:: you don't get the new state. Would be great if you could hot-swap
|
||||
:: that context in here, but we don't know where to put it unless we
|
||||
:: restrict the callbacks to always have `this` at a particular axis,
|
||||
:: and that doesn't feel right
|
||||
::
|
||||
++ turn-plow
|
||||
|* arg=mold
|
||||
|= [hers=(list arg) fun=$-([arg _this] _(pe))]
|
||||
|- ^+ this
|
||||
?~ hers
|
||||
plow-all
|
||||
=. this
|
||||
abet-pe:plow:(fun i.hers this)
|
||||
$(hers t.hers, this this)
|
||||
::
|
||||
++ turn-ships (turn-plow ship)
|
||||
++ turn-events (turn-plow aqua-event)
|
||||
::
|
||||
:: 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
|
||||
::
|
||||
:: 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)
|
||||
--
|
||||
@ -1,231 +0,0 @@
|
||||
/- eth-watcher
|
||||
/+ tapp, stdio
|
||||
=, 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
|
||||
::
|
||||
:- => 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) ,@) ~]
|
||||
::
|
||||
++ 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)
|
||||
--
|
||||
::
|
||||
:: 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
|
||||
::
|
||||
;< ~ bind:m
|
||||
%+ peer-app:stdio
|
||||
[our.bowl %eth-watcher]
|
||||
/logs/[dap.bowl]
|
||||
(pure:m state)
|
||||
::
|
||||
++ handle-peek handle-peek:default-tapp
|
||||
++ handle-take handle-take:default-tapp
|
||||
::
|
||||
++ 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)
|
||||
==
|
||||
::
|
||||
++ 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)
|
||||
==
|
||||
(pure:m state)
|
||||
::
|
||||
:: +handle-peer: handle incoming subscriptions (generally from jael)
|
||||
::
|
||||
:: /~some-ship: listen to events for this ship
|
||||
:: /: listen to events for all ships azimuth-tracker is observing
|
||||
::
|
||||
:: note that incoming subscriptions affect application state.
|
||||
::
|
||||
++ handle-peer
|
||||
|= =path
|
||||
=/ m tapp-async
|
||||
^- form:m
|
||||
?. ?=(?(~ [@ ~]) path) !!
|
||||
=/ who=(unit ship)
|
||||
?~ path ~
|
||||
`(slav %p i.path)
|
||||
=. whos.state
|
||||
?~ who
|
||||
~
|
||||
(~(put in whos.state) u.who)
|
||||
(start state [our dap]:bowl)
|
||||
--
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,234 +0,0 @@
|
||||
:: chat-store: data store that holds linear sequences of chat messages
|
||||
::
|
||||
/+ *chat-json, *chat-eval
|
||||
|%
|
||||
+$ move [bone card]
|
||||
::
|
||||
+$ card
|
||||
$% [%diff diff]
|
||||
[%quit ~]
|
||||
==
|
||||
::
|
||||
+$ state
|
||||
$% [%0 state-zero]
|
||||
==
|
||||
::
|
||||
+$ state-zero
|
||||
$: =inbox
|
||||
==
|
||||
::
|
||||
+$ diff
|
||||
$% [%chat-initial inbox]
|
||||
[%chat-configs chat-configs]
|
||||
[%chat-update chat-update]
|
||||
==
|
||||
--
|
||||
::
|
||||
|_ [bol=bowl:gall state]
|
||||
::
|
||||
++ 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
|
||||
::
|
||||
++ peek-x-envelopes
|
||||
|= pax=path
|
||||
^- (unit (unit [%noun (list envelope)]))
|
||||
?+ pax ~
|
||||
[@ @ *]
|
||||
=/ mail-path t.t.pax
|
||||
=/ mailbox (~(get by inbox) mail-path)
|
||||
?~ mailbox
|
||||
[~ ~ %noun ~]
|
||||
=* envelopes envelopes.u.mailbox
|
||||
=/ sign-test=[?(%neg %pos) @]
|
||||
%- need
|
||||
%+ rush i.pax
|
||||
;~ pose
|
||||
%+ cook
|
||||
|= n=@
|
||||
[%neg n]
|
||||
;~(pfix hep dem:ag)
|
||||
::
|
||||
%+ cook
|
||||
|= n=@
|
||||
[%pos n]
|
||||
dem:ag
|
||||
==
|
||||
=* length length.config.u.mailbox
|
||||
=* start +.sign-test
|
||||
?: =(-.sign-test %neg)
|
||||
?: (gth start length)
|
||||
[~ ~ %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)]
|
||||
==
|
||||
::
|
||||
++ 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)
|
||||
(poke-chat-action (json-to-action jon))
|
||||
::
|
||||
++ poke-chat-action
|
||||
|= action=chat-action
|
||||
^- (quip move _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
?- -.action
|
||||
%create (handle-create action)
|
||||
%delete (handle-delete action)
|
||||
%message (handle-message action)
|
||||
%read (handle-read action)
|
||||
==
|
||||
::
|
||||
++ handle-create
|
||||
|= act=chat-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%create -.act)
|
||||
=/ pax [(scot %p ship.act) path.act]
|
||||
?: (~(has by inbox) pax)
|
||||
[~ this]
|
||||
:- (send-diff pax act)
|
||||
this(inbox (~(put by inbox) pax *mailbox))
|
||||
::
|
||||
++ handle-delete
|
||||
|= act=chat-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%delete -.act)
|
||||
=/ mailbox=(unit mailbox) (~(get by inbox) path.act)
|
||||
?~ mailbox
|
||||
[~ this]
|
||||
:- (send-diff path.act act)
|
||||
this(inbox (~(del by inbox) path.act))
|
||||
::
|
||||
++ handle-message
|
||||
|= act=chat-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%message -.act)
|
||||
=/ mailbox=(unit mailbox) (~(get by inbox) path.act)
|
||||
?~ mailbox
|
||||
[~ this]
|
||||
=* letter letter.envelope.act
|
||||
=? letter &(?=(%code -.letter) ?=(~ output.letter))
|
||||
=/ =hoon (ream expression.letter)
|
||||
letter(output (eval bol hoon))
|
||||
=: length.config.u.mailbox +(length.config.u.mailbox)
|
||||
number.envelope.act +(length.config.u.mailbox)
|
||||
envelopes.u.mailbox (snoc envelopes.u.mailbox envelope.act)
|
||||
==
|
||||
:- (send-diff path.act act)
|
||||
this(inbox (~(put by inbox) path.act u.mailbox))
|
||||
::
|
||||
++ handle-read
|
||||
|= act=chat-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%read -.act)
|
||||
=/ mailbox=(unit mailbox) (~(get by inbox) path.act)
|
||||
?~ mailbox
|
||||
[~ this]
|
||||
=. read.config.u.mailbox length.config.u.mailbox
|
||||
:- (send-diff path.act act)
|
||||
this(inbox (~(put by inbox) path.act u.mailbox))
|
||||
::
|
||||
++ update-subscribers
|
||||
|= [pax=path act=chat-action]
|
||||
^- (list move)
|
||||
%+ turn (prey:pubsub:userlib pax bol)
|
||||
|= [=bone *]
|
||||
[bone %diff %chat-update act]
|
||||
::
|
||||
++ send-diff
|
||||
|= [pax=path act=chat-action]
|
||||
^- (list move)
|
||||
%- zing
|
||||
:~ (update-subscribers /all act)
|
||||
(update-subscribers /updates act)
|
||||
(update-subscribers [%mailbox pax] act)
|
||||
?. |(=(%read -.act) =(%message -.act))
|
||||
~
|
||||
(update-subscribers /configs act)
|
||||
?. |(=(%create -.act) =(%delete -.act))
|
||||
~
|
||||
(update-subscribers /keys act)
|
||||
==
|
||||
::
|
||||
--
|
||||
@ -1,80 +0,0 @@
|
||||
/+ *server
|
||||
/= tile-js
|
||||
/^ octs
|
||||
/; as-octs:mimes:html
|
||||
/: /===/app/clock/js/tile
|
||||
/| /js/
|
||||
/~ ~
|
||||
==
|
||||
=, format
|
||||
::
|
||||
|%
|
||||
:: +move: output effect
|
||||
::
|
||||
+$ 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)
|
||||
=/ launcha
|
||||
[%launch-action [%clock /tile '/~clock/js/tile.js']]
|
||||
:_ this
|
||||
:~
|
||||
[ost.bol %connect / [~ /'~clock'] %clock]
|
||||
[ost.bol %poke /clock [our.bol %launch] 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)
|
||||
|= =inbound-request:eyre
|
||||
^- (quip move _this)
|
||||
=/ request-line (parse-request-line url.request.inbound-request)
|
||||
=/ back-path (flop site.request-line)
|
||||
=/ name=@t
|
||||
=/ back-path (flop site.request-line)
|
||||
?~ back-path
|
||||
''
|
||||
i.back-path
|
||||
::
|
||||
?~ back-path
|
||||
[[ost.bol %http-response not-found:app]~ this]
|
||||
?: =(name 'tile')
|
||||
[[ost.bol %http-response (js-response:app tile-js)]~ this]
|
||||
[[ost.bol %http-response not-found:app]~ this]
|
||||
::
|
||||
--
|
||||
@ -1,174 +0,0 @@
|
||||
/- dns
|
||||
::
|
||||
:: app types and boilerplate
|
||||
::
|
||||
=> |%
|
||||
+$ app-state
|
||||
$: %0
|
||||
requested=(map ship address:dns)
|
||||
completed=(map ship binding:dns)
|
||||
==
|
||||
+$ peek-data
|
||||
$% [%requested (list (pair ship address:dns))]
|
||||
[%completed (list (pair ship binding:dns))]
|
||||
==
|
||||
+$ in-poke-data
|
||||
$% [%dns-address =address:dns]
|
||||
[%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]
|
||||
::
|
||||
++ prep
|
||||
|= old=(unit app-state)
|
||||
^- (quip move _this)
|
||||
=< abet
|
||||
?~ old
|
||||
(poke-app /unlink [[our %hood] [%drum-unlink our dap]]:bowl)
|
||||
this(state u.old)
|
||||
::
|
||||
++ poke
|
||||
|= =in-poke-data
|
||||
^- (quip move _this)
|
||||
=< abet
|
||||
?- -.in-poke-data
|
||||
%noun
|
||||
?: ?=(%debug noun.in-poke-data)
|
||||
~& bowl
|
||||
~& state
|
||||
this
|
||||
::
|
||||
~& %poke-unknown
|
||||
this
|
||||
::
|
||||
%dns-address
|
||||
=* who src.bowl
|
||||
=* adr address.in-poke-data
|
||||
=/ rac (clan:title who)
|
||||
?. ?=(?(%king %duke) rac)
|
||||
~| [%dns-collector-bind-invalid who] !!
|
||||
?: (reserved:eyre if.adr)
|
||||
~| [%dns-collector-reserved-address who if.adr] !!
|
||||
::
|
||||
=/ req=(unit address:dns) (~(get by requested.state) who)
|
||||
=/ 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)
|
||||
::
|
||||
?: &(?=(^ req) =(adr u.req))
|
||||
this
|
||||
:: XX check address?
|
||||
=/ =request:dns [who adr]
|
||||
=. requested.state (~(put by requested.state) request)
|
||||
(give-result /requests %dns-request request)
|
||||
::
|
||||
%dns-complete
|
||||
:: 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
|
||||
=/ req=(unit address:dns) (~(get by requested.state) who)
|
||||
:: ignore established bindings that don't match requested
|
||||
::
|
||||
?: ?| ?=(~ req)
|
||||
!=(adr u.req)
|
||||
==
|
||||
~& %unknown-complete
|
||||
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)
|
||||
==
|
||||
::
|
||||
++ peek
|
||||
|= =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
|
||||
::
|
||||
?: ?=([%sole *] path)
|
||||
this
|
||||
?. ?=([@ ~] path)
|
||||
~| %invalid-path !!
|
||||
?: ?=(%requests i.path)
|
||||
=/ requests ~(tap by requested.state)
|
||||
|- ^+ this
|
||||
=* loop $
|
||||
?~ requests
|
||||
this
|
||||
=. ..this (give-result path %dns-request i.requests)
|
||||
loop(requests t.requests)
|
||||
::
|
||||
=/ 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)
|
||||
--
|
||||
@ -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)
|
||||
==
|
||||
--
|
||||
File diff suppressed because it is too large
Load Diff
@ -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)
|
||||
--
|
||||
@ -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)
|
||||
--
|
||||
@ -1,205 +0,0 @@
|
||||
:: :: ::
|
||||
:::: /hoon/hood/app :: ::
|
||||
:: :: ::
|
||||
/? 310 :: zuse version
|
||||
/+ sole, :: libraries
|
||||
:: XX these should really be separate apps, as
|
||||
:: none of them interact with each other in
|
||||
:: any fashion; however, to reduce boot-time
|
||||
:: complexity and work around the current
|
||||
:: non-functionality of end-to-end acknowledgments,
|
||||
:: they have been bundled into :hood
|
||||
::
|
||||
:: |command handlers
|
||||
hood-helm, hood-kiln, hood-drum, hood-write
|
||||
:: :: ::
|
||||
:::: :: ::
|
||||
:: :: ::
|
||||
|%
|
||||
++ hood-module
|
||||
:: each hood module follows this general shape
|
||||
=> |%
|
||||
+$ part [%module %0 pith]
|
||||
+$ pith ~
|
||||
::
|
||||
+$ move [bone card]
|
||||
+$ card $% [%fake ~]
|
||||
==
|
||||
--
|
||||
|= [bowl:gall own=part]
|
||||
|_ moz=(list move)
|
||||
++ abet [(flop moz) own]
|
||||
--
|
||||
--
|
||||
:: :: ::
|
||||
:::: :: :: state handling
|
||||
:: :: ::
|
||||
!:
|
||||
=> |% ::
|
||||
++ hood-old :: unified old-state
|
||||
{?($0 $1) lac/(map @tas hood-part-old)} ::
|
||||
++ hood-1 :: unified state
|
||||
{$1 lac/(map @tas hood-part)} ::
|
||||
++ hood-good :: extract specific
|
||||
=+ hed=$:hood-head
|
||||
|@ ++ $
|
||||
|: paw=$:hood-part
|
||||
?- hed
|
||||
$drum ?>(?=($drum -.paw) `part:hood-drum`paw)
|
||||
$helm ?>(?=($helm -.paw) `part:hood-helm`paw)
|
||||
$kiln ?>(?=($kiln -.paw) `part:hood-kiln`paw)
|
||||
$write ?>(?=($write -.paw) `part:hood-write`paw)
|
||||
==
|
||||
--
|
||||
++ hood-head _-:$:hood-part :: initialize state
|
||||
++ hood-make ::
|
||||
=+ $:{our/@p hed/hood-head} ::
|
||||
|@ ++ $
|
||||
?- hed
|
||||
$drum (make:hood-drum our)
|
||||
$helm *part:hood-helm
|
||||
$kiln *part:hood-kiln
|
||||
$write *part:hood-write
|
||||
==
|
||||
--
|
||||
++ hood-part-old hood-part :: old state for ++prep
|
||||
++ hood-port :: state transition
|
||||
|: paw=$:hood-part-old ^- hood-part ::
|
||||
paw ::
|
||||
:: ::
|
||||
++ hood-part :: current module state
|
||||
$% {$drum $2 pith-2:hood-drum} ::
|
||||
{$helm $0 pith:hood-helm} ::
|
||||
{$kiln $0 pith:hood-kiln} ::
|
||||
{$write $0 pith:hood-write} ::
|
||||
== ::
|
||||
-- ::
|
||||
:: :: ::
|
||||
:::: :: :: 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)
|
||||
--
|
||||
::
|
||||
++ 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))
|
||||
::
|
||||
++ poke-hood-load :: recover lost brain
|
||||
|= dat/hood-part
|
||||
?> =(our.hid src.hid)
|
||||
~& loaded+-.dat
|
||||
[~ %_(+> lac (~(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))
|
||||
(ably (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))
|
||||
::
|
||||
:: :: ::
|
||||
:::: :: :: 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-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
|
||||
--
|
||||
@ -1,615 +0,0 @@
|
||||
:: Test the pH of your aquarium. See if it's safe to put in real fish.
|
||||
::
|
||||
:: usage:
|
||||
:: :aqua [%run-test %test-add]
|
||||
::
|
||||
/- 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
|
||||
`+>.$
|
||||
--
|
||||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user