mirror of
https://github.com/urbit/shrub.git
synced 2024-12-19 00:13:12 +03:00
91b38d4cea
string<->numbers didn't match the json serialization. This makes preboot validation succeed.
327 lines
8.9 KiB
Plaintext
327 lines
8.9 KiB
Plaintext
:: runtime support code
|
|
::
|
|
/+ ethereum, azimuth
|
|
=> [ethereum=ethereum azimuth=azimuth ..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: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
|
|
|%
|
|
:: +czar:give:dawn: Eth RPC for galaxy table
|
|
::
|
|
++ czar
|
|
^- octs
|
|
%- as-octt:mimes:html
|
|
%- en-json:html
|
|
:- %a
|
|
%+ turn (gulf 0 255)
|
|
|= gal=@
|
|
%+ request-to-json
|
|
(cat 3 'gal-' (scot %ud gal))
|
|
:- 'getPoint'
|
|
(~(put by *(map @t json)) 'ship' s+(scot %p gal))
|
|
:: +point:give:dawn: Eth RPC for ship's contract state
|
|
::
|
|
++ point
|
|
|= who=ship
|
|
^- octs
|
|
%- as-octt:mimes:html
|
|
%- en-json:html
|
|
%+ request-to-json
|
|
~.
|
|
:- 'getPoint'
|
|
(~(put by *(map @t json)) 'ship' s+(scot %p who))
|
|
:: +turf:give:dawn: Eth RPC for network domains
|
|
::
|
|
++ turf
|
|
^- octs
|
|
%- as-octt:mimes:html
|
|
%- en-json:html
|
|
%+ request-to-json
|
|
'turf'
|
|
['getDns' ~]
|
|
:: +request-to-json:give:dawn: internally used for request generation
|
|
::
|
|
::NOTE we could import this from /lib/json/rpc, but adding that as a
|
|
:: dependency seems a bit unclean
|
|
::
|
|
++ request-to-json
|
|
|= [id=@t method=@t params=(map @t json)]
|
|
^- json
|
|
%- pairs:enjs:format
|
|
:~ jsonrpc+s+'2.0'
|
|
id+s+id
|
|
method+s+method
|
|
params+o+params
|
|
==
|
|
--
|
|
:: |take:dawn: parse responses for pre-boot validation
|
|
::
|
|
++ take
|
|
=, abi:ethereum
|
|
=, rpc:ethereum
|
|
=, azimuth
|
|
=, dejs-soft:format
|
|
|%
|
|
:: +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 @ud @ud @]))
|
|
%. u.jon
|
|
=, dejs-soft:format
|
|
=- (ar (ot id+so result+(ot network+- ~) ~))
|
|
%- ot
|
|
:~ :- 'rift' (su dim:ag)
|
|
:- 'keys' (ot 'life'^(su dim:ag) ~)
|
|
:- 'keys' %+ cu pass-from-eth:azimuth
|
|
%- ot
|
|
:~ 'crypt'^(cu (lead 32) (su ;~(pfix (jest '0x') hex)))
|
|
'auth'^(cu (lead 32) (su ;~(pfix (jest '0x') hex)))
|
|
'suite'^(su dim:ag)
|
|
==
|
|
==
|
|
?~ res
|
|
~&([%czar-take-dawn %incomplete-json] ~)
|
|
:- ~
|
|
%+ roll u.res
|
|
|= $: [id=@t deet=[=rift =life =pass]]
|
|
kyz=(map ship [=rift =life =pass])
|
|
==
|
|
^+ kyz
|
|
?: =(0 life.deet)
|
|
kyz
|
|
%+ ~(put by kyz)
|
|
(slav %ud (rsh [3 4] id))
|
|
deet
|
|
:: +point:take:dawn: parse ship's contract state
|
|
::
|
|
++ point
|
|
|= [who=ship rep=octs]
|
|
^- (unit point:azimuth)
|
|
~! *point:azimuth
|
|
=/ jon=(unit json) (de-json:html q.rep)
|
|
?~ jon
|
|
~&([%point-take-dawn %invalid-json] ~)
|
|
=- ?~ res
|
|
~&([%point-take-dawn %incomplete-json] ~)
|
|
=, u.res
|
|
%- some
|
|
:+ own
|
|
?: =(0 life) ~
|
|
`[life pass rift sponsor ~] ::NOTE escape unknown ::TODO could be!
|
|
?. (gth who 0xffff) ~
|
|
`[spawn ~] ::NOTE spawned unknown
|
|
^- $= res
|
|
%- unit
|
|
$: [spawn=@ own=[@ @ @ @]]
|
|
[=rift =life =pass sponsor=[? ship]]
|
|
==
|
|
%. u.jon
|
|
=, dejs-soft:format
|
|
=- (ot result+- ~)
|
|
%- ot
|
|
:~ :- 'ownership'
|
|
%- ot
|
|
|^ :~ 'spawnProxy'^address
|
|
'owner'^address
|
|
'managementProxy'^address
|
|
'votingProxy'^address
|
|
'transferProxy'^address
|
|
==
|
|
::
|
|
++ address
|
|
(ot 'address'^(cu hex-to-num:ethereum so) ~)
|
|
--
|
|
::
|
|
:- 'network'
|
|
%- ot
|
|
::TODO dedupe with +czar
|
|
:~ 'rift'^(su dim:ag)
|
|
'keys'^(ot 'life'^(su dim:ag) ~)
|
|
::
|
|
:- 'keys'
|
|
%+ cu pass-from-eth:azimuth
|
|
%- ot
|
|
:~ 'crypt'^(cu (lead 32) (su ;~(pfix (jest '0x') hex)))
|
|
'auth'^(cu (lead 32) (su ;~(pfix (jest '0x') hex)))
|
|
'suite'^(su dim:ag)
|
|
==
|
|
::
|
|
::TODO inconsistent @p string
|
|
'sponsor'^(ot 'has'^bo 'who'^ni ~)
|
|
::
|
|
::TODO escape
|
|
::TODO what if escape or sponsor not present? possible?
|
|
==
|
|
==
|
|
:: +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))
|
|
((ot result+(ar so) ~) u.jon)
|
|
?~ res
|
|
~&([%turf-take-dawn %invalid-response] ~)
|
|
:: remove duplicates, parse into turfs
|
|
::
|
|
=- `doz
|
|
%+ roll u.res
|
|
|= [dom=@t doh=(set @t) doz=(list ^turf)]
|
|
?: (~(has in doh) dom) [doh doz]
|
|
:- (~(put in doh) dom)
|
|
=/ hot=host:eyre
|
|
(rash dom thos:de-purl:html)
|
|
?. ?=(%& -.hot) doz
|
|
(snoc doz p.hot)
|
|
--
|
|
:: +veri:dawn: validate keys, life, discontinuity, &c
|
|
::
|
|
++ veri
|
|
|= [=ship =feed:jael =point:azimuth =live]
|
|
^- (each seed:jael (lest error=term))
|
|
|^ ?@ -.feed
|
|
?^ err=(test feed) |+[u.err ~]
|
|
&+feed
|
|
?> ?=([%1 ~] -.feed)
|
|
=| errs=(list term)
|
|
|-
|
|
?~ kyz.feed
|
|
|+?~(errs [%no-key ~] errs)
|
|
=/ =seed:jael [who [lyf key ~]:i.kyz]:feed
|
|
?~ err=(test seed)
|
|
&+seed
|
|
=. errs (snoc errs u.err)
|
|
$(kyz.feed t.kyz.feed)
|
|
::
|
|
++ test
|
|
|= =seed:jael
|
|
^- (unit error=term)
|
|
?. =(ship who.seed) `%not-our-key
|
|
=/ 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
|
|
:: 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 !>(.)
|
|
=> |%
|
|
++ load _[~ ..load] :: +4
|
|
++ peek _~ :: +22
|
|
++ poke _[~ ..poke] :: +23
|
|
++ wish :: +10
|
|
|= txt=*
|
|
q:(slap pit (ream ;;(@t txt)))
|
|
--
|
|
::
|
|
|=(* .(+> +:(poke +<)))
|