mirror of
https://github.com/ilyakooo0/urbit.git
synced 2024-12-15 10:02:47 +03:00
a14b6e06d3
This makes the comet mining code actually work. You can now run king with `new --comet` to mine a new comet and get it on the network. Mining appears to be significantly faster; I've had to wait up to 20 minutes with vere, but I've never needed to wait more than 30 seconds with king.
312 lines
10 KiB
Haskell
312 lines
10 KiB
Haskell
module Vere.Dawn where
|
|
|
|
import Arvo.Common
|
|
import Arvo.Event hiding (Address)
|
|
import UrbitPrelude hiding (Call, rights, to)
|
|
|
|
import Data.Bits (xor)
|
|
import Data.List (nub)
|
|
import Data.Text (splitOn)
|
|
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 Network.HTTP.Client.TLS
|
|
|
|
import qualified Azimuth.Azimuth as AZ
|
|
import qualified Crypto.Hash.SHA256 as SHA256
|
|
import qualified Crypto.Hash.SHA512 as SHA512
|
|
import qualified Crypto.Sign.Ed25519 as Ed
|
|
import qualified Data.Binary as B
|
|
import qualified Data.ByteArray as BA
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.ByteString.Char8 as C
|
|
import qualified Network.Ethereum.Ens as Ens
|
|
import qualified Network.HTTP.Client as C
|
|
import qualified Urbit.Ob as Ob
|
|
|
|
-- During boot, use the infura provider
|
|
provider = HttpProvider
|
|
"https://mainnet.infura.io/v3/196a7f37c7d54211b4a07904ec73ad87"
|
|
|
|
-- Conversion Utilities --------------------------------------------------------
|
|
|
|
-- Takes the web3's bytes representation and changes the endianness.
|
|
bytes32ToBS :: BytesN 32 -> ByteString
|
|
bytes32ToBS = reverse . BA.pack . BA.unpack
|
|
|
|
toBloq :: Quantity -> Bloq
|
|
toBloq = fromIntegral . unQuantity
|
|
|
|
passFromEth :: BytesN 32 -> BytesN 32 -> UIntN 32 -> Pass
|
|
passFromEth enc aut sut | sut /= 1 =
|
|
Pass (Ed.PublicKey mempty) (Ed.PublicKey mempty)
|
|
passFromEth enc aut sut =
|
|
Pass (decode aut) (decode enc)
|
|
where
|
|
decode = Ed.PublicKey . bytes32ToBS
|
|
|
|
clanFromShip :: Ship -> Ob.Class
|
|
clanFromShip = Ob.clan . Ob.patp . fromIntegral
|
|
|
|
shipSein :: Ship -> Ship
|
|
shipSein = Ship . fromIntegral . Ob.fromPatp . Ob.sein . Ob.patp . fromIntegral
|
|
|
|
renderShip :: Ship -> Text
|
|
renderShip = Ob.renderPatp . Ob.patp . fromIntegral
|
|
|
|
-- Data Validation -------------------------------------------------------------
|
|
|
|
-- for =(who.seed `@`fix:ex:cub)
|
|
-- getFingerprintFromKey :: Ring -> Atom
|
|
-- getFingerprintFromKey = undefined
|
|
|
|
-- Derive public key structure from the key derivation seed structure
|
|
ringToPass :: Ring -> Pass
|
|
ringToPass Ring{..} = Pass{..}
|
|
where
|
|
passCrypt = decode ringCrypt
|
|
passSign = decode ringSign
|
|
decode = fst . fromJust . Ed.createKeypairFromSeed_
|
|
fromJust = \case
|
|
Nothing -> error "Invalid seed passed to createKeypairFromSeed"
|
|
Just x -> x
|
|
|
|
-- 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
|
|
|
|
-- Retrieves the EthPoint information for an individual point.
|
|
retrievePoint :: Quantity -> Address -> Ship -> Web3 EthPoint
|
|
retrievePoint bloq azimuth ship =
|
|
withAzimuth bloq azimuth $ do
|
|
(encryptionKey,
|
|
authenticationKey,
|
|
hasSponsor,
|
|
active,
|
|
escapeRequested,
|
|
sponsor,
|
|
escapeTo,
|
|
cryptoSuite,
|
|
keyRevision,
|
|
continuityNum) <- AZ.points (fromIntegral ship)
|
|
|
|
let escapeState = if escapeRequested
|
|
then Just $ Ship $ fromIntegral escapeTo
|
|
else Nothing
|
|
|
|
-- The hoon version also sets this to all 0s and then does nothing with it.
|
|
let epOwn = (0, 0, 0, 0)
|
|
|
|
let epNet = if not active
|
|
then Nothing
|
|
else Just
|
|
( fromIntegral keyRevision
|
|
, passFromEth encryptionKey authenticationKey cryptoSuite
|
|
, fromIntegral continuityNum
|
|
, (hasSponsor, Ship (fromIntegral sponsor))
|
|
, escapeState
|
|
)
|
|
|
|
-- TODO: wtf?
|
|
let epKid = case clanFromShip ship of
|
|
Ob.Galaxy -> Just (0, setToHoonSet mempty)
|
|
Ob.Star -> Just (0, setToHoonSet mempty)
|
|
_ -> 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 $ mapFromList <$> mapM getRow [0..255]
|
|
where
|
|
getRow idx = do
|
|
(encryptionKey, authenticationKey, _, _, _, _, _, cryptoSuite,
|
|
keyRev, continuity) <- AZ.points idx
|
|
pure ( fromIntegral idx
|
|
, ( fromIntegral continuity
|
|
, fromIntegral keyRev
|
|
, passFromEth encryptionKey authenticationKey cryptoSuite
|
|
)
|
|
)
|
|
|
|
-- Reads the three Ames domains from Ethereum, removing duplicates
|
|
readAmesDomains :: Quantity -> Address -> Web3 [Turf]
|
|
readAmesDomains bloq azimuth =
|
|
withAzimuth bloq azimuth $ nub <$> mapM getTurf [0..2]
|
|
where
|
|
getTurf idx =
|
|
Turf . fmap Cord . reverse . splitOn "." <$> AZ.dnsDomains idx
|
|
|
|
|
|
validateShipAndGetImmediateSponsor :: Quantity -> Address -> Seed -> Web3 Ship
|
|
validateShipAndGetImmediateSponsor block azimuth (Seed ship life ring oaf) =
|
|
case clanFromShip ship of
|
|
Ob.Comet -> validateComet
|
|
Ob.Moon -> validateMoon
|
|
_ -> validateRest
|
|
where
|
|
validateComet = do
|
|
-- A comet address is the fingerprint of the keypair
|
|
let shipFromPass = cometFingerprint $ ringToPass ring
|
|
when (ship /= shipFromPass) $
|
|
fail ("comet name doesn't match fingerprint " ++ show ship ++ " vs " ++
|
|
show shipFromPass)
|
|
when (life /= 1) $
|
|
fail ("comet can never be re-keyed")
|
|
pure (shipSein ship)
|
|
|
|
validateMoon = do
|
|
-- TODO: The current code in zuse does nothing, but we should be able to
|
|
-- try to validate the oath against the current as exists planet on
|
|
-- chain.
|
|
pure $ shipSein ship
|
|
|
|
validateRest = do
|
|
putStrLn ("boot: retrieving " ++ renderShip ship ++ "'s public keys")
|
|
|
|
whoP <- retrievePoint block azimuth ship
|
|
case epNet whoP of
|
|
Nothing -> fail "ship not keyed"
|
|
Just (netLife, pass, contNum, (hasSponsor, who), _) -> do
|
|
when (netLife /= life) $
|
|
fail ("keyfile life mismatch; keyfile claims life " ++
|
|
show life ++ ", but Azimuth claims life " ++
|
|
show netLife)
|
|
when ((ringToPass ring) /= pass) $
|
|
fail "keyfile does not match blockchain"
|
|
-- TODO: The hoon code does a breach check, but the C code never
|
|
-- supplies the data necessary for it to function.
|
|
pure who
|
|
|
|
|
|
-- Walk through the sponsorship chain retrieving the actual sponsorship chain
|
|
-- as it exists on Ethereum.
|
|
getSponsorshipChain :: Quantity -> Address -> Ship -> Web3 [(Ship,EthPoint)]
|
|
getSponsorshipChain block azimuth = loop
|
|
where
|
|
loop ship = do
|
|
putStrLn ("boot: retrieving keys for sponsor " ++ renderShip ship)
|
|
ethPoint <- retrievePoint block azimuth ship
|
|
|
|
case (clanFromShip ship, epNet ethPoint) of
|
|
(Ob.Comet, _) -> fail "Comets cannot be sponsors"
|
|
(Ob.Moon, _) -> fail "Moons cannot be sponsors"
|
|
|
|
(Ob.Galaxy, Nothing) ->
|
|
fail $ unpack ("Galaxy " ++ renderShip ship ++ " not booted")
|
|
|
|
(Ob.Galaxy, Just _) -> pure [(ship, ethPoint)]
|
|
|
|
(_, Nothing) ->
|
|
fail $ unpack ("Ship " ++ renderShip ship ++ " not booted")
|
|
|
|
(_, Just (_, _, _, (has, sponsor), _)) -> do
|
|
case has of
|
|
False -> fail $ unpack ("Ship " ++ renderShip ship ++
|
|
" has no sponsor")
|
|
True -> do
|
|
chain <- loop sponsor
|
|
pure $ chain ++ [(ship, ethPoint)]
|
|
|
|
|
|
-- Produces either an error or a validated boot event structure.
|
|
dawnVent :: Seed -> RIO e (Either Text Dawn)
|
|
dawnVent dSeed@(Seed ship life ring oaf) = do
|
|
ret <- runWeb3' provider $ do
|
|
block <- blockNumber
|
|
putStrLn ("boot: ethereum block #" ++ tshow block)
|
|
|
|
putStrLn "boot: retrieving azimuth contract"
|
|
azimuth <- withAccount () $ Ens.resolve "azimuth.eth"
|
|
|
|
immediateSponsor <- validateShipAndGetImmediateSponsor block azimuth dSeed
|
|
dSponsor <- getSponsorshipChain block azimuth immediateSponsor
|
|
|
|
putStrLn "boot: retrieving galaxy table"
|
|
dCzar <- mapToHoonMap <$> retrieveGalaxyTable block azimuth
|
|
|
|
putStrLn "boot: retrieving network domains"
|
|
dTurf <- readAmesDomains block azimuth
|
|
|
|
let dBloq = toBloq block
|
|
let dNode = Nothing
|
|
pure $ MkDawn{..}
|
|
|
|
case ret of
|
|
Left x -> pure $ Left $ tshow x
|
|
Right y -> pure $ Right y
|
|
|
|
|
|
dawnCometList :: RIO e [Ship]
|
|
dawnCometList = do
|
|
-- Get the jamfile with the list of stars accepting comets right now.
|
|
manager <- io $ C.newManager tlsManagerSettings
|
|
request <- io $ C.parseRequest "https://bootstrap.urbit.org/comet-stars.jam"
|
|
response <- io $ C.httpLbs (C.setRequestCheckStatus request) manager
|
|
let body = toStrict $ C.responseBody response
|
|
|
|
noun <- cueBS body & either throwIO pure
|
|
fromNounErr noun & either (throwIO . uncurry ParseErr) pure
|
|
|
|
|
|
-- Comet Mining ----------------------------------------------------------------
|
|
|
|
mix :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
|
mix a b = BS.pack $ loop (BS.unpack a) (BS.unpack b)
|
|
where
|
|
loop [] [] = []
|
|
loop a [] = a
|
|
loop [] b = b
|
|
loop (x:xs) (y:ys) = (xor x y) : loop xs ys
|
|
|
|
shas :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
|
shas salt = SHA256.hash . mix salt . SHA256.hash
|
|
|
|
shaf :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
|
shaf salt ruz = (mix a b)
|
|
where
|
|
haz = shas salt ruz
|
|
a = (take 16 haz)
|
|
b = (drop 16 haz)
|
|
|
|
cometFingerprintBS :: Pass -> ByteString
|
|
cometFingerprintBS = (shaf $ C.pack "bfig") . passToBS
|
|
|
|
cometFingerprint :: Pass -> Ship
|
|
cometFingerprint = Ship . B.decode . fromStrict . reverse . cometFingerprintBS
|
|
|
|
tryMineComet :: Set Ship -> Word64 -> Maybe Seed
|
|
tryMineComet ships seed =
|
|
if member shipSponsor ships
|
|
then Just $ Seed shipName 1 ring Nothing
|
|
else Nothing
|
|
where
|
|
-- Hash the incoming seed into a 64 bytes.
|
|
baseHash = SHA512.hash $ toStrict $ B.encode seed
|
|
signSeed = (take 32 baseHash)
|
|
ringSeed = (drop 32 baseHash)
|
|
ring = Ring signSeed ringSeed
|
|
pass = ringToPass ring
|
|
shipName = cometFingerprint pass
|
|
shipSponsor = shipSein shipName
|
|
|
|
mineComet :: Set Ship -> Word64 -> Seed
|
|
mineComet ships = loop
|
|
where
|
|
loop eny =
|
|
case (tryMineComet ships eny) of
|
|
Nothing -> loop (eny + 1)
|
|
Just x -> x
|