urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-23 19:05:48 +03:00
Code Issues Packages Projects Releases Wiki Activity
943ee0ede0
shrub/pkg/arvo/app/ph.hoon
Philip Monk a4dcad7d46
gall: unsubscribe after breach 
fixes #1431
2019-09-24 15:00:16 -07:00

620 lines
18 KiB
Plaintext
Raw Blame History

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