ilyakooo0/urbit
1
0
Fork 0
mirror of https://github.com/ilyakooo0/urbit.git synced 2024-09-20 15:08:34 +03:00
Code Issues Packages Projects Releases Wiki Activity

remove non-monadic ph tests and organize

Browse Source
This commit is contained in:
Philip Monk 2019-04-19 17:41:58 -07:00
parent 04f1ed9e94
commit 1ec78c748f
No known key found for this signature in database
GPG Key ID: B66E1F02604E44EC
13 changed files with 649 additions and 1246 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

328
app/ph.hoon
View File

@ -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,27 +34,19 @@
::
+$ state
$: %0
raw-test-cores=(map term raw-test-core)
test-core=(unit test-core-state)
monad-tests=(map term [(list ship) _*data:(ph ,~)])
tests=(map term [(list ship) _*data:(ph ,~)])
other-state
==
::
+$ test-core-state
$% $: %&
lab=term
hers=(list ship)
m-test=_*data:(ph ,~)
==
$: %|
lab=term
hers=(list ship)
cor=raw-test-core
==
$: lab=term
hers=(list ship)
test=_*data:(ph ,~)
==
::
+$ other-state
$: test-qeu=(qeu [? term])
$: test-qeu=(qeu term)
results=(list (pair term ?))
effect-log=(list [who=ship uf=unix-effect])
==
@ -64,194 +58,10 @@
state
==
++ this .
++ test-lib ~(. ^test-lib our.hid)
::
:: Tests that will be run automatically with :ph %run-all-tests
::
++ auto-tests
=, test-lib
^- (list (pair term raw-test-core))
:~
:- %boot-bud
(galaxy ~bud)
::
:- %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)
(send-hi ~bud ~dev)
::
:- %boot-planet
(planet ~linnup-torsyx)
::
:- %hi-grandparent
%+ compose-tests (planet ~linnup-torsyx)
%+ stateless-test
%hi-grandparent
|_ now=@da
++ start
(dojo ~linnup-torsyx "|hi ~bud")
::
++ route
|= [who=ship uf=unix-effect]
(expect-dojo-output ~linnup-torsyx who uf "hi ~bud successful")
--
::
:- %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")
::
++ 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))
=/ static-eth-node
%- malt
^- (list [@t @t])
:~ :- '{"params":[],"id":"block number","jsonrpc":"2.0","method":"eth_blockNumber"}'
'{"id":"block number","jsonrpc":"2.0","result":"0x7"}'
:- '{"params":[{"fromBlock":"0x0","address":"0x863d9c2e5c4c133596cfac29d55255f0d0f86381","toBlock":"0x7"}],"id":"catch up","jsonrpc":"2.0","method":"eth_getLogs"}'
'{"id":"catch up","jsonrpc":"2.0","result":[{"logIndex":"0x0","transactionIndex":"0x0","transactionHash":"0x68ddd548d852373c1a0647be1b0c3df020e34bacbf6f2e2e9ceb4e80db517e3f","blockHash":"0x3783bf0ba0e9de7449c50375d899a72f00f9423a6dd881b677d4768e3ba7855a","blockNumber":"0x1","address":"0x863d9c2e5c4c133596cfac29d55255f0d0f86381","data":"0x000000000000000000000000000000000000000000000000000000000000006000000000000000000000000000000000000000000000000000000000000000a000000000000000000000000000000000000000000000000000000000000000e0000000000000000000000000000000000000000000000000000000000000000b6578616d706c652e636f6d000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000b6578616d706c652e636f6d000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000b6578616d706c652e636f6d000000000000000000000000000000000000000000","topics":["0xfafd04ade1daae2e1fdb0fc1cc6a899fd424063ed5c92120e67e073053b94898"],"type":"mined"},{"logIndex":"0x0","transactionIndex":"0x0","transactionHash":"0x9ccaa993d930767468a34fa04cd13b0b7868d93eb9900b11f2b1f7d55a0670da","blockHash":"0xff1b610fe58f1938fbccf449363ddd574a902f9a3a71771e0215335b4d99abaa","blockNumber":"0x6","address":"0x863d9c2e5c4c133596cfac29d55255f0d0f86381","data":"0x","topics":["0x8be0079c531659141344cd1fd0a4f28419497f9722a3daafe3b4186f6b6457e0","0x0000000000000000000000006deffb0cafdb11d175f123f6891aa64f01c24f7d","0x00000000000000000000000056db68f29203ff44a803faa2404a44ecbb7a7480"],"type":"mined"}]}'
:- '{"params":[{"fromBlock":"0x0","address":"0x863d9c2e5c4c133596cfac29d55255f0d0f86381"}],"id":"new filter","jsonrpc":"2.0","method":"eth_newFilter"}'
'{"id":"new filter","jsonrpc":"2.0","result":"0xa"}'
:- '{"params":["0x0a"],"id":"filter logs","jsonrpc":"2.0","method":"eth_getFilterLogs"}'
'{"id":"filter logs","jsonrpc":"2.0","result":[{"logIndex":"0x0","transactionIndex":"0x0","transactionHash":"0x68ddd548d852373c1a0647be1b0c3df020e34bacbf6f2e2e9ceb4e80db517e3f","blockHash":"0x3783bf0ba0e9de7449c50375d899a72f00f9423a6dd881b677d4768e3ba7855a","blockNumber":"0x1","address":"0x863d9c2e5c4c133596cfac29d55255f0d0f86381","data":"0x000000000000000000000000000000000000000000000000000000000000006000000000000000000000000000000000000000000000000000000000000000a000000000000000000000000000000000000000000000000000000000000000e0000000000000000000000000000000000000000000000000000000000000000b6578616d706c652e636f6d000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000b6578616d706c652e636f6d000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000b6578616d706c652e636f6d000000000000000000000000000000000000000000","topics":["0xfafd04ade1daae2e1fdb0fc1cc6a899fd424063ed5c92120e67e073053b94898"],"type":"mined"},{"logIndex":"0x0","transactionIndex":"0x0","transactionHash":"0x9ccaa993d930767468a34fa04cd13b0b7868d93eb9900b11f2b1f7d55a0670da","blockHash":"0xff1b610fe58f1938fbccf449363ddd574a902f9a3a71771e0215335b4d99abaa","blockNumber":"0x6","address":"0x863d9c2e5c4c133596cfac29d55255f0d0f86381","data":"0x","topics":["0x8be0079c531659141344cd1fd0a4f28419497f9722a3daafe3b4186f6b6457e0","0x0000000000000000000000006deffb0cafdb11d175f123f6891aa64f01c24f7d","0x00000000000000000000000056db68f29203ff44a803faa2404a44ecbb7a7480"],"type":"mined"}]}'
:- '{"params":["0x0a"],"id":"poll filter","jsonrpc":"2.0","method":"eth_getFilterChanges"}'
'{"id":"poll filter","jsonrpc":"2.0","result":[]}'
==
=/ eth-node (spawn-galaxy:az ~rel)
:~ :: :- %boot-az
:: %^ wrap-test-stateful
:: %fake-eth-node
:: router:eth-node
:: %- compose-tests
:: :_ *raw-test-core
:: %+ compose-tests
:: (raw-ship ~bud `(dawn:ph-azimuth ~bud))
:: (touch-file ~bud %home)
::
:: :- %boot-az-hi
:: %^ wrap-test-stateful
:: %fake-eth-node
:: router:eth-node
:: :: %- compose-tests
:: :: :_ *raw-test-core
:: %+ compose-tests
:: %+ compose-tests
:: (raw-ship ~bud `(dawn:ph-azimuth ~bud))
:: (raw-ship ~dev `(dawn:ph-azimuth ~dev))
:: (send-hi ~bud ~dev)
::
:- %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")
--
==
::
++ manual-monad-tests
^- (list (pair term [(list ship) _*data:(ph ,~)]))
=+ ~(. m-test-lib our.hid)
=/ eth-node (spawn-galaxy:az ~rel)
=+ (ph-tests our.hid)
=/ eth-node (spawn-galaxy:ph-azimuth ~rel)
=/ m (ph ,~)
:~ :+ %boot-bud
~[~bud]
@ -286,11 +96,11 @@
:+ %boot-az
~[~bud]
;< [node=_eth-node ~] bind:m
%+ (wrap-filter ,_eth-node ,~)
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
(raw-ship ~bud `(dawn:ph-azimuth ~bud))
(raw-ship ~bud `(dawn:legacy:ph-azimuth ~bud))
;< [node=_eth-node ~] bind:m
%+ (wrap-filter ,_eth-node ,~)
%+ (wrap-philter ,_eth-node ,~)
router:(spawn-galaxy:node ~pem)
stall
(return:m ~)
@ -310,10 +120,7 @@
::
++ install-tests
^+ this
=. raw-test-cores
(~(uni by (malt auto-tests)) (malt manual-tests))
=. monad-tests
(malt manual-monad-tests)
=. tests (malt manual-tests)
this
::
++ prep
@ -396,24 +203,13 @@
`this
=/ throw-away print-results
`this(results ~)
=^ test test-qeu ~(get to test-qeu)
=+ [m=? lab=term]=test
?. m
~& [running-test=lab test-qeu]
=. effect-log ~
=/ res=[events=(list ph-event) new-state=raw-test-core]
~(start (~(got by raw-test-cores) lab) now.hid)
=> .(test-core `(unit test-core-state)`test-core)
=. test-core `[%| lab [ships .]:new-state.res]
=^ moves-1 this (subscribe-to-effects lab ships.new-state.res)
=^ moves-2 this (run-events lab events.res)
[:(weld init-vanes pause-fleet subscribe-vanes moves-1 moves-2) this]
~& [running-m-test=lab test-qeu]
=^ lab test-qeu ~(get to test-qeu)
~& [running-test=lab test-qeu]
=. effect-log ~
=+ ^- [ships=(list ship) m-test=_*data:(ph ,~)]
(~(got by monad-tests) lab)
=+ ^- [ships=(list ship) test=_*data:(ph ,~)]
(~(got by tests) lab)
=> .(test-core `(unit test-core-state)`test-core)
=. test-core `[%& lab ships m-test]
=. 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 ~]~)
@ -486,34 +282,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
(turn auto-tests head)
|= t=term
[| t]
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])
run-test
::
[%run-m-test lab=@tas]
?. (~(has by monad-tests) lab.arg)
~& [%no-test lab.arg]
`this
=. test-qeu (~(put to test-qeu) [& lab.arg])
=. test-qeu (~(put to test-qeu) lab.com)
run-test
::
%cancel
@ -521,6 +299,12 @@
=. 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)
@ -550,60 +334,36 @@
?. =(lab lab.u.test-core)
~& [%ph-dropping-strange lab]
[[ost.hid %pull way [our.hid %aqua] ~]~ this]
?: ?=(%| -.u.test-core)
=+ |- ^- $: thru-effects=(list unix-effect)
events=(list ph-event)
cor=_u.test-core
log=_effect-log
==
?~ ufs.afs
[~ ~ 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
[i.ufs.afs thru-effects]
thru-effects
(weld events-1 events)
cor
[[who i.ufs]:afs log]
=. test-core `cor
=. effect-log (weld log effect-log)
=> .(test-core `(unit test-core-state)`test-core)
=/ moves-1 (publish-aqua-effects who.afs thru-effects)
=^ moves-2 this (run-events lab events)
[(weld moves-1 moves-2) this]
=+ |- ^- $: thru-effects=(list unix-effect)
events=(list ph-event)
log=_effect-log
done=(unit ?)
m-test=_m-test.u.test-core
test=_test.u.test-core
==
?~ ufs.afs
[~ ~ ~ ~ m-test.u.test-core]
[~ ~ ~ ~ test.u.test-core]
=/ m-res=_*ph-output:(ph ,~)
(m-test.u.test-core now.hid who.afs i.ufs.afs)
(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 ?) m-test.u.test-core
=^ done=(unit ?) test.u.test-core
?- -.next.m-res
%wait [~ m-test.u.test-core]
%wait [~ test.u.test-core]
%cont [~ self.next.m-res]
%fail [`| m-test.u.test-core]
%done [`& m-test.u.test-core]
%fail [`| test.u.test-core]
%done [`& test.u.test-core]
==
=+ ^- _$
?~ done
$(ufs.afs t.ufs.afs)
[~ ~ ~ done m-test.u.test-core]
[~ ~ ~ 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 m-test]
=. m-test.u.test-core m-test
[done test]
=. test.u.test-core test
=. effect-log (weld log effect-log)
=> .(test-core `(unit test-core-state)`test-core)
?^ done

6
gen/ph/cancel.hoon Normal file
View File

@ -0,0 +1,6 @@
/- ph
:- %say
|= [* ~ ~]
:- %ph-command
^- cli:ph
[%cancel ~]

6
gen/ph/init.hoon Normal file
View File

@ -0,0 +1,6 @@
/- ph
:- %say
|= [* ~ ~]
:- %ph-command
^- cli:ph
[%init ~]

6
gen/ph/print.hoon Normal file
View File

@ -0,0 +1,6 @@
/- ph
:- %say
|= [* ~ ~]
:- %ph-command
^- cli:ph
[%print ~]

6
gen/ph/run-all.hoon Normal file
View File

@ -0,0 +1,6 @@
/- ph
:- %say
|= [* ~ ~]
:- %ph-command
^- cli:ph
[%run-all ~]

6
gen/ph/run.hoon Normal file
View File

@ -0,0 +1,6 @@
/- ph
:- %say
|= [* [lab=term ~] ~]
:- %ph-command
^- cli:ph
[%run lab]

961
lib/ph.hoon
View File

@ -3,7 +3,6 @@
::
/- aquarium
=, aquarium
=> .
|%
+$ ph-input
[now=@da who=ship uf=unix-effect]
@ -52,964 +51,4 @@
%done [%cont (fun value.next.b-res)]
==
--
::
++ m-test-lib
|_ our=ship
++ stall
|= ph-input
[& ~ %wait ~]
::
++ just-events
|= events=(list ph-event)
=/ m (ph ,~)
^- data:m
|= ph-input
[& events %done ~]
::
:: Scry into a running aqua ship
::
++ scry-aqua
|* [a=mold now=@da pax=path]
.^ a
%gx
(scot %p our)
%aqua
(scot %da now)
pax
==
::
++ boot-ship
|= [her=ship keys=(unit dawn-event)]
^+ *data:(ph ,~)
|= ph-input
[& (init her keys) %done ~]
::
++ check-ship-booted
|= her=ship
^+ *data:(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
"+ /{(scow %p her)}/base/2/web/testing/udon"
::
%^ is-dojo-output her who :- uf
"is your neighbor"
==
::
++ send-hi
|= [from=@p to=@p]
=/ m (ph ,~)
^- data:m
;< ~ bind:m
^- data:m
|= ph-input
[& (dojo from "|hi {(scow %p to)}") %done ~]
^- data:m
|= input=ph-input
^- ph-output:m
:+ & ~
?. (is-dojo-output from who.input uf.input "hi {(scow %p to)} successful")
[%wait ~]
[%done ~]
::
++ raw-ship
|= [her=ship keys=(unit dawn-event)]
=/ m (ph ,~)
^- data:m
;< ~ bind:m (boot-ship her keys)
;< ~ bind:m (check-ship-booted her)
(return:m ~)
::
++ star
|= her=ship
=/ m (ph ,~)
^- data:m
;< ~ bind:m (raw-ship (^sein:title her) ~)
(raw-ship her ~)
::
++ planet
|= her=ship
=/ m (ph ,~)
^- data:m
;< ~ bind:m (star (^sein:title her))
(raw-ship her ~)
::
++ mount
|= [her=ship des=desk]
=/ m (ph ,~)
^- data:m
;< ~ bind:m (just-events (dojo her "|mount /={(trip des)}="))
|= pin=ph-input
?: (is-ergo her who.pin uf.pin)
[& ~ %done ~]
[& ~ %wait ~]
::
++ touch-file
|= [her=ship des=desk]
=/ m (ph ,@t)
^- data: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-file-touched
|= [her=ship des=desk warped=@t]
=/ m (ph ,~)
^- data: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 ~]
--
::
++ philter
|* o=mold
|%
++ output
$~ [& ~ %wait ~]
$: thru=?
events=(list ph-event)
$= next
$% [%wait ~]
[%cont self=data]
==
==
++ data
$_ ^?
|%
++ stay *o
++ run |~(ph-input *output)
--
--
::
++ wrap-filter
|* [o=mold i=mold]
|= [outer=_*data:(philter o) inner=_*data:(ph i)]
^+ *data:(ph ,[o i])
|= input=ph-input
=/ res-i=_*ph-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)
^+ *ph-output:(ph ,[o i])
:+ thru.res-o (welp events.res-i events.res-o)
?- -.next.res-i
%wait
^+ +>:*ph-output:(ph ,[o i])
?- -.next.res-o
%wait [%wait ~]
%cont [%cont ..$(outer self.next.res-o)]
==
::
%cont
^+ +>:*ph-output:(ph ,[o i])
=. inner self.next.res-i
?- -.next.res-o
%wait [%cont ..$]
%cont [%cont ..$(outer self.next.res-o)]
==
::
%fail [%fail ~]
%done
^+ +>:*ph-output:(ph ,[o i])
?- -.next.res-o
%wait [%done stay:outer value.next.res-i]
%cont [%done stay:self.next.res-o value.next.res-i]
==
==
::
:: Defines a complete integration test.
::
++ 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
==
::
:: Call with a +porecelain-test-core create a stateless test.
::
++ 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]~
::
:: 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]
::
+$ az-log [topics=(lest @) data=@t]
++ az
=| 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)
^+ *data: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 (lent logs)))
?: =(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 (lent logs) eth-filter]
?~ eth-filter
~|(%no-filter-not-implemented !!)
:+ |
%+ answer-request req
(logs-to-json from-block.u.eth-filter (lent logs))
=. last-block.u.eth-filter (lent logs)
[%cont ..stay]
?: =(method 'eth_getFilterChanges')
~& [%filter-changes (lent logs) eth-filter]
?~ eth-filter
~|(%no-filter-not-implemented !!)
:+ |
%+ answer-request req
(logs-to-json last-block.u.eth-filter (lent logs))
=. last-block.u.eth-filter (lent logs)
[%cont ..stay]
[& ~ %wait ~]
::
++ 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
[from-block (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)
--
::
++ ph-azimuth
|%
++ 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]
--
::
++ 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]
--
::
:: Wrap a test with an effect filter.
::
:: This allows intercepting particular effects for special
:: handling.
::
++ wrap-test
|= $: lab=@ta
filter=$-([ship unix-effect] [thru=? pe=(list ph-event)])
cor=raw-test-core
==
^- raw-test-core
|_ now=@da
++ label :((cury cat 3) label:cor '--w--' lab)
++ ships ships:cor
++ start
=^ events cor ~(start cor now)
[events ..start]
::
++ route
|= [who=ship uf=unix-effect]
^- [? (quip ph-event _^|(..start))]
=+ ^- [thru-test=? events-test=(list ph-event) cor-test=_cor]
(~(route cor now) who uf)
=. cor cor-test
?. thru-test
[| events-test ..start]
=+ ^- [thru-filter=? events-filter=(list ph-event)]
(filter who uf)
[thru-filter (weld events-test events-filter) ..start]
--
::
:: Wrap a test with an effect filter.
::
:: This allows intercepting particular effects for special
:: handling.
::
++ wrap-test-stateful
|= $: lab=@ta
::
$= filter
$_ |~ [ship unix-effect]
*[thru=? pe=(list ph-event) self=_^|(..$)]
::
cor=raw-test-core
==
^- raw-test-core
|_ now=@da
++ label :((cury cat 3) label:cor '--ws--' lab)
++ ships ships:cor
++ start
=^ events cor ~(start cor now)
[events ..start]
::
++ route
|= [who=ship uf=unix-effect]
^- [? (quip ph-event _^|(..start))]
=+ ^- [thru-test=? events-test=(list ph-event) cor-test=_cor]
(~(route cor now) who uf)
=. cor cor-test
?. thru-test
[| events-test ..start]
=+ ^- res=[thru=? events=(list ph-event) filter=_filter]
(filter who uf)
=. filter filter.res
[thru.res (weld events-test events.res) ..start]
--
::
:: Mock HTTP responses to particular requests
::
++ wrap-test-http
|= [url=@t responses=(list $-(@t (unit @t))) cor=raw-test-core]
%^ wrap-test
(cat 3 'http-' (scot %uw (mug url responses)))
|= [who=ship uf=unix-effect]
^- [? (list ph-event)]
=/ thus (extract-thus-to uf url)
?~ thus
[& ~]
?~ r.mot.u.thus
[& ~]
|- ^- [? (list ph-event)]
?~ responses
[& ~]
=/ resp (i.responses q.u.r.mot.u.thus)
?~ resp
$(responses t.responses)
:- | :_ ~
:* %event
who
//http/0v1n.2m9vh
%they
num.u.thus
[200 ~ `(as-octs:mimes:html u.resp)]
==
cor
::
:: 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
"+ /{(scow %p her)}/base/2/web/testing/udon"
~
[%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]
~
--
::
:: Send hi from one ship to another
::
++ send-hi
|= [from=@p to=@p]
%+ stateless-test
:((cury cat 3) 'hi-' (scot %p from) '-' (scot %p to))
|_ now=@da
++ start
(dojo from "|hi {(scow %p to)}")
::
++ route
|= [who=ship uf=unix-effect]
(expect-dojo-output from who uf "hi {(scow %p to)} successful")
--
::
:: Scry into a running aqua ship
::
++ scry-aqua
|* [a=mold now=@da pax=path]
.^ a
%gx
(scot %p our)
%aqua
(scot %da now)
pax
==
--
--

