Boot from mined comets in king.

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.

pkg/king/app/Main.hs

@@ -91,6 +91,7 @@ import Data.Conduit.List hiding (catMaybes, map, replicate, take)
 import Data.RAcquire
 import Noun              hiding (Parser)
 import Noun.Atom
+import Noun.Conversions  (cordToUW)
 import RIO.Directory
 import Vere.Pier
 import Vere.Pier.Types
@@ -408,9 +409,6 @@ startBrowser pierPath = runRAcquire $ do
     log <- Log.existing (pierPath <> "/.urb/log")
     rio $ EventBrowser.run log
 
-cordToUW :: Cord -> Maybe UW
-cordToUW = fromNoun . toNoun
-
 checkDawn :: HasLogFunc e => FilePath -> RIO e ()
 checkDawn keyfilePath = do
   -- The keyfile is a jammed Seed then rendered in UW format

pkg/king/lib/Noun/Conversions.hs

@@ -7,7 +7,7 @@ module Noun.Conversions
   , Cord(..), Knot(..), Term(..), Tape(..), Tour(..)
   , BigTape(..), BigCord(..)
   , Wall
-  , UD(..), UV(..), UW(..)
+  , UD(..), UV(..), UW(..), cordToUW
   , Mug(..), Path(..), EvilPath(..), Ship(..)
   , Lenient(..), pathToFilePath, filePathToPath
   ) where
@@ -285,6 +285,9 @@ uwCharNum = \case
   '~' -> pure 63
   _   -> Nothing
 
+-- Maybe parses the underlying atom value from a text printed in UW format.
+cordToUW :: Cord -> Maybe UW
+cordToUW = fromNoun . toNoun
 
 -- Char ------------------------------------------------------------------------
 

pkg/king/lib/Vere/Dawn.hs

@@ -15,6 +15,7 @@ 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
@@ -62,8 +63,8 @@ renderShip = Ob.renderPatp . Ob.patp . fromIntegral
 -- getFingerprintFromKey = undefined
 
 -- Derive public key structure from the key derivation seed structure
-getPassFromRing :: Ring -> Pass
+ringToPass :: Ring -> Pass
-getPassFromRing Ring{..} = Pass{..}
+ringToPass Ring{..} = Pass{..}
   where
     passCrypt = decode ringCrypt
     passSign = decode ringSign
@@ -157,12 +158,13 @@ validateShipAndGetImmediateSponsor block azimuth (Seed ship life ring oaf) =
     _        -> validateRest
   where
     validateComet = do
-      -- TODO: All validation of the comet.
       -- A comet address is the fingerprint of the keypair
-      -- when (ship /= (x ring.seed)) (Left "todo: key mismatch")
+      let shipFromPass = cometFingerprint $ ringToPass ring
-      -- A comet can never be breached
+      when (ship /= shipFromPass) $
-      -- when live Left "comet already booted"
+        fail ("comet name doesn't match fingerprint " ++ show ship ++ " vs " ++
-      -- TODO: the parent must be launched check?
+              show shipFromPass)
+      when (life /= 1) $
+        fail ("comet can never be re-keyed")
       pure (shipSein ship)
 
     validateMoon = do
@@ -182,7 +184,7 @@ validateShipAndGetImmediateSponsor block azimuth (Seed ship life ring oaf) =
               fail ("keyfile life mismatch; keyfile claims life " ++
                     show life ++ ", but Azimuth claims life " ++
                     show netLife)
-          when ((getPassFromRing ring) /= pass) $
+          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.
@@ -261,29 +263,29 @@ dawnCometList = do
 
 -- Comet Mining ----------------------------------------------------------------
 
--- TODO: Comet mining doesn't seem to work and I'm guessing it's because I'm
--- screwing up the math below.
-
--- TODO: This might be entirely wrong. What happens with a or b is longer?
 mix :: BS.ByteString -> BS.ByteString -> BS.ByteString
-mix a b = BS.pack $ BS.zipWith xor a b
+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
 
--- TODO: a/b ordering?
 shaf :: BS.ByteString -> BS.ByteString -> BS.ByteString
 shaf salt ruz = (mix a b)
   where
     haz = shas salt ruz
-    a = (drop 32 haz)
+    a = (take 16 haz)
-    b = (take 32 haz)
+    b = (drop 16 haz)
 
-shas :: BS.ByteString -> BS.ByteString -> BS.ByteString
+cometFingerprintBS :: Pass -> ByteString
-shas salt ruz =
+cometFingerprintBS = (shaf $ C.pack "bfig") . passToBS
-  SHA512.hash $ mix salt $ SHA512.hash ruz
 
-cometFingerprint :: Pass -> Ship  -- Word128
+cometFingerprint :: Pass -> Ship
-cometFingerprint = Ship . B.decode . fromStrict . (shas bfig) . passToBS
+cometFingerprint = Ship . B.decode . fromStrict . reverse . cometFingerprintBS
-  where
-    bfig = C.pack "bfig"
 
 tryMineComet :: Set Ship -> Word64 -> Maybe Seed
 tryMineComet ships seed =
@@ -296,7 +298,7 @@ tryMineComet ships seed =
     signSeed = (take 32 baseHash)
     ringSeed = (drop 32 baseHash)
     ring = Ring signSeed ringSeed
-    pass = getPassFromRing ring
+    pass = ringToPass ring
     shipName = cometFingerprint pass
     shipSponsor = shipSein shipName
 

pkg/king/package.yaml

