mirror of
https://github.com/urbit/shrub.git
synced 2024-12-28 22:54:15 +03:00
zuse: moves |dawn to lib/vere, rewrites +ivory
This commit is contained in:
Joe Bryan
parent
ec7e23ab29
commit
0f0c2a6ffb
@ -1254,7 +1254,7 @@
|
||||
=+ vex=((full parse-command-line:he-parser) [1 1] txt)
|
||||
?. ?=([* ~ [* @ %ex *] *] vex)
|
||||
(he-tab-not-hoon pos :(weld buf (tufa buf.say) "\0a"))
|
||||
=/ typ p:(slop q:he-hoon-head !>(..dawn))
|
||||
=/ typ p:(slop q:he-hoon-head !>(..zuse))
|
||||
=/ tl (tab-list-hoon:auto typ p.q.q.p.u.q.vex)
|
||||
=/ advance (advance-hoon:auto typ p.q.q.p.u.q.vex)
|
||||
=? res ?=(^ advance)
|
||||
|
||||
@ -1,84 +1,33 @@
|
||||
:: Produce an ivory pill
|
||||
::
|
||||
:::: /hoon/ivory/gen
|
||||
::
|
||||
/? 310
|
||||
::
|
||||
::::
|
||||
!:
|
||||
:- %say
|
||||
|= $: [now=@da eny=@uvJ bec=beak]
|
||||
arg=$@(~ [top=path ~])
|
||||
~
|
||||
==
|
||||
:- %noun
|
||||
:: sys: root path to boot system, `/~me/[desk]/now/sys`
|
||||
::
|
||||
=/ sys=path
|
||||
?^ arg top.arg
|
||||
/(scot %p p.bec)/[q.bec]/(scot %da now)/sys
|
||||
:: compiler-source: hoon source file producing compiler, `sys/hoon`
|
||||
=/ lib
|
||||
(welp (flop (tail (flop sys))) /lib)
|
||||
::
|
||||
=/ compiler-source
|
||||
.^(@t %cx (welp sys /hoon/hoon))
|
||||
:: compiler-hoon: compiler as hoon expression
|
||||
|^ =/ ver
|
||||
=/ sub *(trap vase)
|
||||
=. sub (build-sys sub %hoon)
|
||||
=. sub (build-sys sub %arvo)
|
||||
=. sub (build-sys sub %lull)
|
||||
=. sub (build-sys sub %zuse)
|
||||
(build-lib sub %vere)
|
||||
=/ nok !.
|
||||
=> *[ver=(trap vase) ~]
|
||||
!= q:$:ver
|
||||
noun/[[nok ver ~] ~ ~]
|
||||
::
|
||||
:: Parsed with a static path for reproducibility.
|
||||
++ build-sys
|
||||
|= [sub=(trap vase) nam=term] ^- (trap vase)
|
||||
~> %slog.[0 leaf+"ivory: building /sys/{(trip nam)}"]
|
||||
(swat sub (rain /sys/[nam]/hoon .^(@t cx+(welp sys /[nam]/hoon))))
|
||||
::
|
||||
~& %ivory-parsing
|
||||
=/ compiler-hoon (rain /sys/hoon/hoon compiler-source)
|
||||
~& %ivory-parsed
|
||||
:: arvo-source: hoon source file producing arvo kernel, `sys/arvo`
|
||||
::
|
||||
=/ arvo-source
|
||||
.^(@t %cx (welp sys /arvo/hoon))
|
||||
:: whole-hoon: arvo within compiler
|
||||
::
|
||||
:: Parsed with a static path for reproducibility.
|
||||
::
|
||||
=/ whole-hoon=hoon
|
||||
:+ %tsgr compiler-hoon
|
||||
:+ %tsgl (rain /sys/arvo/hoon arvo-source)
|
||||
[%$ 7]
|
||||
:: compile the whole schmeer
|
||||
::
|
||||
~& %ivory-compiling
|
||||
=/ whole-formula
|
||||
q:(~(mint ut %noun) %noun whole-hoon)
|
||||
~& %ivory-compiled
|
||||
:: zuse-ovo: standard library installation event
|
||||
::
|
||||
:: Arvo parses the %veer card contents with +rain;
|
||||
:: we include a static path for reproducibility.
|
||||
::
|
||||
=/ zuse-ovo=ovum
|
||||
:~ //arvo
|
||||
%what
|
||||
[/sys/hoon hoon/compiler-source]
|
||||
[/sys/arvo hoon/arvo-source]
|
||||
[/sys/lull hoon/.^(@ %cx (weld sys /lull/hoon))]
|
||||
[/sys/zuse hoon/.^(@ %cx (weld sys /zuse/hoon))]
|
||||
==
|
||||
:: installed: Arvo gate (formal instance) with %zuse installed
|
||||
::
|
||||
:: The :zuse-ovo event occurs at a defaulted date for reproducibility.
|
||||
::
|
||||
~& %zuse-installing
|
||||
=/ installed
|
||||
.* 0
|
||||
:+ %7 whole-formula
|
||||
[%9 2 %10 [6 %1 *@da zuse-ovo] %0 1]
|
||||
~& %zuse-installed
|
||||
:: our boot-ova is a list containing one massive formula:
|
||||
::
|
||||
:: We evaluate :whole-formula (for jet registration),
|
||||
:: then ignore the result and produces :installed
|
||||
::
|
||||
=/ boot-ova=(list)
|
||||
[[%7 whole-formula %1 installed] ~]
|
||||
:: a pill is a 3-tuple of event-lists: [boot kernel userspace]
|
||||
::
|
||||
:: Our kernel event-list is ~, as we've already installed them.
|
||||
:: Our userspace event-list is ~, as this pill must be compact.
|
||||
::
|
||||
[boot-ova ~ ~]
|
||||
++ build-lib
|
||||
|= [sub=(trap vase) nam=term] ^- (trap vase)
|
||||
~> %slog.[0 leaf+"ivory: building /lib/{(trip nam)}"]
|
||||
(swat sub (rain /lib/[nam]/hoon .^(@t cx+(welp lib /[nam]/hoon))))
|
||||
--
|
||||
|
||||
316
pkg/arvo/lib/vere.hoon
Normal file
316
pkg/arvo/lib/vere.hoon
Normal file
@ -0,0 +1,316 @@
|
||||
:: runtime support code
|
||||
::
|
||||
=> ..zuse =>
|
||||
|%
|
||||
::
|
||||
:: |dawn: pre-boot request/response de/serialization and validation
|
||||
::
|
||||
++ dawn
|
||||
=> |%
|
||||
:: +live: public network state of a ship
|
||||
::
|
||||
+$ live (unit [=life breach=?])
|
||||
--
|
||||
|%
|
||||
:: +come:dawn: mine a comet under a star
|
||||
::
|
||||
:: Randomly generates comet addresses until we find one whose parent is
|
||||
:: in the list of supplied stars. Errors if any supplied ship
|
||||
:: is not a star.
|
||||
::
|
||||
++ come
|
||||
|= [tar=(list ship) eny=@uvJ]
|
||||
::
|
||||
=| stars=(set ship)
|
||||
=. stars
|
||||
|- ^+ stars
|
||||
?~ tar stars
|
||||
::
|
||||
~| [%come-not-king i.tar]
|
||||
?> ?=(%king (clan:title i.tar))
|
||||
$(tar t.tar, stars (~(put in stars) i.tar))
|
||||
::
|
||||
|- ^- seed:able:jael
|
||||
=/ cub=acru:ames (pit:nu:crub:crypto 512 eny)
|
||||
=/ who=ship `@`fig:ex:cub
|
||||
:: disallow 64-bit or smaller addresses
|
||||
::
|
||||
?. ?=(%pawn (clan:title who))
|
||||
$(eny +(eny))
|
||||
?: (~(has in stars) (^sein:title who))
|
||||
[who 1 sec:ex:cub ~]
|
||||
$(eny +(eny))
|
||||
:: |give:dawn: produce requests for pre-boot validation
|
||||
::
|
||||
++ give
|
||||
=, rpc:ethereum
|
||||
=, abi:ethereum
|
||||
=/ tract azimuth:contracts:azimuth
|
||||
|%
|
||||
:: +bloq:give:dawn: Eth RPC for latest block number
|
||||
::
|
||||
++ bloq
|
||||
^- octs
|
||||
%- as-octt:mimes:html
|
||||
%- en-json:html
|
||||
%+ request-to-json
|
||||
`~.0
|
||||
[%eth-block-number ~]
|
||||
:: +czar:give:dawn: Eth RPC for galaxy table
|
||||
::
|
||||
++ czar
|
||||
|= boq=@ud
|
||||
^- octs
|
||||
%- as-octt:mimes:html
|
||||
%- en-json:html
|
||||
:- %a
|
||||
%+ turn (gulf 0 255)
|
||||
|= gal=@
|
||||
%+ request-to-json
|
||||
`(cat 3 'gal-' (scot %ud gal))
|
||||
:+ %eth-call
|
||||
=- [from=~ to=tract gas=~ price=~ value=~ data=-]
|
||||
(encode-call 'points(uint32)' [%uint gal]~)
|
||||
[%number boq]
|
||||
:: +point:give:dawn: Eth RPC for ship's contract state
|
||||
::
|
||||
++ point
|
||||
|= [boq=@ud who=ship]
|
||||
^- octs
|
||||
%- as-octt:mimes:html
|
||||
%- en-json:html
|
||||
%+ request-to-json
|
||||
`~.0
|
||||
:+ %eth-call
|
||||
=- [from=~ to=tract gas=~ price=~ value=~ data=-]
|
||||
(encode-call 'points(uint32)' [%uint `@`who]~)
|
||||
[%number boq]
|
||||
:: +turf:give:dawn: Eth RPC for network domains
|
||||
::
|
||||
++ turf
|
||||
|= boq=@ud
|
||||
^- octs
|
||||
%- as-octt:mimes:html
|
||||
%- en-json:html
|
||||
:- %a
|
||||
%+ turn (gulf 0 2)
|
||||
|= idx=@
|
||||
%+ request-to-json
|
||||
`(cat 3 'turf-' (scot %ud idx))
|
||||
:+ %eth-call
|
||||
=- [from=~ to=tract gas=~ price=~ value=~ data=-]
|
||||
(encode-call 'dnsDomains(uint256)' [%uint idx]~)
|
||||
[%number boq]
|
||||
--
|
||||
:: |take:dawn: parse responses for pre-boot validation
|
||||
::
|
||||
++ take
|
||||
=, abi:ethereum
|
||||
=, rpc:ethereum
|
||||
=, azimuth
|
||||
=, dejs-soft:format
|
||||
|%
|
||||
:: +bloq:take:dawn: parse block number
|
||||
::
|
||||
++ bloq
|
||||
|= rep=octs
|
||||
^- (unit @ud)
|
||||
=/ jon=(unit json) (de-json:html q.rep)
|
||||
?~ jon
|
||||
~&([%bloq-take-dawn %invalid-json] ~)
|
||||
=/ res=(unit cord) ((ot result+so ~) u.jon)
|
||||
?~ res
|
||||
~&([%bloq-take-dawn %invalid-response rep] ~)
|
||||
=/ out
|
||||
%- mule |.
|
||||
(hex-to-num:ethereum u.res)
|
||||
?: ?=(%& -.out)
|
||||
(some p.out)
|
||||
~&([%bloq-take-dawn %invalid-block-number] ~)
|
||||
:: +czar:take:dawn: parse galaxy table
|
||||
::
|
||||
++ czar
|
||||
|= rep=octs
|
||||
^- (unit (map ship [=rift =life =pass]))
|
||||
=/ jon=(unit json) (de-json:html q.rep)
|
||||
?~ jon
|
||||
~&([%czar-take-dawn %invalid-json] ~)
|
||||
=/ res=(unit (list [@t @t]))
|
||||
((ar (ot id+so result+so ~)) u.jon)
|
||||
?~ res
|
||||
~&([%czar-take-dawn %invalid-response rep] ~)
|
||||
=/ dat=(unit (list [who=@p point:azimuth-types]))
|
||||
=- ?:(?=(%| -.out) ~ (some p.out))
|
||||
^= out %- mule |.
|
||||
%+ turn u.res
|
||||
|= [id=@t result=@t]
|
||||
^- [who=ship point:azimuth-types]
|
||||
=/ who `@p`(slav %ud (rsh [3 4] id))
|
||||
:- who
|
||||
%+ point-from-eth
|
||||
who
|
||||
:_ *deed:eth-noun
|
||||
%+ decode-results
|
||||
result
|
||||
point:eth-type
|
||||
?~ dat
|
||||
~&([%bloq-take-dawn %invalid-galaxy-table] ~)
|
||||
:- ~
|
||||
%+ roll u.dat
|
||||
|= $: [who=ship =point:azimuth-types]
|
||||
kyz=(map ship [=rift =life =pass])
|
||||
==
|
||||
^+ kyz
|
||||
?~ net.point
|
||||
kyz
|
||||
(~(put by kyz) who [continuity-number life pass]:u.net.point)
|
||||
:: +point:take:dawn: parse ship's contract state
|
||||
::
|
||||
++ point
|
||||
|= [who=ship rep=octs]
|
||||
^- (unit point:azimuth)
|
||||
=/ jon=(unit json) (de-json:html q.rep)
|
||||
?~ jon
|
||||
~&([%point-take-dawn %invalid-json] ~)
|
||||
=/ res=(unit cord) ((ot result+so ~) u.jon)
|
||||
?~ res
|
||||
~&([%point-take-dawn %invalid-response rep] ~)
|
||||
~? =(u.res '0x')
|
||||
:- 'bad result from node; is azimuth address correct?'
|
||||
azimuth:contracts
|
||||
=/ out
|
||||
%- mule |.
|
||||
%+ point-from-eth
|
||||
who
|
||||
:_ *deed:eth-noun ::TODO call rights to fill
|
||||
(decode-results u.res point:eth-type)
|
||||
?: ?=(%& -.out)
|
||||
(some p.out)
|
||||
~&([%point-take-dawn %invalid-point] ~)
|
||||
:: +turf:take:dawn: parse network domains
|
||||
::
|
||||
++ turf
|
||||
|= rep=octs
|
||||
^- (unit (list ^turf))
|
||||
=/ jon=(unit json) (de-json:html q.rep)
|
||||
?~ jon
|
||||
~&([%turf-take-dawn %invalid-json] ~)
|
||||
=/ res=(unit (list [@t @t]))
|
||||
((ar (ot id+so result+so ~)) u.jon)
|
||||
?~ res
|
||||
~&([%turf-take-dawn %invalid-response rep] ~)
|
||||
=/ dat=(unit (list (pair @ud ^turf)))
|
||||
=- ?:(?=(%| -.out) ~ (some p.out))
|
||||
^= out %- mule |.
|
||||
%+ turn u.res
|
||||
|= [id=@t result=@t]
|
||||
^- (pair @ud ^turf)
|
||||
:- (slav %ud (rsh [3 5] id))
|
||||
=/ dom=tape
|
||||
(decode-results result [%string]~)
|
||||
=/ hot=host:eyre
|
||||
(scan dom thos:de-purl:html)
|
||||
?>(?=(%& -.hot) p.hot)
|
||||
?~ dat
|
||||
~&([%turf-take-dawn %invalid-domains] ~)
|
||||
:- ~
|
||||
=* dom u.dat
|
||||
:: sort by id, ascending, removing duplicates
|
||||
::
|
||||
=| tuf=(map ^turf @ud)
|
||||
|- ^- (list ^turf)
|
||||
?~ dom
|
||||
%+ turn
|
||||
%+ sort ~(tap by tuf)
|
||||
|=([a=(pair ^turf @ud) b=(pair ^turf @ud)] (lth q.a q.b))
|
||||
head
|
||||
=? tuf !(~(has by tuf) q.i.dom)
|
||||
(~(put by tuf) q.i.dom p.i.dom)
|
||||
$(dom t.dom)
|
||||
--
|
||||
:: +veri:dawn: validate keys, life, discontinuity, &c
|
||||
::
|
||||
++ veri
|
||||
|= [=seed:able:jael =point:azimuth =live]
|
||||
^- (unit error=term)
|
||||
=/ rac (clan:title who.seed)
|
||||
=/ cub (nol:nu:crub:crypto key.seed)
|
||||
?- rac
|
||||
%pawn
|
||||
:: a comet address is the fingerprint of the keypair
|
||||
::
|
||||
?. =(who.seed `@`fig:ex:cub)
|
||||
`%key-mismatch
|
||||
:: a comet can never be breached
|
||||
::
|
||||
?^ live
|
||||
`%already-booted
|
||||
:: a comet can never be re-keyed
|
||||
::
|
||||
?. ?=(%1 lyf.seed)
|
||||
`%invalid-life
|
||||
~
|
||||
::
|
||||
%earl
|
||||
~
|
||||
::
|
||||
*
|
||||
:: on-chain ships must be launched
|
||||
::
|
||||
?~ net.point
|
||||
`%not-keyed
|
||||
=* net u.net.point
|
||||
:: boot keys must match the contract
|
||||
::
|
||||
?. =(pub:ex:cub pass.net)
|
||||
~& [%key-mismatch pub:ex:cub pass.net]
|
||||
`%key-mismatch
|
||||
:: life must match the contract
|
||||
::
|
||||
?. =(lyf.seed life.net)
|
||||
`%life-mismatch
|
||||
:: the boot life must be greater than and discontinuous with
|
||||
:: the last seen life (per the sponsor)
|
||||
::
|
||||
?: ?& ?=(^ live)
|
||||
?| ?=(%| breach.u.live)
|
||||
(lte life.net life.u.live)
|
||||
== ==
|
||||
`%already-booted
|
||||
:: produce the sponsor for vere
|
||||
::
|
||||
~? !has.sponsor.net
|
||||
[%no-sponsorship-guarantees-from who.sponsor.net]
|
||||
~
|
||||
==
|
||||
:: +sponsor:dawn: retreive sponsor from point
|
||||
::
|
||||
++ sponsor
|
||||
|= [who=ship =point:azimuth]
|
||||
^- (each ship error=term)
|
||||
?- (clan:title who)
|
||||
%pawn [%& (^sein:title who)]
|
||||
%earl [%& (^sein:title who)]
|
||||
%czar [%& (^sein:title who)]
|
||||
*
|
||||
?~ net.point
|
||||
[%| %not-booted]
|
||||
?. has.sponsor.u.net.point
|
||||
[%| %no-sponsor]
|
||||
[%& who.sponsor.u.net.point]
|
||||
==
|
||||
--
|
||||
--
|
||||
::
|
||||
=/ pit !>(.)
|
||||
=> |%
|
||||
++ come _[~ ..come]
|
||||
++ load _[~ ..come]
|
||||
++ peek _~ :: +46
|
||||
++ poke _[~ ..poke] :: +47
|
||||
++ wish :: +22
|
||||
|= txt=*
|
||||
q:(slap pit (ream ;;(@t txt)))
|
||||
--
|
||||
::
|
||||
|=(* .(+> +:(poke +<)))
|
||||
@ -9222,302 +9222,4 @@
|
||||
==
|
||||
--
|
||||
--
|
||||
::
|
||||
:: |dawn: pre-boot request/response de/serialization and validation
|
||||
::
|
||||
++ dawn
|
||||
=> |%
|
||||
:: +live: public network state of a ship
|
||||
::
|
||||
+$ live (unit [=life breach=?])
|
||||
--
|
||||
|%
|
||||
:: +come:dawn: mine a comet under a star
|
||||
::
|
||||
:: Randomly generates comet addresses until we find one whose parent is
|
||||
:: in the list of supplied stars. Errors if any supplied ship
|
||||
:: is not a star.
|
||||
::
|
||||
++ come
|
||||
|= [tar=(list ship) eny=@uvJ]
|
||||
::
|
||||
=| stars=(set ship)
|
||||
=. stars
|
||||
|- ^+ stars
|
||||
?~ tar stars
|
||||
::
|
||||
~| [%come-not-king i.tar]
|
||||
?> ?=(%king (clan:title i.tar))
|
||||
$(tar t.tar, stars (~(put in stars) i.tar))
|
||||
::
|
||||
|- ^- seed:able:jael
|
||||
=/ cub=acru:ames (pit:nu:crub:crypto 512 eny)
|
||||
=/ who=ship `@`fig:ex:cub
|
||||
:: disallow 64-bit or smaller addresses
|
||||
::
|
||||
?. ?=(%pawn (clan:title who))
|
||||
$(eny +(eny))
|
||||
?: (~(has in stars) (^sein:title who))
|
||||
[who 1 sec:ex:cub ~]
|
||||
$(eny +(eny))
|
||||
:: |give:dawn: produce requests for pre-boot validation
|
||||
::
|
||||
++ give
|
||||
=, rpc:ethereum
|
||||
=, abi:ethereum
|
||||
=/ tract azimuth:contracts:azimuth
|
||||
|%
|
||||
:: +bloq:give:dawn: Eth RPC for latest block number
|
||||
::
|
||||
++ bloq
|
||||
^- octs
|
||||
%- as-octt:mimes:html
|
||||
%- en-json:html
|
||||
%+ request-to-json
|
||||
`~.0
|
||||
[%eth-block-number ~]
|
||||
:: +czar:give:dawn: Eth RPC for galaxy table
|
||||
::
|
||||
++ czar
|
||||
|= boq=@ud
|
||||
^- octs
|
||||
%- as-octt:mimes:html
|
||||
%- en-json:html
|
||||
:- %a
|
||||
%+ turn (gulf 0 255)
|
||||
|= gal=@
|
||||
%+ request-to-json
|
||||
`(cat 3 'gal-' (scot %ud gal))
|
||||
:+ %eth-call
|
||||
=- [from=~ to=tract gas=~ price=~ value=~ data=-]
|
||||
(encode-call 'points(uint32)' [%uint gal]~)
|
||||
[%number boq]
|
||||
:: +point:give:dawn: Eth RPC for ship's contract state
|
||||
::
|
||||
++ point
|
||||
|= [boq=@ud who=ship]
|
||||
^- octs
|
||||
%- as-octt:mimes:html
|
||||
%- en-json:html
|
||||
%+ request-to-json
|
||||
`~.0
|
||||
:+ %eth-call
|
||||
=- [from=~ to=tract gas=~ price=~ value=~ data=-]
|
||||
(encode-call 'points(uint32)' [%uint `@`who]~)
|
||||
[%number boq]
|
||||
:: +turf:give:dawn: Eth RPC for network domains
|
||||
::
|
||||
++ turf
|
||||
|= boq=@ud
|
||||
^- octs
|
||||
%- as-octt:mimes:html
|
||||
%- en-json:html
|
||||
:- %a
|
||||
%+ turn (gulf 0 2)
|
||||
|= idx=@
|
||||
%+ request-to-json
|
||||
`(cat 3 'turf-' (scot %ud idx))
|
||||
:+ %eth-call
|
||||
=- [from=~ to=tract gas=~ price=~ value=~ data=-]
|
||||
(encode-call 'dnsDomains(uint256)' [%uint idx]~)
|
||||
[%number boq]
|
||||
--
|
||||
:: |take:dawn: parse responses for pre-boot validation
|
||||
::
|
||||
++ take
|
||||
=, abi:ethereum
|
||||
=, rpc:ethereum
|
||||
=, azimuth
|
||||
=, dejs-soft:format
|
||||
|%
|
||||
:: +bloq:take:dawn: parse block number
|
||||
::
|
||||
++ bloq
|
||||
|= rep=octs
|
||||
^- (unit @ud)
|
||||
=/ jon=(unit json) (de-json:html q.rep)
|
||||
?~ jon
|
||||
~&([%bloq-take-dawn %invalid-json] ~)
|
||||
=/ res=(unit cord) ((ot result+so ~) u.jon)
|
||||
?~ res
|
||||
~&([%bloq-take-dawn %invalid-response rep] ~)
|
||||
=/ out
|
||||
%- mule |.
|
||||
(hex-to-num:ethereum u.res)
|
||||
?: ?=(%& -.out)
|
||||
(some p.out)
|
||||
~&([%bloq-take-dawn %invalid-block-number] ~)
|
||||
:: +czar:take:dawn: parse galaxy table
|
||||
::
|
||||
++ czar
|
||||
|= rep=octs
|
||||
^- (unit (map ship [=rift =life =pass]))
|
||||
=/ jon=(unit json) (de-json:html q.rep)
|
||||
?~ jon
|
||||
~&([%czar-take-dawn %invalid-json] ~)
|
||||
=/ res=(unit (list [@t @t]))
|
||||
((ar (ot id+so result+so ~)) u.jon)
|
||||
?~ res
|
||||
~&([%czar-take-dawn %invalid-response rep] ~)
|
||||
=/ dat=(unit (list [who=@p point:azimuth-types]))
|
||||
=- ?:(?=(%| -.out) ~ (some p.out))
|
||||
^= out %- mule |.
|
||||
%+ turn u.res
|
||||
|= [id=@t result=@t]
|
||||
^- [who=ship point:azimuth-types]
|
||||
=/ who `@p`(slav %ud (rsh [3 4] id))
|
||||
:- who
|
||||
%+ point-from-eth
|
||||
who
|
||||
:_ *deed:eth-noun
|
||||
%+ decode-results
|
||||
result
|
||||
point:eth-type
|
||||
?~ dat
|
||||
~&([%bloq-take-dawn %invalid-galaxy-table] ~)
|
||||
:- ~
|
||||
%+ roll u.dat
|
||||
|= $: [who=ship =point:azimuth-types]
|
||||
kyz=(map ship [=rift =life =pass])
|
||||
==
|
||||
^+ kyz
|
||||
?~ net.point
|
||||
kyz
|
||||
(~(put by kyz) who [continuity-number life pass]:u.net.point)
|
||||
:: +point:take:dawn: parse ship's contract state
|
||||
::
|
||||
++ point
|
||||
|= [who=ship rep=octs]
|
||||
^- (unit point:azimuth)
|
||||
=/ jon=(unit json) (de-json:html q.rep)
|
||||
?~ jon
|
||||
~&([%point-take-dawn %invalid-json] ~)
|
||||
=/ res=(unit cord) ((ot result+so ~) u.jon)
|
||||
?~ res
|
||||
~&([%point-take-dawn %invalid-response rep] ~)
|
||||
~? =(u.res '0x')
|
||||
:- 'bad result from node; is azimuth address correct?'
|
||||
azimuth:contracts
|
||||
=/ out
|
||||
%- mule |.
|
||||
%+ point-from-eth
|
||||
who
|
||||
:_ *deed:eth-noun ::TODO call rights to fill
|
||||
(decode-results u.res point:eth-type)
|
||||
?: ?=(%& -.out)
|
||||
(some p.out)
|
||||
~&([%point-take-dawn %invalid-point] ~)
|
||||
:: +turf:take:dawn: parse network domains
|
||||
::
|
||||
++ turf
|
||||
|= rep=octs
|
||||
^- (unit (list ^turf))
|
||||
=/ jon=(unit json) (de-json:html q.rep)
|
||||
?~ jon
|
||||
~&([%turf-take-dawn %invalid-json] ~)
|
||||
=/ res=(unit (list [@t @t]))
|
||||
((ar (ot id+so result+so ~)) u.jon)
|
||||
?~ res
|
||||
~&([%turf-take-dawn %invalid-response rep] ~)
|
||||
=/ dat=(unit (list (pair @ud ^turf)))
|
||||
=- ?:(?=(%| -.out) ~ (some p.out))
|
||||
^= out %- mule |.
|
||||
%+ turn u.res
|
||||
|= [id=@t result=@t]
|
||||
^- (pair @ud ^turf)
|
||||
:- (slav %ud (rsh [3 5] id))
|
||||
=/ dom=tape
|
||||
(decode-results result [%string]~)
|
||||
=/ hot=host:eyre
|
||||
(scan dom thos:de-purl:html)
|
||||
?>(?=(%& -.hot) p.hot)
|
||||
?~ dat
|
||||
~&([%turf-take-dawn %invalid-domains] ~)
|
||||
:- ~
|
||||
=* dom u.dat
|
||||
:: sort by id, ascending, removing duplicates
|
||||
::
|
||||
=| tuf=(map ^turf @ud)
|
||||
|- ^- (list ^turf)
|
||||
?~ dom
|
||||
%+ turn
|
||||
%+ sort ~(tap by tuf)
|
||||
|=([a=(pair ^turf @ud) b=(pair ^turf @ud)] (lth q.a q.b))
|
||||
head
|
||||
=? tuf !(~(has by tuf) q.i.dom)
|
||||
(~(put by tuf) q.i.dom p.i.dom)
|
||||
$(dom t.dom)
|
||||
--
|
||||
:: +veri:dawn: validate keys, life, discontinuity, &c
|
||||
::
|
||||
++ veri
|
||||
|= [=seed:able:jael =point:azimuth =live]
|
||||
^- (unit error=term)
|
||||
=/ rac (clan:title who.seed)
|
||||
=/ cub (nol:nu:crub:crypto key.seed)
|
||||
?- rac
|
||||
%pawn
|
||||
:: a comet address is the fingerprint of the keypair
|
||||
::
|
||||
?. =(who.seed `@`fig:ex:cub)
|
||||
`%key-mismatch
|
||||
:: a comet can never be breached
|
||||
::
|
||||
?^ live
|
||||
`%already-booted
|
||||
:: a comet can never be re-keyed
|
||||
::
|
||||
?. ?=(%1 lyf.seed)
|
||||
`%invalid-life
|
||||
~
|
||||
::
|
||||
%earl
|
||||
~
|
||||
::
|
||||
*
|
||||
:: on-chain ships must be launched
|
||||
::
|
||||
?~ net.point
|
||||
`%not-keyed
|
||||
=* net u.net.point
|
||||
:: boot keys must match the contract
|
||||
::
|
||||
?. =(pub:ex:cub pass.net)
|
||||
~& [%key-mismatch pub:ex:cub pass.net]
|
||||
`%key-mismatch
|
||||
:: life must match the contract
|
||||
::
|
||||
?. =(lyf.seed life.net)
|
||||
`%life-mismatch
|
||||
:: the boot life must be greater than and discontinuous with
|
||||
:: the last seen life (per the sponsor)
|
||||
::
|
||||
?: ?& ?=(^ live)
|
||||
?| ?=(%| breach.u.live)
|
||||
(lte life.net life.u.live)
|
||||
== ==
|
||||
`%already-booted
|
||||
:: produce the sponsor for vere
|
||||
::
|
||||
~? !has.sponsor.net
|
||||
[%no-sponsorship-guarantees-from who.sponsor.net]
|
||||
~
|
||||
==
|
||||
:: +sponsor:dawn: retreive sponsor from point
|
||||
::
|
||||
++ sponsor
|
||||
|= [who=ship =point:azimuth]
|
||||
^- (each ship error=term)
|
||||
?- (clan:title who)
|
||||
%pawn [%& (^sein:title who)]
|
||||
%earl [%& (^sein:title who)]
|
||||
%czar [%& (^sein:title who)]
|
||||
*
|
||||
?~ net.point
|
||||
[%| %not-booted]
|
||||
?. has.sponsor.u.net.point
|
||||
[%| %no-sponsor]
|
||||
[%& who.sponsor.u.net.point]
|
||||
==
|
||||
--
|
||||
-- ::
|
||||
--
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
/+ *test
|
||||
/+ *test, *vere
|
||||
|%
|
||||
:: example point for ~zod
|
||||
::
|
||||
Loading…
Reference in New Issue
Block a user