mirror of
https://github.com/urbit/ares.git
synced 2024-11-29 22:56:28 +03:00
1651 lines
41 KiB
Plaintext
1651 lines
41 KiB
Plaintext
:: This file is a combination of tiny.hoon and naive.hoon from urbit/urbit
|
|
:: (but with sham jets). Required to run azimuth-pill.hoon as an Arvo.
|
|
::
|
|
!.
|
|
!=
|
|
:: begin tiny.hoon
|
|
=>
|
|
=> %a50
|
|
~% %a.50 ~ ~
|
|
|%
|
|
:: Types
|
|
::
|
|
+$ ship @p
|
|
+$ life @ud
|
|
+$ rift @ud
|
|
+$ pass @
|
|
+$ bloq @
|
|
+$ step _`@u`1
|
|
+$ bite $@(bloq [=bloq =step])
|
|
+$ octs [p=@ud q=@]
|
|
+$ mold $~(* $-(* *))
|
|
++ unit |$ [item] $@(~ [~ u=item])
|
|
++ list |$ [item] $@(~ [i=item t=(list item)])
|
|
++ lest |$ [item] [i=item t=(list item)]
|
|
++ tree |$ [node] $@(~ [n=node l=(tree node) r=(tree node)])
|
|
++ pair |$ [head tail] [p=head q=tail]
|
|
++ map
|
|
|$ [key value]
|
|
$| (tree (pair key value))
|
|
|=(a=(tree (pair)) ?:(=(~ a) & ~(apt by a)))
|
|
::
|
|
++ set
|
|
|$ [item]
|
|
$| (tree item)
|
|
|=(a=(tree) ?:(=(~ a) & ~(apt in a)))
|
|
::
|
|
++ jug |$ [key value] (map key (set value))
|
|
::
|
|
:: Bits
|
|
::
|
|
++ dec :: decrement
|
|
~/ %dec
|
|
|= a=@
|
|
~> %sham.%dec
|
|
~_ leaf+"decrement-underflow"
|
|
?< =(0 a)
|
|
=+ b=0
|
|
|- ^- @
|
|
?: =(a +(b)) b
|
|
$(b +(b))
|
|
::
|
|
++ add :: plus
|
|
~/ %add
|
|
|= [a=@ b=@]
|
|
~> %sham.%add
|
|
^- @
|
|
?: =(0 a) b
|
|
$(a (dec a), b +(b))
|
|
::
|
|
++ sub :: subtract
|
|
~/ %sub
|
|
|= [a=@ b=@]
|
|
~> %sham.%sub
|
|
~_ leaf+"subtract-underflow"
|
|
:: difference
|
|
^- @
|
|
?: =(0 b) a
|
|
$(a (dec a), b (dec b))
|
|
::
|
|
++ mul :: multiply
|
|
~/ %mul
|
|
|: [a=`@`1 b=`@`1]
|
|
~> %sham.%mul
|
|
^- @
|
|
=+ c=0
|
|
|-
|
|
?: =(0 a) c
|
|
$(a (dec a), c (add b c))
|
|
::
|
|
++ div :: divide
|
|
~/ %div
|
|
|: [a=`@`1 b=`@`1]
|
|
~> %sham.%div
|
|
^- @
|
|
~_ leaf+"divide-by-zero"
|
|
?< =(0 b)
|
|
=+ c=0
|
|
|-
|
|
?: (lth a b) c
|
|
$(a (sub a b), c +(c))
|
|
::
|
|
++ dvr :: divide w/remainder
|
|
~/ %dvr
|
|
|: [a=`@`1 b=`@`1]
|
|
~> %sham.%dvr
|
|
^- [p=@ q=@]
|
|
[(div a b) (mod a b)]
|
|
::
|
|
++ mod :: modulus
|
|
~/ %mod
|
|
|: [a=`@`1 b=`@`1]
|
|
~> %sham.%mod
|
|
^- @
|
|
?< =(0 b)
|
|
(sub a (mul b (div a b)))
|
|
::
|
|
++ bex :: binary exponent
|
|
~/ %bex
|
|
|= a=bloq
|
|
~> %sham.%bex
|
|
^- @
|
|
?: =(0 a) 1
|
|
(mul 2 $(a (dec a)))
|
|
::
|
|
++ lsh :: left-shift
|
|
~/ %lsh
|
|
|= [a=bite b=@]
|
|
~> %sham.%lsh
|
|
=/ [=bloq =step] ?^(a a [a *step])
|
|
(mul b (bex (mul (bex bloq) step)))
|
|
::
|
|
++ rsh :: right-shift
|
|
~/ %rsh
|
|
|= [a=bite b=@]
|
|
~> %sham.%rsh
|
|
=/ [=bloq =step] ?^(a a [a *step])
|
|
(div b (bex (mul (bex bloq) step)))
|
|
::
|
|
++ con :: binary or
|
|
~/ %con
|
|
|= [a=@ b=@]
|
|
~> %sham.%con
|
|
=+ [c=0 d=0]
|
|
|- ^- @
|
|
?: ?&(=(0 a) =(0 b)) d
|
|
%= $
|
|
a (rsh 0 a)
|
|
b (rsh 0 b)
|
|
c +(c)
|
|
d %+ add d
|
|
%+ lsh [0 c]
|
|
?& =(0 (end 0 a))
|
|
=(0 (end 0 b))
|
|
==
|
|
==
|
|
::
|
|
++ dis :: binary and
|
|
~/ %dis
|
|
|= [a=@ b=@]
|
|
~> %sham.%dis
|
|
=| [c=@ d=@]
|
|
|- ^- @
|
|
?: ?|(=(0 a) =(0 b)) d
|
|
%= $
|
|
a (rsh 0 a)
|
|
b (rsh 0 b)
|
|
c +(c)
|
|
d %+ add d
|
|
%+ lsh [0 c]
|
|
?| =(0 (end 0 a))
|
|
=(0 (end 0 b))
|
|
==
|
|
==
|
|
::
|
|
++ mix :: binary xor
|
|
~/ %mix
|
|
|= [a=@ b=@]
|
|
~> %sham.%mix
|
|
^- @
|
|
=+ [c=0 d=0]
|
|
|-
|
|
?: ?&(=(0 a) =(0 b)) d
|
|
%= $
|
|
a (rsh 0 a)
|
|
b (rsh 0 b)
|
|
c +(c)
|
|
d (add d (lsh [0 c] =((end 0 a) (end 0 b))))
|
|
==
|
|
::
|
|
++ lth :: less
|
|
~/ %lth
|
|
|= [a=@ b=@]
|
|
~> %sham.%lth
|
|
^- ?
|
|
?& !=(a b)
|
|
|-
|
|
?| =(0 a)
|
|
?& !=(0 b)
|
|
$(a (dec a), b (dec b))
|
|
== == ==
|
|
::
|
|
++ lte :: less or equal
|
|
~/ %lte
|
|
|= [a=@ b=@]
|
|
~> %sham.%lte
|
|
|(=(a b) (lth a b))
|
|
::
|
|
++ gte :: greater or equal
|
|
~/ %gte
|
|
|= [a=@ b=@]
|
|
~> %sham.%gte
|
|
^- ?
|
|
!(lth a b)
|
|
::
|
|
++ gth :: greater
|
|
~/ %gth
|
|
|= [a=@ b=@]
|
|
~> %sham.%gth
|
|
^- ?
|
|
!(lte a b)
|
|
::
|
|
++ swp :: naive rev bloq order
|
|
~/ %swp
|
|
|= [a=bloq b=@]
|
|
(rep a (flop (rip a b)))
|
|
::
|
|
++ met :: measure
|
|
~/ %met
|
|
|= [a=bloq b=@]
|
|
~> %sham.%met
|
|
^- @
|
|
=+ c=0
|
|
|-
|
|
?: =(0 b) c
|
|
$(b (rsh a b), c +(c))
|
|
::
|
|
++ end :: tail
|
|
~/ %end
|
|
|= [a=bite b=@]
|
|
~> %sham.%end
|
|
=/ [=bloq =step] ?^(a a [a *step])
|
|
(mod b (bex (mul (bex bloq) step)))
|
|
::
|
|
++ cat :: concatenate
|
|
~/ %cat
|
|
|= [a=bloq b=@ c=@]
|
|
~> %sham.%cat
|
|
(add (lsh [a (met a b)] c) b)
|
|
::
|
|
++ cut :: slice
|
|
~/ %cut
|
|
|= [a=bloq [b=step c=step] d=@]
|
|
~> %sham.%cut
|
|
(end [a c] (rsh [a b] d))
|
|
::
|
|
++ can :: assemble
|
|
~/ %can
|
|
|= [a=bloq b=(list [p=step q=@])]
|
|
~> %sham.%can
|
|
^- @
|
|
?~ b 0
|
|
(add (end [a p.i.b] q.i.b) (lsh [a p.i.b] $(b t.b)))
|
|
::
|
|
++ cad :: assemble specific
|
|
~/ %cad
|
|
|= [a=bloq b=(list [p=step q=@])]
|
|
~> %sham.%cad
|
|
^- [=step @]
|
|
:_ (can a b)
|
|
|-
|
|
?~ b
|
|
0
|
|
(add p.i.b $(b t.b))
|
|
::
|
|
++ rep :: assemble fixed
|
|
~/ %rep
|
|
|= [a=bite b=(list @)]
|
|
~> %sham.%rep
|
|
=/ [=bloq =step] ?^(a a [a *step])
|
|
=| i=@ud
|
|
|- ^- @
|
|
?~ b 0
|
|
%+ add $(i +(i), b t.b)
|
|
(lsh [bloq (mul step i)] (end [bloq step] i.b))
|
|
::
|
|
++ rip :: disassemble
|
|
~/ %rip
|
|
|= [a=bite b=@]
|
|
~> %sham.%rip
|
|
^- (list @)
|
|
?: =(0 b) ~
|
|
[(end a b) $(b (rsh a b))]
|
|
::
|
|
::
|
|
:: Lists
|
|
::
|
|
++ lent :: length
|
|
~/ %lent
|
|
|= a=(list)
|
|
^- @
|
|
=+ b=0
|
|
|-
|
|
?~ a b
|
|
$(a t.a, b +(b))
|
|
::
|
|
++ slag :: suffix
|
|
~/ %slag
|
|
|* [a=@ b=(list)]
|
|
|- ^+ b
|
|
?: =(0 a) b
|
|
?~ b ~
|
|
$(b t.b, a (dec a))
|
|
::
|
|
++ snag :: index
|
|
~/ %snag
|
|
|* [a=@ b=(list)]
|
|
|- ^+ ?>(?=(^ b) i.b)
|
|
?~ b
|
|
~_ leaf+"snag-fail"
|
|
!!
|
|
?: =(0 a) i.b
|
|
$(b t.b, a (dec a))
|
|
::
|
|
++ homo :: homogenize
|
|
|* a=(list)
|
|
^+ =< $
|
|
|@ ++ $ ?:(*? ~ [i=(snag 0 a) t=$])
|
|
--
|
|
a
|
|
::
|
|
++ flop :: reverse
|
|
~/ %flop
|
|
|* a=(list)
|
|
=> .(a (homo a))
|
|
^+ a
|
|
=+ b=`_a`~
|
|
|-
|
|
?~ a b
|
|
$(a t.a, b [i.a b])
|
|
::
|
|
++ welp :: concatenate
|
|
~/ %welp
|
|
=| [* *]
|
|
|@
|
|
++ $
|
|
?~ +<-
|
|
+<-(. +<+)
|
|
+<-(+ $(+<- +<->))
|
|
--
|
|
::
|
|
++ reap :: replicate
|
|
~/ %reap
|
|
|* [a=@ b=*]
|
|
|- ^- (list _b)
|
|
?~ a ~
|
|
[b $(a (dec a))]
|
|
::
|
|
:: Modular arithmetic
|
|
::
|
|
++ fe :: modulo bloq
|
|
|_ a=bloq
|
|
++ rol |= [b=bloq c=@ d=@] ^- @ :: roll left
|
|
=+ e=(sit d)
|
|
=+ f=(bex (sub a b))
|
|
=+ g=(mod c f)
|
|
(sit (con (lsh [b g] e) (rsh [b (sub f g)] e)))
|
|
++ sum |=([b=@ c=@] (sit (add b c))) :: wrapping add
|
|
++ sit |=(b=@ (end a b)) :: enforce modulo
|
|
--
|
|
::
|
|
:: Hashes
|
|
::
|
|
++ muk :: standard murmur3
|
|
~% %muk ..muk ~
|
|
=+ ~(. fe 5)
|
|
|= [syd=@ len=@ key=@]
|
|
=. syd (end 5 syd)
|
|
=/ pad (sub len (met 3 key))
|
|
=/ data (welp (rip 3 key) (reap pad 0))
|
|
=/ nblocks (div len 4) :: intentionally off-by-one
|
|
=/ h1 syd
|
|
=+ [c1=0xcc9e.2d51 c2=0x1b87.3593]
|
|
=/ blocks (rip 5 key)
|
|
=/ i nblocks
|
|
=. h1 =/ hi h1 |-
|
|
?: =(0 i) hi
|
|
=/ k1 (snag (sub nblocks i) blocks) :: negative array index
|
|
=. k1 (sit (mul k1 c1))
|
|
=. k1 (rol 0 15 k1)
|
|
=. k1 (sit (mul k1 c2))
|
|
=. hi (mix hi k1)
|
|
=. hi (rol 0 13 hi)
|
|
=. hi (sum (sit (mul hi 5)) 0xe654.6b64)
|
|
$(i (dec i))
|
|
=/ tail (slag (mul 4 nblocks) data)
|
|
=/ k1 0
|
|
=/ tlen (dis len 3)
|
|
=. h1
|
|
?+ tlen h1 :: fallthrough switch
|
|
%3 =. k1 (mix k1 (lsh [0 16] (snag 2 tail)))
|
|
=. k1 (mix k1 (lsh [0 8] (snag 1 tail)))
|
|
=. k1 (mix k1 (snag 0 tail))
|
|
=. k1 (sit (mul k1 c1))
|
|
=. k1 (rol 0 15 k1)
|
|
=. k1 (sit (mul k1 c2))
|
|
(mix h1 k1)
|
|
%2 =. k1 (mix k1 (lsh [0 8] (snag 1 tail)))
|
|
=. k1 (mix k1 (snag 0 tail))
|
|
=. k1 (sit (mul k1 c1))
|
|
=. k1 (rol 0 15 k1)
|
|
=. k1 (sit (mul k1 c2))
|
|
(mix h1 k1)
|
|
%1 =. k1 (mix k1 (snag 0 tail))
|
|
=. k1 (sit (mul k1 c1))
|
|
=. k1 (rol 0 15 k1)
|
|
=. k1 (sit (mul k1 c2))
|
|
(mix h1 k1)
|
|
==
|
|
=. h1 (mix h1 len)
|
|
|^ (fmix32 h1)
|
|
++ fmix32
|
|
|= h=@
|
|
=. h (mix h (rsh [0 16] h))
|
|
=. h (sit (mul h 0x85eb.ca6b))
|
|
=. h (mix h (rsh [0 13] h))
|
|
=. h (sit (mul h 0xc2b2.ae35))
|
|
=. h (mix h (rsh [0 16] h))
|
|
h
|
|
--
|
|
::
|
|
++ mug :: mug with murmur3
|
|
~/ %mug
|
|
|= a=*
|
|
~> %sham.%mug
|
|
|^ ?@ a (mum 0xcafe.babe 0x7fff a)
|
|
=/ b (cat 5 $(a -.a) $(a +.a))
|
|
(mum 0xdead.beef 0xfffe b)
|
|
::
|
|
++ mum
|
|
|= [syd=@uxF fal=@F key=@]
|
|
=/ wyd (met 3 key)
|
|
=| i=@ud
|
|
|- ^- @F
|
|
?: =(8 i) fal
|
|
=/ haz=@F (muk syd wyd key)
|
|
=/ ham=@F (mix (rsh [0 31] haz) (end [0 31] haz))
|
|
?.(=(0 ham) ham $(i +(i), syd +(syd)))
|
|
--
|
|
::
|
|
++ gor :: mug order
|
|
~/ %gor
|
|
|= [a=* b=*]
|
|
~> %sham.%gor
|
|
^- ?
|
|
=+ [c=(mug a) d=(mug b)]
|
|
?: =(c d)
|
|
(dor a b)
|
|
(lth c d)
|
|
::
|
|
++ mor :: more mug order
|
|
~/ %mor
|
|
|= [a=* b=*]
|
|
~> %sham.%mor
|
|
^- ?
|
|
=+ [c=(mug (mug a)) d=(mug (mug b))]
|
|
?: =(c d)
|
|
(dor a b)
|
|
(lth c d)
|
|
::
|
|
++ dor :: tree order
|
|
~/ %dor
|
|
|= [a=* b=*]
|
|
~> %sham.%dor
|
|
^- ?
|
|
?: =(a b) &
|
|
?. ?=(@ a)
|
|
?: ?=(@ b) |
|
|
?: =(-.a -.b)
|
|
$(a +.a, b +.b)
|
|
$(a -.a, b -.b)
|
|
?. ?=(@ b) &
|
|
(lth a b)
|
|
::
|
|
++ por :: parent order
|
|
~/ %por
|
|
|= [a=@p b=@p]
|
|
~> %sham.%por
|
|
^- ?
|
|
?: =(a b) &
|
|
=| i=@
|
|
|-
|
|
?: =(i 2)
|
|
:: second two bytes
|
|
(lte a b)
|
|
:: first two bytes
|
|
=+ [c=(end 3 a) d=(end 3 b)]
|
|
?: =(c d)
|
|
$(a (rsh 3 a), b (rsh 3 b), i +(i))
|
|
(lth c d)
|
|
::
|
|
:: Maps
|
|
::
|
|
++ by
|
|
~/ %by
|
|
=| a=(tree (pair)) :: (map)
|
|
~> %sham.%by
|
|
=* node ?>(?=(^ a) n.a)
|
|
|@
|
|
++ get
|
|
~/ %get
|
|
|* b=*
|
|
~> %sham.%get
|
|
=> .(b `_?>(?=(^ a) p.n.a)`b)
|
|
|- ^- (unit _?>(?=(^ a) q.n.a))
|
|
?~ a
|
|
~
|
|
?: =(b p.n.a)
|
|
`q.n.a
|
|
?: (gor b p.n.a)
|
|
$(a l.a)
|
|
$(a r.a)
|
|
::
|
|
++ put
|
|
~/ %put
|
|
|* [b=* c=*]
|
|
~> %sham.%put
|
|
|- ^+ a
|
|
~> %sham.%putt
|
|
?~ a
|
|
[[b c] ~ ~]
|
|
?: =(b p.n.a)
|
|
?: =(c q.n.a)
|
|
a
|
|
a(n [b c])
|
|
?: (gor b p.n.a)
|
|
=+ d=$(a l.a)
|
|
?> ?=(^ d)
|
|
?: (mor p.n.a p.n.d)
|
|
a(l d)
|
|
d(r a(l r.d))
|
|
=+ d=$(a r.a)
|
|
?> ?=(^ d)
|
|
?: (mor p.n.a p.n.d)
|
|
a(r d)
|
|
d(l a(r l.d))
|
|
::
|
|
++ del
|
|
~/ %del
|
|
|* b=*
|
|
~> %sham.%del
|
|
|- ^+ a
|
|
?~ a
|
|
~
|
|
?. =(b p.n.a)
|
|
?: (gor b p.n.a)
|
|
a(l $(a l.a))
|
|
a(r $(a r.a))
|
|
|- ^- [$?(~ _a)]
|
|
?~ l.a r.a
|
|
?~ r.a l.a
|
|
?: (mor p.n.l.a p.n.r.a)
|
|
l.a(r $(l.a r.l.a))
|
|
r.a(l $(r.a l.r.a))
|
|
::
|
|
++ apt
|
|
=< $
|
|
~/ %apt
|
|
=| [l=(unit) r=(unit)]
|
|
~> %sham.%apt
|
|
|. ^- ?
|
|
?~ a &
|
|
?& ?~(l & &((gor p.n.a u.l) !=(p.n.a u.l)))
|
|
?~(r & &((gor u.r p.n.a) !=(u.r p.n.a)))
|
|
?~ l.a &
|
|
&((mor p.n.a p.n.l.a) !=(p.n.a p.n.l.a) $(a l.a, l `p.n.a))
|
|
?~ r.a &
|
|
&((mor p.n.a p.n.r.a) !=(p.n.a p.n.r.a) $(a r.a, r `p.n.a))
|
|
==
|
|
--
|
|
::
|
|
++ on :: ordered map
|
|
~/ %on
|
|
|* [key=mold val=mold]
|
|
~> %sham.%on
|
|
=> |%
|
|
+$ item [key=key val=val]
|
|
--
|
|
::
|
|
~% %comp +>+ ~
|
|
|= compare=$-([key key] ?)
|
|
~% %core + ~
|
|
|%
|
|
::
|
|
++ apt
|
|
~/ %apt
|
|
|= a=(tree item)
|
|
~> %sham.%apt
|
|
=| [l=(unit key) r=(unit key)]
|
|
|- ^- ?
|
|
?~ a %.y
|
|
?& ?~(l %.y (compare key.n.a u.l))
|
|
?~(r %.y (compare u.r key.n.a))
|
|
?~(l.a %.y &((mor key.n.a key.n.l.a) $(a l.a, l `key.n.a)))
|
|
?~(r.a %.y &((mor key.n.a key.n.r.a) $(a r.a, r `key.n.a)))
|
|
==
|
|
::
|
|
++ get
|
|
~/ %get
|
|
|= [a=(tree item) b=key]
|
|
~> %sham.%get
|
|
^- (unit val)
|
|
?~ a ~
|
|
?: =(b key.n.a)
|
|
`val.n.a
|
|
?: (compare b key.n.a)
|
|
$(a l.a)
|
|
$(a r.a)
|
|
::
|
|
++ has
|
|
~/ %has
|
|
|= [a=(tree item) b=key]
|
|
~> %sham.%has
|
|
^- ?
|
|
!=(~ (get a b))
|
|
::
|
|
++ put
|
|
~/ %put
|
|
|= [a=(tree item) =key =val]
|
|
~> %sham.%put
|
|
^- (tree item)
|
|
?~ a [n=[key val] l=~ r=~]
|
|
?: =(key.n.a key) a(val.n val)
|
|
?: (compare key key.n.a)
|
|
=/ l $(a l.a)
|
|
?> ?=(^ l)
|
|
?: (mor key.n.a key.n.l)
|
|
a(l l)
|
|
l(r a(l r.l))
|
|
=/ r $(a r.a)
|
|
?> ?=(^ r)
|
|
?: (mor key.n.a key.n.r)
|
|
a(r r)
|
|
r(l a(r l.r))
|
|
--
|
|
::
|
|
:: Sets
|
|
::
|
|
++ in
|
|
~/ %in
|
|
=| a=(tree) :: (set)
|
|
~> %sham.%in
|
|
|@
|
|
++ put
|
|
~/ %put
|
|
|* b=*
|
|
~> %sham.%put
|
|
|- ^+ a
|
|
?~ a
|
|
[b ~ ~]
|
|
?: =(b n.a)
|
|
a
|
|
?: (gor b n.a)
|
|
=+ c=$(a l.a)
|
|
?> ?=(^ c)
|
|
?: (mor n.a n.c)
|
|
a(l c)
|
|
c(r a(l r.c))
|
|
=+ c=$(a r.a)
|
|
?> ?=(^ c)
|
|
?: (mor n.a n.c)
|
|
a(r c)
|
|
c(l a(r l.c))
|
|
::
|
|
++ del
|
|
~/ %del
|
|
|* b=*
|
|
~> %sham.%del
|
|
|- ^+ a
|
|
?~ a
|
|
~
|
|
?. =(b n.a)
|
|
?: (gor b n.a)
|
|
a(l $(a l.a))
|
|
a(r $(a r.a))
|
|
|- ^- [$?(~ _a)]
|
|
?~ l.a r.a
|
|
?~ r.a l.a
|
|
?: (mor n.l.a n.r.a)
|
|
l.a(r $(l.a r.l.a))
|
|
r.a(l $(r.a l.r.a))
|
|
::
|
|
++ apt
|
|
=< $
|
|
~/ %apt
|
|
=| [l=(unit) r=(unit)]
|
|
~> %sham.%apt
|
|
|. ^- ?
|
|
?~ a &
|
|
?& ?~(l & (gor n.a u.l))
|
|
?~(r & (gor u.r n.a))
|
|
?~(l.a & ?&((mor n.a n.l.a) $(a l.a, l `n.a)))
|
|
?~(r.a & ?&((mor n.a n.r.a) $(a r.a, r `n.a)))
|
|
==
|
|
--
|
|
::
|
|
:: Jugs
|
|
::
|
|
++ ju
|
|
=| a=(tree (pair * (tree))) :: (jug)
|
|
|@
|
|
++ get
|
|
|* b=*
|
|
=+ c=(~(get by a) b)
|
|
?~(c ~ u.c)
|
|
::
|
|
++ del
|
|
|* [b=* c=*]
|
|
^+ a
|
|
=+ d=(get b)
|
|
=+ e=(~(del in d) c)
|
|
?~ e
|
|
(~(del by a) b)
|
|
(~(put by a) b e)
|
|
::
|
|
++ put
|
|
|* [b=* c=*]
|
|
^+ a
|
|
=+ d=(get b)
|
|
(~(put by a) b (~(put in d) c))
|
|
--
|
|
--
|
|
::
|
|
:: Begin naive.hoon
|
|
::
|
|
=>
|
|
:: Laconic bit
|
|
::
|
|
=| lac=?
|
|
:: Constants
|
|
::
|
|
|%
|
|
:: Transfers on L1 to this address count as depositing to L2
|
|
::
|
|
++ deposit-address 0x1111.1111.1111.1111.1111.1111.1111.1111.1111.1111
|
|
++ log-names
|
|
|%
|
|
:: Generated with (keccak-256:keccak:crypto (as-octs:mimes:html name))
|
|
::
|
|
:: OwnerChanged(uint32,address)
|
|
++ owner-changed
|
|
0x16d0.f539.d49c.6cad.822b.767a.9445.bfb1.
|
|
cf7e.a6f2.a6c2.b120.a7ea.4cc7.660d.8fda
|
|
::
|
|
:: Activated(uint32)
|
|
++ activated
|
|
0xe74c.0380.9d07.69e1.b1f7.06cc.8414.258c.
|
|
d1f3.b6fe.020c.d15d.0165.c210.ba50.3a0f
|
|
::
|
|
:: Spawned(uint32,uint32)
|
|
++ spawned
|
|
0xb2d3.a6e7.a339.f5c8.ff96.265e.2f03.a010.
|
|
a854.1070.f374.4a24.7090.9644.1508.1546
|
|
::
|
|
:: OwnershipTransferred(address,address)
|
|
++ ownership-transferred
|
|
0x8be0.079c.5316.5914.1344.cd1f.d0a4.f284.
|
|
1949.7f97.22a3.daaf.e3b4.186f.6b64.57e0
|
|
::
|
|
:: EscapeRequested(uint32,uint32)
|
|
++ escape-requested
|
|
0xb4d4.850b.8f21.8218.141c.5665.cba3.79e5.
|
|
3e9b.b015.b51e.8d93.4be7.0210.aead.874a
|
|
::
|
|
:: EscapeCanceled(uint32,uint32)
|
|
++ escape-canceled
|
|
0xd653.bb0e.0bb7.ce83.93e6.24d9.8fbf.17cd.
|
|
a590.2c83.28ed.0cd0.9988.f368.90d9.932a
|
|
::
|
|
:: EscapeAccepted(uint32,uint32)
|
|
++ escape-accepted
|
|
0x7e44.7c9b.1bda.4b17.4b07.96e1.00bf.7f34.
|
|
ebf3.6dbb.7fe6.6549.0b1b.fce6.246a.9da5
|
|
::
|
|
:: LostSponsor(uint32,uint32)
|
|
++ lost-sponsor
|
|
0xd770.4f9a.2519.3dbd.0b0c.b4a8.09fe.ffff.
|
|
a7f1.9d1a.ae88.17a7.1346.c194.4482.10d5
|
|
::
|
|
:: ChangedKeys(uint32,bytes32,bytes32,uint32,uint32)
|
|
++ changed-keys
|
|
0xaa10.e7a0.117d.4323.f1d9.9d63.0ec1.69be.
|
|
bb3a.988e.8957.70e3.5198.7e01.ff54.23d5
|
|
::
|
|
:: BrokeContinuity(uint32,uint32)
|
|
++ broke-continuity
|
|
0x2929.4799.f1c2.1a37.ef83.8e15.f79d.d91b.
|
|
cee2.df99.d63c.d1c1.8ac9.68b1.2951.4e6e
|
|
::
|
|
:: ChangedSpawnProxy(uint32,address)
|
|
++ changed-spawn-proxy
|
|
0x9027.36af.7b3c.efe1.0d9e.840a.ed0d.687e.
|
|
35c8.4095.122b.2505.1a20.ead8.866f.006d
|
|
::
|
|
:: ChangedTransferProxy(uint32,address)
|
|
++ changed-transfer-proxy
|
|
0xcfe3.69b7.197e.7f0c.f067.93ae.2472.a9b1.
|
|
3583.fecb.ed2f.78df.a14d.1f10.796b.847c
|
|
::
|
|
:: ChangedManagementProxy(uint32,address)
|
|
++ changed-management-proxy
|
|
0xab9c.9327.cffd.2acc.168f.afed.be06.139f.
|
|
5f55.cb84.c761.df05.e051.1c25.1e2e.e9bf
|
|
::
|
|
:: ChangedVotingProxy(uint32,address)
|
|
++ changed-voting-proxy
|
|
0xcbd6.269e.c714.57f2.c7b1.a227.74f2.46f6.
|
|
c5a2.eae3.795e.d730.0db5.1768.0c61.c805
|
|
::
|
|
:: ChangedDns(string,string,string)
|
|
++ changed-dns
|
|
0xfafd.04ad.e1da.ae2e.1fdb.0fc1.cc6a.899f.
|
|
d424.063e.d5c9.2120.e67e.0730.53b9.4898
|
|
::
|
|
:: ApprovalForAll(address,address,bool)
|
|
++ approval-for-all
|
|
0x1730.7eab.39ab.6107.e889.9845.ad3d.59bd.
|
|
9653.f200.f220.9204.89ca.2b59.3769.6c31
|
|
--
|
|
-- =>
|
|
:: Types
|
|
|%
|
|
:: ethereum address, 20 bytes.
|
|
::
|
|
+$ address @ux
|
|
+$ nonce @ud
|
|
+$ dominion ?(%l1 %l2 %spawn)
|
|
+$ keys [=life suite=@ud auth=@ crypt=@]
|
|
++ orm ((on ship point) por)
|
|
++ point
|
|
$: :: domain
|
|
::
|
|
=dominion
|
|
::
|
|
:: ownership
|
|
::
|
|
$= own
|
|
$: owner=[=address =nonce]
|
|
spawn-proxy=[=address =nonce]
|
|
management-proxy=[=address =nonce]
|
|
voting-proxy=[=address =nonce]
|
|
transfer-proxy=[=address =nonce]
|
|
==
|
|
::
|
|
:: networking
|
|
::
|
|
$= net
|
|
$: rift=@ud
|
|
=keys
|
|
sponsor=[has=? who=@p]
|
|
escape=(unit @p)
|
|
==
|
|
==
|
|
::
|
|
++ diff
|
|
$% [%nonce =ship =proxy =nonce]
|
|
[%tx =raw-tx err=(unit @tas)]
|
|
[%operator owner=address operator=address approved=?]
|
|
[%dns domains=(list @t)]
|
|
$: %point =ship
|
|
$% [%rift =rift]
|
|
[%keys =keys]
|
|
[%sponsor sponsor=(unit @p)]
|
|
[%escape to=(unit @p)]
|
|
[%owner =address]
|
|
[%spawn-proxy =address]
|
|
[%management-proxy =address]
|
|
[%voting-proxy =address]
|
|
[%transfer-proxy =address]
|
|
[%dominion =dominion]
|
|
== == ==
|
|
::
|
|
+$ state
|
|
$: %0
|
|
=points
|
|
=operators
|
|
dns=(list @t)
|
|
==
|
|
+$ points (tree [ship point])
|
|
+$ operators (jug address address)
|
|
+$ effects (list diff)
|
|
+$ proxy ?(%own %spawn %manage %vote %transfer)
|
|
+$ roll (list raw-tx)
|
|
+$ raw-tx [sig=@ raw=octs =tx]
|
|
+$ tx [from=[=ship =proxy] skim-tx]
|
|
+$ skim-tx
|
|
$% [%transfer-point =address reset=?]
|
|
[%spawn =ship =address]
|
|
[%configure-keys encrypt=@ auth=@ crypto-suite=@ breach=?]
|
|
[%escape parent=ship]
|
|
[%cancel-escape parent=ship]
|
|
[%adopt =ship]
|
|
[%reject =ship]
|
|
[%detach =ship]
|
|
[%set-management-proxy =address]
|
|
[%set-spawn-proxy =address]
|
|
[%set-transfer-proxy =address]
|
|
==
|
|
::
|
|
+$ event-log
|
|
$: address=@ux
|
|
data=@ux
|
|
topics=(lest @ux)
|
|
==
|
|
+$ input
|
|
$: block=@ud
|
|
$% [%bat batch=@]
|
|
[%log =event-log]
|
|
== ==
|
|
:: ECDSA verifier.
|
|
::
|
|
:: Must keccak `dat` and recover the ethereum address which signed.
|
|
:: Must not crash. `v` will normally be between 0 and 3; if it is not,
|
|
:: should produce null.
|
|
::
|
|
+$ verifier $-([dat=octs v=@ r=@ s=@] (unit address))
|
|
-- =>
|
|
::
|
|
|%
|
|
++ debug
|
|
|* [meg=@t *]
|
|
?: lac
|
|
+<+
|
|
~> %slog.[0 meg]
|
|
+<+
|
|
::
|
|
++ parse-roll
|
|
|= batch=@
|
|
=| =roll
|
|
=| pos=@ud
|
|
=/ las (met 0 batch)
|
|
|- ^+ roll
|
|
?: (gte pos las)
|
|
(flop roll)
|
|
=/ parse-result (parse-raw-tx pos batch)
|
|
:: Parsing failed, abort batch
|
|
::
|
|
?~ parse-result
|
|
(debug %parse-failed ~)
|
|
=^ =raw-tx pos u.parse-result
|
|
$(roll [raw-tx roll])
|
|
::
|
|
++ parse-raw-tx
|
|
|= [pos=@ud batch=@]
|
|
^- (unit [raw-tx pos=@ud])
|
|
|^
|
|
=^ sig pos (take 3 65)
|
|
=/ res=(unit [=tx pos=@ud]) parse-tx
|
|
?~ res ~
|
|
=/ dif (sub pos.u.res pos)
|
|
=/ len =>((dvr dif 8) ?>(=(0 q) p))
|
|
:- ~ :_ pos.u.res
|
|
[sig [len (cut 0 [pos dif] batch)] tx.u.res]
|
|
::
|
|
++ parse-tx
|
|
^- (unit [tx pos=@ud])
|
|
=^ from-proxy=@ pos (take 0 3)
|
|
?. ?=(?(%0 %1 %2 %3 %4) from-proxy) (debug %bad-proxy ~)
|
|
=/ =proxy
|
|
?- from-proxy
|
|
%0 %own
|
|
%1 %spawn
|
|
%2 %manage
|
|
%3 %vote
|
|
%4 %transfer
|
|
==
|
|
=^ pad pos (take 0 5)
|
|
=^ from-ship=ship pos (take 3 4)
|
|
=- ?~ res
|
|
~
|
|
`[[[from-ship proxy] skim-tx.u.res] pos.u.res]
|
|
^- res=(unit [=skim-tx pos=@ud])
|
|
=^ op pos (take 0 7)
|
|
?+ op (debug %strange-opcode ~)
|
|
%0
|
|
=^ reset=@ pos (take 0)
|
|
=^ =address pos (take 3 20)
|
|
`[[%transfer-point address =(0 reset)] pos]
|
|
::
|
|
%1
|
|
=^ pad=@ pos (take 0)
|
|
=^ =ship pos (take 3 4)
|
|
=^ =address pos (take 3 20)
|
|
`[[%spawn ship address] pos]
|
|
::
|
|
%2
|
|
=^ breach=@ pos (take 0)
|
|
=^ encrypt=@ pos (take 3 32)
|
|
=^ auth=@ pos (take 3 32)
|
|
=^ crypto-suite=@ pos (take 3 4)
|
|
`[[%configure-keys encrypt auth crypto-suite =(0 breach)] pos]
|
|
::
|
|
%3 =^(res pos take-ship `[[%escape res] pos])
|
|
%4 =^(res pos take-ship `[[%cancel-escape res] pos])
|
|
%5 =^(res pos take-ship `[[%adopt res] pos])
|
|
%6 =^(res pos take-ship `[[%reject res] pos])
|
|
%7 =^(res pos take-ship `[[%detach res] pos])
|
|
%8 =^(res pos take-address `[[%set-management-proxy res] pos])
|
|
%9 =^(res pos take-address `[[%set-spawn-proxy res] pos])
|
|
%10 =^(res pos take-address `[[%set-transfer-proxy res] pos])
|
|
==
|
|
::
|
|
:: Take a bite
|
|
::
|
|
++ take
|
|
|= =bite
|
|
^- [@ @ud]
|
|
=/ =step
|
|
?@ bite (bex bite)
|
|
(mul step.bite (bex bloq.bite))
|
|
[(cut 0 [pos step] batch) (add pos step)]
|
|
:: Encode ship and address
|
|
::
|
|
++ take-address
|
|
^- [address @ud]
|
|
=^ pad=@ pos (take 0)
|
|
=^ =address pos (take 3 20)
|
|
[address pos]
|
|
:: Encode escape-related txs
|
|
::
|
|
++ take-ship
|
|
^- [ship @ud]
|
|
=^ pad=@ pos (take 0)
|
|
=^ other=ship pos (take 3 4)
|
|
[other pos]
|
|
--
|
|
::
|
|
++ proxy-from-point
|
|
|= [=proxy point]
|
|
^- [=address =nonce]
|
|
?- proxy
|
|
%own owner.own
|
|
%spawn spawn-proxy.own
|
|
%manage management-proxy.own
|
|
%vote voting-proxy.own
|
|
%transfer transfer-proxy.own
|
|
==
|
|
::
|
|
++ verify-sig-and-nonce
|
|
|= [=verifier chain-t=@t =state =raw-tx]
|
|
^- ?
|
|
|^
|
|
=/ point (get-point state ship.from.tx.raw-tx)
|
|
?> ?=(^ point) :: we never parse more than four bytes for a ship
|
|
=/ need=[=address =nonce]
|
|
(proxy-from-point proxy.from.tx.raw-tx u.point)
|
|
:: We include a domain separator to avoid letting signatures be
|
|
:: accidentally reused with other applications. We include the name
|
|
:: UrbitID, a signature format version number, and the EIP-155 chain
|
|
:: ID.
|
|
::
|
|
:: We also include a nonce so that a transaction cannot be
|
|
:: rebroadcast.
|
|
::
|
|
=/ prepared-data=octs
|
|
%: cad 3
|
|
14^'UrbitIDV1Chain'
|
|
(met 3 chain-t)^chain-t
|
|
1^':'
|
|
4^nonce.need
|
|
raw.raw-tx
|
|
~
|
|
==
|
|
:: Wallets which support personal_sign include this preamble to avoid
|
|
:: letting personal_sign be used to sign ethereum transactions
|
|
::
|
|
=/ signed-data=octs
|
|
=/ len (ud-to-ascii p.prepared-data)
|
|
%: cad 3
|
|
26^'\19Ethereum Signed Message:\0a'
|
|
(met 3 len)^len
|
|
prepared-data
|
|
~
|
|
==
|
|
=/ dress (verify-sig sig.raw-tx signed-data)
|
|
?~ dress
|
|
|
|
|
=(address.need u.dress)
|
|
:: Verify signature and produce signer address
|
|
::
|
|
++ verify-sig
|
|
|= [sig=@ txdata=octs]
|
|
^- (unit address)
|
|
|^
|
|
:: Reversed of the usual r-s-v order because Ethereum integers are
|
|
:: big-endian
|
|
::
|
|
=^ v sig (take 3)
|
|
=^ s sig (take 3 32)
|
|
=^ r sig (take 3 32)
|
|
:: In Ethereum, v is generally 27 + recid, and verifier expects a
|
|
:: recid. Old versions of geth used 0 + recid, so most software
|
|
:: now supports either format. See:
|
|
::
|
|
:: https://github.com/ethereum/go-ethereum/issues/2053
|
|
::
|
|
=? v (gte v 27) (sub v 27)
|
|
(verifier txdata v r s)
|
|
::
|
|
++ take
|
|
|= =bite
|
|
[(end bite sig) (rsh bite sig)]
|
|
--
|
|
--
|
|
:: ASCII-decimal encode
|
|
::
|
|
++ ud-to-ascii
|
|
|= n=@ud
|
|
?~ n '0'
|
|
=| l=(list @)
|
|
|- ^- @t
|
|
?~ n (rep 3 l)
|
|
=+ (dvr n 10)
|
|
$(n p, l [(add '0' q) l])
|
|
::
|
|
++ ship-rank
|
|
|= =ship
|
|
^- ?(%0 %1 %2 %3 %4)
|
|
?: (lth ship 0x100) %0
|
|
?: (lth ship 0x1.0000) %1
|
|
?: (lth ship 0x1.0000.0000) %2
|
|
?: (lth ship 0x1.0000.0000.0000.0000) %3
|
|
%4
|
|
::
|
|
++ sein :: autoboss
|
|
|= who=ship
|
|
^- ship
|
|
=/ mir (ship-rank who)
|
|
?- mir
|
|
%0 who
|
|
%1 (end 3 who)
|
|
%2 (end 4 who)
|
|
%3 (end 5 who)
|
|
%4 (end 4 who)
|
|
==
|
|
::
|
|
:: Produces null only if ship is not a galaxy, star, or planet
|
|
::
|
|
++ get-point
|
|
|= [=state =ship]
|
|
^- (unit point)
|
|
=/ existing (get:orm points.state ship)
|
|
?^ existing
|
|
`u.existing
|
|
=| =point
|
|
=. who.sponsor.net.point (sein ship)
|
|
?+ (ship-rank ship) (debug %strange-point ~)
|
|
%0 `point(dominion %l1)
|
|
?(%1 %2)
|
|
=/ existing-parent $(ship (sein ship))
|
|
?~ existing-parent ~
|
|
:- ~
|
|
%= point
|
|
dominion
|
|
?- dominion.u.existing-parent
|
|
%l1 %l1
|
|
%l2 %l2
|
|
%spawn %l2
|
|
==
|
|
==
|
|
==
|
|
-- =>
|
|
|%
|
|
:: Receive log from L1 transaction
|
|
::
|
|
++ receive-log
|
|
|= [=state log=event-log]
|
|
^- [effects ^state]
|
|
=* log-name i.topics.log
|
|
?: =(log-name activated:log-names) `state
|
|
?: =(log-name spawned:log-names) `state
|
|
?: =(log-name ownership-transferred:log-names) `state
|
|
?: =(log-name changed-dns:log-names)
|
|
?> ?=(~ t.topics.log)
|
|
=/ words (rip 8 data.log)
|
|
:: This is only true if each domain is <= 32 bytes
|
|
::
|
|
?. ?=([c=@ @ b=@ @ a=@ @ @ @ @ ~] words) `state
|
|
=* one &5.words
|
|
=* two &3.words
|
|
=* tri &1.words
|
|
=/ domains ~[(swp 3 one) (swp 3 two) (swp 3 tri)]
|
|
:- [%dns domains]~
|
|
state(dns domains)
|
|
::
|
|
?: =(log-name approval-for-all:log-names)
|
|
?> ?=([@ @ ~] t.topics.log)
|
|
=* owner i.t.topics.log
|
|
=* operator i.t.t.topics.log
|
|
=/ approved !=(0 data.log)
|
|
:- [%operator owner operator approved]~
|
|
=- state(operators -)
|
|
?: approved
|
|
(~(put ju operators.state) owner operator)
|
|
(~(del ju operators.state) owner operator)
|
|
::
|
|
:: The rest of the logs modify a particular ship, specified in the
|
|
:: second topic. We fetch it, and insert the modification back into
|
|
:: our state.
|
|
::
|
|
?> ?=([@ *] t.topics.log)
|
|
=* ship=@ i.t.topics.log
|
|
=/ the-point (get-point state ship)
|
|
?> ?=(^ the-point)
|
|
=* point u.the-point
|
|
::
|
|
:: Important to fully no-op on failure so we don't insert an entry
|
|
:: into points.state
|
|
::
|
|
=- ?~ res
|
|
`state
|
|
=/ p (put:orm points.state ship new-point.u.res)
|
|
[effects.u.res state(points p)]
|
|
^- res=(unit [=effects new-point=^point])
|
|
::
|
|
?: =(log-name changed-spawn-proxy:log-names)
|
|
?. ?=(%l1 -.point) ~
|
|
?> ?=([@ ~] t.t.topics.log)
|
|
=* to i.t.t.topics.log
|
|
:: Depositing to L2 is represented by a spawn proxy change on L1,
|
|
:: but it doesn't change the actual spawn proxy.
|
|
::
|
|
?: =(deposit-address to)
|
|
:+ ~ [%point ship %dominion %spawn]~
|
|
point(dominion %spawn)
|
|
:+ ~ [%point ship %spawn-proxy to]~
|
|
point(address.spawn-proxy.own to)
|
|
::
|
|
?: =(log-name escape-accepted:log-names)
|
|
?> ?=([@ ~] t.t.topics.log)
|
|
=* parent=@ i.t.t.topics.log
|
|
=/ parent-point (get-point state parent)
|
|
?> ?=(^ parent-point)
|
|
?: ?=(%l2 -.u.parent-point) ~
|
|
:+ ~ [%point ship %sponsor `parent]~
|
|
point(escape.net ~, sponsor.net [%& parent])
|
|
::
|
|
?: =(log-name lost-sponsor:log-names)
|
|
?> ?=([@ ~] t.t.topics.log)
|
|
=* parent=@ i.t.t.topics.log
|
|
:: If the sponsor we lost was not our actual sponsor, we didn't
|
|
:: actually lose anything.
|
|
::
|
|
?. =(parent who.sponsor.net.point) ~
|
|
::
|
|
=/ parent-point (get-point state parent)
|
|
?> ?=(^ parent-point)
|
|
::
|
|
:: We can detach even if the child is on L2, as long as the parent
|
|
:: is on L1.
|
|
::
|
|
?: ?=(%l2 -.u.parent-point) ~
|
|
:+ ~ [%point ship %sponsor ~]~
|
|
point(has.sponsor.net %|)
|
|
::
|
|
:: The rest can be done by any ship on L1, even if their spawn proxy
|
|
:: is set to L2
|
|
::
|
|
?: ?=(%l2 -.point) ~
|
|
::
|
|
?: =(log-name escape-requested:log-names)
|
|
?> ?=([@ ~] t.t.topics.log)
|
|
=* parent=@ i.t.t.topics.log
|
|
=/ parent-point (get-point state parent)
|
|
?> ?=(^ parent-point)
|
|
:+ ~ [%point ship %escape `parent]~
|
|
point(escape.net `parent)
|
|
::
|
|
?: =(log-name escape-canceled:log-names)
|
|
?> ?=([@ ~] t.t.topics.log)
|
|
=* parent=@ i.t.t.topics.log
|
|
=/ parent-point (get-point state parent)
|
|
?> ?=(^ parent-point)
|
|
:+ ~ [%point ship %escape ~]~
|
|
point(escape.net ~)
|
|
::
|
|
?: =(log-name broke-continuity:log-names)
|
|
?> ?=(~ t.t.topics.log)
|
|
=* rift=@ data.log
|
|
:+ ~ [%point ship %rift rift]~
|
|
point(rift.net rift)
|
|
::
|
|
?: =(log-name changed-keys:log-names)
|
|
?> ?=(~ t.t.topics.log)
|
|
=/ =keys
|
|
:* life=(cut 8 [0 1] data.log)
|
|
suite=(cut 8 [1 1] data.log)
|
|
auth=(cut 8 [2 1] data.log)
|
|
crypt=(cut 8 [3 1] data.log)
|
|
==
|
|
:+ ~ [%point ship %keys keys]~
|
|
point(keys.net keys)
|
|
::
|
|
?: =(log-name owner-changed:log-names)
|
|
?> ?=([@ ~] t.t.topics.log)
|
|
=* to i.t.t.topics.log
|
|
:: Depositing to L2 is represented by an ownership change on L1,
|
|
:: but it doesn't change who actually owns the ship.
|
|
::
|
|
?: =(deposit-address to)
|
|
:+ ~ [%point ship %dominion %l2]~
|
|
point(dominion %l2)
|
|
:+ ~ [%point ship %owner to]~
|
|
point(address.owner.own to)
|
|
::
|
|
?: =(log-name changed-transfer-proxy:log-names)
|
|
?> ?=([@ ~] t.t.topics.log)
|
|
=* to i.t.t.topics.log
|
|
:: XX
|
|
:+ ~ [%point ship %transfer-proxy to]~
|
|
point(address.transfer-proxy.own to)
|
|
::
|
|
?: =(log-name changed-management-proxy:log-names)
|
|
?> ?=([@ ~] t.t.topics.log)
|
|
=* to i.t.t.topics.log
|
|
:+ ~ [%point ship %management-proxy to]~
|
|
point(address.management-proxy.own to)
|
|
::
|
|
?: =(log-name changed-voting-proxy:log-names)
|
|
?> ?=([@ ~] t.t.topics.log)
|
|
=* to i.t.t.topics.log
|
|
:+ ~ [%point ship %voting-proxy to]~
|
|
point(address.voting-proxy.own to)
|
|
::
|
|
(debug %unknown-log ~)
|
|
::
|
|
:: Receive batch of L2 transactions
|
|
::
|
|
++ receive-batch
|
|
|= [=verifier chain-id=@ud =state batch=@]
|
|
=/ chain-t (ud-to-ascii chain-id)
|
|
=/ =roll (parse-roll batch)
|
|
|- ^- [effects ^state]
|
|
?~ roll
|
|
[~ state]
|
|
:: Verify signature, else skip tx
|
|
::
|
|
?. (verify-sig-and-nonce verifier chain-t state i.roll)
|
|
%+ debug %l2-sig-failed
|
|
=^ effects state $(roll t.roll)
|
|
:_ state
|
|
[[%tx i.roll `%sig-or-nonce-failed] effects]
|
|
:: Increment nonce, even if it later fails
|
|
::
|
|
=^ effects-1 points.state (increment-nonce state from.tx.i.roll)
|
|
:: Process tx
|
|
::
|
|
=^ effects-2 state
|
|
=/ tx-result=(unit [=effects =^state]) (receive-tx state tx.i.roll)
|
|
?~ tx-result
|
|
%+ debug %l2-tx-failed
|
|
[[%tx i.roll `%tx-failed]~ state]
|
|
[[[%tx i.roll ~] effects.u.tx-result] state.u.tx-result]
|
|
=^ effects-3 state $(roll t.roll)
|
|
[:(welp effects-1 effects-2 effects-3) state]
|
|
::
|
|
++ increment-nonce
|
|
|= [=state =ship =proxy]
|
|
=/ point (get-point state ship)
|
|
?> ?=(^ point) :: we only parsed 4 bytes
|
|
=* own own.u.point
|
|
=^ nonce u.point
|
|
?- proxy
|
|
%own
|
|
:- nonce.owner.own
|
|
u.point(nonce.owner.own +(nonce.owner.own))
|
|
::
|
|
%spawn
|
|
:- nonce.spawn-proxy.own
|
|
u.point(nonce.spawn-proxy.own +(nonce.spawn-proxy.own))
|
|
::
|
|
%manage
|
|
:- nonce.management-proxy.own
|
|
u.point(nonce.management-proxy.own +(nonce.management-proxy.own))
|
|
::
|
|
%vote
|
|
:- nonce.voting-proxy.own
|
|
u.point(nonce.voting-proxy.own +(nonce.voting-proxy.own))
|
|
::
|
|
%transfer
|
|
:- nonce.transfer-proxy.own
|
|
u.point(nonce.transfer-proxy.own +(nonce.transfer-proxy.own))
|
|
==
|
|
::
|
|
:- [%nonce ship proxy nonce]~
|
|
(put:orm points.state ship u.point)
|
|
::
|
|
:: Receive an individual L2 transaction
|
|
::
|
|
++ receive-tx
|
|
|= [=state =tx]
|
|
|^
|
|
^- (unit [effects ^state])
|
|
?- +<.tx
|
|
%spawn (process-spawn +>.tx)
|
|
%transfer-point (w-point process-transfer-point ship.from.tx +>.tx)
|
|
%configure-keys (w-point process-configure-keys ship.from.tx +>.tx)
|
|
%escape (w-point-esc process-escape ship.from.tx +>.tx)
|
|
%cancel-escape (w-point-esc process-cancel-escape ship.from.tx +>.tx)
|
|
%adopt (w-point-esc process-adopt ship.tx +>.tx)
|
|
%reject (w-point-esc process-reject ship.tx +>.tx)
|
|
%detach (w-point-esc process-detach ship.tx +>.tx)
|
|
%set-spawn-proxy
|
|
(w-point-spawn process-set-spawn-proxy ship.from.tx +>.tx)
|
|
::
|
|
%set-transfer-proxy
|
|
(w-point process-set-transfer-proxy ship.from.tx +>.tx)
|
|
::
|
|
%set-management-proxy
|
|
(w-point process-set-management-proxy ship.from.tx +>.tx)
|
|
==
|
|
::
|
|
++ w-point
|
|
|* [fun=$-([ship point *] (unit [effects point])) =ship rest=*]
|
|
^- (unit [effects ^state])
|
|
=/ point (get-point state ship)
|
|
?~ point (debug %strange-ship ~)
|
|
?. ?=(%l2 -.u.point) (debug %ship-not-on-l2 ~)
|
|
:: Important to fully no-op on failure so we don't insert an entry
|
|
:: into points.state
|
|
::
|
|
=/ res=(unit [=effects new-point=^point]) (fun u.point rest)
|
|
?~ res
|
|
~
|
|
`[effects.u.res state(points (put:orm points.state ship new-point.u.res))]
|
|
::
|
|
++ w-point-esc
|
|
|* [fun=$-([ship point *] (unit [effects point])) =ship rest=*]
|
|
^- (unit [effects ^state])
|
|
=/ point (get-point state ship)
|
|
?~ point (debug %strange-ship ~)
|
|
=/ res=(unit [=effects new-point=^point]) (fun u.point rest)
|
|
?~ res
|
|
~
|
|
`[effects.u.res state(points (put:orm points.state ship new-point.u.res))]
|
|
::
|
|
++ w-point-spawn
|
|
|* [fun=$-([ship point *] (unit [effects point])) =ship rest=*]
|
|
^- (unit [effects ^state])
|
|
=/ point (get-point state ship)
|
|
?~ point (debug %strange-ship ~)
|
|
?: ?=(%l1 -.u.point) (debug %ship-on-l2 ~)
|
|
=/ res=(unit [=effects new-point=^point]) (fun u.point rest)
|
|
?~ res
|
|
~
|
|
`[effects.u.res state(points (put:orm points.state ship new-point.u.res))]
|
|
::
|
|
++ process-transfer-point
|
|
|= [=point to=address reset=?]
|
|
=* ship ship.from.tx
|
|
:: Assert from owner or transfer prxoy
|
|
::
|
|
?. |(=(%own proxy.from.tx) =(%transfer proxy.from.tx))
|
|
(debug %bad-permission ~)
|
|
:: Execute transfer
|
|
::
|
|
=/ effects-1
|
|
~[[%point ship %owner to] [%point ship %transfer-proxy *address]]
|
|
=: address.owner.own.point to
|
|
address.transfer-proxy.own.point *address
|
|
==
|
|
:: Execute reset if requested
|
|
::
|
|
?. reset
|
|
`[effects-1 point]
|
|
::
|
|
=^ effects-2 net.point
|
|
?: =([0 0 0] +.keys.net.point)
|
|
`net.point
|
|
=/ =keys [+(life.keys.net.point) 0 0 0]
|
|
:- [%point ship %keys keys]~
|
|
[rift.net.point keys sponsor.net.point escape.net.point]
|
|
=^ effects-3 rift.net.point
|
|
?: =(0 life.keys.net.point)
|
|
`rift.net.point
|
|
:- [%point ship %rift +(rift.net.point)]~
|
|
+(rift.net.point)
|
|
=/ effects-4
|
|
:~ [%point ship %spawn-proxy *address]
|
|
[%point ship %management-proxy *address]
|
|
[%point ship %voting-proxy *address]
|
|
[%point ship %transfer-proxy *address]
|
|
==
|
|
=: address.spawn-proxy.own.point *address
|
|
address.management-proxy.own.point *address
|
|
address.voting-proxy.own.point *address
|
|
address.transfer-proxy.own.point *address
|
|
==
|
|
`[:(welp effects-1 effects-2 effects-3 effects-4) point]
|
|
::
|
|
++ process-spawn
|
|
|= [=ship to=address]
|
|
^- (unit [effects ^state])
|
|
=/ parent=^ship (sein ship)
|
|
:: Assert parent is on L2
|
|
::
|
|
=/ parent-point (get-point state parent)
|
|
?~ parent-point ~
|
|
?. ?=(?(%l2 %spawn) -.u.parent-point) ~
|
|
:: Assert from owner or spawn proxy
|
|
::
|
|
?. ?& =(parent ship.from.tx)
|
|
|(=(%own proxy.from.tx) =(%spawn proxy.from.tx))
|
|
==
|
|
(debug %bad-permission ~)
|
|
:: Assert child not already spawned
|
|
::
|
|
?^ (get:orm points.state ship) (debug %spawn-exists ~)
|
|
:: Assert one-level-down
|
|
::
|
|
?. =(+((ship-rank parent)) (ship-rank ship)) (debug %bad-rank ~)
|
|
::
|
|
=/ [=effects new-point=point]
|
|
=/ point=(unit point) (get-point state ship)
|
|
?> ?=(^ point) :: only parsed 4 bytes
|
|
:: If spawning to self, just do it
|
|
::
|
|
?: ?| ?& =(%own proxy.from.tx)
|
|
=(to address.owner.own.u.parent-point)
|
|
==
|
|
?& =(%spawn proxy.from.tx)
|
|
=(to address.spawn-proxy.own.u.parent-point)
|
|
==
|
|
==
|
|
:- ~[[%point ship %dominion %l2] [%point ship %owner to]]
|
|
u.point(address.owner.own to)
|
|
:: Else spawn to parent and set transfer proxy
|
|
::
|
|
:- :~ [%point ship %dominion %l2]
|
|
[%point ship %owner address.owner.own.u.parent-point]
|
|
[%point ship %transfer-proxy to]
|
|
==
|
|
%= u.point
|
|
address.owner.own address.owner.own.u.parent-point
|
|
address.transfer-proxy.own to
|
|
==
|
|
`[effects state(points (put:orm points.state ship new-point))]
|
|
::
|
|
++ process-configure-keys
|
|
|= [=point crypt=@ auth=@ suite=@ breach=?]
|
|
=* ship ship.from.tx
|
|
::
|
|
?. |(=(%own proxy.from.tx) =(%manage proxy.from.tx))
|
|
(debug %bad-permission ~)
|
|
::
|
|
=^ rift-effects rift.net.point
|
|
?. breach
|
|
`rift.net.point
|
|
[[%point ship %rift +(rift.net.point)]~ +(rift.net.point)]
|
|
::
|
|
=^ keys-effects keys.net.point
|
|
?: =(+.keys.net.point [suite auth crypt])
|
|
`keys.net.point
|
|
=/ =keys
|
|
[+(life.keys.net.point) suite auth crypt]
|
|
[[%point ship %keys keys]~ keys]
|
|
::
|
|
`[(welp rift-effects keys-effects) point]
|
|
::
|
|
++ process-escape
|
|
|= [=point parent=ship]
|
|
=* ship ship.from.tx
|
|
?. |(=(%own proxy.from.tx) =(%manage proxy.from.tx))
|
|
(debug %bad-permission ~)
|
|
::
|
|
?. =(+((ship-rank parent)) (ship-rank ship))
|
|
(debug %bad-rank ~)
|
|
::
|
|
:+ ~ [%point ship %escape `parent]~
|
|
point(escape.net `parent)
|
|
::
|
|
++ process-cancel-escape
|
|
|= [=point parent=ship]
|
|
=* ship ship.from.tx
|
|
?. |(=(%own proxy.from.tx) =(%manage proxy.from.tx))
|
|
(debug %bad-permission ~)
|
|
::
|
|
:+ ~ [%point ship %escape ~]~
|
|
point(escape.net ~)
|
|
::
|
|
++ process-adopt
|
|
|= [=point =ship]
|
|
=* parent ship.from.tx
|
|
?. |(=(%own proxy.from.tx) =(%manage proxy.from.tx))
|
|
(debug %bad-permission ~)
|
|
::
|
|
?. =(escape.net.point `parent) (debug %no-adopt ~)
|
|
:+ ~ [%point ship %sponsor `parent]~
|
|
point(escape.net ~, sponsor.net [%& parent])
|
|
::
|
|
++ process-reject
|
|
|= [=point =ship]
|
|
=* parent ship.from.tx
|
|
?. |(=(%own proxy.from.tx) =(%manage proxy.from.tx))
|
|
(debug %bad-permission ~)
|
|
::
|
|
?. =(escape.net.point `parent) (debug %no-reject ~)
|
|
:+ ~ [%point ship %escape ~]~
|
|
point(escape.net ~)
|
|
::
|
|
++ process-detach
|
|
|= [=point =ship]
|
|
=* parent ship.from.tx
|
|
?. |(=(%own proxy.from.tx) =(%manage proxy.from.tx))
|
|
(debug %bad-permission ~)
|
|
::
|
|
?. =(who.sponsor.net.point parent) (debug %no-detach ~)
|
|
:+ ~ [%point ship %sponsor ~]~
|
|
point(has.sponsor.net %|)
|
|
::
|
|
++ process-set-management-proxy
|
|
|= [=point =address]
|
|
?. |(=(%own proxy.from.tx) =(%manage proxy.from.tx))
|
|
(debug %bad-permission ~)
|
|
::
|
|
:+ ~ [%point ship.from.tx %management-proxy address]~
|
|
point(address.management-proxy.own address)
|
|
::
|
|
++ process-set-spawn-proxy
|
|
|= [=point =address]
|
|
?. |(=(%own proxy.from.tx) =(%spawn proxy.from.tx))
|
|
(debug %bad-permission ~)
|
|
::
|
|
?: (gte (ship-rank ship.from.tx) 2)
|
|
(debug %spawn-proxy-planet ~)
|
|
::
|
|
:+ ~ [%point ship.from.tx %spawn-proxy address]~
|
|
point(address.spawn-proxy.own address)
|
|
::
|
|
++ process-set-transfer-proxy
|
|
|= [=point =address]
|
|
?. |(=(%own proxy.from.tx) =(%transfer proxy.from.tx))
|
|
(debug %bad-permission ~)
|
|
::
|
|
:+ ~ [%point ship.from.tx %transfer-proxy address]~
|
|
point(address.transfer-proxy.own address)
|
|
--
|
|
--
|
|
::
|
|
:: State transition function
|
|
::
|
|
|= [=verifier chain-id=@ud =state =input]
|
|
^- [effects ^state]
|
|
?: ?=(%log +<.input)
|
|
:: Received log from L1 transaction
|
|
::
|
|
(receive-log state event-log.input)
|
|
:: Received L2 batch
|
|
::
|
|
:: %+ debug %batch
|
|
(receive-batch verifier chain-id state batch.input)
|