Reduce memory usage of the create-staked command using lazy IO.

cabal.project

@@ -197,8 +197,8 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger
-  tag: 0913292b13963ae4b60136eddb8d18b137f96a21
-  --sha256: 19rrnvvplvg8v989bcv6vpjwvblfa0m65izxkcp8dclf0a914qq3
+  tag: 830e4e41d772087d7df69c6fd5a2bf5439ad97a6
+  --sha256: 1065z9y51bhdf3yy0d2hchk8d8crji31cznjp02arddbyv6n57lr
   subdir:
     eras/alonzo/impl
     eras/alonzo/test-suite
@@ -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

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

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

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)

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)

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))

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

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

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

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)

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)