urbit/lib/ph.hoon

904 lines
23 KiB
Plaintext
Raw Normal View History

2019-02-06 05:21:41 +03:00
::
:::: /hoon/ph/lib
::
/- aquarium
=, aquarium
2019-04-14 05:51:46 +03:00
=> .
2019-02-06 05:21:41 +03:00
|%
2019-04-13 09:54:30 +03:00
+$ ph-input
[who=ship uf=unix-effect]
::
++ ph
|* a=mold
|%
2019-04-18 23:52:00 +03:00
++ ph-output (ph-output-raw a)
++ ph-output-raw
|* a=mold
2019-04-14 05:51:46 +03:00
$~ [& ~ %done & *a]
$: thru=?
2019-04-13 09:54:30 +03:00
events=(list ph-event)
2019-04-14 05:51:46 +03:00
$= next
$% [%wait ~]
2019-04-18 23:52:00 +03:00
[%cont self=(data-raw a)]
2019-04-14 05:51:46 +03:00
[%done success=? value=a]
==
2019-04-13 09:54:30 +03:00
==
::
2019-04-18 23:52:00 +03:00
++ data (data-raw a)
++ data-raw
|* a=mold
$-(ph-input (ph-output-raw a))
::
2019-04-13 09:54:30 +03:00
++ return
|= arg=a
2019-04-14 05:51:46 +03:00
^- data
2019-04-13 09:54:30 +03:00
|= ph-input
2019-04-14 05:51:46 +03:00
[& ~ %done & arg]
2019-04-18 23:52:00 +03:00
::
++ bind
2019-04-13 09:54:30 +03:00
|* b=mold
2019-04-18 23:52:00 +03:00
|= [m-b=(data-raw b) fun=$-(b data)]
^- data
2019-04-13 09:54:30 +03:00
|= input=ph-input
2019-04-18 23:52:00 +03:00
=/ b-res=(ph-output-raw b)
(m-b input)
^- ph-output
:+ thru.b-res events.b-res
?- -.next.b-res
2019-04-14 05:51:46 +03:00
%wait [%wait ~]
%cont
:- %cont
|= input-inner=ph-input
2019-04-18 23:52:00 +03:00
^$(m-b self.next.b-res, input input-inner)
2019-04-14 05:51:46 +03:00
::
%done
2019-04-18 23:52:00 +03:00
?. success.next.b-res
[%done | *a]
2019-04-14 05:51:46 +03:00
:- %cont
2019-04-18 23:52:00 +03:00
(fun value.next.b-res)
2019-04-14 05:51:46 +03:00
==
2019-04-18 23:52:00 +03:00
--
::
++ m-test-lib
|%
2019-04-14 05:51:46 +03:00
++ boot-ship
|= [her=ship keys=(unit dawn-event)]
^+ *data:(ph ,[%booted who=@p])
|= ph-input
~& %first-i
2019-04-18 23:52:00 +03:00
[& (init her ~) %done & %booted her]
2019-04-14 05:51:46 +03:00
::
++ check-ship-booted
|= her=ship
^+ *data:(ph ,[%boot-done whodunnit=@p])
|= ph-input
=; done=?
~& [%second-i done]
:+ & ~
?: done
[%done & %boot-done her]
[%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.
::
?|
2019-04-18 23:52:00 +03:00
%^ is-dojo-output her who :- uf
"+ /{(scow %p her)}/base/2/web/testing/udon"
2019-04-14 05:51:46 +03:00
::
2019-04-18 23:52:00 +03:00
%^ is-dojo-output her who :- uf
2019-04-14 05:51:46 +03:00
"is your neighbor"
==
2019-04-13 09:54:30 +03:00
::
2019-04-18 23:52:00 +03:00
++ 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 & ~]
::
2019-04-14 05:51:46 +03:00
++ raw-ship
|= [her=ship keys=(unit dawn-event)]
:: [%boot-done h=@p] ~&(who-monad=who (check-ship-booted her)),
:: ;#(ph-bind ~ (return:(ph ,~) ~), [%booted who=@p] (return:(ph ,[%booted who=@p]) [%booted who=~tyr]), ~ (return:(ph ,~) ~), ~ (return:(ph ,~) ~))
:: ;#(ph-bind [%booted who=@p] (boot-ship her keys), [%booted whom=@p] (boot-ship ~tyr keys), ~ ~&([%ww who whom] (return:(ph ,~) ~)))
2019-04-18 23:52:00 +03:00
:: ;# ph-bind
:: [%booted who=@p] <-- (boot-ship her keys)
:: [%boot-done whos=@p] <-- (check-ship-booted her)
:: ~ <--
:: ~& [%wws who whos]
:: (return:(ph ,~) ~)
:: ==
2019-04-14 05:51:46 +03:00
:: %+ (bind:(ph ,~) ,~)
:: (boot-ship her keys)
:: |= ~
:: (check-ship-booted her)
2019-04-18 23:52:00 +03:00
=/ m (ph ,~)
^- data:m
=% [%booted who=@p] bind:m (boot-ship her keys)
=% [%boot-done whos=@p] bind:m (check-ship-booted her)
(return:m ~)
2019-04-13 09:54:30 +03:00
--
2019-04-14 05:51:46 +03:00
::
:: ++ wrap-filter
:: |* o=mold
:: |* i=mold
:: |= [outer=_*data:(ph o) inner=_*data:(ph i)]
:: ^+ *data:(ph ,[o i])
:: |= input=ph-input
:: =/ res-i=_*ph-output:(ph i)
:: (inner input)
:: =. inner self.res-i
:: ?. thru.res-i
:: [result.res-i thru.res-i events.res-i ..$]
:: =/ res-o=_*ph-output:(ph o)
:: (outer input)
:: =. outer self.res-o
:: [result.res-i thru.res-o (welp events.res-i events.res-o) ..$]
2019-04-13 09:54:30 +03:00
::
2019-02-06 05:21:41 +03:00
:: Defines a complete integration test.
::
2019-03-07 10:31:14 +03:00
++ raw-test-core
2019-03-21 00:38:42 +03:00
$_ ^|
|_ now=@da
2019-02-12 22:26:48 +03:00
::
:: Unique name, used as a cache label.
::
2019-03-06 23:22:37 +03:00
++ label *@ta
2019-02-12 22:26:48 +03:00
::
:: 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.
::
2019-02-12 02:25:25 +03:00
++ ships *(list ship)
2019-02-12 22:26:48 +03:00
::
:: Called first to kick off the test.
::
2019-03-21 00:38:42 +03:00
++ start *(quip ph-event _^|(..start))
2019-02-12 22:26:48 +03:00
::
:: Called on every effect from a ship.
::
2019-03-23 03:18:54 +03:00
:: The loobean in the return value says whether we should pass on
:: the effect to vane drivers. Usually this should be yes.
::
2019-03-21 00:38:42 +03:00
++ route |~([ship unix-effect] *[? (quip ph-event _^|(..start))])
2019-03-07 10:31:14 +03:00
--
::
2019-03-23 03:18:54 +03:00
:: 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
2019-03-20 23:57:24 +03:00
::
2019-03-07 10:31:14 +03:00
++ porcelain-test-core
2019-03-21 00:38:42 +03:00
$_ ^|
|_ now=@da
2019-03-07 10:31:14 +03:00
:: Called first to kick off the test.
::
2019-03-21 00:38:42 +03:00
++ start *(quip ph-event _^|(..start))
2019-03-07 10:31:14 +03:00
::
:: Called on every effect from a ship.
::
2019-03-21 00:38:42 +03:00
++ route |~([ship unix-effect] *(quip ph-event _^|(..start)))
2019-02-06 05:21:41 +03:00
--
::
2019-03-23 03:18:54 +03:00
:: A simpler interface for when you don't need test state.
::
:: Use with +stateless-test
2019-03-20 23:57:24 +03:00
::
++ stateless-test-core
2019-03-21 00:38:42 +03:00
$_ ^|
|_ now=@da
2019-03-23 03:18:54 +03:00
:: Called first to kick off the test.
::
2019-03-21 00:38:42 +03:00
++ start *(list ph-event)
2019-03-23 03:18:54 +03:00
::
:: Called on every effect from a ship.
::
2019-03-21 00:38:42 +03:00
++ route |~([ship unix-effect] *(list ph-event))
2019-03-20 23:57:24 +03:00
--
::
2019-02-06 05:21:41 +03:00
++ ph-event
$% [%test-done p=?]
aqua-event
==
::
2019-03-23 03:18:54 +03:00
:: Call with a +porecelain-test-core create a stateless test.
2019-03-20 23:57:24 +03:00
::
2019-03-07 10:31:14 +03:00
++ porcelain-test
|= [label=@ta porcelain=porcelain-test-core]
^- raw-test-core
2019-03-21 00:38:42 +03:00
|_ now=@da
2019-03-07 10:31:14 +03:00
++ label ^label
++ ships ~
++ start
2019-03-21 00:38:42 +03:00
=^ events porcelain ~(start porcelain now)
2019-03-07 10:31:14 +03:00
[events ..start]
::
++ route
2019-03-21 00:38:42 +03:00
|= args=[ship unix-effect]
=^ events porcelain (~(route porcelain now) args)
2019-03-07 10:31:14 +03:00
[& events ..start]
--
::
2019-03-23 03:18:54 +03:00
:: Call with a +stateless-test-core create a stateless test.
2019-03-20 23:57:24 +03:00
::
++ stateless-test
|= [label=@tas stateless=stateless-test-core]
%+ porcelain-test
label
^- porcelain-test-core
2019-03-21 00:38:42 +03:00
|_ now=@da
2019-03-20 23:57:24 +03:00
++ start
2019-03-21 00:38:42 +03:00
[~(start stateless now) ..start]
2019-03-20 23:57:24 +03:00
::
++ route
2019-03-21 00:38:42 +03:00
|= args=[ship unix-effect]
[(~(route stateless now) args) ..start]
2019-03-20 23:57:24 +03:00
--
::
2019-03-23 03:18:54 +03:00
:: Turn [ship (list unix-event)] into (list ph-event)
::
2019-02-06 05:21:41 +03:00
++ send-events-to
|= [who=ship what=(list unix-event)]
^- (list ph-event)
%+ turn what
2019-03-07 10:31:14 +03:00
|= ue=unix-event
[%event who ue]
2019-02-06 05:21:41 +03:00
::
2019-03-23 03:18:54 +03:00
:: Start a ship (low-level; prefer +raw-ship)
::
2019-02-06 05:21:41 +03:00
++ init
2019-03-06 23:22:37 +03:00
|= [who=ship keys=(unit dawn-event)]
2019-02-06 05:21:41 +03:00
^- (list ph-event)
2019-03-06 23:22:37 +03:00
[%init-ship who keys]~
2019-02-06 05:21:41 +03:00
::
2019-03-27 04:07:42 +03:00
:: Send dojo command
2019-02-06 05:21:41 +03:00
::
++ 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 ~]
==
::
2019-03-23 03:18:54 +03:00
:: Inject a file into a ship
::
2019-02-09 02:21:40 +03:00
++ insert-file
2019-02-23 02:52:18 +03:00
|= [who=ship des=desk pax=path txt=@t]
2019-02-09 02:21:40 +03:00
^- (list ph-event)
?> ?=([@ @ @ *] pax)
2019-02-15 04:18:04 +03:00
=/ file [/text/plain (as-octs:mimes:html txt)]
2019-02-09 02:21:40 +03:00
%+ send-events-to who
:~
2019-02-23 02:52:18 +03:00
[//sync/0v1n.2m9vh %into des | [t.t.t.pax `file]~]
2019-02-09 02:21:40 +03:00
==
::
2019-03-23 03:18:54 +03:00
:: Checks whether the given event is a dojo output blit containing the
:: given tape
::
2019-03-20 23:57:24 +03:00
++ is-dojo-output
|= [who=ship her=ship uf=unix-effect what=tape]
?& =(who her)
?=(%blit -.q.uf)
::
%+ lien p.q.uf
|= =blit:dill
2019-02-06 05:21:41 +03:00
?. ?=(%lin -.blit)
|
!=(~ (find what p.blit))
2019-03-20 23:57:24 +03:00
==
2019-02-09 06:18:38 +03:00
::
2019-03-23 03:18:54 +03:00
:: Test is successful if +is-dojo-output
::
2019-02-09 06:18:38 +03:00
++ expect-dojo-output
2019-03-07 10:31:14 +03:00
|= [who=ship her=ship uf=unix-effect what=tape]
2019-02-09 06:18:38 +03:00
^- (list ph-event)
2019-03-20 23:57:24 +03:00
?. (is-dojo-output who her uf what)
~
2019-02-06 05:21:41 +03:00
[%test-done &]~
2019-02-12 02:25:25 +03:00
::
2019-03-23 03:18:54 +03:00
:: Check whether the given event is an ergo
::
2019-03-13 14:50:56 +03:00
++ is-ergo
|= [who=ship her=ship uf=unix-effect]
?& =(who her)
?=(%ergo -.q.uf)
==
::
2019-03-27 04:07:42 +03:00
:: 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]
::
2019-04-11 04:49:20 +03:00
+$ az-log [topics=(lest @) data=@t]
2019-04-09 07:13:06 +03:00
++ az
=| logs=(list az-log) :: oldest logs first
=, azimuth-events:azimuth
|%
++ this-az .
++ add-logs
|= new-logs=(list az-log)
^+ this-az
2019-04-11 04:49:20 +03:00
=. logs (weld logs new-logs)
2019-04-09 07:13:06 +03:00
this-az
::
++ router
2019-04-11 04:49:20 +03:00
=| eth-filter=(unit [from-block=@ud last-block=@ud address=@ux])
|= [who=ship uf=unix-effect]
=* this-router ..$
^- [thru=? pe=(list ph-event) self=_^|(this-router)]
2019-04-09 07:13:06 +03:00
=, enjs:format
2019-04-11 04:49:20 +03:00
=/ thus (extract-thus-to uf 'http://localhost:8545')
?~ thus
[& ~ this-router]
?~ r.mot.u.thus
[& ~ this-router]
=/ req q.u.r.mot.u.thus
|^
=/ method (get-method req)
?: =(method 'eth_blockNumber')
:- | :_ this-router
%+ answer-request req
s+(crip (num-to-hex:ethereum (lent logs)))
?: =(method 'eth_getLogs')
:- | :_ this-router
%+ answer-request req
%+ logs-to-json
(get-param-obj req 'fromBlock')
(get-param-obj req 'toBlock')
?: =(method 'eth_newFilter')
=. eth-filter
:^ ~
(get-param-obj req 'fromBlock')
(get-param-obj req 'fromBlock')
(get-param-obj req 'address')
:- | :_ this-router
(answer-request req s+'0xa')
?: =(method 'eth_getFilterLogs')
?~ eth-filter
~|(%no-filter-not-implemented !!)
=. last-block.u.eth-filter (lent logs)
:- | :_ this-router
%+ answer-request req
(logs-to-json from-block.u.eth-filter (lent logs))
?: =(method 'eth_getFilterChanges')
?~ eth-filter
~|(%no-filter-not-implemented !!)
=. last-block.u.eth-filter (lent logs)
:- | :_ this-router
%+ answer-request req
(logs-to-json last-block.u.eth-filter (lent logs))
[& ~ this-router]
2019-04-09 07:13:06 +03:00
::
++ get-id
|= req=@t
=, dejs:format
2019-04-11 04:49:20 +03:00
%. (need (de-json:html req))
2019-04-09 07:13:06 +03:00
(ot id+so ~)
::
++ get-method
|= req=@t
=, dejs:format
2019-04-11 04:49:20 +03:00
%. (need (de-json:html req))
2019-04-09 07:13:06 +03:00
(ot method+so ~)
2019-04-11 04:49:20 +03:00
::
++ 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
//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=@
|- ^- (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)
==
2019-04-09 07:13:06 +03:00
--
::
++ spawn-galaxy
|= who=@p
%- add-logs
:~ [~[activated who] '']
[~[owner-changed who 0xdead.beef] '']
:- ~[changed-keys who]
2019-04-11 04:49:20 +03:00
%- crip
2019-04-09 07:13:06 +03:00
%- prefix-hex:ethereum
;: welp
2019-04-13 09:54:30 +03:00
(get-keys who 1 %auth)
(get-keys who 1 %crypt)
2019-04-11 04:49:20 +03:00
(render-hex-bytes:ethereum 32 `@`1)
(render-hex-bytes:ethereum 32 `@`1)
2019-04-09 07:13:06 +03:00
==
==
::
++ get-keys
2019-04-11 04:49:20 +03:00
|= [who=@p life=@ud typ=?(%auth %crypt)]
2019-04-09 07:13:06 +03:00
%+ render-hex-bytes:ethereum 32
%- keccak-256:keccak:crypto
2019-04-11 04:49:20 +03:00
%- as-octs:mimes:html
:((cury cat 3) (scot %p who) (scot %ud life) typ)
2019-04-09 07:13:06 +03:00
--
::
++ ph-azimuth
2019-03-06 23:22:37 +03:00
|%
++ 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]
--
::
2019-02-12 05:46:36 +03:00
++ test-lib
|_ our=ship
2019-03-23 03:18:54 +03:00
::
:: Run one test, then the next.
::
:: Caches the result of the first test.
::
2019-02-12 05:46:36 +03:00
++ compose-tests
2019-03-07 10:31:14 +03:00
|= [a=raw-test-core b=raw-test-core]
^- raw-test-core
2019-02-12 05:46:36 +03:00
=/ done-with-a |
2019-02-22 02:57:51 +03:00
=>
|%
++ 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]
2019-03-21 00:38:42 +03:00
=^ events-start b ~(start b now)
2019-02-22 02:57:51 +03:00
[(welp other-events [snap-event events-start]) ..filter-a]
--
2019-03-21 00:38:42 +03:00
|_ now=@da
2019-02-12 05:46:36 +03:00
::
:: Cache lookup label
::
++ label `@tas`:((cury cat 3) label:a '--' label:b)
2019-02-12 05:46:36 +03:00
::
:: 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
2019-02-15 04:18:04 +03:00
(scry-aqua ? now /fleet-snap/[label:a]/noun)
2019-03-27 04:07:42 +03:00
:: ?: 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]
2019-03-21 00:38:42 +03:00
=^ events a ~(start a now)
2019-02-12 02:25:25 +03:00
[events ..start]
2019-02-12 05:46:36 +03:00
::
:: 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
2019-03-21 00:38:42 +03:00
|= [who=ship uf=unix-effect]
2019-03-07 10:31:14 +03:00
^- [? (quip ph-event _..start)]
2019-02-12 05:46:36 +03:00
?: done-with-a
2019-03-07 10:31:14 +03:00
=+ ^- [thru=? events=(list ph-event) cor=raw-test-core]
2019-03-21 00:38:42 +03:00
(~(route b now) who uf)
2019-03-07 10:31:14 +03:00
=. b cor
[thru events ..start]
=+ ^- [thru=? events=(list ph-event) cor=raw-test-core]
2019-03-21 00:38:42 +03:00
(~(route a now) who uf)
2019-03-07 10:31:14 +03:00
=. a cor
2019-02-22 02:57:51 +03:00
=^ events ..filter-a (filter-a now events)
2019-03-07 10:31:14 +03:00
[thru events ..start]
2019-02-12 05:46:36 +03:00
--
::
2019-03-27 04:07:42 +03:00
:: 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]
--
::
2019-04-11 04:49:20 +03:00
:: 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]
--
::
2019-03-27 04:07:42 +03:00
:: Mock HTTP responses to particular requests
::
++ wrap-test-http
2019-04-09 07:13:06 +03:00
|= [url=@t responses=(list $-(@t (unit @t))) cor=raw-test-core]
2019-03-27 04:07:42 +03:00
%^ 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
[& ~]
2019-04-09 07:13:06 +03:00
|- ^- [? (list ph-event)]
?~ responses
2019-04-13 09:54:30 +03:00
[& ~]
2019-04-09 07:13:06 +03:00
=/ resp (i.responses q.u.r.mot.u.thus)
?~ resp
$(responses t.responses)
2019-03-27 04:07:42 +03:00
:- | :_ ~
:* %event
who
//http/0v1n.2m9vh
%they
num.u.thus
[200 ~ `(as-octs:mimes:html u.resp)]
==
cor
::
2019-03-23 03:18:54 +03:00
:: Don't use directly unless you've already started any parent.
2019-02-12 02:53:23 +03:00
::
:: Consider ++galaxy, ++star, ++planet, and ++ship-with-ancestors.
::
++ raw-ship
2019-03-06 23:22:37 +03:00
|= [her=ship keys=(unit dawn-event)]
2019-03-07 10:31:14 +03:00
^- raw-test-core
2019-03-21 00:38:42 +03:00
|_ now=@da
2019-03-06 23:22:37 +03:00
++ label :((cury cat 3) 'init-' (scot %p her) '-' (scot %uw (mug (fall keys *dawn-event))))
2019-02-12 02:53:23 +03:00
++ ships ~[her]
2019-02-12 02:25:25 +03:00
++ start
^- (quip ph-event _..start)
2019-03-06 23:22:37 +03:00
[(init her keys) ..start]
2019-02-12 02:25:25 +03:00
::
++ route
2019-03-21 00:38:42 +03:00
|= [who=ship uf=unix-effect]
2019-03-07 10:31:14 +03:00
^- [? (quip ph-event _..start)]
:- &
2019-02-12 02:25:25 +03:00
:_ ..start
%- zing
2019-02-12 02:53:23 +03:00
:: This is a pretty bad heuristic, but in general galaxies will
:: hit the first of these cases, and other ships will hit the
:: second.
::
2019-02-12 02:25:25 +03:00
:~
2019-03-20 23:57:24 +03:00
?. %^ is-dojo-output her who :- uf
"+ /{(scow %p her)}/base/2/web/testing/udon"
~
2019-02-12 02:53:23 +03:00
[%test-done &]~
2019-02-12 02:25:25 +03:00
::
2019-03-20 23:57:24 +03:00
?. %^ is-dojo-output her who :- uf
"is your neighbor"
~
2019-02-12 02:25:25 +03:00
[%test-done &]~
==
--
2019-02-12 22:26:48 +03:00
::
2019-02-12 02:53:23 +03:00
++ galaxy
|= her=ship
?> =(%czar (clan:title her))
2019-03-06 23:22:37 +03:00
(raw-ship her ~)
2019-02-12 02:53:23 +03:00
::
++ star
|= her=ship
?> =(%king (clan:title her))
%+ compose-tests (galaxy (^sein:title her))
2019-03-06 23:22:37 +03:00
(raw-ship her ~)
2019-02-12 02:53:23 +03:00
::
++ planet
|= her=ship
?> =(%duke (clan:title her))
%+ compose-tests (star (^sein:title her))
2019-03-06 23:22:37 +03:00
(raw-ship her ~)
2019-02-12 02:53:23 +03:00
::
++ ship-with-ancestors
|= her=ship
%. her
?- (clan:title her)
%czar galaxy
%king star
%duke planet
%earl ~|(%moon-not-implemented !!)
%pawn ~|(%comet-not-implemented !!)
==
2019-02-15 04:18:04 +03:00
::
2019-02-15 04:36:30 +03:00
:: Touches /sur/aquarium/hoon on the given ship.
::
++ touch-file
2019-02-23 02:52:18 +03:00
|= [her=ship des=desk]
2019-03-07 10:31:14 +03:00
%+ porcelain-test
(cat 3 'touch-file-' (scot %p her))
2019-03-13 14:50:56 +03:00
=| [warped=@t change-sent=_|]
2019-03-21 00:38:42 +03:00
^- porcelain-test-core
|_ now=@da
2019-02-15 04:36:30 +03:00
++ start
^- (pair (list ph-event) _..start)
:_ ..start
2019-03-13 14:50:56 +03:00
(dojo her "|mount /={(trip des)}=")
2019-02-15 04:36:30 +03:00
::
++ route
2019-03-21 00:38:42 +03:00
|= [who=ship uf=unix-effect]
2019-02-15 04:36:30 +03:00
^- (quip ph-event _..start)
2019-03-13 14:50:56 +03:00
?. (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]
2019-02-15 04:36:30 +03:00
:_ ..start
2019-03-13 14:50:56 +03:00
=/ pax /i/(scot %p her)/[des]/(scot %da now)/sur/aquarium/hoon/noun
?: =(warped (need (scry-aqua (unit @) now pax)))
[%test-done &]~
~
2019-02-15 04:36:30 +03:00
--
::
2019-03-23 03:18:54 +03:00
:: Check that /sur/aquarium/hoon has been touched, as by ++touch-file
::
++ check-file-touched
2019-02-23 02:52:18 +03:00
|= [her=ship des=desk]
2019-03-21 00:52:05 +03:00
%+ stateless-test
2019-03-07 10:31:14 +03:00
(cat 3 'check-file-touched-' (scot %p her))
2019-03-21 00:38:42 +03:00
|_ 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)
::
2019-03-21 00:52:05 +03:00
(dojo her "|mount /={(trip des)}=")
::
++ route
2019-03-21 00:38:42 +03:00
|= [who=ship uf=unix-effect]
2019-03-21 00:52:05 +03:00
^- (list ph-event)
2019-03-20 23:57:24 +03:00
?. ?| (is-ergo her who uf)
(is-dojo-output her who uf ">=")
2019-02-23 02:52:18 +03:00
==
~
2019-03-20 23:57:24 +03:00
=/ 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 &]~
~
--
2019-02-22 02:57:51 +03:00
::
:: Reload vane from filesystem
::
++ reload-vane
|= [her=ship vane=term]
2019-03-21 00:52:05 +03:00
%+ stateless-test
2019-03-07 10:31:14 +03:00
:((cury cat 3) 'reload-vane-' (scot %p her) '-' vane)
2019-03-21 00:38:42 +03:00
|_ now=@da
2019-02-22 02:57:51 +03:00
++ start
2019-03-21 00:52:05 +03:00
^- (list ph-event)
2019-02-22 02:57:51 +03:00
=/ pax
/(scot %p our)/home/(scot %da now)/sys/vane/[vane]/hoon
%- zing
2019-02-23 02:52:18 +03:00
:~ (dojo her "|mount /=home=")
(insert-file her %home pax .^(@t %cx pax))
2019-02-22 02:57:51 +03:00
[%test-done &]~
==
::
++ route
2019-03-21 00:38:42 +03:00
|= [who=ship uf=unix-effect]
2019-03-21 00:52:05 +03:00
~
2019-02-22 02:57:51 +03:00
--
::
2019-03-30 00:59:45 +03:00
:: 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")
--
::
2019-03-23 03:18:54 +03:00
:: Scry into a running aqua ship
::
2019-02-15 04:18:04 +03:00
++ scry-aqua
|* [a=mold now=@da pax=path]
.^ a
%gx
(scot %p our)
%aqua
(scot %da now)
pax
==
2019-02-12 05:46:36 +03:00
--
2019-02-06 05:21:41 +03:00
--