Sanity check works!

Author: Jimbo4350

cardano-node/src/Cardano/Node/Protocol/Byron.hs

@@ -36,6 +36,7 @@ import           Cardano.Tracing.OrphanInstances.Shelley ()
 import           Ouroboros.Consensus.Cardano
 import qualified Ouroboros.Consensus.Cardano as Consensus
 
+import           Control.Exception
 import qualified Data.ByteString.Lazy as LB
 import           Data.Maybe (fromMaybe)
 import           Data.Text (Text)
@@ -167,6 +168,9 @@ data ByronProtocolInstantiationError =
   | SigningKeyFilepathNotSpecified
   deriving Show
 
+instance Exception ByronProtocolInstantiationError where 
+  displayException = docToString . prettyError
+
 instance Error ByronProtocolInstantiationError where
   prettyError (CanonicalDecodeFailure fp failure) =
         "Canonical decode failure in " <> pshow fp

cardano-testnet/cardano-testnet.cabal

@@ -86,6 +86,8 @@ library
                       , process
                       , resourcet
                       , retry
+                      , rio
+                      , rio-orphans
                       , safe-exceptions
                       , scientific
                       , si-timers
@@ -111,17 +113,20 @@ library
                         Testnet.EpochStateProcessing
                         Testnet.Filepath
                         Testnet.Handlers
+                        Testnet.Orphans
                         Testnet.Ping
                         Testnet.Process.Cli.DRep
                         Testnet.Process.Cli.Keys
                         Testnet.Process.Cli.SPO
                         Testnet.Process.Cli.Transaction
+                        Testnet.Process.NewRun
                         Testnet.Process.Run
                         Testnet.Property.Assert
                         Testnet.Property.Run
                         Testnet.Property.Util
                         Testnet.Runtime
                         Testnet.Start.Byron
+                        Testnet.Start.Cardano
                         Testnet.Start.Types
                         Testnet.SubmitApi
                         Testnet.TestQueryCmds
@@ -130,7 +135,6 @@ library
   other-modules:        Parsers.Cardano
                         Parsers.Help
                         Parsers.Version
-                        Testnet.Start.Cardano
                         Testnet.TestEnumGenerator
                         Paths_cardano_testnet
 

cardano-testnet/src/Parsers/Run.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Parsers.Run
@@ -11,12 +10,14 @@ module Parsers.Run
   ) where
 
 import           Cardano.CLI.Environment
+import           Control.Monad
 
 import           Data.Default.Class (def)
 import           Data.Foldable
 import           Options.Applicative
 import qualified Options.Applicative as Opt
-
+import           RIO (runRIO)
+import           RIO.Orphans 
 import           Testnet.Property.Run
 import           Testnet.Start.Cardano
 import           Testnet.Start.Types
@@ -61,34 +62,35 @@ createEnvOptions CardanoTestnetCreateEnvOptions
   , createEnvOutputDir=outputDir
   , createEnvCreateEnvOptions=ceOptions
   } =
-    testnetRoutine (UserProvidedEnv outputDir) $ \conf -> do
-      createTestnetEnv
-        testnetOptions genesisOptions ceOptions
-        -- Do not add hashes to the main config file, so that genesis files
-        -- can be modified without having to recompute hashes every time.
-        conf{genesisHashesPolicy = WithoutHashes}
+    testnetRoutine (UserProvidedEnv outputDir) $ \conf -> do 
+      liftToIntegration $
+        createTestnetEnv
+          testnetOptions genesisOptions ceOptions
+          -- Do not add hashes to the main config file, so that genesis files
+          -- can be modified without having to recompute hashes every time.
+          conf{genesisHashesPolicy = WithoutHashes}
 
 runCardanoOptions :: CardanoTestnetCliOptions -> IO ()
 runCardanoOptions CardanoTestnetCliOptions
