Review changes

Author: Jimbo4350

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

@@ -47,7 +47,7 @@ import           Cardano.Api as Api hiding (txId)
 import           Cardano.Api.Ledger (Credential, DRepState, EpochInterval (..), KeyRole (DRepRole))
 import qualified Cardano.Api.Ledger as L
 import qualified Cardano.Api.UTxO as Utxo
-
+import Testnet.Runtime
 import           Cardano.Ledger.Api (ConwayGovState)
 import qualified Cardano.Ledger.Api as L
 import qualified Cardano.Ledger.Conway.Governance as L
@@ -253,13 +253,12 @@ getEpochStateView
   :: HasCallStack
   => MonadResource m
   => MonadTest m
-  => MonadCatch m
   => NodeConfigFile In -- ^ node Yaml configuration file path
   -> SocketPath -- ^ node socket path
   -> m EpochStateView
 getEpochStateView nodeConfigFile socketPath = withFrozenCallStack $ do
   epochStateView <- H.evalIO $ newIORef Nothing
-  H.asyncRegister_ . runExceptT . foldEpochState nodeConfigFile socketPath QuickValidation (EpochNo maxBound) Nothing
+  void . asyncRegister_ . runExceptT . foldEpochState nodeConfigFile socketPath QuickValidation (EpochNo maxBound) Nothing
     $ \epochState slotNumber blockNumber -> do
         liftIO . writeIORef epochStateView $ Just (epochState, slotNumber, blockNumber)
         pure ConditionNotMet

cardano-testnet/src/Testnet/Orphans.hs

@@ -2,7 +2,7 @@
 
 module Testnet.Orphans () where
 
-import           RIO (RIO(..), liftIO)
+import           RIO (RIO(..), throwString)
 
 instance MonadFail (RIO env) where 
-  fail = liftIO . fail
+  fail = throwString

cardano-testnet/src/Testnet/Process/RunIO.hs

@@ -1,4 +1,6 @@
 
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -44,6 +46,7 @@ defaultExecConfig = ExecConfig
 
 
 mkExecConfig :: ()
+  => HasCallStack
   => MonadIO m
   => FilePath
   -> IO.Sprocket
@@ -65,7 +68,8 @@ mkExecConfig tempBaseAbsPath sprocket networkId = do
 
 
 execCli'
-  :: MonadIO m
+  :: HasCallStack
+  => MonadIO m
   => ExecConfig
   -> [String]
   -> m String
@@ -94,14 +98,16 @@ execCli = GHC.withFrozenCallStack $ execFlex "cardano-cli" "CARDANO_CLI"
 -- When running outside a nix environment, the `pkgBin` describes the name of the binary
 -- to launch via cabal exec.
 execFlex
-  :: String
+  :: HasCallStack
+  => String
   -> String
   -> [String]
   -> RIO env String
 execFlex = execFlex' defaultExecConfig
 
 execFlex'
   :: MonadIO m
+  => HasCallStack
   => ExecConfig
   -> String
   -> String
@@ -215,8 +221,7 @@ exeSuffix = if OS.isWin32 then ".exe" else ""
 -- executable has been built.
 -- Throws an exception on failure.
 binDist
-  :: HasCallStack
-  => MonadIO m
+  :: (HasCallStack, MonadIO m)
   => String
   -- ^ Package name
   -> String
@@ -233,20 +238,25 @@ binDist pkg binaryEnv = do
               <> "\" if you are working with sources. Otherwise define "
               <> binaryEnv
               <> " and have it point to the executable you want."
-  contents <- liftIOAnnotated $ LBS.readFile planJsonFile
-
-  case eitherDecode contents of
-    Right plan -> case L.filter matching (plan & installPlan) of
-      (component:_) -> case component & binFile of
-        Just bin -> return $ addExeSuffix (T.unpack bin)
-        Nothing -> error $ "missing \"bin-file\" key in plan component: " <> show component <> " in the plan in: " <> planJsonFile
-      [] -> error $ "Cannot find \"component-name\" key with the value \"exe:" <> pkg <> "\" in the plan in: " <> planJsonFile
-    Left message -> error $ "Cannot decode plan in " <> planJsonFile <> ": " <> message
-  where matching :: Component -> Bool
-        matching component = case componentName component of
-          Just name -> name == "exe:" <> T.pack pkg
-          Nothing -> False
 
