Merge pull request #6346 from IntersectMBO/jordan/remove-integration-monad

Remove Integration Monad

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

@@ -38,6 +38,7 @@ library
 
   build-depends:        aeson
                       , aeson-pretty
+                      , annotated-exception
                       , ansi-terminal
                       , bytestring
                       , cardano-api ^>= 10.19
@@ -88,6 +89,8 @@ library
                       , process
                       , resourcet
                       , retry
+                      , rio
+                      , rio-orphans
                       , safe-exceptions
                       , scientific
                       , stm
@@ -99,6 +102,7 @@ library
                       , time
                       , transformers
                       , transformers-except
+                      , unliftio
                       , yaml
 
   hs-source-dirs:       src
@@ -111,17 +115,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.RunIO
                         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 +137,6 @@ library
   other-modules:        Parsers.Cardano
                         Parsers.Help
                         Parsers.Version
-                        Testnet.Start.Cardano
                         Testnet.TestEnumGenerator
                         Paths_cardano_testnet
 
@@ -265,6 +271,7 @@ test-suite cardano-testnet-test
                       , monad-control
                       , mtl
                       , process
+                      , resourcet
                       , regex-compat
                       , rio
                       , tasty ^>= 1.5

cardano-testnet/src/Parsers/Run.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Parsers.Run
@@ -11,13 +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           Testnet.Property.Run
+import           RIO (runRIO)
+import           RIO.Orphans 
 import           Testnet.Start.Cardano
 import           Testnet.Start.Types
 
@@ -60,8 +60,8 @@ createEnvOptions CardanoTestnetCreateEnvOptions
   , createEnvGenesisOptions=genesisOptions
   , createEnvOutputDir=outputDir
   , createEnvCreateEnvOptions=ceOptions
-  } =
-    testnetRoutine (UserProvidedEnv outputDir) $ \conf -> do
+  } = do 
+      conf <- mkConfigAbs outputDir
       createTestnetEnv
         testnetOptions genesisOptions ceOptions
         -- Do not add hashes to the main config file, so that genesis files
@@ -70,25 +70,25 @@ createEnvOptions CardanoTestnetCreateEnvOptions
 
 runCardanoOptions :: CardanoTestnetCliOptions -> IO ()
 runCardanoOptions CardanoTestnetCliOptions
-  { cliTestnetOptions=testnetOptions@CardanoTestnetOptions{cardanoOutputDir}
+  { cliTestnetOptions=testnetOptions
   , cliGenesisOptions=genesisOptions
   , cliNodeEnvironment=env
-  , cliUpdateTimestamps=updateTimestamps
-  } =
+  , cliUpdateTimestamps=updateTimestamps'
+  } = do 
     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

@@ -29,43 +29,44 @@ import qualified Cardano.Crypto.Hash.Blake2b as Crypto
 import qualified Cardano.Crypto.Hash.Class as Crypto
 import           Cardano.Ledger.BaseTypes (unsafeNonZero)
 import           Cardano.Ledger.Dijkstra.Genesis (DijkstraGenesis)
+import           Cardano.Node.Protocol.Byron
 
-import           Control.Exception.Safe (MonadCatch)
+import           Control.Exception
 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           Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Time.Clock as DTC
 import           Data.Word (Word64)
 import           GHC.Stack (HasCallStack)
 import qualified GHC.Stack as GHC
 import qualified Network.HTTP.Simple as HTTP
+import           RIO ( 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.RunIO (execCli_, liftIOAnnotated)
 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)
@@ -85,7 +86,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 :: ()
@@ -96,22 +97,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 <- liftIOAnnotated $ BS.readFile path
   let genesisHash = Crypto.hashWith id content :: Crypto.Hash Crypto.Blake2b_256 BS.ByteString
   pure . singleton (fromText key) $ toJSON genesisHash
 
@@ -122,31 +126,34 @@ 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 <- liftIOAnnotated 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
   => m AlonzoGenesis
 getDefaultAlonzoGenesis =
-  H.evalEither $ first prettyError Defaults.defaultAlonzoGenesis
+  case Defaults.defaultAlonzoGenesis of 
+    Right genesis -> return genesis
+    Left err -> throwM err
+
 
 numSeededUTxOKeys :: Int
 numSeededUTxOKeys = 3
 
 createSPOGenesisAndFiles
-  :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)
+  :: MonadIO m
+  => HasCallStack
+  => MonadThrow m
   => CardanoTestnetOptions -- ^ The options to use
   -> GenesisOptions
   -> TestnetOnChainParams
@@ -155,11 +162,14 @@ createSPOGenesisAndFiles
 createSPOGenesisAndFiles
   testnetOptions genesisOptions@GenesisOptions{genesisTestnetMagic}
   onChainParams
