mirror of
https://github.com/urbit/shrub.git
synced 2025-01-05 19:46:50 +03:00
Jared Tobin
GitHub
commit
d2724bb705
@ -85,7 +85,7 @@ function barMass(urb) {
|
|||||||
function aqua(urb) {
|
function aqua(urb) {
|
||||||
return urb.line("|start %ph")
|
return urb.line("|start %ph")
|
||||||
.then(function(){
|
.then(function(){
|
||||||
return urb.line(":ph %init");
|
return urb.line(":ph|init");
|
||||||
})
|
})
|
||||||
.then(function(){
|
.then(function(){
|
||||||
return urb.line(":aqua &pill +solid");
|
return urb.line(":aqua &pill +solid");
|
||||||
@ -94,7 +94,7 @@ function aqua(urb) {
|
|||||||
urb.every(/TEST [^ ]* FAILED/, function(arg){
|
urb.every(/TEST [^ ]* FAILED/, function(arg){
|
||||||
throw Error(arg);
|
throw Error(arg);
|
||||||
});
|
});
|
||||||
return urb.line(":ph [%run-test %hi]");
|
return urb.line(":ph|run %hi");
|
||||||
})
|
})
|
||||||
.then(function(){
|
.then(function(){
|
||||||
return urb.expectEcho("ALL TESTS SUCCEEDED")
|
return urb.expectEcho("ALL TESTS SUCCEEDED")
|
||||||
|
|||||||
@ -57,6 +57,7 @@ Most parts of Arvo have dedicated maintainers.
|
|||||||
* `/app/dns`: @joemfb (~master-morzod)
|
* `/app/dns`: @joemfb (~master-morzod)
|
||||||
* `/app/hall`: @fang- (~palfun-foslup)
|
* `/app/hall`: @fang- (~palfun-foslup)
|
||||||
* `/app/talk`: @fang- (~palfun-foslup)
|
* `/app/talk`: @fang- (~palfun-foslup)
|
||||||
|
* `/app/aqua`: @philipcmonk (~wicdev-wisryt)
|
||||||
* `/lib/test`: @eglaysher (~littel-ponnys)
|
* `/lib/test`: @eglaysher (~littel-ponnys)
|
||||||
|
|
||||||
## Contact
|
## Contact
|
||||||
|
|||||||
@ -117,10 +117,13 @@
|
|||||||
?> ?=(%0 -.poke-arm)
|
?> ?=(%0 -.poke-arm)
|
||||||
=/ poke p.poke-arm
|
=/ poke p.poke-arm
|
||||||
=. tym (max +(tym) now.hid)
|
=. tym (max +(tym) now.hid)
|
||||||
=/ poke-result (slum poke tym ue)
|
=/ poke-result (mule |.((slum poke tym ue)))
|
||||||
=. snap +.poke-result
|
?: ?=(%| -.poke-result)
|
||||||
|
%- (slog >%aqua-crash< p.poke-result)
|
||||||
|
$
|
||||||
|
=. snap +.p.poke-result
|
||||||
=. ..abet-pe (publish-event tym ue)
|
=. ..abet-pe (publish-event tym ue)
|
||||||
=. ..abet-pe (handle-effects ((list ovum) -.poke-result))
|
=. ..abet-pe (handle-effects ((list ovum) -.p.poke-result))
|
||||||
$
|
$
|
||||||
::
|
::
|
||||||
:: Peek
|
:: Peek
|
||||||
@ -458,6 +461,8 @@
|
|||||||
%event
|
%event
|
||||||
~? &(aqua-debug=| !?=(?(%belt %hear) -.q.ue.ae))
|
~? &(aqua-debug=| !?=(?(%belt %hear) -.q.ue.ae))
|
||||||
raw-event=[who.ae -.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]~)
|
(push-events:(pe who.ae) [ue.ae]~)
|
||||||
==
|
==
|
||||||
::
|
::
|
||||||
|
|||||||
326
app/ph.hoon
326
app/ph.hoon
@ -7,10 +7,12 @@
|
|||||||
:: - Restore a fleet
|
:: - Restore a fleet
|
||||||
:: - Compose tests
|
:: - Compose tests
|
||||||
::
|
::
|
||||||
/- aquarium
|
/- aquarium, ph
|
||||||
/+ ph
|
/+ ph, ph-tests, ph-azimuth, ph-philter
|
||||||
|
=, ph-sur=^ph
|
||||||
=, aquarium
|
=, aquarium
|
||||||
=, ph
|
=, ph
|
||||||
|
=, ph-philter
|
||||||
=> $~ |%
|
=> $~ |%
|
||||||
+$ move (pair bone card)
|
+$ move (pair bone card)
|
||||||
+$ card
|
+$ card
|
||||||
@ -32,20 +34,21 @@
|
|||||||
::
|
::
|
||||||
+$ state
|
+$ state
|
||||||
$: %0
|
$: %0
|
||||||
raw-test-cores=(map term raw-test-core)
|
|
||||||
test-core=(unit test-core-state)
|
test-core=(unit test-core-state)
|
||||||
|
tests=(map term [(list ship) _*form:(ph ,~)])
|
||||||
other-state
|
other-state
|
||||||
==
|
==
|
||||||
::
|
::
|
||||||
+$ test-core-state
|
+$ test-core-state
|
||||||
$: hers=(list ship)
|
$: lab=term
|
||||||
cor=raw-test-core
|
hers=(list ship)
|
||||||
effect-log=(list [who=ship uf=unix-effect])
|
test=_*form:(ph ,~)
|
||||||
==
|
==
|
||||||
::
|
::
|
||||||
+$ other-state
|
+$ other-state
|
||||||
$: test-qeu=(qeu term)
|
$: test-qeu=(qeu term)
|
||||||
results=(list (pair term ?))
|
results=(list (pair term ?))
|
||||||
|
effect-log=(list [who=ship uf=unix-effect])
|
||||||
==
|
==
|
||||||
--
|
--
|
||||||
=, gall
|
=, gall
|
||||||
@ -55,176 +58,70 @@
|
|||||||
state
|
state
|
||||||
==
|
==
|
||||||
++ this .
|
++ this .
|
||||||
++ test-lib ~(. ^test-lib our.hid)
|
++ manual-tests
|
||||||
::
|
^- (list (pair term [(list ship) _*form:(ph ,~)]))
|
||||||
:: Tests that will be run automatically with :ph %run-all-tests
|
=+ (ph-tests our.hid)
|
||||||
::
|
=/ eth-node (spawn-galaxy:ph-azimuth ~rel)
|
||||||
++ auto-tests
|
=/ m (ph ,~)
|
||||||
=, test-lib
|
:~ :+ %boot-bud
|
||||||
^- (list (pair term raw-test-core))
|
~[~bud]
|
||||||
:~
|
(raw-ship ~bud ~)
|
||||||
:- %boot-bud
|
|
||||||
(galaxy ~bud)
|
|
||||||
::
|
::
|
||||||
:- %add
|
:+ %add
|
||||||
^- raw-test-core
|
~[~bud]
|
||||||
%+ compose-tests (galaxy ~bud)
|
;< ~ bind:m (raw-ship ~bud ~)
|
||||||
%+ stateless-test
|
|= pin=ph-input
|
||||||
%add
|
?: =(%init -.q.uf.pin)
|
||||||
|_ now=@da
|
[& (dojo ~bud "[%test-result (add 2 3)]") %wait ~]
|
||||||
++ start
|
?: (is-dojo-output ~bud who.pin uf.pin "[%test-result 5]")
|
||||||
(dojo ~bud "[%test-result (add 2 3)]")
|
[& ~ %done ~]
|
||||||
|
[& ~ %wait ~]
|
||||||
::
|
::
|
||||||
++ route
|
:+ %hi
|
||||||
|= [who=ship uf=unix-effect]
|
~[~bud ~dev]
|
||||||
(expect-dojo-output ~bud who uf "[%test-result 5]")
|
;< ~ bind:m (raw-ship ~bud ~)
|
||||||
--
|
;< ~ bind:m (raw-ship ~dev ~)
|
||||||
|
(send-hi ~bud ~dev)
|
||||||
::
|
::
|
||||||
:- %hi
|
:+ %boot-planet
|
||||||
%+ compose-tests
|
~[~bud ~marbud ~linnup-torsyx]
|
||||||
%+ 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
|
|
||||||
(planet ~linnup-torsyx)
|
(planet ~linnup-torsyx)
|
||||||
::
|
::
|
||||||
:- %hi-grandparent
|
:+ %second-cousin-hi
|
||||||
%+ compose-tests (planet ~linnup-torsyx)
|
~[~bud ~marbud ~linnup-torsyx ~dev ~mardev ~mitnep-todsut]
|
||||||
%+ stateless-test
|
;< ~ bind:m (planet ~linnup-torsyx)
|
||||||
%hi-grandparent
|
;< ~ bind:m (planet ~mitnep-todsut)
|
||||||
|_ now=@da
|
(send-hi ~linnup-torsyx ~mitnep-todsut)
|
||||||
++ start
|
|
||||||
(dojo ~linnup-torsyx "|hi ~bud")
|
|
||||||
::
|
::
|
||||||
++ route
|
:+ %change-file
|
||||||
|= [who=ship uf=unix-effect]
|
~[~bud]
|
||||||
(expect-dojo-output ~linnup-torsyx who uf "hi ~bud successful")
|
;< ~ bind:m (raw-ship ~bud ~)
|
||||||
--
|
;< file=@t bind:m (touch-file ~bud %home)
|
||||||
|
(check-file-touched ~bud %home file)
|
||||||
::
|
::
|
||||||
:- %second-cousin-hi
|
:+ %child-sync
|
||||||
%+ compose-tests
|
~[~bud ~marbud]
|
||||||
%+ compose-tests (planet ~mitnep-todsut)
|
;< ~ bind:m (star ~marbud)
|
||||||
(planet ~haplun-todtus)
|
;< file=@t bind:m (touch-file ~bud %base)
|
||||||
%+ stateless-test
|
(check-file-touched ~marbud %home file)
|
||||||
%second-cousin-hi
|
|
||||||
|_ now=@da
|
|
||||||
++ start
|
|
||||||
(dojo ~haplun-todtus "|hi ~mitnep-todsut")
|
|
||||||
::
|
::
|
||||||
++ route
|
:+ %boot-az
|
||||||
|= [who=ship uf=unix-effect]
|
~[~bud]
|
||||||
(expect-dojo-output ~haplun-todtus who uf "hi ~mitnep-todsut successful")
|
;< [node=_eth-node ~] bind:m
|
||||||
--
|
%+ (wrap-philter ,_eth-node ,~)
|
||||||
::
|
router:eth-node
|
||||||
:- %change-file
|
(raw-ship ~bud `(dawn:legacy:ph-azimuth ~bud))
|
||||||
%+ compose-tests (galaxy ~bud)
|
=. node (spawn-galaxy:node ~pem)
|
||||||
(touch-file ~bud %home)
|
;< [node=_eth-node ~] bind:m
|
||||||
::
|
%+ (wrap-philter ,_eth-node ,~)
|
||||||
:- %child-sync
|
router:node
|
||||||
%+ compose-tests
|
(pure:m ~)
|
||||||
%+ compose-tests
|
(pure:m ~)
|
||||||
(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")
|
|
||||||
--
|
|
||||||
==
|
==
|
||||||
::
|
::
|
||||||
++ install-tests
|
++ install-tests
|
||||||
^+ this
|
^+ this
|
||||||
=. raw-test-cores
|
=. tests (malt manual-tests)
|
||||||
(~(uni by (malt auto-tests)) (malt manual-tests))
|
|
||||||
this
|
this
|
||||||
::
|
::
|
||||||
++ prep
|
++ prep
|
||||||
@ -260,9 +157,6 @@
|
|||||||
?~ what
|
?~ what
|
||||||
[%& ~]
|
[%& ~]
|
||||||
?: ?=(%test-done -.i.what)
|
?: ?=(%test-done -.i.what)
|
||||||
~& ?~ p.i.what
|
|
||||||
"TEST {(trip lab)} SUCCESSFUL"
|
|
||||||
"TEST {(trip lab)} FAILED"
|
|
||||||
[%| p.i.what]
|
[%| p.i.what]
|
||||||
=/ nex $(what t.what)
|
=/ nex $(what t.what)
|
||||||
?: ?=(%| -.nex)
|
?: ?=(%| -.nex)
|
||||||
@ -281,6 +175,9 @@
|
|||||||
^- (quip move _this)
|
^- (quip move _this)
|
||||||
?~ test-core
|
?~ test-core
|
||||||
`this
|
`this
|
||||||
|
~& ?: success
|
||||||
|
"TEST {(trip lab)} SUCCESSFUL"
|
||||||
|
"TEST {(trip lab)} FAILED"
|
||||||
:_ this(test-core ~, results [[lab success] results])
|
:_ this(test-core ~, results [[lab success] results])
|
||||||
%- zing
|
%- zing
|
||||||
%+ turn hers.u.test-core
|
%+ turn hers.u.test-core
|
||||||
@ -309,12 +206,14 @@
|
|||||||
`this(results ~)
|
`this(results ~)
|
||||||
=^ lab test-qeu ~(get to test-qeu)
|
=^ lab test-qeu ~(get to test-qeu)
|
||||||
~& [running-test=lab test-qeu]
|
~& [running-test=lab test-qeu]
|
||||||
=/ res=[events=(list ph-event) new-state=raw-test-core]
|
=. effect-log ~
|
||||||
~(start (~(got by raw-test-cores) lab) now.hid)
|
=+ ^- [ships=(list ship) test=_*form:(ph ,~)]
|
||||||
|
(~(got by tests) lab)
|
||||||
=> .(test-core `(unit test-core-state)`test-core)
|
=> .(test-core `(unit test-core-state)`test-core)
|
||||||
=. test-core `[ships . ~]:new-state.res
|
=. test-core `[lab ships test]
|
||||||
=^ moves-1 this (subscribe-to-effects lab ships.new-state.res)
|
=^ moves-1 this (subscribe-to-effects lab ships)
|
||||||
=^ moves-2 this (run-events lab events.res)
|
=^ moves-2 this
|
||||||
|
(diff-aqua-effects /[lab]/(scot %p -.ships) -.ships [/ %init ~]~)
|
||||||
[:(weld init-vanes pause-fleet subscribe-vanes moves-1 moves-2) this]
|
[:(weld init-vanes pause-fleet subscribe-vanes moves-1 moves-2) this]
|
||||||
::
|
::
|
||||||
:: Print results with ~&
|
:: Print results with ~&
|
||||||
@ -384,24 +283,16 @@
|
|||||||
::
|
::
|
||||||
:: User interface
|
:: User interface
|
||||||
::
|
::
|
||||||
++ poke-noun
|
++ poke-ph-command
|
||||||
|= arg=*
|
|= com=cli:ph-sur
|
||||||
^- (quip move _this)
|
^- (quip move _this)
|
||||||
?+ arg ~|(%bad-noun-arg !!)
|
?- -.com
|
||||||
%init
|
%init [init-vanes this]
|
||||||
[init-vanes this]
|
%run
|
||||||
::
|
?. (~(has by tests) lab.com)
|
||||||
%run-all-tests
|
~& [%no-test lab.com]
|
||||||
=. 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]
|
|
||||||
`this
|
`this
|
||||||
=. test-qeu (~(put to test-qeu) lab.arg)
|
=. test-qeu (~(put to test-qeu) lab.com)
|
||||||
run-test
|
run-test
|
||||||
::
|
::
|
||||||
%cancel
|
%cancel
|
||||||
@ -409,11 +300,16 @@
|
|||||||
=. test-qeu ~
|
=. test-qeu ~
|
||||||
=^ moves-2 this run-test
|
=^ moves-2 this run-test
|
||||||
[:(weld moves-1 moves-2) this]
|
[:(weld moves-1 moves-2) this]
|
||||||
|
::
|
||||||
|
%run-all
|
||||||
|
=. test-qeu
|
||||||
|
%- ~(gas to test-qeu)
|
||||||
|
(turn manual-tests head)
|
||||||
|
run-test
|
||||||
::
|
::
|
||||||
%print
|
%print
|
||||||
=/ log effect-log:(need test-core)
|
~& lent=(lent effect-log)
|
||||||
~& lent=(lent log)
|
~& %+ roll effect-log
|
||||||
~& %+ roll log
|
|
||||||
|= [[who=ship uf=unix-effect] ~]
|
|= [[who=ship uf=unix-effect] ~]
|
||||||
?: ?=(?(%blit %doze) -.q.uf)
|
?: ?=(?(%blit %doze) -.q.uf)
|
||||||
~
|
~
|
||||||
@ -434,27 +330,47 @@
|
|||||||
?> ?=([@tas @ ~] way)
|
?> ?=([@tas @ ~] way)
|
||||||
=/ lab i.way
|
=/ lab i.way
|
||||||
?~ test-core
|
?~ test-core
|
||||||
~& [%ph-dropping lab]
|
~& [%ph-dropping-done lab]
|
||||||
`this
|
[[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)
|
=+ |- ^- $: thru-effects=(list unix-effect)
|
||||||
events=(list ph-event)
|
events=(list ph-event)
|
||||||
cor=_u.test-core
|
log=_effect-log
|
||||||
|
done=(unit ?)
|
||||||
|
test=_test.u.test-core
|
||||||
==
|
==
|
||||||
?~ ufs.afs
|
?~ ufs.afs
|
||||||
[~ ~ u.test-core]
|
[~ ~ ~ ~ test.u.test-core]
|
||||||
=. effect-log.u.test-core
|
=/ m-res=_*output:(ph ,~)
|
||||||
[[who i.ufs]:afs effect-log.u.test-core]
|
(test.u.test-core now.hid who.afs i.ufs.afs)
|
||||||
=+ ^- [thru=? events-1=(list ph-event) cor=_cor.u.test-core]
|
=? ufs.afs =(%cont -.next.m-res)
|
||||||
(~(route cor.u.test-core now.hid) who.afs i.ufs.afs)
|
[i.ufs.afs [/ %init ~] t.ufs.afs]
|
||||||
=. cor.u.test-core cor
|
=^ done=(unit ?) test.u.test-core
|
||||||
=+ $(ufs.afs t.ufs.afs)
|
?- -.next.m-res
|
||||||
:+ ?: thru
|
%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]
|
[i.ufs.afs thru-effects]
|
||||||
thru-effects
|
thru-effects
|
||||||
(weld events-1 events)
|
(weld events.m-res events)
|
||||||
cor
|
[[who i.ufs]:afs log]
|
||||||
=. test-core `cor
|
[done test]
|
||||||
|
=. test.u.test-core test
|
||||||
|
=. effect-log (weld log effect-log)
|
||||||
=> .(test-core `(unit test-core-state)`test-core)
|
=> .(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-1 (publish-aqua-effects who.afs thru-effects)
|
||||||
=^ moves-2 this (run-events lab events)
|
=^ moves-2 this (run-events lab events)
|
||||||
[(weld moves-1 moves-2) this]
|
[(weld moves-1 moves-2) this]
|
||||||
|
|||||||
@ -1,7 +1,7 @@
|
|||||||
/- aquarium
|
/- aquarium
|
||||||
=, aquarium
|
=, aquarium
|
||||||
:- %say
|
:- %say
|
||||||
|= [* [her=ship command=tape] ~]
|
|= [* [her=ship command=tape ~] ~]
|
||||||
:- %aqua-events
|
:- %aqua-events
|
||||||
%+ turn
|
%+ turn
|
||||||
^- (list unix-event)
|
^- (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]
|
||||||
533
lib/ph.hoon
533
lib/ph.hoon
@ -1,473 +1,86 @@
|
|||||||
|
:: Defines the ph monad.
|
||||||
|
::
|
||||||
|
:: 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.
|
||||||
::
|
::
|
||||||
:::: /hoon/ph/lib
|
|
||||||
::
|
|
||||||
/- aquarium
|
/- aquarium
|
||||||
=, aquarium
|
=, aquarium
|
||||||
|%
|
|%
|
||||||
:: Defines a complete integration test.
|
+$ ph-input
|
||||||
|
[now=@da who=ship uf=unix-effect]
|
||||||
::
|
::
|
||||||
++ raw-test-core
|
++ ph-output-raw
|
||||||
$_ ^|
|
|* a=mold
|
||||||
|_ now=@da
|
$~ [& ~ %done *a]
|
||||||
::
|
$: thru=?
|
||||||
:: Unique name, used as a cache label.
|
events=(list ph-event)
|
||||||
::
|
$= next
|
||||||
++ label *@ta
|
$% [%wait ~]
|
||||||
::
|
[%cont self=(ph-form-raw a)]
|
||||||
:: List of ships that are part of the test.
|
[%fail ~]
|
||||||
::
|
[%done value=a]
|
||||||
:: 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.
|
++ ph-form-raw
|
||||||
|
|* a=mold
|
||||||
|
$-(ph-input (ph-output-raw a))
|
||||||
::
|
::
|
||||||
++ porcelain-test
|
++ ph
|
||||||
|= [label=@ta porcelain=porcelain-test-core]
|
|* a=mold
|
||||||
^- 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
|
|
||||||
|%
|
|%
|
||||||
++ dawn
|
++ output (ph-output-raw a)
|
||||||
|= who=ship
|
++ form (ph-form-raw a)
|
||||||
^- dawn-event
|
++ pure
|
||||||
:* (need (private-key who))
|
|= arg=a
|
||||||
(^sein:title who)
|
^- form
|
||||||
czar
|
|= ph-input
|
||||||
~[~['arvo' 'netw' 'ork']]
|
[& ~ %done arg]
|
||||||
0
|
|
||||||
`(need (de-purl:html 'http://localhost:8545'))
|
|
||||||
~
|
|
||||||
==
|
|
||||||
::
|
::
|
||||||
++ czar
|
++ bind
|
||||||
^- (map ship [life pass])
|
|* b=mold
|
||||||
%- my
|
|= [m-b=(ph-form-raw b) fun=$-(b form)]
|
||||||
^- (list (pair ship [life pass]))
|
^- form
|
||||||
%+ murn (gulf 0x0 0xff)
|
|= input=ph-input
|
||||||
|= her=ship
|
=/ b-res=(ph-output-raw b)
|
||||||
^- (unit [ship life pass])
|
(m-b input)
|
||||||
=/ pub (public-key her)
|
^- output
|
||||||
?~ pub
|
:+ thru.b-res events.b-res
|
||||||
~
|
?- -.next.b-res
|
||||||
`[her u.pub]
|
%wait [%wait ~]
|
||||||
::
|
%cont [%cont ..$(m-b self.next.b-res)]
|
||||||
++ private-key
|
%fail [%fail ~]
|
||||||
|= who=ship
|
%done [%cont (fun value.next.b-res)]
|
||||||
=- (~(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
|
|
||||||
==
|
==
|
||||||
--
|
--
|
||||||
--
|
--
|
||||||
|
|||||||
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
|
:: 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
|
:: 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
|
:: depending on context, so we do away with that naming scheme and use
|
||||||
@ -12,6 +11,11 @@
|
|||||||
:: it's a list.
|
:: it's a list.
|
||||||
::
|
::
|
||||||
|%
|
|%
|
||||||
|
++ ph-event
|
||||||
|
$% [%test-done p=?]
|
||||||
|
aqua-event
|
||||||
|
==
|
||||||
|
::
|
||||||
+$ aqua-event
|
+$ aqua-event
|
||||||
$% [%init-ship who=ship keys=(unit dawn-event)]
|
$% [%init-ship who=ship keys=(unit dawn-event)]
|
||||||
[%pause-events who=ship]
|
[%pause-events who=ship]
|
||||||
@ -55,6 +59,7 @@
|
|||||||
[%ergo p=@tas q=mode:clay]
|
[%ergo p=@tas q=mode:clay]
|
||||||
[%sleep ~]
|
[%sleep ~]
|
||||||
[%restore ~]
|
[%restore ~]
|
||||||
|
[%init ~]
|
||||||
==
|
==
|
||||||
+$ pill
|
+$ pill
|
||||||
[boot-ova=* kernel-ova=(list unix-event) userspace-ova=(list unix-event)]
|
[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
|
eny=@uvJ
|
||||||
ski=sley
|
ski=sley
|
||||||
==
|
==
|
||||||
|
^?
|
||||||
|%
|
|%
|
||||||
:: :: ++call
|
:: :: ++call
|
||||||
++ call :: request
|
++ call :: request
|
||||||
|
|||||||
@ -8198,6 +8198,8 @@
|
|||||||
|= n=@
|
|= n=@
|
||||||
^- tape
|
^- tape
|
||||||
%- prefix-hex
|
%- prefix-hex
|
||||||
|
?: =(0 n)
|
||||||
|
"0"
|
||||||
%- render-hex-bytes
|
%- render-hex-bytes
|
||||||
(as-octs:mimes:html n)
|
(as-octs:mimes:html n)
|
||||||
::
|
::
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user