{-# LANGUAGE GeneralisedNewtypeDeriving #-}
module Cardano.CLI.Byron.Genesis
( ByronGenesisError(..)
, GenesisParameters(..)
, NewDirectory(..)
, dumpGenesis
, mkGenesis
, readGenesis
, renderByronGenesisError
)
where
import Cardano.Prelude (canonicalDecodePretty, canonicalEncodePretty)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans (MonadTrans (..))
import Control.Monad.Trans.Except (ExceptT (..), withExceptT)
import Control.Monad.Trans.Except.Extra (firstExceptT, left, right)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LB
import qualified Data.List as List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.String (IsString)
import Data.Text (Text)
import qualified Data.Text.Encoding as Text
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Builder (toLazyText)
import Data.Time (UTCTime)
import Formatting.Buildable
import Cardano.Api (Key (..), NetworkId, textShow, writeSecrets)
import Cardano.Api.Byron (ByronKey, SerialiseAsRawBytes (..), SigningKey (..),
toByronRequiresNetworkMagic)
import System.Directory (createDirectory, doesPathExist)
import qualified Cardano.Chain.Common as Common
import Cardano.Chain.Delegation hiding (Map, epoch)
import Cardano.Chain.Genesis (GeneratedSecrets (..))
import qualified Cardano.Chain.Genesis as Genesis
import qualified Cardano.Chain.UTxO as UTxO
import qualified Cardano.Crypto as Crypto
import Cardano.CLI.Byron.Delegation
import Cardano.CLI.Byron.Key
import Cardano.CLI.Types (GenesisFile (..))
data ByronGenesisError
= ByronDelegationCertSerializationError !ByronDelegationError
| ByronDelegationKeySerializationError ByronDelegationError
| GenesisGenerationError !Genesis.GenesisDataGenerationError
| GenesisOutputDirAlreadyExists FilePath
| GenesisReadError !FilePath !Genesis.GenesisDataError
| GenesisSpecError !Text
| MakeGenesisDelegationError !Genesis.GenesisDelegationError
| NoGenesisDelegationForKey !Text
| ProtocolParametersParseFailed !FilePath !Text
| PoorKeyFailure !ByronKeyFailure
deriving Int -> ByronGenesisError -> ShowS
[ByronGenesisError] -> ShowS
ByronGenesisError -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ByronGenesisError] -> ShowS
$cshowList :: [ByronGenesisError] -> ShowS
show :: ByronGenesisError -> FilePath
$cshow :: ByronGenesisError -> FilePath
showsPrec :: Int -> ByronGenesisError -> ShowS
$cshowsPrec :: Int -> ByronGenesisError -> ShowS
Show
renderByronGenesisError :: ByronGenesisError -> Text
renderByronGenesisError :: ByronGenesisError -> Text
renderByronGenesisError ByronGenesisError
err =
case ByronGenesisError
err of
ProtocolParametersParseFailed FilePath
pParamFp Text
parseError ->
Text
"Protocol parameters parse failed at: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow FilePath
pParamFp forall a. Semigroup a => a -> a -> a
<> Text
" Error: " forall a. Semigroup a => a -> a -> a
<> Text
parseError
ByronDelegationCertSerializationError ByronDelegationError
bDelegSerErr ->
Text
"Error while serializing the delegation certificate: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow ByronDelegationError
bDelegSerErr
ByronDelegationKeySerializationError ByronDelegationError
bKeySerErr ->
Text
"Error while serializing the delegation key: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow ByronDelegationError
bKeySerErr
PoorKeyFailure ByronKeyFailure
bKeyFailure ->
Text
"Error creating poor keys: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow ByronKeyFailure
bKeyFailure
MakeGenesisDelegationError GenesisDelegationError
genDelegError ->
Text
"Error creating genesis delegation: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow GenesisDelegationError
genDelegError
GenesisGenerationError GenesisDataGenerationError
genDataGenError ->
Text
"Error generating genesis: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow GenesisDataGenerationError
genDataGenError
GenesisOutputDirAlreadyExists FilePath
genOutDir ->
Text
"Genesis output directory already exists: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow FilePath
genOutDir
GenesisReadError FilePath
genFp GenesisDataError
genDataError ->
Text
"Error while reading genesis file at: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow FilePath
genFp forall a. Semigroup a => a -> a -> a
<> Text
" Error: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow GenesisDataError
genDataError
GenesisSpecError Text
genSpecError ->
Text
"Error while creating genesis spec" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow Text
genSpecError
NoGenesisDelegationForKey Text
verKey ->
Text
"Error while creating genesis, no delegation certificate for this verification key:" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow Text
verKey
newtype NewDirectory =
NewDirectory FilePath
deriving (NewDirectory -> NewDirectory -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NewDirectory -> NewDirectory -> Bool
$c/= :: NewDirectory -> NewDirectory -> Bool
== :: NewDirectory -> NewDirectory -> Bool
$c== :: NewDirectory -> NewDirectory -> Bool
Eq, Eq NewDirectory
NewDirectory -> NewDirectory -> Bool
NewDirectory -> NewDirectory -> Ordering
NewDirectory -> NewDirectory -> NewDirectory
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NewDirectory -> NewDirectory -> NewDirectory
$cmin :: NewDirectory -> NewDirectory -> NewDirectory
max :: NewDirectory -> NewDirectory -> NewDirectory
$cmax :: NewDirectory -> NewDirectory -> NewDirectory
>= :: NewDirectory -> NewDirectory -> Bool
$c>= :: NewDirectory -> NewDirectory -> Bool
> :: NewDirectory -> NewDirectory -> Bool
$c> :: NewDirectory -> NewDirectory -> Bool
<= :: NewDirectory -> NewDirectory -> Bool
$c<= :: NewDirectory -> NewDirectory -> Bool
< :: NewDirectory -> NewDirectory -> Bool
$c< :: NewDirectory -> NewDirectory -> Bool
compare :: NewDirectory -> NewDirectory -> Ordering
$ccompare :: NewDirectory -> NewDirectory -> Ordering
Ord, Int -> NewDirectory -> ShowS
[NewDirectory] -> ShowS
NewDirectory -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [NewDirectory] -> ShowS
$cshowList :: [NewDirectory] -> ShowS
show :: NewDirectory -> FilePath
$cshow :: NewDirectory -> FilePath
showsPrec :: Int -> NewDirectory -> ShowS
$cshowsPrec :: Int -> NewDirectory -> ShowS
Show, FilePath -> NewDirectory
forall a. (FilePath -> a) -> IsString a
fromString :: FilePath -> NewDirectory
$cfromString :: FilePath -> NewDirectory
IsString)
data GenesisParameters = GenesisParameters
{ GenesisParameters -> UTCTime
gpStartTime :: !UTCTime
, GenesisParameters -> FilePath
gpProtocolParamsFile :: !FilePath
, GenesisParameters -> BlockCount
gpK :: !Common.BlockCount
, GenesisParameters -> ProtocolMagic
gpProtocolMagic :: !Crypto.ProtocolMagic
, GenesisParameters -> TestnetBalanceOptions
gpTestnetBalance :: !Genesis.TestnetBalanceOptions
, GenesisParameters -> FakeAvvmOptions
gpFakeAvvmOptions :: !Genesis.FakeAvvmOptions
, GenesisParameters -> LovelacePortion
gpAvvmBalanceFactor :: !Common.LovelacePortion
, GenesisParameters -> Maybe Integer
gpSeed :: !(Maybe Integer)
} deriving Int -> GenesisParameters -> ShowS
[GenesisParameters] -> ShowS
GenesisParameters -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [GenesisParameters] -> ShowS
$cshowList :: [GenesisParameters] -> ShowS
show :: GenesisParameters -> FilePath
$cshow :: GenesisParameters -> FilePath
showsPrec :: Int -> GenesisParameters -> ShowS
$cshowsPrec :: Int -> GenesisParameters -> ShowS
Show
mkGenesisSpec :: GenesisParameters -> ExceptT ByronGenesisError IO Genesis.GenesisSpec
mkGenesisSpec :: GenesisParameters -> ExceptT ByronGenesisError IO GenesisSpec
mkGenesisSpec GenesisParameters
gp = do
ByteString
protoParamsRaw <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ByteString
LB.readFile forall a b. (a -> b) -> a -> b
$ GenesisParameters -> FilePath
gpProtocolParamsFile GenesisParameters
gp
ProtocolParameters
protocolParameters <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT
(FilePath -> Text -> ByronGenesisError
ProtocolParametersParseFailed (GenesisParameters -> FilePath
gpProtocolParamsFile GenesisParameters
gp)) forall a b. (a -> b) -> a -> b
$
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
FromJSON (Either SchemaError) a =>
ByteString -> Either Text a
canonicalDecodePretty ByteString
protoParamsRaw
GenesisDelegation
genesisDelegation <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT GenesisDelegationError -> ByronGenesisError
MakeGenesisDelegationError forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
MonadError GenesisDelegationError m =>
[Certificate] -> m GenesisDelegation
Genesis.mkGenesisDelegation []
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT Text -> ByronGenesisError
GenesisSpecError forall a b. (a -> b) -> a -> b
$
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ GenesisAvvmBalances
-> GenesisDelegation
-> ProtocolParameters
-> BlockCount
-> ProtocolMagic
-> GenesisInitializer
-> Either Text GenesisSpec
Genesis.mkGenesisSpec
(Map CompactRedeemVerificationKey Lovelace -> GenesisAvvmBalances
Genesis.GenesisAvvmBalances forall a. Monoid a => a
mempty)
GenesisDelegation
genesisDelegation
ProtocolParameters
protocolParameters
(GenesisParameters -> BlockCount
gpK GenesisParameters
gp)
(GenesisParameters -> ProtocolMagic
gpProtocolMagic GenesisParameters
gp)
(Bool -> GenesisInitializer
mkGenesisInitialiser Bool
True)
where
mkGenesisInitialiser :: Bool -> Genesis.GenesisInitializer
mkGenesisInitialiser :: Bool -> GenesisInitializer
mkGenesisInitialiser =
TestnetBalanceOptions
-> FakeAvvmOptions -> Rational -> Bool -> GenesisInitializer
Genesis.GenesisInitializer
(GenesisParameters -> TestnetBalanceOptions
gpTestnetBalance GenesisParameters
gp)
(GenesisParameters -> FakeAvvmOptions
gpFakeAvvmOptions GenesisParameters
gp)
(LovelacePortion -> Rational
Common.lovelacePortionToRational (GenesisParameters -> LovelacePortion
gpAvvmBalanceFactor GenesisParameters
gp))
mkGenesis
:: GenesisParameters
-> ExceptT ByronGenesisError IO (Genesis.GenesisData, Genesis.GeneratedSecrets)
mkGenesis :: GenesisParameters
-> ExceptT ByronGenesisError IO (GenesisData, GeneratedSecrets)
mkGenesis GenesisParameters
gp = do
GenesisSpec
genesisSpec <- GenesisParameters -> ExceptT ByronGenesisError IO GenesisSpec
mkGenesisSpec GenesisParameters
gp
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT GenesisDataGenerationError -> ByronGenesisError
GenesisGenerationError forall a b. (a -> b) -> a -> b
$
UTCTime
-> GenesisSpec
-> ExceptT
GenesisDataGenerationError IO (GenesisData, GeneratedSecrets)
Genesis.generateGenesisData (GenesisParameters -> UTCTime
gpStartTime GenesisParameters
gp) GenesisSpec
genesisSpec
readGenesis :: GenesisFile
-> NetworkId
-> ExceptT ByronGenesisError IO Genesis.Config
readGenesis :: GenesisFile -> NetworkId -> ExceptT ByronGenesisError IO Config
readGenesis (GenesisFile FilePath
file) NetworkId
nw =
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
firstExceptT (FilePath -> GenesisDataError -> ByronGenesisError
GenesisReadError FilePath
file) forall a b. (a -> b) -> a -> b
$ do
(GenesisData
genesisData, GenesisHash
genesisHash) <- forall (m :: * -> *).
(MonadError GenesisDataError m, MonadIO m) =>
FilePath -> m (GenesisData, GenesisHash)
Genesis.readGenesisData FilePath
file
forall (m :: * -> *) a. Monad m => a -> m a
return Genesis.Config {
configGenesisData :: GenesisData
Genesis.configGenesisData = GenesisData
genesisData,
configGenesisHash :: GenesisHash
Genesis.configGenesisHash = GenesisHash
genesisHash,
configReqNetMagic :: RequiresNetworkMagic
Genesis.configReqNetMagic = NetworkId -> RequiresNetworkMagic
toByronRequiresNetworkMagic NetworkId
nw,
configUTxOConfiguration :: UTxOConfiguration
Genesis.configUTxOConfiguration = UTxOConfiguration
UTxO.defaultUTxOConfiguration
}
dumpGenesis
:: NewDirectory
-> Genesis.GenesisData
-> Genesis.GeneratedSecrets
-> ExceptT ByronGenesisError IO ()
dumpGenesis :: NewDirectory
-> GenesisData
-> GeneratedSecrets
-> ExceptT ByronGenesisError IO ()
dumpGenesis (NewDirectory FilePath
outDir) GenesisData
genesisData GeneratedSecrets
gs = do
Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesPathExist FilePath
outDir
if Bool
exists
then forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall a b. (a -> b) -> a -> b
$ FilePath -> ByronGenesisError
GenesisOutputDirAlreadyExists FilePath
outDir
else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
createDirectory FilePath
outDir
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
LB.writeFile FilePath
genesisJSONFile (forall a. ToJSON Identity a => a -> ByteString
canonicalEncodePretty GenesisData
genesisData)
[Certificate]
dlgCerts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SigningKey ByronKey -> ExceptT ByronGenesisError IO Certificate
findDelegateCert forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey -> SigningKey ByronKey
ByronSigningKey) forall a b. (a -> b) -> a -> b
$ GeneratedSecrets -> [SigningKey]
gsRichSecrets GeneratedSecrets
gs
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. FilePath -> FilePath -> (a -> ByteString) -> [a] -> IO ()
wOut FilePath
"genesis-keys" FilePath
"key"
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes
(forall a b. (a -> b) -> [a] -> [b]
map SigningKey -> SigningKey ByronKey
ByronSigningKey forall a b. (a -> b) -> a -> b
$ GeneratedSecrets -> [SigningKey]
gsDlgIssuersSecrets GeneratedSecrets
gs)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. FilePath -> FilePath -> (a -> ByteString) -> [a] -> IO ()
wOut FilePath
"delegate-keys" FilePath
"key"
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes
(forall a b. (a -> b) -> [a] -> [b]
map SigningKey -> SigningKey ByronKey
ByronSigningKey forall a b. (a -> b) -> a -> b
$ GeneratedSecrets -> [SigningKey]
gsRichSecrets GeneratedSecrets
gs)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. FilePath -> FilePath -> (a -> ByteString) -> [a] -> IO ()
wOut FilePath
"poor-keys" FilePath
"key"
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes
(forall a b. (a -> b) -> [a] -> [b]
map (SigningKey -> SigningKey ByronKey
ByronSigningKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoorSecret -> SigningKey
Genesis.poorSecretToKey) forall a b. (a -> b) -> a -> b
$ GeneratedSecrets -> [PoorSecret]
gsPoorSecrets GeneratedSecrets
gs)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. FilePath -> FilePath -> (a -> ByteString) -> [a] -> IO ()
wOut FilePath
"delegation-cert" FilePath
"json" Certificate -> ByteString
serialiseDelegationCert [Certificate]
dlgCerts
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. FilePath -> FilePath -> (a -> ByteString) -> [a] -> IO ()
wOut FilePath
"avvm-secrets" FilePath
"secret" RedeemSigningKey -> ByteString
printFakeAvvmSecrets forall a b. (a -> b) -> a -> b
$ GeneratedSecrets -> [RedeemSigningKey]
gsFakeAvvmSecrets GeneratedSecrets
gs
where
dlgCertMap :: Map Common.KeyHash Certificate
dlgCertMap :: Map KeyHash Certificate
dlgCertMap = GenesisDelegation -> Map KeyHash Certificate
Genesis.unGenesisDelegation forall a b. (a -> b) -> a -> b
$ GenesisData -> GenesisDelegation
Genesis.gdHeavyDelegation GenesisData
genesisData
findDelegateCert :: SigningKey ByronKey -> ExceptT ByronGenesisError IO Certificate
findDelegateCert :: SigningKey ByronKey -> ExceptT ByronGenesisError IO Certificate
findDelegateCert bSkey :: SigningKey ByronKey
bSkey@(ByronSigningKey SigningKey
sk) =
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (SigningKey -> Certificate -> Bool
isCertForSK SigningKey
sk) (forall k a. Map k a -> [a]
Map.elems Map KeyHash Certificate
dlgCertMap) of
Maybe Certificate
Nothing -> forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByronGenesisError
NoGenesisDelegationForKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerificationKey ByronKey -> Text
prettyPublicKey forall a b. (a -> b) -> a -> b
$ forall keyrole.
Key keyrole =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey ByronKey
bSkey
Just Certificate
x -> forall (m :: * -> *) a x. Monad m => a -> ExceptT x m a
right Certificate
x
genesisJSONFile :: FilePath
genesisJSONFile :: FilePath
genesisJSONFile = FilePath
outDir forall a. Semigroup a => a -> a -> a
<> FilePath
"/genesis.json"
printFakeAvvmSecrets :: Crypto.RedeemSigningKey -> ByteString
printFakeAvvmSecrets :: RedeemSigningKey -> ByteString
printFakeAvvmSecrets RedeemSigningKey
rskey = Text -> ByteString
Text.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText forall a b. (a -> b) -> a -> b
$ forall p. Buildable p => p -> Builder
build RedeemSigningKey
rskey
isCertForSK :: Crypto.SigningKey -> Certificate -> Bool
isCertForSK :: SigningKey -> Certificate -> Bool
isCertForSK SigningKey
sk Certificate
cert = forall a. ACertificate a -> VerificationKey
delegateVK Certificate
cert forall a. Eq a => a -> a -> Bool
== SigningKey -> VerificationKey
Crypto.toVerification SigningKey
sk
wOut :: String -> String -> (a -> ByteString) -> [a] -> IO ()
wOut :: forall a. FilePath -> FilePath -> (a -> ByteString) -> [a] -> IO ()
wOut = forall a.
FilePath
-> FilePath -> FilePath -> (a -> ByteString) -> [a] -> IO ()
writeSecrets FilePath
outDir