mirror of
https://github.com/urbit/shrub.git
synced 2024-12-22 18:31:44 +03:00
3259f1f588
Small touch-ups to simulation behavior and ph tests. Most of them pass now, even if they're still really slow at times. The breach ones don't pass, but also complain of dangling bone, so might work once the fix for that is in.
298 lines
7.7 KiB
Plaintext
298 lines
7.7 KiB
Plaintext
/- *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))
|
|
::
|
|
++ send-azimuth-action
|
|
|= =azimuth-action
|
|
=/ m (strand ,~)
|
|
^- form:m
|
|
(poke-our %aqua %azimuth-action !>(azimuth-action))
|
|
::
|
|
++ 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 ~)
|
|
::
|
|
++ start-azimuth
|
|
=/ m (strand ,~)
|
|
^- form:m
|
|
;<(~ bind:m start-simple init)
|
|
::
|
|
++ end
|
|
(end-test %aqua-ames %aqua-behn %aqua-dill %aqua-eyre ~)
|
|
::
|
|
++ start-test
|
|
|= vane-threads=(list term)
|
|
=/ m (strand ,~)
|
|
^- form:m
|
|
~& > "starting"
|
|
;< tids=(map term tid:spider) 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.
|
|
::
|
|
:: Threads might not get built until a %writ is dripped back to
|
|
:: spider. Drips are at +(now), so we sleep until two clicks in the
|
|
:: future.
|
|
::
|
|
;< ~ bind:m (sleep `@dr`2)
|
|
(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 ,(map term tid:spider))
|
|
^- form:m
|
|
;< =bowl:spider bind:m get-bowl
|
|
=| tids=(map term tid:spider)
|
|
|- ^- form:m
|
|
=* loop $
|
|
?~ threads
|
|
(pure:m tids)
|
|
=/ tid
|
|
%+ scot %ta
|
|
(cat 3 (cat 3 'strand_' i.threads) (scot %uv (sham i.threads eny.bowl)))
|
|
=/ poke-vase !>([`tid.bowl ~ byk.bowl i.threads *vase])
|
|
;< ~ bind:m (poke-our %spider %spider-start poke-vase)
|
|
loop(threads t.threads, tids (~(put by tids) i.threads tid))
|
|
::
|
|
++ stop-threads
|
|
|= threads=(list term)
|
|
=/ m (strand ,~)
|
|
^- form:m
|
|
(pure:m ~)
|
|
::
|
|
::
|
|
++ init
|
|
=/ m (strand ,~)
|
|
^- form:m
|
|
(send-azimuth-action %init-azimuth ~)
|
|
::
|
|
++ spawn
|
|
|= =ship
|
|
~& > "spawning {<ship>}"
|
|
=/ m (strand ,~)
|
|
^- form:m
|
|
(send-azimuth-action %spawn ship)
|
|
::
|
|
++ breach
|
|
|= =ship
|
|
~& > "breaching {<ship>}"
|
|
=/ m (strand ,~)
|
|
^- form:m
|
|
(send-azimuth-action %breach ship)
|
|
::
|
|
:: who: breachee
|
|
:: her: wait until hears about breach
|
|
::
|
|
++ breach-and-hear
|
|
|= [who=ship her=ship]
|
|
~& > "breaching {<who>} for {<her>}"
|
|
=/ m (strand ,~)
|
|
;< =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)
|
|
;< ~ bind:m (send-azimuth-action %breach who)
|
|
|- ^- form:m
|
|
=* loop $
|
|
;< ~ bind:m (sleep ~s10)
|
|
;< =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
|
|
::
|
|
++ init-ship
|
|
|= [=ship fake=?]
|
|
=/ m (strand ,~)
|
|
^- form:m
|
|
~& > "starting {<ship>}"
|
|
;< ~ bind:m (send-events (init:util ship fake))
|
|
(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 ":dojo>")
|
|
(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]
|
|
~& > 'sending hi not responding'
|
|
=/ 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
|
|
(touch her desk /sur/aquarium/hoon extra)
|
|
::
|
|
:: Modify path on the given ship
|
|
::
|
|
++ touch
|
|
|= [her=ship =desk pax=path 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
|
|
=/ 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-files:util her desk [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 ,~)
|
|
(check-touched ship desk /sur/aquarium/hoon warped)
|
|
::
|
|
:: Check path on the given desk has the given contents.
|
|
::
|
|
++ check-touched
|
|
|= [=ship =desk pax=path 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
|
|
=/ 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
|
|
::
|
|
:: Turns poke into a dojo command
|
|
::
|
|
++ poke-app
|
|
|= [=ship app=term =mark data=*]
|
|
=/ m (strand ,~)
|
|
^- form:m
|
|
=/ command=tape ":{(trip app)} &{(trip mark)} {<data>}"
|
|
(send-events (dojo:util ship command))
|
|
::
|
|
++ dojo-thread
|
|
|= [=ship ted=term =mark data=*]
|
|
=/ m (strand ,~)
|
|
^- form:m
|
|
=/ command=tape "-{(trip ted)} &{(trip mark)} {<data>}"
|
|
(send-events (dojo:util ship command))
|
|
--
|