kh: support multikeyfiles

2024-11-28 19:55:53 +03:00 · 2021-06-03 01:04:45 +02:00 · 2021-06-03 01:04:45 +02:00 · cc362b27c9
commit cc362b27c9
parent 2e2361e522
3 changed files with 103 additions and 52 deletions
--- a/pkg/hs/urbit-king/lib/Urbit/Arvo/Event.hs
+++ b/pkg/hs/urbit-king/lib/Urbit/Arvo/Event.hs
@ -117,6 +117,35 @@ data Seed = Seed
    }
  deriving (Eq, Show)

+data Feed
+  = Feed0 Seed
+  | Feed1 [Seed]
+  deriving (Eq, Show)
+
+--NOTE  reify type environment
+$(pure [])
+
+instance ToNoun Feed where
+  toNoun = \case
+    Feed0 s -> toSeed s
+    Feed1 s -> C (C (A 1) (A 0)) $ toList s
+    where
+      toList :: [Seed] -> Noun
+      toList [] = A 0
+      toList (x:xs) = C (toSeed x) (toList xs)
+      toSeed = $(deriveToNounFunc ''Seed)
+
+instance FromNoun Feed where
+  parseNoun = \case
+    (C (C (A 1) (A 0)) s) -> Feed1 <$> parseList s
+    n                     -> Feed0 <$> parseSeed n
+    where
+      parseList = \case
+        Atom 0   -> pure []
+        Atom _   -> fail "list terminated with non-null atom"
+        Cell l r -> (:) <$> parseSeed l <*> parseList r
+      parseSeed = $(deriveFromNounFunc ''Seed)
+
 type Public = (Life, HoonMap Life Pass)

 data Dnses = Dnses { dPri::Cord, dSec::Cord, dTer::Cord }
@ -133,7 +162,7 @@ data EthPoint = EthPoint
  deriving (Eq, Show)

 data Dawn = MkDawn
