diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Address.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Address.hs index 213319eb1ba..6de241dacd2 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Address.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Address.hs @@ -68,27 +68,44 @@ runAddressKeyGenToFile :: AddressKeyType -> VerificationKeyFile -> SigningKeyFile -> ExceptT ShelleyAddressCmdError IO () -runAddressKeyGenToFile kt (VerificationKeyFile vkeyPath) (SigningKeyFile skeyPath) = - case kt of - AddressKeyShelley -> generateAndWriteKeyFiles AsPaymentKey - AddressKeyShelleyExtended -> generateAndWriteKeyFiles AsPaymentExtendedKey - AddressKeyByron -> generateAndWriteKeyFiles AsByronKey +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) =<< generatePaymentKeys asType + +generatePaymentKeys :: () + => Key keyrole + => AsType keyrole + -> ExceptT ShelleyAddressCmdError IO (VerificationKey keyrole, SigningKey keyrole) +generatePaymentKeys asType = do + skey <- liftIO $ generateSigningKey asType + return (getVerificationKey skey, skey) + +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 () diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs index d067b1c4e38..ab6d4a74805 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs @@ -7,6 +7,7 @@ {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# LANGUAGE RecordWildCards #-} module Cardano.CLI.Shelley.Run.Genesis ( ShelleyGenesisCmdError(..) @@ -80,7 +81,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, runStakeAddressKeyGenToFile, keyGenStakeAddress) + renderShelleyStakeAddressCmdError, runStakeAddressKeyGenToFile) import Cardano.CLI.Types import Cardano.CLI.Byron.Delegation @@ -703,23 +704,46 @@ runGenesisCreateStaked (GenesisDir rootdir) ] -- Distribute M delegates across N pools: - delegations :: [Delegation] <- forM distribution $ \(poolParams, index) -> do + delegations <- liftIO $ Lazy.forM distribution $ \(poolParams, index) -> do computeDelegation network stdeldir poolParams index + liftIO $ LBS.writeFile (stdeldir "delegations.jsonl") $ B.toLazyByteString $ + mconcat (List.intersperse "\n" (B.lazyByteString . Aeson.encode <$> delegations)) + + -- NOTE The following code which reads from the same file 'delegations.jsonl' multiple times + -- looks like duplication, but it is not. The file is read lazily, and it is important that + -- they be read multiple times because the code is streaming and reading the file multiple + -- times ensures that any data structures that are created as a result of the read is not + -- retained in memory. + + !numDelegations <- fmap length $ liftIO $ LBS.lines <$> LBS.readFile (stdeldir "delegations.jsonl") + + delegations2 <- do + delegationLines <- liftIO $ LBS.lines <$> LBS.readFile (stdeldir "delegations.jsonl") + return $ catMaybes $ Aeson.decode @Delegation <$> delegationLines + + delegations3 <- do + delegationLines <- liftIO $ LBS.lines <$> LBS.readFile (stdeldir "delegations.jsonl") + return $ catMaybes $ Aeson.decode @Delegation <$> delegationLines + + delegations4 <- do + delegationLines <- liftIO $ LBS.lines <$> LBS.readFile (stdeldir "delegations.jsonl") + return $ catMaybes $ Aeson.decode @Delegation <$> delegationLines + genDlgs <- readGenDelegsMap gendir deldir nonDelegAddrs <- readInitialFundAddresses utxodir network start <- maybe (SystemStart <$> getCurrentTimePlus30) pure mStart stuffedUtxoAddrs <- liftIO $ Lazy.replicateM (fromIntegral numStuffedUtxo) genStuffedAddress - let poolMap :: Map (Ledger.KeyHash Ledger.Staking StandardCrypto) (Ledger.PoolParams StandardCrypto) - poolMap = Map.fromList $ mkDelegationMapEntry <$> delegations - delegAddrs = dInitialUtxoAddr <$> delegations + let stake = second Ledger._poolId . mkDelegationMapEntry <$> delegations2 + stakePools = [ (Ledger._poolId poolParams, poolParams) | poolParams <- snd . mkDelegationMapEntry <$> delegations3 ] + delegAddrs = dInitialUtxoAddr <$> delegations4 !shelleyGenesis = updateOutputTemplate -- Shelley genesis parameters - start genDlgs mNonDlgAmount nonDelegAddrs poolMap - stDlgAmount delegAddrs stuffedUtxoAddrs (toOutputTemplate template) + start genDlgs mNonDlgAmount (length nonDelegAddrs) nonDelegAddrs stakePools stake + stDlgAmount numDelegations delegAddrs stuffedUtxoAddrs (toOutputTemplate template) -- shelleyGenesis contains lazy loaded data, so using lazyToJson to serialise to avoid -- retaining large datastructures in memory. @@ -735,9 +759,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 [ ", " @@ -855,12 +877,24 @@ createPoolCredentials dir index = do coldSK = SigningKeyFile $ dir "cold" ++ strIndex ++ ".skey" opCertCtr = OpCertCounterFile $ dir "opcert" ++ strIndex ++ ".counter" -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 + } + +instance ToJSON Delegation where + toJSON delegation = Aeson.object + [ "initialUtxoAddr" .= dInitialUtxoAddr delegation + , "delegStaking" .= dDelegStaking delegation + , "poolParams" .= dPoolParams delegation + ] + +instance FromJSON Delegation where + parseJSON = Aeson.withObject "Delegation" $ \v -> Delegation + <$> (v .: "initialUtxoAddr") + <*> (v .: "delegStaking") + <*> (v .: "poolParams") buildPool :: NetworkId -> FilePath -> Word -> ExceptT ShelleyGenesisCmdError IO (Ledger.PoolParams StandardCrypto) buildPool nw dir index = do @@ -924,34 +958,13 @@ computeDelegation :: () -> FilePath -> Ledger.PoolParams StandardCrypto -> Word - -> ExceptT ShelleyGenesisCmdError IO Delegation -computeDelegation nw delegDir pool delegIx = do - let strIndex = show delegIx - - let paymentVKF = VerificationKeyFile $ delegDir "payment" ++ strIndex ++ ".vkey" - - firstExceptT ShelleyGenesisCmdAddressCmdError $ do - let paymentSKF = SigningKeyFile $ delegDir "payment" ++ strIndex ++ ".skey" - runAddressKeyGenToFile AddressKeyShelley paymentVKF paymentSKF - - let stakingVKF = VerificationKeyFile $ delegDir "staking" ++ strIndex ++ ".vkey" - - (_, stakeVK) <- firstExceptT ShelleyGenesisCmdStakeAddressCmdError $ do - -- let stakingSK = SigningKeyFile $ delegDir "staking" ++ strIndex ++ ".skey" - -- runStakeAddressKeyGenToFile stakingVKF stakingSK - keyGenStakeAddress + -> IO Delegation +computeDelegation nw _delegDir pool _delegIx = do + paymentVK <- fmap getVerificationKey $ generateSigningKey AsPaymentKey + stakeVK <- fmap getVerificationKey $ generateSigningKey AsStakeKey - paySVK <- firstExceptT (ShelleyGenesisCmdAddressCmdError - . ShelleyAddressCmdVerificationKeyTextOrFileError) $ - readAddressVerificationKeyTextOrFile - (VktofVerificationKeyFile paymentVKF) - - initialUtxoAddr <- case paySVK of - APaymentVerificationKey payVK -> do - firstExceptT ShelleyGenesisCmdAddressCmdError $ do - let stakeVerifier = StakeVerifierKey . VerificationKeyFilePath $ stakingVKF - makeShelleyAddress nw (PaymentCredentialByKey (verificationKeyHash payVK)) <$> makeStakeAddressRef stakeVerifier - _ -> left $ ShelleyGenesisCmdUnexpectedAddressVerificationKey paymentVKF "APaymentVerificationKey" paySVK + let stakeAddressReference = StakeAddressByValue . StakeCredentialByKey . verificationKeyHash $ stakeVK + let initialUtxoAddr = makeShelleyAddress nw (PaymentCredentialByKey (verificationKeyHash paymentVK)) stakeAddressReference pure Delegation { dInitialUtxoAddr = shelleyAddressInEra initialUtxoAddr @@ -1084,17 +1097,20 @@ updateOutputTemplate -> Map (Hash GenesisKey) (Hash GenesisDelegateKey, Hash VrfKey) -- Non-delegated initial UTxO spec: -> Maybe Lovelace + -> Int -> [AddressInEra ShelleyEra] -- Genesis staking: pools/delegation map & delegated initial UTxO spec: - -> Map (Ledger.KeyHash 'Ledger.Staking StandardCrypto) (Ledger.PoolParams StandardCrypto) + -> [(Ledger.KeyHash 'Ledger.StakePool StandardCrypto, Ledger.PoolParams StandardCrypto)] + -> [(Ledger.KeyHash 'Ledger.Staking StandardCrypto, Ledger.KeyHash 'Ledger.StakePool StandardCrypto)] -> Lovelace - -> [AddressInEra ShelleyEra] + -> Int + -> [AddressInEra ShelleyEra] -- -> [AddressInEra ShelleyEra] -> OT.OutputShelleyGenesis StandardShelley -> OT.OutputShelleyGenesis StandardShelley updateOutputTemplate (SystemStart start) - genDelegMap mAmountNonDeleg utxoAddrsNonDeleg - poolSpecs (Lovelace amountDeleg) utxoAddrsDeleg stuffedUtxoAddrs + genDelegMap mAmountNonDeleg nUtxoAddrsNonDeleg utxoAddrsNonDeleg + pools stake (Lovelace amountDeleg) nUtxoAddrsDeleg utxoAddrsDeleg stuffedUtxoAddrs template = do let pparamsFromTemplate = OT.sgProtocolParams template @@ -1105,15 +1121,16 @@ updateOutputTemplate (SystemStart start) , OT.sgInitialFunds = ListMap [ (toShelleyAddr addr, toShelleyLovelace v) | (addr, v) <- - distribute (nonDelegCoin - subtractForTreasury) utxoAddrsNonDeleg ++ - distribute (delegCoin - subtractForTreasury) utxoAddrsDeleg ++ - mkStuffedUtxo stuffedUtxoAddrs ] + distribute (nonDelegCoin - subtractForTreasury) nUtxoAddrsNonDeleg utxoAddrsNonDeleg + ++ + distribute (delegCoin - subtractForTreasury) nUtxoAddrsDeleg utxoAddrsDeleg + ++ + mkStuffedUtxo stuffedUtxoAddrs + ] , OT.sgStaking = - ShelleyGenesisStaking - { sgsPools = Map.fromList - [ (Ledger._poolId poolParams, poolParams) - | poolParams <- Map.elems poolSpecs ] - , sgsStake = Ledger._poolId <$> poolSpecs + OT.OutputShelleyGenesisStaking + { OT.osgsPools = ListMap pools + , OT.osgsStake = ListMap stake } , OT.sgProtocolParams = pparamsFromTemplate } @@ -1128,22 +1145,11 @@ updateOutputTemplate (SystemStart start) nonDelegCoin = fromIntegral (fromMaybe maximumLovelaceSupply (unLovelace <$> mAmountNonDeleg)) delegCoin = fromIntegral amountDeleg - distribute :: Integer -> [AddressInEra ShelleyEra] -> [(AddressInEra ShelleyEra, Lovelace)] - distribute funds addrs = - fst $ List.foldl' folder ([], fromIntegral funds) addrs - where - nAddrs, coinPerAddr, splitThreshold :: Integer - nAddrs = fromIntegral $ length addrs - coinPerAddr = funds `div` nAddrs - splitThreshold = coinPerAddr + nAddrs - - folder :: ([(AddressInEra ShelleyEra, Lovelace)], Integer) - -> AddressInEra ShelleyEra - -> ([(AddressInEra ShelleyEra, Lovelace)], Integer) - folder (acc, rest) addr - | rest > splitThreshold = - ((addr, Lovelace coinPerAddr) : acc, rest - coinPerAddr) - | otherwise = ((addr, Lovelace rest) : acc, 0) + distribute :: Integer -> Int -> [AddressInEra ShelleyEra] -> [(AddressInEra ShelleyEra, Lovelace)] + distribute funds nAddrs addrs = zipWith (,) 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 diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis/LazyToJson.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis/LazyToJson.hs index 7fdd0973866..15760011103 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis/LazyToJson.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis/LazyToJson.hs @@ -2,12 +2,13 @@ {-# LANGUAGE FlexibleInstances #-} module Cardano.CLI.Shelley.Run.Genesis.LazyToJson - ( LazyToJson(..) + ( Aeson(..) + , LazyToJson(..) ) where import Cardano.Ledger.Address (Addr) import Cardano.Ledger.Crypto (StandardCrypto) -import Data.Aeson (Value) +import Data.Aeson (Value, ToJSON) import Data.Functor ((<$>)) import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) @@ -38,3 +39,8 @@ instance LazyToJson a => LazyToJson [a] where instance LazyToJson (Addr StandardCrypto) where lazyToJson = B.lazyByteString . J.encode + +newtype Aeson a = Aeson a + +instance ToJSON a => LazyToJson (Aeson a) where + lazyToJson (Aeson a) = B.lazyByteString (J.encode a) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis/Types.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis/Types.hs index 49e0b199763..eb1b6fc1ca7 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis/Types.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis/Types.hs @@ -14,6 +14,7 @@ module Cardano.CLI.Shelley.Run.Genesis.Types ( OutputShelleyGenesis(..) + , OutputShelleyGenesisStaking(..) , ListMap(..) , toOutputTemplate ) where @@ -25,7 +26,6 @@ import Cardano.Ledger.BaseTypes (PositiveUnitInterval, Network) import Cardano.Ledger.Coin (Coin) import Cardano.Ledger.Era (Era(Crypto)) import Cardano.Ledger.Keys (KeyHash, KeyRole(Genesis), GenDelegPair) -import Cardano.Ledger.Shelley.Genesis (ShelleyGenesisStaking) import Cardano.Ledger.Shelley.PParams ( PParams ) import Cardano.Slotting.Slot (EpochSize(..)) import Data.Aeson (ToJSON(..), (.=)) @@ -39,7 +39,9 @@ import GHC.Generics (Generic) import Text.Show (Show) import qualified Cardano.Ledger.Crypto as Ledger +import qualified Cardano.Ledger.Keys as Ledger import qualified Cardano.Ledger.Shelley.Genesis as Ledger +import qualified Cardano.Ledger.Shelley.TxBody as Ledger import qualified Data.Aeson as Aeson import qualified Data.Map as Map @@ -58,7 +60,7 @@ data OutputShelleyGenesis era = OutputShelleyGenesis , sgProtocolParams :: !(PParams era) , sgGenDelegs :: !(ListMap (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))) , sgInitialFunds :: !(ListMap (Addr (Crypto era)) Coin) - , sgStaking :: !(ShelleyGenesisStaking (Crypto era)) + , sgStaking :: !(OutputShelleyGenesisStaking era) } deriving stock (Eq, Show, Generic) @@ -114,12 +116,14 @@ toOutputTemplate template = OutputShelleyGenesis , sgProtocolParams = Ledger.sgProtocolParams template , sgGenDelegs = ListMap (Map.toList (Ledger.sgGenDelegs template)) , sgInitialFunds = ListMap (Map.toList (Ledger.sgInitialFunds template)) - , sgStaking = Ledger.sgStaking template + , sgStaking = OutputShelleyGenesisStaking + { osgsPools = ListMap $ Map.toList $ Ledger.sgsPools $ Ledger.sgStaking template + , osgsStake = ListMap $ Map.toList $ Ledger.sgsStake $ Ledger.sgStaking template + } } instance ( Ledger.Crypto (Crypto era) - , ToJSON (ShelleyGenesisStaking (Crypto era)) ) => LazyToJson (OutputShelleyGenesis era) where lazyToJson sg = -- Forced evaluation of each field allows the parent object to no longer be @@ -155,5 +159,28 @@ instance <> ",\"protocolParams\": " <> lazyToJson (toJSON protocolParams) <> ",\"genDelegs\": " <> lazyToJson genDelegs <> ",\"initialFunds\": " <> lazyToJson initialFunds - <> ",\"staking\": " <> lazyToJson (toJSON staking) + <> ",\"staking\": " <> lazyToJson staking <> "}" + +data OutputShelleyGenesisStaking era = OutputShelleyGenesisStaking + { osgsPools :: !(ListMap (KeyHash 'Ledger.StakePool (Crypto era)) (Ledger.PoolParams (Crypto era))) + , osgsStake :: !(ListMap (KeyHash 'Ledger.Staking (Crypto era)) (KeyHash 'Ledger.StakePool (Crypto era))) + } + deriving stock (Eq, Show, Generic) + +instance + ( Ledger.Crypto (Crypto era) + ) => LazyToJson (OutputShelleyGenesisStaking era) where + lazyToJson sg = + let !pools = osgsPools sg + !stake = osgsStake sg + in mempty + <> "{\"pools\":" <> lazyToJson pools + <> ",\"stake\":" <> lazyToJson stake + <> "}" + +instance Era era => ToJSON (OutputShelleyGenesisStaking era) where + toJSON sg = Aeson.object + [ "pools" .= osgsPools sg + , "stake" .= osgsStake sg + ] diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/StakeAddress.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/StakeAddress.hs index c7a664ed533..e52aae4a58d 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/StakeAddress.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/StakeAddress.hs @@ -3,7 +3,6 @@ module Cardano.CLI.Shelley.Run.StakeAddress , renderShelleyStakeAddressCmdError , runStakeAddressCmd , runStakeAddressKeyGenToFile - , keyGenStakeAddress ) where import Cardano.Prelude @@ -54,11 +53,6 @@ runStakeAddressCmd (StakeCredentialDeRegistrationCert stakeVerifier outputFp) = -- Stake address command implementations -- -keyGenStakeAddress :: MonadIO m => m (SigningKey StakeKey, VerificationKey StakeKey) -keyGenStakeAddress = do - skey <- liftIO $ generateSigningKey AsStakeKey - return (skey, getVerificationKey skey) - runStakeAddressKeyGenToFile :: () => VerificationKeyFile -> SigningKeyFile @@ -67,7 +61,9 @@ runStakeAddressKeyGenToFile (VerificationKeyFile vkFp) (SigningKeyFile skFp) = d let skeyDesc = "Stake Signing Key" let vkeyDesc = "Stake Verification Key" - (skey, vkey) <- keyGenStakeAddress + skey <- liftIO $ generateSigningKey AsStakeKey + + let vkey = getVerificationKey skey firstExceptT ShelleyStakeAddressCmdWriteFileError $ do newExceptT $ writeFileTextEnvelope skFp (Just skeyDesc) skey