-  (TmpAbsolutePath tempAbsPath) = GHC.withFrozenCallStack $ do
+  (TmpAbsolutePath tempAbsPath) =  do
   AnyShelleyBasedEra sbe <- pure cardanoNodeEra
 
-  let genesisShelleyDirAbs = takeDirectory inputGenesisShelleyFp
-  genesisShelleyDir <- H.createDirectoryIfMissing genesisShelleyDirAbs
+  
+  let genesisShelleyDir = takeDirectory inputGenesisShelleyFp
+  
+  liftIOAnnotated $ System.createDirectoryIfMissing True genesisShelleyDir
+
   let -- At least there should be a delegator per DRep
       -- otherwise some won't be representing anybody
       numStakeDelegators = max 3 (fromIntegral cardanoNumDReps) :: Int
@@ -176,23 +186,20 @@ createSPOGenesisAndFiles
   let conwayGenesis' = Defaults.defaultConwayGenesis
       dijkstraGenesis' = dijkstraGenesisDefaults
 
-  (shelleyGenesis, alonzoGenesis, conwayGenesis, dijkstraGenesis) <- resolveOnChainParams onChainParams
-    (shelleyGenesis', alonzoGenesis', conwayGenesis', dijkstraGenesis')
+  (shelleyGenesis, alonzoGenesis, conwayGenesis, dijkstraGenesis)   
+     <- resolveOnChainParams onChainParams
+     (shelleyGenesis', alonzoGenesis', conwayGenesis', dijkstraGenesis')
 
   -- Write Genesis files to disk, so they can be picked up by create-testnet-data
-  H.lbsWriteFile inputGenesisAlonzoFp $ A.encodePretty alonzoGenesis
-  H.lbsWriteFile inputGenesisConwayFp $ A.encodePretty conwayGenesis
-  H.lbsWriteFile inputGenesisShelleyFp $ A.encodePretty shelleyGenesis
-  H.lbsWriteFile inputGenesisDijkstraFp $ A.encodePretty dijkstraGenesis
-
-  H.note_ $ "Number of pools: " <> show nPoolNodes
-  H.note_ $ "Number of stake delegators: " <> show numStakeDelegators
-  H.note_ $ "Number of seeded UTxO keys: " <> show numSeededUTxOKeys
-
+  liftIOAnnotated $ do
+    LBS.writeFile inputGenesisAlonzoFp $ A.encodePretty alonzoGenesis
+    LBS.writeFile inputGenesisConwayFp $ A.encodePretty conwayGenesis
+    LBS.writeFile inputGenesisShelleyFp $ A.encodePretty shelleyGenesis
+    LBS.writeFile inputGenesisDijkstraFp $ A.encodePretty dijkstraGenesis
   let era = toCardanoEra sbe
 
-  currentTime <- H.noteShowIO DTC.getCurrentTime
-  startTime <- H.noteShow $ DTC.addUTCTime startTimeOffsetSeconds currentTime
+  currentTime <- liftIOAnnotated DTC.getCurrentTime
+  let startTime = DTC.addUTCTime startTimeOffsetSeconds currentTime
 
   execCli_ $
     [ eraToString sbe, "genesis", "create-testnet-data" ]
@@ -216,10 +223,7 @@ createSPOGenesisAndFiles
     [  inputGenesisShelleyFp, inputGenesisAlonzoFp, inputGenesisConwayFp
      , tempAbsPath </> "byron.genesis.spec.json" -- Created by create-testnet-data
     ]
-    (\fp -> liftIO $ whenM (System.doesFileExist fp) (System.removeFile fp))
-
-  files <- H.listDirectory tempAbsPath
-  forM_ files H.note
+    (\fp -> liftIOAnnotated $ whenM (System.doesFileExist fp) (System.removeFile fp))
 
   return genesisShelleyDir
   where
@@ -235,23 +239,38 @@ createSPOGenesisAndFiles
     createTestnetDataFlag sbe =
         ["--spec-" ++ eraToString sbe, genesisInputFilepath sbe]
 
+
+
+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
  -> (ShelleyGenesis, AlonzoGenesis, ConwayGenesis, DijkstraGenesis)
  -> m (ShelleyGenesis, AlonzoGenesis, ConwayGenesis, DijkstraGenesis)
 resolveOnChainParams onChainParams geneses = case onChainParams of
 
-  DefaultParams -> pure geneses
+  DefaultParams -> do 
+    pure geneses
 
   OnChainParamsFile file -> do
-    eParams <- H.readJsonFile file
-    params <- H.leftFail eParams
-    pure $ blockfrostToGenesis geneses params
+    eParams <- eitherDecode <$> liftIOAnnotated (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 <- liftIOAnnotated $ HTTP.getResponseBody <$> HTTP.httpJSON mainnetParamsRequest
     pure $ blockfrostToGenesis geneses mainnetParams