@@ -37,6 +37,7 @@ dependencies:
   - classy-prelude
   - conduit
   - containers
+  - cryptohash-sha256
   - cryptohash-sha512
   - data-default
   - data-fix
@@ -86,6 +87,7 @@ dependencies:
   - stm-chans
   - tasty
   - tasty-golden
+  - tasty-hunit
   - tasty-quickcheck
   - tasty-th
   - template-haskell

pkg/king/test/DawnTests.hs

@@ -0,0 +1,88 @@
+module DawnTests (tests) where
+
+import Arvo.Event
+import Noun.Conversions
+import UrbitPrelude
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import qualified Urbit.Ob  as Ob
+import qualified Vere.Dawn as Dawn
+
+--------------------------------------------------------------------------------
+
+-- These golden cases generated in Urbit from entropy to make sure our +mix,
+-- +shas, +shaf, etc. were actually calculated correctly.
+
+cordToAtomBytes :: Text -> ByteString
+cordToAtomBytes t = cordToAtom t ^. atomBytes
+
+cordToAtom :: Text -> Atom
+cordToAtom t = case cordToUW (Cord t) of
+    Nothing     -> error "Couldn't parse constant embedded in file."
+    Just (UW a) -> a
+
+testString = cordToAtomBytes $ concat
+    [ "0w1.XqnKc.onYJK.0zVOU.Uw142.jNx3C.oWV83.TYt6T.kmHUg.cnoq1.zla6B.bKeNa"
+    , ".8wUZu.6ZLHJ.c1TKV.KPcb3.9lU3~.p2G8D"
+    ]
+
+testSalt = cordToAtomBytes "0wc.~cOwa.Kb-DI.BrjVW.i0U37"
+
+mixByteStrings = (Dawn.mix testSalt testString) @?= expected
+  where
+    expected = cordToAtomBytes $ concat
+      [ "0w1.XqnKc.onYJK.0zVOU.Uw142.jNx3C.oWV83.TYt6T.kmHUg.cnoq1.zla6B.bKeNa"
+      , ".8wUZu.6ZLHx.Pd5eP.0UOIL.IeHW5.b2ibw"
+      ]
+
+shasByteStrings = (Dawn.shas testSalt testString) @?= expected
+  where
+    expected = cordToAtomBytes
+      "0wfKW.mXzrj.c~IBb.lKd6k.2njoG.bRLcD.9eszA.gSSs8.mHRah"
+
+shafByteStrings = (Dawn.shaf testSalt testString) @?= expected
+  where
+    expected = cordToAtomBytes "0w3h.Bg1Qh.ZZjoJ.23J~p.PHg-D"
+
+--------------------------------------------------------------------------------
+
+cometShip :: Ship
+cometShip = case Ob.parsePatp cometStr of
+  Left x  -> error "Invalid ship name"
+  Right p -> Ship $ fromIntegral $ Ob.fromPatp p
+  where
+    cometStr = "~radmes-dilsec-sovlup-lagwep--tonred-waldeb-tocseg-marzod"
+
+cometPass :: Pass
+cometPass = case fromNoun (Atom cometPassAtom) of
+  Nothing -> error "Keyfile does not seem to contain a seed."
+  Just s  -> s
+  where
+    cometPassAtom = cordToAtom $ concat
+      [ "0w99.P80w4.rL7Qt.0i5-h.8yta7.RhgHI.nrXjO.xBCix.Pxx5a.sJ6bv.a-Iwo.OeVBr"
+      , ".x8-Gs.1LLG~.FgDRk.GML3Y.X3qFZ.jtlpy"
+      ]
+
+cometRawBS = cordToAtomBytes "0w39.q35g-.hrd3f.q9UWK.Zxg40"
+
+-- Verifies the internal usage of +shaf in comet derivation gets the right
+-- answer.
+testCometFingerprintBS = (Dawn.cometFingerprintBS cometPass) @?= cometRawBS
+
+-- Tests that the real public interface for fingerprint generation does the
+-- byte-munging correctly.
+testCometFingerprint = (Dawn.cometFingerprint cometPass) @?= cometShip
+
+--------------------------------------------------------------------------------
+
+tests :: TestTree
+tests =
+  testGroup "Dawn"
+    [ testCase "Mix bytestrings of different length" $ mixByteStrings
+    , testCase "Shas bytestrings" $ shasByteStrings
+    , testCase "Shaf bytestrings" $ shafByteStrings
+    , testCase "Fingerprint bytestring derivation" $ testCometFingerprintBS
+    , testCase "Fingerprint total derivation" $ testCometFingerprint
+    ]

pkg/king/test/Main.hs

@@ -14,6 +14,7 @@ import System.Environment (setEnv)
 import qualified AmesTests
 import qualified ArvoTests
 import qualified BehnTests
+import qualified DawnTests
 import qualified DeriveNounTests
 import qualified HoonMapSetTests
 import qualified LogTests
@@ -24,11 +25,12 @@ main = do
     makeAbsolute "../.." >>= setCurrentDirectory
     setEnv "TASTY_NUM_THREADS" "1"
     runInBoundThread $ defaultMain $ testGroup "Urbit"
-        [ DeriveNounTests.tests
+        [ AmesTests.tests
         , ArvoTests.tests
-        , AmesTests.tests
-        , LogTests.tests
         , BehnTests.tests
-        , NounConversionTests.tests
+        , DawnTests.tests
+        , DeriveNounTests.tests
         , HoonMapSetTests.tests
+        , LogTests.tests
+        , NounConversionTests.tests
         ]