mirror of
https://github.com/urbit/shrub.git
synced 2024-12-30 07:35:19 +03:00
676a8ee6a6
This changes Pass to decode the Ed.Point directly in the type, instead of having the packed Atom representation or raw ByteStrings. Added conversion quickchecks and also decoded data off the Ethereum contracts.
238 lines
7.3 KiB
Haskell
238 lines
7.3 KiB
Haskell
{-# OPTIONS_GHC -Wwarn #-}
|
|
module Vere.Dawn where
|
|
|
|
import Arvo.Common
|
|
import Arvo.Event hiding (Address)
|
|
import Azimuth.Azimuth
|
|
import UrbitPrelude hiding (Call, rights, to)
|
|
|
|
import Data.Solidity.Abi.Codec (encode)
|
|
import Network.Ethereum.Account
|
|
import Network.Ethereum.Api.Eth
|
|
import Network.Ethereum.Api.Provider
|
|
import Network.Ethereum.Api.Types hiding (blockNumber)
|
|
import Network.Ethereum.Web3
|
|
|
|
|
|
import Data.Text (splitOn)
|
|
|
|
import qualified Crypto.ECC.Edwards25519 as Ed
|
|
import qualified Crypto.Error as Ed
|
|
import qualified Data.ByteArray as BA
|
|
import qualified Data.Map.Strict as M
|
|
import qualified Network.Ethereum.Ens as Ens
|
|
import qualified Urbit.Ob as Ob
|
|
|
|
{-TODOs:
|
|
|
|
- Dawn takes a NounMap instead of a Map. Need a conversion function.
|
|
|
|
- The Haskell Dawn structure as it exists right now isn't right? It can't
|
|
parse a real %dawn event in the event browser.
|
|
|
|
-}
|
|
|
|
|
|
-- During boot, use the infura provider
|
|
provider = HttpProvider
|
|
"https://mainnet.infura.io/v3/196a7f37c7d54211b4a07904ec73ad87"
|
|
|
|
|
|
--azimuthContract = "0x223c067F8CF28ae173EE5CafEa60cA44C335fecB"
|
|
|
|
-- Conversion Utilities --------------------------------------------------------
|
|
|
|
bsToAtom :: ByteString -> Atom
|
|
bsToAtom x = x ^. from atomBytes
|
|
|
|
-- Takes the web3's bytes representation and changes the endianness.
|
|
bytes32ToBS :: BytesN 32 -> ByteString
|
|
bytes32ToBS = reverse . BA.pack . BA.unpack
|
|
|
|
bytes32ToAtom :: BytesN 32 -> Atom
|
|
bytes32ToAtom = bsToAtom . bytes32ToBS
|
|
|
|
-- web3 doesn't export unAddress.
|
|
addressToBS :: Address -> ByteString
|
|
addressToBS = reverse . encode
|
|
|
|
addressToAtom = bsToAtom . addressToBS
|
|
|
|
-- A Pass is the encryptionKey and authenticationKey concatenated together.
|
|
passFromEth :: BytesN 32 -> BytesN 32 -> UIntN 32 -> Pass
|
|
passFromEth enc aut sut | sut /= 1 = error "Invalid crypto suite number"
|
|
passFromEth enc aut sut = Pass (decode enc) (decode aut)
|
|
where
|
|
decode = Ed.throwCryptoError . Ed.pointDecode . bytes32ToBS
|
|
|
|
clanFromShip :: Ship -> Ob.Class
|
|
clanFromShip = Ob.clan . Ob.patp . fromIntegral
|
|
|
|
shipSein :: Ship -> Ship
|
|
shipSein = Ship . fromIntegral . Ob.fromPatp . Ob.sein . Ob.patp . fromIntegral
|
|
|
|
|
|
|
|
|
|
-- Data Validation -------------------------------------------------------------
|
|
|
|
-- for =(who.seed `@`fix:ex:cub)
|
|
getFingerprintFromKey :: Ring -> Atom
|
|
getFingerprintFromKey = undefined
|
|
|
|
-- getPassFromKey :: Ring -> Pass
|
|
-- getPassFromKey (Ring crypt sign) = (Pass pubCrypt pubSign)
|
|
-- where
|
|
-- pubCrypt = decode crypt
|
|
-- pubSign = decode sign
|
|
-- decode = Ed.throwCryptoError . Ed.pointDecode
|
|
|
|
-- Validates the keys, life, discontinuity, etc. If everything is ok, return
|
|
-- the sponsoring ship for Seed.
|
|
validateAndGetSponsor :: Seed -> EthPoint -> Either Text Ship
|
|
validateAndGetSponsor (Seed ship life ring mo) EthPoint{..} = do
|
|
let clan = clanFromShip ship
|
|
|
|
case clan of
|
|
Ob.Comet -> do
|
|
-- A comet address is the fingerprint of the keypair
|
|
-- when (ship /= (x ring.seed)) (Left "todo: key mismatch")
|
|
-- A comet can never be breached
|
|
-- when live Left "comet already booted"
|
|
-- TODO: the parent must be launched check?
|
|
Right $ shipSein ship
|
|
|
|
-- When the ship is a moon, the only requirement is that the parent is
|
|
-- launched.
|
|
Ob.Moon -> do
|
|
Left "todo: moon's parent must be launched"
|
|
|
|
-- For Galaxies, Stars and Planets, we do the full checks.
|
|
_ -> case epNet of
|
|
Nothing -> Left "ship not keyed"
|
|
Just (life, pass, contNum, _, _) -> do
|
|
-- when ( /= pass) $ Left "key mismatch"
|
|
pure $ Ship 5
|
|
|
|
|
|
|
|
-- Azimuth Functions -----------------------------------------------------------
|
|
|
|
-- Perform a request to azimuth at a certain block number
|
|
withAzimuth :: Quantity
|
|
-> Address
|
|
-> DefaultAccount Web3 a
|
|
-> Web3 a
|
|
withAzimuth bloq azimuth action =
|
|
withAccount () $
|
|
withParam (to .~ azimuth) $
|
|
withParam (block .~ (BlockWithNumber bloq))
|
|
action
|
|
|
|
-- In the Hoon implementation, the EthPoint structure has space for the deed
|
|
-- information, but it immediately punts on this by bunting the deed structure
|
|
-- instead of making the correct calls. We just do the right thing.
|
|
--
|
|
retrievePoint :: Quantity -> Address -> Int -> Web3 (EthPoint)
|
|
retrievePoint bloq azimuth p =
|
|
withAzimuth bloq azimuth $ do
|
|
(owner, managementProxy, spawnProxy, votingProxy, transferProxy)
|
|
<- rights (fromIntegral p)
|
|
|
|
(encryptionKey,
|
|
authenticationKey,
|
|
hasSponsor,
|
|
active,
|
|
escapeRequested,
|
|
sponsor,
|
|
escapeTo,
|
|
cryptoSuite,
|
|
keyRevision, continuityNum) <- points (fromIntegral p)
|
|
|
|
let escapeState = if escapeRequested
|
|
then Just $ Ship $ fromIntegral escapeTo
|
|
else Nothing
|
|
|
|
let epOwn = (addressToAtom owner,
|
|
addressToAtom managementProxy,
|
|
addressToAtom votingProxy,
|
|
addressToAtom transferProxy)
|
|
|
|
let epNet = if (not active)
|
|
then Nothing
|
|
else Just (
|
|
(fromIntegral keyRevision),
|
|
(passFromEth encryptionKey authenticationKey cryptoSuite),
|
|
(fromIntegral continuityNum),
|
|
(hasSponsor, Ship (fromIntegral sponsor)),
|
|
escapeState
|
|
)
|
|
|
|
let epKid = case (clanFromShip $ Ship $ fromIntegral p) of
|
|
Ob.Galaxy -> Just (addressToAtom spawnProxy, None)
|
|
Ob.Star -> Just (addressToAtom spawnProxy, None)
|
|
_ -> Nothing
|
|
|
|
pure EthPoint{..}
|
|
|
|
-- Retrieves information about all the galaxies from Ethereum.
|
|
retrieveGalaxyTable :: Quantity -> Address -> Web3 (Map Ship (Rift, Life, Pass))
|
|
retrieveGalaxyTable bloq azimuth =
|
|
withAzimuth bloq azimuth $ M.fromList <$> mapM getRow [0..5]
|
|
where
|
|
getRow idx = do
|
|
(encryptionKey, authenticationKey, _, _, _, _, _, cryptoSuite,
|
|
keyRev, continuity) <- points idx
|
|
pure (fromIntegral idx,
|
|
(fromIntegral continuity,
|
|
fromIntegral keyRev,
|
|
(passFromEth encryptionKey authenticationKey cryptoSuite)))
|
|
|
|
-- Reads the three Ames domains from Ethereum.
|
|
readAmesDomains :: Quantity -> Address -> Web3 ([Turf])
|
|
readAmesDomains bloq azimuth =
|
|
withAzimuth bloq azimuth $ mapM getTurf [0..2]
|
|
where
|
|
getTurf idx = do
|
|
str <- dnsDomains idx
|
|
pure $ Turf $ fmap Cord $ reverse $ splitOn "." str
|
|
|
|
{-
|
|
[%dawn seed sponsor galaxies domains block eth-url]
|
|
-}
|
|
|
|
-- Produces either an error or a validated boot event structure.
|
|
dawnVent :: Seed -> RIO e (Either Text Dawn)
|
|
dawnVent (Seed (Ship ship) life ring oaf) = do
|
|
--
|
|
-- Everyone needs the Ethereum node instead of just the galaxies.
|
|
|
|
hs <- runWeb3' provider $ do
|
|
-- Block number (dBloq)
|
|
dBloq <- blockNumber
|
|
print ("boot: eth block: " ++ (show dBloq))
|
|
|
|
azimuth <- withAccount () $ Ens.resolve "azimuth.eth"
|
|
print ("Azimuth: " ++ (show azimuth))
|
|
|
|
-- TODO: We're retrieving point information, but we don't have
|
|
--
|
|
-- TODO: Comets don't go through retrievePoint.
|
|
p <- retrievePoint dBloq azimuth (fromIntegral ship)
|
|
print $ show p
|
|
|
|
-- Retrieve the galaxy table [MUST FIX s/5/255/]
|
|
-- galaxyTable <- retrieveGalaxyTable dBloq azimuth
|
|
-- print $ show galaxyTable
|
|
|
|
-- Read Ames domains [DONE]
|
|
-- dTurf <- readAmesDomains dBloq azimuth
|
|
-- print $ show dTurf
|
|
|
|
pure (dBloq)
|
|
|
|
print $ show hs
|
|
|
|
pure (Left "bad")
|
|
|