mirror of
https://github.com/ilyakooo0/urbit.git
synced 2024-12-17 03:44:34 +03:00
366 lines
8.7 KiB
Plaintext
366 lines
8.7 KiB
Plaintext
::
|
|
:::: /hoon/ph/lib
|
|
::
|
|
/- aquarium
|
|
=, aquarium
|
|
|%
|
|
:: Defines a complete integration test.
|
|
::
|
|
++ test-core
|
|
$_ ^?
|
|
|%
|
|
::
|
|
:: Unique name, used as a cache label.
|
|
::
|
|
++ label *term
|
|
::
|
|
:: 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 |~(now=@da *(quip ph-event _^?(..start)))
|
|
::
|
|
:: Called on every effect from a ship.
|
|
::
|
|
++ route |~([now=@da ship unix-effect] *(quip ph-event _^?(..start)))
|
|
--
|
|
::
|
|
++ ph-event
|
|
$% [%test-done p=?]
|
|
aqua-event
|
|
==
|
|
::
|
|
++ send-events-to
|
|
|= [who=ship what=(list unix-event)]
|
|
^- (list ph-event)
|
|
%+ turn what
|
|
|= ovo=unix-event
|
|
[%event who ovo]
|
|
::
|
|
++ init
|
|
|= who=ship
|
|
^- (list ph-event)
|
|
[%init-ship who]~
|
|
::
|
|
:: 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 ~]
|
|
==
|
|
::
|
|
++ 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]~]
|
|
==
|
|
::
|
|
++ on-dojo-output
|
|
|= [who=ship her=ship ovo=unix-effect what=tape fun=$-($~ (list ph-event))]
|
|
^- (list ph-event)
|
|
?. =(who her)
|
|
~
|
|
?. ?=(%blit -.q.ovo)
|
|
~
|
|
?. %+ lien p.q.ovo
|
|
|= =blit:dill
|
|
?. ?=(%lin -.blit)
|
|
|
|
|
!=(~ (find what p.blit))
|
|
~
|
|
(fun)
|
|
::
|
|
++ expect-dojo-output
|
|
|= [who=ship her=ship ovo=unix-effect what=tape]
|
|
^- (list ph-event)
|
|
%- on-dojo-output
|
|
:^ who her ovo
|
|
:- what
|
|
|= ~
|
|
[%test-done &]~
|
|
::
|
|
++ on-ergo
|
|
|= [who=ship her=ship ovo=unix-effect fun=$-($~ (list ph-event))]
|
|
?. =(who her)
|
|
~
|
|
?. ?=(%ergo -.q.ovo)
|
|
~
|
|
(fun)
|
|
::
|
|
++ test-lib
|
|
|_ our=ship
|
|
++ compose-tests
|
|
|= [a=test-core b=test-core]
|
|
^- 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]
|
|
--
|
|
|%
|
|
::
|
|
:: 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
|
|
|= now=@da
|
|
^- (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
|
|
|= [now=@da who=ship ovo=unix-effect]
|
|
^- (quip ph-event _..start)
|
|
?: done-with-a
|
|
=^ events b (route:b now who ovo)
|
|
[events ..start]
|
|
=^ events a (route:a now who ovo)
|
|
=^ events ..filter-a (filter-a now events)
|
|
[events ..start]
|
|
--
|
|
::
|
|
:: Don't use directly, or else you might not have a parent.
|
|
::
|
|
:: Consider ++galaxy, ++star, ++planet, and ++ship-with-ancestors.
|
|
::
|
|
++ raw-ship
|
|
|= her=ship
|
|
^- test-core
|
|
|%
|
|
++ label (cat 3 'init-' (scot %p her))
|
|
++ ships ~[her]
|
|
++ start
|
|
|= now=@da
|
|
^- (quip ph-event _..start)
|
|
[(init her) ..start]
|
|
::
|
|
++ route
|
|
|= [now=@da who=ship ovo=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.
|
|
::
|
|
:~
|
|
%- on-dojo-output
|
|
:^ her who ovo
|
|
:- "+ /{(scow %p her)}/base/2/web/testing/udon"
|
|
|= ~
|
|
[%test-done &]~
|
|
::
|
|
%- on-dojo-output
|
|
:^ her who ovo
|
|
:- "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.
|
|
::
|
|
:: Ship must have been started.
|
|
::
|
|
++ touch-file
|
|
|= [her=ship des=desk]
|
|
^- test-core
|
|
=| warped=@t
|
|
|%
|
|
++ label (cat 3 'touch-file-' (scot %p her))
|
|
++ ships ~
|
|
++ start
|
|
|= now=@da
|
|
^- (pair (list ph-event) _..start)
|
|
=/ pax
|
|
/(scot %p our)/home/(scot %da now)/sur/aquarium/hoon
|
|
=. warped (cat 3 '=> . ' .^(@t %cx pax))
|
|
:_ ..start
|
|
%- zing
|
|
:~ (dojo her "|mount /={(trip des)}=")
|
|
(insert-file her des pax warped)
|
|
==
|
|
::
|
|
++ route
|
|
|= [now=@da who=ship ovo=unix-effect]
|
|
^- (quip ph-event _..start)
|
|
:_ ..start
|
|
%- zing
|
|
:~ %- on-ergo
|
|
:^ her who ovo
|
|
|= $~
|
|
=/ pax /i/(scot %p her)/[des]/(scot %da now)/sur/aquarium/hoon/noun
|
|
?: =(warped (need (scry-aqua (unit @) now pax)))
|
|
[%test-done &]~
|
|
~& %not-done-yet
|
|
~
|
|
==
|
|
--
|
|
::
|
|
:: Checks that /sur/aquarium/hoon has been touched, as by ++touch-file
|
|
::
|
|
:: Ship must have been started.
|
|
::
|
|
++ check-file-touched
|
|
|= [her=ship des=desk]
|
|
^- test-core
|
|
|%
|
|
++ label (cat 3 'check-file-touched-' (scot %p her))
|
|
++ ships ~
|
|
++ start
|
|
|= now=@da
|
|
:: 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)
|
|
::
|
|
~& %mounting
|
|
[(dojo her "|mount /={(trip des)}=") ..start]
|
|
::
|
|
++ route
|
|
|= [now=@da who=ship ovo=unix-effect]
|
|
^- (quip ph-event _..start)
|
|
=/ cb
|
|
|= $~
|
|
~& %cbing
|
|
=/ 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 &]~
|
|
~& %not-done-yet
|
|
~
|
|
:_ ..start
|
|
%- zing
|
|
:~ (on-ergo her who ovo cb)
|
|
(on-dojo-output her who ovo ">=" cb)
|
|
==
|
|
--
|
|
::
|
|
:: Reload vane from filesystem
|
|
::
|
|
:: Ship must have been started.
|
|
::
|
|
++ reload-vane
|
|
|= [her=ship vane=term]
|
|
^- test-core
|
|
|%
|
|
++ label :((cury cat 3) 'reload-vane-' (scot %p her) '-' vane)
|
|
++ ships ~
|
|
++ start
|
|
|= now=@da
|
|
^- (pair (list ph-event) _..start)
|
|
=/ pax
|
|
/(scot %p our)/home/(scot %da now)/sys/vane/[vane]/hoon
|
|
:_ ..start
|
|
%- zing
|
|
:~ (dojo her "|mount /=home=")
|
|
(insert-file her %home pax .^(@t %cx pax))
|
|
[%test-done &]~
|
|
==
|
|
::
|
|
++ route
|
|
|= [now=@da who=ship ovo=unix-effect]
|
|
^- (quip ph-event _..start)
|
|
`..start
|
|
--
|
|
::
|
|
++ scry-aqua
|
|
|* [a=mold now=@da pax=path]
|
|
.^ a
|
|
%gx
|
|
(scot %p our)
|
|
%aqua
|
|
(scot %da now)
|
|
pax
|
|
==
|
|
--
|
|
--
|