diff --git a/cabal.project b/cabal.project index 2a5232cf9a8..a5151556595 100644 --- a/cabal.project +++ b/cabal.project @@ -31,8 +31,8 @@ packages: trace-resources trace-forward -program-options - ghc-options: -Werror +-- program-options +-- ghc-options: -Werror test-show-details: direct diff --git a/cardano-testnet/cardano-testnet.cabal b/cardano-testnet/cardano-testnet.cabal index 2d9ab117aa9..e060cdbac2e 100644 --- a/cardano-testnet/cardano-testnet.cabal +++ b/cardano-testnet/cardano-testnet.cabal @@ -34,6 +34,7 @@ library build-depends: aeson , aeson-pretty , ansi-terminal + , async , bytestring , cardano-api ^>= 8.46 , cardano-cli ^>= 8.23 @@ -57,6 +58,7 @@ library , containers , contra-tracer , data-default-class + , Diff , directory , exceptions , filepath diff --git a/cardano-testnet/src/Testnet/Components/Query.hs b/cardano-testnet/src/Testnet/Components/Query.hs index a15cad08234..f3a09f7fdb8 100644 --- a/cardano-testnet/src/Testnet/Components/Query.hs +++ b/cardano-testnet/src/Testnet/Components/Query.hs @@ -248,13 +248,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 - runInBackground . runExceptT . foldEpochState nodeConfigFile socketPath QuickValidation (EpochNo maxBound) Nothing + runInBackground (return ()) . runExceptT . foldEpochState nodeConfigFile socketPath QuickValidation (EpochNo maxBound) Nothing $ \epochState slotNumber blockNumber -> do liftIO . writeIORef epochStateView $ Just (epochState, slotNumber, blockNumber) pure ConditionNotMet diff --git a/cardano-testnet/src/Testnet/Property/Util.hs b/cardano-testnet/src/Testnet/Property/Util.hs index 4a64d79ffbd..4d47459c7d7 100644 --- a/cardano-testnet/src/Testnet/Property/Util.hs +++ b/cardano-testnet/src/Testnet/Property/Util.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -15,11 +16,13 @@ module Testnet.Property.Util import Cardano.Api -import Control.Exception.Safe (MonadCatch) +import Control.Concurrent.Async +import qualified Control.Exception as E import Control.Monad import Control.Monad.Trans.Resource import qualified Data.Aeson as Aeson import GHC.Stack +import Network.Mux.Trace import qualified System.Environment as IO import System.Info (os) import qualified System.IO.Unsafe as IO @@ -60,18 +63,44 @@ integrationWorkspace workspaceName f = withFrozenCallStack $ isLinux :: Bool isLinux = os == "linux" - -- | Runs an action in background, and registers cleanup to `MonadResource m` --- The argument forces IO monad to prevent leaking of `MonadResource` to the child thread +-- Concurrency is tricky in the 'ResourceT' monad. See the "Concurrency" section of +-- https://www.fpcomplete.com/blog/understanding-resourcet/. runInBackground :: MonadTest m => MonadResource m - => MonadCatch m - => IO a + => IO () + -> IO a -> m () -runInBackground act = void . H.evalM $ allocate (H.async act) cleanUp - where - cleanUp :: H.Async a -> IO () - cleanUp a = H.cancel a >> void (H.link a) +runInBackground runOnException act = + void . H.evalIO + $ runResourceT + -- We don't 'wait' because this "background process" may not terminate. + -- If we 'wait' and it doesn't terminate, 'ResourceT' will not kill it + -- and the test will hang indefinitely. + -- Not waiting isn't a problem because this "background process" + -- is meant to run indefinitely and will be cleaned up by + -- 'ResourceT' when the test ends or fails. + -- We use 'asyncWithUnmask' because our logging thread is terminated via an exception. + -- In order to avoid competing for a file handle we must catch the exception which signals + -- the logging file is no longer being written to and we can now run the desired additional IO action we + -- want (runOnException). Attempting to share the 'FileHandle' and use concurrency primitives was not fruitful + -- and the section "Other ways to abuse ResourceT" in https://www.fpcomplete.com/blog/understanding-resourcet/ + -- confirms this is problematic in 'ResourceT'. + $ resourceForkWith (\_ -> do r <- H.asyncWithUnmask (\restore -> restore act `E.onException` runOnException) + linkOnly ignoreException r + ) $ return () + where + ignoreException :: E.SomeException -> Bool + ignoreException e = + case E.fromException e of + Just (MuxError errType _) -> + case errType of + MuxBearerClosed -> False + -- This is expected as the background thread is killed. + -- However we do want to be made aware about other + -- exceptions. + _ -> True + _ -> False decodeEraUTxO :: (IsShelleyBasedEra era, MonadTest m) => ShelleyBasedEra era -> Aeson.Value -> m (UTxO era) decodeEraUTxO _ = H.jsonErrorFail . Aeson.fromJSON diff --git a/cardano-testnet/src/Testnet/Runtime.hs b/cardano-testnet/src/Testnet/Runtime.hs index 903f1bd2567..3a230dc728b 100644 --- a/cardano-testnet/src/Testnet/Runtime.hs +++ b/cardano-testnet/src/Testnet/Runtime.hs @@ -1,10 +1,13 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} + module Testnet.Runtime ( startNode , startLedgerNewEpochStateLogging @@ -13,14 +16,25 @@ module Testnet.Runtime import Cardano.Api import qualified Cardano.Api as Api +import qualified Cardano.Ledger.Api as L +import qualified Cardano.Ledger.Shelley.LedgerState as L + import Prelude import Control.Exception.Safe import Control.Monad -import Control.Monad.State.Strict (StateT) +import Control.Monad.State.Strict import Control.Monad.Trans.Resource +import Data.Aeson +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.Algorithm.Diff +import Data.Algorithm.DiffOutput +import qualified Data.ByteString.Lazy.Char8 as BSC +import Data.Function import qualified Data.List as List import Data.Text (Text, unpack) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text import GHC.Stack import qualified GHC.Stack as GHC import Network.Socket (PortNumber) @@ -33,8 +47,9 @@ import qualified System.Process as IO import Testnet.Filepath import qualified Testnet.Ping as Ping import Testnet.Process.Run -import Testnet.Property.Util (runInBackground) -import Testnet.Types hiding (testnetMagic) +import Testnet.Property.Util +import Testnet.Types (NodeRuntime (NodeRuntime), TestnetRuntime (configurationFile), + poolSprockets) import Hedgehog (MonadTest) import qualified Hedgehog as H @@ -169,7 +184,12 @@ createSubdirectoryIfMissingNew parent subdirectory = GHC.withFrozenCallStack $ d pure subdirectory -- | Start ledger's new epoch state logging for the first node in the background. --- Logs will be placed in /logs/ledger-new-epoch-state.log +-- Pretty JSON logs will be placed in: +-- 1. /logs/ledger-new-epoch-state.log +-- 2. /logs/ledger-new-epoch-state-diffs.log +-- NB: The diffs represent the the changes in the 'NewEpochState' between each +-- block or turn of the epoch. We have excluded the 'stashedAVVMAddresses' +-- field of 'NewEpochState' in the JSON rendering. -- The logging thread will be cancelled when `MonadResource` releases all resources. -- Idempotent. startLedgerNewEpochStateLogging @@ -197,27 +217,112 @@ startLedgerNewEpochStateLogging testnetRuntime tmpWorkspace = withFrozenCallStac False -> do H.evalIO $ appendFile logFile "" socketPath <- H.noteM $ H.sprocketSystemName <$> H.headM (poolSprockets testnetRuntime) - _ <- runInBackground . runExceptT $ - foldEpochState - (configurationFile testnetRuntime) - (Api.File socketPath) - Api.QuickValidation - (EpochNo maxBound) - () - (\epochState _ _ -> handler logFile epochState) + + runInBackground + (do logFileContents <- IO.readFile logFile + let epochStateValues = epochStateBeforeAfterValues logFileContents + epochStateDiffs' = epochStateDiffs epochStateValues + Text.writeFile (logDir "ledger-epoch-state-diffs.log") epochStateDiffs' + ) + (do void $ runExceptT $ + foldEpochState + (configurationFile testnetRuntime) + (Api.File socketPath) + Api.QuickValidation + (EpochNo maxBound) + () + (\epochState _ _ -> + liftIO $ evalStateT (handler logFile epochState) 0 + ) + ) + + H.note_ $ "Started logging epoch states to: " <> logFile + where - handler :: FilePath -> AnyNewEpochState -> StateT () IO LedgerStateCondition - handler outputFp anyNewEpochState = handleException . liftIO $ do - appendFile outputFp $ "#### BLOCK ####" <> "\n" - appendFile outputFp $ show anyNewEpochState <> "\n" - pure ConditionNotMet + handler :: FilePath -> AnyNewEpochState -> StateT Int IO LedgerStateCondition + handler outputFpHandle (AnyNewEpochState sbe nes) = do + handleException . liftIO $ do + appendFile outputFpHandle $ "#### BLOCK ####" <> "\n" + appendFile outputFpHandle $ BSC.unpack (shelleyBasedEraConstraints sbe $ encodePretty nes) <> "\n" + pure ConditionNotMet where -- | Handle all sync exceptions and log them into the log file. We don't want to fail the test just -- because logging has failed. handleException = handle $ \(e :: SomeException) -> do - liftIO $ appendFile outputFp $ "Ledger new epoch logging failed - caught exception:\n" + liftIO $ appendFile outputFpHandle $ "Ledger new epoch logging failed - caught exception:\n" <> displayException e <> "\n" pure ConditionMet +-- TODO: Not sure why this isn't terminating. Read up on resourcet and how it works. +-- See concurrency section: https://www.fpcomplete.com/blog/understanding-resourcet/ +-- Probably need to use resourceForkWith but best to not use concurrency at all! + + +-- | Produce tuples that represent the change of the 'NewEpochState' after +-- a transition. +epochStateBeforeAfterValues + :: String + -> [(Text, Text)] +epochStateBeforeAfterValues logFileContents = + let allEpochStates = filter (/= "") . Text.splitOn "#### BLOCK ####" $ Text.pack logFileContents + in getAllTransitions allEpochStates + +getAllTransitions :: [Text] -> [(Text, Text)] +getAllTransitions [] = [] +getAllTransitions trans = + let (singleTransition, rest) = splitAt 2 trans + tupleSingleTransition = toTuple singleTransition + in case singleTransition of + [a] -> [(a,"")] + _ -> tupleSingleTransition ++ getAllTransitions (snd (head tupleSingleTransition) : rest) + where + toTuple [a,b] = [(a,b)] + toTuple [] = [] + toTuple _ = error "toTuple: a single transition was not generated" + +epochStateDiffs + :: [(Text,Text)] + -> Text +epochStateDiffs [] = "No epoch state values to compare" +epochStateDiffs states = + -- We first get the block number changes + labelAllEpochStateTransitions + [ Text.pack $ epochStateTransitionDiff (Text.unpack i) (Text.unpack n) + | (i, n) <- states + ] & Text.intercalate "\n" + where + labelSingleEpochStateTransition :: Int -> Text + labelSingleEpochStateTransition transitionNumber = + "Epoch state transition: " <> Text.pack (show transitionNumber) + + labelAllEpochStateTransitions [] = [] + labelAllEpochStateTransitions trans = + go trans (1 :: Int) [] + where + go [] _ acc = acc + go (x:xs) 1 _ = go xs 2 [labelSingleEpochStateTransition 1, x] + go (x:xs) n acc = go xs (n + 1) (acc ++ [labelSingleEpochStateTransition n, x]) + +epochStateTransitionDiff + :: String -- ^ Initial epoch state + -> String -- ^ Following epoch state + -> String +epochStateTransitionDiff initialState next = + let removeBlockNumberChangeInitial = lines initialState + removeBlockNumberChangeNext = lines next + diffResult = getGroupedDiff removeBlockNumberChangeInitial removeBlockNumberChangeNext + in if null diffResult + then "No changes in epoch state" + else ppDiff diffResult +instance (L.EraTxOut ledgerera, L.EraGov ledgerera) => ToJSON (L.NewEpochState ledgerera) where + toJSON (L.NewEpochState nesEL nesBprev nesBCur nesEs nesRu nesPd _stashedAvvm)= + object + [ "currentEpoch" .= nesEL + , "priorBlocks" .= nesBprev + , "currentEpochBlocks" .= nesBCur + , "currentEpochState" .= nesEs + , "rewardUpdate" .= nesRu + , "currentStakeDistribution" .= nesPd + ] diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/NoConfidence.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/NoConfidence.hs index 0fe251dedcd..4366cf82c58 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/NoConfidence.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/NoConfidence.hs @@ -131,7 +131,7 @@ hprop_gov_no_confidence = integrationWorkspace "no-confidence" $ \tempAbsBasePat epochStateView <- getEpochStateView configurationFile (File socketPath) - H.nothingFailM $ watchEpochStateUpdate epochStateView (EpochInterval 3) $ \(anyNewEpochState, _, _) -> + H.nothingFailM $ watchEpochStateUpdate epochStateView (EpochInterval 3) $ \anyNewEpochState-> pure $ committeeIsPresent True anyNewEpochState -- Step 2. Propose motion of no confidence. DRep and SPO voting thresholds must be met. @@ -223,13 +223,11 @@ hprop_gov_no_confidence = integrationWorkspace "no-confidence" $ \tempAbsBasePat -- Step 4. We confirm the no confidence motion has been ratified by checking -- for an empty constitutional committee. - - H.nothingFailM $ watchEpochStateUpdate epochStateView (EpochInterval 10) $ \(anyNewEpochState, _, _) -> - pure $ committeeIsPresent False anyNewEpochState + H.nothingFailM $ watchEpochStateUpdate epochStateView (EpochInterval 10) (return . committeeIsPresent False) -- | Checks if the committee is empty or not. -committeeIsPresent :: Bool -> AnyNewEpochState -> Maybe () -committeeIsPresent committeeExists (AnyNewEpochState sbe newEpochState) = +committeeIsPresent :: Bool -> (AnyNewEpochState, SlotNo, BlockNo) -> Maybe () +committeeIsPresent committeeExists (AnyNewEpochState sbe newEpochState, _, _) = caseShelleyToBabbageOrConwayEraOnwards (const $ error "Constitutional committee does not exist pre-Conway era") (const $ let mCommittee = newEpochState