-    { dSeed    :: Seed
+    { dFeed    :: (Life, Feed)
    , dSponsor :: [(Ship, EthPoint)]
    , dCzar    :: HoonMap Ship (Rift, Life, Pass)
    , dTurf    :: [Turf]
--- a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs
+++ b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs
@ -500,7 +500,7 @@ newShip CLI.New{..} opts = do
      let seed = mineComet (Set.fromList starList) eny
      putStrLn ("boot: found comet " ++ renderShip (sShip seed))
      putStrLn ("code: " ++ (tshow $ deriveCode $ sRing seed))
-      bootFromSeed pill seed
+      bootFromSeed pill $ Feed0 seed

    CLI.BootFake name -> do
      pill <- pillFrom nPillSource
@ -514,13 +514,13 @@ newShip CLI.New{..} opts = do
        Just (UW a) -> pure a

      asNoun <- cueExn asAtom
-      seed :: Seed <- case fromNoun asNoun of
+      feed :: Feed <- case fromNoun asNoun of
        Nothing -> error "Keyfile does not seem to contain a seed."
        Just s  -> pure s

      pill <- pillFrom nPillSource

-      bootFromSeed pill seed
+      bootFromSeed pill feed

  where
    shipFrom :: Text -> RIO HostEnv Ship
@ -541,14 +541,13 @@ newShip CLI.New{..} opts = do
          Nothing -> error "Urbit.ob didn't produce string with ~"
          Just x  -> pure x

-    bootFromSeed :: Pill -> Seed -> RIO HostEnv ()
-    bootFromSeed pill seed = do
-      ethReturn <- dawnVent nEthNode seed
+    bootFromSeed :: Pill -> Feed -> RIO HostEnv ()
+    bootFromSeed pill feed = do
+      ethReturn <- dawnVent nEthNode feed

      case ethReturn of
        Left x -> error $ unpack x
-        Right dawn -> do
-          let ship = sShip $ dSeed dawn
+        Right (ship, dawn) -> do
          name <- nameFromShip ship
          runTryBootFromPill pill name ship (Dawn dawn)

@ -642,13 +641,13 @@ checkDawn provider keyfilePath = do
    Just (UW a) -> pure a

  asNoun <- cueExn asAtom
-  seed :: Seed <- case fromNoun asNoun of
+  feed :: Feed <- case fromNoun asNoun of
    Nothing -> error "Keyfile does not seem to contain a seed."
    Just s  -> pure s

-  print $ show seed
+  print $ show feed

-  e <- dawnVent provider seed
+  e <- dawnVent provider feed
  print $ show e


--- a/pkg/hs/urbit-king/lib/Urbit/Vere/Dawn.hs
+++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Dawn.hs
@ -335,45 +335,65 @@ retrievePoint endpoint block ship =
      [x] -> pure x
      _   -> error "JSON server returned multiple return values."

-validateShipAndGetSponsor :: String -> TextBlockNum -> Seed -> RIO e Ship
-validateShipAndGetSponsor endpoint block (Seed ship life ring oaf) =
-  case clanFromShip ship of
-    Ob.Comet -> validateComet
-    Ob.Moon  -> validateMoon
-    _        -> validateRest
+validateFeedAndGetSponsor :: String
+                          -> TextBlockNum
+                          -> Feed
+                          -> RIO e (Ship, Life, Ship)
+validateFeedAndGetSponsor endpoint block = \case
+    Feed0 s -> do
+                 r <- (validateSeed s)
+                 pure (sShip s, sLife s, r)
+    Feed1 s -> validateSeeds s
+
  where
-    validateComet = do
-      -- A comet address is the fingerprint of the keypair
-      let shipFromPass = cometFingerprint $ ringToPass ring
-      when (ship /= shipFromPass) $
-        error ("comet name doesn't match fingerprint " <> show ship <> " vs " <>
-              show shipFromPass)
-      when (life /= 1) $
-        error ("comet can never be re-keyed")
-      pure (shipSein ship)
+    validateSeeds = \case
+      []    -> error ("no usable keys in keyfile")
+      (s:f) -> do
+                 r :: Either SomeException Ship
+                   <- try do validateSeed s
+                 case r of
+                   Left _  -> validateSeeds f
+                   Right r -> pure (sShip s, sLife s, r)

-    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
+    validateSeed (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) $
+            error ("comet name doesn't match fingerprint " <> show ship <> " vs " <>
+                  show shipFromPass)
+          when (life /= 1) $
+            error ("comet can never be re-keyed")
+          pure (shipSein ship)

-    validateRest = do
-      putStrLn ("boot: retrieving " <> renderShip ship <> "'s public keys")
+        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

-      whoP <- retrievePoint endpoint block ship
-      case epNet whoP of
-        Nothing -> error "ship not keyed"
-        Just (netLife, pass, contNum, (hasSponsor, who), _) -> do
-          when (netLife /= life) $
-              error ("keyfile life mismatch; keyfile claims life " <>
-                    show life <> ", but Azimuth claims life " <>
-                    show netLife)
-          when ((ringToPass ring) /= pass) $
-              error "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
+        validateRest = do
+          putStrLn ("boot: retrieving " <> renderShip ship <> "'s public keys")
+
+          --TODO  could cache this lookup
+          whoP <- retrievePoint endpoint block ship
+          case epNet whoP of
+            Nothing -> error "ship not keyed"
+            Just (netLife, pass, contNum, (hasSponsor, who), _) -> do
+              when (netLife /= life) $
+                  error ("keyfile life mismatch; keyfile claims life " <>
+                        show life <> ", but Azimuth claims life " <>
+                        show netLife)
+              when ((ringToPass ring) /= pass) $
+                  error "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
@ -402,10 +422,11 @@ getSponsorshipChain endpoint block = loop
            pure $ chain <> [(ship, ethPoint)]

 -- Produces either an error or a validated boot event structure.
-dawnVent :: HasLogFunc e => String -> Seed -> RIO e (Either Text Dawn)
-dawnVent provider dSeed@(Seed ship life ring oaf) =
+dawnVent :: HasLogFunc e => String -> Feed -> RIO e (Either Text (Ship, 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
+  (onLeft tshow :: Either SomeException (Ship, Dawn)
+                -> Either Text (Ship, Dawn)) <$> try do
    putStrLn ("boot: requesting ethereum information from " <> pack provider)
    blockResponses
      <- dawnPostRequests provider parseBlockRequest [BlockRequest]
@ -417,7 +438,8 @@ dawnVent provider dSeed@(Seed ship life ring oaf) =
    let dBloq = hexStrToAtom hexStrBlock
    putStrLn ("boot: ethereum block #" <> tshow dBloq)

-    immediateSponsor <- validateShipAndGetSponsor provider hexStrBlock dSeed
+    (ship, life, immediateSponsor)
+      <- validateFeedAndGetSponsor provider hexStrBlock feed
    dSponsor <- getSponsorshipChain provider hexStrBlock immediateSponsor

    putStrLn "boot: retrieving galaxy table"
@ -429,9 +451,10 @@ dawnVent provider dSeed@(Seed ship life ring oaf) =
    dTurf <- nub <$> (dawnPostRequests provider parseTurfResponse $
      map (TurfRequest hexStrBlock) [0..2])

+    let dFeed = (life, feed)
    let dNode = Nothing

-    pure $ MkDawn{..}
+    pure (ship, MkDawn{..})


 -- Comet List ------------------------------------------------------------------