mirror of
https://github.com/ilyakooo0/urbit.git
synced 2024-12-22 14:21:34 +03:00
490 lines
16 KiB
Haskell
490 lines
16 KiB
Haskell
{-|
|
|
Use L2 to access PKI information.
|
|
-}
|
|
|
|
module Urbit.Vere.Dawn ( dawnVent
|
|
, dawnCometList
|
|
, renderShip
|
|
, mineComet
|
|
-- Used only in testing
|
|
, mix
|
|
, shas
|
|
, shaf
|
|
, deriveCode
|
|
, cometFingerprintBS
|
|
, cometFingerprint
|
|
) where
|
|
|
|
import Urbit.Arvo.Common
|
|
import Urbit.Arvo.Event hiding (Address)
|
|
import Urbit.Prelude hiding (rights, to, (.=))
|
|
|
|
import Prelude (read)
|
|
|
|
import Data.Bits (xor)
|
|
import Data.List (nub)
|
|
import Data.Text (splitOn)
|
|
import Data.Aeson
|
|
import Data.HexString
|
|
|
|
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.ByteString as BS
|
|
import qualified Data.ByteString.Char8 as C
|
|
import qualified Data.ByteString.Lazy as L
|
|
import qualified Network.HTTP.Client as C
|
|
import qualified Urbit.Ob as Ob
|
|
|
|
import qualified Network.HTTP.Client.TLS as TLS
|
|
import qualified Network.HTTP.Types as HT
|
|
|
|
-- Conversion Utilities --------------------------------------------------------
|
|
|
|
passFromBytes :: ByteString -> ByteString -> Int -> Pass
|
|
passFromBytes enc aut sut
|
|
| sut /= 1 = Pass (Ed.PublicKey mempty) (Ed.PublicKey mempty)
|
|
| otherwise = Pass (Ed.PublicKey aut) (Ed.PublicKey enc)
|
|
|
|
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
|
|
|
|
onLeft :: (a -> b) -> Either a c -> Either b c
|
|
onLeft fun = bimap fun id
|
|
|
|
-- Data Validation -------------------------------------------------------------
|
|
|
|
-- 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
|
|
|
|
-- JSONRPC Functions -----------------------------------------------------------
|
|
|
|
-- Our use case here is simple enough.
|
|
-- Network.JSONRPC appeared fragile and has no documentation.
|
|
-- So, like with Vere, we roll our own.
|
|
|
|
dawnSendHTTP :: String -> L.ByteString -> RIO e (Either Int L.ByteString)
|
|
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", "application/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
|
|
_ -> pure $ Left code
|
|
|
|
class RequestMethod m where
|
|
getRequestMethod :: m -> Text
|
|
|
|
data RawResponse r = RawResponse
|
|
{ rrId :: Int
|
|
, rrResult :: r
|
|
}
|
|
deriving (Show)
|
|
|
|
instance FromJSON r => FromJSON (RawResponse r) where
|
|
parseJSON = withObject "Response" $ \v -> do
|
|
rawId <- v .: "id"
|
|
rrResult <- v .: "result"
|
|
let rrId = read rawId
|
|
pure RawResponse{..}
|
|
|
|
|
|
-- Given a list of methods and parameters, return a list of decoded responses.
|
|
dawnPostRequests :: forall req e resp res
|
|
. (ToJSON req, RequestMethod req, FromJSON res)
|
|
=> String
|
|
-> (req -> res -> resp)
|
|
-> [req]
|
|
-> RIO e [resp]
|
|
dawnPostRequests endpoint responseBuilder requests = do
|
|
-- Encode our input requests
|
|
let requestPayload =
|
|
encode $ Array $ fromList $ fmap toFullRequest $ zip [0..] requests
|
|
|
|
-- Send to the server
|
|
responses <- dawnSendHTTP endpoint requestPayload >>= \case
|
|
Left err -> error $ "error fetching " <> endpoint <> ": 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 structure, eitherwise,
|
|
-- we'd lean on FromJSON).
|
|
let results = map (uncurry responseBuilder) (zip requests rawSorted)
|
|
pure results
|
|
|
|
where
|
|
toFullRequest :: (Int, req) -> Value
|
|
toFullRequest (rid, req) = object [ "jsonrpc" .= ("2.0" :: Text)
|
|
, "method" .= getRequestMethod req
|
|
, "params" .= req
|
|
, "id" .= (show rid)
|
|
]
|
|
|
|
-- Azimuth JSON Requests -------------------------------------------------------
|
|
|
|
data PointResponse = PointResponse
|
|
-- NOTE also contains dominion and ownership, but not actually used here
|
|
{ prNetwork :: PointNetwork
|
|
} deriving (Show, Eq, Generic)
|
|
|
|
instance FromJSON PointResponse where
|
|
parseJSON = withObject "PointResponse" $ \o -> do
|
|
prNetwork <- o .: "network"
|
|
pure PointResponse{..}
|
|
|
|
data PointNetwork = PointNetwork
|
|
{ pnKeys :: PointKeys
|
|
, pnSponsor :: PointSponsor
|
|
, pnRift :: ContNum
|
|
} deriving (Show, Eq, Generic)
|
|
|
|
instance FromJSON PointNetwork where
|
|
parseJSON = withObject "PointNetwork" $ \o -> do
|
|
pnKeys <- o .: "keys"
|
|
pnSponsor <- o .: "sponsor"
|
|
pnRift <- o .: "rift"
|
|
pure PointNetwork{..}
|
|
|
|
data PointKeys = PointKeys
|
|
{ pkLife :: Life
|
|
, pkSuite :: Int
|
|
, pkAuth :: ByteString
|
|
, pkCrypt :: ByteString
|
|
} deriving (Show, Eq, Generic)
|
|
|
|
instance FromJSON PointKeys where
|
|
parseJSON = withObject "PointKeys" $ \o -> do
|
|
pkLife <- o .: "life"
|
|
pkSuite <- o .: "suite"
|
|
rawAuth <- o .: "auth"
|
|
rawCrypt <- o .: "crypt"
|
|
let pkAuth = parseKey rawAuth
|
|
let pkCrypt = parseKey rawCrypt
|
|
pure PointKeys{..}
|
|
where
|
|
parseKey = reverse . toBytes . hexString . removePrefix . encodeUtf8
|
|
|
|
data PointSponsor = PointSponsor
|
|
{ psHas :: Bool
|
|
, psWho :: Text
|
|
} deriving (Show, Eq, Generic)
|
|
|
|
instance FromJSON PointSponsor where
|
|
parseJSON = withObject "PointSponsor" $ \o -> do
|
|
psHas <- o .: "has"
|
|
psWho <- o .: "who"
|
|
pure PointSponsor{..}
|
|
|
|
data PointRequest = PointRequest Ship
|
|
|
|
instance RequestMethod PointRequest where
|
|
getRequestMethod PointRequest{} = "getPoint"
|
|
|
|
instance ToJSON PointRequest where
|
|
toJSON (PointRequest point) = object [ "ship" .= renderShip point ]
|
|
|
|
parseAzimuthPoint :: PointRequest -> PointResponse -> EthPoint
|
|
parseAzimuthPoint (PointRequest point) response = EthPoint{..}
|
|
where
|
|
net = prNetwork response
|
|
key = pnKeys net
|
|
|
|
-- Vere doesn't set ownership information, neither did the old Dawn.hs
|
|
-- implementation.
|
|
epOwn = (0, 0, 0, 0)
|
|
|
|
sponsorShip = Ob.parsePatp $ psWho $ pnSponsor net
|
|
epNet = if pkLife key == 0
|
|
then Nothing
|
|
else case sponsorShip of
|
|
Left _ -> Nothing
|
|
Right s -> Just
|
|
( fromIntegral $ pkLife key
|
|
, passFromBytes (pkCrypt key) (pkAuth key) (pkSuite key)
|
|
, fromIntegral $ pnRift net
|
|
, (psHas $ pnSponsor net, Ship $ fromIntegral $ Ob.fromPatp s)
|
|
, Nothing -- NOTE goes unused currently, so we simply put Nothing
|
|
)
|
|
|
|
-- I don't know what this is supposed to be, other than the old Dawn.hs and
|
|
-- dawn.c do the same thing.
|
|
-- zero-fill spawn data
|
|
epKid = case clanFromShip (Ship $ fromIntegral point) 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 -> PointResponse -> (Ship, (Rift, Life, Pass))
|
|
parseGalaxyTableEntry (PointRequest point) response = (ship, (rift, life, pass))
|
|
where
|
|
net = prNetwork response
|
|
keys = pnKeys net
|
|
|
|
ship = Ship $ fromIntegral point
|
|
rift = fromIntegral $ pnRift net
|
|
life = fromIntegral $ pkLife keys
|
|
pass = passFromBytes (pkCrypt keys) (pkAuth keys) (pkSuite keys)
|
|
|
|
removePrefix :: ByteString -> ByteString
|
|
removePrefix withOhEx
|
|
| prefix == "0x" = suffix
|
|
| otherwise = error "not prefixed with 0x"
|
|
where
|
|
(prefix, suffix) = splitAt 2 withOhEx
|
|
|
|
data TurfRequest = TurfRequest
|
|
|
|
instance RequestMethod TurfRequest where
|
|
getRequestMethod TurfRequest = "getDns"
|
|
|
|
instance ToJSON TurfRequest where
|
|
toJSON TurfRequest = object [] -- NOTE getDns takes no parameters
|
|
|
|
parseTurfResponse :: TurfRequest -> [Text] -> [Turf]
|
|
parseTurfResponse TurfRequest = map turf
|
|
where
|
|
turf t = Turf $ fmap Cord $ reverse $ splitOn "." t
|
|
|
|
-- Azimuth Functions -----------------------------------------------------------
|
|
|
|
retrievePoint :: String -> Ship -> RIO e EthPoint
|
|
retrievePoint endpoint ship =
|
|
dawnPostRequests endpoint parseAzimuthPoint [PointRequest ship]
|
|
>>= \case
|
|
[x] -> pure x
|
|
_ -> error "JSON server returned multiple return values."
|
|
|
|
validateFeedAndGetSponsor :: String
|
|
-> Feed
|
|
-> RIO e (Seed, Ship)
|
|
validateFeedAndGetSponsor endpoint = \case
|
|
Feed0 s -> do
|
|
r <- validateSeed s
|
|
case r of
|
|
Left e -> error e
|
|
Right r -> pure (s, r)
|
|
Feed1 s -> validateGerms s
|
|
|
|
where
|
|
validateGerms Germs{..} =
|
|
case gFeed of
|
|
[] -> error "no usable keys in keyfile"
|
|
(Germ{..}:f) -> do
|
|
let seed = Seed gShip gLife gRing Nothing
|
|
r :: Either String Ship
|
|
<- validateSeed seed
|
|
case r of
|
|
Left _ -> validateGerms $ Germs gShip f
|
|
Right r -> pure (seed, r)
|
|
|
|
validateSeed (Seed ship life ring oaf) = do
|
|
case clanFromShip ship of
|
|
Ob.Comet -> pure validateComet
|
|
Ob.Moon -> pure validateMoon
|
|
_ -> validateRest
|
|
where
|
|
cometFromPass = cometFingerprint $ ringToPass ring
|
|
validateComet
|
|
-- A comet address is the fingerprint of the keypair
|
|
| (ship /= cometFromPass) =
|
|
Left ("comet name doesn't match fingerprint " <>
|
|
show ship <> " vs " <>
|
|
show cometFromPass)
|
|
| (life /= 1) =
|
|
Left "comet can never be re-keyed"
|
|
| otherwise =
|
|
Right (shipSein ship)
|
|
|
|
validateMoon =
|
|
-- 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.
|
|
Right $ shipSein ship
|
|
|
|
validateRest = do
|
|
putStrLn ("boot: retrieving " <> renderShip ship <> "'s public keys")
|
|
|
|
--TODO could cache this lookup
|
|
whoP <- retrievePoint endpoint ship
|
|
case epNet whoP of
|
|
Nothing -> pure $ Left "ship not keyed"
|
|
Just (netLife, pass, contNum, (hasSponsor, who), _) -> do
|
|
if (netLife /= life) then
|
|
pure $ Left ("keyfile life mismatch; keyfile claims life " <>
|
|
show life <> ", but Azimuth claims life " <>
|
|
show netLife)
|
|
else if ((ringToPass ring) /= pass) then
|
|
pure $ Left "keyfile does not match Azimuth"
|
|
-- TODO: The hoon code does a breach check, but the C code never
|
|
-- supplies the data necessary for it to function.
|
|
else
|
|
pure $ Right who
|
|
|
|
|
|
-- Walk through the sponsorship chain retrieving the actual sponsorship chain
|
|
-- as it exists on Azimuth.
|
|
getSponsorshipChain :: String -> Ship -> RIO e [(Ship,EthPoint)]
|
|
getSponsorshipChain endpoint = loop
|
|
where
|
|
loop ship = do
|
|
putStrLn ("boot: retrieving keys for sponsor " <> renderShip ship)
|
|
ethPoint <- retrievePoint endpoint ship
|
|
|
|
case (clanFromShip ship, epNet ethPoint) of
|
|
(Ob.Comet, _) -> error "Comets cannot be sponsors"
|
|
(Ob.Moon, _) -> error "Moons cannot be sponsors"
|
|
|
|
(_, Nothing) ->
|
|
error $ unpack ("Ship " <> renderShip ship <> " not booted")
|
|
|
|
(Ob.Galaxy, Just _) -> pure [(ship, ethPoint)]
|
|
|
|
(_, Just (_, _, _, (False, _), _)) ->
|
|
error $ unpack ("Ship " <> renderShip ship <> " has no sponsor")
|
|
|
|
(_, Just (_, _, _, (True, sponsor), _)) -> do
|
|
chain <- loop sponsor
|
|
pure $ chain <> [(ship, ethPoint)]
|
|
|
|
-- Produces either an error or a validated boot event structure.
|
|
dawnVent :: HasLogFunc e => String -> Feed -> RIO e (Either Text Dawn)
|
|
dawnVent provider feed =
|
|
-- The type checker can't figure this out on its own.
|
|
(onLeft tshow :: Either SomeException Dawn -> Either Text Dawn) <$> try do
|
|
putStrLn ("boot: requesting L2 Azimuth information from " <> pack provider)
|
|
|
|
(dSeed, immediateSponsor)
|
|
<- validateFeedAndGetSponsor provider feed
|
|
dSponsor <- getSponsorshipChain provider immediateSponsor
|
|
|
|
putStrLn "boot: retrieving galaxy table"
|
|
dCzar <- (mapToHoonMap . mapFromList) <$>
|
|
(dawnPostRequests provider parseGalaxyTableEntry (map (PointRequest . Ship . fromIntegral) [0..255]))
|
|
|
|
putStrLn "boot: retrieving network domains"
|
|
dTurf <- (dawnPostRequests provider parseTurfResponse [TurfRequest])
|
|
>>= \case
|
|
[] -> pure []
|
|
[t] -> pure (nub t)
|
|
_ -> error "too many turf responses"
|
|
|
|
let dNode = Nothing
|
|
|
|
-- NOTE blocknum of 0 is fine because jael ignores it.
|
|
-- should probably be removed from dawn event.
|
|
let dBloq = 0
|
|
|
|
pure MkDawn{..}
|
|
|
|
|
|
-- Comet List ------------------------------------------------------------------
|
|
|
|
dawnCometList :: RIO e [Ship]
|
|
dawnCometList = do
|
|
-- Get the jamfile with the list of stars accepting comets right now.
|
|
manager <- io $ C.newManager TLS.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
|
|
|
|
shax :: BS.ByteString -> BS.ByteString
|
|
shax = SHA256.hash
|
|
|
|
shas :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
|
shas salt = shax . mix salt . shax
|
|
|
|
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)
|
|
|
|
-- Given a ring, derives the network login code.
|
|
--
|
|
-- Note that the network code is a patp, not a patq: the bytes have been
|
|
-- scrambled.
|
|
deriveCode :: Ring -> Ob.Patp
|
|
deriveCode Ring {..} = Ob.patp $
|
|
bytesAtom $
|
|
take 8 $
|
|
shaf (C.pack "pass") $
|
|
shax $
|
|
C.singleton 'B' <> ringSign <> ringCrypt
|
|
|
|
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
|