diff options
| author | polwex <polwex@sortug.com> | 2025-06-22 06:14:42 +0700 |
|---|---|---|
| committer | polwex <polwex@sortug.com> | 2025-06-22 06:14:42 +0700 |
| commit | 6dccba9bb5100329209ad01732f9d63f4c4fb43b (patch) | |
| tree | 140b33d2e25084174fce057056de9dea0e2dcbea | |
metamask login getting there
| -rw-r--r-- | app/zodiac.hoon | 62 | ||||
| -rw-r--r-- | desk.bill | 2 | ||||
| -rw-r--r-- | desk.ship | 1 | ||||
| -rw-r--r-- | lib/ethereum.hoon | 1006 | ||||
| -rw-r--r-- | lib/metamask.hoon | 169 | ||||
| -rw-r--r-- | lib/naive.hoon | 926 | ||||
| -rw-r--r-- | lib/server.hoon | 179 | ||||
| -rw-r--r-- | lib/sortug.hoon | 679 | ||||
| -rw-r--r-- | lib/tiny.hoon | 670 | ||||
| -rw-r--r-- | mar/bill.hoon | 34 | ||||
| -rw-r--r-- | mar/hoon.hoon | 36 | ||||
| -rw-r--r-- | mar/kelvin.hoon | 28 | ||||
| -rw-r--r-- | mar/mime.hoon | 32 | ||||
| -rw-r--r-- | mar/noun.hoon | 22 | ||||
| -rw-r--r-- | mar/ship.hoon | 20 | ||||
| -rw-r--r-- | sur/zodiac.hoon | 7 | ||||
| -rw-r--r-- | sys.kelvin | 1 | ||||
| -rw-r--r-- | web/index.hoon | 465 | ||||
| -rw-r--r-- | web/router.hoon | 101 |
19 files changed, 4440 insertions, 0 deletions
diff --git a/app/zodiac.hoon b/app/zodiac.hoon new file mode 100644 index 0000000..43a5694 --- /dev/null +++ b/app/zodiac.hoon @@ -0,0 +1,62 @@ +/- *zodiac +/= router /web/router +=| versioned-state +=* state - +^- agent:gall +|_ =bowl:gall ++* this . +++ on-init + ^- (quip card:agent:gall agent:gall) + :_ this + =/ weblib router(bowl bowl) + :~((eyre-binding-card:weblib /zodiac)) +:: +++ on-save + ^- vase + !>(state) +:: +++ on-load + |~ old-state=vase + ^- (quip card:agent:gall agent:gall) + `this +:: +++ on-poke + |= [=mark =vase] + ^- (quip card:agent:gall agent:gall) + ?+ mark `this + %handle-http-request + =/ order !<([id=@ta req=inbound-request:eyre] vase) + =/ weblib ~(. router [bowl id.order req.order state]) + :- route:weblib this + == +:: +++ on-watch + |~ path + ^- (quip card:agent:gall agent:gall) + `this +:: +++ on-leave + |~ path + ^- (quip card:agent:gall agent:gall) + `this +:: +++ on-peek + |~ path + ^- (unit (unit cage)) + ~ +:: +++ on-agent + |~ [wire sign:agent:gall] + ^- (quip card:agent:gall agent:gall) + `this +:: +++ on-arvo + |~ [wire =sign-arvo] + ^- (quip card:agent:gall agent:gall) + `this +:: +++ on-fail + |~ [term tang] + ^- (quip card:agent:gall agent:gall) + `this +-- diff --git a/desk.bill b/desk.bill new file mode 100644 index 0000000..32ce7b6 --- /dev/null +++ b/desk.bill @@ -0,0 +1,2 @@ +:~ %zodiac +== diff --git a/desk.ship b/desk.ship new file mode 100644 index 0000000..7661bd5 --- /dev/null +++ b/desk.ship @@ -0,0 +1 @@ +~zod diff --git a/lib/ethereum.hoon b/lib/ethereum.hoon new file mode 100644 index 0000000..0c2c635 --- /dev/null +++ b/lib/ethereum.hoon @@ -0,0 +1,1006 @@ +:: ethereum: utilities +:: +=, ethereum-types +|% +:: deriving and using ethereum keys +:: +++ key + |% + ++ address-from-pub + =, keccak:crypto + |= pub=@ + %+ end [3 20] + %+ keccak-256 64 + (rev 3 64 pub) + :: + ++ address-from-prv + (cork pub-from-prv address-from-pub) + :: + ++ pub-from-prv + =, secp256k1:secp:crypto + |= prv=@ + %- serialize-point + (priv-to-pub prv) + :: + ++ sign-typed-transaction + |= [tx=typed-transaction:rpc pk=@] + ^- @ux + =- (cat 3 - -.tx) + ?- -.tx + %0x0 (sign-transaction +.tx pk) + %0x2 (sign-transaction-1559 +.tx pk) + == + :: + ++ sign-transaction + =, crypto + |= [tx=transaction:rpc pk=@] + |^ ^- @ux + :: hash the raw transaction data + =/ hash=@ + %- keccak-256:keccak + =+ dat=(encode chain-id.tx 0 0) + =+ wid=(met 3 dat) + [wid (rev 3 wid dat)] + :: sign transaction hash with private key + =+ (ecdsa-raw-sign:secp256k1:secp hash pk) + :: complete transaction is raw data, with r and s + :: taken from the signature, and v as per eip-155 + (encode :(add (mul chain-id.tx 2) 35 v) r s) + :: + ++ encode + |= [v=@ r=@ s=@] + %+ encode:rlp %l + tx(to b+20^to.tx, chain-id [v r s ~]) + -- + :: + ++ sign-transaction-1559 + =, crypto + |= [tx=transaction-1559:rpc pk=@] + |^ ^- @ux + =; hash=@ + =+ (ecdsa-raw-sign:secp256k1:secp hash pk) + ::NOTE we retrieve y's parity from the v value + (encode-1559 ~ (end 0 v) r s) + :: hash the raw transaction data including leading 0x2 + %- keccak-256:keccak + =+ dat=(cat 3 (encode-1559 ~) 0x2) + =+ wid=(met 3 dat) + [wid (rev 3 wid dat)] + :: + ++ encode-1559 + |= sig=(unit [y=@ r=@ s=@]) + %+ encode:rlp %l + =, tx + :* chain-id + nonce + max-priority-gas-fee + max-gas-fee + gas + b+20^to + value + data + :: + :- %l + %+ turn ~(tap by access-list) + |= [a=address b=(list @ux)] + l+~[b+20^a l+(turn b |=(c=@ux b+32^c))] + :: + ?~ sig ~ + ~[y r s]:u.sig + == + -- + -- +:: +:: rlp en/decoding +::NOTE https://eth.wiki/en/fundamentals/rlp +:: +++ rlp + |% + ::NOTE rlp encoding doesn't really care about leading zeroes, + :: but because we need to disinguish between no-bytes zero + :: and one-byte zero (and also empty list) we end up with + :: this awful type... + +$ item + $@ @ + $% [%l l=(list item)] + [%b b=byts] + == + :: +encode-atoms: encode list of atoms as a %l of %b items + :: + ++ encode-atoms ::NOTE deprecated + |= l=(list @) + ^- @ + (encode l+l) + :: + ++ encode + |= in=item + |^ ^- @ + ?- in + @ + $(in [%b (met 3 in) in]) + :: + [%b *] + ?: &(=(1 wid.b.in) (lte dat.b.in 0x7f)) + dat.b.in + =- (can 3 ~[b.in [(met 3 -) -]]) + (encode-length wid.b.in 0x80) + :: + [%l *] + :: we +can because b+1^0x0 encodes to 0x00 + :: + =/ l=(list byts) + %+ turn l.in + |= ni=item + =+ (encode ni) + [(max 1 (met 3 -)) -] + %+ can 3 + %- flop + =- [(met 3 -)^- l] + (encode-length (roll (turn l head) add) 0xc0) + == + :: + ++ encode-length + |= [len=@ off=@] + ?: (lth len 56) (add len off) + =- (cat 3 len -) + :(add (met 3 len) off 55) + -- + :: +decode-atoms: decode expecting a %l of %b items, producing atoms within + :: + ++ decode-atoms + |= dat=@ + ^- (list @) + =/ i=item (decode dat) + ~| [%unexpected-data i] + ?> ?=(%l -.i) + %+ turn l.i + |= i=item + ~| [%unexpected-list i] + ?> ?=(%b -.i) + dat.b.i + :: + ++ decode + |= dat=@ + ^- item + =/ bytes=(list @) (flop (rip 3 dat)) + =? bytes ?=(~ bytes) ~[0] + |^ item:decode-head + :: + ++ decode-head + ^- [done=@ud =item] + ?~ bytes + ~| %rlp-unexpected-end + !! + =* byt i.bytes + :: byte in 0x00-0x79 range encodes itself + :: + ?: (lte byt 0x79) + :- 1 + [%b 1^byt] + :: byte in 0x80-0xb7 range encodes string length + :: + ?: (lte byt 0xb7) + =+ len=(sub byt 0x80) + :- +(len) + :- %b + len^(get-value 1 len) + :: byte in 0xb8-0xbf range encodes string length length + :: + ?: (lte byt 0xbf) + =+ led=(sub byt 0xb7) + =+ len=(get-value 1 led) + :- (add +(led) len) + :- %b + len^(get-value +(led) len) + :: byte in 0xc0-f7 range encodes list length + :: + ?: (lte byt 0xf7) + =+ len=(sub byt 0xc0) + :- +(len) + :- %l + %. len + decode-list(bytes (slag 1 `(list @)`bytes)) + :: byte in 0xf8-ff range encodes list length length + :: + ?: (lte byt 0xff) + =+ led=(sub byt 0xf7) + =+ len=(get-value 1 led) + :- (add +(led) len) + :- %l + %. len + decode-list(bytes (slag +(led) `(list @)`bytes)) + ~| [%rip-not-bloq-3 `@ux`byt] + !! + :: + ++ decode-list + |= rem=@ud + ^- (list item) + ?: =(0 rem) ~ + =+ ^- [don=@ud =item] ::TODO =/ + decode-head + :- item + %= $ + rem (sub rem don) + bytes (slag don bytes) + == + :: + ++ get-value + |= [at=@ud to=@ud] + ^- @ + (rep 3 (flop (swag [at to] bytes))) + -- + -- +:: +:: abi en/decoding +::NOTE https://solidity.readthedocs.io/en/develop/abi-spec.html +:: +++ abi + => |% + :: solidity types. integer bitsizes ignored + ++ etyp + $@ $? :: static + %address %bool + %int %uint + %real %ureal + :: dynamic + %bytes %string + == + $% :: static + [%bytes-n n=@ud] + :: dynamic + [%array-n t=etyp n=@ud] + [%array t=etyp] + == + :: + :: solidity-style typed data. integer bitsizes ignored + ++ data + $% [%address p=address] + [%string p=tape] + [%bool p=?] + [%int p=@sd] + [%uint p=@ud] + [%real p=@rs] + [%ureal p=@urs] + [%array-n p=(list data)] + [%array p=(list data)] + [%bytes-n p=octs] ::TODO just @, because context knows length? + [%bytes p=octs] + == + -- + =, mimes:html + |% + :: encoding + :: + ++ encode-args + :: encode list of arguments. + :: + |= das=(list data) + ^- tape + (encode-data [%array-n das]) + :: + ++ encode-data + :: encode typed data into ABI bytestring. + :: + |= dat=data + ^- tape + ?+ -.dat + ~| [%unsupported-type -.dat] + !! + :: + %array-n + :: enc(X) = head(X[0]) ... head(X[k-1]) tail(X[0]) ... tail(X[k-1]) + :: where head and tail are defined for X[i] being of a static type as + :: head(X[i]) = enc(X[i]) and tail(X[i]) = "" (the empty string), or as + :: head(X[i]) = enc(len( head(X[0])..head(X[k-1]) + :: tail(X[0])..tail(X[i-1]) )) + :: and tail(X[i]) = enc(X[i]) otherwise. + :: + :: so: if it's a static type, data goes in the head. if it's a dynamic + :: type, a reference goes into the head and data goes into the tail. + :: + :: in the head, we first put a placeholder where references need to go. + =+ hol=(reap 64 'x') + =/ hes=(list tape) + %+ turn p.dat + |= d=data + ?. (is-dynamic-type d) ^$(dat d) + hol + =/ tas=(list tape) + %+ turn p.dat + |= d=data + ?. (is-dynamic-type d) "" + ^$(dat d) + :: once we know the head and tail, we can fill in the references in head. + =- (weld nes `tape`(zing tas)) + ^- [@ud nes=tape] + =+ led=(lent (zing hes)) + %+ roll hes + |= [t=tape i=@ud nes=tape] + :- +(i) + :: if no reference needed, just put the data. + ?. =(t hol) (weld nes t) + :: calculate byte offset of data we need to reference. + =/ ofs=@ud + =- (div - 2) :: two hex digits per byte. + %+ add led :: count head, and + %- lent %- zing :: count all tail data + (scag i tas) :: preceding ours. + =+ ref=^$(dat [%uint ofs]) + :: shouldn't hit this unless we're sending over 2gb of data? + ~| [%weird-ref-lent (lent ref)] + ?> =((lent ref) (lent hol)) + (weld nes ref) + :: + %array :: where X has k elements (k is assumed to be of type uint256): + :: enc(X) = enc(k) enc([X[1], ..., X[k]]) + :: i.e. it is encoded as if it were an array of static size k, prefixed + :: with the number of elements. + %+ weld $(dat [%uint (lent p.dat)]) + $(dat [%array-n p.dat]) + :: + %bytes-n + :: enc(X) is the sequence of bytes in X padded with zero-bytes to a + :: length of 32. + :: Note that for any X, len(enc(X)) is a multiple of 32. + ~| [%bytes-n-too-long max=32 actual=p.p.dat] + ?> (lte p.p.dat 32) + (pad-to-multiple (render-hex-bytes p.dat) 64 %right) + :: + %bytes :: of length k (which is assumed to be of type uint256) + :: enc(X) = enc(k) pad_right(X), i.e. the number of bytes is encoded as a + :: uint256 followed by the actual value of X as a byte sequence, followed + :: by the minimum number of zero-bytes such that len(enc(X)) is a + :: multiple of 32. + %+ weld $(dat [%uint p.p.dat]) + (pad-to-multiple (render-hex-bytes p.dat) 64 %right) + :: + %string + :: enc(X) = enc(enc_utf8(X)), i.e. X is utf-8 encoded and this value is + :: interpreted as of bytes type and encoded further. Note that the length + :: used in this subsequent encoding is the number of bytes of the utf-8 + :: encoded string, not its number of characters. + $(dat [%bytes (lent p.dat) (swp 3 (crip p.dat))]) + :: + %uint + :: enc(X) is the big-endian encoding of X, padded on the higher-order + :: (left) side with zero-bytes such that the length is a multiple of 32 + :: bytes. + (pad-to-multiple (render-hex-bytes (as-octs p.dat)) 64 %left) + :: + %bool + :: as in the uint8 case, where 1 is used for true and 0 for false + $(dat [%uint ?:(p.dat 1 0)]) + :: + %address + :: as in the uint160 case + $(dat [%uint `@ud`p.dat]) + == + :: + ++ is-dynamic-type + |= a=data + ?. ?=(%array-n -.a) + ?=(?(%string %bytes %array) -.a) + &(!=((lent p.a) 0) (lien p.a is-dynamic-type)) + :: + :: decoding + :: + ++ decode-topics decode-arguments + :: + ++ decode-results + :: rex: string of hex bytes with leading 0x. + |* [rex=@t tys=(list etyp)] + =- (decode-arguments - tys) + %^ rut 9 + (rsh [3 2] rex) + (curr rash hex) + :: + ++ decode-arguments + |* [wos=(list @) tys=(list etyp)] + =/ wos=(list @) wos :: get rid of tmi + =| win=@ud + =< (decode-from 0 tys) + |% + ++ decode-from + |* [win=@ud tys=(list etyp)] + ?~ tys !! + =- ?~ t.tys dat + [dat $(win nin, tys t.tys)] + (decode-one win ~[i.tys]) + :: + ++ decode-one + ::NOTE we take (list etyp) even though we only operate on + :: a single etyp as a workaround for urbit/arvo#673 + |* [win=@ud tys=(list etyp)] + =- [nin dat]=- ::NOTE ^= regular form broken + ?~ tys !! + =* typ i.tys + =+ wor=(snag win wos) + ?+ typ + ~| [%unsupported-type typ] + !! + :: + ?(%address %bool %uint) :: %int %real %ureal + :- +(win) + ?- typ + %address `@ux`wor + %uint `@ud`wor + %bool =(1 wor) + == + :: + %string + =+ $(tys ~[%bytes]) + [nin (trip (swp 3 q.dat))] + :: + %bytes + :- +(win) + :: find the word index of the actual data. + =/ lic=@ud (div wor 32) + :: learn the bytelength of the data. + =/ len=@ud (snag lic wos) + (decode-bytes-n +(lic) len) + :: + [%bytes-n *] + :- (add win +((div (dec n.typ) 32))) + (decode-bytes-n win n.typ) + :: + [%array *] + :- +(win) + :: find the word index of the actual data. + =. win (div wor 32) + :: read the elements from their location. + %- tail + %^ decode-array-n ~[t.typ] +(win) + (snag win wos) + :: + [%array-n *] + (decode-array-n ~[t.typ] win n.typ) + == + :: + ++ decode-bytes-n + |= [fro=@ud bys=@ud] + ^- octs + :: parse {bys} bytes from {fro}. + :- bys + %+ rsh + :- 3 + =+ (mod bys 32) + ?:(=(0 -) - (sub 32 -)) + %+ rep 8 + %- flop + =- (swag [fro -] wos) + +((div (dec bys) 32)) + :: + ++ decode-array-n + ::NOTE we take (list etyp) even though we only operate on + :: a single etyp as a workaround for urbit/arvo#673 + ::NOTE careful! produces lists without type info + =| res=(list) + |* [tys=(list etyp) fro=@ud len=@ud] + ^- [@ud (list)] + ?~ tys !! + ?: =(len 0) [fro (flop `(list)`res)] + =+ (decode-one fro ~[i.tys]) :: [nin=@ud dat=*] + $(res ^+(res [dat res]), fro nin, len (dec len)) + -- + -- +:: +:: communicating with rpc nodes +::NOTE https://github.com/ethereum/wiki/wiki/JSON-RPC +:: +++ rpc + :: types + :: + => =, abi + =, format + |% + :: raw call data + ++ call-data + $: function=@t + arguments=(list data) + == + :: + :: raw transaction data + +$ typed-transaction + $% [%0x0 transaction] + [%0x2 transaction-1559] + == + :: + +$ transaction + $: nonce=@ud + gas-price=@ud + gas=@ud + to=address + value=@ud + data=@ux + chain-id=@ux + == + :: + +$ transaction-1559 + $: chain-id=@ux + nonce=@ud + max-priority-gas-fee=@ud + max-gas-fee=@ud + gas=@ud + to=address + value=@ud + data=@ux + access-list=(jar address @ux) + == + :: + :: ethereum json rpc api + :: + :: supported requests. + ++ request + $% [%eth-block-number ~] + [%eth-call cal=call deb=block] + $: %eth-new-filter + fro=(unit block) + tob=(unit block) + adr=(list address) + top=(list ?(@ux (list @ux))) + == + [%eth-get-block-by-number bon=@ud txs=?] + [%eth-get-filter-logs fid=@ud] + $: %eth-get-logs + fro=(unit block) + tob=(unit block) + adr=(list address) + top=(list ?(@ux (list @ux))) + == + $: %eth-get-logs-by-hash + has=@ + adr=(list address) + top=(list ?(@ux (list @ux))) + == + [%eth-get-filter-changes fid=@ud] + [%eth-get-transaction-by-hash txh=@ux] + [%eth-get-transaction-count adr=address =block] + [%eth-get-balance adr=address =block] + [%eth-get-transaction-receipt txh=@ux] + [%eth-send-raw-transaction dat=@ux] + == + :: + ::TODO clean up & actually use + ++ response + $% ::TODO + [%eth-new-filter fid=@ud] + [%eth-get-filter-logs los=(list event-log)] + [%eth-get-logs los=(list event-log)] + [%eth-get-logs-by-hash los=(list event-log)] + [%eth-got-filter-changes los=(list event-log)] + [%eth-transaction-hash haz=@ux] + == + :: + ++ transaction-result + $: block-hash=(unit @ux) + block-number=(unit @ud) + transaction-index=(unit @ud) + from=@ux + to=(unit @ux) + input=@t + == + :: + ++ event-log + $: :: null for pending logs + $= mined %- unit + $: input=(unit @ux) + log-index=@ud + transaction-index=@ud + transaction-hash=@ux + block-number=@ud + block-hash=@ux + removed=? + == + :: + address=@ux + data=@t + :: event data + :: + :: For standard events, the first topic is the event signature + :: hash. For anonymous events, the first topic is the first + :: indexed argument. + :: Note that this does not support the "anonymous event with + :: zero topics" case. This has dubious usability, and using + :: +lest instead of +list saves a lot of ?~ checks. + :: + topics=(lest @ux) + == + :: + :: data for eth_call. + ++ call + $: from=(unit address) + to=address + gas=(unit @ud) + gas-price=(unit @ud) + value=(unit @ud) + data=tape + == + :: + :: minimum data needed to construct a read call + ++ proto-read-request + $: id=(unit @t) + to=address + call-data + == + :: + :: block to operate on. + ++ block + $% [%number n=@ud] + [%label l=?(%earliest %latest %pending)] + == + -- + :: + :: logic + :: + |% + ++ encode-call + |= call-data + ^- tape + ::TODO should this check to see if the data matches the function signature? + =- :(weld "0x" - (encode-args arguments)) + %+ scag 8 + %+ render-hex-bytes 32 + %- keccak-256:keccak:crypto + (as-octs:mimes:html function) + :: + :: building requests + :: + ++ json-request + =, eyre + |= [url=purl jon=json] + ^- hiss + :^ url %post + %- ~(gas in *math) + ~['Content-Type'^['application/json']~] + (some (as-octs (en:json:html jon))) + :: +light-json-request: like json-request, but for %l + :: + :: TODO: Exorcising +purl from our system is a much longer term effort; + :: get the current output types for now. + :: + ++ light-json-request + |= [url=purl:eyre jon=json] + ^- request:http + :: + :* %'POST' + (crip (en-purl:html url)) + ~[['content-type' 'application/json']] + (some (as-octs (en:json:html jon))) + == + :: + ++ batch-read-request + |= req=(list proto-read-request) + ^- json + a+(turn req read-request) + :: + ++ read-request + |= proto-read-request + ^- json + %+ request-to-json id + :+ %eth-call + ^- call + [~ to ~ ~ ~ `tape`(encode-call function arguments)] + [%label %latest] + :: + ++ request-to-json + =, enjs:format + |= [riq=(unit @t) req=request] + ^- json + %- pairs + =; r=[met=@t pas=(list json)] + ::TODO should use request-to-json:rpc:jstd, + :: and probably (fall riq -.req) + :* jsonrpc+s+'2.0' + method+s+met.r + params+a+pas.r + ::TODO would just jamming the req noun for id be a bad idea? + ?~ riq ~ + [id+s+u.riq]~ + == + ?- -.req + %eth-block-number + ['eth_blockNumber' ~] + :: + %eth-call + :- 'eth_call' + :~ (eth-call-to-json cal.req) + (block-to-json deb.req) + == + :: + %eth-new-filter + :- 'eth_newFilter' + :_ ~ + :- %o %- ~(gas by *(map @t json)) + =- (murn - same) + ^- (list (unit (pair @t json))) + :~ ?~ fro.req ~ + `['fromBlock' (block-to-json u.fro.req)] + :: + ?~ tob.req ~ + `['toBlock' (block-to-json u.tob.req)] + :: + ::NOTE tmi + ?: =(0 (lent adr.req)) ~ + :+ ~ 'address' + ?: =(1 (lent adr.req)) (tape (address-to-hex (snag 0 adr.req))) + :- %a + (turn adr.req (cork address-to-hex tape)) + :: + ?~ top.req ~ + :+ ~ 'topics' + (topics-to-json top.req) + == + :: + %eth-get-block-by-number + :- 'eth_getBlockByNumber' + :~ (tape (num-to-hex-minimal bon.req)) + b+txs.req + == + :: + %eth-get-filter-logs + ['eth_getFilterLogs' (tape (num-to-hex fid.req)) ~] + :: + %eth-get-logs + :- 'eth_getLogs' + :_ ~ + :- %o %- ~(gas by *(map @t json)) + =- (murn - same) + ^- (list (unit (pair @t json))) + :~ ?~ fro.req ~ + `['fromBlock' (block-to-json u.fro.req)] + :: + ?~ tob.req ~ + `['toBlock' (block-to-json u.tob.req)] + :: + ?: =(0 (lent adr.req)) ~ + :+ ~ 'address' + ?: =(1 (lent adr.req)) (tape (address-to-hex (snag 0 adr.req))) + :- %a + (turn adr.req (cork address-to-hex tape)) + :: + ?~ top.req ~ + :+ ~ 'topics' + (topics-to-json top.req) + == + :: + %eth-get-logs-by-hash + :- 'eth_getLogs' + :_ ~ :- %o + %- ~(gas by *(map @t json)) + =- (murn - same) + ^- (list (unit (pair @t json))) + :~ `['blockHash' (tape (transaction-to-hex has.req))] + :: + ?: =(0 (lent adr.req)) ~ + :+ ~ 'address' + ?: =(1 (lent adr.req)) (tape (address-to-hex (snag 0 adr.req))) + :- %a + (turn adr.req (cork address-to-hex tape)) + :: + ?~ top.req ~ + :+ ~ 'topics' + (topics-to-json top.req) + == + :: + %eth-get-filter-changes + ['eth_getFilterChanges' (tape (num-to-hex fid.req)) ~] + :: + %eth-get-transaction-count + :- 'eth_getTransactionCount' + :~ (tape (address-to-hex adr.req)) + (block-to-json block.req) + == + :: + %eth-get-balance + :- 'eth_getBalance' + :~ (tape (address-to-hex adr.req)) + (block-to-json block.req) + == + :: + %eth-get-transaction-by-hash + ['eth_getTransactionByHash' (tape (transaction-to-hex txh.req)) ~] + :: + %eth-get-transaction-receipt + ['eth_getTransactionReceipt' (tape (transaction-to-hex txh.req)) ~] + :: + %eth-send-raw-transaction + ['eth_sendRawTransaction' (tape (num-to-hex dat.req)) ~] + == + :: + ++ eth-call-to-json + =, enjs:format + |= cal=call + ^- json + :- %o %- ~(gas by *(map @t json)) + =- (murn - same) + ^- (list (unit (pair @t json))) + :~ ?~ from.cal ~ + `['from' (tape (address-to-hex u.from.cal))] + :: + `['to' (tape (address-to-hex to.cal))] + :: + ?~ gas.cal ~ + `['gas' (tape (num-to-hex u.gas.cal))] + :: + ?~ gas-price.cal ~ + `['gasPrice' (tape (num-to-hex u.gas-price.cal))] + :: + ?~ value.cal ~ + `['value' (tape (num-to-hex u.value.cal))] + :: + ?~ data.cal ~ + `['data' (tape data.cal)] + == + :: + ++ block-to-json + |= dob=block + ^- json + ?- -.dob + %number s+(crip '0' 'x' ((x-co:co 1) n.dob)) + %label s+l.dob + == + :: + ++ topics-to-json + |= tos=(list ?(@ux (list @ux))) + ^- json + :- %a + =/ ttj + ;: cork + (cury render-hex-bytes 32) + prefix-hex + tape:enjs:format + == + %+ turn tos + |= t=?(@ (list @)) + ?@ t + ?: =(0 t) ~ + (ttj `@`t) + a+(turn t ttj) + :: + :: parsing responses + :: + ::TODO ++ parse-response |= json ^- response + :: + ++ parse-hex-result + |= j=json + ^- @ + ?> ?=(%s -.j) + (hex-to-num p.j) + :: + ++ parse-eth-new-filter-res parse-hex-result + :: + ++ parse-eth-block-number parse-hex-result + :: + ++ parse-transaction-hash parse-hex-result + :: + ++ parse-eth-get-transaction-count parse-hex-result + :: + ++ parse-eth-get-balance parse-hex-result + :: + ++ parse-event-logs + (ar:dejs:format parse-event-log) + :: + ++ parse-event-log + =, dejs:format + |= log=json + ^- event-log + =- ((ot -) log) + :~ =- ['logIndex'^(cu - (mu so))] + |= li=(unit @t) + ?~ li ~ + =- ``((ou -) log) ::TODO not sure if elegant or hacky. + :~ 'logIndex'^(un (cu hex-to-num so)) + 'transactionIndex'^(un (cu hex-to-num so)) + 'transactionHash'^(un (cu hex-to-num so)) + 'blockNumber'^(un (cu hex-to-num so)) + 'blockHash'^(un (cu hex-to-num so)) + 'removed'^(uf | bo) + == + :: + address+(cu hex-to-num so) + data+so + :: + =- topics+(cu - (ar so)) + |= r=(list @t) + ^- (lest @ux) + ?> ?=([@t *] r) + :- (hex-to-num i.r) + (turn t.r hex-to-num) + == + :: + ++ parse-transaction-result + =, dejs:format + |= jon=json + ~| jon=jon + ^- transaction-result + =- ((ot -) jon) + :~ 'blockHash'^_~ :: TODO: fails if maybe-num? + 'blockNumber'^maybe-num + 'transactionIndex'^maybe-num + from+(cu hex-to-num so) + to+maybe-num + input+so + == + :: + ++ maybe-num + =, dejs:format + =- (cu - (mu so)) + |= r=(unit @t) + ?~ r ~ + `(hex-to-num u.r) + -- +:: +:: utilities +::TODO give them better homes! +:: +++ num-to-hex + |= n=@ + ^- tape + %- prefix-hex + ?: =(0 n) + "0" + %- render-hex-bytes + (as-octs:mimes:html n) +:: +++ num-to-hex-minimal + |= n=@ + ^- tape + %- prefix-hex + ((x-co:co 1) n) +:: +++ address-to-hex + |= a=address + ^- tape + %- prefix-hex + (render-hex-bytes 20 `@`a) +:: +++ address-to-checksum + |= a=address + ^- tape + =/ hexed (render-hex-bytes 20 `@`a) + =/ hash (keccak-256:keccak:crypto (as-octs:mimes:html (crip hexed))) + =| ret=tape + =/ pos 63 + |- + ?~ hexed (prefix-hex (flop ret)) + =/ char i.hexed + ?: (lth char 58) $(pos (dec pos), ret [char ret], hexed t.hexed) + =/ nib (cut 2 [pos 1] hash) + ?: (lth 7 nib) $(pos (dec pos), ret [(sub char 32) ret], hexed t.hexed) + $(pos (dec pos), ret [char ret], hexed t.hexed) +:: +++ transaction-to-hex + |= h=@ + ^- tape + %- prefix-hex + (render-hex-bytes 32 h) +:: +++ prefix-hex + |= a=tape + ^- tape + ['0' 'x' a] +:: +++ render-hex-bytes + :: atom to string of hex bytes without 0x prefix and dots. + |= a=octs + ^- tape + ((x-co:co (mul 2 p.a)) q.a) +:: +++ pad-to-multiple + |= [wat=tape mof=@ud wer=?(%left %right)] + ^- tape + =+ len=(lent wat) + ?: =(0 len) (reap mof '0') + =+ mad=(mod len mof) + ?: =(0 mad) wat + =+ tad=(reap (sub mof mad) '0') + %- weld + ?:(?=(%left wer) [tad wat] [wat tad]) +:: +++ hex-to-num + |= a=@t + ~| %non-hex-cord + ?> =((end [3 2] a) '0x') + =< ?<(=(0 p) q) %- need + (de:base16:mimes:html (rsh [3 2] a)) +-- diff --git a/lib/metamask.hoon b/lib/metamask.hoon new file mode 100644 index 0000000..4cb403b --- /dev/null +++ b/lib/metamask.hoon @@ -0,0 +1,169 @@ +/+ naive, ethereum, server +=> +|% ++$ challenges (set secret) ++$ secret @uv ++$ authorization + $: who=@p + =secret + adr=tape + sig=tape + == ++$ user-sessions (map comet=@p id=@p) ++$ sessions + $: =challenges + users=user-sessions + == +-- +|_ [=sessions =bowl:gall] ++$ sess ^sessions +:: state field to keep track of users logged with metamask +++ login ^- @p + =/ session (~(get by users.sessions) src.bowl) + ?~ session src.bowl + u.session + + :: this goes on the router + ++ serve-metamask-challenge + |= eyre-id=@ta + :: special-case MetaMask auth handling + =/ new-challenge (sham [now eny]:bowl) + %+ weld (self-poke [%meta new-challenge]) + %+ give-simple-payload:app:server + eyre-id + ^- simple-payload:http + :- :- 200 + ~[['Content-Type' 'application/json']] + `(as-octs:mimes:html (en:json:html (enjs-challenge new-challenge))) + :: Modified from ~rabsef-bicrym's %mask by ~hanfel-dovned. + ++ process-metamask-auth + |= [order-id=@t octs=(unit octs)] + ^- (list card:agent:gall) + =/ challenges challenges.sessions + |^ + ?~ octs ~|(%empty-auth-request !!) + :: ?. =('auth' (cut 3 [0 4] q.u.octs)) + :: *(list card:agent:gall) + =/ jon (de:json:html q.u.octs) + ?~ jon ~|(%empty-auth-json !!) + =/ body=json u.jon + =/ axn (dejs-action body) + =/ is-valid (validate who.axn secret.axn adr.axn sig.axn) + ~& >> signature-valid=[is-valid who.axn secret.axn adr.axn sig.axn] + ?. is-valid ~|(%bad-metamask-signature !!) + %+ weld + (self-poke [%auth who.axn src.bowl secret.axn]) + %+ give-simple-payload:app:server + order-id + ^- simple-payload:http + :- :- 200 + ~[['Content-Type' 'application/json']] + =/ obj=json %- pairs:enjs:format :~([%login-ok [%b .y]]) + `(as-octs:mimes:html (en:json:html obj)) + + ++ validate + |= [who=@p challenge=secret address=tape hancock=tape] + ^- ? + =/ addy (from-tape address) + =/ cock (from-tape hancock) + =/ owner (get-owner who) ?~ owner + ~& "no owner" + %.n + ?. =(addy u.owner) + ~& "wrong owner" + %.n + ?. (~(has in challenges) challenge) + ~& "bad challenge" + %.n + =/ note=@uvI + =+ octs=(as-octs:mimes:html (scot %uv challenge)) + %- keccak-256:keccak:crypto + %- as-octs:mimes:html + ;: (cury cat 3) + '\19Ethereum Signed Message:\0a' + (crip (a-co:co p.octs)) + q.octs + == + ?. &(=(20 (met 3 addy)) =(65 (met 3 cock))) + ~& "addy != cock" + %.n + =/ r (cut 3 [33 32] cock) + =/ s (cut 3 [1 32] cock) + =/ v=@ + =+ v=(cut 3 [0 1] cock) + ?+ v 99 + %0 0 + %1 1 + %27 0 + %28 1 + == + ?. |(=(0 v) =(1 v)) + ~& "wrong v" + %.n + =/ xy + (ecdsa-raw-recover:secp256k1:secp:crypto note v r s) + =/ pub :((cury cat 3) y.xy x.xy 0x4) + =/ add (address-from-pub:key:ethereum pub) + =(addy add) + :: + ++ from-tape + |=(h=tape ^-(@ux (scan h ;~(pfix (jest '0x') hex)))) + :: + ++ get-owner + |= who=@p + ^- (unit @ux) + =- ?~ pin=`(unit point:naive)`- + ~ + ?. |(?=(%l1 dominion.u.pin) ?=(%l2 dominion.u.pin)) + ~ + `address.owner.own.u.pin + .^ (unit point:naive) + %gx + %+ en-beam + [our.bowl %azimuth [%da now.bowl]] + /point/(scot %p who)/noun + == + ++ dejs-action + |= jon=json + ^- authorization + =, dejs:format + %. jon + %- ot + :~ [%who (se %p)] + [%secret (se %uv)] + [%address sa] + [%signature sa] + == + -- + ++ enjs-challenge + =, enjs:format + |= chal=@ + ^- json + %- pairs + :~ [%challenge [%s (scot %uv chal)]] + == + ++ self-poke + |= noun=* + ^- (list card:agent:gall) + :~ [%pass /gib %agent [our.bowl dap.bowl] %poke %noun !>(noun)] + == + + :: these are the poke handlers + ++ handle-meta + |= new-challenge=@ ^- ^sessions + =? users.sessions + !(~(has by users.sessions) src.bowl) + (~(put by users.sessions) [src.bowl src.bowl]) + =? challenges.sessions + =(src.bowl (~(got by users.sessions) src.bowl)) + (~(put in challenges.sessions) new-challenge) + + sessions + ++ handle-auth + |= [who=@p src=@p =secret] ^- ^sessions + ~& > "%ustj: Successful authentication of {<src>} as {<who>}." + =. users.sessions (~(put by users.sessions) src who) + =. challenges.sessions (~(del in challenges.sessions) secret) + sessions + +-- diff --git a/lib/naive.hoon b/lib/naive.hoon new file mode 100644 index 0000000..7f46eaf --- /dev/null +++ b/lib/naive.hoon @@ -0,0 +1,926 @@ +/+ tiny +!. +=> => tiny +:: 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 + [effects.u.res state(points (put:orm points.state ship new-point.u.res))] + ^- 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 + :+ ~ [%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) diff --git a/lib/server.hoon b/lib/server.hoon new file mode 100644 index 0000000..74230b4 --- /dev/null +++ b/lib/server.hoon @@ -0,0 +1,179 @@ +=, eyre +|% ++$ request-line + $: [ext=(unit @ta) site=(list @t)] + args=(list [key=@t value=@t]) + == +:: +parse-request-line: take a cord and parse out a url +:: +++ parse-request-line + |= url=@t + ^- request-line + (fall (rush url ;~(plug apat:de-purl:html yque:de-purl:html)) [[~ ~] ~]) +:: +++ manx-to-octs + |= man=manx + ^- octs + (as-octt:mimes:html (en-xml:html man)) +:: +++ json-to-octs + |= jon=json + ^- octs + (as-octs:mimes:html (en:json:html jon)) +:: +++ app + |% + :: + :: +require-authorization: + :: redirect to the login page when unauthenticated + :: otherwise call handler on inbound request + :: + ++ require-authorization + |= $: =inbound-request:eyre + handler=$-(inbound-request:eyre simple-payload:http) + == + ^- simple-payload:http + :: + ?: authenticated.inbound-request + ~! this + ~! +:*handler + (handler inbound-request) + :: + =- [[307 ['location' -]~] ~] + %^ cat 3 + '/~/login?redirect=' + url.request.inbound-request + :: + :: +require-authorization-simple: + :: redirect to the login page when unauthenticated + :: otherwise pass through simple-paylod + :: + ++ require-authorization-simple + |= [=inbound-request:eyre =simple-payload:http] + ^- simple-payload:http + :: + ?: authenticated.inbound-request + ~! this + simple-payload + :: + =- [[307 ['location' -]~] ~] + %^ cat 3 + '/~/login?redirect=' + url.request.inbound-request + :: + ++ give-simple-payload + |= [eyre-id=@ta =simple-payload:http] + ^- (list card:agent:gall) + =/ header-cage + [%http-response-header !>(response-header.simple-payload)] + =/ data-cage + [%http-response-data !>(data.simple-payload)] + :~ [%give %fact ~[/http-response/[eyre-id]] header-cage] + [%give %fact ~[/http-response/[eyre-id]] data-cage] + [%give %kick ~[/http-response/[eyre-id]] ~] + == + -- +++ core + |% + ++ gate + =| opt=@ + |= a=@ opt + :: ++ try gate(opt 5) + ++ try2 + =/ g gate + g(opt 5) + -- +++ gen + |% + :: + ++ max-1-da ['cache-control' 'max-age=86400'] + :: ++ max-1-wk ['cache-control' 'max-age=604800'] + ++ max-1-wk ['cache-control' 'no-cache, no-store, must-revalidate'] + ++ no-cache ['cache-control' 'no-cache, no-store, must-revalidate'] + :: + ++ lol + =| lmao=? + |= a=* %lol + ++ html-response + =| cache=? + |= =octs + ^- simple-payload:http + :_ `octs + [200 [['content-type' 'text/html'] ?:(cache [max-1-wk ~] ~)]] + :: + ++ css-response + =| cache=? + |= =octs + ^- simple-payload:http + :_ `octs + [200 [['content-type' 'text/css'] ?:(cache [max-1-wk ~] ~)]] + :: + ++ js-response + =| cache=? + |= =octs + ^- simple-payload:http + :_ `octs + [200 [['content-type' 'text/javascript'] ?:(cache [max-1-wk ~] ~)]] + :: + ++ png-response + =| cache=? + |= =octs + ^- simple-payload:http + :_ `octs + [200 [['content-type' 'image/png'] ?:(cache [max-1-wk ~] ~)]] + :: + ++ svg-response + =| cache=? + |= =octs + ^- simple-payload:http + :_ `octs + [200 [['content-type' 'image/svg+xml'] ?:(cache [max-1-wk ~] ~)]] + :: + ++ ico-response + |= =octs + ^- simple-payload:http + [[200 [['content-type' 'image/x-icon'] max-1-wk ~]] `octs] + :: + ++ woff2-response + =| cache=? + |= =octs + ^- simple-payload:http + [[200 [['content-type' 'font/woff2'] max-1-wk ~]] `octs] + ++ woff-response + =| cache=? + |= =octs + ^- simple-payload:http + [[200 [['content-type' 'font/woff'] max-1-wk ~]] `octs] + :: + ++ json-response + =| cache=_| + |= =json + ^- simple-payload:http + :_ `(json-to-octs json) + [200 [['content-type' 'application/json'] ?:(cache [max-1-da ~] ~)]] + :: + ++ manx-response + =| cache=_| + |= man=manx + ^- simple-payload:http + :_ `(manx-to-octs man) + [200 [['content-type' 'text/html'] ?:(cache [max-1-da ~] ~)]] + :: + ++ not-found + ^- simple-payload:http + [[404 ~] ~] + :: + ++ login-redirect + |= =request:http + ^- simple-payload:http + =- [[307 ['location' -]~] ~] + %^ cat 3 + '/~/login?redirect=' + url.request + :: + ++ redirect + |= redirect=cord + ^- simple-payload:http + [[303 ['location' redirect]~] ~] + -- +-- diff --git a/lib/sortug.hoon b/lib/sortug.hoon new file mode 100644 index 0000000..e86e163 --- /dev/null +++ b/lib/sortug.hoon @@ -0,0 +1,679 @@ +|% +:: parsing and printing dates +++ dates + |% + ++ pad pad:string + ++ to-htmldate |= d=@da ^- tape + =+ [[* y=@] m=@ [d=@ h=@ mm=@ s=@ f=*]]=(yore d) + =/ ys (scow %ud y) + =/ ms (pad:string (scow %ud m) 2) + =/ ds (pad:string (scow %ud d) 2) + =/ hs (pad:string (scow %ud h) 2) + =/ mins (pad:string (scow %ud mm) 2) + "{ys}-{ms}-{ds}T{hs}:{mins}" + ++ date-to-path + |= d=@da ^- path + =+ [[a y] m [d h mm s f]]=(yore d) + =/ yr (numb:enjs:format y) + ?> ?=(%n -.yr) + /[p.yr]/(scot %ud m)/(scot %ud d) + ++ date-to-tape + |= [d=@da delim=tape] ^- tape + =+ [[a y] m [d h mm s f]]=(yore d) + =/ ys (ud-to-cord:string y) + =/ month (pad "{<m.m>}" 2) + =/ day (pad "{<d.d>}" 2) + "{(trip ys)}{delim}{month}{delim}{day}" + ++ datetime-to-tape + |= [d=@da delim=tape] ^- tape + =+ [[a y] m [d h mm s f]]=(yore d) + =/ ys (ud-to-cord:string y) + =/ month (pad "{<m.m>}" 2) + =/ day (pad "{<d.d>}" 2) + =/ hours (pad "{<h.h>}" 2) + =/ minutes (pad "{<m.mm>}" 2) + =/ seconds (pad "{<s.s>}" 2) + "{(trip ys)}{delim}{month}{delim}{day} {hours}:{minutes}:{seconds}" + ++ time-to-tape + |= d=@da ^- tape + =+ [[a y] m [d h mm s f]]=(yore d) + =/ hours (pad "{<h.h>}" 2) + =/ minutes (pad "{<m.mm>}" 2) + "{hours}:{minutes}" + + -- +++ parsing + |% + :: utils + ++ atom-dots + |= s=@t ^- @ud + =/ no-dots (rush s dem) + ?~ no-dots (rash s dem:ag) u.no-dots + ++ uri-encode + |= t=tape ^- tape + =+ (en-urlt:html t) :: double-encoding because iris decodes shit at some point for some reason + (en-urlt:html -) + :: raw functions used by other functions + ++ white (star gah) + ++ para + |% + ++ eof ;~(less next (easy ~)) + ++ white (mask "\09 ") + ++ blank ;~(plug (star white) (just '\0a')) + ++ hard-wrap (cold ' ' ;~(plug blank (star white))) + ++ one-space (cold ' ' (plus white)) + ++ empty + ;~ pose + ;~(plug blank (plus blank)) + ;~(plug (star white) eof) + ;~(plug blank (star white) eof) + == + ++ para + %+ ifix + [(star white) empty] + %- plus + ;~ less + empty + next + == + -- + ++ trim para:para :: from whom/lib/docu + :: Dates + ++ y (bass 10 (stun 3^4 dit)) + :: ++ m (sear (snug mon:yu) (plus alf)) + ++ d (bass 10 (stun 1^2 dit)) + ++ t :: hours:minutes:secs + :: %+ cook |=([h=@u @ m=@u @ s=@u] ~[h m s]) + :: ;~(plug d col d col d) + ;~(plug d col d) + ++ weekday-3 + ;~ pose + %+ cold 0 (jest 'Sun') + %+ cold 1 (jest 'Mon') + %+ cold 2 (jest 'Tue') + %+ cold 3 (jest 'Wed') + %+ cold 4 (jest 'Thu') + %+ cold 5 (jest 'Fri') + %+ cold 6 (jest 'Sat') + == + ++ monthname-3 + ;~ pose + %+ cold 1 (jest 'Jan') + %+ cold 2 (jest 'Feb') + %+ cold 3 (jest 'Mar') + %+ cold 4 (jest 'Apr') + %+ cold 5 (jest 'May') + %+ cold 6 (jest 'Jun') + %+ cold 7 (jest 'Jul') + %+ cold 8 (jest 'Aug') + %+ cold 9 (jest 'Sep') + %+ cold 10 (jest 'Oct') + %+ cold 11 (jest 'Nov') + %+ cold 12 (jest 'Dec') + == + ++ three-section-time :: hours:minutes:secs + %+ cook |=([h=@u @ m=@u @ s=@u] [h m s]) + ;~(plug d col d col d) + ++ html-datetime + %+ cook |= [y=@ud * m=@ud * d=@ud * h=@ud * min=@ud] + =/ dt *date =. dt dt(y y, m m, d.t d, h.t h, m.t min) + (year dt) + ;~ plug y hep d hep d (just 'T') + t + == + ++ twatter-date + %+ cook |= [w=@ * m=@ * d=@ * [h=@ mn=@ s=@] * y=@] + =| dat=date %- year + dat(y y, m m, t [d h mn s ~]) + ;~ plug + weekday-3 + ace + monthname-3 + ace + d + ace + three-section-time + ;~ plug + ace + lus + y + ace + == + y + == + :: urls + ++ link auri:de-purl:html + ++ youtube + ;~ pfix + ;~ plug + (jest 'https://') + ;~ pose + (jest 'www.youtube.com/watch?v=') + (jest 'youtube.com/watch?v=') + (jest 'youtu.be/') + == + == + ;~ sfix + (star aln) + (star next) + == + == + ++ twatter + ;~ pfix + ;~ plug + (jest 'https://') + ;~ pose + (jest 'x.com/') + (jest 'twitter.com/') + == + (star ;~(less fas next)) + (jest '/status/') + == + ;~ sfix + (star nud) + (star next) + == + == + :: Better scow/slaw + ++ scow + |= [mod=@tas a=@] ^- tape + ?+ mod "" + %s (signed-scow a) + %ud (a-co:co a) + %ux ((x-co:co 0) a) + %uv ((v-co:co 0) a) + %uw ((w-co:co 0) a) + == + ++ signed-scow |= a=@s ^- tape + =/ old (old:si a) + =/ num (scow %ud +.old) + =/ sign=tape ?: -.old "" "-" + "{sign}{num}" + ++ b64 (bass 64 (plus siw:ab)) + ++ b16 (bass 16 (plus six:ab)) + ++ slaw + |= [mod=@tas txt=@t] ^- (unit @) + ?+ mod ~ + %ud (rush txt dem) + %ux (rush txt b16) + %uv (rush txt vum:ag) + %uw (rush txt b64) + == + :: ++ b64 + :: %+ cook + :: |=(a=tape (rap 3 ^-((list @) a))) + :: (star ;~(pose nud low cen hig hep dot sig cab)) + :: Paths + +$ michi (list @t) + ++ stam + %+ sear + |= m=michi + ^- (unit michi) + ?: ?=([~ ~] m) ~ + ?. =(~ (rear m)) `m + ~ + ;~(pfix fas (most fas b64)) + ++ smat + |= m=michi ^- tape + =/ t "/" + |- + ?~ m t + =/ nt "{t}/{(trip i.m)}" + $(m t.m, t nt) + ++ de-comma + %+ sear + |= p=path + ^- (unit path) + ?: ?=([~ ~] p) `~ + ?. =(~ (rear p)) `p + ~ + (most com urs:ab) + ++ de-path + :: modified from apat:de-purl:html + =/ delim ;~(pose fas dot) + %+ cook :: get rid of the last dot and make the extension a part of the path + |= p=path ?~ p p + =/ flopped=path (flop p) + =/ sr=path (rash -.flopped (csplit dot)) + =/ rest=path +.flopped + %- flop %+ welp (flop sr) rest + ;~(pfix fas (more fas smeg:de-purl:html)) + + :: splitting + ++ csplit |* =rule + (more rule (cook crip (star ;~(less rule next)))) + ++ split |* =rule + (more rule (star ;~(less rule next))) + ++ dinfix |* [pf=rule sf=rule] + =/ neither (star ;~(less ;~(pose pf sf) next)) + ;~(pfix pf ;~(sfix neither sf)) + :: infixes + ++ infix + |* =rule + (ifix [rule rule] (star ;~(less rule next))) + ++ infix2 + |* [delim=rule inner=rule] + |= tub=nail + =+ vex=(delim tub) + ?~ q.vex + (fail tub) + =/ but=nail tub + =+ outer=(;~(sfix (plus ;~(less delim next)) delim) q.u.q.vex) + ?~ q.outer + (fail tub) + =+ in=(inner [1 1] p.u.q.outer) + ?~ q.in + (fail tub) + outer(p.u.q p.u.q.in) + + :: this fixes parsing with troon flags + :: :: nest-failing + :: ++ esca :: escaped character + :: =/ qux (bass 16 (stun [4 4] hit)) + :: ;~ pfix bas + :: =* loo + :: =* lip + :: ^- (list (pair @t @)) + :: [b+8 t+9 n+10 f+12 r+13 ~] + :: =* wow `(map @t @)`(malt lip) + :: (sear ~(get by wow) low) + :: =* tuf ;~(pfix (just 'u') (cook tuft qux)) + :: ;~(pose doq fas soq bas loo tuf) + :: == + :: ++ dejson :: parse JSON + :: =/ de de:json:html + :: =. esca.de esca + :: de + -- + :: string utils + ++ string + |% + ++ replace + |= [bit=tape bot=tape =tape] + ^- ^tape + |- + =/ off (find bit tape) + ?~ off tape + =/ clr (oust [(need off) (lent bit)] tape) + $(tape :(weld (scag (need off) clr) bot (slag (need off) clr))) + :: + ++ split + |= [str=tape delim=tape] + ^- (list tape) + (split-rule str (jest (crip delim))) + ++ split-rule + |* [str=tape delim=rule] + ^- (list tape) + %+ fall + (rust str (more delim (star ;~(less delim next)))) + [str ~] + ++ contains + |= [str=tape nedl=tape] + ^- ? + ?~ (find nedl str) | & + ++ trim + |= a=tape + |- ^- tape + ?: ?=([%' ' *] a) + $(a t.a) + (flop a) + ++ number + |= a=@ud ^- tape + ?: =(0 a) "0" + %- flop + |- ^- tape + ?:(=(0 a) ~ [(add '0' (mod a 10)) $(a (div a 10))]) + ++ capitalize + |= a=@t ^- tape + =/ t=(list @t) (trip a) + ?~ t (trip a) + t(i (sub i.t 32)) + ++ enpath + |= str=cord ^- path + =/ allow ;~(pose low nud) + =/ lcase %+ cook + |= a=@t (add 32 a) hig + =/ rul ;~(pose allow lcase) + =/ del ;~(less rul next) + =/ frul (more del (cook crip (star rul))) + (rash str frul) + ++ enkebab |= s=@t (crip (enkebab2 s)) + ++ enkebab2 + |= str=cord ^- tape + =/ allow ;~(pose low nud hep) + =/ kebab (cold '-' next) + =/ lcase %+ cook + |= a=@t (add 32 a) hig + =/ rul ;~(pose allow lcase kebab) + (rash str (star rul)) + ++ enkebab3 + |= str=cord ^- tape + =/ allow ;~(pose low nud hep) + =/ kebab (cold '-' next) + =/ lcase %+ cook + |= a=@t (add 32 a) hig + =/ rul ;~(pose allow lcase unic kebab) + (rash str (star rul)) + ++ unic + %- cook :_ unicode + |= a=@ %- crip (scow:parsing %uw a) + ++ unicode (shim 128 100.000.000) + :: Split string by parsing rule delimiter. + :: ++ enkebab + :: |= str=cord + :: ^- cord + :: ~| str + :: =- (fall - str) + :: %+ rush str + :: =/ name + :: %+ cook + :: |= part=tape + :: ^- tape + :: ?~ part part + :: :- (add i.part 32) + :: t.part + :: ;~(plug hig (star low)) + :: %+ cook + :: |=(a=(list tape) (crip (zing (join "-" a)))) + :: ;~(plug (star low) (star name)) + ++ cut-cord + |= [=cord chars=@ud] + %+ end 3^chars cord + :: + ++ pad + |= [t=tape length=@ud] ^- tape + ?: .=(length (lent t)) t + $(t "0{t}") + :: + ++ ud-to-cord + |= n=@ud ^- @t + %- crip + %- zing (rush (scot %ud n) (more dot (star nud))) + ++ remove + |= [s=@t r=@t] ^- @t + %- crip + %- zing + %+ rush s + %+ more (jest r) + %- star + ;~(less (jest r) next) + :: bitwise stuff + ++ cord-size + |= c=@t + (met 3 c) + ++ concat-cord-list + |= c=(list @t) + (rap 3 c) + ++ cut-cord-2 + |= [c=@t s=@ud e=@ud] + (cut 3 [s e] c) + ++ cfind-index + |= [nedl=@t hay=@t length=@ud case=?] ^- (unit [snip=@t left-amari=@ud right-amari=@ud]) + =/ nlen (met 3 nedl) + =/ hlen (met 3 hay) + ?: (lth hlen nlen) ~ + =? nedl !case + (crass nedl) + :: iterate from index 0 + =/ pos 0 + =/ lim (sub hlen nlen) + |- + :: If our position is further than the length of query + :: it's obviously not gonna happen anymore so return + ?: (gth pos lim) ~ + :: If needle is equal to the [position needle-length] slice of hay then we're good + =/ substring ?: case (cut 3 [pos nlen] hay) (crass (cut 3 [pos nlen] hay)) + ?. .=(nedl substring) $(pos +(pos)) + :: we grab a bigger piece of the cord, starting where + =/ [start-index=@ud end-index=@ud] [pos (add pos nlen)] + :: say it's [150 160] + =/ halfway=@ud (div (sub length nlen) 2) :: that's 45 + =/ start=@ud ?: (gth pos halfway) (sub pos halfway) 0 :: that's 105 + =/ end=@ud ?: (gte (add halfway end-index) hlen) hlen (add halfway end-index) :: 200 + + =/ right-amari (sub halfway (sub end end-index)) :: 5 + =/ left-amari (sub halfway (sub start-index start)) :: 0 + =/ snip=@t (cut 3 [start end] hay) + %- some :+ snip left-amari right-amari + + ++ cfindi + |= [nedl=@t hay=@t case=?] ^- @t + =/ nlen (met 3 nedl) + =/ hlen (met 3 hay) + =| res=@t + ?: (lth hlen nlen) res + =? nedl !case + (crass nedl) + :: iterate from index 0 + =/ pos 0 + =/ lim (sub hlen nlen) + |- + :: If our position is further than the length of query + :: it's obviously not gonna happen anymore so return + ?: (gth pos lim) res + :: If needle is equal to the [position needle-length] slice of hay then we're good + ?: .= nedl + ?: case + (cut 3 [pos nlen] hay) + (crass (cut 3 [pos nlen] hay)) + :: we grab a bigger piece of the cord, starting where + =/ s ?: (lte pos 50) 0 (sub pos 50) + (cut 3 [s 100] hay) + $(pos +(pos)) + ++ cfind + |= [nedl=@t hay=@t case=?] + ^- ? + =/ nlen (met 3 nedl) + =/ hlen (met 3 hay) + ?: (lth hlen nlen) + | + =? nedl !case + (crass nedl) + =/ pos 0 + =/ lim (sub hlen nlen) + |- + ?: (gth pos lim) + | + ?: .= nedl + ?: case + (cut 3 [pos nlen] hay) + (crass (cut 3 [pos nlen] hay)) + & + $(pos +(pos)) + ++ crass + |= text=@t + ^- @t + %^ run + 3 + text + |= dat=@ + ^- @ + ?. &((gth dat 64) (lth dat 91)) + dat + (add dat 32) + + + -- + :: agentio replacement +++ io + |_ =bowl:gall + ++ retrieve + |= =path + =/ bp /gx/(scot %p our.bowl)/[dap.bowl]/(scot %da now.bowl) + .^(* (weld bp (weld path /noun))) + ++ scry + |* [app=@tas =path =mold] + =/ bp /gx/(scot %p our.bowl)/[app]/(scot %da now.bowl) + =/ pat (weld bp (weld path /noun)) + .^(mold pat) + ++ scry2 + |* [app=@tas =path =mold] + =/ bp /gx/(scot %p our.bowl)/[app]/(scot %da now.bowl) + =/ pat (weld bp (weld path /noun)) + %- mole |. .^(mold pat) + ++ scry-pad + |= t=@tas ^- path /(scot %p our.bowl)/[t]/(scot %da now.bowl) + -- + :: esoteric types + ++ types + |% + :: result type + ++ resu + |* =mold + $% [%ok mold] + [%err p=@t] + == + -- + ++ web + |% + ++ images + %- silt :~('png' 'jpg' 'jpeg' 'svg' 'webp') + ++ is-image + |= url=@t ^- ? + =/ u=(unit purl:eyre) (de-purl:html url) + ?~ u .n + =/ ext p.q.u.u + ?~ ext .n + (~(has in images) u.ext) + -- +:: list functions +++ seq + |% + ++ slice + |* [a=(list) count=@ud index=@ud] + =| i=@ud + |- ^+ a + ?~ a ~ + ?: .=(count 0) ~ + ?: (lth i index) $(a t.a, i +(i)) + :- i.a + $(a t.a, i +(i), count (dec count)) + + ++ pick + |* [a=(list) b=@] + =/ top (dec (lent a)) + =/ ind (mod b top) + (snag ind a) + ++ flop :: reverse + |* a=(list) + => .(a (homo a)) + ^+ a + =+ b=`_a`~ + |- + ?~ a b + $(a t.a, b [i.a b]) + :: TODO study these two well + ++ reel + ~/ %reel + |* [a=(list) b=_=>(~ |=([* *] +<+))] + |- ^+ ,.+<+.b + ?~ a + +<+.b + (b i.a $(a t.a)) + ++ roll + ~/ %roll + |* [a=(list) b=_=>(~ |=([* *] +<+))] + |- ^+ ,.+<+.b + ?~ a + +<+.b + $(a t.a, b b(+<+ (b i.a +<+.b))) + ++ snip + |* a=(list) + =/ rev (flop a) + ?~ rev a + (flop t.rev) + ++ fold + |* [a=(list) b=* c=_|=(^ +<+)] + |- ^+ b + ?~ a b + =/ nb (c [i.a b]) + $(a t.a, b nb) + ++ foldi + |* [a=(list) b=* c=_|=(^ +<+)] + =| i=@ud + |- ^+ b + ?~ a b + =/ nb (c i i.a b) + $(a t.a, b nb, i +(i)) + ++ mapi + |* [a=(list) b=gate] + =| i=@ud + => .(a (homo a)) + ^- (list _?>(?=(^ a) (b i i.a))) + |- + ?~ a ~ + :- i=(b i i.a) + t=$(a t.a, i +(i)) + -- +++ js + |% + ++ de + |% + ++ maybe + |* fst=$-(json *) + |= jon=json + ?~ jon ~ (fst jon) + ++ st + |= mol=mold + |= jon=json + ?> ?=([%s *] jon) + %- mol p.jon + ++ ur + |* wit=$-(json *) + |= jon=(unit json) + ?~(jon ~ `(wit u.jon)) + ++ gen + |= jon=json + ?- -.jon + %s p.jon + %n p.jon + %b p.jon + %a (turn p.jon gen) + %o ((om:dejs:format gen) jon) + == + -- + ++ en + |% + ++ bitch %bitch + -- + -- +++ sail + |% + ++ coki-to-string + |= m=(map @t @t) ^- cord + %- crip %- ~(rep by m) + |= [pair=[key=@t value=@t] acc=tape] + "{acc}{(trip key.pair)}={(trip value.pair)}; " + ++ handle-html-form + |= body=(unit octs) ^- (map @t @t) + ?~ body ~ + =/ text q.u.body + =/ clean (remove:string text '%0D') + :: TODO html forms use \0d\0a + :: for carriage return + :: this breaks the markdown parser + =/ parser (more tis (star next)) + =/ res (rush clean yquy:de-purl:html) + ?~ res ~ (malt u.res) + -- +++ search + |% + ++ parse-query + |= query=@t ^- (map @t [query=@t neg=?]) + :: =s \'"machine learning" OR "data science" lmao -filter:links -from:elonmusk since:2023-01-01 until:2023-10-12 lang:en filter:verified\' + ~ + ++ apex + %+ knee ** + |. ~+ + %- star + ;~ pose + (stag %quot quotes) + (stag %white (split:parsing ace)) + (stag %lol rest) + :: next + == +++ rest (plus ;~(less doq next)) +++ quotes (infix:parsing doq) +++ else (star next) + -- +-- diff --git a/lib/tiny.hoon b/lib/tiny.hoon new file mode 100644 index 0000000..f4cbf06 --- /dev/null +++ b/lib/tiny.hoon @@ -0,0 +1,670 @@ +!. +=> %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=@ + ~_ leaf+"decrement-underflow" + ?< =(0 a) + =+ b=0 + |- ^- @ + ?: =(a +(b)) b + $(b +(b)) +:: +++ add :: plus + ~/ %add + |= [a=@ b=@] + ^- @ + ?: =(0 a) b + $(a (dec a), b +(b)) +:: +++ sub :: subtract + ~/ %sub + |= [a=@ b=@] + ~_ leaf+"subtract-underflow" + :: difference + ^- @ + ?: =(0 b) a + $(a (dec a), b (dec b)) +:: +++ mul :: multiply + ~/ %mul + |: [a=`@`1 b=`@`1] + ^- @ + =+ c=0 + |- + ?: =(0 a) c + $(a (dec a), c (add b c)) +:: +++ div :: divide + ~/ %div + |: [a=`@`1 b=`@`1] + ^- @ + ~_ 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] + ^- [p=@ q=@] + [(div a b) (mod a b)] +:: +++ mod :: modulus + ~/ %mod + |: [a=`@`1 b=`@`1] + ^- @ + ?< =(0 b) + (sub a (mul b (div a b))) +:: +++ bex :: binary exponent + ~/ %bex + |= a=bloq + ^- @ + ?: =(0 a) 1 + (mul 2 $(a (dec a))) +:: +++ lsh :: left-shift + ~/ %lsh + |= [a=bite b=@] + =/ [=bloq =step] ?^(a a [a *step]) + (mul b (bex (mul (bex bloq) step))) +:: +++ rsh :: right-shift + ~/ %rsh + |= [a=bite b=@] + =/ [=bloq =step] ?^(a a [a *step]) + (div b (bex (mul (bex bloq) step))) +:: +++ con :: binary or + ~/ %con + |= [a=@ b=@] + =+ [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=@] + =| [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=@] + ^- @ + =+ [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=@] + ^- ? + ?& !=(a b) + |- + ?| =(0 a) + ?& !=(0 b) + $(a (dec a), b (dec b)) + == == == +:: +++ lte :: less or equal + ~/ %lte + |= [a=@ b=@] + |(=(a b) (lth a b)) +:: +++ gte :: greater or equal + ~/ %gte + |= [a=@ b=@] + ^- ? + !(lth a b) +:: +++ gth :: greater + ~/ %gth + |= [a=@ b=@] + ^- ? + !(lte a b) +:: +++ swp :: naive rev bloq order + ~/ %swp + |= [a=bloq b=@] + (rep a (flop (rip a b))) +:: +++ met :: measure + ~/ %met + |= [a=bloq b=@] + ^- @ + =+ c=0 + |- + ?: =(0 b) c + $(b (rsh a b), c +(c)) +:: +++ end :: tail + ~/ %end + |= [a=bite b=@] + =/ [=bloq =step] ?^(a a [a *step]) + (mod b (bex (mul (bex bloq) step))) +:: +++ cat :: concatenate + ~/ %cat + |= [a=bloq b=@ c=@] + (add (lsh [a (met a b)] c) b) +:: +++ cut :: slice + ~/ %cut + |= [a=bloq [b=step c=step] d=@] + (end [a c] (rsh [a b] d)) +:: +++ can :: assemble + ~/ %can + |= [a=bloq b=(list [p=step q=@])] + ^- @ + ?~ 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=@])] + ^- [=step @] + :_ (can a b) + |- + ?~ b + 0 + (add p.i.b $(b t.b)) +:: +++ rep :: assemble fixed + ~/ %rep + |= [a=bite b=(list @)] + =/ [=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=@] + ^- (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=* + |^ ?@ 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=*] + ^- ? + =+ [c=(mug a) d=(mug b)] + ?: =(c d) + (dor a b) + (lth c d) +:: +++ mor :: more mug order + ~/ %mor + |= [a=* b=*] + ^- ? + =+ [c=(mug (mug a)) d=(mug (mug b))] + ?: =(c d) + (dor a b) + (lth c d) +:: +++ dor :: tree order + ~/ %dor + |= [a=* b=*] + ^- ? + ?: =(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] + ^- ? + ?: =(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) + =* node ?>(?=(^ a) n.a) + |@ + ++ get + ~/ %get + |* b=* + => .(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=*] + |- ^+ a + ?~ 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=* + |- ^+ 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)] + |. ^- ? + ?~ 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] + => |% + +$ item [key=key val=val] + -- + :: + ~% %comp +>+ ~ + |= compare=$-([key key] ?) + ~% %core + ~ + |% + :: + ++ apt + ~/ %apt + |= a=(tree item) + =| [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] + ^- (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] + ^- ? + !=(~ (get a b)) + :: + ++ put + ~/ %put + |= [a=(tree item) =key =val] + ^- (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) + |@ + ++ put + ~/ %put + |* b=* + |- ^+ 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=* + |- ^+ 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)] + |. ^- ? + ?~ 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)) + -- +-- diff --git a/mar/bill.hoon b/mar/bill.hoon new file mode 100644 index 0000000..76cef34 --- /dev/null +++ b/mar/bill.hoon @@ -0,0 +1,34 @@ +|_ bil=(list dude:gall) +++ grow + |% + ++ mime `^mime`[/text/x-bill (as-octs:mimes:html hoon)] + ++ noun bil + ++ hoon + ^- @t + |^ (crip (of-wall:format (wrap-lines (spit-duz bil)))) + :: + ++ wrap-lines + |= taz=wall + ^- wall + ?~ taz ["~"]~ + :- (weld ":~ " i.taz) + %- snoc :_ "==" + (turn t.taz |=(t=tape (weld " " t))) + :: + ++ spit-duz + |= duz=(list dude:gall) + ^- wall + (turn duz |=(=dude:gall ['%' (trip dude)])) + -- + ++ txt (to-wain:format hoon) + -- +++ grab + |% + ++ noun (list dude:gall) + ++ mime + |= [=mite len=@ud tex=@] + ~_ tex + !<((list dude:gall) (slap !>(~) (ream tex))) + -- +++ grad %noun +-- diff --git a/mar/hoon.hoon b/mar/hoon.hoon new file mode 100644 index 0000000..428e105 --- /dev/null +++ b/mar/hoon.hoon @@ -0,0 +1,36 @@ +:::: /hoon/hoon/mar + :: +/? 310 +:: +=, eyre +|_ own=@t +:: +++ grow :: convert to + |% + ++ mime `^mime`[/text/x-hoon (as-octs:mimes:html own)] :: convert to %mime + ++ hymn + ;html + ;head + ;title:"Source" + ;script@"//cdnjs.cloudflare.com/ajax/libs/codemirror/4.3.0/codemirror.js"; + ;script@"/lib/syntax/hoon.js"; + ;link(rel "stylesheet", href "//cdnjs.cloudflare.com/ajax/libs/". + "codemirror/4.3.0/codemirror.min.css"); + ;link/"/lib/syntax/codemirror.css"(rel "stylesheet"); + == + ;body + ;textarea#src:"{(trip own)}" + ;script:'CodeMirror.fromTextArea(src, {lineNumbers:true, readOnly:true})' + == + == + ++ txt + (to-wain:format own) + -- +++ grab + |% :: convert from + ++ mime |=([p=mite q=octs] q.q) + ++ noun @t :: clam from %noun + ++ txt of-wain:format + -- +++ grad %txt +-- diff --git a/mar/kelvin.hoon b/mar/kelvin.hoon new file mode 100644 index 0000000..7f1b409 --- /dev/null +++ b/mar/kelvin.hoon @@ -0,0 +1,28 @@ +|_ kal=waft:clay +++ grow + |% + ++ mime `^mime`[/text/x-kelvin (as-octs:mimes:html hoon)] + ++ noun kal + ++ hoon + %+ rap 3 + %+ turn + %+ sort + ~(tap in (waft-to-wefts:clay kal)) + |= [a=weft b=weft] + ?: =(lal.a lal.b) + (gte num.a num.b) + (gte lal.a lal.b) + |= =weft + (rap 3 '[%' (scot %tas lal.weft) ' ' (scot %ud num.weft) ']\0a' ~) + :: + ++ txt (to-wain:format hoon) + -- +++ grab + |% + ++ noun waft:clay + ++ mime + |= [=mite len=@ud tex=@] + (cord-to-waft:clay tex) + -- +++ grad %noun +-- diff --git a/mar/mime.hoon b/mar/mime.hoon new file mode 100644 index 0000000..83b4dae --- /dev/null +++ b/mar/mime.hoon @@ -0,0 +1,32 @@ +:: +:::: /hoon/mime/mar + :: +/? 310 +:: +|_ own=mime +++ grow + ^? + |% + ++ jam `@`q.q.own + -- +:: +++ grab :: convert from + ^? + |% + ++ noun mime :: clam from %noun + ++ tape + |=(a=_"" [/application/x-urb-unknown (as-octt:mimes:html a)]) + -- +++ grad + ^? + |% + ++ form %mime + ++ diff |=(mime +<) + ++ pact |=(mime +<) + ++ join |=([mime mime] `(unit mime)`~) + ++ mash + |= [[ship desk mime] [ship desk mime]] + ^- mime + ~|(%mime-mash !!) + -- +-- diff --git a/mar/noun.hoon b/mar/noun.hoon new file mode 100644 index 0000000..ff5443e --- /dev/null +++ b/mar/noun.hoon @@ -0,0 +1,22 @@ +:: +:::: /hoon/noun/mar + :: +/? 310 +!: +:::: A minimal noun mark +|_ non=* +++ grab |% + ++ noun * + -- +++ grow |% + ++ mime [/application/x-urb-jam (as-octs:mimes:html (jam non))] + -- +++ grad + |% + ++ form %noun + ++ diff |=(* +<) + ++ pact |=(* +<) + ++ join |=([* *] *(unit *)) + ++ mash |=([[ship desk *] [ship desk *]] `*`~|(%noun-mash !!)) + -- +-- diff --git a/mar/ship.hoon b/mar/ship.hoon new file mode 100644 index 0000000..176bcad --- /dev/null +++ b/mar/ship.hoon @@ -0,0 +1,20 @@ +|_ s=ship +++ grad %noun +++ grow + |% + ++ noun s + ++ json s+(scot %p s) + ++ mime + ^- ^mime + [/text/x-ship (as-octt:mimes:html (scow %p s))] + + -- +++ grab + |% + ++ noun ship + ++ json (su:dejs:format ;~(pfix sig fed:ag)) + ++ mime + |= [=mite len=@ tex=@] + (slav %p (snag 0 (to-wain:format tex))) + -- +-- diff --git a/sur/zodiac.hoon b/sur/zodiac.hoon new file mode 100644 index 0000000..b71eae9 --- /dev/null +++ b/sur/zodiac.hoon @@ -0,0 +1,7 @@ +/+ metalib=metamask +|% ++$ versioned-state + $: %0 + sessions=sess:metalib +== +-- diff --git a/sys.kelvin b/sys.kelvin new file mode 100644 index 0000000..1ec239e --- /dev/null +++ b/sys.kelvin @@ -0,0 +1 @@ +[%zuse 410] diff --git a/web/index.hoon b/web/index.hoon new file mode 100644 index 0000000..9aede2e --- /dev/null +++ b/web/index.hoon @@ -0,0 +1,465 @@ +|_ bowl:gall +++ auth-styling + ''' + @import url("https://rsms.me/inter/inter.css"); + @font-face { + font-family: "Source Code Pro"; + src: url("https://storage.googleapis.com/media.urbit.org/fonts/scp-regular.woff"); + font-weight: 400; + font-display: swap; + } + :root { + --red-soft: #FFEFEC; + --red: #FF6240; + --gray-100: #E5E5E5; + --gray-400: #999999; + --gray-800: #333333; + --white: #FFFFFF; + } + html { + font-family: Inter, sans-serif; + height: 100%; + margin: 0; + width: 100%; + background: var(--white); + color: var(--gray-800); + -webkit-font-smoothing: antialiased; + line-height: 1.5; + font-size: 16px; + font-weight: 600; + display: flex; + flex-flow: row nowrap; + justify-content: center; + } + body { + display: flex; + flex-flow: column nowrap; + justify-content: center; + max-width: 300px; + padding: 1rem; + width: 100%; + } + body.local #eauth, + body.eauth #local { + display: none; + min-height: 100%; + } + #eauth input { + /*NOTE dumb hack to get approx equal height with #local */ + margin-bottom: 15px; + } + body nav { + background: var(--gray-100); + border-radius: 2rem; + display: flex; + justify-content: space-around; + overflow: hidden; + margin-bottom: 1rem; + } + body nav div { + width: 50%; + padding: 0.5rem 1rem; + text-align: center; + cursor: pointer; + } + body.local nav div.local, + body.eauth nav div.eauth { + background: var(--gray-800); + color: var(--white); + cursor: default; + } + nav div.local { + border-right: none; + border-top-right-radius: 0; + border-bottom-right-radius: 0; + } + nav div.eauth { + border-left: none; + border-top-left-radius: 0; + border-bottom-left-radius: 0; + } + body > *, + form > input { + width: 100%; + } + form { + display: flex; + flex-flow: column; + align-items: flex-start; + } + input { + background: var(--gray-100); + border: 2px solid transparent; + padding: 0.5rem; + border-radius: 0.5rem; + font-size: inherit; + color: var(--gray-800); + box-shadow: none; + width: 100%; + } + input:disabled { + background: var(--gray-100); + color: var(--gray-400); + } + input:focus { + outline: none; + background: var(--white); + border-color: var(--gray-400); + } + input:invalid:not(:focus) { + background: var(--red-soft); + border-color: var(--red); + outline: none; + color: var(--red); + } + button[type=submit] { + margin-top: 1rem; + } + button[type=submit], a.button { + font-size: 1rem; + padding: 0.5rem 1rem; + border-radius: 0.5rem; + background: var(--gray-800); + color: var(--white); + border: none; + font-weight: 600; + text-decoration: none; + } + input:invalid ~ button[type=submit] { + border-color: currentColor; + background: var(--gray-100); + color: var(--gray-400); + pointer-events: none; + } + span.guest, span.guest a { + color: var(--gray-400); + } + span.failed { + display: flex; + flex-flow: row nowrap; + height: 1rem; + align-items: center; + margin-top: 0.875rem; + color: var(--red); + } + span.failed svg { + height: 1rem; + margin-right: 0.25rem; + } + span.failed path { + fill: transparent; + stroke-width: 2px; + stroke-linecap: round; + stroke: currentColor; + } + .mono { + font-family: 'Source Code Pro', monospace; + } + @media all and (prefers-color-scheme: dark) { + :root { + --white: #000000; + --gray-800: #E5E5E5; + --gray-400: #808080; + --gray-100: #333333; + --red-soft: #7F1D1D; + } + } + @media screen and (min-width: 30em) { + html { + font-size: 14px; + } + } + ''' +++ favicon %+ + weld "<svg width='10' height='10' viewBox='0 0 10 10' xmlns='http://www.w3.org/2000/svg'>" + "<circle r='3.09' cx='5' cy='5' /></svg>" +++ landscape ^- manx +=/ eauth=(unit ?) [~ %|] +=/ failed=? .n +=/ identity=identity:eyre [%ours ~] +=/ redirect-url=(unit @t) ~ +=/ redirect-str ?~(redirect-url "" (trip u.redirect-url)) + ;html + ;head + ;meta(charset "utf-8"); + ;meta(name "viewport", content "width=device-width, initial-scale=1, shrink-to-fit=no"); + ;link(rel "icon", type "image/svg+xml", href (weld "data:image/svg+xml;utf8," favicon)); + ;title:"Urbit" + ;style:"{(trip auth-styling)}" + ;style:"{?^(eauth "" "nav \{ display: none; }")}" + ;script:"our = '{(scow %p our)}';" + ;script:''' + let name, pass; + function setup(isEauth) { + name = document.getElementById('name'); + pass = document.getElementById('pass'); + if (isEauth) goEauth(); else goLocal(); + } + function goLocal() { + document.body.className = 'local'; + pass.focus(); + } + function goEauth() { + document.body.className = 'eauth'; + name.focus(); + } + function doEauth() { + if (name.value == our) { + event.preventDefault(); + goLocal(); + } + } + ''' + == + ;body + =class "{?:(=(`& eauth) "eauth" "local")}" + =onload "setup({?:(=(`& eauth) "true" "false")})" + ;div#local + ;p:"Urbit ID" + ;input(value "{(scow %p our)}", disabled "true", class "mono"); + ;+ ?: =(%ours -.identity) + ;div + ;p:"Already authenticated" + ;a.button/"{(trip (fall redirect-url '/'))}":"Continue" + == + ;form(action "/~/login", method "post", enctype "application/x-www-form-urlencoded") + ;p:"Access Key" + ;input + =type "password" + =name "password" + =id "pass" + =placeholder "sampel-ticlyt-migfun-falmel" + =class "mono" + =required "true" + =minlength "27" + =maxlength "27" + =pattern "((?:[a-z]\{6}-)\{3}(?:[a-z]\{6}))"; + ;input(type "hidden", name "redirect", value redirect-str); + ;+ ?. failed ;span; + ;span.failed + ;svg(xmlns "http://www.w3.org/2000/svg", viewBox "0 0 16 16") + ;path(d "m8 8 4-4M8 8 4 4m4 4-4 4m4-4 4 4"); + == + Key is incorrect + == + ;button(type "submit"):"Continue" + == + == + ;div#eauth + ;form(action "/~/login", method "post", onsubmit "return doEauth()") + ;p:"Urbit ID Metamask Login" + ;input.mono + =name "name" + =id "name" + =placeholder "{(scow %p our)}" + =required "true" + =minlength "4" + =maxlength "57" + =pattern "~((([a-z]\{6})\{1,2}-\{0,2})+|[a-z]\{3})"; + ;p + ; You will be redirected to your own web interface to authorize + ; logging in to + ;span.mono:"{(scow %p our)}" + ; . + == + ;input(type "hidden", name "redirect", value redirect-str); + ;button(name "eauth", type "submit"):"Continue" + == + == + ;* ?: ?=(%ours -.identity) ~ + =+ as="proceed as{?:(?=(%fake -.identity) " guest" "")}" + ;+ ;span.guest.mono + ; Or try to + ;a/"{(trip (fall redirect-url '/'))}":"{as}" + ; . + == + == + ;script:''' + var failSpan = document.querySelector('.failed'); + if (failSpan) { + document.querySelector("input[type=password]") + .addEventListener('keyup', function (event) { + failSpan.style.display = 'none'; + }); + } + ''' + == +++ $ +=/ redirect-str "/forum" +;html + ;head + ;meta(charset "utf-8"); + ;meta(name "viewport", content "width=device-width, initial-scale=1, shrink-to-fit=no"); + ;link(rel "icon", type "image/svg+xml", href (weld "data:image/svg+xml;utf8," favicon)); + == + ;body + ;main#login-page.white + ;h1.tc:"Login" + ;form#form(action "/~/login", method "POST") + ;h2.tc: Urbit OS (Azimuth via Arvo) + ;input.mono(type "text") + =name "name" + =id "name" + =placeholder "~sampel-palnet" + =required "true" + =minlength "4" + =maxlength "14" + =pattern "~((([a-z]\{6})\{1,2}-\{0,2})+|[a-z]\{3})"; + ;input(type "hidden", name "redirect", value redirect-str); + ;button(name "eauth", type "submit"):"Login via Ship »" + == + ;button(id "mauth"):"Login via 🦊MetaMask »" + ;script(type "module"):"{metamask-script}" + :: ;script(type "importmap"):"{import-script}" + ;div(id "wallet-points"); + ;div(id "spinner"); + ;h2.tc: Join the Urbit Network + ;div.tc.nudge + ;a.button/"https://redhorizon.com/join/2d55b768-a5f4-45cf-a4e5-a4302e05a1f9":"Get Urbit ID »" + ;p:"If you don't have an Urbit ID, get one for free from Red Horizon." + == + == + == +== +++ import-script + ^~ + %- trip +''' + {"imports": { + "ethers": "/node_modules/ethers/" + }} +''' +++ metamask-script + ^~ + %- trip +''' + import { ethers } from "https://cdnjs.cloudflare.com/ajax/libs/ethers/6.7.0/ethers.min.js"; + + + const AZIMUTH_ADDRESS = "0x223c067F8CF28ae173EE5CafEa60cA44C335fecB"; + const AZIMUTH_ABI_MINI = [{ + "constant": true, + "inputs": [{ "name": "_whose", "type": "address" }], + "name": "getOwnedPoints", + "outputs": [{ "name": "ownedPoints", "type": "uint32[]" }], + "payable": false, + "stateMutability": "view", + "type": "function" + }]; + + window.addEventListener("DOMContentLoaded", () => { + + const spinner = document.getElementById("spinner"); + const pointsDiv = document.getElementById("wallet-points"); + const metamaskButton = document.getElementById("mauth"); + metamaskButton.addEventListener("click", (event) => { + event.preventDefault(); // Prevent the form from submitting the default way + metamaskButton.disabled = true; + getProvider().then(provider => { + getPoints(provider).then(points => { + console.log({points}) + points.forEach(point => { + const div = document.createElement("div"); + div.innerText = `${point}`; + div.addEventListener("click", e => { + if (spinner.innerText) return + spinner.innerText = "Logging in..." + metamaskLogin(provider.address, point).then(res => { + spinner.innerText = `${res}` + }) + }) + pointsDiv.appendChild(div); + }) + // why doesn't this work wtf + // for (const points of points){ + // console.log({point}) + // } + + }).catch(e => { + metamaskButton.disabled = false; + }) + }) + }); + }); + + async function fetchSecret() { + try { + const response = await fetch('/forum/metamask'); + if (response.ok) { + const data = await response.json(); + return data.challenge; + } else { + throw new Error('Failed to retrieve secret'); + } + } catch (error) { + console.error('Error fetching secret:', error); + } + } + + + async function getProvider(){ + if (typeof window.ethereum !== 'undefined') { + try { + const accounts = await window.ethereum.request({ method: "eth_requestAccounts" }); + const account = accounts[0]; + console.log("logged with metamask on account", account); + const provider = new ethers.BrowserProvider(window.ethereum) + const t1 = await provider.getBalance(account) + console.log({t1}) + const signer = await provider.getSigner(); + console.log({provider, signer}) + return signer + + } catch (error) { + alert("MetaMask initialization failed"); + } + } else { + alert("MetaMask is not installed. Please install it to continue."); + } + + } + + async function metamaskLogin(account, point){ + // Fetch the secret from the server + const secret = await fetchSecret(); + console.log({secret}); + const signature = await window.ethereum.request({ + method: "personal_sign", + params: [secret, account], + }); + + const response = await fetch('/forum/auth', { + method: 'POST', + headers: { + 'Content-Type': 'application/json' + }, + body: JSON.stringify({ + who: point, + secret: secret, + address: account, + signature: signature + }), + }); + + if (response.ok) { + // location.reload(); + // window.location.replace('/forum'); + return "done!" + } else { + alert("Login failed. Please try again."); + } + + } + + async function getPoints(provider){ + const address = provider.address; + const contract = new ethers.Contract( + AZIMUTH_ADDRESS, + AZIMUTH_ABI_MINI, + provider, + ); + const res = await contract.getOwnedPoints(address); + return res.toArray(); + } +''' +-- diff --git a/web/router.hoon b/web/router.hoon new file mode 100644 index 0000000..fdb6c43 --- /dev/null +++ b/web/router.hoon @@ -0,0 +1,101 @@ +/- sur=zodiac +/+ server, metamask, sr=sortug +/= login-page /web/index + +|_ [=bowl:gall eyre-id=@ta req=inbound-request:eyre state=versioned-state:sur] + +++ session-timeout ~d300 +++ session-cookie-string + |= [session=@uv extend=?] + ^- @t + %- crip + =; max-age=tape + :: "urbauth-{(scow %p src.bowl)}={(scow %uv session)}; Path=/; Max-Age={max-age}" + "ucm-{(scow %p src.bowl)}={(scow %uv session)}; Path=/; Max-Age={max-age}" + %+ scow:parsing:sr %ud + ?. extend 0 + (div (msec:milly session-timeout) 1.000) + +++ get-file-at + |= [base=path file=path ext=@ta] + ^- (unit octs) + =/ =path + :* (scot %p our.bowl) + q.byk.bowl + (scot %da now.bowl) + (snoc (weld base file) ext) + == + ?. .^(? %cu path) ~ + %- some + %- as-octs:mimes:html + .^(@ %cx path) + +++ handle-get-request + |= [headers=header-list:http request-line:server] + ^- simple-payload:http + ?~ ext $(ext `%html, site [%index ~]) + ?: ?=([%zodiac *] site) $(site +.site) + :: serve dynamic session.js + :: + ?: =([/session `%js] [site ext]) + %- js-response:gen:server + %- as-octt:mimes:html + """ + window.ship = '{(scow %p src.bowl)}'; + """ + =/ file=(unit octs) + (get-file-at /web site u.ext) + ?~ file ~& "file not found" not-found:gen:server + ?+ u.ext not-found:gen:server + %html (html-response:gen:server u.file) + %js (js-response:gen:server u.file) + %css (css-response:gen:server u.file) + %png (png-response:gen:server u.file) + %woff (woff-response:gen:server u.file) + %woff2 (woff2-response:gen:server u.file) + == + + +++ ebail + ^- (list card:agent:gall) + (send-response pbail) +++ egive + |= pl=simple-payload:http + ^- (list card:agent:gall) + (send-response pl) +++ pbail + %- html-response:gen:server + %- manx-to-octs:server + manx-bail +++ manx-bail ^- manx ;div:"404" +++ manx-payload + |= =manx + ^- simple-payload:http + %- html-response:gen:server + %- manx-to-octs:server manx + +++ send-response + |= =simple-payload:http + =/ cookie ['set-cookie' (session-cookie-string 0vublog .y)] + =. headers.response-header.simple-payload + [cookie headers.response-header.simple-payload] + %+ give-simple-payload:app:server eyre-id simple-payload + + +++ route + =/ metalib ~(. metamask [sessions.state bowl]) + =/ rl (parse-request-line:server url.request.req) + =/ sitepath=path /[(head site.rl)] + =/ pat=(pole knot) site.rl + ?+ pat ebail + [%zodiac %metamask rest=*] (serve-metamask-challenge:metalib eyre-id) + [%zodiac %auth rest=*] (process-metamask-auth:metalib eyre-id body.request.req) + [%zodiac ~] (send-response (manx-payload (login-page bowl))) + :: [site=@t *] (send-response (handle-get-request header-list.request.req rl)) + == + +++ eyre-binding-card +|= =path + ~& > adding-binding=[path dap.bowl] + [%pass /eyre/connect %arvo %e %connect [~ path] dap.bowl] +-- |