mirror of
https://github.com/urbit/shrub.git
synced 2024-12-14 20:02:51 +03:00
Jared Tobin
GitHub
commit
d2724bb705
@ -85,7 +85,7 @@ function barMass(urb) {
|
||||
function aqua(urb) {
|
||||
return urb.line("|start %ph")
|
||||
.then(function(){
|
||||
return urb.line(":ph %init");
|
||||
return urb.line(":ph|init");
|
||||
})
|
||||
.then(function(){
|
||||
return urb.line(":aqua &pill +solid");
|
||||
@ -94,7 +94,7 @@ function aqua(urb) {
|
||||
urb.every(/TEST [^ ]* FAILED/, function(arg){
|
||||
throw Error(arg);
|
||||
});
|
||||
return urb.line(":ph [%run-test %hi]");
|
||||
return urb.line(":ph|run %hi");
|
||||
})
|
||||
.then(function(){
|
||||
return urb.expectEcho("ALL TESTS SUCCEEDED")
|
||||
|
||||
@ -57,6 +57,7 @@ Most parts of Arvo have dedicated maintainers.
|
||||
* `/app/dns`: @joemfb (~master-morzod)
|
||||
* `/app/hall`: @fang- (~palfun-foslup)
|
||||
* `/app/talk`: @fang- (~palfun-foslup)
|
||||
* `/app/aqua`: @philipcmonk (~wicdev-wisryt)
|
||||
* `/lib/test`: @eglaysher (~littel-ponnys)
|
||||
|
||||
## Contact
|
||||
|
||||
@ -117,10 +117,13 @@
|
||||
?> ?=(%0 -.poke-arm)
|
||||
=/ poke p.poke-arm
|
||||
=. tym (max +(tym) now.hid)
|
||||
=/ poke-result (slum poke tym ue)
|
||||
=. snap +.poke-result
|
||||
=/ poke-result (mule |.((slum poke tym ue)))
|
||||
?: ?=(%| -.poke-result)
|
||||
%- (slog >%aqua-crash< p.poke-result)
|
||||
$
|
||||
=. snap +.p.poke-result
|
||||
=. ..abet-pe (publish-event tym ue)
|
||||
=. ..abet-pe (handle-effects ((list ovum) -.poke-result))
|
||||
=. ..abet-pe (handle-effects ((list ovum) -.p.poke-result))
|
||||
$
|
||||
::
|
||||
:: Peek
|
||||
@ -458,6 +461,8 @@
|
||||
%event
|
||||
~? &(aqua-debug=| !?=(?(%belt %hear) -.q.ue.ae))
|
||||
raw-event=[who.ae -.q.ue.ae]
|
||||
~? &(debug=& ?=(%they -.q.ue.ae))
|
||||
raw-event=[who.ae ue.ae]
|
||||
(push-events:(pe who.ae) [ue.ae]~)
|
||||
==
|
||||
::
|
||||
|
||||
326
app/ph.hoon
326
app/ph.hoon
@ -7,10 +7,12 @@
|
||||
:: - Restore a fleet
|
||||
:: - Compose tests
|
||||
::
|
||||
/- aquarium
|
||||
/+ ph
|
||||
/- aquarium, ph
|
||||
/+ ph, ph-tests, ph-azimuth, ph-philter
|
||||
=, ph-sur=^ph
|
||||
=, aquarium
|
||||
=, ph
|
||||
=, ph-philter
|
||||
=> $~ |%
|
||||
+$ move (pair bone card)
|
||||
+$ card
|
||||
@ -32,20 +34,21 @@
|
||||
::
|
||||
+$ state
|
||||
$: %0
|
||||
raw-test-cores=(map term raw-test-core)
|
||||
test-core=(unit test-core-state)
|
||||
tests=(map term [(list ship) _*form:(ph ,~)])
|
||||
other-state
|
||||
==
|
||||
::
|
||||
+$ test-core-state
|
||||
$: hers=(list ship)
|
||||
cor=raw-test-core
|
||||
effect-log=(list [who=ship uf=unix-effect])
|
||||
$: 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
|
||||
@ -55,176 +58,70 @@
|
||||
state
|
||||
==
|
||||
++ this .
|
||||
++ test-lib ~(. ^test-lib our.hid)
|
||||
++ manual-tests
|
||||
^- (list (pair term [(list ship) _*form:(ph ,~)]))
|
||||
=+ (ph-tests our.hid)
|
||||
=/ eth-node (spawn-galaxy:ph-azimuth ~rel)
|
||||
=/ m (ph ,~)
|
||||
:~ :+ %boot-bud
|
||||
~[~bud]
|
||||
(raw-ship ~bud ~)
|
||||
::
|
||||
:: Tests that will be run automatically with :ph %run-all-tests
|
||||
:+ %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 ~]
|
||||
::
|
||||
++ auto-tests
|
||||
=, test-lib
|
||||
^- (list (pair term raw-test-core))
|
||||
:~
|
||||
:- %boot-bud
|
||||
(galaxy ~bud)
|
||||
:+ %hi
|
||||
~[~bud ~dev]
|
||||
;< ~ bind:m (raw-ship ~bud ~)
|
||||
;< ~ bind:m (raw-ship ~dev ~)
|
||||
(send-hi ~bud ~dev)
|
||||
::
|
||||
:- %add
|
||||
^- raw-test-core
|
||||
%+ compose-tests (galaxy ~bud)
|
||||
%+ stateless-test
|
||||
%add
|
||||
|_ now=@da
|
||||
++ start
|
||||
(dojo ~bud "[%test-result (add 2 3)]")
|
||||
::
|
||||
++ route
|
||||
|= [who=ship uf=unix-effect]
|
||||
(expect-dojo-output ~bud who uf "[%test-result 5]")
|
||||
--
|
||||
::
|
||||
:- %hi
|
||||
%+ compose-tests
|
||||
%+ compose-tests
|
||||
(galaxy ~bud)
|
||||
(galaxy ~dev)
|
||||
%+ stateless-test
|
||||
%hi
|
||||
|_ now=@da
|
||||
++ start
|
||||
(dojo ~bud "|hi ~dev")
|
||||
::
|
||||
++ route
|
||||
|= [who=ship uf=unix-effect]
|
||||
(expect-dojo-output ~bud who uf "hi ~dev successful")
|
||||
--
|
||||
::
|
||||
:- %boot-planet
|
||||
:+ %boot-planet
|
||||
~[~bud ~marbud ~linnup-torsyx]
|
||||
(planet ~linnup-torsyx)
|
||||
::
|
||||
:- %hi-grandparent
|
||||
%+ compose-tests (planet ~linnup-torsyx)
|
||||
%+ stateless-test
|
||||
%hi-grandparent
|
||||
|_ now=@da
|
||||
++ start
|
||||
(dojo ~linnup-torsyx "|hi ~bud")
|
||||
:+ %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)
|
||||
::
|
||||
++ route
|
||||
|= [who=ship uf=unix-effect]
|
||||
(expect-dojo-output ~linnup-torsyx who uf "hi ~bud successful")
|
||||
--
|
||||
:+ %change-file
|
||||
~[~bud]
|
||||
;< ~ bind:m (raw-ship ~bud ~)
|
||||
;< file=@t bind:m (touch-file ~bud %home)
|
||||
(check-file-touched ~bud %home file)
|
||||
::
|
||||
:- %second-cousin-hi
|
||||
%+ compose-tests
|
||||
%+ compose-tests (planet ~mitnep-todsut)
|
||||
(planet ~haplun-todtus)
|
||||
%+ stateless-test
|
||||
%second-cousin-hi
|
||||
|_ now=@da
|
||||
++ start
|
||||
(dojo ~haplun-todtus "|hi ~mitnep-todsut")
|
||||
:+ %child-sync
|
||||
~[~bud ~marbud]
|
||||
;< ~ bind:m (star ~marbud)
|
||||
;< file=@t bind:m (touch-file ~bud %base)
|
||||
(check-file-touched ~marbud %home file)
|
||||
::
|
||||
++ route
|
||||
|= [who=ship uf=unix-effect]
|
||||
(expect-dojo-output ~haplun-todtus who uf "hi ~mitnep-todsut successful")
|
||||
--
|
||||
::
|
||||
:- %change-file
|
||||
%+ compose-tests (galaxy ~bud)
|
||||
(touch-file ~bud %home)
|
||||
::
|
||||
:- %child-sync
|
||||
%+ compose-tests
|
||||
%+ compose-tests
|
||||
(star ~marbud)
|
||||
(touch-file ~bud %base)
|
||||
(check-file-touched ~marbud %home)
|
||||
==
|
||||
::
|
||||
:: Tests that will not be run automatically.
|
||||
::
|
||||
:: Some valid reasons for not running a test automatically:
|
||||
:: - Nondeterministic
|
||||
:: - Depends on external services
|
||||
:: - Is very slow
|
||||
::
|
||||
++ manual-tests
|
||||
=, test-lib
|
||||
^- (list (pair term raw-test-core))
|
||||
:~ :- %boot-from-azimuth
|
||||
%+ compose-tests
|
||||
%+ compose-tests
|
||||
(raw-ship ~bud `(dawn:azimuth ~bud))
|
||||
(touch-file ~bud %home)
|
||||
:: %- assert-happens
|
||||
:: :~
|
||||
:: ==
|
||||
*raw-test-core
|
||||
::
|
||||
:- %simple-add
|
||||
%+ compose-tests (galaxy ~bud)
|
||||
%+ stateless-test
|
||||
%add
|
||||
^- stateless-test-core
|
||||
|_ now=@da
|
||||
++ start
|
||||
=/ command "[%test-result (add 2 3)]"
|
||||
:~ [%event ~bud //term/1 %belt %txt ((list @c) command)]
|
||||
[%event ~bud //term/1 %belt %ret ~]
|
||||
==
|
||||
::
|
||||
++ route
|
||||
|= [who=ship uf=unix-effect]
|
||||
?. (is-dojo-output ~bud who uf "[%test-result 5]")
|
||||
~
|
||||
[%test-done &]~
|
||||
--
|
||||
::
|
||||
:- %count
|
||||
%+ compose-tests (galaxy ~bud)
|
||||
%+ porcelain-test
|
||||
%state
|
||||
=| count=@
|
||||
|_ now=@da
|
||||
++ start
|
||||
^- (quip ph-event _..start)
|
||||
[(dojo ~bud "\"count: {<count>}\"") ..start]
|
||||
::
|
||||
++ route
|
||||
|= [who=ship uf=unix-effect]
|
||||
^- (quip ph-event _..start)
|
||||
?. (is-dojo-output ~bud who uf "\"count: {<count>}\"")
|
||||
[~ ..start]
|
||||
?: (gte count 10)
|
||||
[[%test-done &]~ ..start]
|
||||
=. count +(count)
|
||||
start
|
||||
--
|
||||
::
|
||||
:- %break-behn
|
||||
%+ compose-tests
|
||||
%+ compose-tests
|
||||
(galaxy ~bud)
|
||||
(galaxy ~dev)
|
||||
^- raw-test-core
|
||||
|_ now=@da
|
||||
++ label %break-behn
|
||||
++ ships ~
|
||||
++ start
|
||||
[(dojo ~bud "|hi ~dev") ..start]
|
||||
::
|
||||
++ route
|
||||
|= [who=ship uf=unix-effect]
|
||||
^- [? (quip ph-event _..start)]
|
||||
?: ?=(%doze -.q.uf)
|
||||
[| ~ ..start]
|
||||
:- & :_ ..start
|
||||
(expect-dojo-output ~bud who uf "hi ~dev successful")
|
||||
--
|
||||
:+ %boot-az
|
||||
~[~bud]
|
||||
;< [node=_eth-node ~] bind:m
|
||||
%+ (wrap-philter ,_eth-node ,~)
|
||||
router:eth-node
|
||||
(raw-ship ~bud `(dawn:legacy:ph-azimuth ~bud))
|
||||
=. node (spawn-galaxy:node ~pem)
|
||||
;< [node=_eth-node ~] bind:m
|
||||
%+ (wrap-philter ,_eth-node ,~)
|
||||
router:node
|
||||
(pure:m ~)
|
||||
(pure:m ~)
|
||||
==
|
||||
::
|
||||
++ install-tests
|
||||
^+ this
|
||||
=. raw-test-cores
|
||||
(~(uni by (malt auto-tests)) (malt manual-tests))
|
||||
=. tests (malt manual-tests)
|
||||
this
|
||||
::
|
||||
++ prep
|
||||
@ -260,9 +157,6 @@
|
||||
?~ what
|
||||
[%& ~]
|
||||
?: ?=(%test-done -.i.what)
|
||||
~& ?~ p.i.what
|
||||
"TEST {(trip lab)} SUCCESSFUL"
|
||||
"TEST {(trip lab)} FAILED"
|
||||
[%| p.i.what]
|
||||
=/ nex $(what t.what)
|
||||
?: ?=(%| -.nex)
|
||||
@ -281,6 +175,9 @@
|
||||
^- (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
|
||||
@ -309,12 +206,14 @@
|
||||
`this(results ~)
|
||||
=^ lab test-qeu ~(get to test-qeu)
|
||||
~& [running-test=lab test-qeu]
|
||||
=/ res=[events=(list ph-event) new-state=raw-test-core]
|
||||
~(start (~(got by raw-test-cores) lab) now.hid)
|
||||
=. effect-log ~
|
||||
=+ ^- [ships=(list ship) test=_*form:(ph ,~)]
|
||||
(~(got by tests) lab)
|
||||
=> .(test-core `(unit test-core-state)`test-core)
|
||||
=. test-core `[ships . ~]:new-state.res
|
||||
=^ moves-1 this (subscribe-to-effects lab ships.new-state.res)
|
||||
=^ moves-2 this (run-events lab events.res)
|
||||
=. 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 ~&
|
||||
@ -384,24 +283,16 @@
|
||||
::
|
||||
:: User interface
|
||||
::
|
||||
++ poke-noun
|
||||
|= arg=*
|
||||
++ poke-ph-command
|
||||
|= com=cli:ph-sur
|
||||
^- (quip move _this)
|
||||
?+ arg ~|(%bad-noun-arg !!)
|
||||
%init
|
||||
[init-vanes this]
|
||||
::
|
||||
%run-all-tests
|
||||
=. test-qeu
|
||||
%- ~(gas to test-qeu)
|
||||
(turn auto-tests head)
|
||||
run-test
|
||||
::
|
||||
[%run-test lab=@tas]
|
||||
?. (~(has by raw-test-cores) lab.arg)
|
||||
~& [%no-test lab.arg]
|
||||
?- -.com
|
||||
%init [init-vanes this]
|
||||
%run
|
||||
?. (~(has by tests) lab.com)
|
||||
~& [%no-test lab.com]
|
||||
`this
|
||||
=. test-qeu (~(put to test-qeu) lab.arg)
|
||||
=. test-qeu (~(put to test-qeu) lab.com)
|
||||
run-test
|
||||
::
|
||||
%cancel
|
||||
@ -409,11 +300,16 @@
|
||||
=. 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
|
||||
=/ log effect-log:(need test-core)
|
||||
~& lent=(lent log)
|
||||
~& %+ roll log
|
||||
~& lent=(lent effect-log)
|
||||
~& %+ roll effect-log
|
||||
|= [[who=ship uf=unix-effect] ~]
|
||||
?: ?=(?(%blit %doze) -.q.uf)
|
||||
~
|
||||
@ -434,27 +330,47 @@
|
||||
?> ?=([@tas @ ~] way)
|
||||
=/ lab i.way
|
||||
?~ test-core
|
||||
~& [%ph-dropping lab]
|
||||
`this
|
||||
~& [%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)
|
||||
cor=_u.test-core
|
||||
log=_effect-log
|
||||
done=(unit ?)
|
||||
test=_test.u.test-core
|
||||
==
|
||||
?~ ufs.afs
|
||||
[~ ~ u.test-core]
|
||||
=. effect-log.u.test-core
|
||||
[[who i.ufs]:afs effect-log.u.test-core]
|
||||
=+ ^- [thru=? events-1=(list ph-event) cor=_cor.u.test-core]
|
||||
(~(route cor.u.test-core now.hid) who.afs i.ufs.afs)
|
||||
=. cor.u.test-core cor
|
||||
=+ $(ufs.afs t.ufs.afs)
|
||||
:+ ?: thru
|
||||
[~ ~ ~ ~ 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-1 events)
|
||||
cor
|
||||
=. test-core `cor
|
||||
(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]
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
/- aquarium
|
||||
=, aquarium
|
||||
:- %say
|
||||
|= [* [her=ship command=tape] ~]
|
||||
|= [* [her=ship command=tape ~] ~]
|
||||
:- %aqua-events
|
||||
%+ turn
|
||||
^- (list unix-event)
|
||||
|
||||
6
gen/ph/cancel.hoon
Normal file
6
gen/ph/cancel.hoon
Normal file
@ -0,0 +1,6 @@
|
||||
/- ph
|
||||
:- %say
|
||||
|= [* ~ ~]
|
||||
:- %ph-command
|
||||
^- cli:ph
|
||||
[%cancel ~]
|
||||
6
gen/ph/init.hoon
Normal file
6
gen/ph/init.hoon
Normal file
@ -0,0 +1,6 @@
|
||||
/- ph
|
||||
:- %say
|
||||
|= [* ~ ~]
|
||||
:- %ph-command
|
||||
^- cli:ph
|
||||
[%init ~]
|
||||
6
gen/ph/print.hoon
Normal file
6
gen/ph/print.hoon
Normal file
@ -0,0 +1,6 @@
|
||||
/- ph
|
||||
:- %say
|
||||
|= [* ~ ~]
|
||||
:- %ph-command
|
||||
^- cli:ph
|
||||
[%print ~]
|
||||
6
gen/ph/run-all.hoon
Normal file
6
gen/ph/run-all.hoon
Normal file
@ -0,0 +1,6 @@
|
||||
/- ph
|
||||
:- %say
|
||||
|= [* ~ ~]
|
||||
:- %ph-command
|
||||
^- cli:ph
|
||||
[%run-all ~]
|
||||
6
gen/ph/run.hoon
Normal file
6
gen/ph/run.hoon
Normal file
@ -0,0 +1,6 @@
|
||||
/- ph
|
||||
:- %say
|
||||
|= [* [lab=term ~] ~]
|
||||
:- %ph-command
|
||||
^- cli:ph
|
||||
[%run lab]
|
||||
531
lib/ph.hoon
531
lib/ph.hoon
@ -1,473 +1,86 @@
|
||||
:: Defines the ph monad.
|
||||
::
|
||||
:::: /hoon/ph/lib
|
||||
:: A complete ph test has type data:(ph ,~). This is a function that
|
||||
:: accepts a new unix-effect and produces a list of ph-events to inject
|
||||
:: back into the system. It also produces one of four "next steps":
|
||||
::
|
||||
:: %wait: no change; on next unix-effect call this same function.
|
||||
:: %cont: swap out this test for another one. Mainly useful for
|
||||
:: the implementation of +bind.
|
||||
:: %fail: the test has failed.
|
||||
:: %done: the test has finished successfully.
|
||||
::
|
||||
:: When producing %done, you may specify a value. The ph app assumes
|
||||
:: the value of each whole test will be ~. During the test, though, it
|
||||
:: may be useful to produce intermediate values.
|
||||
::
|
||||
:: We define two additional functions. +return takes a value and
|
||||
:: produces a test which immediately produces a %done with that value.
|
||||
::
|
||||
:: +bind takes a test and a function from the output type of that test
|
||||
:: to another test. This is useful to link tests together. See
|
||||
:: lib/ph/tests.hoon for examples of usage.
|
||||
::
|
||||
:: You may recognize monad terminology. These functions satisfy the
|
||||
:: monad laws: If `f` and `g` are the sort of function that go in the
|
||||
:: second argument to bind and `m` is a test, then:
|
||||
::
|
||||
:: (cork pure (curr bind f)) = f
|
||||
:: (bind m pure) = m
|
||||
:: ((bind m f) g) = (bind m (bind f g))
|
||||
::
|
||||
:: Maintaining these laws requires a particular interpretation of the
|
||||
:: monad, which the ph app implements in +diff-aqua-effects. Thus,
|
||||
:: within the ph app the monad laws hold.
|
||||
::
|
||||
/- aquarium
|
||||
=, aquarium
|
||||
|%
|
||||
:: Defines a complete integration test.
|
||||
+$ ph-input
|
||||
[now=@da who=ship uf=unix-effect]
|
||||
::
|
||||
++ raw-test-core
|
||||
$_ ^|
|
||||
|_ now=@da
|
||||
::
|
||||
:: Unique name, used as a cache label.
|
||||
::
|
||||
++ label *@ta
|
||||
::
|
||||
:: List of ships that are part of the test.
|
||||
::
|
||||
:: We'll only hear effects from these ships, and only these will
|
||||
:: be in the cache points.
|
||||
::
|
||||
++ ships *(list ship)
|
||||
::
|
||||
:: Called first to kick off the test.
|
||||
::
|
||||
++ start *(quip ph-event _^|(..start))
|
||||
::
|
||||
:: Called on every effect from a ship.
|
||||
::
|
||||
:: The loobean in the return value says whether we should pass on
|
||||
:: the effect to vane drivers. Usually this should be yes.
|
||||
::
|
||||
++ route |~([ship unix-effect] *[? (quip ph-event _^|(..start))])
|
||||
--
|
||||
::
|
||||
:: A simpler interface for when you don't need all the power.
|
||||
::
|
||||
:: Doesn't allwow you to explicitly subscribe to certain ships or
|
||||
:: blocking certain effects from going to their usual vane drivers.
|
||||
::
|
||||
:: Use with +porcelain-test
|
||||
::
|
||||
++ porcelain-test-core
|
||||
$_ ^|
|
||||
|_ now=@da
|
||||
:: Called first to kick off the test.
|
||||
::
|
||||
++ start *(quip ph-event _^|(..start))
|
||||
::
|
||||
:: Called on every effect from a ship.
|
||||
::
|
||||
++ route |~([ship unix-effect] *(quip ph-event _^|(..start)))
|
||||
--
|
||||
::
|
||||
:: A simpler interface for when you don't need test state.
|
||||
::
|
||||
:: Use with +stateless-test
|
||||
::
|
||||
++ stateless-test-core
|
||||
$_ ^|
|
||||
|_ now=@da
|
||||
:: Called first to kick off the test.
|
||||
::
|
||||
++ start *(list ph-event)
|
||||
::
|
||||
:: Called on every effect from a ship.
|
||||
::
|
||||
++ route |~([ship unix-effect] *(list ph-event))
|
||||
--
|
||||
::
|
||||
++ ph-event
|
||||
$% [%test-done p=?]
|
||||
aqua-event
|
||||
++ ph-output-raw
|
||||
|* a=mold
|
||||
$~ [& ~ %done *a]
|
||||
$: thru=?
|
||||
events=(list ph-event)
|
||||
$= next
|
||||
$% [%wait ~]
|
||||
[%cont self=(ph-form-raw a)]
|
||||
[%fail ~]
|
||||
[%done value=a]
|
||||
==
|
||||
==
|
||||
::
|
||||
:: Call with a +porecelain-test-core create a stateless test.
|
||||
++ ph-form-raw
|
||||
|* a=mold
|
||||
$-(ph-input (ph-output-raw a))
|
||||
::
|
||||
++ porcelain-test
|
||||
|= [label=@ta porcelain=porcelain-test-core]
|
||||
^- raw-test-core
|
||||
|_ now=@da
|
||||
++ label ^label
|
||||
++ ships ~
|
||||
++ start
|
||||
=^ events porcelain ~(start porcelain now)
|
||||
[events ..start]
|
||||
::
|
||||
++ route
|
||||
|= args=[ship unix-effect]
|
||||
=^ events porcelain (~(route porcelain now) args)
|
||||
[& events ..start]
|
||||
--
|
||||
::
|
||||
:: Call with a +stateless-test-core create a stateless test.
|
||||
::
|
||||
++ stateless-test
|
||||
|= [label=@tas stateless=stateless-test-core]
|
||||
%+ porcelain-test
|
||||
label
|
||||
^- porcelain-test-core
|
||||
|_ now=@da
|
||||
++ start
|
||||
[~(start stateless now) ..start]
|
||||
::
|
||||
++ route
|
||||
|= args=[ship unix-effect]
|
||||
[(~(route stateless now) args) ..start]
|
||||
--
|
||||
::
|
||||
:: Turn [ship (list unix-event)] into (list ph-event)
|
||||
::
|
||||
++ send-events-to
|
||||
|= [who=ship what=(list unix-event)]
|
||||
^- (list ph-event)
|
||||
%+ turn what
|
||||
|= ue=unix-event
|
||||
[%event who ue]
|
||||
::
|
||||
:: Start a ship (low-level; prefer +raw-ship)
|
||||
::
|
||||
++ init
|
||||
|= [who=ship keys=(unit dawn-event)]
|
||||
^- (list ph-event)
|
||||
[%init-ship who keys]~
|
||||
::
|
||||
:: factor out send-events-to
|
||||
::
|
||||
++ dojo
|
||||
|= [who=ship what=tape]
|
||||
^- (list ph-event)
|
||||
%+ send-events-to who
|
||||
^- (list unix-event)
|
||||
:~
|
||||
[//term/1 %belt %ctl `@c`%e]
|
||||
[//term/1 %belt %ctl `@c`%u]
|
||||
[//term/1 %belt %txt ((list @c) what)]
|
||||
[//term/1 %belt %ret ~]
|
||||
==
|
||||
::
|
||||
:: Inject a file into a ship
|
||||
::
|
||||
++ insert-file
|
||||
|= [who=ship des=desk pax=path txt=@t]
|
||||
^- (list ph-event)
|
||||
?> ?=([@ @ @ *] pax)
|
||||
=/ file [/text/plain (as-octs:mimes:html txt)]
|
||||
%+ send-events-to who
|
||||
:~
|
||||
[//sync/0v1n.2m9vh %into des | [t.t.t.pax `file]~]
|
||||
==
|
||||
::
|
||||
:: Checks whether the given event is a dojo output blit containing the
|
||||
:: given tape
|
||||
::
|
||||
++ is-dojo-output
|
||||
|= [who=ship her=ship uf=unix-effect what=tape]
|
||||
?& =(who her)
|
||||
?=(%blit -.q.uf)
|
||||
::
|
||||
%+ lien p.q.uf
|
||||
|= =blit:dill
|
||||
?. ?=(%lin -.blit)
|
||||
|
|
||||
!=(~ (find what p.blit))
|
||||
==
|
||||
::
|
||||
:: Test is successful if +is-dojo-output
|
||||
::
|
||||
++ expect-dojo-output
|
||||
|= [who=ship her=ship uf=unix-effect what=tape]
|
||||
^- (list ph-event)
|
||||
?. (is-dojo-output who her uf what)
|
||||
~
|
||||
[%test-done &]~
|
||||
::
|
||||
:: Check whether the given event is an ergo
|
||||
::
|
||||
++ is-ergo
|
||||
|= [who=ship her=ship uf=unix-effect]
|
||||
?& =(who her)
|
||||
?=(%ergo -.q.uf)
|
||||
==
|
||||
::
|
||||
++ azimuth
|
||||
++ ph
|
||||
|* a=mold
|
||||
|%
|
||||
++ dawn
|
||||
|= who=ship
|
||||
^- dawn-event
|
||||
:* (need (private-key who))
|
||||
(^sein:title who)
|
||||
czar
|
||||
~[~['arvo' 'netw' 'ork']]
|
||||
0
|
||||
`(need (de-purl:html 'http://localhost:8545'))
|
||||
~
|
||||
==
|
||||
++ output (ph-output-raw a)
|
||||
++ form (ph-form-raw a)
|
||||
++ pure
|
||||
|= arg=a
|
||||
^- form
|
||||
|= ph-input
|
||||
[& ~ %done arg]
|
||||
::
|
||||
++ czar
|
||||
^- (map ship [life pass])
|
||||
%- my
|
||||
^- (list (pair ship [life pass]))
|
||||
%+ murn (gulf 0x0 0xff)
|
||||
|= her=ship
|
||||
^- (unit [ship life pass])
|
||||
=/ pub (public-key her)
|
||||
?~ pub
|
||||
~
|
||||
`[her u.pub]
|
||||
::
|
||||
++ private-key
|
||||
|= who=ship
|
||||
=- (~(get by -) who)
|
||||
^- (map ship seed:able:jael)
|
||||
%- my
|
||||
:~ [~bud ~bud 1 'BbudB' ~]
|
||||
[~dev ~dev 1 'Bdev' ~]
|
||||
==
|
||||
::
|
||||
++ public-key
|
||||
|= who=ship
|
||||
^- (unit [life pass])
|
||||
=/ priv (private-key who)
|
||||
?~ priv
|
||||
~
|
||||
=/ cub (nol:nu:crub:crypto key.u.priv)
|
||||
`[lyf.u.priv pub:ex:cub]
|
||||
--
|
||||
::
|
||||
++ test-lib
|
||||
|_ our=ship
|
||||
::
|
||||
:: Run one test, then the next.
|
||||
::
|
||||
:: Caches the result of the first test.
|
||||
::
|
||||
++ compose-tests
|
||||
|= [a=raw-test-core b=raw-test-core]
|
||||
^- raw-test-core
|
||||
=/ done-with-a |
|
||||
=>
|
||||
|%
|
||||
++ filter-a
|
||||
|= [now=@da events=(list ph-event)]
|
||||
^- (quip ph-event _..filter-a)
|
||||
=+ ^- [done=(list ph-event) other-events=(list ph-event)]
|
||||
%+ skid events
|
||||
|= e=ph-event
|
||||
=(%test-done -.e)
|
||||
?~ done
|
||||
[other-events ..filter-a]
|
||||
?> ?=(%test-done -.i.done)
|
||||
?. p.i.done
|
||||
[[%test-done |]~ ..filter-a]
|
||||
=. done-with-a &
|
||||
=/ snap-event [%snap-ships label:a ships:a]
|
||||
=^ events-start b ~(start b now)
|
||||
[(welp other-events [snap-event events-start]) ..filter-a]
|
||||
--
|
||||
|_ now=@da
|
||||
::
|
||||
:: Cache lookup label
|
||||
::
|
||||
++ label `@tas`:((cury cat 3) label:a '--' label:b)
|
||||
::
|
||||
:: Union of ships in a and b
|
||||
::
|
||||
++ ships ~(tap in (~(uni in (silt ships.a)) (silt ships.b)))
|
||||
::
|
||||
:: Start with start of a
|
||||
::
|
||||
++ start
|
||||
^- (quip ph-event _..start)
|
||||
=/ have-cache
|
||||
(scry-aqua ? now /fleet-snap/[label:a]/noun)
|
||||
?: have-cache
|
||||
~& [%caching-in label:a label]
|
||||
=. done-with-a &
|
||||
=/ restore-event [%restore-snap label:a]
|
||||
=^ events-start b ~(start b now)
|
||||
=^ events ..filter-a (filter-a now restore-event events-start)
|
||||
[events ..start]
|
||||
=^ events a ~(start a now)
|
||||
[events ..start]
|
||||
::
|
||||
:: Keep going on a until it's done. If success, go to b.
|
||||
::
|
||||
:: In theory, we should be able to just swap out the whole core
|
||||
:: for b, but in practice the types are hard, and we generally
|
||||
:: try to avoid changing the structure of a core in the middle
|
||||
:: like that.
|
||||
::
|
||||
++ route
|
||||
|= [who=ship uf=unix-effect]
|
||||
^- [? (quip ph-event _..start)]
|
||||
?: done-with-a
|
||||
=+ ^- [thru=? events=(list ph-event) cor=raw-test-core]
|
||||
(~(route b now) who uf)
|
||||
=. b cor
|
||||
[thru events ..start]
|
||||
=+ ^- [thru=? events=(list ph-event) cor=raw-test-core]
|
||||
(~(route a now) who uf)
|
||||
=. a cor
|
||||
=^ events ..filter-a (filter-a now events)
|
||||
[thru events ..start]
|
||||
--
|
||||
::
|
||||
:: Don't use directly unless you've already started any parent.
|
||||
::
|
||||
:: Consider ++galaxy, ++star, ++planet, and ++ship-with-ancestors.
|
||||
::
|
||||
++ raw-ship
|
||||
|= [her=ship keys=(unit dawn-event)]
|
||||
^- raw-test-core
|
||||
|_ now=@da
|
||||
++ label :((cury cat 3) 'init-' (scot %p her) '-' (scot %uw (mug (fall keys *dawn-event))))
|
||||
++ ships ~[her]
|
||||
++ start
|
||||
^- (quip ph-event _..start)
|
||||
[(init her keys) ..start]
|
||||
::
|
||||
++ route
|
||||
|= [who=ship uf=unix-effect]
|
||||
^- [? (quip ph-event _..start)]
|
||||
:- &
|
||||
:_ ..start
|
||||
%- zing
|
||||
:: This is a pretty bad heuristic, but in general galaxies will
|
||||
:: hit the first of these cases, and other ships will hit the
|
||||
:: second.
|
||||
::
|
||||
:~
|
||||
?. %^ is-dojo-output her who :- uf
|
||||
"clay: committed initial filesystem (all)"
|
||||
~
|
||||
[%test-done &]~
|
||||
::
|
||||
?. %^ is-dojo-output her who :- uf
|
||||
"is your neighbor"
|
||||
~
|
||||
[%test-done &]~
|
||||
==
|
||||
--
|
||||
::
|
||||
++ galaxy
|
||||
|= her=ship
|
||||
?> =(%czar (clan:title her))
|
||||
(raw-ship her ~)
|
||||
::
|
||||
++ star
|
||||
|= her=ship
|
||||
?> =(%king (clan:title her))
|
||||
%+ compose-tests (galaxy (^sein:title her))
|
||||
(raw-ship her ~)
|
||||
::
|
||||
++ planet
|
||||
|= her=ship
|
||||
?> =(%duke (clan:title her))
|
||||
%+ compose-tests (star (^sein:title her))
|
||||
(raw-ship her ~)
|
||||
::
|
||||
++ ship-with-ancestors
|
||||
|= her=ship
|
||||
%. her
|
||||
?- (clan:title her)
|
||||
%czar galaxy
|
||||
%king star
|
||||
%duke planet
|
||||
%earl ~|(%moon-not-implemented !!)
|
||||
%pawn ~|(%comet-not-implemented !!)
|
||||
==
|
||||
::
|
||||
:: Touches /sur/aquarium/hoon on the given ship.
|
||||
::
|
||||
++ touch-file
|
||||
|= [her=ship des=desk]
|
||||
%+ porcelain-test
|
||||
(cat 3 'touch-file-' (scot %p her))
|
||||
=| [warped=@t change-sent=_|]
|
||||
^- porcelain-test-core
|
||||
|_ now=@da
|
||||
++ start
|
||||
^- (pair (list ph-event) _..start)
|
||||
:_ ..start
|
||||
(dojo her "|mount /={(trip des)}=")
|
||||
::
|
||||
++ route
|
||||
|= [who=ship uf=unix-effect]
|
||||
^- (quip ph-event _..start)
|
||||
?. (is-ergo her who uf)
|
||||
`..start
|
||||
?. change-sent
|
||||
=/ host-pax
|
||||
/(scot %p our)/home/(scot %da now)/sur/aquarium/hoon
|
||||
=. warped (cat 3 '=> . ' .^(@t %cx host-pax))
|
||||
=. change-sent &
|
||||
[(insert-file her des host-pax warped) ..start]
|
||||
:_ ..start
|
||||
=/ pax /i/(scot %p her)/[des]/(scot %da now)/sur/aquarium/hoon/noun
|
||||
?: =(warped (need (scry-aqua (unit @) now pax)))
|
||||
[%test-done &]~
|
||||
~
|
||||
--
|
||||
::
|
||||
:: Check that /sur/aquarium/hoon has been touched, as by ++touch-file
|
||||
::
|
||||
++ check-file-touched
|
||||
|= [her=ship des=desk]
|
||||
%+ stateless-test
|
||||
(cat 3 'check-file-touched-' (scot %p her))
|
||||
|_ now=@da
|
||||
++ start
|
||||
:: mounting is not strictly necessary since we check via scry,
|
||||
:: but this way we don't have to check on every event, just
|
||||
:: ergos (and dojo because we can't guarantee an ergo if the desk
|
||||
:: is already mounted)
|
||||
::
|
||||
(dojo her "|mount /={(trip des)}=")
|
||||
::
|
||||
++ route
|
||||
|= [who=ship uf=unix-effect]
|
||||
^- (list ph-event)
|
||||
?. ?| (is-ergo her who uf)
|
||||
(is-dojo-output her who uf ">=")
|
||||
==
|
||||
~
|
||||
=/ pax /home/(scot %da now)/sur/aquarium/hoon
|
||||
=/ warped (cat 3 '=> . ' .^(@t %cx (weld /(scot %p our) pax)))
|
||||
=/ aqua-pax
|
||||
;: weld
|
||||
/i/(scot %p her)
|
||||
pax(- des)
|
||||
/noun
|
||||
==
|
||||
?: =(warped (need (scry-aqua (unit @) now aqua-pax)))
|
||||
[%test-done &]~
|
||||
~
|
||||
--
|
||||
::
|
||||
:: Reload vane from filesystem
|
||||
::
|
||||
++ reload-vane
|
||||
|= [her=ship vane=term]
|
||||
%+ stateless-test
|
||||
:((cury cat 3) 'reload-vane-' (scot %p her) '-' vane)
|
||||
|_ now=@da
|
||||
++ start
|
||||
^- (list ph-event)
|
||||
=/ pax
|
||||
/(scot %p our)/home/(scot %da now)/sys/vane/[vane]/hoon
|
||||
%- zing
|
||||
:~ (dojo her "|mount /=home=")
|
||||
(insert-file her %home pax .^(@t %cx pax))
|
||||
[%test-done &]~
|
||||
==
|
||||
::
|
||||
++ route
|
||||
|= [who=ship uf=unix-effect]
|
||||
~
|
||||
--
|
||||
::
|
||||
:: Scry into a running aqua ship
|
||||
::
|
||||
++ scry-aqua
|
||||
|* [a=mold now=@da pax=path]
|
||||
.^ a
|
||||
%gx
|
||||
(scot %p our)
|
||||
%aqua
|
||||
(scot %da now)
|
||||
pax
|
||||
++ bind
|
||||
|* b=mold
|
||||
|= [m-b=(ph-form-raw b) fun=$-(b form)]
|
||||
^- form
|
||||
|= input=ph-input
|
||||
=/ b-res=(ph-output-raw b)
|
||||
(m-b input)
|
||||
^- output
|
||||
:+ thru.b-res events.b-res
|
||||
?- -.next.b-res
|
||||
%wait [%wait ~]
|
||||
%cont [%cont ..$(m-b self.next.b-res)]
|
||||
%fail [%fail ~]
|
||||
%done [%cont (fun value.next.b-res)]
|
||||
==
|
||||
--
|
||||
--
|
||||
|
||||
235
lib/ph/azimuth.hoon
Normal file
235
lib/ph/azimuth.hoon
Normal file
@ -0,0 +1,235 @@
|
||||
:: Mock Azimuth
|
||||
::
|
||||
/+ ph, ph-util, ph-philter
|
||||
=, ph
|
||||
=, ph-util
|
||||
=, ph-philter
|
||||
=> |%
|
||||
+$ az-log [topics=(lest @) data=@t]
|
||||
--
|
||||
=| logs=(list az-log) :: oldest logs first
|
||||
=| eth-filter=(unit [from-block=@ud last-block=@ud address=@ux])
|
||||
=, azimuth-events:azimuth
|
||||
|%
|
||||
++ this-az .
|
||||
++ add-logs
|
||||
|= new-logs=(list az-log)
|
||||
^+ this-az
|
||||
=. logs (weld logs new-logs)
|
||||
this-az
|
||||
::
|
||||
++ router
|
||||
=/ n (philter ,_this-az)
|
||||
^- form:n
|
||||
|%
|
||||
++ stay this-az
|
||||
++ run
|
||||
|= pin=ph-input
|
||||
^- output:n
|
||||
=, enjs:format
|
||||
=/ thus (extract-thus-to uf.pin 'http://localhost:8545')
|
||||
?~ thus
|
||||
[& ~ %wait ~]
|
||||
?~ r.mot.u.thus
|
||||
[& ~ %wait ~]
|
||||
=/ req q.u.r.mot.u.thus
|
||||
|^ ^- output:n
|
||||
=/ method (get-method req)
|
||||
?: =(method 'eth_blockNumber')
|
||||
:- | :_ [%wait ~]
|
||||
%+ answer-request req
|
||||
s+(crip (num-to-hex:ethereum latest-block))
|
||||
?: =(method 'eth_getLogs')
|
||||
:- | :_ [%wait ~]
|
||||
%+ answer-request req
|
||||
%+ logs-to-json
|
||||
(get-param-obj req 'fromBlock')
|
||||
(get-param-obj req 'toBlock')
|
||||
?: =(method 'eth_newFilter')
|
||||
:+ |
|
||||
(answer-request req s+'0xa')
|
||||
=. eth-filter
|
||||
:^ ~
|
||||
(get-param-obj req 'fromBlock')
|
||||
(get-param-obj req 'fromBlock')
|
||||
(get-param-obj req 'address')
|
||||
[%cont ..stay]
|
||||
?: =(method 'eth_getFilterLogs')
|
||||
~& [%filter-logs latest-block eth-filter]
|
||||
?~ eth-filter
|
||||
~|(%no-filter-not-implemented !!)
|
||||
:+ |
|
||||
%+ answer-request req
|
||||
~| [eth-filter latest-block]
|
||||
(logs-to-json from-block.u.eth-filter latest-block)
|
||||
=. last-block.u.eth-filter latest-block
|
||||
[%cont ..stay]
|
||||
?: =(method 'eth_getFilterChanges')
|
||||
~& [%filter-changes latest-block eth-filter]
|
||||
?~ eth-filter
|
||||
~|(%no-filter-not-implemented !!)
|
||||
:+ |
|
||||
%+ answer-request req
|
||||
(logs-to-json last-block.u.eth-filter latest-block)
|
||||
=. last-block.u.eth-filter latest-block
|
||||
[%cont ..stay]
|
||||
[& ~ %wait ~]
|
||||
::
|
||||
++ latest-block
|
||||
(add launch:contracts:azimuth (lent logs))
|
||||
::
|
||||
++ get-id
|
||||
|= req=@t
|
||||
=, dejs:format
|
||||
%. (need (de-json:html req))
|
||||
(ot id+so ~)
|
||||
::
|
||||
++ get-method
|
||||
|= req=@t
|
||||
=, dejs:format
|
||||
%. (need (de-json:html req))
|
||||
(ot method+so ~)
|
||||
::
|
||||
++ get-param-obj
|
||||
|= [req=@t param=@t]
|
||||
=, dejs:format
|
||||
%- hex-to-num:ethereum
|
||||
=/ array
|
||||
%. (need (de-json:html req))
|
||||
(ot params+(ar (ot param^so ~)) ~)
|
||||
?> ?=([* ~] array)
|
||||
i.array
|
||||
::
|
||||
++ answer-request
|
||||
|= [req=@t result=json]
|
||||
^- (list ph-event)
|
||||
=/ resp
|
||||
%- crip
|
||||
%- en-json:html
|
||||
%- pairs
|
||||
:~ id+s+(get-id req)
|
||||
jsonrpc+s+'2.0'
|
||||
result+result
|
||||
==
|
||||
:_ ~
|
||||
:* %event
|
||||
who.pin
|
||||
//http/0v1n.2m9vh
|
||||
%they
|
||||
num.u.thus
|
||||
[200 ~ `(as-octs:mimes:html resp)]
|
||||
==
|
||||
::
|
||||
++ logs-to-json
|
||||
|= [from-block=@ud to-block=@ud]
|
||||
^- json
|
||||
:- %a
|
||||
=/ selected-logs
|
||||
%+ swag
|
||||
[(sub from-block launch:contracts:azimuth) (sub to-block from-block)]
|
||||
logs
|
||||
=/ count from-block
|
||||
|- ^- (list json)
|
||||
?~ selected-logs
|
||||
~
|
||||
:_ $(selected-logs t.selected-logs, count +(count))
|
||||
%- pairs
|
||||
:~ 'logIndex'^s+'0x0'
|
||||
'transactionIndex'^s+'0x0'
|
||||
:+ 'transactionHash' %s
|
||||
(crip (prefix-hex:ethereum (render-hex-bytes:ethereum 32 `@`0x5362)))
|
||||
::
|
||||
:+ 'blockHash' %s
|
||||
(crip (prefix-hex:ethereum (render-hex-bytes:ethereum 32 `@`0x5363)))
|
||||
::
|
||||
:+ 'blockNumber' %s
|
||||
(crip (num-to-hex:ethereum count))
|
||||
::
|
||||
:+ 'address' %s
|
||||
(crip (address-to-hex:ethereum azimuth:contracts:azimuth))
|
||||
::
|
||||
'type'^s+'mined'
|
||||
::
|
||||
'data'^s+data.i.selected-logs
|
||||
:+ 'topics' %a
|
||||
%+ turn topics.i.selected-logs
|
||||
|= topic=@ux
|
||||
^- json
|
||||
:- %s
|
||||
%- crip
|
||||
%- prefix-hex:ethereum
|
||||
(render-hex-bytes:ethereum 32 `@`topic)
|
||||
==
|
||||
--
|
||||
--
|
||||
::
|
||||
++ spawn-galaxy
|
||||
|= who=@p
|
||||
%- add-logs
|
||||
:~ [~[activated who] '']
|
||||
[~[owner-changed who 0xdead.beef] '']
|
||||
:- ~[changed-keys who]
|
||||
%- crip
|
||||
%- prefix-hex:ethereum
|
||||
;: welp
|
||||
(get-keys who 1 %auth)
|
||||
(get-keys who 1 %crypt)
|
||||
(render-hex-bytes:ethereum 32 `@`1)
|
||||
(render-hex-bytes:ethereum 32 `@`1)
|
||||
==
|
||||
==
|
||||
::
|
||||
++ get-keys
|
||||
|= [who=@p life=@ud typ=?(%auth %crypt)]
|
||||
%+ render-hex-bytes:ethereum 32
|
||||
%- keccak-256:keccak:crypto
|
||||
%- as-octs:mimes:html
|
||||
:((cury cat 3) (scot %p who) (scot %ud life) typ)
|
||||
::
|
||||
:: XX replace
|
||||
::
|
||||
++ legacy
|
||||
|%
|
||||
++ dawn
|
||||
|= who=ship
|
||||
^- dawn-event
|
||||
:* (need (private-key who))
|
||||
(^sein:title who)
|
||||
czar
|
||||
~[~['arvo' 'netw' 'ork']]
|
||||
0
|
||||
`(need (de-purl:html 'http://localhost:8545'))
|
||||
~
|
||||
==
|
||||
::
|
||||
++ czar
|
||||
^- (map ship [life pass])
|
||||
%- my
|
||||
^- (list (pair ship [life pass]))
|
||||
%+ murn (gulf 0x0 0xff)
|
||||
|= her=ship
|
||||
^- (unit [ship life pass])
|
||||
=/ pub (public-key her)
|
||||
?~ pub
|
||||
~
|
||||
`[her u.pub]
|
||||
::
|
||||
++ private-key
|
||||
|= who=ship
|
||||
=- (~(get by -) who)
|
||||
^- (map ship seed:able:jael)
|
||||
%- my
|
||||
:~ [~bud ~bud 1 'BbudB' ~]
|
||||
[~dev ~dev 1 'Bdev' ~]
|
||||
==
|
||||
::
|
||||
++ public-key
|
||||
|= who=ship
|
||||
^- (unit [life pass])
|
||||
=/ priv (private-key who)
|
||||
?~ priv
|
||||
~
|
||||
=/ cub (nol:nu:crub:crypto key.u.priv)
|
||||
`[lyf.u.priv pub:ex:cub]
|
||||
--
|
||||
--
|
||||
76
lib/ph/philter.hoon
Normal file
76
lib/ph/philter.hoon
Normal file
@ -0,0 +1,76 @@
|
||||
:: Wrap tests in stateful philters
|
||||
::
|
||||
/+ ph
|
||||
=, ph
|
||||
|%
|
||||
::
|
||||
:: A philter is similar to a test in structure, but they don't
|
||||
:: terminate and have a ++stay arm for saving their state.
|
||||
::
|
||||
:: They may be wrappped around a test with +wrap-philter.
|
||||
::
|
||||
++ philter
|
||||
|* o=mold
|
||||
|%
|
||||
++ output
|
||||
$~ [& ~ %wait ~]
|
||||
$: thru=?
|
||||
events=(list ph-event)
|
||||
$= next
|
||||
$% [%wait ~]
|
||||
[%cont self=form]
|
||||
==
|
||||
==
|
||||
++ form
|
||||
$_ ^?
|
||||
|%
|
||||
++ stay *o
|
||||
++ run |~(ph-input *output)
|
||||
--
|
||||
--
|
||||
::
|
||||
:: Run the inner test wrapped in the outer philter. The philter may
|
||||
:: respond to any event that the test didn't consume. One use is to
|
||||
:: mock outside services, like an Ethereum node or LetsEncrypt.
|
||||
::
|
||||
++ wrap-philter
|
||||
|* [o=mold i=mold]
|
||||
|= [outer=_*form:(philter o) inner=_*form:(ph i)]
|
||||
^+ *form:(ph ,[o i])
|
||||
|= input=ph-input
|
||||
=/ res-i=_*output:(ph i)
|
||||
(inner input)
|
||||
?. thru.res-i
|
||||
:+ thru.res-i events.res-i
|
||||
?- -.next.res-i
|
||||
%wait [%wait ~]
|
||||
%cont [%cont ..$(inner self.next.res-i)]
|
||||
%fail [%fail ~]
|
||||
%done [%done stay:outer value.next.res-i]
|
||||
==
|
||||
=/ res-o=_*output:(philter o)
|
||||
(run:outer input)
|
||||
^+ *output:(ph ,[o i])
|
||||
:+ thru.res-o (welp events.res-i events.res-o)
|
||||
?- -.next.res-i
|
||||
%wait
|
||||
?- -.next.res-o
|
||||
%wait [%wait ~]
|
||||
%cont [%cont ..$(outer self.next.res-o)]
|
||||
==
|
||||
::
|
||||
%cont
|
||||
=. inner self.next.res-i
|
||||
?- -.next.res-o
|
||||
%wait [%cont ..$]
|
||||
%cont [%cont ..$(outer self.next.res-o)]
|
||||
==
|
||||
::
|
||||
%fail [%fail ~]
|
||||
%done
|
||||
?- -.next.res-o
|
||||
%wait [%done stay:outer value.next.res-i]
|
||||
%cont [%done stay:self.next.res-o value.next.res-i]
|
||||
==
|
||||
==
|
||||
--
|
||||
163
lib/ph/tests.hoon
Normal file
163
lib/ph/tests.hoon
Normal file
@ -0,0 +1,163 @@
|
||||
:: Useful tests for testing things
|
||||
::
|
||||
/+ ph, ph-util
|
||||
=, ph
|
||||
=, ph-util
|
||||
|= our=ship
|
||||
=> :: Helper functions, not tests
|
||||
::
|
||||
|%
|
||||
:: Scry into a running aqua ship
|
||||
::
|
||||
++ scry-aqua
|
||||
|* [a=mold now=@da pax=path]
|
||||
.^ a
|
||||
%gx
|
||||
(scot %p our)
|
||||
%aqua
|
||||
(scot %da now)
|
||||
pax
|
||||
==
|
||||
::
|
||||
--
|
||||
::
|
||||
:: Useful tests
|
||||
::
|
||||
|%
|
||||
::
|
||||
:: Never-ending test, for development.
|
||||
::
|
||||
++ stall
|
||||
|= ph-input
|
||||
[& ~ %wait ~]
|
||||
::
|
||||
:: Test to produce events unconditionally.
|
||||
::
|
||||
++ just-events
|
||||
|= events=(list ph-event)
|
||||
=/ m (ph ,~)
|
||||
^- form:m
|
||||
|= ph-input
|
||||
[& events %done ~]
|
||||
::
|
||||
:: Boot ship; don't check it succeeded.
|
||||
::
|
||||
++ boot-ship
|
||||
|= [her=ship keys=(unit dawn-event)]
|
||||
^+ *form:(ph ,~)
|
||||
|= ph-input
|
||||
[& (init her keys) %done ~]
|
||||
::
|
||||
:: Wait until ship has finished booting.
|
||||
::
|
||||
++ check-ship-booted
|
||||
|= her=ship
|
||||
^+ *form:(ph ,~)
|
||||
|= ph-input
|
||||
=; done=?
|
||||
:+ & ~
|
||||
?: done
|
||||
[%done ~]
|
||||
[%wait ~]
|
||||
:: This is a pretty bad heuristic, but in general galaxies will
|
||||
:: hit the first of these cases, and other ships will hit the
|
||||
:: second.
|
||||
::
|
||||
?|
|
||||
%^ is-dojo-output her who :- uf
|
||||
"clay: committed initial filesystem (all)"
|
||||
::
|
||||
%^ is-dojo-output her who :- uf
|
||||
"is your neighbor"
|
||||
==
|
||||
::
|
||||
:: Send "|hi" from one ship to another
|
||||
::
|
||||
++ send-hi
|
||||
|= [from=@p to=@p]
|
||||
=/ m (ph ,~)
|
||||
^- form:m
|
||||
;< ~ bind:m
|
||||
^- form:m
|
||||
|= ph-input
|
||||
[& (dojo from "|hi {(scow %p to)}") %done ~]
|
||||
^- form:m
|
||||
|= input=ph-input
|
||||
^- output:m
|
||||
:+ & ~
|
||||
?. (is-dojo-output from who.input uf.input "hi {(scow %p to)} successful")
|
||||
[%wait ~]
|
||||
[%done ~]
|
||||
::
|
||||
:: Boot a ship and verify it booted. Parent must already be booted.
|
||||
::
|
||||
++ raw-ship
|
||||
|= [her=ship keys=(unit dawn-event)]
|
||||
=/ m (ph ,~)
|
||||
^- form:m
|
||||
;< ~ bind:m (boot-ship her keys)
|
||||
(check-ship-booted her)
|
||||
::
|
||||
:: Boot a fake star and its parent.
|
||||
::
|
||||
++ star
|
||||
|= her=ship
|
||||
=/ m (ph ,~)
|
||||
^- form:m
|
||||
;< ~ bind:m (raw-ship (^sein:title her) ~)
|
||||
(raw-ship her ~)
|
||||
::
|
||||
:: Boot a fake planet, its parent, and its grandparent.
|
||||
::
|
||||
++ planet
|
||||
|= her=ship
|
||||
=/ m (ph ,~)
|
||||
^- form:m
|
||||
;< ~ bind:m (star (^sein:title her))
|
||||
(raw-ship her ~)
|
||||
::
|
||||
:: Mount a desk.
|
||||
::
|
||||
++ mount
|
||||
|= [her=ship des=desk]
|
||||
=/ m (ph ,~)
|
||||
^- form:m
|
||||
;< ~ bind:m (just-events (dojo her "|mount /={(trip des)}="))
|
||||
|= pin=ph-input
|
||||
?: (is-ergo her who.pin uf.pin)
|
||||
[& ~ %done ~]
|
||||
[& ~ %wait ~]
|
||||
::
|
||||
:: Modify /sur/aquarium/hoon on the given ship
|
||||
::
|
||||
++ touch-file
|
||||
|= [her=ship des=desk]
|
||||
=/ m (ph ,@t)
|
||||
^- form:m
|
||||
;< ~ bind:m (mount her des)
|
||||
|= pin=ph-input
|
||||
=/ host-pax
|
||||
/(scot %p our)/home/(scot %da now.pin)/sur/aquarium/hoon
|
||||
=/ warped (cat 3 '=> . ' .^(@t %cx host-pax))
|
||||
[& (insert-file her des host-pax warped) %done warped]
|
||||
::
|
||||
:: Check /sur/aquarium/hoon on the given has the given contents.
|
||||
::
|
||||
++ check-file-touched
|
||||
|= [her=ship des=desk warped=@t]
|
||||
=/ m (ph ,~)
|
||||
^- form:m
|
||||
|= pin=ph-input
|
||||
?. &(=(her who.pin) ?=(?(%init %ergo) -.q.uf.pin))
|
||||
[& ~ %wait ~]
|
||||
=/ pax /home/(scot %da now.pin)/sur/aquarium/hoon
|
||||
=/ aqua-pax
|
||||
;: weld
|
||||
/i/(scot %p her)
|
||||
pax(- des)
|
||||
/noun
|
||||
==
|
||||
?: =(warped (need (scry-aqua (unit @) now.pin aqua-pax)))
|
||||
[& ~ %done ~]
|
||||
[& ~ %wait ~]
|
||||
--
|
||||
90
lib/ph/util.hoon
Normal file
90
lib/ph/util.hoon
Normal file
@ -0,0 +1,90 @@
|
||||
:: Utility functions for constructing tests
|
||||
::
|
||||
/+ ph
|
||||
=, ph
|
||||
|%
|
||||
::
|
||||
:: Turn [ship (list unix-event)] into (list ph-event)
|
||||
::
|
||||
++ send-events-to
|
||||
|= [who=ship what=(list unix-event)]
|
||||
^- (list ph-event)
|
||||
%+ turn what
|
||||
|= ue=unix-event
|
||||
[%event who ue]
|
||||
::
|
||||
:: Start a ship (low-level; prefer +raw-ship)
|
||||
::
|
||||
++ init
|
||||
|= [who=ship keys=(unit dawn-event)]
|
||||
^- (list ph-event)
|
||||
[%init-ship who keys]~
|
||||
::
|
||||
:: Send dojo command
|
||||
::
|
||||
++ dojo
|
||||
|= [who=ship what=tape]
|
||||
^- (list ph-event)
|
||||
%+ send-events-to who
|
||||
^- (list unix-event)
|
||||
:~
|
||||
[//term/1 %belt %ctl `@c`%e]
|
||||
[//term/1 %belt %ctl `@c`%u]
|
||||
[//term/1 %belt %txt ((list @c) what)]
|
||||
[//term/1 %belt %ret ~]
|
||||
==
|
||||
::
|
||||
:: Inject a file into a ship
|
||||
::
|
||||
++ insert-file
|
||||
|= [who=ship des=desk pax=path txt=@t]
|
||||
^- (list ph-event)
|
||||
?> ?=([@ @ @ *] pax)
|
||||
=/ file [/text/plain (as-octs:mimes:html txt)]
|
||||
%+ send-events-to who
|
||||
:~
|
||||
[//sync/0v1n.2m9vh %into des | [t.t.t.pax `file]~]
|
||||
==
|
||||
::
|
||||
:: Checks whether the given event is a dojo output blit containing the
|
||||
:: given tape
|
||||
::
|
||||
++ is-dojo-output
|
||||
|= [who=ship her=ship uf=unix-effect what=tape]
|
||||
?& =(who her)
|
||||
?=(%blit -.q.uf)
|
||||
::
|
||||
%+ lien p.q.uf
|
||||
|= =blit:dill
|
||||
?. ?=(%lin -.blit)
|
||||
|
|
||||
!=(~ (find what p.blit))
|
||||
==
|
||||
::
|
||||
:: Test is successful if +is-dojo-output
|
||||
::
|
||||
++ expect-dojo-output
|
||||
|= [who=ship her=ship uf=unix-effect what=tape]
|
||||
^- (list ph-event)
|
||||
?. (is-dojo-output who her uf what)
|
||||
~
|
||||
[%test-done &]~
|
||||
::
|
||||
:: Check whether the given event is an ergo
|
||||
::
|
||||
++ is-ergo
|
||||
|= [who=ship her=ship uf=unix-effect]
|
||||
?& =(who her)
|
||||
?=(%ergo -.q.uf)
|
||||
==
|
||||
::
|
||||
:: Check if given effect is an http request; extract
|
||||
::
|
||||
++ extract-thus-to
|
||||
|= [uf=unix-effect dest=@t]
|
||||
^- (unit [num=@ud mot=moth:eyre])
|
||||
?. ?=(%thus -.q.uf) ~
|
||||
?~ q.q.uf ~
|
||||
?. =(p.u.q.q.uf (rash dest auri:de-purl:html)) ~
|
||||
`[p.q.uf q.u.q.q.uf]
|
||||
--
|
||||
@ -1,4 +1,3 @@
|
||||
::
|
||||
:: Traditionally, ovo refers to an ovum -- (pair wire card) -- and ova
|
||||
:: refers to a list of them. We have several versions of each of these
|
||||
:: depending on context, so we do away with that naming scheme and use
|
||||
@ -12,6 +11,11 @@
|
||||
:: it's a list.
|
||||
::
|
||||
|%
|
||||
++ ph-event
|
||||
$% [%test-done p=?]
|
||||
aqua-event
|
||||
==
|
||||
::
|
||||
+$ aqua-event
|
||||
$% [%init-ship who=ship keys=(unit dawn-event)]
|
||||
[%pause-events who=ship]
|
||||
@ -55,6 +59,7 @@
|
||||
[%ergo p=@tas q=mode:clay]
|
||||
[%sleep ~]
|
||||
[%restore ~]
|
||||
[%init ~]
|
||||
==
|
||||
+$ pill
|
||||
[boot-ova=* kernel-ova=(list unix-event) userspace-ova=(list unix-event)]
|
||||
|
||||
9
sur/ph.hoon
Normal file
9
sur/ph.hoon
Normal file
@ -0,0 +1,9 @@
|
||||
|%
|
||||
++ cli
|
||||
$% [%init ~]
|
||||
[%cancel ~]
|
||||
[%run lab=term]
|
||||
[%run-all ~]
|
||||
[%print ~]
|
||||
==
|
||||
--
|
||||
@ -2240,6 +2240,7 @@
|
||||
eny=@uvJ
|
||||
ski=sley
|
||||
==
|
||||
^?
|
||||
|%
|
||||
:: :: ++call
|
||||
++ call :: request
|
||||
|
||||
@ -8198,6 +8198,8 @@
|
||||
|= n=@
|
||||
^- tape
|
||||
%- prefix-hex
|
||||
?: =(0 n)
|
||||
"0"
|
||||
%- render-hex-bytes
|
||||
(as-octs:mimes:html n)
|
||||
::
|
||||
|
||||
Loading…
Reference in New Issue
Block a user