+  Plan{installPlan} <- eitherDecode <$> liftIOAnnotated (LBS.readFile planJsonFile)
+      >>= \case
+        Left message -> error $ "Cannot decode plan in " <> planJsonFile <> ": " <> message
+        Right plan -> pure plan
+
+  let componentName = "exe:" <> fromString pkg
+  case findComponent componentName installPlan of
+    Just Component{binFile=Just binFilePath} -> pure . addExeSuffix $ T.unpack binFilePath
+    Just component@Component{binFile=Nothing} ->
+      error $ "missing \"bin-file\" key in plan component: " <> show component <> " in the plan in: " <> planJsonFile
+    Nothing ->
+      error $ "Cannot find \"component-name\" key with the value \"exe:" <> pkg <> "\" in the plan in: " <> planJsonFile
+  where
+    findComponent :: Text -> [Component] -> Maybe Component
+    findComponent _ [] = Nothing
+    findComponent needle (c@Component{componentName, components}:topLevelComponents)
+      | componentName == Just needle = Just c
+      | otherwise = findComponent needle topLevelComponents <|> findComponent needle components
 
 
 procNode
@@ -278,7 +288,7 @@ procFlex
   -- ^ Captured stdout
 procFlex = procFlex' defaultExecConfig
 
-
+-- This will also catch async exceptions as well.
 liftIOAnnotated :: (HasCallStack, MonadIO m) => IO a -> m a 
 liftIOAnnotated action = GHC.withFrozenCallStack $
-  liftIO $ action `catch` (\(e :: SomeException) -> throwM $ exceptionWithCallStack e)
+  liftIOAnnotated $ action `catch` (\(e :: SomeException) -> throwM $ exceptionWithCallStack e)

cardano-testnet/src/Testnet/Runtime.hs

@@ -156,7 +156,7 @@ startNode tp node ipv4 port _testnetMagic nodeCmd = GHC.withFrozenCallStack $ do
 
     isClosed <- liftIOAnnotated $ Ping.waitForPortClosed 30 0.1 port
     unless isClosed $ 
-      throwString $ "Port  is still in use after 30 seconds before starting node: " <> show port 
+      throwString $ "Port is still in use after 30 seconds before starting node: " <> show port 
 
     (Just stdIn, _, _, hProcess, _)
       <- firstExceptT ProcessRelatedFailure $ initiateProcess
@@ -278,7 +278,6 @@ createSubdirectoryIfMissingNew parent subdirectory = GHC.withFrozenCallStack $ d
 -- Idempotent.
 startLedgerNewEpochStateLogging
   :: HasCallStack
-  => MonadCatch m
   => MonadResource m
   => TestnetRuntime
   -> FilePath -- ^ tmp workspace directory
@@ -294,23 +293,24 @@ startLedgerNewEpochStateLogging testnetRuntime tmpWorkspace = withFrozenCallStac
     False -> do
       throwString $ "Log directory does not exist: " <> logDir <> " - cannot start logging epoch states"
 
-  liftIOAnnotated $ IO.doesFileExist logFile >>= \case
+  liftIOAnnotated (IO.doesFileExist logFile) >>= \case
     True -> return () 
-    False -> liftIO $ appendFile logFile ""
-
-  let socketPath = case uncons (testnetSprockets testnetRuntime) of
-        Just (sprocket, _) -> H.sprocketSystemName sprocket
-        Nothing            -> throwString "No testnet sprocket available"
-
-  let act = runExceptT $
-              foldEpochState
-                (configurationFile testnetRuntime)
-                (Api.File socketPath)
-                Api.QuickValidation
-                (EpochNo maxBound)
-                Nothing
-                (handler logFile diffFile)
-  void $ asyncRegister_ act
+    False -> do 
+      liftIOAnnotated $ appendFile logFile ""
+
+      let socketPath = case uncons (testnetSprockets testnetRuntime) of
+            Just (sprocket, _) -> H.sprocketSystemName sprocket
+            Nothing            -> throwString "No testnet sprocket available"
+    
+      void $ asyncRegister_ . runExceptT $
+                  foldEpochState
+                    (configurationFile testnetRuntime)
+                    (Api.File socketPath)
+                    Api.QuickValidation
+                    (EpochNo maxBound)
+                    Nothing
+                    (handler logFile diffFile)
+                    
   where
     handler :: FilePath -- ^ log file
             -> FilePath -- ^ diff file