-  { cliTestnetOptions=testnetOptions@CardanoTestnetOptions{cardanoOutputDir}
+  { cliTestnetOptions=testnetOptions
   , cliGenesisOptions=genesisOptions
   , cliNodeEnvironment=env
-  , cliUpdateTimestamps=updateTimestamps
+  , cliUpdateTimestamps=updateTimestamps'
   } =
     case env of
-      NoUserProvidedEnv ->
+      NoUserProvidedEnv -> do
         -- Create the sandbox, then run cardano-testnet.
         -- It is not necessary to honor `cliUpdateTimestamps` here, because
         -- the genesis files will be created with up-to-date stamps already.
-        runTestnet cardanoOutputDir $ \conf -> do
-          createTestnetEnv
-            testnetOptions genesisOptions def
-            conf
-          cardanoTestnet testnetOptions conf
-      UserProvidedEnv nodeEnvPath ->
+        conf <- mkConfigAbs "testnet"
+        runRIO () $ createTestnetEnv
+                   testnetOptions genesisOptions def
+                   conf
+        withResourceMap (\rm -> void . runRIO rm $ cardanoTestnet testnetOptions conf)
+      UserProvidedEnv nodeEnvPath -> do
         -- Run cardano-testnet in the sandbox provided by the user
         -- In that case, 'cardanoOutputDir' is not used
-        runTestnet (UserProvidedEnv nodeEnvPath) $ \conf ->
-          cardanoTestnet
+        conf <- mkConfigAbs nodeEnvPath
+        withResourceMap (\rm -> void . runRIO rm $ cardanoTestnet
             testnetOptions
-            conf{updateTimestamps=updateTimestamps}
+            conf{updateTimestamps=updateTimestamps'})

cardano-testnet/src/Testnet/Components/Configuration.hs

@@ -33,19 +33,18 @@ import           Cardano.Network.PeerSelection.Bootstrap
 import           Cardano.Network.PeerSelection.PeerTrustable
 import qualified Cardano.Node.Configuration.Topology as NonP2P
 import qualified Cardano.Node.Configuration.TopologyP2P as P2P
+import           Cardano.Node.Protocol.Byron
 import           Ouroboros.Network.NodeToNode (DiffusionMode (..))
 import           Ouroboros.Network.PeerSelection.LedgerPeers
 import           Ouroboros.Network.PeerSelection.State.LocalRootPeers
 
-import           Control.Exception.Safe (MonadCatch)
 import           Control.Monad
 import           Control.Monad.Extra
 import           Data.Aeson
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Encode.Pretty as A
 import           Data.Aeson.Key hiding (fromString)
 import           Data.Aeson.KeyMap hiding (map)
-import           Data.Bifunctor (first)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.List as List
@@ -57,25 +56,26 @@ import           Data.Word (Word64)
 import           GHC.Stack (HasCallStack)
 import qualified GHC.Stack as GHC
 import qualified Network.HTTP.Simple as HTTP
+import           RIO (Exception(..), MonadThrow, throwM)
 import qualified System.Directory as System
 import           System.FilePath.Posix (takeDirectory, (</>))
 
+
 import           Testnet.Blockfrost (blockfrostToGenesis)
 import qualified Testnet.Defaults as Defaults
 import           Testnet.Filepath
-import           Testnet.Process.Run (execCli_)
+import           Testnet.Process.NewRun (execCli_)
 import           Testnet.Start.Types
 
-import           Hedgehog
-import qualified Hedgehog as H
 import qualified Hedgehog.Extras.Stock.OS as OS
 import qualified Hedgehog.Extras.Stock.Time as DTC
-import qualified Hedgehog.Extras.Test.Base as H
-import qualified Hedgehog.Extras.Test.File as H
+
 
 -- | Returns JSON encoded hashes of the era, as well as the hard fork configuration toggle.
 createConfigJson :: ()
-  => (MonadTest m, MonadIO m, HasCallStack)
+  => HasCallStack
+  => MonadIO m
+  => MonadThrow m
   => TmpAbsolutePath
   -> ShelleyBasedEra era -- ^ The era used for generating the hard fork configuration toggle
   -> m (KeyMap Aeson.Value)
@@ -93,7 +93,7 @@ createConfigJson (TmpAbsolutePath tempAbsPath) sbe = GHC.withFrozenCallStack $ d
     , Defaults.defaultYamlHardforkViaConfig sbe
     ]
    where
-    getHash :: (MonadTest m, MonadIO m) => CardanoEra a -> Text.Text -> m (KeyMap Value)
+    getHash ::  MonadIO m => CardanoEra a -> Text.Text -> m (KeyMap Value)
     getHash e = getShelleyGenesisHash (tempAbsPath </> Defaults.defaultGenesisFilepath e)
 
 createConfigJsonNoHash :: ()
@@ -104,22 +104,25 @@ createConfigJsonNoHash = Defaults.defaultYamlHardforkViaConfig
 -- Generate hashes for genesis.json files
 
 getByronGenesisHash
-  :: (H.MonadTest m, MonadIO m)
+  :: MonadIO m
+  => MonadThrow m
   => FilePath
   -> m (KeyMap Aeson.Value)
 getByronGenesisHash path = do
   e <- runExceptT $ readGenesisData path
-  (_, genesisHash) <- H.leftFail e
-  let genesisHash' = unGenesisHash genesisHash
-  pure . singleton "ByronGenesisHash" $ toJSON genesisHash'
+  case e of 
+    Left err -> throwM $ GenesisReadError path err
+    Right (_, genesisHash) -> do
+      let genesisHash' = unGenesisHash genesisHash
+      pure . singleton "ByronGenesisHash" $ toJSON genesisHash'
 
 getShelleyGenesisHash
-  :: (H.MonadTest m, MonadIO m)
+  :: MonadIO m
   => FilePath
   -> Text
   -> m (KeyMap Aeson.Value)
 getShelleyGenesisHash path key = do
-  content <- H.evalIO  $ BS.readFile path
+  content <- liftIO $ BS.readFile path
   let genesisHash = Crypto.hashWith id content :: Crypto.Hash Crypto.Blake2b_256 BS.ByteString
   pure . singleton (fromText key) $ toJSON genesisHash
 
@@ -130,32 +133,44 @@ startTimeOffsetSeconds = if OS.isWin32 then 90 else 15
 
 -- | A start time and 'ShelleyGenesis' value that are fit to pass to 'cardanoTestnet'
 getDefaultShelleyGenesis :: ()
-  => HasCallStack
   => MonadIO m
-  => MonadTest m
   => AnyShelleyBasedEra
   -> Word64 -- ^ The max supply
   -> GenesisOptions
   -> m ShelleyGenesis
 getDefaultShelleyGenesis asbe maxSupply opts = do
-  currentTime <- H.noteShowIO DTC.getCurrentTime
-  startTime <- H.noteShow $ DTC.addUTCTime startTimeOffsetSeconds currentTime
+  currentTime <- liftIO DTC.getCurrentTime
+  let startTime = DTC.addUTCTime startTimeOffsetSeconds currentTime
   return $ Defaults.defaultShelleyGenesis asbe startTime maxSupply opts
 
 -- | An 'AlonzoGenesis' value that is fit to pass to 'cardanoTestnet'
 getDefaultAlonzoGenesis :: ()
   => HasCallStack
-  => MonadTest m
+  => MonadThrow m
   => ShelleyBasedEra era
   -> m AlonzoGenesis
 getDefaultAlonzoGenesis sbe =
-  H.evalEither $ first prettyError (Defaults.defaultAlonzoGenesis sbe)
+  case Defaults.defaultAlonzoGenesis sbe of 
+    Right genesis -> return genesis
+    Left err -> throwM err
+
 
 numSeededUTxOKeys :: Int
 numSeededUTxOKeys = 3
 
+-- TODO: So that we don't lose 
+-- logging power. We should catch the exception 
+-- and use the MonadTest instance of the Integration
+-- monad to log the exception and also log additional
+-- information from the function. 
+-- Once we lift to Integration monad we can 
+-- use the various hedgehog-extra functions
+-- for logging purposes. No reason for the annotations 
+-- to be littered within the functions 
 createSPOGenesisAndFiles
-  :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)
+  :: MonadIO m
+  => HasCallStack
+  => MonadThrow m
   => CardanoTestnetOptions -- ^ The options to use
   -> GenesisOptions
   -> TestnetOnChainParams
@@ -168,7 +183,8 @@ createSPOGenesisAndFiles
   AnyShelleyBasedEra sbe <- pure cardanoNodeEra
 
   let genesisShelleyDirAbs = takeDirectory inputGenesisShelleyFp
-  genesisShelleyDir <- H.createDirectoryIfMissing genesisShelleyDirAbs
+
+  genesisShelleyDir <- liftIO $ System.createDirectoryIfMissing True genesisShelleyDirAbs >> pure genesisShelleyDirAbs
   let -- At least there should be a delegator per DRep
       -- otherwise some won't be representing anybody
       numStakeDelegators = max 3 (fromIntegral cardanoNumDReps) :: Int
@@ -184,23 +200,25 @@ createSPOGenesisAndFiles
   alonzoGenesis' <- getDefaultAlonzoGenesis sbe
   let conwayGenesis' = Defaults.defaultConwayGenesis
 
-  (alonzoGenesis, conwayGenesis, shelleyGenesis) <- resolveOnChainParams onChainParams
-    (alonzoGenesis', conwayGenesis', shelleyGenesis')
+  (alonzoGenesis, conwayGenesis, shelleyGenesis)   
+     <- resolveOnChainParams onChainParams
+     (alonzoGenesis', conwayGenesis', shelleyGenesis')
 
   -- Write Genesis files to disk, so they can be picked up by create-testnet-data
-  H.evalIO $ do
+  -- H.evalIO $ do
+  liftIO $ do
     LBS.writeFile inputGenesisAlonzoFp $ A.encodePretty alonzoGenesis
     LBS.writeFile inputGenesisConwayFp $ A.encodePretty conwayGenesis
     LBS.writeFile inputGenesisShelleyFp $ A.encodePretty shelleyGenesis
 
-  H.note_ $ "Number of pools: " <> show nPoolNodes
-  H.note_ $ "Number of stake delegators: " <> show numStakeDelegators
-  H.note_ $ "Number of seeded UTxO keys: " <> show numSeededUTxOKeys
+  -- TODO: H.note_ $ "Number of pools: " <> show nPoolNodes
+  -- TODO: H.note_ $ "Number of stake delegators: " <> show numStakeDelegators
+  -- TODO: H.note_ $ "Number of seeded UTxO keys: " <> show numSeededUTxOKeys
 
   let era = toCardanoEra sbe
 
-  currentTime <- H.noteShowIO DTC.getCurrentTime
-  startTime <- H.noteShow $ DTC.addUTCTime startTimeOffsetSeconds currentTime
+  currentTime <- liftIO DTC.getCurrentTime
+  let startTime = DTC.addUTCTime startTimeOffsetSeconds currentTime
 
   execCli_ $
     [ eraToString sbe, "genesis", "create-testnet-data" ]
@@ -225,8 +243,8 @@ createSPOGenesisAndFiles
     ]
     (\fp -> liftIO $ whenM (System.doesFileExist fp) (System.removeFile fp))
 
-  files <- H.listDirectory tempAbsPath
-  forM_ files H.note
+  _files <- liftIO $ System.listDirectory tempAbsPath
+  -- forM_ files H.note
 
   return genesisShelleyDir
   where
@@ -287,11 +305,23 @@ mkTopologyConfig numNodes allPorts port True = A.encodePretty topologyP2P
         DontUseBootstrapPeers
         Nothing
 
+
+data BlockfrostParamsError = BlockfrostParamsDecodeError FilePath String
+  deriving Show
+
+instance Exception BlockfrostParamsError where 
+  displayException (BlockfrostParamsDecodeError fp err) =
+    "Failed to decode Blockfrost on-chain parameters from file "
+      <> fp
+      <> ": "
+      <> err
+
 -- | Resolves different kinds of user-provided on-chain parameters
 -- into a unified, consistent set of Genesis files
 resolveOnChainParams :: ()
- => (MonadTest m, MonadIO m)
  => HasCallStack
+ => MonadIO m
+ => MonadThrow m
  => TestnetOnChainParams
  -> (AlonzoGenesis, ConwayGenesis, ShelleyGenesis)
  -> m (AlonzoGenesis, ConwayGenesis, ShelleyGenesis)
@@ -300,10 +330,11 @@ resolveOnChainParams onChainParams geneses = case onChainParams of
   DefaultParams -> pure geneses
 
   OnChainParamsFile file -> do
-    eParams <- H.readJsonFile file
-    params <- H.leftFail eParams
-    pure $ blockfrostToGenesis geneses params
+    eParams <- eitherDecode <$> liftIO (LBS.readFile file)
+    case eParams of 
+      Right params -> pure $ blockfrostToGenesis geneses params
+      Left err -> throwM $ BlockfrostParamsDecodeError file err
 
   OnChainParamsMainnet -> do
-    mainnetParams <- H.evalIO $ HTTP.getResponseBody <$> HTTP.httpJSON mainnetParamsRequest
+    mainnetParams <- liftIO $ HTTP.getResponseBody <$> HTTP.httpJSON mainnetParamsRequest
     pure $ blockfrostToGenesis geneses mainnetParams

cardano-testnet/src/Testnet/Defaults.hs

@@ -74,6 +74,7 @@ import           Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValenc
 
 import           Prelude
 
+import           Control.Exception (Exception (..))
 import           Control.Monad.Identity (Identity)
 import           Data.Aeson (ToJSON (..), Value, (.=))
 import qualified Data.Aeson as Aeson
@@ -107,6 +108,10 @@ newtype AlonzoGenesisError
   = AlonzoGenErrTooMuchPrecision Rational
   deriving Show
 
+instance Exception AlonzoGenesisError where 
+  displayException = Api.docToString . Api.prettyError
+
+
 defaultAlonzoGenesis :: ShelleyBasedEra era -> Either AlonzoGenesisError AlonzoGenesis
 defaultAlonzoGenesis sbe = do
   let genesis = Api.alonzoGenesisDefaults (toCardanoEra sbe)