diff --git a/pkg/king/app/Main.hs b/pkg/king/app/Main.hs index fe7679dffa..009566aa01 100644 --- a/pkg/king/app/Main.hs +++ b/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 diff --git a/pkg/king/lib/Noun/Conversions.hs b/pkg/king/lib/Noun/Conversions.hs index 859d288f7d..3ae928c677 100644 --- a/pkg/king/lib/Noun/Conversions.hs +++ b/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 ------------------------------------------------------------------------ diff --git a/pkg/king/lib/Vere/Dawn.hs b/pkg/king/lib/Vere/Dawn.hs index cd74c93008..418e5e8024 100644 --- a/pkg/king/lib/Vere/Dawn.hs +++ b/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 -getPassFromRing Ring{..} = Pass{..} +ringToPass :: 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") - -- A comet can never be breached - -- when live Left "comet already booted" - -- TODO: the parent must be launched check? + 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 @@ -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) - b = (take 32 haz) + a = (take 16 haz) + b = (drop 16 haz) -shas :: BS.ByteString -> BS.ByteString -> BS.ByteString -shas salt ruz = - SHA512.hash $ mix salt $ SHA512.hash ruz +cometFingerprintBS :: Pass -> ByteString +cometFingerprintBS = (shaf $ C.pack "bfig") . passToBS -cometFingerprint :: Pass -> Ship -- Word128 -cometFingerprint = Ship . B.decode . fromStrict . (shas bfig) . passToBS - where - bfig = C.pack "bfig" +cometFingerprint :: Pass -> Ship +cometFingerprint = Ship . B.decode . fromStrict . reverse . cometFingerprintBS 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 diff --git a/pkg/king/package.yaml b/pkg/king/package.yaml index b86207030c..e777b82d24 100644 --- a/pkg/king/package.yaml +++ b/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 diff --git a/pkg/king/test/DawnTests.hs b/pkg/king/test/DawnTests.hs new file mode 100644 index 0000000000..795cc1705d --- /dev/null +++ b/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 + ] diff --git a/pkg/king/test/Main.hs b/pkg/king/test/Main.hs index 17f5ddf8d8..e978560caf 100644 --- a/pkg/king/test/Main.hs +++ b/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 ]