cardano-testnet/src/Testnet/Start/Cardano.hs

@@ -80,6 +80,7 @@ import Testnet.Orphans ()
 import RIO.Orphans (ResourceMap)
 import UnliftIO.Async
 
+
 -- | There are certain conditions that need to be met in order to run
 -- a valid node cluster.
 testMinimumConfigurationRequirements :: ()
@@ -90,7 +91,7 @@ testMinimumConfigurationRequirements options = withFrozenCallStack $ do
   when (cardanoNumPools options < 1) $ do
     throwString "Need at least one SPO node to produce blocks, but got none."
 
-liftToIntegration :: RIO ResourceMap a -> H.Integration a 
+liftToIntegration :: HasCallStack => RIO ResourceMap a -> H.Integration a 
 liftToIntegration  r = do 
    rMap <- lift $ lift getInternalState 
    liftIOAnnotated $ runRIO rMap r

cardano-testnet/src/Testnet/Start/Types.hs

@@ -42,7 +42,6 @@ module Testnet.Start.Types
   , NodeConfigurationYaml
   , mkConf
   , mkConfigAbs
-  , mkConfig
   ) where
 
 import           Cardano.Api hiding (cardanoEra)
@@ -52,6 +51,7 @@ import           Cardano.Ledger.Conway.Genesis (ConwayGenesis)
 import           Prelude
 
 import           Control.Exception (throw)
+import           Control.Monad (unless)
 import qualified Data.Aeson as Aeson
 import           Data.Aeson.Types (parseFail)
 import           Data.Char (toLower)
@@ -288,7 +288,8 @@ data Conf = Conf
   , updateTimestamps :: UpdateTimestamps
   } deriving (Eq, Show)
 
--- Logs the argument in the test.
+-- |  Same as mkConfig except that it renders the path 
+-- when failing in a property test.
 mkConf :: (HasCallStack, MonadTest m) => FilePath -> m Conf
 mkConf tempAbsPath' = withFrozenCallStack $ do
   H.note_ tempAbsPath'
@@ -304,17 +305,16 @@ mkConfig tempAbsPath' =
     , updateTimestamps = DontUpdateTimestamps
     }
 
+-- | Create a 'Conf' from an absolute path, with Genesis Hashes enabled
+-- and updating time stamps disabled.
 mkConfigAbs :: FilePath -> IO Conf
 mkConfigAbs userOutputDir = do 
   absUserOutputDir <-  makeAbsolute userOutputDir
   dirExists <- doesDirectoryExist absUserOutputDir
   let conf = mkConfig absUserOutputDir 
-  if dirExists then
-    -- Happens when the environment has previously been created by the user
-    return conf
-  else do
+  unless dirExists $
     createDirectory absUserOutputDir
-    return conf
+  pure conf
 
 -- | @anyEraToString (AnyCardanoEra ByronEra)@ returns @"byron"@
 anyEraToString :: AnyCardanoEra -> String

cardano-testnet/test/cardano-testnet-test/cardano-testnet-test.hs

@@ -12,6 +12,7 @@ import qualified Cardano.Testnet.Test.Cli.Plutus.Scripts
 import qualified Cardano.Testnet.Test.Cli.Query
 import qualified Cardano.Testnet.Test.Cli.QuerySlotNumber
 import qualified Cardano.Testnet.Test.Cli.StakeSnapshot
+import qualified Cardano.Testnet.Test.SanityCheck
 import qualified Cardano.Testnet.Test.Cli.Transaction
 import qualified Cardano.Testnet.Test.Cli.Transaction.RegisterDeregisterStakeAddress
 import qualified Cardano.Testnet.Test.DumpConfig
@@ -56,6 +57,7 @@ tests = do
     [ T.testGroup "Spec"
         [ T.testGroup "Ledger Events"
            [ ignoreOnWindows "Sanity Check" LedgerEvents.hprop_ledger_events_sanity_check
+           , ignoreOnWindows "Async Register" Cardano.Testnet.Test.SanityCheck.hprop_asyncRegister_sanity_check
            -- FIXME this tests gets stuck - investigate why
            -- , ignoreOnWindows "Treasury Growth" Gov.prop_check_if_treasury_is_growing
             -- TODO: Replace foldBlocks with checkConditionResult