231
lib/ph/azimuth.hoon Normal file
View File

@ -0,0 +1,231 @@
:: 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)
^- data: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 (lent logs)))
?: =(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 (lent logs) eth-filter]
?~ eth-filter
~|(%no-filter-not-implemented !!)
:+ |
%+ answer-request req
(logs-to-json from-block.u.eth-filter (lent logs))
=. last-block.u.eth-filter (lent logs)
[%cont ..stay]
?: =(method 'eth_getFilterChanges')
~& [%filter-changes (lent logs) eth-filter]
?~ eth-filter
~|(%no-filter-not-implemented !!)
:+ |
%+ answer-request req
(logs-to-json last-block.u.eth-filter (lent logs))
=. last-block.u.eth-filter (lent logs)
[%cont ..stay]
[& ~ %wait ~]
::
++ 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
[from-block (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
View 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=data]
==
==
++ data
$_ ^?
|%
++ 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=_*data:(philter o) inner=_*data:(ph i)]
^+ *data:(ph ,[o i])
|= input=ph-input
=/ res-i=_*ph-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)
^+ *ph-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]
==
==
--

164
lib/ph/tests.hoon Normal file
View File

@ -0,0 +1,164 @@
:: 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 ,~)
^- data:m
|= ph-input
[& events %done ~]
::
:: Boot ship; don't check it succeeded.
::
++ boot-ship
|= [her=ship keys=(unit dawn-event)]
^+ *data:(ph ,~)
|= ph-input
[& (init her keys) %done ~]
::
:: Wait until ship has finished booting.
::
++ check-ship-booted
|= her=ship
^+ *data:(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
"+ /{(scow %p her)}/base/2/web/testing/udon"
::
%^ is-dojo-output her who :- uf
"is your neighbor"
==
::
:: Send "|hi" from one ship to another
::
++ send-hi
|= [from=@p to=@p]
=/ m (ph ,~)
^- data:m
;< ~ bind:m
^- data:m
|= ph-input
[& (dojo from "|hi {(scow %p to)}") %done ~]
^- data:m
|= input=ph-input
^- ph-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 ,~)
^- data:m
;< ~ bind:m (boot-ship her keys)
;< ~ bind:m (check-ship-booted her)
(return:m ~)
::
:: Boot a fake star and its parent.
::
++ star
|= her=ship
=/ m (ph ,~)
^- data: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 ,~)
^- data:m
;< ~ bind:m (star (^sein:title her))
(raw-ship her ~)
::
:: Mount a desk.
::
++ mount
|= [her=ship des=desk]
=/ m (ph ,~)
^- data: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)
^- data: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 ,~)
^- data: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
View 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]
--

6
sur/aquarium.hoon
View File

@ -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]

9
sur/ph.hoon Normal file
View File

@ -0,0 +1,9 @@
|%
++ cli
$% [%init ~]
[%cancel ~]
[%run lab=term]
[%run-all ~]
[%print ~]
==
--