king dawn: replace web3 usage with hand rolled jsonrpc messages.

This replaces the autogenerated bindings to the Azimuth contracts
which use Network.Web3 with hand rolled json messages. Booting a
ship involved 256 individual galaxy point lookups using web3, while
Vere batched all of that into one JSONRPC message.

With this patch, we also batch everything at each phase into one
JSONRPC batch.
This commit is contained in:
Elliot Glaysher 2020-08-28 16:17:46 -04:00
parent 1e8158b683
commit 4a7e1b2009
2 changed files with 308 additions and 134 deletions

View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -Wno-deprecations #-}
{-| {-|
Use etherium to access PKI information. Use etherium to access PKI information.
-} -}
@ -6,51 +8,45 @@ module Urbit.Vere.Dawn where
import Urbit.Arvo.Common import Urbit.Arvo.Common
import Urbit.Arvo.Event hiding (Address) import Urbit.Arvo.Event hiding (Address)
import Urbit.Prelude hiding (Call, rights, to) import Urbit.Prelude hiding (Call, rights, to, (.=))
import Data.Bits (xor) import Data.Bits (xor)
import Data.List (nub) import Data.List (nub)
import Data.Text (splitOn) import Data.Text (splitOn)
import Network.Ethereum.Account import Data.Aeson
import Network.Ethereum.Api.Eth import Data.HexString
import Network.Ethereum.Api.Provider import Numeric (showHex)
import Network.Ethereum.Api.Types hiding (blockNumber)
import Network.Ethereum.Web3
import Network.HTTP.Client.TLS
import Data.Solidity.Prim.Address (fromHexString)
import qualified Crypto.Hash.SHA256 as SHA256 import qualified Crypto.Hash.SHA256 as SHA256
import qualified Crypto.Hash.SHA512 as SHA512 import qualified Crypto.Hash.SHA512 as SHA512
import qualified Crypto.Sign.Ed25519 as Ed import qualified Crypto.Sign.Ed25519 as Ed
import qualified Data.Binary as B import qualified Data.Binary as B
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.Char8 as C
-- import qualified Network.Ethereum.Ens as Ens
import qualified Network.HTTP.Client as C import qualified Network.HTTP.Client as C
import qualified Urbit.Azimuth as AZ
import qualified Urbit.Ob as Ob import qualified Urbit.Ob as Ob
import qualified Network.HTTP.Client.TLS as TLS
import qualified Network.HTTP.Types as HT
-- During boot, use the infura provider -- During boot, use the infura provider
provider = HttpProvider "http://eth-mainnet.urbit.org:8545" provider = "http://eth-mainnet.urbit.org:8545"
-- The address of the azimuth contract as a string.
azimuthAddr = "0x223c067f8cf28ae173ee5cafea60ca44c335fecb" :: Text
-- Conversion Utilities -------------------------------------------------------- -- Conversion Utilities --------------------------------------------------------
-- Takes the web3's bytes representation and changes the endianness. passFromBS :: ByteString -> ByteString -> ByteString -> Pass
bytes32ToBS :: BytesN 32 -> ByteString passFromBS enc aut sut | bytesAtom sut /= 1 =
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) Pass (Ed.PublicKey mempty) (Ed.PublicKey mempty)
passFromEth enc aut sut = passFromBS enc aut sut =
Pass (decode aut) (decode enc) Pass (decode aut) (decode enc)
where where
decode = Ed.PublicKey . bytes32ToBS decode = Ed.PublicKey
bsToBool :: ByteString -> Bool
bsToBool bs = bytesAtom bs == 1
clanFromShip :: Ship -> Ob.Class clanFromShip :: Ship -> Ob.Class
clanFromShip = Ob.clan . Ob.patp . fromIntegral clanFromShip = Ob.clan . Ob.patp . fromIntegral
@ -61,6 +57,11 @@ shipSein = Ship . fromIntegral . Ob.fromPatp . Ob.sein . Ob.patp . fromIntegral
renderShip :: Ship -> Text renderShip :: Ship -> Text
renderShip = Ob.renderPatp . Ob.patp . fromIntegral renderShip = Ob.renderPatp . Ob.patp . fromIntegral
hexStrToAtom :: Text -> Atom
hexStrToAtom =
bytesAtom . reverse . toBytes . hexString . removePrefix . encodeUtf8
-- Data Validation ------------------------------------------------------------- -- Data Validation -------------------------------------------------------------
-- Derive public key structure from the key derivation seed structure -- Derive public key structure from the key derivation seed structure
@ -74,85 +75,262 @@ ringToPass Ring{..} = Pass{..}
Nothing -> error "Invalid seed passed to createKeypairFromSeed" Nothing -> error "Invalid seed passed to createKeypairFromSeed"
Just x -> x Just x -> x
-- JSONRPC Functions -----------------------------------------------------------
-- The big problem here is that we can't really use the generated web3 wrappers
-- around the azimuth contracts, especially for the galaxy table request. They
-- make multiple rpc invocations per galaxy request (which aren't even
-- batched!), while Vere built a single batched rpc call to fetch the entire
-- galaxy table.
--
-- The included Network.JsonRpc.TinyClient that Network.Web3 embeds can't do
-- batches, so calling that directly is out.
--
-- Network.JSONRPC appears to not like something about the JSON that Infura
-- returns; it's just hanging? Also no documentation.
--
-- So, like with Vere, we roll our own.
dawnSendHTTP endpoint requestData = liftIO do
manager <- C.newManager TLS.tlsManagerSettings
initialRequest <- C.parseRequest endpoint
let request = initialRequest
{ C.method = "POST"
, C.requestBody = C.RequestBodyLBS $ requestData
, C.requestHeaders = [("Accept", "applciation/json"),
("Content-Type", "application/json"),
("Charsets", "utf-8")]
}
response <- C.httpLbs request manager
-- Return body if 200.
let code = HT.statusCode $ C.responseStatus response
case code of
200 -> pure $ Right $ C.responseBody response
x -> pure $ Left x
class RequestMethod m where
getRequestMethod :: m -> Text
data RawResponse = RawResponse
{ rrId :: Int
, rrResult :: Text
}
deriving (Show)
instance FromJSON RawResponse where
parseJSON = withObject "Response" $ \v -> do
rrId <- v .: "id"
rrResult <- v .: "result"
pure RawResponse{..}
-- Given a list of methods and parameters, return a list of decoded responses.
dawnPostRequests :: forall req e resp
. (ToJSON req, RequestMethod req)
=> String
-> (req -> Text -> resp)
-> [req]
-> RIO e [resp]
dawnPostRequests endpoint responseBuilder requests = do
-- Encode our input requests
let requestPayload =
encode $ Array $ fromList $ map toFullRequest $ zip [0..] requests
-- Send to the server
responses <- dawnSendHTTP endpoint requestPayload >>= \case
Left err -> error $ "error fetching " ++ provider ++ ": HTTP " ++ (show err)
Right x -> pure x
-- Get a list of the result texts in the order of the submitted requests
rawSorted <- case decode responses of
Nothing -> error $ "couldn't decode json"
Just x -> pure $ map rrResult $ sortOn rrId x
-- Build the final result structure by calling the passed in builder with the
-- request (some outputs need data from the request sturcture, eitherwise,
-- we'd lean on FromJSON).
let results = map (uncurry responseBuilder) (zip requests rawSorted)
pure results
where
toFullRequest :: (Int, req) -> Value
toFullRequest (id, req) = object [ "jsonrpc" .= ("2.0" :: Text)
, "method" .= getRequestMethod req
, "params" .= req
, "id" .= id
]
-- Azimuth JSON Requests -------------------------------------------------------
-- Simple packing a block number to the text format.
blockNumToStr :: Int -> Text
blockNumToStr bn = pack $ "0x" <> (showHex bn "")
-- Not a full implementation of the Ethereum ABI, but just the ability to call
-- a method by encoded id (like 0x63fa9a87 for `points(uint32)`), and a single
-- UIntN 32 parameter.
encodeCall :: Text -> Int -> Text
encodeCall method idx = method <> leadingZeroes <> renderedNumber
where
renderedNumber = pack $ showHex idx ""
leadingZeroes = replicate (64 - length renderedNumber) '0'
data BlockRequest = BlockRequest
deriving (Show, Eq)
instance RequestMethod BlockRequest where
getRequestMethod BlockRequest = "eth_blockNumber"
instance ToJSON BlockRequest where
toJSON BlockRequest = Array $ fromList []
-- No need to parse, it's already in the format we'll pass as an argument to
-- eth calls which take a block number.
parseBlockRequest :: BlockRequest -> Text -> TextBlockNum
parseBlockRequest br txt = txt
type TextBlockNum = Text
data PointRequest = PointRequest
{ grqHexBlockNum :: TextBlockNum
, grqPointId :: Int
} deriving (Show, Eq)
instance RequestMethod PointRequest where
getRequestMethod PointRequest{..} = "eth_call"
instance ToJSON PointRequest where
toJSON PointRequest{..} =
Array $ fromList [object [ "to" .= azimuthAddr
, "data" .= encodeCall "0x63fa9a87" grqPointId],
String grqHexBlockNum
]
parseAndChunkResultToBS :: Text -> [ByteString]
parseAndChunkResultToBS result =
map reverse $
chunkBytestring 32 $
toBytes $
hexString $
removePrefix $
encodeUtf8 result
-- The incoming result is a text bytestring. We need to take that text, and
-- spit out the parsed data.
--
-- We're sort of lucky here. After removing the front "0x", we can just chop
-- the incoming text string into 10 different 64 character chunks and then
-- parse them as numbers.
parseEthPoint :: PointRequest -> Text -> EthPoint
parseEthPoint PointRequest{..} result = EthPoint{..}
where
[rawEncryptionKey,
rawAuthenticationKey,
rawHasSponsor,
rawActive,
rawEscapeRequested,
rawSponsor,
rawEscapeTo,
rawCryptoSuite,
rawKeyRevision,
rawContinuityNum] = parseAndChunkResultToBS result
escapeState = if bsToBool rawEscapeRequested
then Just $ Ship $ fromIntegral $ bytesAtom rawEscapeTo
else Nothing
-- Vere doesn't set ownership information, neither did the old Dawn.hs
-- implementation.
epOwn = (0, 0, 0, 0)
epNet = if not $ bsToBool rawActive
then Nothing
else Just
( fromIntegral $ bytesAtom rawKeyRevision
, passFromBS rawEncryptionKey rawAuthenticationKey rawCryptoSuite
, fromIntegral $ bytesAtom rawContinuityNum
, (bsToBool rawHasSponsor,
Ship (fromIntegral $ bytesAtom rawSponsor))
, escapeState
)
-- I don't know what this is supposed to be, other than the old Dawn.hs and
-- dawn.c do the same thing.
epKid = case clanFromShip (Ship $ fromIntegral grqPointId) of
Ob.Galaxy -> Just (0, setToHoonSet mempty)
Ob.Star -> Just (0, setToHoonSet mempty)
_ -> Nothing
-- Preprocess data from a point request into the form used in the galaxy table.
parseGalaxyTableEntry :: PointRequest -> Text -> (Ship, (Rift, Life, Pass))
parseGalaxyTableEntry PointRequest{..} result = (ship, (rift, life, pass))
where
[rawEncryptionKey,
rawAuthenticationKey,
_, _, _, _, _,
rawCryptoSuite,
rawKeyRevision,
rawContinuityNum] = parseAndChunkResultToBS result
ship = Ship $ fromIntegral grqPointId
rift = fromIntegral $ bytesAtom rawContinuityNum
life = fromIntegral $ bytesAtom rawKeyRevision
pass = passFromBS rawEncryptionKey rawAuthenticationKey rawCryptoSuite
removePrefix :: ByteString -> ByteString
removePrefix withOhEx
| prefix == "0x" = suffix
| otherwise = error "not prefixed with 0x"
where
(prefix, suffix) = splitAt 2 withOhEx
chunkBytestring :: Int -> ByteString -> [ByteString]
chunkBytestring size bs
| null rest = [cur]
| otherwise = (cur : chunkBytestring size rest)
where
(cur, rest) = splitAt size bs
data TurfRequest = TurfRequest
{ trqHexBlockNum :: TextBlockNum
, trqTurfId :: Int
} deriving (Show, Eq)
instance RequestMethod TurfRequest where
getRequestMethod TurfRequest{..} = "eth_call"
instance ToJSON TurfRequest where
toJSON TurfRequest{..} =
Array $ fromList [object [ "to" .= azimuthAddr
, "data" .= encodeCall "0xeccc8ff1" trqTurfId],
String trqHexBlockNum
]
-- This is another hack instead of a full Ethereum ABI resposne.
parseTurfResponse :: TurfRequest -> Text -> Turf
parseTurfResponse a raw = turf
where
without0x = removePrefix $ encodeUtf8 raw
(_, blRest) = splitAt 64 without0x
(utfLenStr, utfStr) = splitAt 64 blRest
utfLen = fromIntegral $ bytesAtom $ reverse $ toBytes $ hexString utfLenStr
dnsStr = decodeUtf8 $ (BS.take utfLen) $ toBytes $ hexString utfStr
turf = Turf $ fmap Cord $ reverse $ splitOn "." dnsStr
-- Azimuth Functions ----------------------------------------------------------- -- Azimuth Functions -----------------------------------------------------------
-- Perform a request to azimuth at a certain block number retrievePoint :: String -> TextBlockNum -> Ship -> RIO e EthPoint
withAzimuth :: Quantity retrievePoint endpoint block ship =
-> Address dawnPostRequests provider parseEthPoint
-> DefaultAccount Web3 a [(PointRequest block (fromIntegral ship))] >>= \case
-> Web3 a [x] -> pure x
withAzimuth bloq azimuth action = _ -> error "JSON server returned multiple return values."
withAccount () $
withParam (to .~ azimuth) $
withParam (block .~ BlockWithNumber bloq)
action
-- Retrieves the EthPoint information for an individual point. validateShipAndGetSponsor :: String -> TextBlockNum -> Seed -> RIO e Ship
retrievePoint :: Quantity -> Address -> Ship -> Web3 EthPoint validateShipAndGetSponsor endpoint block (Seed ship life ring oaf) =
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 case clanFromShip ship of
Ob.Comet -> validateComet Ob.Comet -> validateComet
Ob.Moon -> validateMoon Ob.Moon -> validateMoon
@ -177,7 +355,7 @@ validateShipAndGetImmediateSponsor block azimuth (Seed ship life ring oaf) =
validateRest = do validateRest = do
putStrLn ("boot: retrieving " ++ renderShip ship ++ "'s public keys") putStrLn ("boot: retrieving " ++ renderShip ship ++ "'s public keys")
whoP <- retrievePoint block azimuth ship whoP <- retrievePoint endpoint block ship
case epNet whoP of case epNet whoP of
Nothing -> fail "ship not keyed" Nothing -> fail "ship not keyed"
Just (netLife, pass, contNum, (hasSponsor, who), _) -> do Just (netLife, pass, contNum, (hasSponsor, who), _) -> do
@ -194,12 +372,12 @@ validateShipAndGetImmediateSponsor block azimuth (Seed ship life ring oaf) =
-- Walk through the sponsorship chain retrieving the actual sponsorship chain -- Walk through the sponsorship chain retrieving the actual sponsorship chain
-- as it exists on Ethereum. -- as it exists on Ethereum.
getSponsorshipChain :: Quantity -> Address -> Ship -> Web3 [(Ship,EthPoint)] getSponsorshipChain :: String -> TextBlockNum -> Ship -> RIO e [(Ship,EthPoint)]
getSponsorshipChain block azimuth = loop getSponsorshipChain endpoint block = loop
where where
loop ship = do loop ship = do
putStrLn ("boot: retrieving keys for sponsor " ++ renderShip ship) putStrLn ("boot: retrieving keys for sponsor " ++ renderShip ship)
ethPoint <- retrievePoint block azimuth ship ethPoint <- retrievePoint endpoint block ship
case (clanFromShip ship, epNet ethPoint) of case (clanFromShip ship, epNet ethPoint) of
(Ob.Comet, _) -> fail "Comets cannot be sponsors" (Ob.Comet, _) -> fail "Comets cannot be sponsors"
@ -217,47 +395,44 @@ getSponsorshipChain block azimuth = loop
chain <- loop sponsor chain <- loop sponsor
pure $ chain ++ [(ship, ethPoint)] pure $ chain ++ [(ship, ethPoint)]
-- Produces either an error or a validated boot event structure. -- Produces either an error or a validated boot event structure.
dawnVent :: Seed -> RIO e (Either Text Dawn) dawnVent :: HasLogFunc e => Seed -> RIO e (Either Text Dawn)
dawnVent dSeed@(Seed ship life ring oaf) = do dawnVent dSeed@(Seed ship life ring oaf) = do
ret <- runWeb3' provider $ do blockResponses
block <- blockNumber <- dawnPostRequests provider parseBlockRequest [BlockRequest]
putStrLn ("boot: ethereum block #" ++ tshow block)
-- TODO: Eventually look up the contract from ENS. Right now, our infura hexStrBlock <- case blockResponses of
-- node is filtering everything except for a very small set of contracts, [num] -> pure num
-- so just hard code the address. x -> error "Unexpected multiple returns from block # request"
--
-- putStrLn "boot: retrieving azimuth contract"
-- azimuth <- withAccount () $ Ens.resolve "azimuth.eth"
let azimuthAddr = "0x223c067f8cf28ae173ee5cafea60ca44c335fecb"
let azimuth = case fromHexString azimuthAddr of
Left _ -> error "Impossible"
Right x -> x
immediateSponsor <- validateShipAndGetImmediateSponsor block azimuth dSeed let dBloq = hexStrToAtom hexStrBlock
dSponsor <- getSponsorshipChain block azimuth immediateSponsor putStrLn ("boot: ethereum block #" ++ tshow dBloq)
putStrLn "boot: retrieving galaxy table" immediateSponsor <- validateShipAndGetSponsor provider hexStrBlock dSeed
dCzar <- mapToHoonMap <$> retrieveGalaxyTable block azimuth dSponsor <- getSponsorshipChain provider hexStrBlock immediateSponsor
putStrLn "boot: retrieving network domains" putStrLn "boot: retrieving galaxy table"
dTurf <- readAmesDomains block azimuth dCzar <- (mapToHoonMap . mapFromList) <$>
(dawnPostRequests provider parseGalaxyTableEntry $
map (PointRequest hexStrBlock) [0..255])
let dBloq = toBloq block putStrLn "boot: retrieving network domains"
let dNode = Nothing dTurf <- nub <$> (dawnPostRequests provider parseTurfResponse $
pure $ MkDawn{..} map (TurfRequest hexStrBlock) [0..2])
case ret of let dNode = Nothing
Left x -> pure $ Left $ tshow x
Right y -> pure $ Right y
-- TODO: Figure out exception handling now. We don't want all the `error`
-- statements in ehre to literally kill the program.
pure $ Right $ MkDawn{..}
-- Comet List ------------------------------------------------------------------
dawnCometList :: RIO e [Ship] dawnCometList :: RIO e [Ship]
dawnCometList = do dawnCometList = do
-- Get the jamfile with the list of stars accepting comets right now. -- Get the jamfile with the list of stars accepting comets right now.
manager <- io $ C.newManager tlsManagerSettings manager <- io $ C.newManager TLS.tlsManagerSettings
request <- io $ C.parseRequest "https://bootstrap.urbit.org/comet-stars.jam" request <- io $ C.parseRequest "https://bootstrap.urbit.org/comet-stars.jam"
response <- io $ C.httpLbs (C.setRequestCheckStatus request) manager response <- io $ C.httpLbs (C.setRequestCheckStatus request) manager
let body = toStrict $ C.responseBody response let body = toStrict $ C.responseBody response

View File

@ -51,6 +51,7 @@ dependencies:
- hashable - hashable
- hashtables - hashtables
- heap - heap
- hexstring
- http-client - http-client
- http-client-tls - http-client-tls
- http-types - http-types
@ -101,7 +102,6 @@ dependencies:
- unliftio-core - unliftio-core
- unordered-containers - unordered-containers
- urbit-atom - urbit-atom
- urbit-azimuth
- urbit-eventlog-lmdb - urbit-eventlog-lmdb
- urbit-hob - urbit-hob
- urbit-noun - urbit-noun
@ -114,7 +114,6 @@ dependencies:
- wai-websockets - wai-websockets
- warp - warp
- warp-tls - warp-tls
- web3
- websockets - websockets
default-extensions: default-extensions: