diff --git a/cabal.project b/cabal.project index 5349ded5f0b..8305084b045 100644 --- a/cabal.project +++ b/cabal.project @@ -330,6 +330,12 @@ source-repository-package tag: ee59880f47ab835dbd73bea0847dab7869fc20d8 --sha256: 1lrzknw765pz2j97nvv9ip3l1mcpf2zr4n56hwlz0rk7wq7ls4cm +source-repository-package + type: git + location: https://github.com/input-output-hk/aeson + tag: be4774468e651d1d512edad278cca7276e978034 + --sha256: 12fr5xnr3ax0r5gzwbf4v49yirppgprmvzlfj1ldx4zhcrdf5j7j + constraints: hedgehog >= 1.0 , bimap >= 0.4.0 diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 2a34795e3ed..682a8fe16aa 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -117,7 +117,6 @@ library , cardano-protocol-tpraos , cardano-slotting , cborg - , vector-map , contra-tracer , containers , cryptonite @@ -141,6 +140,7 @@ library , plutus-ledger-api , prettyprinter , prettyprinter-configurable + , random , scientific , serialise , small-steps @@ -155,6 +155,7 @@ library , typed-protocols , unordered-containers >= 0.2.11 , vector + , vector-map , yaml library gen diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 86aa035c136..1fc337dc947 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -48,6 +48,7 @@ module Cardano.Api ( castVerificationKey, castSigningKey, generateSigningKey, + generateInsecureSigningKey, -- ** Hashes -- | In Cardano most keys are identified by their hash, and hashes are diff --git a/cardano-api/src/Cardano/Api/Address.hs b/cardano-api/src/Cardano/Api/Address.hs index 561a2e1e1c7..17bfe22351d 100644 --- a/cardano-api/src/Cardano/Api/Address.hs +++ b/cardano-api/src/Cardano/Api/Address.hs @@ -106,6 +106,7 @@ import Cardano.Api.Script import Cardano.Api.SerialiseBech32 import Cardano.Api.SerialiseRaw import Cardano.Api.Utils +import Control.DeepSeq (NFData(..), deepseq) @@ -192,6 +193,10 @@ deriving instance Eq (Address addrtype) deriving instance Ord (Address addrtype) deriving instance Show (Address addrtype) +instance NFData (Address addrtype) where + rnf = \case + ByronAddress address -> deepseq address () + ShelleyAddress n pc sr -> deepseq (deepseq (deepseq n pc) sr) () instance HasTypeProxy addrtype => HasTypeProxy (Address addrtype) where data AsType (Address addrtype) = AsAddress (AsType addrtype) @@ -337,6 +342,9 @@ data AddressInEra era where -> Address addrtype -> AddressInEra era +instance NFData (AddressInEra era) where + rnf (AddressInEra t a) = deepseq (deepseq t a) () + instance IsCardanoEra era => ToJSON (AddressInEra era) where toJSON = Aeson.String . serialiseAddress @@ -387,6 +395,10 @@ data AddressTypeInEra addrtype era where deriving instance Show (AddressTypeInEra addrtype era) +instance NFData (AddressTypeInEra addrtype era) where + rnf = \case + ByronAddressInAnyEra -> () + ShelleyAddressInEra sbe -> deepseq sbe () instance HasTypeProxy era => HasTypeProxy (AddressInEra era) where data AsType (AddressInEra era) = AsAddressInEra (AsType era) diff --git a/cardano-api/src/Cardano/Api/Eras.hs b/cardano-api/src/Cardano/Api/Eras.hs index bd0addb7b96..70cb69c5688 100644 --- a/cardano-api/src/Cardano/Api/Eras.hs +++ b/cardano-api/src/Cardano/Api/Eras.hs @@ -55,6 +55,7 @@ import Ouroboros.Consensus.Shelley.Eras as Consensus (StandardAllegra, StandardBabbage, StandardMary, StandardShelley) import Cardano.Api.HasTypeProxy +import Control.DeepSeq (NFData(..)) -- | A type used as a tag to distinguish the Byron era. @@ -306,6 +307,14 @@ data ShelleyBasedEra era where ShelleyBasedEraAlonzo :: ShelleyBasedEra AlonzoEra ShelleyBasedEraBabbage :: ShelleyBasedEra BabbageEra +instance NFData (ShelleyBasedEra era) where + rnf = \case + ShelleyBasedEraShelley -> () + ShelleyBasedEraAllegra -> () + ShelleyBasedEraMary -> () + ShelleyBasedEraAlonzo -> () + ShelleyBasedEraBabbage -> () + deriving instance Eq (ShelleyBasedEra era) deriving instance Ord (ShelleyBasedEra era) deriving instance Show (ShelleyBasedEra era) diff --git a/cardano-api/src/Cardano/Api/Key.hs b/cardano-api/src/Cardano/Api/Key.hs index db98a42c059..2000cd8ae17 100644 --- a/cardano-api/src/Cardano/Api/Key.hs +++ b/cardano-api/src/Cardano/Api/Key.hs @@ -5,6 +5,7 @@ module Cardano.Api.Key ( Key(..) , generateSigningKey + , generateInsecureSigningKey , CastVerificationKeyRole(..) , CastSigningKeyRole(..) , AsType(AsVerificationKey, AsSigningKey) @@ -21,7 +22,9 @@ import Cardano.Api.Hash import Cardano.Api.HasTypeProxy import Cardano.Api.SerialiseRaw import Cardano.Api.SerialiseTextEnvelope +import System.Random (StdGen) +import qualified System.Random as Random -- | An interface for cryptographic keys used for signatures with a 'SigningKey' -- and a 'VerificationKey' key. @@ -67,6 +70,17 @@ generateSigningKey keytype = do seedSize = deterministicSigningKeySeedSize keytype +generateInsecureSigningKey + :: (Key keyrole, SerialiseAsRawBytes (SigningKey keyrole)) + => StdGen + -> AsType keyrole + -> IO (SigningKey keyrole, StdGen) +generateInsecureSigningKey g keytype = do + let (bs, g') = Random.genByteString (fromIntegral $ deterministicSigningKeySeedSize keytype) g + case deserialiseFromRawBytes (AsSigningKey keytype) bs of + Just key -> return (key, g') + Nothing -> error "generateInsecureSigningKey: Unable to generate insecure key" + instance HasTypeProxy a => HasTypeProxy (VerificationKey a) where data AsType (VerificationKey a) = AsVerificationKey (AsType a) proxyToAsType _ = AsVerificationKey (proxyToAsType (Proxy :: Proxy a)) diff --git a/cardano-api/src/Cardano/Api/KeysShelley.hs b/cardano-api/src/Cardano/Api/KeysShelley.hs index 1cca72bcdd6..d4c5b0dd74c 100644 --- a/cardano-api/src/Cardano/Api/KeysShelley.hs +++ b/cardano-api/src/Cardano/Api/KeysShelley.hs @@ -323,8 +323,9 @@ instance HasTypeProxy StakeKey where instance Key StakeKey where - newtype VerificationKey StakeKey = - StakeVerificationKey (Shelley.VKey Shelley.Staking StandardCrypto) + newtype VerificationKey StakeKey = StakeVerificationKey + { unStakeVerificationKey :: Shelley.VKey Shelley.Staking StandardCrypto + } deriving stock (Eq) deriving newtype (ToCBOR, FromCBOR) deriving anyclass SerialiseAsCBOR diff --git a/cardano-api/src/Cardano/Api/TxBody.hs b/cardano-api/src/Cardano/Api/TxBody.hs index 0cab7712481..d3e418f246c 100644 --- a/cardano-api/src/Cardano/Api/TxBody.hs +++ b/cardano-api/src/Cardano/Api/TxBody.hs @@ -2680,8 +2680,8 @@ getByronTxBodyContent (Annotated Byron.UnsafeTx{txInputs, txOutputs} _) = txScriptValidity = TxScriptValidityNone } -makeShelleyTransactionBody :: () - => ShelleyBasedEra era +makeShelleyTransactionBody + :: ShelleyBasedEra era -> TxBodyContent BuildTx era -> Either TxBodyError (TxBody era) makeShelleyTransactionBody era@ShelleyBasedEraShelley diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index b16fa3cf477..cd69dacf268 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -70,6 +70,8 @@ library Cardano.CLI.Byron.UpdateProposal Cardano.CLI.Byron.Vote + Cardano.CLI.IO.Lazy + Cardano.CLI.Shelley.Commands Cardano.CLI.Shelley.Key Cardano.CLI.Shelley.Orphans @@ -135,6 +137,7 @@ library , ouroboros-network , parsec , prettyprinter + , random , cardano-ledger-shelley , set-algebra , split @@ -143,6 +146,7 @@ library , time , transformers , transformers-except + , unliftio-core , utf8-string , vector , yaml diff --git a/cardano-cli/src/Cardano/CLI/IO/Lazy.hs b/cardano-cli/src/Cardano/CLI/IO/Lazy.hs new file mode 100644 index 00000000000..d4fe2d5b6ca --- /dev/null +++ b/cardano-cli/src/Cardano/CLI/IO/Lazy.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.CLI.IO.Lazy + ( replicateM + , sequenceM + , traverseM + , traverseStateM + , forM + , forStateM + ) where + +import Control.Applicative (Applicative((<*>), pure), (<$>)) +import Control.Monad (Monad(..)) +import Control.Monad.IO.Unlift (MonadIO(liftIO), MonadUnliftIO, askUnliftIO, UnliftIO(unliftIO)) +import Data.Function (($), (.), flip) +import Data.Int (Int) +import System.IO (IO) + +import qualified Data.List as L +import qualified System.IO.Unsafe as IO + +replicateM :: MonadUnliftIO m => Int -> m a -> m [a] +replicateM n f = sequenceM (L.replicate n f) + +sequenceM :: MonadUnliftIO m => [m a] -> m [a] +sequenceM as = do + f <- askUnliftIO + liftIO $ sequenceIO (L.map (unliftIO f) as) + +-- | Traverses the function over the list and produces a lazy list in a +-- monadic context. +-- +-- It is intended to be like the "standard" 'traverse' except +-- that the list is generated lazily. +traverseM :: MonadUnliftIO m => (a -> m b) -> [a] -> m [b] +traverseM f as = do + u <- askUnliftIO + liftIO $ IO.unsafeInterleaveIO (go u as) + where + go _ [] = pure [] + go !u (v:vs) = do + !res <- unliftIO u (f v) + rest <- IO.unsafeInterleaveIO (go u vs) + pure (res:rest) + +traverseStateM :: forall m s a b. MonadUnliftIO m => s -> (s -> a -> m (s, b)) -> [a] -> m [b] +traverseStateM s f as = do + u <- askUnliftIO + liftIO $ IO.unsafeInterleaveIO (go s u as) + where + go :: s -> UnliftIO m -> [a] -> IO [b] + go _ _ [] = pure [] + go t !u (v:vs) = do + (t', !res) <- unliftIO u (f t v) + rest <- IO.unsafeInterleaveIO (go t' u vs) + pure (res:rest) + +forM :: MonadUnliftIO m => [a] -> (a -> m b) -> m [b] +forM = flip traverseM + +forStateM :: MonadUnliftIO m => s -> [a] -> (s -> a -> m (s, b)) -> m [b] +forStateM s as f = traverseStateM s f as + +-- Internal +sequenceIO :: [IO a] -> IO [a] +sequenceIO = IO.unsafeInterleaveIO . go + where go :: [IO a] -> IO [a] + go [] = return [] + go (fa:fas) = (:) <$> fa <*> IO.unsafeInterleaveIO (go fas) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Key.hs b/cardano-cli/src/Cardano/CLI/Shelley/Key.hs index 99ef27fbf90..11006e69fd1 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Key.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Key.hs @@ -34,6 +34,8 @@ module Cardano.CLI.Shelley.Key , PaymentVerifier(..) , StakeVerifier(..) + + , generateKeyPair ) where import Cardano.Prelude @@ -481,3 +483,8 @@ readVerificationKeyOrHashOrTextEnvFile asType verKeyOrHashOrFile = eitherVk <- readVerificationKeyOrTextEnvFile asType vkOrFile pure (verificationKeyHash <$> eitherVk) VerificationKeyHash vkHash -> pure (Right vkHash) + +generateKeyPair :: Key keyrole => AsType keyrole -> IO (VerificationKey keyrole, SigningKey keyrole) +generateKeyPair asType = do + skey <- generateSigningKey asType + return (getVerificationKey skey, skey) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Address.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Address.hs index de7348d5a2c..b6581f5eb7d 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Address.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Address.hs @@ -7,8 +7,9 @@ module Cardano.CLI.Shelley.Run.Address , buildShelleyAddress , renderShelleyAddressCmdError , runAddressCmd - , runAddressKeyGen + , runAddressKeyGenToFile , readAddressVerificationKeyTextOrFile + , makeStakeAddressRef ) where import Cardano.Prelude hiding (putStrLn) @@ -26,7 +27,7 @@ import Cardano.Api.Shelley import Cardano.CLI.Helpers import Cardano.CLI.Shelley.Key (InputDecodeError, PaymentVerifier (..), StakeVerifier (..), VerificationKeyTextOrFile, - VerificationKeyTextOrFileError (..), readVerificationKeyOrFile, + VerificationKeyTextOrFileError (..), generateKeyPair, readVerificationKeyOrFile, readVerificationKeyTextOrFileAnyOf, renderVerificationKeyTextOrFileError) import Cardano.CLI.Shelley.Parsers (AddressCmd (..), AddressKeyType (..), OutputFile (..)) import Cardano.CLI.Shelley.Run.Address.Info (ShelleyAddressInfoError, runAddressInfo) @@ -57,37 +58,47 @@ renderShelleyAddressCmdError err = runAddressCmd :: AddressCmd -> ExceptT ShelleyAddressCmdError IO () runAddressCmd cmd = case cmd of - AddressKeyGen kt vkf skf -> runAddressKeyGen kt vkf skf + AddressKeyGen kt vkf skf -> runAddressKeyGenToFile kt vkf skf AddressKeyHash vkf mOFp -> runAddressKeyHash vkf mOFp AddressBuild paymentVerifier mbStakeVerifier nw mOutFp -> runAddressBuild paymentVerifier mbStakeVerifier nw mOutFp AddressBuildMultiSig sFp nId mOutFp -> runAddressBuildScript sFp nId mOutFp AddressInfo txt mOFp -> firstExceptT ShelleyAddressCmdAddressInfoError $ runAddressInfo txt mOFp -runAddressKeyGen :: AddressKeyType - -> VerificationKeyFile - -> SigningKeyFile - -> ExceptT ShelleyAddressCmdError IO () -runAddressKeyGen kt (VerificationKeyFile vkeyPath) (SigningKeyFile skeyPath) = - case kt of - AddressKeyShelley -> generateAndWriteKeyFiles AsPaymentKey - AddressKeyShelleyExtended -> generateAndWriteKeyFiles AsPaymentExtendedKey - AddressKeyByron -> generateAndWriteKeyFiles AsByronKey +runAddressKeyGenToFile + :: AddressKeyType + -> VerificationKeyFile + -> SigningKeyFile + -> ExceptT ShelleyAddressCmdError IO () +runAddressKeyGenToFile kt vkf skf = case kt of + AddressKeyShelley -> generateAndWriteKeyFiles AsPaymentKey vkf skf + AddressKeyShelleyExtended -> generateAndWriteKeyFiles AsPaymentExtendedKey vkf skf + AddressKeyByron -> generateAndWriteKeyFiles AsByronKey vkf skf + +generateAndWriteKeyFiles + :: Key keyrole + => AsType keyrole + -> VerificationKeyFile + -> SigningKeyFile + -> ExceptT ShelleyAddressCmdError IO () +generateAndWriteKeyFiles asType vkf skf = do + uncurry (writePaymentKeyFiles vkf skf) =<< liftIO (generateKeyPair asType) + +writePaymentKeyFiles + :: Key keyrole + => VerificationKeyFile + -> SigningKeyFile + -> VerificationKey keyrole + -> SigningKey keyrole + -> ExceptT ShelleyAddressCmdError IO () +writePaymentKeyFiles (VerificationKeyFile vkeyPath) (SigningKeyFile skeyPath) vkey skey = do + firstExceptT ShelleyAddressCmdWriteFileError $ do + newExceptT $ writeFileTextEnvelope skeyPath (Just skeyDesc) skey + newExceptT $ writeFileTextEnvelope vkeyPath (Just vkeyDesc) vkey where - generateAndWriteKeyFiles asType = do - skey <- liftIO $ generateSigningKey asType - let vkey = getVerificationKey skey - firstExceptT ShelleyAddressCmdWriteFileError - . newExceptT - $ writeFileTextEnvelope skeyPath (Just skeyDesc) skey - firstExceptT ShelleyAddressCmdWriteFileError - . newExceptT - $ writeFileTextEnvelope vkeyPath (Just vkeyDesc) vkey - skeyDesc, vkeyDesc :: TextEnvelopeDescr skeyDesc = "Payment Signing Key" vkeyDesc = "Payment Verification Key" - runAddressKeyHash :: VerificationKeyTextOrFile -> Maybe OutputFile -> ExceptT ShelleyAddressCmdError IO () @@ -136,26 +147,23 @@ runAddressBuild paymentVerifier mbStakeVerifier nw mOutFp = do let payCred = PaymentCredentialByScript (hashScript script) - serialiseAddress . makeShelleyAddress nw payCred <$> makeStakeAddressRef mbStakeVerifier + stakeAddressReference <- maybe (return NoStakeAddress) makeStakeAddressRef mbStakeVerifier + + return $ serialiseAddress . makeShelleyAddress nw payCred $ stakeAddressReference case mOutFp of Just (OutputFile fpath) -> liftIO $ Text.writeFile fpath outText Nothing -> liftIO $ Text.putStr outText makeStakeAddressRef - :: Maybe StakeVerifier + :: StakeVerifier -> ExceptT ShelleyAddressCmdError IO StakeAddressReference -makeStakeAddressRef mbStakeVerifier = do - case mbStakeVerifier of - Nothing -> pure NoStakeAddress - Just stakeVerifier -> case stakeVerifier of +makeStakeAddressRef stakeVerifier = case stakeVerifier of StakeVerifierKey stkVkeyOrFile -> do - mstakeVKey <- firstExceptT ShelleyAddressCmdReadKeyFileError $ - fmap Just $ newExceptT $ readVerificationKeyOrFile AsStakeKey stkVkeyOrFile + stakeVKey <- firstExceptT ShelleyAddressCmdReadKeyFileError $ + newExceptT $ readVerificationKeyOrFile AsStakeKey stkVkeyOrFile - return $ maybe NoStakeAddress - (StakeAddressByValue . StakeCredentialByKey . verificationKeyHash) - mstakeVKey + return . StakeAddressByValue . StakeCredentialByKey . verificationKeyHash $ stakeVKey StakeVerifierScriptFile (ScriptFile fp) -> do ScriptInAnyLang _lang script <- @@ -171,7 +179,7 @@ buildShelleyAddress -> NetworkId -> ExceptT ShelleyAddressCmdError IO (Address ShelleyAddr) buildShelleyAddress vkey mbStakeVerifier nw = - makeShelleyAddress nw (PaymentCredentialByKey (verificationKeyHash vkey)) <$> makeStakeAddressRef mbStakeVerifier + makeShelleyAddress nw (PaymentCredentialByKey (verificationKeyHash vkey)) <$> maybe (return NoStakeAddress) makeStakeAddressRef mbStakeVerifier -- diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs index 9b0befc1114..02f1631ca0c 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs @@ -1,11 +1,18 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{- HLINT ignore "Reduce duplication" -} +{- HLINT ignore "Use let" -} module Cardano.CLI.Shelley.Run.Genesis ( ShelleyGenesisCmdError(..) @@ -20,15 +27,14 @@ import Prelude (id, unlines, zip3, error) import Data.Aeson hiding (Key) import qualified Data.Aeson as Aeson -import qualified Data.Aeson.KeyMap as Aeson import Data.Aeson.Encode.Pretty (encodePretty) +import qualified Data.Aeson.KeyMap as Aeson import qualified Data.Binary.Get as Bin import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Coerce (coerce) import qualified Data.List as List import qualified Data.List.Split as List -import Data.ListMap (ListMap(ListMap)) import qualified Data.ListMap as ListMap import qualified Data.Map.Strict as Map @@ -56,8 +62,8 @@ import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT import qualified Cardano.Crypto.Hash as Crypto import Cardano.Api -import Cardano.Api.Shelley import Cardano.Api.Byron (toByronRequiresNetworkMagic, toByronProtocolMagicId, toByronLovelace) +import Cardano.Api.Shelley import Ouroboros.Consensus.BlockchainTime (SystemStart (..)) import Ouroboros.Consensus.Shelley.Eras (StandardShelley) @@ -82,7 +88,7 @@ import Cardano.CLI.Shelley.Run.Node (ShelleyNodeCmdError (..), renderS runNodeIssueOpCert, runNodeKeyGenCold, runNodeKeyGenKES, runNodeKeyGenVRF) import Cardano.CLI.Shelley.Run.Pool (ShelleyPoolCmdError (..), renderShelleyPoolCmdError) import Cardano.CLI.Shelley.Run.StakeAddress (ShelleyStakeAddressCmdError (..), - renderShelleyStakeAddressCmdError, runStakeAddressKeyGen) + renderShelleyStakeAddressCmdError, runStakeAddressKeyGenToFile) import Cardano.CLI.Types import Cardano.CLI.Byron.Delegation @@ -103,7 +109,12 @@ import Data.Fixed (Fixed(MkFixed)) import qualified Data.Yaml as Yaml import Text.JSON.Canonical (parseCanonicalJSON, renderCanonicalJSON) -{- HLINT ignore "Reduce duplication" -} +import Data.ListMap (ListMap(..)) + +import qualified Cardano.CLI.IO.Lazy as Lazy + +import qualified System.Random as Random +import System.Random (StdGen) data ShelleyGenesisCmdError = ShelleyGenesisCmdAesonDecodeError !FilePath !Text @@ -685,38 +696,36 @@ runGenesisCreateStaked (GenesisDir rootdir) forM_ (zip [ 1 .. bulkPoolCredFiles ] bulkSlices) $ uncurry (writeBulkPoolCredentials pooldir) - forM_ [ 1 .. genNumStDelegs ] $ \index -> - createDelegatorCredentials stdeldir index - - delegations :: [Delegation] <- - -- Distribute M delegates across N pools: - forM [ (pool, delegIx) - | (pool, poolIx) <- zip pools [1 ..] - , delegIxLocal <- [ 1 .. delegsPerPool ] ++ - -- Add all remaining delegates to the last pool: - if delegsRemaining /= 0 && poolIx == genNumPools - then [ delegsPerPool + 1 .. delegsPerPool + delegsRemaining ] - else [] - , let delegIx = delegIxLocal + delegsPerPool * (poolIx - 1)] $ - uncurry (computeDelegation network stdeldir) + let (delegsPerPool, delegsRemaining) = divMod genNumStDelegs genNumPools + delegsForPool poolIx = if delegsRemaining /= 0 && poolIx == genNumPools + then delegsPerPool + else delegsPerPool + delegsRemaining + distribution = [pool | (pool, poolIx) <- zip pools [1 ..], _ <- [1 .. delegsForPool poolIx]] + + g <- Random.getStdGen + + -- Distribute M delegates across N pools: + delegations <- liftIO $ Lazy.forStateM g distribution $ flip computeInsecureDelegation network + + let numDelegations = length delegations genDlgs <- readGenDelegsMap gendir deldir nonDelegAddrs <- readInitialFundAddresses utxodir network start <- maybe (SystemStart <$> getCurrentTimePlus30) pure mStart - stuffedUtxoAddrs <- liftIO $ replicateM (fromIntegral numStuffedUtxo) - genStuffedAddress + stuffedUtxoAddrs <- liftIO $ Lazy.replicateM (fromIntegral numStuffedUtxo) genStuffedAddress - let poolMap :: Map (Ledger.KeyHash Ledger.Staking StandardCrypto) (Ledger.PoolParams StandardCrypto) - poolMap = Map.fromList $ mkDelegationMapEntry <$> delegations + let stake = second Ledger._poolId . mkDelegationMapEntry <$> delegations + stakePools = [ (Ledger._poolId poolParams, poolParams) | poolParams <- snd . mkDelegationMapEntry <$> delegations ] delegAddrs = dInitialUtxoAddr <$> delegations - shelleyGenesis = - updateTemplate + !shelleyGenesis = + updateCreateStakedOutputTemplate -- Shelley genesis parameters - start genDlgs mNonDlgAmount nonDelegAddrs poolMap - stDlgAmount delegAddrs stuffedUtxoAddrs template + start genDlgs mNonDlgAmount (length nonDelegAddrs) nonDelegAddrs stakePools stake + stDlgAmount numDelegations delegAddrs stuffedUtxoAddrs template + + liftIO $ LBS.writeFile (rootdir "genesis.json") $ Aeson.encode shelleyGenesis - writeFileGenesis (rootdir "genesis.json") shelleyGenesis writeFileGenesis (rootdir "genesis.alonzo.json") alonzoGenesis --TODO: rationalise the naming convention on these genesis json files. @@ -726,9 +735,7 @@ runGenesisCreateStaked (GenesisDir rootdir) , textShow genNumUTxOKeys, " non-delegating UTxO keys, " , textShow genNumPools, " stake pools, " , textShow genNumStDelegs, " delegating UTxO keys, " - , textShow (length delegations), " delegation relationships, " - , textShow (Map.size poolMap), " delegation map entries, " - , textShow (length delegAddrs), " delegating addresses" + , textShow numDelegations, " delegation map entries, " ] ++ [ mconcat [ ", " @@ -741,7 +748,6 @@ runGenesisCreateStaked (GenesisDir rootdir) | bulkPoolCredFiles * bulkPoolsPerFile > 0 ] where - (,) delegsPerPool delegsRemaining = divMod genNumStDelegs genNumPools adjustTemplate t = t { sgNetworkMagic = unNetworkMagic (toNetworkMagic network) } mkDelegationMapEntry :: Delegation -> (Ledger.KeyHash Ledger.Staking StandardCrypto, Ledger.PoolParams StandardCrypto) mkDelegationMapEntry d = (dDelegStaking d, dPoolParams d) @@ -837,7 +843,7 @@ createPoolCredentials dir index = do (KESPeriod 0) (OutputFile $ dir "opcert" ++ strIndex ++ ".cert") firstExceptT ShelleyGenesisCmdStakeAddressCmdError $ - runStakeAddressKeyGen + runStakeAddressKeyGenToFile (VerificationKeyFile $ dir "staking-reward" ++ strIndex ++ ".vkey") (SigningKeyFile $ dir "staking-reward" ++ strIndex ++ ".skey") where @@ -846,28 +852,12 @@ createPoolCredentials dir index = do coldSK = SigningKeyFile $ dir "cold" ++ strIndex ++ ".skey" opCertCtr = OpCertCounterFile $ dir "opcert" ++ strIndex ++ ".counter" -createDelegatorCredentials :: FilePath -> Word -> ExceptT ShelleyGenesisCmdError IO () -createDelegatorCredentials dir index = do - liftIO $ createDirectoryIfMissing False dir - firstExceptT ShelleyGenesisCmdAddressCmdError $ do - runAddressKeyGen - AddressKeyShelley - addrVK - (SigningKeyFile $ dir "payment" ++ strIndex ++ ".skey") - firstExceptT ShelleyGenesisCmdStakeAddressCmdError $ - runStakeAddressKeyGen - (VerificationKeyFile $ dir "staking" ++ strIndex ++ ".vkey") - (SigningKeyFile $ dir "staking" ++ strIndex ++ ".skey") - where - strIndex = show index - addrVK = VerificationKeyFile $ dir "payment" ++ strIndex ++ ".vkey" - -data Delegation - = Delegation - { dInitialUtxoAddr :: AddressInEra ShelleyEra - , dDelegStaking :: Ledger.KeyHash Ledger.Staking StandardCrypto - , dPoolParams :: Ledger.PoolParams StandardCrypto - } +data Delegation = Delegation + { dInitialUtxoAddr :: !(AddressInEra ShelleyEra) + , dDelegStaking :: !(Ledger.KeyHash Ledger.Staking StandardCrypto) + , dPoolParams :: !(Ledger.PoolParams StandardCrypto) + } + deriving (Generic, NFData) buildPool :: NetworkId -> FilePath -> Word -> ExceptT ShelleyGenesisCmdError IO (Ledger.PoolParams StandardCrypto) buildPool nw dir index = do @@ -926,31 +916,27 @@ writeBulkPoolCredentials dir bulkIx poolIxs = do firstExceptT (ShelleyGenesisCmdAesonDecodeError fp . Text.pack) . hoistEither $ Aeson.eitherDecodeStrict' content -computeDelegation :: NetworkId -> FilePath -> Ledger.PoolParams StandardCrypto -> Word -> ExceptT ShelleyGenesisCmdError IO Delegation -computeDelegation nw delegDir pool delegIx = do - paySVK <- firstExceptT (ShelleyGenesisCmdAddressCmdError - . ShelleyAddressCmdVerificationKeyTextOrFileError) $ - readAddressVerificationKeyTextOrFile - (VktofVerificationKeyFile payVKF) - initialUtxoAddr <- case paySVK of - APaymentVerificationKey payVK -> - firstExceptT ShelleyGenesisCmdAddressCmdError - $ buildShelleyAddress payVK (Just . StakeVerifierKey . VerificationKeyFilePath . VerificationKeyFile $ stakeVKF) nw - _ -> left $ ShelleyGenesisCmdUnexpectedAddressVerificationKey payVKF "APaymentVerificationKey" paySVK - - StakeVerificationKey stakeVK <- firstExceptT ShelleyGenesisCmdTextEnvReadFileError - . newExceptT - $ readFileTextEnvelope (AsVerificationKey AsStakeKey) stakeVKF +-- | This function should only be used for testing purposes. +-- Keys returned by this function are not cryptographically secure. +computeInsecureDelegation + :: StdGen + -> NetworkId + -> Ledger.PoolParams StandardCrypto + -> IO (StdGen, Delegation) +computeInsecureDelegation g0 nw pool = do + (paymentVK, g1) <- fmap (first getVerificationKey) $ generateInsecureSigningKey g0 AsPaymentKey + (stakeVK , g2) <- fmap (first getVerificationKey) $ generateInsecureSigningKey g1 AsStakeKey - pure Delegation + let stakeAddressReference = StakeAddressByValue . StakeCredentialByKey . verificationKeyHash $ stakeVK + let initialUtxoAddr = makeShelleyAddress nw (PaymentCredentialByKey (verificationKeyHash paymentVK)) stakeAddressReference + + delegation <- pure $ force Delegation { dInitialUtxoAddr = shelleyAddressInEra initialUtxoAddr - , dDelegStaking = Ledger.hashKey stakeVK + , dDelegStaking = Ledger.hashKey (unStakeVerificationKey stakeVK) , dPoolParams = pool } - where - strIndexDeleg = show delegIx - payVKF = VerificationKeyFile $ delegDir "payment" ++ strIndexDeleg ++ ".vkey" - stakeVKF = delegDir "staking" ++ strIndexDeleg ++ ".vkey" + + pure (g2, delegation) -- | Current UTCTime plus 30 seconds getCurrentTimePlus30 :: ExceptT a IO UTCTime @@ -979,7 +965,7 @@ readShelleyGenesisWithDefault fpath adjustDefaults = do writeDefault = do handleIOExceptT (ShelleyGenesisCmdGenesisFileError . FileIOError fpath) $ - LBS.writeFile fpath (encodePretty defaults) + LBS.writeFile fpath (encode defaults) return defaults readAndDecodeShelleyGenesis @@ -991,18 +977,25 @@ readAndDecodeShelleyGenesis fpath = runExceptT $ do . hoistEither $ Aeson.eitherDecode' lbs updateTemplate + -- | System start time :: SystemStart - -- Genesis delegation (not stake-based): + -- | Genesis delegation (not stake-based) -> Map (Hash GenesisKey) (Hash GenesisDelegateKey, Hash VrfKey) - -- Non-delegated initial UTxO spec: + -- | Amount of lovelace not delegated -> Maybe Lovelace + -- | UTxO addresses that are not delegating -> [AddressInEra ShelleyEra] - -- Genesis staking: pools/delegation map & delegated initial UTxO spec: + -- | Genesis staking: pools/delegation map & delegated initial UTxO spec -> Map (Ledger.KeyHash 'Ledger.Staking StandardCrypto) (Ledger.PoolParams StandardCrypto) + -- | Number of UTxO Addresses for delegation -> Lovelace + -- | UTxO Addresses for delegation -> [AddressInEra ShelleyEra] + -- | Stuffed UTxO addresses -> [AddressInEra ShelleyEra] + -- | Template from which to build a genesis -> ShelleyGenesis StandardShelley + -- | Updated genesis -> ShelleyGenesis StandardShelley updateTemplate (SystemStart start) genDelegMap mAmountNonDeleg utxoAddrsNonDeleg @@ -1014,7 +1007,7 @@ updateTemplate (SystemStart start) { sgSystemStart = start , sgMaxLovelaceSupply = fromIntegral $ nonDelegCoin + delegCoin , sgGenDelegs = shelleyDelKeys - , sgInitialFunds = ListMap + , sgInitialFunds = ListMap.fromList [ (toShelleyAddr addr, toShelleyLovelace v) | (addr, v) <- distribute (nonDelegCoin - subtractForTreasury) utxoAddrsNonDeleg ++ @@ -1022,7 +1015,7 @@ updateTemplate (SystemStart start) mkStuffedUtxo stuffedUtxoAddrs ] , sgStaking = ShelleyGenesisStaking - { sgsPools = ListMap + { sgsPools = ListMap.fromList [ (Ledger._poolId poolParams, poolParams) | poolParams <- Map.elems poolSpecs ] , sgsStake = ListMap.fromMap $ Ledger._poolId <$> poolSpecs @@ -1059,7 +1052,7 @@ updateTemplate (SystemStart start) mkStuffedUtxo :: [AddressInEra ShelleyEra] -> [(AddressInEra ShelleyEra, Lovelace)] mkStuffedUtxo xs = (, Lovelace minUtxoVal) <$> xs - where (Coin minUtxoVal) = Shelley._minUTxOValue $ sgProtocolParams template + where Coin minUtxoVal = Shelley._minUTxOValue $ sgProtocolParams template shelleyDelKeys = Map.fromList @@ -1071,6 +1064,90 @@ updateTemplate (SystemStart start) unLovelace :: Integral a => Lovelace -> a unLovelace (Lovelace coin) = fromIntegral coin +updateCreateStakedOutputTemplate + -- | System start time + :: SystemStart + -- | Genesis delegation (not stake-based) + -> Map (Hash GenesisKey) (Hash GenesisDelegateKey, Hash VrfKey) + -- | Amount of lovelace not delegated + -> Maybe Lovelace + -- | Number of UTxO addresses that are delegating + -> Int + -- | UTxO addresses that are not delegating + -> [AddressInEra ShelleyEra] + -- | Pool map + -> [(Ledger.KeyHash 'Ledger.StakePool StandardCrypto, Ledger.PoolParams StandardCrypto)] + -- | Delegaton map + -> [(Ledger.KeyHash 'Ledger.Staking StandardCrypto, Ledger.KeyHash 'Ledger.StakePool StandardCrypto)] + -- | Amount of lovelace to delegate + -> Lovelace + -- | Number of UTxO address for delegationg + -> Int + -- | UTxO address for delegationg + -> [AddressInEra ShelleyEra] + -- | Stuffed UTxO addresses + -> [AddressInEra ShelleyEra] + -- | Template from which to build a genesis + -> ShelleyGenesis StandardShelley + -- | Updated genesis + -> ShelleyGenesis StandardShelley +updateCreateStakedOutputTemplate + (SystemStart start) + genDelegMap mAmountNonDeleg nUtxoAddrsNonDeleg utxoAddrsNonDeleg pools stake + (Lovelace amountDeleg) + nUtxoAddrsDeleg utxoAddrsDeleg stuffedUtxoAddrs + template = do + let pparamsFromTemplate = sgProtocolParams template + shelleyGenesis = template + { sgSystemStart = start + , sgMaxLovelaceSupply = fromIntegral $ nonDelegCoin + delegCoin + , sgGenDelegs = shelleyDelKeys + , sgInitialFunds = ListMap.fromList + [ (toShelleyAddr addr, toShelleyLovelace v) + | (addr, v) <- + distribute (nonDelegCoin - subtractForTreasury) nUtxoAddrsNonDeleg utxoAddrsNonDeleg + ++ + distribute (delegCoin - subtractForTreasury) nUtxoAddrsDeleg utxoAddrsDeleg + ++ + mkStuffedUtxo stuffedUtxoAddrs + ] + , sgStaking = + ShelleyGenesisStaking + { sgsPools = ListMap pools + , sgsStake = ListMap stake + } + , sgProtocolParams = pparamsFromTemplate + } + shelleyGenesis + where + maximumLovelaceSupply :: Word64 + maximumLovelaceSupply = sgMaxLovelaceSupply template + -- If the initial funds are equal to the maximum funds, rewards cannot be created. + subtractForTreasury :: Integer + subtractForTreasury = nonDelegCoin `quot` 10 + nonDelegCoin, delegCoin :: Integer + nonDelegCoin = fromIntegral (fromMaybe maximumLovelaceSupply (unLovelace <$> mAmountNonDeleg)) + delegCoin = fromIntegral amountDeleg + + distribute :: Integer -> Int -> [AddressInEra ShelleyEra] -> [(AddressInEra ShelleyEra, Lovelace)] + distribute funds nAddrs addrs = zip addrs (fmap Lovelace (coinPerAddr + rest:repeat coinPerAddr)) + where coinPerAddr :: Integer + coinPerAddr = funds `div` fromIntegral nAddrs + rest = coinPerAddr * fromIntegral nAddrs + + mkStuffedUtxo :: [AddressInEra ShelleyEra] -> [(AddressInEra ShelleyEra, Lovelace)] + mkStuffedUtxo xs = (, Lovelace minUtxoVal) <$> xs + where Coin minUtxoVal = Shelley._minUTxOValue $ sgProtocolParams template + + shelleyDelKeys = Map.fromList + [ (gh, Ledger.GenDelegPair gdh h) + | (GenesisKeyHash gh, + (GenesisDelegateKeyHash gdh, VrfKeyHash h)) <- Map.toList genDelegMap + ] + + unLovelace :: Integral a => Lovelace -> a + unLovelace (Lovelace coin) = fromIntegral coin + writeFileGenesis :: ToJSON genesis => FilePath @@ -1078,7 +1155,7 @@ writeFileGenesis -> ExceptT ShelleyGenesisCmdError IO () writeFileGenesis fpath genesis = handleIOExceptT (ShelleyGenesisCmdGenesisFileError . FileIOError fpath) $ - LBS.writeFile fpath (encodePretty genesis) + LBS.writeFile fpath (Aeson.encode genesis) -- ---------------------------------------------------------------------------- @@ -1231,4 +1308,3 @@ readAlonzoGenesis fpath = do lbs <- handleIOExceptT (ShelleyGenesisCmdGenesisFileError . FileIOError fpath) $ LBS.readFile fpath firstExceptT (ShelleyGenesisCmdAesonDecodeError fpath . Text.pack) . hoistEither $ Aeson.eitherDecode' lbs - diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/StakeAddress.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/StakeAddress.hs index 77d6d40ae5f..9454ba8123f 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/StakeAddress.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/StakeAddress.hs @@ -2,7 +2,7 @@ module Cardano.CLI.Shelley.Run.StakeAddress ( ShelleyStakeAddressCmdError(ShelleyStakeAddressCmdReadKeyFileError) , renderShelleyStakeAddressCmdError , runStakeAddressCmd - , runStakeAddressKeyGen + , runStakeAddressKeyGenToFile ) where import Cardano.Prelude @@ -37,7 +37,7 @@ renderShelleyStakeAddressCmdError err = ShelleyStakeAddressCmdReadScriptFileError fileErr -> Text.pack (displayError fileErr) runStakeAddressCmd :: StakeAddressCmd -> ExceptT ShelleyStakeAddressCmdError IO () -runStakeAddressCmd (StakeAddressKeyGen vk sk) = runStakeAddressKeyGen vk sk +runStakeAddressCmd (StakeAddressKeyGen vk sk) = runStakeAddressKeyGenToFile vk sk runStakeAddressCmd (StakeAddressKeyHash vk mOutputFp) = runStakeAddressKeyHash vk mOutputFp runStakeAddressCmd (StakeAddressBuild stakeVerifier nw mOutputFp) = runStakeAddressBuild stakeVerifier nw mOutputFp @@ -53,20 +53,21 @@ runStakeAddressCmd (StakeCredentialDeRegistrationCert stakeVerifier outputFp) = -- Stake address command implementations -- -runStakeAddressKeyGen :: VerificationKeyFile -> SigningKeyFile -> ExceptT ShelleyStakeAddressCmdError IO () -runStakeAddressKeyGen (VerificationKeyFile vkFp) (SigningKeyFile skFp) = do - skey <- liftIO $ generateSigningKey AsStakeKey - let vkey = getVerificationKey skey - firstExceptT ShelleyStakeAddressCmdWriteFileError - . newExceptT - $ writeFileTextEnvelope skFp (Just skeyDesc) skey - firstExceptT ShelleyStakeAddressCmdWriteFileError - . newExceptT - $ writeFileTextEnvelope vkFp (Just vkeyDesc) vkey - where - skeyDesc, vkeyDesc :: TextEnvelopeDescr - skeyDesc = "Stake Signing Key" - vkeyDesc = "Stake Verification Key" +runStakeAddressKeyGenToFile + :: VerificationKeyFile + -> SigningKeyFile + -> ExceptT ShelleyStakeAddressCmdError IO () +runStakeAddressKeyGenToFile (VerificationKeyFile vkFp) (SigningKeyFile skFp) = do + let skeyDesc = "Stake Signing Key" + let vkeyDesc = "Stake Verification Key" + + skey <- liftIO $ generateSigningKey AsStakeKey + + let vkey = getVerificationKey skey + + firstExceptT ShelleyStakeAddressCmdWriteFileError $ do + newExceptT $ writeFileTextEnvelope skFp (Just skeyDesc) skey + newExceptT $ writeFileTextEnvelope vkFp (Just vkeyDesc) vkey runStakeAddressKeyHash :: VerificationKeyOrFile StakeKey diff --git a/doc/new-tracing/tracers_doc_generated.md b/doc/new-tracing/tracers_doc_generated.md index 165c2352d9d..0eff69cb3eb 100644 --- a/doc/new-tracing/tracers_doc_generated.md +++ b/doc/new-tracing/tracers_doc_generated.md @@ -9576,4 +9576,4 @@ TxSubmission.TxInbound.Collected Configuration: TraceConfig {tcOptions = fromList [([],[ConfSeverity {severity = Notice},ConfDetail {detail = DNormal},ConfBackend {backends = [Stdout MachineFormat,EKGBackend,Forwarder]}]),(["AcceptPolicy"],[ConfSeverity {severity = Info}]),(["BlockFetchClient","CompletedBlockFetch"],[ConfLimiter {maxFrequency = 2.0}]),(["ChainDB"],[ConfSeverity {severity = Info}]),(["ChainDB","AddBlockEvent","AddBlockValidation","ValidCandidate"],[ConfLimiter {maxFrequency = 2.0}]),(["ChainDB","AddBlockEvent","AddedBlockToQueue"],[ConfLimiter {maxFrequency = 2.0}]),(["ChainDB","AddBlockEvent","AddedBlockToVolatileDB"],[ConfLimiter {maxFrequency = 2.0}]),(["ChainDB","CopyToImmutableDBEvent","CopiedBlockToImmutableDB"],[ConfLimiter {maxFrequency = 2.0}]),(["DNSResolver"],[ConfSeverity {severity = Info}]),(["DNSSubscription"],[ConfSeverity {severity = Info}]),(["DiffusionInit"],[ConfSeverity {severity = Info}]),(["ErrorPolicy"],[ConfSeverity {severity = Info}]),(["Forge"],[ConfSeverity {severity = Info}]),(["IpSubscription"],[ConfSeverity {severity = Info}]),(["LocalErrorPolicy"],[ConfSeverity {severity = Info}]),(["Mempool"],[ConfSeverity {severity = Info}]),(["Resources"],[ConfSeverity {severity = Info}])], tcForwarder = TraceOptionForwarder {tofConnQueueSize = 2000, tofDisconnQueueSize = 200000, tofVerbosity = Minimum}, tcNodeName = Nothing, tcPeerFrequency = Just 2000, tcResourceFrequency = Just 5000} 663 log messages. -Generated at 2022-07-11 10:20:06.282523 AEST. \ No newline at end of file +Generated at 2022-07-11 10:20:06.282523 AEST.