From 1b9b76b24a82ef2c226570088370dff0ed98ddab Mon Sep 17 00:00:00 2001 From: Michael Bishop Date: Wed, 16 Jan 2019 18:47:47 -0400 Subject: [PATCH 1/8] [DEVOPS-1131] scriptable cluster test automation --- cabal.project.freeze | 7 +- chain/src/Pos/Chain/Update/BlockVersion.hs | 10 +- chain/src/Pos/Chain/Update/Configuration.hs | 24 +- client/src/Pos/Client/KeyStorage.hs | 1 + client/src/Pos/Client/Txp/Balances.hs | 1 + cluster/app/demo/Main.hs | 1 + db/src/Pos/DB/Block/Epoch.hs | 2 +- db/src/Pos/DB/Txp/Logic/Local.hs | 2 + db/src/Pos/DB/Update/GState.hs | 9 + default.nix | 1 + infra/src/Pos/Infra/Shutdown/Logic.hs | 36 +- infra/src/Pos/Infra/Shutdown/Types.hs | 5 +- lib/src/Pos/Client/CLI/NodeOptions.hs | 23 ++ lib/src/Pos/Client/CLI/Options.hs | 11 + lib/src/Pos/DB/DB.hs | 1 + lib/src/Pos/Launcher/Configuration.hs | 21 + lib/src/Pos/Launcher/Resource.hs | 2 +- lib/src/Pos/Launcher/Runner.hs | 17 +- lib/src/Pos/Util/UserSecret.hs | 2 + lib/test/Test/Pos/Launcher/Configuration.hs | 2 +- nix/.stack-pkgs.nix | 1 + nix/.stack.nix/cardano-sl-script-runner.nix | 96 +++++ nix/overlays/required.nix | 5 + pkgs/default.nix | 115 ++++++ script-runner/BlockParser.hs | 36 ++ script-runner/LICENSE | 20 + script-runner/Makefile | 8 + script-runner/Setup.hs | 2 + script-runner/TestCases.hs | 131 ++++++ script-runner/cardano-sl-script-runner.cabal | 91 ++++ script-runner/common/AutomatedTestRunner.hs | 411 +++++++++++++++++++ script-runner/common/BrickUI.hs | 272 ++++++++++++ script-runner/common/BrickUITypes.hs | 46 +++ script-runner/common/NodeControl.hs | 209 ++++++++++ script-runner/common/OrphanedLenses.hs | 12 + script-runner/common/PocMode.hs | 268 ++++++++++++ script-runner/common/Types.hs | 29 ++ script-runner/log-config.yaml | 24 ++ script-runner/runtest.nix | 16 + script-runner/shell.nix | 27 ++ script-runner/topology-local.yaml | 5 + script-runner/topology-mainnet.yaml | 5 + script-runner/topology-staging.yaml | 5 + script-runner/topology-testnet.yaml | 5 + script-runner/topology.yaml | 6 + scripts/policies/policy_script-runner.yaml | 84 ++++ stack.yaml | 1 + util/src/Pos/Util/Wlog/Compatibility.hs | 5 + 48 files changed, 2075 insertions(+), 38 deletions(-) create mode 100644 nix/.stack.nix/cardano-sl-script-runner.nix create mode 100644 script-runner/BlockParser.hs create mode 100644 script-runner/LICENSE create mode 100644 script-runner/Makefile create mode 100644 script-runner/Setup.hs create mode 100644 script-runner/TestCases.hs create mode 100644 script-runner/cardano-sl-script-runner.cabal create mode 100644 script-runner/common/AutomatedTestRunner.hs create mode 100644 script-runner/common/BrickUI.hs create mode 100644 script-runner/common/BrickUITypes.hs create mode 100644 script-runner/common/NodeControl.hs create mode 100644 script-runner/common/OrphanedLenses.hs create mode 100644 script-runner/common/PocMode.hs create mode 100644 script-runner/common/Types.hs create mode 100644 script-runner/log-config.yaml create mode 100644 script-runner/runtest.nix create mode 100644 script-runner/shell.nix create mode 100644 script-runner/topology-local.yaml create mode 100644 script-runner/topology-mainnet.yaml create mode 100644 script-runner/topology-staging.yaml create mode 100644 script-runner/topology-testnet.yaml create mode 100644 script-runner/topology.yaml create mode 100644 scripts/policies/policy_script-runner.yaml diff --git a/cabal.project.freeze b/cabal.project.freeze index 61528ecba96..e1eb135755c 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -27,6 +27,7 @@ constraints: Cabal ==2.2.0.1, beam-migrate ==0.3.2.1, beam-sqlite ==0.3.2.3, bifunctors ==5.5.3, + brick ==0.37.2, canonical-json ==0.5.0.1, case-insensitive ==1.2.0.11, cassava ==0.5.1.0, @@ -99,7 +100,6 @@ constraints: Cabal ==2.2.0.1, mmorph ==1.1.2, monad-control ==1.0.2.3, mono-traversable ==1.0.9.0, - mtl ==2.2.2, mwc-random ==0.13.6.0, neat-interpolation ==0.3.2.2, network ==2.6.3.6, @@ -110,7 +110,6 @@ constraints: Cabal ==2.2.0.1, normaldistribution ==1.1.0.3, optparse-applicative ==0.14.3.0, optparse-simple ==0.1.0, - parsec ==3.1.13.0, parser-combinators ==1.0.0, parsers ==0.12.9, pipes ==4.3.9, @@ -147,7 +146,6 @@ constraints: Cabal ==2.2.0.1, split ==0.2.3.3, sqlite-simple ==0.4.16.0, sqlite-simple-errors ==0.6.1.0, - stm ==2.4.5.1, stm-chans ==3.0.0.4, streaming-commons ==0.2.1.0, strict ==0.3.2, @@ -159,7 +157,6 @@ constraints: Cabal ==2.2.0.1, tagged ==0.8.5, tar ==0.5.1.0, temporary ==1.3, - text ==1.2.3.1, th-utilities ==0.2.0.1, these ==0.7.5, time-units ==1.0.0, @@ -167,6 +164,7 @@ constraints: Cabal ==2.2.0.1, transformers-base ==0.4.5.2, transformers-lift ==0.2.0.1, trifecta ==2, + turtle ==1.5.12, universum ==1.2.0, unix-compat ==0.5.1, unliftio ==0.2.8.1, @@ -175,6 +173,7 @@ constraints: Cabal ==2.2.0.1, uuid ==1.3.13, validation ==1, vector ==0.12.0.1, + vty ==5.21, wai ==3.2.1.2, wai-app-static ==3.1.6.2, wai-cors ==0.2.6, diff --git a/chain/src/Pos/Chain/Update/BlockVersion.hs b/chain/src/Pos/Chain/Update/BlockVersion.hs index 2f97b48cf14..54e91f9180d 100644 --- a/chain/src/Pos/Chain/Update/BlockVersion.hs +++ b/chain/src/Pos/Chain/Update/BlockVersion.hs @@ -9,9 +9,7 @@ import Universum import Data.Aeson.TH (defaultOptions, deriveJSON) import Data.SafeCopy (base, deriveSafeCopySimple) -import Formatting (bprint, shown) import qualified Formatting.Buildable as Buildable -import qualified Prelude import Pos.Binary.Class (Cons (..), Field (..), deriveSimpleBi) import Pos.Util.Some (Some, liftLensSome) @@ -21,14 +19,10 @@ data BlockVersion = BlockVersion { bvMajor :: !Word16 , bvMinor :: !Word16 , bvAlt :: !Word8 - } deriving (Eq, Generic, Ord, Typeable) - -instance Show BlockVersion where - show BlockVersion {..} = - intercalate "." [show bvMajor, show bvMinor, show bvAlt] + } deriving (Eq, Generic, Ord, Typeable, Show) instance Buildable BlockVersion where - build = bprint shown + build BlockVersion{..} = fromString $ intercalate "." [show bvMajor, show bvMinor, show bvAlt] instance Hashable BlockVersion diff --git a/chain/src/Pos/Chain/Update/Configuration.hs b/chain/src/Pos/Chain/Update/Configuration.hs index 0da2118ba8b..f5e26fe1eae 100644 --- a/chain/src/Pos/Chain/Update/Configuration.hs +++ b/chain/src/Pos/Chain/Update/Configuration.hs @@ -15,22 +15,29 @@ module Pos.Chain.Update.Configuration , curSoftwareVersion , currentSystemTag + + , ccApplicationName_L + , ccLastKnownBlockVersion_L + , ccApplicationVersion_L + , ccSystemTag_L ) where import Universum -import Data.Aeson (FromJSON (..), ToJSON (..), genericToJSON, - withObject, (.:), (.:?)) -import Data.Aeson.Options (defaultOptions) +import Control.Lens (makeLensesWith) +import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, + (.:), (.:?), (.=)) import Data.Maybe (fromMaybe) import Data.Reflection (Given (..), give) import Distribution.System (buildArch, buildOS) -import Pos.Chain.Update.ApplicationName (ApplicationName) +import Pos.Chain.Update.ApplicationName + (ApplicationName (ApplicationName)) import Pos.Chain.Update.BlockVersion (BlockVersion (..)) import Pos.Chain.Update.SoftwareVersion (SoftwareVersion (..)) import Pos.Chain.Update.SystemTag (SystemTag (..), archHelper, osHelper) +import Pos.Util (postfixLFields) ---------------------------------------------------------------------------- -- Config itself @@ -57,8 +64,15 @@ data UpdateConfiguration = UpdateConfiguration } deriving (Eq, Generic, Show) +makeLensesWith postfixLFields ''UpdateConfiguration + instance ToJSON UpdateConfiguration where - toJSON = genericToJSON defaultOptions + toJSON (UpdateConfiguration (ApplicationName appname) lkbv appver (SystemTag systag)) = object [ + "applicationName" .= appname + , "lastKnownBlockVersion" .= lkbv + , "applicationVersion" .= appver + , "systemTag" .= systag + ] instance FromJSON UpdateConfiguration where parseJSON = withObject "UpdateConfiguration" $ \o -> do diff --git a/client/src/Pos/Client/KeyStorage.hs b/client/src/Pos/Client/KeyStorage.hs index 780c5757987..e0befb5df93 100644 --- a/client/src/Pos/Client/KeyStorage.hs +++ b/client/src/Pos/Client/KeyStorage.hs @@ -71,6 +71,7 @@ getSecretKeys = AllUserSecrets <$> getSecretKeysPlain getSecretKeysPlain :: MonadKeysRead m => m [EncryptedSecretKey] getSecretKeysPlain = view usKeys <$> getSecret +{-# INLINE addSecretKey #-} addSecretKey :: MonadKeys m => EncryptedSecretKey -> m () addSecretKey sk = modifySecret $ \us -> if view usKeys us `containsKey` sk diff --git a/client/src/Pos/Client/Txp/Balances.hs b/client/src/Pos/Client/Txp/Balances.hs index 1a61e7a623c..3cea535c2bd 100644 --- a/client/src/Pos/Client/Txp/Balances.hs +++ b/client/src/Pos/Client/Txp/Balances.hs @@ -39,6 +39,7 @@ getBalanceFromUtxo :: MonadBalances m => GenesisData -> Address -> m Coin getBalanceFromUtxo genesisData addr = getTotalCoinsInUtxo <$> getOwnUtxo genesisData addr +{-# INLINE getOwnUtxosGenesis #-} getOwnUtxosGenesis :: Applicative m => GenesisData -> [Address] -> m Utxo getOwnUtxosGenesis genesisData addrs = pure $ filterUtxoByAddrs addrs $ genesisUtxo genesisData diff --git a/cluster/app/demo/Main.hs b/cluster/app/demo/Main.hs index fd9b8fc2248..e377725c92a 100644 --- a/cluster/app/demo/Main.hs +++ b/cluster/app/demo/Main.hs @@ -80,6 +80,7 @@ main = void $ do putTextFromStart $ "..." <> nodeId <> " OK!" when (nodeType /= NodeEdge) $ putText $ "\n......address: " <> toText (env ! "LISTEN") + -- todo, dont mapm over chars putTextLn $ "\n......api address: " <> toText (env ! "NODE_API_ADDRESS") <> "\n......doc address: " <> toText (env ! "NODE_DOC_ADDRESS") diff --git a/db/src/Pos/DB/Block/Epoch.hs b/db/src/Pos/DB/Block/Epoch.hs index 46f78c0102f..36c9d5ab105 100644 --- a/db/src/Pos/DB/Block/Epoch.hs +++ b/db/src/Pos/DB/Block/Epoch.hs @@ -237,7 +237,7 @@ renderConsolidateError = \case CEBlockLookupFailed fn lsi h -> fn <> sformat (": block lookup failed on (" % build % ", " % build % ")") lsi h CEBBlockNotFound fn lsi hh -> - fn <> sformat (": block mssing : " % build % " " % build) lsi hh + fn <> sformat (": block missing : " % build % " " % build) lsi hh -- ----------------------------------------------------------------------------- diff --git a/db/src/Pos/DB/Txp/Logic/Local.hs b/db/src/Pos/DB/Txp/Logic/Local.hs index f87bc85b951..34c68eed2c9 100644 --- a/db/src/Pos/DB/Txp/Logic/Local.hs +++ b/db/src/Pos/DB/Txp/Logic/Local.hs @@ -64,6 +64,7 @@ type TxpProcessTransactionMode ctx m = , CanJsonLog m ) +{-# INLINE txProcessTransaction #-} -- | Process transaction. 'TxId' is expected to be the hash of -- transaction in 'TxAux'. Separation is supported for optimization -- only. @@ -196,6 +197,7 @@ txProcessTransactionAbstract epochSlots genesisConfig buildEnv txAction itw@(txI (Left err@(ToilTipsMismatch {})) -> reportError (pretty err) _ -> pass +{-# INLINE txNormalize #-} -- | 1. Recompute UtxoView by current MemPool -- | 2. Remove invalid transactions from MemPool -- | 3. Set new tip to txp local data diff --git a/db/src/Pos/DB/Update/GState.hs b/db/src/Pos/DB/Update/GState.hs index 123a07484b6..9bad48a8d78 100644 --- a/db/src/Pos/DB/Update/GState.hs +++ b/db/src/Pos/DB/Update/GState.hs @@ -16,6 +16,7 @@ module Pos.DB.Update.GState , getMaxBlockSize , getSlottingData , getEpochProposers + , getAllProposals -- * Operations , UpdateOp (..) @@ -209,6 +210,10 @@ initGStateUS genesisConfig = do data PropIter +-- proposals added by PutProposal, and removed by DeleteProposal +-- upModifierToBatch takes a list of proposals to add&delete +-- listed via getAllProposals, getOldProposals, getDeepProposals, getProposalsByApp +-- does not contain confirmed proposals instance DBIteratorClass PropIter where type IterKey PropIter = UpId type IterValue PropIter = ProposalState @@ -219,6 +224,10 @@ proposalSource :: => ConduitT () (IterType PropIter) (ResourceT m) () proposalSource = dbIterSource GStateDB (Proxy @PropIter) +getAllProposals :: (MonadDBRead m, MonadUnliftIO m) => m [(UpId, ProposalState)] +getAllProposals = do + runConduitRes $ proposalSource .| CL.consume + -- TODO: it can be optimized by storing some index sorted by -- 'SlotId's, but I don't think it may be crucial. -- | Get all proposals which were issued no later than given slot. diff --git a/default.nix b/default.nix index a317f3936ca..60d290ebd14 100644 --- a/default.nix +++ b/default.nix @@ -271,6 +271,7 @@ let // { inherit (self.cardanoPackages) cardano-sl cardano-sl-auxx + cardano-sl-script-runner cardano-sl-chain cardano-sl-cluster cardano-sl-core diff --git a/infra/src/Pos/Infra/Shutdown/Logic.hs b/infra/src/Pos/Infra/Shutdown/Logic.hs index 90ebc7c31c9..a33cb04df87 100644 --- a/infra/src/Pos/Infra/Shutdown/Logic.hs +++ b/infra/src/Pos/Infra/Shutdown/Logic.hs @@ -1,11 +1,13 @@ module Pos.Infra.Shutdown.Logic ( triggerShutdown + , triggerShutdown' , waitForShutdown ) where +import System.Exit (ExitCode (ExitFailure)) import Universum -import Control.Concurrent.STM (check, readTVar, writeTVar) +import Control.Concurrent.STM (readTVar, retry, writeTVar) import Pos.Infra.InjectFail (FInject (..), testLogFInject) import Pos.Infra.Shutdown.Class (HasShutdownContext (..)) @@ -13,16 +15,36 @@ import Pos.Infra.Shutdown.Types (ShutdownContext (..), shdnFInjects, shdnIsTriggered) import Pos.Util.Wlog (WithLogger, logInfo) -triggerShutdown +{-# INLINE triggerShutdown' #-} +triggerShutdown' :: (MonadIO m, MonadReader ctx m, WithLogger m, HasShutdownContext ctx) - => m () -triggerShutdown = do + => ExitCode -> m () +triggerShutdown' exitcode = do shutCtx <- view shutdownContext doFail <- liftIO $ testLogFInject (shutCtx ^. shdnFInjects) FInjIgnoreShutdown + applyWrongCode <- liftIO $ testLogFInject (shutCtx ^. shdnFInjects) FInjApplyUpdateWrongExitCode + let + realCode = if applyWrongCode + then ExitFailure 42 -- inject wrong exit code + else exitcode unless doFail $ do logInfo "NODE SHUTDOWN TRIGGERED, WAITING FOR WORKERS TO TERMINATE" - view (shutdownContext . shdnIsTriggered) >>= atomically . flip writeTVar True + view (shutdownContext . shdnIsTriggered) >>= atomically . flip writeTVar (Just realCode) + +{-# INLINE triggerShutdown #-} +triggerShutdown + :: (MonadIO m, MonadReader ctx m, WithLogger m, HasShutdownContext ctx) + => m () +triggerShutdown = triggerShutdown' $ ExitFailure 20 -- special exit code to indicate an update -- | Wait for the shutdown var to be true. -waitForShutdown :: ShutdownContext -> IO () -waitForShutdown (ShutdownContext shutdownTriggered _) = atomically (readTVar shutdownTriggered >>= check) +waitForShutdown :: ShutdownContext -> IO ExitCode +waitForShutdown (ShutdownContext shutdownTriggered _) = do + let + go :: STM ExitCode + go = do + res <- readTVar shutdownTriggered + case res of + Nothing -> retry + Just a -> pure a + atomically go diff --git a/infra/src/Pos/Infra/Shutdown/Types.hs b/infra/src/Pos/Infra/Shutdown/Types.hs index 3e7850edf16..6ee9429dc8e 100644 --- a/infra/src/Pos/Infra/Shutdown/Types.hs +++ b/infra/src/Pos/Infra/Shutdown/Types.hs @@ -5,15 +5,16 @@ module Pos.Infra.Shutdown.Types , shdnIsTriggered, shdnFInjects ) where +import System.Exit (ExitCode) import Universum import Control.Lens (makeLenses) import Pos.Infra.InjectFail (FInjects) data ShutdownContext = ShutdownContext - { _shdnIsTriggered :: !(TVar Bool) + { _shdnIsTriggered :: !(TVar (Maybe ExitCode)) + -- ^ If this flag is `Just`, then workers should stop. , _shdnFInjects :: !(FInjects IO) - -- ^ If this flag is `True`, then workers should stop. } makeLenses ''ShutdownContext diff --git a/lib/src/Pos/Client/CLI/NodeOptions.hs b/lib/src/Pos/Client/CLI/NodeOptions.hs index 630fd9f21dd..ae98e3e621e 100644 --- a/lib/src/Pos/Client/CLI/NodeOptions.hs +++ b/lib/src/Pos/Client/CLI/NodeOptions.hs @@ -17,16 +17,37 @@ module Pos.Client.CLI.NodeOptions , getSimpleNodeOptions , getNodeApiOptions , usageExample + + , dbPath_L + , rebuildDB_L + , cnaAssetLockPath_L + , devGenesisSecretI_L + , publicKeyfilePath_L + , keyfilePath_L + , networkConfigOpts_L + , jlPath_L + , commonArgs_L + , updateLatestPath_L + , updateWithPackage_L + , route53Params_L + , enableMetrics_L + , ekgParams_L + , statsdParams_L + , cnaDumpGenesisDataPath_L + , cnaDumpConfiguration_L + , cnaFInjectsSpec_L ) where import Universum +import Control.Lens (makeLensesWith) import Data.Version (showVersion) import NeatInterpolation (text) import Options.Applicative (Parser, auto, execParser, footerDoc, fullDesc, header, help, helper, info, infoOption, long, metavar, option, progDesc, showDefault, strOption, switch, value) +import Pos.Util (postfixLFields) import Text.PrettyPrint.ANSI.Leijen (Doc) import Paths_cardano_sl (version) @@ -67,6 +88,8 @@ data CommonNodeArgs = CommonNodeArgs , cnaFInjectsSpec :: !FInjectsSpec } deriving Show +makeLensesWith postfixLFields ''CommonNodeArgs + commonNodeArgsParser :: Parser CommonNodeArgs commonNodeArgsParser = do dbPath <- optional $ strOption $ diff --git a/lib/src/Pos/Client/CLI/Options.hs b/lib/src/Pos/Client/CLI/Options.hs index e39d2d8a3d5..8cdca6f5bb0 100644 --- a/lib/src/Pos/Client/CLI/Options.hs +++ b/lib/src/Pos/Client/CLI/Options.hs @@ -18,14 +18,23 @@ module Pos.Client.CLI.Options , templateParser , nodeIdOption + + , logConfig_L + , logPrefix_L + , logConsoleOff_L + , reportServers_L + , updateServers_L + , configurationOptions_L ) where import Universum +import Control.Lens (makeLensesWith) import Data.Default (def) import Data.Time.Units (fromMicroseconds) import qualified Options.Applicative as Opt import Options.Applicative.Builder.Internal (HasMetavar, HasName) +import Pos.Util (postfixLFields) import Pos.Util.OptParse (fromParsec) import Pos.Communication (NodeId) @@ -44,6 +53,8 @@ data CommonArgs = CommonArgs , configurationOptions :: !ConfigurationOptions } deriving Show +makeLensesWith postfixLFields ''CommonArgs + commonArgsParser :: Opt.Parser CommonArgs commonArgsParser = do logConfig <- optionalLogConfig diff --git a/lib/src/Pos/DB/DB.hs b/lib/src/Pos/DB/DB.hs index 67d8af20c6d..3dc07c9513f 100644 --- a/lib/src/Pos/DB/DB.hs +++ b/lib/src/Pos/DB/DB.hs @@ -17,6 +17,7 @@ import Pos.DB.Lrc (prepareLrcDB) import Pos.DB.Update (getAdoptedBVData) import Pos.GState.GState (prepareGStateDB) +{-# INLINE initNodeDBs #-} -- | Initialize DBs if necessary. initNodeDBs :: forall m diff --git a/lib/src/Pos/Launcher/Configuration.hs b/lib/src/Pos/Launcher/Configuration.hs index 4d936c00e42..8800d030cc7 100644 --- a/lib/src/Pos/Launcher/Configuration.hs +++ b/lib/src/Pos/Launcher/Configuration.hs @@ -21,6 +21,22 @@ module Pos.Launcher.Configuration , dumpGenesisData + , ccGenesis_L + , ccNtp_L + , ccUpdate_L + , ccSsc_L + , ccDlg_L + , ccTxp_L + , ccBlock_L + , ccNode_L + , ccWallet_L + , ccReqNetMagic_L + + , cfoFilePath_L + , cfoKey_L + , cfoSystemStart_L + , cfoSeed_L + -- Exposed mostly for testing. , readAssetLockedSrcAddrs ) where @@ -45,6 +61,7 @@ import System.FilePath (takeDirectory) import Ntp.Client (NtpConfiguration) +import Control.Lens (makeLensesWith) import Pos.Chain.Genesis as Genesis (Config (..), GenesisData (..), StaticConfig, canonicalGenesisJson, mkConfigFromStaticConfig, prettyGenesisJson) @@ -52,6 +69,7 @@ import Pos.Core (Address, decodeTextAddress) import Pos.Core.Conc (currentTime) import Pos.Core.Slotting (Timestamp (..)) import Pos.Crypto (RequiresNetworkMagic (..)) +import Pos.Util (postfixLFields) import Pos.Util.AssertMode (inAssertMode) import Pos.Util.Config (parseYamlConfig) import Pos.Util.Wlog (WithLogger, logInfo) @@ -186,6 +204,9 @@ data ConfigurationOptions = ConfigurationOptions , cfoSeed :: !(Maybe Integer) } deriving (Show) +makeLensesWith postfixLFields ''Configuration +makeLensesWith postfixLFields ''ConfigurationOptions + instance FromJSON ConfigurationOptions where parseJSON = withObject "ConfigurationOptions" $ \o -> do cfoFilePath <- o .: "filePath" diff --git a/lib/src/Pos/Launcher/Resource.hs b/lib/src/Pos/Launcher/Resource.hs index 35abee18cd0..be046c65868 100644 --- a/lib/src/Pos/Launcher/Resource.hs +++ b/lib/src/Pos/Launcher/Resource.hs @@ -309,7 +309,7 @@ allocateNodeContext genesisConfig ancd txpSettings ekgStore = do ncBlockRetrievalQueue <- liftIO $ newTBQueueIO blockRetrievalQueueSize ncRecoveryHeader <- liftIO newEmptyTMVarIO logDebug "Created block retrieval queue, recovery and progress headers" - ncShutdownFlag <- newTVarIO False + ncShutdownFlag <- newTVarIO Nothing ncStartTime <- StartTime <$> liftIO Time.getCurrentTime ncLastKnownHeader <- newTVarIO Nothing logDebug "Created last known header and shutdown flag variables" diff --git a/lib/src/Pos/Launcher/Runner.hs b/lib/src/Pos/Launcher/Runner.hs index b47f355c012..e4c8e1493e8 100644 --- a/lib/src/Pos/Launcher/Runner.hs +++ b/lib/src/Pos/Launcher/Runner.hs @@ -40,7 +40,6 @@ import Pos.Diffusion.Full (FullDiffusionConfiguration (..), diffusionLayerFull) import Pos.Infra.Diffusion.Types (Diffusion (..), DiffusionLayer (..), hoistDiffusion) -import Pos.Infra.InjectFail (FInject (..), testLogFInject) import Pos.Infra.Network.Types (NetworkConfig (..), topologyRoute53HealthCheckEnabled) import Pos.Infra.Reporting.Ekg (EkgNodeMetrics (..), @@ -161,7 +160,7 @@ runServer -> (Diffusion IO -> Logic IO) -> (Diffusion IO -> IO t) -> IO t -runServer uc genesisConfig NodeParams {..} ekgNodeMetrics shdnContext mkLogic act = exitOnShutdown npFInjects $ +runServer uc genesisConfig NodeParams {..} ekgNodeMetrics shdnContext mkLogic act = exitOnShutdown $ diffusionLayerFull fdconf npNetworkConfig (Just ekgNodeMetrics) @@ -185,13 +184,13 @@ runServer uc genesisConfig NodeParams {..} ekgNodeMetrics shdnContext mkLogic ac , fdcTrace = wlogTrace "diffusion" , fdcStreamWindow = streamWindow } - exitOnShutdown fInjects action = do - _ <- race (waitForShutdown shdnContext) action - doFail <- testLogFInject fInjects FInjApplyUpdateWrongExitCode - exitWith $ ExitFailure $ - if doFail - then 42 -- inject wrong exit code - else 20 -- special exit code to indicate an update + exitOnShutdown action = do + result <- race (waitForShutdown shdnContext) action + let + code = case result of + Left code' -> code' + Right _ -> ExitSuccess + exitWith code ekgStore = enmStore ekgNodeMetrics (hcHost, hcPort) = case npRoute53Params of Nothing -> ("127.0.0.1", 3030) diff --git a/lib/src/Pos/Util/UserSecret.hs b/lib/src/Pos/Util/UserSecret.hs index a74823e844a..8006cc817a0 100644 --- a/lib/src/Pos/Util/UserSecret.hs +++ b/lib/src/Pos/Util/UserSecret.hs @@ -225,6 +225,7 @@ getAccessMode path = do setMode600 :: (MonadIO m) => FilePath -> m () setMode600 path = liftIO $ PSX.setFileMode path mode600 +{-# INLINE ensureModeIs600 #-} ensureModeIs600 :: MonadMaybeLog m => FilePath -> m () ensureModeIs600 path = do accessMode <- getAccessMode path @@ -253,6 +254,7 @@ initializeUserSecret secretPath = do createEmptyFile :: (MonadIO m) => FilePath -> m () createEmptyFile = liftIO . flip writeFile mempty +{-# INLINE readUserSecret #-} -- | Reads user secret from file, assuming that file exists, -- and has mode 600, throws exception in other case readUserSecret :: MonadMaybeLog m => FilePath -> m UserSecret diff --git a/lib/test/Test/Pos/Launcher/Configuration.hs b/lib/test/Test/Pos/Launcher/Configuration.hs index 380764a1643..144ead6d8d6 100644 --- a/lib/test/Test/Pos/Launcher/Configuration.hs +++ b/lib/test/Test/Pos/Launcher/Configuration.hs @@ -1,4 +1,4 @@ -module Test.Pos.Launcher.Configuration (tests, roundTripConfiguration) where +module Test.Pos.Launcher.Configuration (tests) where import Hedgehog (Property) import qualified Hedgehog as H diff --git a/nix/.stack-pkgs.nix b/nix/.stack-pkgs.nix index e52e559f326..25e20a33d3b 100644 --- a/nix/.stack-pkgs.nix +++ b/nix/.stack-pkgs.nix @@ -46,6 +46,7 @@ cardano-sl-generator = ./.stack.nix/cardano-sl-generator.nix; cardano-sl-client = ./.stack.nix/cardano-sl-client.nix; cardano-sl-auxx = ./.stack.nix/cardano-sl-auxx.nix; + cardano-sl-script-runner = ./.stack.nix/cardano-sl-script-runner.nix; cardano-sl-explorer = ./.stack.nix/cardano-sl-explorer.nix; cardano-sl-node = ./.stack.nix/cardano-sl-node.nix; cardano-sl-tools = ./.stack.nix/cardano-sl-tools.nix; diff --git a/nix/.stack.nix/cardano-sl-script-runner.nix b/nix/.stack.nix/cardano-sl-script-runner.nix new file mode 100644 index 00000000000..89c91e3ae46 --- /dev/null +++ b/nix/.stack.nix/cardano-sl-script-runner.nix @@ -0,0 +1,96 @@ +{ system +, compiler +, flags +, pkgs +, hsPkgs +, pkgconfPkgs +, ... }: + { + flags = {}; + package = { + specVersion = "1.10"; + identifier = { + name = "cardano-sl-script-runner"; + version = "2.0.0"; + }; + license = "MIT"; + copyright = "2018 IOHK"; + maintainer = "operations@iohk.io"; + author = "IOHK"; + homepage = ""; + url = ""; + synopsis = "Cardano SL - Script Runner"; + description = "Cardano SL - ScriptRunner"; + buildType = "Simple"; + }; + components = { + "library" = { + depends = [ + (hsPkgs.base) + (hsPkgs.aeson) + (hsPkgs.brick) + (hsPkgs.bytestring) + (hsPkgs.cardano-sl) + (hsPkgs.cardano-sl-chain) + (hsPkgs.cardano-sl-client) + (hsPkgs.cardano-sl-core) + (hsPkgs.cardano-sl-crypto) + (hsPkgs.cardano-sl-db) + (hsPkgs.cardano-sl-infra) + (hsPkgs.cardano-sl-networking) + (hsPkgs.cardano-sl-util) + (hsPkgs.conduit) + (hsPkgs.constraints) + (hsPkgs.containers) + (hsPkgs.data-default) + (hsPkgs.dns) + (hsPkgs.formatting) + (hsPkgs.lens) + (hsPkgs.lifted-async) + (hsPkgs.mtl) + (hsPkgs.optparse-applicative) + (hsPkgs.process) + (hsPkgs.resourcet) + (hsPkgs.serokell-util) + (hsPkgs.stm) + (hsPkgs.text) + (hsPkgs.time) + (hsPkgs.time-units) + (hsPkgs.turtle) + (hsPkgs.universum) + (hsPkgs.unix) + (hsPkgs.unordered-containers) + (hsPkgs.vector) + (hsPkgs.vty) + (hsPkgs.yaml) + ]; + }; + exes = { + "testcases" = { + depends = [ + (hsPkgs.base) + (hsPkgs.bytestring) + (hsPkgs.cardano-sl) + (hsPkgs.cardano-sl-binary) + (hsPkgs.cardano-sl-chain) + (hsPkgs.cardano-sl-core) + (hsPkgs.cardano-sl-db) + (hsPkgs.cardano-sl-infra) + (hsPkgs.cardano-sl-script-runner) + (hsPkgs.cardano-sl-util) + (hsPkgs.cborg) + (hsPkgs.constraints) + (hsPkgs.data-default) + (hsPkgs.formatting) + (hsPkgs.serokell-util) + (hsPkgs.text) + (hsPkgs.time-units) + (hsPkgs.turtle) + (hsPkgs.universum) + ]; + }; + }; + }; + } // rec { + src = .././../script-runner; + } \ No newline at end of file diff --git a/nix/overlays/required.nix b/nix/overlays/required.nix index 43ee4edb9dc..a3bbc302a87 100644 --- a/nix/overlays/required.nix +++ b/nix/overlays/required.nix @@ -32,6 +32,11 @@ self: super: { cardano-sl-client = addRealTimeTestLogs super.cardano-sl-client; cardano-sl-generator = addRealTimeTestLogs super.cardano-sl-generator; cardano-sl-networking = addRealTimeTestLogs super.cardano-sl-networking; + data-clist = doJailbreak super.data-clist; + mtl = null; + stm = null; + text = null; + parsec = null; ######################################################################## # The base Haskell package builder diff --git a/pkgs/default.nix b/pkgs/default.nix index b745eb9e6e0..54843806a29 100644 --- a/pkgs/default.nix +++ b/pkgs/default.nix @@ -16292,6 +16292,121 @@ universum doHaddock = false; license = stdenv.lib.licenses.mit; +}) {}; +"cardano-sl-script-runner" = callPackage +({ + mkDerivation +, aeson +, base +, brick +, bytestring +, cardano-sl +, cardano-sl-binary +, cardano-sl-chain +, cardano-sl-client +, cardano-sl-core +, cardano-sl-crypto +, cardano-sl-db +, cardano-sl-infra +, cardano-sl-networking +, cardano-sl-util +, cborg +, conduit +, constraints +, containers +, data-default +, dns +, formatting +, lens +, lifted-async +, mtl +, optparse-applicative +, process +, resourcet +, serokell-util +, stdenv +, stm +, text +, time +, time-units +, turtle +, universum +, unix +, unordered-containers +, vector +, vty +, yaml +}: +mkDerivation { + +pname = "cardano-sl-script-runner"; +version = "2.0.0"; +src = ./../script-runner; +isLibrary = true; +isExecutable = true; +libraryHaskellDepends = [ +aeson +base +brick +bytestring +cardano-sl +cardano-sl-chain +cardano-sl-client +cardano-sl-core +cardano-sl-crypto +cardano-sl-db +cardano-sl-infra +cardano-sl-networking +cardano-sl-util +conduit +constraints +containers +data-default +dns +formatting +lens +lifted-async +mtl +optparse-applicative +process +resourcet +serokell-util +stm +text +time +time-units +turtle +universum +unix +unordered-containers +vector +vty +yaml +]; +executableHaskellDepends = [ +base +bytestring +cardano-sl +cardano-sl-binary +cardano-sl-chain +cardano-sl-core +cardano-sl-db +cardano-sl-infra +cardano-sl-util +cborg +constraints +data-default +formatting +serokell-util +text +time-units +turtle +universum +]; +doHaddock = false; +description = "Cardano SL - Script Runner"; +license = stdenv.lib.licenses.mit; + }) {}; "cardano-sl-tools" = callPackage ({ diff --git a/script-runner/BlockParser.hs b/script-runner/BlockParser.hs new file mode 100644 index 00000000000..c85390de3cb --- /dev/null +++ b/script-runner/BlockParser.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module BlockParser (file1, file2, printBlock) where + +import Codec.CBOR.Read (deserialiseFromBytes) +import Pos.Binary.Class (decode) +import Pos.Chain.Block (Block) +import System.IO hiding (print) +import Universum hiding (openFile, when) + +import qualified Data.ByteString.Lazy as LBS + +file1 :: FilePath +file1 = "/home/clever/dedup/staging-poc/blocks/data/68/c85b75adcc99048e633e4b84337b36542e020337c618742d7716e6acc22b39.blund" +file2 :: FilePath +file2 = "9f5124c1f20924f809e741dc9ceda2d2c5422ce8f7024f800060df4e787bc9d3.blund" + +printBlock :: FilePath -> IO () +printBlock filename = do + raw <- LBS.readFile filename + let + blockraw :: LBS.ByteString + _undoraw :: LBS.ByteString + Right ("", (blockraw, _undoraw)) = deserialiseFromBytes decode raw + block :: Block + Right ("", block) = deserialiseFromBytes decode blockraw + case block of + Left gb -> do + hnd <- openFile "show.txt" WriteMode + print ("genesis block" :: String) + hPutStrLn hnd $ show gb + hClose hnd + Right mb -> do + print ("main block" :: String) + print mb diff --git a/script-runner/LICENSE b/script-runner/LICENSE new file mode 100644 index 00000000000..367a48d9eac --- /dev/null +++ b/script-runner/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 IOHK + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to +do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. + diff --git a/script-runner/Makefile b/script-runner/Makefile new file mode 100644 index 00000000000..4fee3f7beb3 --- /dev/null +++ b/script-runner/Makefile @@ -0,0 +1,8 @@ +dist/build/poc/poc: AutomatedTestRunner.hs BlockParser.hs Poc.hs BrickUI.hs NodeControl.hs + runhaskell Setup.hs build -j10 poc + +poc-test: dist/build/poc/poc + mkdir -p poc-state + ./dist/build/poc/poc --configuration-file ../lib/configuration.yaml --log-console-off --db-path poc-state/db --keyfile poc-state/secret.key --log-config log-config.yaml --logs-prefix poc-state/logs/ --topology topology-local.yaml + +.PHONY: poc-test diff --git a/script-runner/Setup.hs b/script-runner/Setup.hs new file mode 100644 index 00000000000..44671092b28 --- /dev/null +++ b/script-runner/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/script-runner/TestCases.hs b/script-runner/TestCases.hs new file mode 100644 index 00000000000..14b66d27e20 --- /dev/null +++ b/script-runner/TestCases.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Main (main) where + +import qualified Data.ByteString as BS +import Data.Constraint (Dict (Dict)) +import Data.Default (def) +import Data.Ix (range) +import qualified Data.Text as T +import System.Environment (getEnv) +import System.Exit (ExitCode (..)) +import System.IO (hPutStrLn) +import Universum hiding (on) + +import Pos.Chain.Update (ApplicationName (ApplicationName), + BlockVersion (BlockVersion), + BlockVersionData (bvdMaxBlockSize), + BlockVersionModifier (bvmMaxBlockSize), + SoftwareVersion (SoftwareVersion), UpdateConfiguration, + ccApplicationVersion_L, ccLastKnownBlockVersion_L) +import qualified Pos.Client.CLI as CLI +import Pos.DB.Class (gsAdoptedBVData) +import qualified Pos.GState as GS +import Pos.Infra.Diffusion.Types (Diffusion) +import Pos.Launcher (Configuration, HasConfigurations, ccUpdate_L, + cfoFilePath_L, cfoKey_L) +import Pos.Util.Util (lensOf) + +import AutomatedTestRunner +import BlockParser () +import NodeControl (NodeInfo (..), mutateConfigurationYaml, startNode, + stopNodeByName) +import OrphanedLenses () +import PocMode +import Types (NodeType (..), Todo (Todo)) + +import Serokell.Data.Memory.Units (Byte) + +mutateConfiguration :: Configuration -> Configuration +mutateConfiguration cfg = (cfg & ccUpdate_L . ccLastKnownBlockVersion_L .~ BlockVersion 0 1 0) & ccUpdate_L . ccApplicationVersion_L .~ 1 + +data ExpectedResult = SuccessFullUpdate | FailedProposalUpdate deriving (Show, Eq) + +-- most logging to console is disabled to reduce signal to noise ratio +-- but the messages from this script should always go to the console +-- maybe use a different log priority config to handle things better? +logMsg :: String -> PocMode () +logMsg = liftIO . hPutStrLn stderr + +test4 :: Byte -> ExpectedResult -> Script () +test4 targetblocksize expectedResult = do + genesisConfig <- getGenesisConfig + let + proposal :: Dict HasConfigurations -> Diffusion PocMode -> PocMode () + proposal Dict diffusion = do + let + keyIndex :: Int + keyIndex = 0 + blockVersion = BlockVersion 0 1 0 + softwareVersion = SoftwareVersion (ApplicationName "cardano-sl") 1 + blockVersionModifier :: BlockVersionModifier + blockVersionModifier = def { bvmMaxBlockSize = Just targetblocksize } + doUpdate diffusion genesisConfig keyIndex blockVersion softwareVersion blockVersionModifier + onStartup $ \Dict _diffusion -> do + stateDir <- view acStatePath + loadNKeys stateDir 4 + on (1,2) proposal + on (1,6) $ \Dict _diffusion -> do + uc <- view (lensOf @UpdateConfiguration) + proposals <- GS.getConfirmedProposals uc Nothing + case (proposals, expectedResult) of + ([], FailedProposalUpdate) -> do + logMsg "expected failed proposal, passing test" + endScript ExitSuccess + (_, FailedProposalUpdate) -> do + logMsg "expected failure, but proposal was accepted!" + endScript $ ExitFailure 1 + ([], _) -> do + logMsg "expected proposal to pass, but it didnt" + endScript $ ExitFailure 2 + ([_one], SuccessFullUpdate) -> do + stateDir <- view acStatePath + opts <- view acScriptOptions + let + -- the config for the script-runner is mirrored to the nodes it starts + cfg = opts ^. srCommonNodeArgs . CLI.commonArgs_L + newConfiguration <- liftIO $ mutateConfigurationYaml (cfg ^. CLI.configurationOptions_L . cfoFilePath_L) (cfg ^. CLI.configurationOptions_L . cfoKey_L) mutateConfiguration + liftIO $ BS.writeFile (T.unpack $ stateDir <> "/configuration2.yaml") newConfiguration + let + cfg2 = cfg & CLI.configurationOptions_L . cfoFilePath_L .~ (T.unpack $ stateDir <> "/configuration2.yaml") + forM_ (range (0,3)) $ \node -> do + stopNodeByName (Core, node) + startNode $ NodeInfo node Core stateDir (stateDir <> "/topology.yaml") cfg2 + (_toomany, SuccessFullUpdate) -> do + logMsg "expected 1 proposal to pass, but >1 have passed" + endScript $ ExitFailure 3 + on (3,10) $ \Dict _diffusion -> do + bvd <- gsAdoptedBVData + case (bvdMaxBlockSize bvd == targetblocksize) of + True -> endScript ExitSuccess + _ -> do + liftIO $ hPutStrLn stderr "max block size not what was expected" + endScript $ ExitFailure 4 + forM_ (range (0,20)) $ \epoch -> do + on(epoch, 0) $ printbvd epoch 0 + on(epoch, 1) $ printbvd epoch 1 + +emptyScript :: Script () +emptyScript = do + pure () + +main :: IO () +main = do + script <- getEnv "SCRIPT" + let + getScript :: String -> Script () + getScript "test4.1" = test4 1000000 SuccessFullUpdate + getScript "test4.2" = test4 10000000 FailedProposalUpdate + getScript "none" = emptyScript + getAutoMode :: String -> Bool + getAutoMode "none" = False + getAutoMode _ = True + runScript $ ScriptParams + { spTodo = (Todo 4) + , spScript = getScript script + , spRecentSystemStart = getAutoMode script + , spStartCoreAndRelay = getAutoMode script + } diff --git a/script-runner/cardano-sl-script-runner.cabal b/script-runner/cardano-sl-script-runner.cabal new file mode 100644 index 00000000000..901ddf3ffc0 --- /dev/null +++ b/script-runner/cardano-sl-script-runner.cabal @@ -0,0 +1,91 @@ +name: cardano-sl-script-runner +version: 2.0.0 +synopsis: Cardano SL - Script Runner +description: Cardano SL - ScriptRunner +license: MIT +license-file: LICENSE +author: IOHK +maintainer: operations@iohk.io +copyright: 2018 IOHK +category: Currency +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: common + exposed-modules: AutomatedTestRunner + BrickUI + BrickUITypes + NodeControl + OrphanedLenses + PocMode + Types + default-language: Haskell2010 + build-depends: base + , aeson + , brick + , bytestring + , cardano-sl + , cardano-sl-chain + , cardano-sl-client + , cardano-sl-core + , cardano-sl-crypto + , cardano-sl-db + , cardano-sl-infra + , cardano-sl-networking + , cardano-sl-util + , conduit + , constraints + , containers + , data-default + , dns + , formatting + , lens + , lifted-async + , mtl + , optparse-applicative + , process + , resourcet + , serokell-util + , stm + , text + , time + , time-units + , turtle + , universum + , unix + , unordered-containers + , vector + , vty + , yaml + ghc-options: -Wall -Weverything + -Wno-unsafe -Wno-missing-import-lists + -O2 + +executable testcases + main-is: TestCases.hs + other-modules: BlockParser + default-language: Haskell2010 + build-depends: base + , bytestring + , cardano-sl + , cardano-sl-binary + , cardano-sl-chain + , cardano-sl-core + , cardano-sl-db + , cardano-sl-infra + , cardano-sl-script-runner + , cardano-sl-util + , cborg + , constraints + , data-default + , formatting + , serokell-util + , text + , time-units + , turtle + , universum + ghc-options: -threaded -rtsopts + -Wall -Weverything + -Wno-unsafe -Wno-missing-import-lists + -O2 diff --git a/script-runner/common/AutomatedTestRunner.hs b/script-runner/common/AutomatedTestRunner.hs new file mode 100644 index 00000000000..d63488fe303 --- /dev/null +++ b/script-runner/common/AutomatedTestRunner.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module AutomatedTestRunner (Script, getGenesisConfig, loadNKeys, doUpdate, onStartup, on, runScript, ScriptRunnerOptions(..), endScript, srCommonNodeArgs, printbvd, ScriptParams(..)) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async.Lifted.Safe (Async, async, wait) +import Control.Exception (throw) +import Control.Lens (to) +import Control.Monad.STM (orElse) +import Data.Constraint (Dict (Dict)) +import Data.Default (Default (def)) +import qualified Data.HashMap.Strict as HM +import Data.Ix (range) +import Data.List ((!!)) +import qualified Data.Map as Map +import qualified Data.Text as T +import Data.Time.Units (fromMicroseconds) +import Data.Version (showVersion) +import Formatting (Format, int, sformat, stext, (%)) +import Options.Applicative (Parser, execParser, footerDoc, fullDesc, + header, help, helper, info, infoOption, long, progDesc, + switch) +import Prelude (read) +import System.Exit (ExitCode) +import System.IO (BufferMode (LineBuffering), hPrint, hSetBuffering) +import qualified Turtle as T +import Universum hiding (on, state, when) + +import Ntp.Client (NtpConfiguration) +import Paths_cardano_sl (version) +import Pos.Chain.Block (LastKnownHeaderTag) +import Pos.Chain.Genesis as Genesis + (Config (configGeneratedSecrets, configProtocolMagic), + configEpochSlots) +import Pos.Chain.Txp (TxpConfiguration) +import Pos.Chain.Update (BlockVersion, + BlockVersionData (bvdMaxBlockSize, bvdMaxTxSize), + BlockVersionModifier, SoftwareVersion, SystemTag, + UpdateConfiguration, UpdateData, mkUpdateProposalWSign, + updateConfiguration) +import qualified Pos.Client.CLI as CLI +import Pos.Client.KeyStorage (addSecretKey, getSecretKeysPlain) +import Pos.Client.Update.Network (submitUpdateProposal) +import Pos.Core (EpochIndex (EpochIndex), LocalSlotIndex, SlotCount, + SlotId (SlotId, siEpoch, siSlot), Timestamp (Timestamp), + difficultyL, getBlockCount, getChainDifficulty, + getEpochIndex, getEpochOrSlot, getSlotIndex, + mkLocalSlotIndex) +import Pos.Crypto (emptyPassphrase, hash, hashHexF, noPassEncrypt, + withSafeSigners) +import Pos.DB.BlockIndex (getTipHeader) +import Pos.DB.Class (gsAdoptedBVData) +import Pos.DB.DB (initNodeDBs) +import Pos.DB.Txp (txpGlobalSettings) +import qualified Pos.GState as GS +import Pos.Infra.Diffusion.Types (Diffusion, hoistDiffusion) +import Pos.Infra.Network.Types (NetworkConfig (ncDequeuePolicy, ncEnqueuePolicy, ncFailurePolicy, ncTopology), + NodeId, Topology (TopologyAuxx), topologyDequeuePolicy, + topologyEnqueuePolicy, topologyFailurePolicy) +import Pos.Infra.Shutdown (triggerShutdown, triggerShutdown') +import Pos.Infra.Slotting.Util (defaultOnNewSlotParams, onNewSlot) +import Pos.Launcher (HasConfigurations, InitModeContext, NodeParams (npBehaviorConfig, npNetworkConfig, npUserSecret), + NodeResources, WalletConfiguration, bracketNodeResources, + cfoSystemStart_L, loggerBracket, runNode, runRealMode, + withConfigurations) +import Pos.Util (lensOf, logException) +import Pos.Util.CompileInfo (CompileTimeInfo (ctiGitRevision), + HasCompileInfo, compileInfo, withCompileInfo) +import Pos.Util.UserSecret (readUserSecret, usKeys, usPrimKey, usVss) +import Pos.Util.Wlog (LoggerName) +import Pos.WorkMode (EmptyMempoolExt, RealMode) +import Serokell.Data.Memory.Units (Byte) + +import Brick.BChan (BChan, newBChan, readBChan, writeBChan) + +import BrickUI (runUI) +import BrickUITypes (CustomEvent (CENodeInfo, CESlotStart, ProposalReply, QuitEvent), + NodeInfo (NodeInfo), + Reply (QueryProposals, TriggerShutdown), + SlotStart (SlotStart)) +import NodeControl (cleanupNodes, createNodes, genSystemStart, mkTopo) +import PocMode (AuxxContext (AuxxContext, _acEventChan, _acNodeHandles, _acRealModeContext, _acScriptOptions, _acStatePath, _acTopology), + CompiledScript (slotTriggers, startupActions), + InputParams (InputParams, ipEventChan, ipReplyChan, ipScriptParams, ipStatePath), + InputParams2 (InputParams2, ip2EventChan, ip2ReplyChan, ip2ScriptParams, ip2StatePath), + PocMode, Script (runScriptMonad), + ScriptBuilder (ScriptBuilder, sbEpochSlots, sbGenesisConfig, sbScript), + ScriptParams (spRecentSystemStart, spScript, spStartCoreAndRelay, spTodo), + ScriptT (runScriptT), SlotTrigger (SlotTrigger), + realModeToAuxx, writeBrickChan) +import Types (ScriptRunnerOptions (ScriptRunnerOptions), + ScriptRunnerUIMode (BrickUI, PrintUI), srCommonNodeArgs, + srPeers, srUiMode) + +exampleToScript :: SlotCount -> Config -> Script () -> CompiledScript +exampleToScript epochSlots config example = sbScript $ snd $ runIdentity $ runStateT (runScriptT $ runScriptMonad example) (ScriptBuilder def epochSlots config) + +scriptRunnerOptionsParser :: Parser ScriptRunnerOptions +scriptRunnerOptionsParser = do + let + disabledParser :: Parser Bool + disabledParser = switch $ long "no-brickui" <> help "Disable brick based ui" + disableBrick <- disabledParser + commonNodeArgs <- CLI.commonNodeArgsParser + peers <- many $ CLI.nodeIdOption "peer" "Address of a peer." + pure $ ScriptRunnerOptions commonNodeArgs peers (if disableBrick then PrintUI else BrickUI) + +getScriptRunnerOptions :: HasCompileInfo => IO ScriptRunnerOptions +getScriptRunnerOptions = execParser programInfo + where + programInfo = info (helper <*> versionOption <*> scriptRunnerOptionsParser) $ + fullDesc <> progDesc "Cardano SL CLI utilities." + <> header "CLI-based utilities (auxx)." + <> footerDoc (Just "todo") + versionOption :: Parser (a -> a) + versionOption = infoOption + ("cardano-script-runner" <> showVersion version <> ", git revision " <> toString (ctiGitRevision compileInfo)) + (long "version" <> help "Show version.") + +loggerName :: LoggerName +loggerName = "script-runner" + +thing :: HasCompileInfo => ScriptRunnerOptions -> InputParams -> IO () +thing opts inputParams = do + let + conf = CLI.configurationOptions (CLI.commonArgs cArgs) + cArgs@CLI.CommonNodeArgs{CLI.cnaDumpGenesisDataPath,CLI.cnaDumpConfiguration} = opts ^. srCommonNodeArgs + withConfigurations Nothing cnaDumpGenesisDataPath cnaDumpConfiguration conf (runWithConfig opts inputParams) + +maybeAddPeers :: [NodeId] -> NodeParams -> NodeParams +maybeAddPeers [] params = params +maybeAddPeers peers nodeParams = addQueuePolicies $ nodeParams { npNetworkConfig = (npNetworkConfig nodeParams) { ncTopology = TopologyAuxx peers } } + +-- used with maybeAddPeers to fix default policies after changing topology type +addQueuePolicies :: NodeParams -> NodeParams +addQueuePolicies nodeParams = do + let + topology = ncTopology $ npNetworkConfig nodeParams + nodeParams { npNetworkConfig = (npNetworkConfig nodeParams) + { ncEnqueuePolicy = topologyEnqueuePolicy topology + , ncDequeuePolicy = topologyDequeuePolicy topology + , ncFailurePolicy = topologyFailurePolicy topology + } + } + +runWithConfig :: (HasCompileInfo, HasConfigurations) => ScriptRunnerOptions -> InputParams -> Genesis.Config -> WalletConfiguration -> TxpConfiguration -> NtpConfiguration -> IO () +runWithConfig opts inputParams genesisConfig _walletConfig txpConfig _ntpConfig = do + let + nArgs = CLI.NodeArgs { CLI.behaviorConfigPath = Nothing} + (nodeParams', _mSscParams) <- CLI.getNodeParams loggerName (opts ^. srCommonNodeArgs) nArgs (configGeneratedSecrets genesisConfig) + let + nodeParams = maybeAddPeers (opts ^. srPeers) $ nodeParams' + vssSK = fromMaybe (error "no user secret given") (npUserSecret nodeParams ^. usVss) + sscParams = CLI.gtSscParams (opts ^. srCommonNodeArgs) vssSK (npBehaviorConfig nodeParams) + thing1 = txpGlobalSettings genesisConfig txpConfig + thing2 :: ReaderT InitModeContext IO () + thing2 = initNodeDBs genesisConfig + let + inputParams' = InputParams2 (ipEventChan inputParams) (ipReplyChan inputParams) (ipScriptParams inputParams) (ipStatePath inputParams) + bracketNodeResources genesisConfig nodeParams sscParams thing1 thing2 (thing3 opts genesisConfig txpConfig inputParams') + +thing3 :: (HasCompileInfo, HasConfigurations) => ScriptRunnerOptions -> Config -> TxpConfiguration -> InputParams2 -> NodeResources () -> IO () +thing3 opts genesisConfig txpConfig inputParams nr = do + handles <- newTVarIO mempty + let + -- cores run from 0-3, relays run from 0-0 + topo = mkTopo 3 0 + let + toRealMode :: PocMode a -> RealMode EmptyMempoolExt a + toRealMode auxxAction = do + realModeContext <- ask + lift $ runReaderT auxxAction $ AuxxContext + { _acRealModeContext = realModeContext + , _acEventChan = ip2EventChan inputParams + , _acNodeHandles = handles + , _acScriptOptions = opts + , _acTopology = topo + , _acStatePath = ip2StatePath inputParams + } + thing2 :: Diffusion (RealMode ()) -> RealMode EmptyMempoolExt () + thing2 diffusion = toRealMode (thing5 (hoistDiffusion realModeToAuxx toRealMode diffusion)) + thing5 :: Diffusion PocMode -> PocMode () + thing5 diffusion = do + if spStartCoreAndRelay $ ip2ScriptParams inputParams + then createNodes (spTodo $ ip2ScriptParams inputParams) opts + else pure () + let epochSlots = configEpochSlots genesisConfig + let finalscript = (exampleToScript epochSlots genesisConfig . spScript . ip2ScriptParams) inputParams + runNode genesisConfig txpConfig nr (thing4 finalscript) diffusion + cleanupNodes + thing4 :: CompiledScript -> [ (Text, Diffusion PocMode -> PocMode ()) ] + thing4 script = workers script genesisConfig inputParams + runRealMode updateConfiguration genesisConfig txpConfig nr thing2 + +workers :: HasConfigurations => CompiledScript -> Genesis.Config -> InputParams2 -> [ (Text, Diffusion PocMode -> PocMode ()) ] +workers script genesisConfig InputParams2{ip2EventChan,ip2ReplyChan} = + [ ( "worker1", worker1 genesisConfig script ip2EventChan) + , ( "worker2", worker2 ip2EventChan) + , ( "brick reply worker", brickReplyWorker ip2ReplyChan) + ] + +brickReplyWorker :: HasConfigurations => BChan Reply -> Diffusion PocMode -> PocMode () +brickReplyWorker replyChan diffusion = do + reply <- liftIO $ readBChan replyChan + case reply of + TriggerShutdown -> do + triggerShutdown + QueryProposals -> do + uc <- view (lensOf @UpdateConfiguration) + proposals <- GS.getConfirmedProposals uc Nothing + allProp <- GS.getAllProposals + writeBrickChan $ ProposalReply proposals allProp + + brickReplyWorker replyChan diffusion + +worker2 :: HasConfigurations => BChan CustomEvent -> Diffusion PocMode -> PocMode () +worker2 eventChan diffusion = do + localTip <- getTipHeader + headerRef <- view (lensOf @LastKnownHeaderTag) + mbHeader <- atomically $ readTVar headerRef `orElse` pure Nothing + let + globalHeight = view (difficultyL . to getChainDifficulty) <$> mbHeader + localHeight = view (difficultyL . to getChainDifficulty) localTip + f (Just v) = Just $ getBlockCount v + f Nothing = Nothing + liftIO $ do + writeBChan eventChan $ CENodeInfo $ NodeInfo (getBlockCount localHeight) (getEpochOrSlot localTip) (f globalHeight) + threadDelay 10000 + worker2 eventChan diffusion + +worker1 :: HasConfigurations => Genesis.Config -> CompiledScript -> BChan CustomEvent -> Diffusion (PocMode) -> PocMode () +worker1 genesisConfig script eventChan diffusion = do + let + handler :: SlotId -> PocMode () + handler slotid = do + liftIO $ writeBChan eventChan $ CESlotStart $ SlotStart (getEpochIndex $ siEpoch slotid) (getSlotIndex $ siSlot slotid) + case Map.lookup slotid (slotTriggers script) of + Just (SlotTrigger act) -> runAction act + Nothing -> pure () + pure () + errhandler :: Show e => e -> PocMode () + errhandler e = print e + runAction :: (Dict HasConfigurations -> Diffusion PocMode -> PocMode ()) -> PocMode () + runAction act = do + act Dict diffusion `catch` errhandler @SomeException + realWorker = do + mapM_ (\(SlotTrigger act) -> runAction act) (startupActions script) + onNewSlot (configEpochSlots genesisConfig) defaultOnNewSlotParams handler + pure () + realWorker `catch` errhandler @SomeException + +runScript :: ScriptParams -> IO () +runScript sp = T.with (T.mktempdir "/tmp" "script-runner") $ \stateDir -> withCompileInfo $ do + systemStart <- genSystemStart 10 + let + systemStartTs :: Timestamp + systemStartTs = Timestamp $ fromMicroseconds $ (read systemStart) * 1000000 + opts' <- getScriptRunnerOptions + let + opts = if (spRecentSystemStart sp) + then setSystemStartMutator systemStartTs opts' + else opts' + (eventChan, replyChan, asyncUi) <- runUI' opts + let + loggingParams = CLI.loggingParams loggerName (opts ^. srCommonNodeArgs) + loggerBracket "script-runner" loggingParams . logException "script-runner" $ do + let + inputParams = InputParams eventChan replyChan sp (T.pack $ T.encodeString stateDir) + thing opts inputParams + pure () + liftIO $ writeBChan eventChan QuitEvent + _finalState <- wait asyncUi + --print finalState + pure () + +runUI' :: ScriptRunnerOptions -> IO (BChan CustomEvent, BChan Reply, Async ()) +runUI' opts = do + case opts ^. srUiMode of + BrickUI -> runUI + PrintUI -> runDummyUI + +runDummyUI :: IO (BChan CustomEvent, BChan Reply, Async ()) +runDummyUI = do + hSetBuffering stdout LineBuffering + eventChan <- newBChan 10 + replyChan <- newBChan 10 + let + go :: IO () + go = do + reply <- liftIO $ readBChan eventChan + case reply of + QuitEvent -> pure () + _ -> go + fakesync <- async go + pure (eventChan, replyChan, fakesync) + +getGenesisConfig :: Script Config +getGenesisConfig = sbGenesisConfig <$> get + +data SlotCreationFailure = SlotCreationFailure { msg :: Text, slotsInEpoch :: SlotCount } deriving Show +instance Exception SlotCreationFailure where + +onStartup :: (Dict HasConfigurations -> Diffusion PocMode -> PocMode ()) -> Script () +onStartup action = do + oldsb <- get + let + oldscript = sbScript oldsb + script = oldscript { + startupActions = [ SlotTrigger action ] <> (startupActions oldscript) + } + newsb = oldsb { + sbScript = script + } + put newsb + pure () + +endScript :: ExitCode -> PocMode () +endScript code = do + writeBrickChan QuitEvent + triggerShutdown' code + +on :: (Word64, Word16) -> (Dict HasConfigurations -> Diffusion PocMode -> PocMode ()) -> Script () +on (epoch, slot) action = do + oldsb <- get + let + todo = sbEpochSlots oldsb + go :: Either Text LocalSlotIndex -> Script LocalSlotIndex + go (Right localSlot) = pure localSlot + go (Left err) = do + throw $ SlotCreationFailure err todo + localSlot <- go $ mkLocalSlotIndex todo slot + let + slot' = SlotId (EpochIndex epoch) localSlot + oldscript = sbScript oldsb + script = oldscript { + slotTriggers = Map.insert slot' (SlotTrigger action) (slotTriggers oldscript) + } + newsb = oldsb { + sbScript = script + } + put newsb + +doUpdate :: HasConfigurations => Diffusion PocMode -> Config -> Int -> BlockVersion -> SoftwareVersion -> BlockVersionModifier -> PocMode () +doUpdate diffusion genesisConfig keyIndex blockVersion softwareVersion blockVersionModifier = do + let + --tag = SystemTag "win64" + updateData :: HM.HashMap SystemTag UpdateData + updateData = HM.fromList [ + --(tag, UpdateData dummyHash dummyHash dummyHash dummyHash) + ] + voteAll = True + errmsg :: Format r (Int -> Int -> r) + errmsg = "Number of safe signers: " % int % ", expected " % int + pm = configProtocolMagic genesisConfig + skeys <- if voteAll then + getSecretKeysPlain + else do + skey <- (!! keyIndex) <$> getSecretKeysPlain + pure [ skey ] + withSafeSigners skeys (pure emptyPassphrase) $ \ss -> do + unless (length skeys == length ss) $ error $ sformat errmsg (length ss) (length skeys) + let + publisherSS = ss !! if not voteAll then 0 else keyIndex + updateProposal = mkUpdateProposalWSign pm blockVersion blockVersionModifier softwareVersion updateData def publisherSS + upid = hash updateProposal + submitUpdateProposal pm diffusion ss updateProposal + if not voteAll then + putText (sformat ("Update proposal submitted, upId: "%hashHexF%"\n") upid) + else + putText (sformat ("Update proposal submitted along with votes, upId: "%hashHexF%"\n") upid) + print updateProposal + +loadNKeys :: Text -> Integer -> PocMode () +loadNKeys stateDir n = do + let + fmt :: Format r (Text -> Integer -> r) + fmt = stext % "/genesis-keys/generated-keys/rich/key" % int % ".sk" + loadKey :: Integer -> PocMode () + loadKey x = do + let + keypath = sformat fmt stateDir x + secret <- readUserSecret (T.unpack keypath) + let + sk = maybeToList $ secret ^. usPrimKey + secret' = secret & usKeys %~ (++ map noPassEncrypt sk) + let primSk = fromMaybe (error "Primary key not found") (secret' ^. usPrimKey) + addSecretKey $ noPassEncrypt primSk + mapM_ loadKey (range (0,n - 1)) + +printbvd :: Word64 -> Word16 -> Dict HasConfigurations -> Diffusion PocMode -> PocMode () +printbvd epoch slot Dict _diffusion = do + let + bvdfmt :: Format r (Word64 -> Word16 -> Byte -> Byte -> r) + bvdfmt = "epoch: "%int%" slot: "%int%" BVD: max-tx: " %int% ", max-block: " %int + bar <- gsAdoptedBVData + liftIO $ hPrint stderr $ sformat bvdfmt epoch slot (bvdMaxTxSize bar) (bvdMaxBlockSize bar) + +setSystemStartMutator :: Timestamp -> ScriptRunnerOptions -> ScriptRunnerOptions +setSystemStartMutator systemStartTs optsin = + -- sets the systemStart inside the ScriptRunnerOptions to the systemStart passed in + optsin & srCommonNodeArgs . CLI.commonArgs_L . CLI.configurationOptions_L . cfoSystemStart_L .~ Just systemStartTs diff --git a/script-runner/common/BrickUI.hs b/script-runner/common/BrickUI.hs new file mode 100644 index 00000000000..95b2274a45e --- /dev/null +++ b/script-runner/common/BrickUI.hs @@ -0,0 +1,272 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module BrickUI (runUI) where + +import BrickUITypes (AppState (AppState, asChoiceList, asCurrentScreen, asGlobalHeight, asLastMsg, asLocalEpochOrSlot, asLocalHeight, asProposalList, asReplyChan), + CurrentScreen (MainScreen, ProposalListing), + CustomEvent (CENodeInfo, CESlotStart, ProposalReply, QuitEvent), + MenuChoice (Dummy1, Dummy2, ListProposals), + Name (MainMenu, None, ProposalName), + NodeInfo (NodeInfo, niGlobalHeight, niLocalEpochOrSlot, niLocalHeight), + Reply (QueryProposals, TriggerShutdown), + SlotStart (SlotStart)) + +import Control.Concurrent.Async.Lifted.Safe (Async, async) +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import qualified Data.Text.Lazy.Builder as T +import qualified Data.Vector as V +import Formatting +import Universum hiding (HashMap, list, on, state, when) + +import Brick (App (App, appAttrMap, appChooseCursor, appDraw, appHandleEvent, appStartEvent), + BrickEvent (AppEvent, VtyEvent), EventM, Next, Widget, + continue, customMain, emptyWidget, hBox, halt, on, padAll, + padLeftRight, showFirstCursor, str, strWrap, txt, vBox, + withBorderStyle) +import qualified Brick.AttrMap as A +import Brick.BChan (BChan, newBChan, writeBChan) +import qualified Brick.Widgets.Border as B +import qualified Brick.Widgets.Border.Style as BS +import qualified Brick.Widgets.List as L +import qualified Brick.Widgets.ProgressBar as P +import qualified Graphics.Vty as V + +import Pos.Chain.Block (HeaderHash) +import Pos.Chain.Update (ConfirmedProposalState (cpsAdopted, cpsConfirmed, cpsDecided, cpsImplicit, cpsNegativeStake, cpsPositiveStake, cpsProposed, cpsUpdateProposal, cpsVotes), + DecidedProposalState (dpsDecision, dpsDifficulty, dpsExtra, dpsUndecided), + ProposalState (PSDecided, PSUndecided), StakeholderVotes, + SystemTag (getSystemTag), + UndecidedProposalState (upsExtra, upsNegativeStake, upsPositiveStake, upsProposal, upsSlot, upsVotes), + UpId, UpdateData, + UpdateProposal (upData, upSoftwareVersion)) +import Pos.Core (Coin, EpochOrSlot (EpochOrSlot), getCoin) +import Pos.Core.Slotting (EpochIndex (EpochIndex), + LocalSlotIndex (UnsafeLocalSlotIndex), SlotId (SlotId)) + +runUI :: IO (BChan CustomEvent, BChan Reply, Async ()) +runUI = do + eventChan <- newBChan 10 + replyChan <- newBChan 10 + let + app = App + { appDraw = drawUi + , appChooseCursor = showFirstCursor + , appHandleEvent = handleEvent + , appStartEvent = \x -> pure x + , appAttrMap = const $ theMap + } + go :: IO () + go = do + _ <- customMain (V.mkVty V.defaultConfig) (Just eventChan) app (defaultState replyChan) + writeBChan replyChan TriggerShutdown + pure () + brick <- async go + pure (eventChan, replyChan, brick) + +defaultState :: BChan Reply -> AppState +defaultState replyChan = AppState 0 Nothing "" Nothing replyChan defaultList MainScreen emptyList + +defaultList :: L.List Name MenuChoice +defaultList = L.list MainMenu (V.fromList [ ListProposals, Dummy1, Dummy2 ]) 1 + +emptyList :: L.List Name a +emptyList = L.list None (V.fromList []) 1 + +localHeight :: AppState -> Widget Name +localHeight AppState{asLocalHeight} = str $ "Local Block Count: " <> show asLocalHeight + +globalHeight :: AppState -> Widget Name +globalHeight AppState{asGlobalHeight} = str $ "global: " <> maybe "unknown" show asGlobalHeight + +progressBar :: AppState -> Widget Name +progressBar AppState{asLocalHeight,asGlobalHeight} = do + let + fmt :: Format Text (Float -> Text) + fmt = "Percent: " % float % "%" + go :: Maybe Word64 -> Widget Name + go (Just global) = do + let + percent :: Float + percent = (fromIntegral asLocalHeight) / (fromIntegral global) + P.progressBar (Just $ T.unpack $ sformat fmt (percent * 100)) percent + go Nothing = emptyWidget + go asGlobalHeight + +lastMessage :: AppState -> Widget Name +lastMessage AppState{asLastMsg} = withBorderStyle BS.unicodeBold $ B.borderWithLabel (str "last debug msg") $ padAll 1 $ strWrap asLastMsg + +currentTip :: AppState -> Widget Name +currentTip AppState{asLocalEpochOrSlot} = go asLocalEpochOrSlot + where + go :: Maybe EpochOrSlot -> Widget Name + go (Just eors) = txt $ sformat fmt eors + go Nothing = txt "Local Slot unknown" + fmt :: Format r (EpochOrSlot -> r) + fmt = "Local Slot: " % fmtEpochOrSlot + +fmtEpochOrSlot :: Format r (EpochOrSlot -> r) +fmtEpochOrSlot = later f + where + f :: EpochOrSlot -> T.Builder + f (EpochOrSlot (Left (EpochIndex epoch))) = (T.fromText "EBB#") <> (T.fromString $ show epoch) + f (EpochOrSlot (Right (SlotId (EpochIndex epoch) (UnsafeLocalSlotIndex slot)))) = (T.fromText "Epoch ") <> (T.fromString $ show epoch) <> (T.fromText " Slot ") <> (T.fromString $ show slot) + +drawUi :: AppState -> [ Widget Name ] +drawUi state = do + let + debugMsg = lastMessage state + currentWindow :: Widget Name + currentWindow = case (asCurrentScreen state) of + MainScreen -> ui state + ProposalListing -> proposalUi state + [ vBox [ debugMsg, currentWindow ] ] + +ui :: AppState -> Widget Name +ui state = vBox [ localHeight state, globalHeight state, progressBar state, currentTip state, actionsList state ] + +renderUpData :: (SystemTag,UpdateData) -> Widget Name +renderUpData (tag,_) = padLeftRight 1 $ txt $ getSystemTag tag + +renderUpdateProposalLabel :: Widget Name -> UpdateProposal -> Widget Name +renderUpdateProposalLabel lbl prop = hBox ([ lbl, version ] <> (map renderUpData updata)) + where + updata :: [ (SystemTag, UpdateData) ] + updata = HM.toList $ upData prop + version :: Widget Name + version = padLeftRight 1 $ str $ show $ upSoftwareVersion prop + +proposalUi :: AppState -> Widget Name +proposalUi state = do + let + renderProposal :: Either ConfirmedProposalState (UpId,ProposalState) -> Widget Name + renderProposal (Left proposal) = renderUpdateProposalLabel (str "Confirmed: ") (cpsUpdateProposal proposal) + renderProposal (Right (upid, PSUndecided prop)) = renderUpdateProposalLabel (str "Undecided: ") (upsProposal prop) + renderProposal (Right (upid, PSDecided prop)) = renderUpdateProposalLabel (str "Decided: ") (upsProposal $ dpsUndecided prop) + let + renderProposalState :: (UpId, ProposalState) -> Widget Name + renderProposalState (upid, PSDecided prop) = do + let + decision, undecided, difficulty, extra :: Widget Name + decision = str $ "Decision: " <> show (dpsDecision prop) + undecided = renderProposalState (upid, PSUndecided $ dpsUndecided prop) + difficulty = str $ "Difficulty: " <> show (dpsDifficulty prop) + extra = str $ show $ dpsExtra prop + vBox [ decision, undecided, difficulty, extra ] + renderProposalState (upid', PSUndecided prop) = do + let + upid, votes, proposal, slot, extra :: Widget Name + upid = str $ "UpId: " <> show upid' + votes = renderVotes $ upsVotes prop + proposal = renderUpdateProposal $ upsProposal prop + slot = str $ "Slot: " <> show (upsSlot prop) + extra = str $ "Extra: " <> show (upsExtra prop) + vBox ([ upid, proposal, votes, slot, extra ] <> renderPosNeg upsPositiveStake upsNegativeStake prop) + proposalList = L.renderList (const $ renderProposal) True (asProposalList state) + details = case L.listSelectedElement (asProposalList state) of + Just (_, Left proposal) -> renderFullProposal proposal + Just (_, Right prop) -> renderProposalState prop + Nothing -> emptyWidget + proposalListing = withBorderStyle BS.unicodeBold $ B.borderWithLabel (str "Proposals") $ padLeftRight 1 proposalList + vBox [ proposalListing, details ] + +-- for future use: +-- getHeaderEpochOrSlot :: MonadDBRead m => HeaderHash -> m (Maybe EpochOrSlot) +-- exists + +renderVotes :: StakeholderVotes -> Widget Name +renderVotes votes = withBorderStyle BS.unicodeBold $ B.borderWithLabel (str "StakeholderVotes") $ strWrap $ "Votes: " <> show (length $ toList votes) <> " " <> show votes + +renderUpdateProposal :: UpdateProposal -> Widget Name +renderUpdateProposal prop = withBorderStyle BS.unicodeBold $ B.borderWithLabel (str "UpdateProposal") $ strWrap $ show prop + +renderPosNeg :: (a -> Coin) -> (a -> Coin) -> a -> [ Widget Name ] +renderPosNeg pos neg thing = [ posWidget, negWidget ] + where + posWidget, negWidget :: Widget Name + posWidget = str $ "Positive: " <> show (getCoin $ pos thing) + negWidget = str $ "Negative: " <> show (getCoin $ neg thing) + +renderFullProposal :: ConfirmedProposalState -> Widget Name +renderFullProposal prop = do + let + proposal, implicit, proposed, decided, confirmed, adopted :: Widget Name + proposal = renderUpdateProposal $ cpsUpdateProposal prop + implicit = str $ "Implicit: " <> if (cpsImplicit prop) then "Yes" else "no" + hhf :: String -> (ConfirmedProposalState -> HeaderHash) -> Widget Name + hhf lbl hh = str $ lbl <> show (hh prop) + proposed = hhf "Proposed: " cpsProposed + decided = hhf "Decided: " cpsDecided + confirmed = hhf "Confirmed: " cpsConfirmed + adopted = str $ "Adopted: " <> maybe "not yet (or no BV changes)" show (cpsAdopted prop) + votes = renderVotes $ cpsVotes prop + vBox ([ proposal, implicit, proposed, decided, confirmed, adopted, votes ] <> renderPosNeg cpsPositiveStake cpsNegativeStake prop) + +actionsList :: AppState -> Widget Name +actionsList state = do + let + renderRow :: Bool -> MenuChoice -> Widget Name + renderRow _ name = str $ show name + withBorderStyle BS.unicodeBold $ B.borderWithLabel (str "Main Menu") $ padLeftRight 1 $ L.renderList renderRow True (asChoiceList state) + +theMap :: A.AttrMap +theMap = A.attrMap V.defAttr + [ (L.listAttr, V.white `on` V.blue) + , (L.listSelectedAttr, V.blue `on` V.white) + , (P.progressCompleteAttr, V.blue `on` V.green) + , (P.progressIncompleteAttr, V.blue `on` V.red) + ] + +handleEvent :: AppState -> BrickEvent Name CustomEvent -> EventM Name (Next AppState) +handleEvent state (VtyEvent evt) = do + case (asCurrentScreen state) of + MainScreen -> do + let + openThing :: EventM Name (Next AppState) + openThing = do + case L.listSelectedElement (asChoiceList state) of + Just (_, ListProposals) -> do + liftIO $ writeBChan (asReplyChan state) QueryProposals + continue $ state + Just (_, item) -> do + continue $ state { asLastMsg = show item } + Nothing -> do + continue state + case evt of + V.EvKey (V.KChar 'q') [] -> do + halt state + V.EvKey V.KEnter [] -> openThing + V.EvKey V.KRight [] -> openThing + _ -> do + newlist <- L.handleListEventVi L.handleListEvent evt (asChoiceList state) + continue $ state { asLastMsg = show evt, asChoiceList = newlist } + ProposalListing -> do + case evt of + V.EvKey (V.KChar 'q') [] -> continue $ state { asCurrentScreen = MainScreen } + V.EvKey V.KLeft [] -> continue $ state { asCurrentScreen = MainScreen } + _ -> do + newlist <- L.handleListEventVi L.handleListEvent evt (asProposalList state) + continue $ state { asLastMsg = show evt, asProposalList = newlist } + +handleEvent state (AppEvent ae) = do + case ae of + CENodeInfo (NodeInfo{niLocalHeight,niGlobalHeight,niLocalEpochOrSlot}) -> do + continue $ state + { asLocalHeight = niLocalHeight + , asGlobalHeight = niGlobalHeight + , asLocalEpochOrSlot = Just niLocalEpochOrSlot + } + QuitEvent -> halt state + CESlotStart (SlotStart e s) -> continue $ state { asLastMsg = (show e) <> " " <> (show s) } + ProposalReply proposals other -> do + let + list = (map Left proposals) <> (map Right other) + continue $ state + { asCurrentScreen = ProposalListing + , asProposalList = L.list ProposalName (V.fromList list) 1 + } + +handleEvent state evt = do + continue $ state { asLastMsg = show evt } diff --git a/script-runner/common/BrickUITypes.hs b/script-runner/common/BrickUITypes.hs new file mode 100644 index 00000000000..8cd6a878461 --- /dev/null +++ b/script-runner/common/BrickUITypes.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module BrickUITypes (AppState(..), Name(..), CustomEvent(..), Reply(..), SlotStart(..), NodeInfo(..), MenuChoice(..), CurrentScreen(..)) where + +import qualified Brick.BChan as B +import qualified Brick.Widgets.List as L +import Pos.Core (EpochOrSlot) +import Universum + +import Pos.Chain.Update (ConfirmedProposalState, ProposalState, UpId) + +data AppState = AppState + { asLocalHeight :: Word64 + , asGlobalHeight :: Maybe Word64 + , asLastMsg :: String + , asLocalEpochOrSlot :: Maybe EpochOrSlot + , asReplyChan :: B.BChan Reply + , asChoiceList :: L.List Name MenuChoice + , asCurrentScreen :: CurrentScreen + , asProposalList :: L.List Name (Either ConfirmedProposalState (UpId,ProposalState)) + } + +data MenuChoice = ListProposals | Dummy1 | Dummy2 deriving (Show, Eq) +data CurrentScreen = MainScreen | ProposalListing deriving (Show, Eq) + +data Reply = TriggerShutdown | QueryProposals + +data SlotStart = SlotStart + { ssEpoch :: Word64 + , ssSlot :: Word16 + } deriving Show + +data NodeInfo = NodeInfo + { niLocalHeight :: Word64 + , niLocalEpochOrSlot :: EpochOrSlot + , niGlobalHeight :: Maybe Word64 + } deriving Show + +data CustomEvent + = CESlotStart SlotStart + | CENodeInfo NodeInfo + | QuitEvent + | ProposalReply [ConfirmedProposalState] [(UpId,ProposalState)] + deriving Show + +data Name = ProposalName | MainMenu | None deriving (Show, Ord, Eq) diff --git a/script-runner/common/NodeControl.hs b/script-runner/common/NodeControl.hs new file mode 100644 index 00000000000..15daf7fbe31 --- /dev/null +++ b/script-runner/common/NodeControl.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module NodeControl (NodeHandle, startNode, stopNode, stopNodeByName, genSystemStart, mkTopo, keygen, NodeInfo(..), mutateConfigurationYaml, createNodes, cleanupNodes) where + +import Control.Concurrent.Async.Lifted.Safe +import Control.Concurrent.STM.TVar (modifyTVar) +import qualified Data.Aeson as A +import qualified Data.ByteString.Lazy as BSL +import Data.Ix (range) +import qualified Data.Map as Map +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import Data.Time (NominalDiffTime, addUTCTime, defaultTimeLocale, + formatTime, getCurrentTime) +import Data.Time.Units (Second, convertUnit) +import qualified Data.Yaml as Y +import Network.Broadcast.OutboundQueue + (MaxBucketSize (BucketSizeUnlimited)) +import Network.DNS.Types (Domain) +import PocMode (PocMode, acStatePath, acTopology, nodeHandles) +import qualified Pos.Client.CLI as CLI +import Pos.Core.Slotting (Timestamp, getTimestamp) +import Pos.Infra.Network.DnsDomains (NodeAddr (..)) +import Pos.Infra.Network.Types (Fallbacks, NodeName (..), + NodeType (..), Valency) +import Pos.Infra.Network.Yaml (AllStaticallyKnownPeers (..), + DnsDomains (..), NodeMetadata (..), NodeRegion (..), + NodeRoutes (..), Topology (..)) +import Pos.Launcher (Configuration, ConfigurationOptions, + cfoFilePath_L, cfoSystemStart_L) +import Pos.Util.Config (parseYamlConfig) +import Pos.Util.Wlog (logInfo, logWarning) +import System.Posix.Signals +import System.Process +import Types +import Universum hiding (on, state, when) + +data NodeInfo = NodeInfo + { niIndex :: Integer + , niType :: Types.NodeType + , stateRoot :: Text + , topoPath :: Text + , niCfgFilePath :: CLI.CommonArgs + } + +startingPortOffset :: Num i => Types.NodeType -> i +startingPortOffset Core = 100 +startingPortOffset Relay = 0 + +mkTopo :: Integer -> Integer -> Topology +mkTopo cores relays = do + let + nmRegion = NodeRegion "none" + nmSubscribe :: DnsDomains ByteString + nmSubscribe = DnsDomains [] + nmValency :: Valency + nmValency = 1 + nmFallbacks :: Fallbacks + nmFallbacks = 1 + nmKademlia = False + nmPublicDNS = False + nmMaxSubscrs = BucketSizeUnlimited + mkNodeMeta :: Integer -> Types.NodeType -> NodeMetadata + mkNodeMeta idx typ = do + let + nmType = case typ of + Core -> NodeCore + Relay -> NodeRelay + nmAddress :: NodeAddr (Maybe Domain) + nmAddress = NodeAddrExact "127.0.0.1" (Just $ startingPortOffset typ + 3000 + (fromIntegral idx)) + mkRoute :: Integer -> [ NodeName ] + mkRoute x = [ NodeName ("core-" <> show x) ] + nmRoutes = case typ of + Core -> NodeRoutes [ [ NodeName "relay-0" ] ] + Relay -> NodeRoutes $ map mkRoute $ range (0,cores) + NodeMetadata{..} + mkCoreTup :: Integer -> (NodeName, NodeMetadata) + mkCoreTup idx = (NodeName $ T.pack $ "core-" <> (show idx), mkNodeMeta idx Core) + mkRelayTup idx = (NodeName $ T.pack $ "relay-" <> (show idx), mkNodeMeta idx Relay) + allCoreNodes :: [ (NodeName, NodeMetadata) ] + allCoreNodes = map mkCoreTup (range (0, cores)) + allRelayNodes :: [ (NodeName, NodeMetadata) ] + allRelayNodes = map mkRelayTup (range (0, relays)) + TopologyStatic $ AllStaticallyKnownPeers $ M.fromList (allCoreNodes <> allRelayNodes) + +typeToString :: Types.NodeType -> String +typeToString Core = "core" +typeToString Relay = "relay" + +commonNodeParams :: NodeInfo -> [ String ] +commonNodeParams (NodeInfo idx typ stateRoot topoPath cfg) = [ + "--configuration-file", cfg ^. CLI.configurationOptions_L . cfoFilePath_L + , "--topology", T.unpack topoPath + , "--db-path", (T.unpack stateRoot) <> "/poc-state/" <> (typeToString typ) <> (show idx) <> "-db" + , "--node-id", (typeToString typ) <> "-" <> (show idx) + , "--node-api-address", "127.0.0.1:" <> show (startingPortOffset typ + 8083 + idx) + , "--no-tls" + , "--node-doc-address", "127.0.0.1:" <> show (startingPortOffset typ + 8180 + idx) + , "--json-log", "poc-state/" <> typeToString typ <> show idx <> ".json" + , "--logs-prefix", "poc-state/logs-" <> typeToString typ <> show idx + ] <> (maybeSystemStart $ cfg ^. CLI.configurationOptions_L . cfoSystemStart_L) + <> (maybeLogConfig $ cfg ^. CLI.logConfig_L) + +maybeSystemStart :: Maybe Timestamp -> [ String ] +maybeSystemStart Nothing = [] +maybeSystemStart (Just ts) = [ "--system-start", show seconds ] + where + seconds :: Integer + seconds = fromIntegral @Second (convertUnit $ getTimestamp ts) + +maybeLogConfig :: Maybe FilePath -> [ String ] +maybeLogConfig Nothing = [] +maybeLogConfig (Just logconfig) = [ "--log-config", logconfig ] + +commonNodeStart :: String -> [ String ] -> Types.NodeType -> Integer -> PocMode () +commonNodeStart prog args typ idx = do + let + typename = typeToString typ + childStdout <- openFile ("poc-state/" <> typename <> "-stdout-" <> show idx) AppendMode + let + pc :: CreateProcess + pc = (proc prog args) { std_out = UseHandle childStdout } + (_stdin, _stdout, _stderr, ph) <- liftIO $ createProcess pc + later <- liftIO $ async $ do + _ <- waitForProcess ph + pure () + let + hnd = NodeHandle later ph + tvar <- nodeHandles + atomically $ modifyTVar tvar $ Map.insert (typ, idx) hnd + +startNode :: NodeInfo -> PocMode () +startNode info@(NodeInfo idx Core stateRoot _topoPath _cfg) = do + let + params = (commonNodeParams info) <> + [ "--keyfile", T.unpack (stateRoot <> "/genesis-keys/generated-keys/rich/key" <> (show idx) <> ".sk") + , "--listen", "127.0.0.1:" <> show (startingPortOffset Core + idx + 3000) + ] + commonNodeStart "cardano-node-simple" params Core idx +startNode info@(NodeInfo idx Relay stateRoot _topoPath _cfg) = do + let + params = (commonNodeParams info) <> + [ "--keyfile", T.unpack (stateRoot <> "/relay" <> (show idx) <> ".sk") + , "--listen", "127.0.0.1:" <> show (startingPortOffset Relay + idx + 3000) + ] + commonNodeStart "cardano-node-simple" params Relay idx + +stopNode :: NodeHandle -> IO () +stopNode (NodeHandle _async ph) = do + maybePid <- getPid ph + case maybePid of + Just pid -> do + signalProcess sigINT pid + Nothing -> do + logWarning "node already stopped when trying to stop it" + +stopNodeByName :: (Types.NodeType, Integer) -> PocMode () +stopNodeByName name = do + map' <- nodeHandles >>= atomically . readTVar + case (Map.lookup name map') of + Just hnd -> liftIO $ stopNode hnd + Nothing -> logWarning ("node " <> show name <> " not found in node map") + +genSystemStart :: NominalDiffTime -> IO String +genSystemStart offset = formatTime defaultTimeLocale "%s" . addUTCTime offset <$> getCurrentTime + +keygen :: ConfigurationOptions -> Text -> IO () +keygen cfg stateRoot = do + let + params = [ "generate-keys-by-spec" + , "--genesis-out-dir", T.unpack (stateRoot <> "/genesis-keys") + , "--configuration-file", cfg ^. cfoFilePath_L + ] <> (maybeSystemStart $ cfg ^. cfoSystemStart_L) + pc :: CreateProcess + pc = proc "cardano-keygen" params + (_stdin, _stdout, _stderr, ph) <- createProcess pc + _ <- waitForProcess ph + pure () + +mutateConfigurationYaml :: FilePath -> Text -> (Configuration -> Configuration) -> IO ByteString +mutateConfigurationYaml filepath key mutator = do + cfg <- parseYamlConfig filepath key + let + newcfg = mutator cfg + newmap = Map.singleton key newcfg + yaml = Y.encode newmap + pure yaml + +createNodes :: Todo -> ScriptRunnerOptions -> PocMode () +createNodes todo opts = do + topo <- view acTopology + stateDir <- view acStatePath + let + path = stateDir <> "/topology.yaml" + -- the config for the script-runner is mirrored to the nodes it starts + cfg = opts ^. srCommonNodeArgs . CLI.commonArgs_L + liftIO $ do + BSL.writeFile (T.unpack path) (A.encode topo) + keygen (cfg ^. CLI.configurationOptions_L) stateDir + forM_ (range (0,todoCoreNodes todo - 1)) $ \node -> startNode (NodeInfo node Core stateDir path cfg) + forM_ (range (0,0)) $ \node -> startNode (NodeInfo node Relay stateDir path cfg) + +cleanupNodes :: PocMode () +cleanupNodes = do + logInfo "stopping all nodes" + nodeHandles >>= atomically . readTVar >>= liftIO . mapM_ stopNode diff --git a/script-runner/common/OrphanedLenses.hs b/script-runner/common/OrphanedLenses.hs new file mode 100644 index 00000000000..4cd2c557de9 --- /dev/null +++ b/script-runner/common/OrphanedLenses.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} + +module OrphanedLenses where + +import Control.Lens (makeLensesWith) + +import Pos.Chain.Update (BlockVersionData, BlockVersionModifier) +import Pos.Util (postfixLFields) + +makeLensesWith postfixLFields ''BlockVersionModifier +makeLensesWith postfixLFields ''BlockVersionData diff --git a/script-runner/common/PocMode.hs b/script-runner/common/PocMode.hs new file mode 100644 index 00000000000..f690a51449d --- /dev/null +++ b/script-runner/common/PocMode.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Execution mode used in Auxx. + +module PocMode + ( + -- * Mode, context, etc. + AuxxContext (..) + , PocMode + , MonadPocMode + , acScriptOptions + , acTopology + , acStatePath + , ScriptBuilder(..) + , CompiledScript(..) + , SlotTrigger(..) + , Script(..) + , ScriptT(runScriptT) + , InputParams(..) + , InputParams2(..) + , ScriptParams(..) + + -- * Helpers + , realModeToAuxx + , writeBrickChan + , nodeHandles + ) where + +import Universum + +import Brick.BChan (BChan, writeBChan) +import Control.Lens (lens, makeLenses) +import Control.Monad.Reader (withReaderT) +import Control.Monad.Trans.Resource (transResourceT) +import Data.Conduit (transPipe) +import Data.Constraint (Dict) +import Data.Default (Default (def)) +import qualified Data.Map as Map +import Prelude (show) + +import BrickUITypes (CustomEvent) + +import Pos.Chain.Block (HasSlogContext (slogContext), + HasSlogGState (slogGState)) +import Pos.Chain.Genesis as Genesis (Config) +import Pos.Chain.Ssc (HasSscContext (sscContext)) +import Pos.Client.KeyStorage (MonadKeys (modifySecret), + MonadKeysRead (getSecret), getSecretDefault, + modifySecretDefault) +import Pos.Context (HasNodeContext (nodeContext)) +import Pos.Core (SlotCount, SlotId) +import Pos.Core (HasPrimaryKey (primaryKey)) +import Pos.Core.JsonLog (CanJsonLog (jsonLog)) +import Pos.Core.Reporting (HasMisbehaviorMetrics (misbehaviorMetrics), + MonadReporting (report)) +import Pos.Core.Slotting + (HasSlottingVar (slottingTimestamp, slottingVar), + MonadSlotsData) +import Pos.DB (MonadGState (gsAdoptedBVData)) +import Pos.DB.Block (MonadBListener (onApplyBlocks, onRollbackBlocks)) +import Pos.DB.Class + (MonadDB (dbDelete, dbPut, dbPutSerBlunds, dbWriteBatch), + MonadDBRead (dbGet, dbGetSerBlock, dbGetSerBlund, dbGetSerUndo, dbIterSource)) +import Pos.DB.Txp (MempoolExt, + MonadTxpLocal (txpNormalize, txpProcessTx), txNormalize, + txProcessTransaction) +import Pos.Infra.Diffusion.Types (Diffusion) +import Pos.Infra.Network.Types (HasNodeType (getNodeType), + NodeType (NodeEdge)) +import Pos.Infra.Network.Yaml (Topology) +import Pos.Infra.Shutdown (HasShutdownContext (shutdownContext)) +import Pos.Infra.Slotting.Class (MonadSlots (currentTimeSlotting, getCurrentSlot, getCurrentSlotBlocking, getCurrentSlotInaccurate)) +import Pos.Launcher (HasConfigurations) +import Pos.Util (HasLens (lensOf)) +import Pos.Util.CompileInfo (HasCompileInfo) +import Pos.Util.LoggerName (HasLoggerName' (loggerName)) +import Pos.Util.UserSecret (HasUserSecret (userSecret)) +import Pos.Util.Wlog (HasLoggerName (askLoggerName, modifyLoggerName)) +import Pos.WorkMode (EmptyMempoolExt, RealMode, RealModeContext) + +import BrickUITypes +import Types (NodeHandle, NodeType, ScriptRunnerOptions, Todo) + +type PocMode = ReaderT AuxxContext IO + +class (m ~ PocMode, HasConfigurations, HasCompileInfo) => MonadPocMode m +instance (HasConfigurations, HasCompileInfo) => MonadPocMode PocMode + +data AuxxContext = AuxxContext + { _acRealModeContext :: !(RealModeContext EmptyMempoolExt) + , _acEventChan :: !(BChan CustomEvent) + , _acNodeHandles :: !(TVar (Map (Types.NodeType,Integer) NodeHandle)) + , _acScriptOptions :: !(ScriptRunnerOptions) + , _acTopology :: !(Topology) + , _acStatePath :: !(Text) + } + +makeLenses ''AuxxContext + +data SlotTrigger = SlotTrigger (Dict HasConfigurations -> Diffusion PocMode -> PocMode ()) +instance Show SlotTrigger where + show _ = "IO ()" + +data CompiledScript = CompiledScript + { slotTriggers :: Map.Map SlotId SlotTrigger + , startupActions :: [ SlotTrigger ] + } deriving (Show, Generic) +instance Default CompiledScript where def = CompiledScript def def + +data ScriptBuilder = ScriptBuilder + { sbScript :: CompiledScript + , sbEpochSlots :: SlotCount + , sbGenesisConfig :: Config + } + +data ScriptParams = ScriptParams + { spScript :: !(Script ()) + , spTodo :: Todo + , spRecentSystemStart :: Bool + , spStartCoreAndRelay :: Bool + } + +data InputParams = InputParams + { ipEventChan :: BChan CustomEvent + , ipReplyChan :: BChan Reply + , ipScriptParams :: ScriptParams + , ipStatePath :: Text + } +data InputParams2 = InputParams2 + { ip2EventChan :: BChan CustomEvent + , ip2ReplyChan :: BChan Reply + , ip2ScriptParams :: ScriptParams + , ip2StatePath :: Text + } + +newtype ScriptT m a = ScriptT { runScriptT :: StateT ScriptBuilder m a } deriving (Functor, Applicative, Monad, MonadState ScriptBuilder) +newtype Script a = Script { runScriptMonad :: ScriptT (Identity) a } deriving (Applicative, Functor, Monad, MonadState ScriptBuilder) + +writeBrickChan :: CustomEvent -> PocMode () +writeBrickChan event = do + chan <- view acEventChan + liftIO $ writeBChan chan event + +nodeHandles :: PocMode (TVar (Map (Types.NodeType,Integer) NodeHandle)) +nodeHandles = view acNodeHandles + +---------------------------------------------------------------------------- +-- Helpers +---------------------------------------------------------------------------- + +-- | Turn 'RealMode' action into 'PocMode' action. +realModeToAuxx :: RealMode EmptyMempoolExt a -> PocMode a +realModeToAuxx = withReaderT _acRealModeContext + +---------------------------------------------------------------------------- +-- Boilerplate instances +---------------------------------------------------------------------------- + +instance HasSscContext AuxxContext where + sscContext = acRealModeContext . sscContext + +instance HasPrimaryKey AuxxContext where + primaryKey = acRealModeContext . primaryKey + +-- | Ignore reports. +-- FIXME it's a bad sign that we even need this instance. +-- The pieces of the software which the block generator uses should never +-- even try to report. +instance MonadReporting PocMode where + report _ = pure () + +-- | Ignore reports. +-- FIXME it's a bad sign that we even need this instance. +instance HasMisbehaviorMetrics AuxxContext where + misbehaviorMetrics = lens (const Nothing) const + +instance HasUserSecret AuxxContext where + userSecret = acRealModeContext . userSecret + +instance HasShutdownContext AuxxContext where + shutdownContext = acRealModeContext . shutdownContext + +instance HasNodeContext AuxxContext where + nodeContext = acRealModeContext . nodeContext + +instance HasSlottingVar AuxxContext where + slottingTimestamp = acRealModeContext . slottingTimestamp + slottingVar = acRealModeContext . slottingVar + +instance HasNodeType AuxxContext where + getNodeType _ = NodeEdge + +instance {-# OVERLAPPABLE #-} + HasLens tag (RealModeContext EmptyMempoolExt) r => + HasLens tag AuxxContext r + where + lensOf = acRealModeContext . lensOf @tag + +instance HasLoggerName' AuxxContext where + loggerName = acRealModeContext . loggerName + +instance HasSlogContext AuxxContext where + slogContext = acRealModeContext . slogContext + +instance HasSlogGState AuxxContext where + slogGState = acRealModeContext . slogGState + +instance MonadSlotsData ctx PocMode => MonadSlots ctx PocMode where + getCurrentSlot = realModeToAuxx . getCurrentSlot + getCurrentSlotBlocking = realModeToAuxx . getCurrentSlotBlocking + getCurrentSlotInaccurate = realModeToAuxx . getCurrentSlotInaccurate + currentTimeSlotting = realModeToAuxx currentTimeSlotting + +instance {-# OVERLAPPING #-} HasLoggerName PocMode where + askLoggerName = realModeToAuxx askLoggerName + modifyLoggerName f action = do + auxxCtx <- ask + let auxxToRealMode :: PocMode a -> RealMode EmptyMempoolExt a + auxxToRealMode = withReaderT (\realCtx -> set acRealModeContext realCtx auxxCtx) + realModeToAuxx $ modifyLoggerName f $ auxxToRealMode action + +instance {-# OVERLAPPING #-} CanJsonLog PocMode where + jsonLog = realModeToAuxx ... jsonLog + +instance MonadDBRead PocMode where + dbGet = realModeToAuxx ... dbGet + dbIterSource tag p = + transPipe (transResourceT realModeToAuxx) (dbIterSource tag p) + dbGetSerBlock = realModeToAuxx ... dbGetSerBlock + dbGetSerUndo = realModeToAuxx ... dbGetSerUndo + dbGetSerBlund = realModeToAuxx ... dbGetSerBlund + +instance MonadDB PocMode where + dbPut = realModeToAuxx ... dbPut + dbWriteBatch = realModeToAuxx ... dbWriteBatch + dbDelete = realModeToAuxx ... dbDelete + dbPutSerBlunds = realModeToAuxx ... dbPutSerBlunds + +instance MonadGState PocMode where + gsAdoptedBVData = realModeToAuxx ... gsAdoptedBVData + +instance MonadBListener PocMode where + onApplyBlocks = realModeToAuxx ... onApplyBlocks + onRollbackBlocks = realModeToAuxx ... onRollbackBlocks + +instance MonadKeysRead PocMode where + getSecret = getSecretDefault + +instance MonadKeys PocMode where + modifySecret = modifySecretDefault + +type instance MempoolExt PocMode = EmptyMempoolExt + +instance MonadTxpLocal PocMode where + txpNormalize pm = withReaderT _acRealModeContext . txNormalize pm + txpProcessTx genesisConfig txpConfig = withReaderT _acRealModeContext . txProcessTransaction genesisConfig txpConfig + diff --git a/script-runner/common/Types.hs b/script-runner/common/Types.hs new file mode 100644 index 00000000000..25d0ea24b65 --- /dev/null +++ b/script-runner/common/Types.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} + +module Types (NodeHandle(..), NodeType(..), ScriptRunnerOptions(..), ScriptRunnerUIMode(..), srCommonNodeArgs, srPeers, srUiMode, Todo(..)) where + +import Control.Concurrent.Async.Lifted.Safe +import Control.Lens (makeLenses) +import System.Process +import Universum + +import qualified Pos.Client.CLI as CLI +import Pos.Infra.Network.Types (NodeId) + +data NodeHandle = NodeHandle (Async ()) ProcessHandle +data NodeType = Core | Relay deriving (Eq, Ord, Show) +data ScriptRunnerUIMode = BrickUI | PrintUI deriving Show + +data ScriptRunnerOptions = ScriptRunnerOptions + { _srCommonNodeArgs :: !CLI.CommonNodeArgs -- ^ Common CLI args for nodes + , _srPeers :: ![NodeId] + , _srUiMode :: !ScriptRunnerUIMode + } deriving Show + +makeLenses ''ScriptRunnerOptions + +-- todo, extract this metadata out of the Configuration type +data Todo = Todo { + todoCoreNodes :: Integer + } deriving Show diff --git a/script-runner/log-config.yaml b/script-runner/log-config.yaml new file mode 100644 index 00000000000..6256c0a333f --- /dev/null +++ b/script-runner/log-config.yaml @@ -0,0 +1,24 @@ +rotation: + logLimit: 104857600 # 100MB + keepFiles: 100 +loggerTree: + severity: Info+ + files: + + handlers: + - { name: "console" + , logsafety: SecretLogLevel + , severity: Debug + , filepath: "stdout" + , backend: StdoutBE } + - { name: "JSON1" + , filepath: "pub/node.json" + , logsafety: PublicLogLevel + , severity: Debug + , backend: FileJsonBE } + - { name: "JSON2" + , filepath: "node.json" + , logsafety: SecretLogLevel + , severity: Debug + , backend: FileJsonBE } + diff --git a/script-runner/runtest.nix b/script-runner/runtest.nix new file mode 100644 index 00000000000..8bf2c357599 --- /dev/null +++ b/script-runner/runtest.nix @@ -0,0 +1,16 @@ +let + cardanoPkgs = import ../default.nix {}; + pkgs = cardanoPkgs.pkgs; + runTest = testname: pkgs.runCommand "test-${testname}" { buildInputs = with cardanoPkgs; [ cardano-sl-script-runner cardano-sl-node-static cardano-sl-tools ]; } '' + cat /etc/nsswitch.conf /etc/protocols > /dev/null + mkdir $out + cd $out + mkdir poc-state + export SCRIPT=${testname} + testcases --configuration-file ${../lib/configuration.yaml} --db-path poc-state/db --keyfile poc-state/secret.key --log-console-off --log-config ${./log-config.yaml} --logs-prefix poc-state/logs --topology ${./topology-local.yaml} --no-brickui --policies ${../scripts/policies/policy_script-runner.yaml} + egrep -r --color=always "Processing of proposal|We'll request data for key Tagged|Ignoring data|Proposal .* is confirmed" poc-state/relay-stdout-0 + ''; +in { + test41 = runTest "test4.1"; + test42 = runTest "test4.2"; +} diff --git a/script-runner/shell.nix b/script-runner/shell.nix new file mode 100644 index 00000000000..df1866b2ed0 --- /dev/null +++ b/script-runner/shell.nix @@ -0,0 +1,27 @@ +let + cardanoPkgs = import ../default.nix {}; + cfgFiles = cardanoPkgs.pkgs.runCommand "cfg" {} '' + mkdir $out + cd $out + cp ${../lib/configuration.yaml} configuration.yaml + cp ${../lib/mainnet-genesis.json} mainnet-genesis.json + cp ${../lib/testnet-genesis.json} testnet-genesis.json + cp ${../lib/mainnet-genesis-dryrun-with-stakeholders.json} mainnet-genesis-dryrun-with-stakeholders.json + ''; + makeHelper = cfg: cardanoPkgs.pkgs.writeScriptBin "test-gui-${cfg.name}" '' + #!/bin/sh + + BIN=$(realpath dist/build/testcases/testcases) + + mkdir -pv ~/dedup/poc-state-${cfg.name} + cd ~/dedup/poc-state-${cfg.name} + + SCRIPT=none $BIN --configuration-file ${cfgFiles}/configuration.yaml --configuration-key ${cfg.key} --log-console-off --db-path db --keyfile secret.key --log-config ${./log-config.yaml} --logs-prefix logs --topology ${./. + "/topology-${cfg.name}.yaml"} + ''; + mainnet = makeHelper { name = "mainnet"; key = "mainnet_full"; }; + testnet = makeHelper { name = "testnet"; key = "testnet_full"; }; + staging = makeHelper { name = "staging"; key = "mainnet_dryrun_full"; }; +in + cardanoPkgs.cardano-sl-script-runner.env.overrideAttrs (drv: { + buildInputs = drv.buildInputs ++ [ cardanoPkgs.cardano-sl-node-static cardanoPkgs.cardano-sl-tools mainnet testnet staging ]; + }) diff --git a/script-runner/topology-local.yaml b/script-runner/topology-local.yaml new file mode 100644 index 00000000000..0cf51953b15 --- /dev/null +++ b/script-runner/topology-local.yaml @@ -0,0 +1,5 @@ +wallet: + relays: + - - addr: 127.0.0.1 + valency: 1 + fallbacks: 7 diff --git a/script-runner/topology-mainnet.yaml b/script-runner/topology-mainnet.yaml new file mode 100644 index 00000000000..10f76603b28 --- /dev/null +++ b/script-runner/topology-mainnet.yaml @@ -0,0 +1,5 @@ +wallet: + relays: + - - host: relays.cardano-mainnet.iohk.io + valency: 1 + fallbacks: 7 diff --git a/script-runner/topology-staging.yaml b/script-runner/topology-staging.yaml new file mode 100644 index 00000000000..e95a33a6a61 --- /dev/null +++ b/script-runner/topology-staging.yaml @@ -0,0 +1,5 @@ +wallet: + relays: + - - host: relays.awstest.iohkdev.io + valency: 1 + fallbacks: 7 diff --git a/script-runner/topology-testnet.yaml b/script-runner/topology-testnet.yaml new file mode 100644 index 00000000000..ac99b2e1b11 --- /dev/null +++ b/script-runner/topology-testnet.yaml @@ -0,0 +1,5 @@ +wallet: + relays: + - - host: relays.cardano-testnet.iohkdev.io + valency: 1 + fallbacks: 7 diff --git a/script-runner/topology.yaml b/script-runner/topology.yaml new file mode 100644 index 00000000000..668392cae88 --- /dev/null +++ b/script-runner/topology.yaml @@ -0,0 +1,6 @@ +wallet: + relays: + - - addr: 127.0.0.1 + port: 3100 + valency: 1 + fallbacks: 7 diff --git a/scripts/policies/policy_script-runner.yaml b/scripts/policies/policy_script-runner.yaml new file mode 100644 index 00000000000..c8970e563cf --- /dev/null +++ b/scripts/policies/policy_script-runner.yaml @@ -0,0 +1,84 @@ +enqueue: + + announceBlockHeader: [] + + requestBlockHeaders: + - all: + nodeType: 'relay' + maxAhead: 1 + precedence: 'high' + + requestBlocks: + - one: + nodeTypes: ['relay'] + maxAhead: 2 + precedence: 'high' + + mpc: + send: + - all: + nodeType: 'relay' + maxAhead: 2 + precedence: 'medium' + forward: + - all: + nodeType: 'relay' + maxAhead: 2 + precedence: 'medium' + + transaction: + send: + - all: + nodeType: 'relay' + maxAhead: 2 + precedence: 'low' + forward: [] + +dequeue: + + core: + rateLimit: 0 + maxInFlight: 0 + + relay: + rateLimit: 1 + maxInFlight: 2 + + edge: + rateLimit: 0 + maxInFlight: 0 + +failure: + + core: + announceBlockHeader: 200 + requestBlockHeaders: 200 + requestBlocks: 200 + transaction: + send: 200 + forward: 200 + mpc: + send: 200 + forward: 200 + + relay: + announceBlockHeader: 200 + requestBlockHeaders: 200 + requestBlocks: 200 + transaction: + send: 200 + forward: 200 + mpc: + send: 200 + forward: 200 + + edge: + announceBlockHeader: 200 + requestBlockHeaders: 200 + requestBlocks: 200 + transaction: + send: 200 + forward: 200 + mpc: + send: 200 + forward: 200 diff --git a/stack.yaml b/stack.yaml index 6d1590a9450..94a507c468c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -30,6 +30,7 @@ packages: - generator - client - auxx +- script-runner - explorer - node - tools diff --git a/util/src/Pos/Util/Wlog/Compatibility.hs b/util/src/Pos/Util/Wlog/Compatibility.hs index ab26846daad..53625333e02 100644 --- a/util/src/Pos/Util/Wlog/Compatibility.hs +++ b/util/src/Pos/Util/Wlog/Compatibility.hs @@ -112,6 +112,10 @@ instance CanLog IO where type WithLogger m = (CanLog m, HasLoggerName m) +{-# INLINE logInfo #-} +{-# INLINE logNotice #-} +{-# INLINE logWarning #-} +{-# INLINE logError #-} logDebug, logInfo, logNotice, logWarning, logError :: WithLogger m => Text -> m () @@ -121,6 +125,7 @@ logNotice = logMessage Notice logWarning = logMessage Warning logError = logMessage Error +{-# INLINE logMessage #-} logMessage :: WithLogger m => Severity -> Text -> m () logMessage severity msg = do name <- askLoggerName From d43d96ba8038c0fef11d073f6d4fe51db73f1c33 Mon Sep 17 00:00:00 2001 From: Michael Hueschen Date: Thu, 17 Jan 2019 16:12:50 -0500 Subject: [PATCH 2/8] [DEVOPS-1131] Add (hopefully) more descriptive variable names --- script-runner/common/AutomatedTestRunner.hs | 36 ++++++++++----------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/script-runner/common/AutomatedTestRunner.hs b/script-runner/common/AutomatedTestRunner.hs index d63488fe303..69e02058c4c 100644 --- a/script-runner/common/AutomatedTestRunner.hs +++ b/script-runner/common/AutomatedTestRunner.hs @@ -34,7 +34,7 @@ import Prelude (read) import System.Exit (ExitCode) import System.IO (BufferMode (LineBuffering), hPrint, hSetBuffering) import qualified Turtle as T -import Universum hiding (on, state, when) +import Universum hiding (on) import Ntp.Client (NtpConfiguration) import Paths_cardano_sl (version) @@ -130,8 +130,8 @@ getScriptRunnerOptions = execParser programInfo loggerName :: LoggerName loggerName = "script-runner" -thing :: HasCompileInfo => ScriptRunnerOptions -> InputParams -> IO () -thing opts inputParams = do +executeAction :: HasCompileInfo => ScriptRunnerOptions -> InputParams -> IO () +executeAction opts inputParams = do let conf = CLI.configurationOptions (CLI.commonArgs cArgs) cArgs@CLI.CommonNodeArgs{CLI.cnaDumpGenesisDataPath,CLI.cnaDumpConfiguration} = opts ^. srCommonNodeArgs @@ -162,15 +162,15 @@ runWithConfig opts inputParams genesisConfig _walletConfig txpConfig _ntpConfig nodeParams = maybeAddPeers (opts ^. srPeers) $ nodeParams' vssSK = fromMaybe (error "no user secret given") (npUserSecret nodeParams ^. usVss) sscParams = CLI.gtSscParams (opts ^. srCommonNodeArgs) vssSK (npBehaviorConfig nodeParams) - thing1 = txpGlobalSettings genesisConfig txpConfig - thing2 :: ReaderT InitModeContext IO () - thing2 = initNodeDBs genesisConfig + txpGS = txpGlobalSettings genesisConfig txpConfig + initNDBs :: ReaderT InitModeContext IO () + initNDBs = initNodeDBs genesisConfig let inputParams' = InputParams2 (ipEventChan inputParams) (ipReplyChan inputParams) (ipScriptParams inputParams) (ipStatePath inputParams) - bracketNodeResources genesisConfig nodeParams sscParams thing1 thing2 (thing3 opts genesisConfig txpConfig inputParams') + bracketNodeResources genesisConfig nodeParams sscParams txpGS initNDBs (nodeResourceAction opts genesisConfig txpConfig inputParams') -thing3 :: (HasCompileInfo, HasConfigurations) => ScriptRunnerOptions -> Config -> TxpConfiguration -> InputParams2 -> NodeResources () -> IO () -thing3 opts genesisConfig txpConfig inputParams nr = do +nodeResourceAction :: (HasCompileInfo, HasConfigurations) => ScriptRunnerOptions -> Config -> TxpConfiguration -> InputParams2 -> NodeResources () -> IO () +nodeResourceAction opts genesisConfig txpConfig inputParams nr = do handles <- newTVarIO mempty let -- cores run from 0-3, relays run from 0-0 @@ -187,20 +187,20 @@ thing3 opts genesisConfig txpConfig inputParams nr = do , _acTopology = topo , _acStatePath = ip2StatePath inputParams } - thing2 :: Diffusion (RealMode ()) -> RealMode EmptyMempoolExt () - thing2 diffusion = toRealMode (thing5 (hoistDiffusion realModeToAuxx toRealMode diffusion)) - thing5 :: Diffusion PocMode -> PocMode () - thing5 diffusion = do + mkPlugins :: CompiledScript -> [ (Text, Diffusion PocMode -> PocMode ()) ] + mkPlugins script = workers script genesisConfig inputParams + mkPocMode :: Diffusion PocMode -> PocMode () + mkPocMode diffusion = do if spStartCoreAndRelay $ ip2ScriptParams inputParams then createNodes (spTodo $ ip2ScriptParams inputParams) opts else pure () let epochSlots = configEpochSlots genesisConfig let finalscript = (exampleToScript epochSlots genesisConfig . spScript . ip2ScriptParams) inputParams - runNode genesisConfig txpConfig nr (thing4 finalscript) diffusion + runNode genesisConfig txpConfig nr (mkPlugins finalscript) diffusion cleanupNodes - thing4 :: CompiledScript -> [ (Text, Diffusion PocMode -> PocMode ()) ] - thing4 script = workers script genesisConfig inputParams - runRealMode updateConfiguration genesisConfig txpConfig nr thing2 + action :: Diffusion (RealMode ()) -> RealMode EmptyMempoolExt () + action diffusion = toRealMode (mkPocMode (hoistDiffusion realModeToAuxx toRealMode diffusion)) + runRealMode updateConfiguration genesisConfig txpConfig nr action workers :: HasConfigurations => CompiledScript -> Genesis.Config -> InputParams2 -> [ (Text, Diffusion PocMode -> PocMode ()) ] workers script genesisConfig InputParams2{ip2EventChan,ip2ReplyChan} = @@ -276,7 +276,7 @@ runScript sp = T.with (T.mktempdir "/tmp" "script-runner") $ \stateDir -> withCo loggerBracket "script-runner" loggingParams . logException "script-runner" $ do let inputParams = InputParams eventChan replyChan sp (T.pack $ T.encodeString stateDir) - thing opts inputParams + executeAction opts inputParams pure () liftIO $ writeBChan eventChan QuitEvent _finalState <- wait asyncUi From df67a2aa62b0fcddbf3a6dae02f9279e02e3832e Mon Sep 17 00:00:00 2001 From: Michael Bishop Date: Tue, 22 Jan 2019 01:40:37 -0400 Subject: [PATCH 3/8] [DEVOPS-1131] remove paths specific to my local machine --- script-runner/BlockParser.hs | 7 +------ script-runner/Makefile | 8 -------- script-runner/shell.nix | 4 ++-- 3 files changed, 3 insertions(+), 16 deletions(-) delete mode 100644 script-runner/Makefile diff --git a/script-runner/BlockParser.hs b/script-runner/BlockParser.hs index c85390de3cb..799f1002f4f 100644 --- a/script-runner/BlockParser.hs +++ b/script-runner/BlockParser.hs @@ -1,7 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -module BlockParser (file1, file2, printBlock) where +module BlockParser (printBlock) where import Codec.CBOR.Read (deserialiseFromBytes) import Pos.Binary.Class (decode) @@ -11,11 +11,6 @@ import Universum hiding (openFile, when) import qualified Data.ByteString.Lazy as LBS -file1 :: FilePath -file1 = "/home/clever/dedup/staging-poc/blocks/data/68/c85b75adcc99048e633e4b84337b36542e020337c618742d7716e6acc22b39.blund" -file2 :: FilePath -file2 = "9f5124c1f20924f809e741dc9ceda2d2c5422ce8f7024f800060df4e787bc9d3.blund" - printBlock :: FilePath -> IO () printBlock filename = do raw <- LBS.readFile filename diff --git a/script-runner/Makefile b/script-runner/Makefile deleted file mode 100644 index 4fee3f7beb3..00000000000 --- a/script-runner/Makefile +++ /dev/null @@ -1,8 +0,0 @@ -dist/build/poc/poc: AutomatedTestRunner.hs BlockParser.hs Poc.hs BrickUI.hs NodeControl.hs - runhaskell Setup.hs build -j10 poc - -poc-test: dist/build/poc/poc - mkdir -p poc-state - ./dist/build/poc/poc --configuration-file ../lib/configuration.yaml --log-console-off --db-path poc-state/db --keyfile poc-state/secret.key --log-config log-config.yaml --logs-prefix poc-state/logs/ --topology topology-local.yaml - -.PHONY: poc-test diff --git a/script-runner/shell.nix b/script-runner/shell.nix index df1866b2ed0..d33803e034a 100644 --- a/script-runner/shell.nix +++ b/script-runner/shell.nix @@ -13,8 +13,8 @@ let BIN=$(realpath dist/build/testcases/testcases) - mkdir -pv ~/dedup/poc-state-${cfg.name} - cd ~/dedup/poc-state-${cfg.name} + mkdir -pv states/poc-state-${cfg.name} + cd states/poc-state-${cfg.name} SCRIPT=none $BIN --configuration-file ${cfgFiles}/configuration.yaml --configuration-key ${cfg.key} --log-console-off --db-path db --keyfile secret.key --log-config ${./log-config.yaml} --logs-prefix logs --topology ${./. + "/topology-${cfg.name}.yaml"} ''; From f47720333e68193f37c33056d0f886432975170d Mon Sep 17 00:00:00 2001 From: Michael Bishop Date: Wed, 23 Jan 2019 04:57:18 -0400 Subject: [PATCH 4/8] [DEVOPS-1131] add some scripts that can run the tests under stack --- script-runner/stack-gui | 37 +++++++++++++++++++++++++++++++++++++ script-runner/stack-test | 26 ++++++++++++++++++++++++++ 2 files changed, 63 insertions(+) create mode 100755 script-runner/stack-gui create mode 100755 script-runner/stack-test diff --git a/script-runner/stack-gui b/script-runner/stack-gui new file mode 100755 index 00000000000..a35fa013bad --- /dev/null +++ b/script-runner/stack-gui @@ -0,0 +1,37 @@ +#!/bin/sh + +# usage: ./stack-gui testnet + +set -e +set -x + +pushd .. +stack build cardano-sl-script-runner cardano-sl-node cardano-sl-tools +export PATH=$(realpath .stack-work/install/x86_64-linux-nix/lts-12.17/8.4.4/bin/):$PATH +popd + +NAME=$1 + +case "$NAME" in + mainnet) + KEY=mainnet_full + ;; + testnet) + KEY=testnet_full + ;; + staging) + KEY=mainnet_dryrun_full + ;; + *) + echo "error, you must give a cluster name, '$0 testnet' for example" + exit 1 + ;; +esac +CFG=$(realpath ../lib/configuration.yaml) +LOGCFG=$(realpath ./log-config.yaml) +TOPO=$(realpath ./topology-${NAME}.yaml) + +mkdir -pv states/poc-state-${NAME} +cd states/poc-state-${NAME} + +SCRIPT=none testcases --configuration-file $CFG --configuration-key "$KEY" --log-console-off --db-path db --keyfile secret.key --log-config $LOGCFG --logs-prefix logs --topology $TOPO diff --git a/script-runner/stack-test b/script-runner/stack-test new file mode 100755 index 00000000000..5129d2f85fe --- /dev/null +++ b/script-runner/stack-test @@ -0,0 +1,26 @@ +#!/bin/sh + +# usage: ./stack-test test4.2 + +set -e +set -x + +pushd .. +stack build cardano-sl-script-runner cardano-sl-node cardano-sl-tools +export PATH=$(realpath .stack-work/install/x86_64-linux-nix/lts-12.17/8.4.4/bin/):$PATH +popd + +export SCRIPT=$1 + +CFG=$(realpath ../lib/configuration.yaml) +LOGCFG=$(realpath ./log-config.yaml) +TOPO=$(realpath ./topology-local.yaml) +POLFILE=$(realpath ../scripts/policies/policy_script-runner.yaml) + +T=$(mktemp -d -p . testrun-XXXXXX) +cd $T +mkdir poc-state + +testcases --configuration-file $CFG --log-console-off --db-path poc-state/db --keyfile secret.key --log-config $LOGCFG --logs-prefix poc-state/logs --topology $TOPO --no-brickui --policies $POLFILE + +egrep -r --color=always "Processing of proposal|We'll request data for key Tagged|Ignoring data|Proposal .* is confirmed" relay-stdout-0 From 8709a1afac72c9bf28c549c755e3f324396047e7 Mon Sep 17 00:00:00 2001 From: Michael Hueschen Date: Wed, 23 Jan 2019 12:00:57 -0500 Subject: [PATCH 5/8] [DEVOPS-1131] Add README, tweak scripts, add gitignore entry --- .gitignore | 3 +++ script-runner/README.md | 7 +++++++ script-runner/stack-gui | 9 ++++++++- script-runner/stack-test | 12 ++++++++++-- 4 files changed, 28 insertions(+), 3 deletions(-) create mode 100644 script-runner/README.md diff --git a/.gitignore b/.gitignore index 496a7d0e352..d3685d276de 100644 --- a/.gitignore +++ b/.gitignore @@ -73,6 +73,9 @@ scripts/haskell/dependencies.hi scripts/haskell/dependencies.o scripts/haskell/dependencies +# script-runner state +script-runner/states/ + # Cache for pkgs/generate.sh /pkgs/.cabal/ /pkgs/.stack/ diff --git a/script-runner/README.md b/script-runner/README.md new file mode 100644 index 00000000000..7151ceaf5d3 --- /dev/null +++ b/script-runner/README.md @@ -0,0 +1,7 @@ +# script-runner + +This module contains scripts to perform tests at the cluster level - running clusters of nodes, issuing update proposals to them, restarting them, etc. Some of the code here was extracted from the `auxx` package and reworked. + +### Usage + +See the `stack-gui` and `stack-test` scripts which contain usage commands. diff --git a/script-runner/stack-gui b/script-runner/stack-gui index a35fa013bad..c69839ed869 100755 --- a/script-runner/stack-gui +++ b/script-runner/stack-gui @@ -2,12 +2,19 @@ # usage: ./stack-gui testnet +# UI usage: +# +# Up/down arrows: navigate menus +# Left arrow: return to higher menu level +# Enter: activate menu items +# 'q': return to higher menu level or (at toplevel) quit the Brick UI + set -e set -x pushd .. stack build cardano-sl-script-runner cardano-sl-node cardano-sl-tools -export PATH=$(realpath .stack-work/install/x86_64-linux-nix/lts-12.17/8.4.4/bin/):$PATH +export PATH=$(realpath $(stack path --local-install-root)/bin):$PATH popd NAME=$1 diff --git a/script-runner/stack-test b/script-runner/stack-test index 5129d2f85fe..b84c514372a 100755 --- a/script-runner/stack-test +++ b/script-runner/stack-test @@ -2,12 +2,15 @@ # usage: ./stack-test test4.2 +# on Mac (and OS's with different `mktemp` versions) +# usage: ALT_MKTEMP=1 ./stack-test test4.2 + set -e set -x pushd .. stack build cardano-sl-script-runner cardano-sl-node cardano-sl-tools -export PATH=$(realpath .stack-work/install/x86_64-linux-nix/lts-12.17/8.4.4/bin/):$PATH +export PATH=$(realpath $(stack path --local-install-root)/bin):$PATH popd export SCRIPT=$1 @@ -17,7 +20,12 @@ LOGCFG=$(realpath ./log-config.yaml) TOPO=$(realpath ./topology-local.yaml) POLFILE=$(realpath ../scripts/policies/policy_script-runner.yaml) -T=$(mktemp -d -p . testrun-XXXXXX) +if [ -z "$ALT_MKTEMP" ]; then + T=$(mktemp -d -t . testrun-XXXXXX) +else + T=$(mktemp -d -p . testrun-XXXXXX) +fi + cd $T mkdir poc-state From 1dac017591bd0b4adef778567bb3a0fe18448e22 Mon Sep 17 00:00:00 2001 From: Michael Hueschen Date: Wed, 23 Jan 2019 20:29:53 -0500 Subject: [PATCH 6/8] [DEVOPS-1131] Fix merge errors & compiler complaints --- lib/src/Pos/Launcher/Configuration.hs | 1 + script-runner/common/BrickUI.hs | 6 +++--- script-runner/common/OrphanedLenses.hs | 2 +- script-runner/common/PocMode.hs | 7 ++----- 4 files changed, 7 insertions(+), 9 deletions(-) diff --git a/lib/src/Pos/Launcher/Configuration.hs b/lib/src/Pos/Launcher/Configuration.hs index 8800d030cc7..ad6f74fc568 100644 --- a/lib/src/Pos/Launcher/Configuration.hs +++ b/lib/src/Pos/Launcher/Configuration.hs @@ -31,6 +31,7 @@ module Pos.Launcher.Configuration , ccNode_L , ccWallet_L , ccReqNetMagic_L + , ccTxValRules_L , cfoFilePath_L , cfoKey_L diff --git a/script-runner/common/BrickUI.hs b/script-runner/common/BrickUI.hs index 95b2274a45e..4dc390e387f 100644 --- a/script-runner/common/BrickUI.hs +++ b/script-runner/common/BrickUI.hs @@ -19,7 +19,7 @@ import qualified Data.Text as T import qualified Data.Text.Lazy.Builder as T import qualified Data.Vector as V import Formatting -import Universum hiding (HashMap, list, on, state, when) +import Universum hiding (HashMap, list, on, state) import Brick (App (App, appAttrMap, appChooseCursor, appDraw, appHandleEvent, appStartEvent), BrickEvent (AppEvent, VtyEvent), EventM, Next, Widget, @@ -143,8 +143,8 @@ proposalUi state = do let renderProposal :: Either ConfirmedProposalState (UpId,ProposalState) -> Widget Name renderProposal (Left proposal) = renderUpdateProposalLabel (str "Confirmed: ") (cpsUpdateProposal proposal) - renderProposal (Right (upid, PSUndecided prop)) = renderUpdateProposalLabel (str "Undecided: ") (upsProposal prop) - renderProposal (Right (upid, PSDecided prop)) = renderUpdateProposalLabel (str "Decided: ") (upsProposal $ dpsUndecided prop) + renderProposal (Right (_upid, PSUndecided prop)) = renderUpdateProposalLabel (str "Undecided: ") (upsProposal prop) + renderProposal (Right (_upid, PSDecided prop)) = renderUpdateProposalLabel (str "Decided: ") (upsProposal $ dpsUndecided prop) let renderProposalState :: (UpId, ProposalState) -> Widget Name renderProposalState (upid, PSDecided prop) = do diff --git a/script-runner/common/OrphanedLenses.hs b/script-runner/common/OrphanedLenses.hs index 4cd2c557de9..82ac70b69e3 100644 --- a/script-runner/common/OrphanedLenses.hs +++ b/script-runner/common/OrphanedLenses.hs @@ -1,7 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-} -module OrphanedLenses where +module OrphanedLenses () where import Control.Lens (makeLensesWith) diff --git a/script-runner/common/PocMode.hs b/script-runner/common/PocMode.hs index f690a51449d..f2728b2f368 100644 --- a/script-runner/common/PocMode.hs +++ b/script-runner/common/PocMode.hs @@ -49,8 +49,6 @@ import Data.Default (Default (def)) import qualified Data.Map as Map import Prelude (show) -import BrickUITypes (CustomEvent) - import Pos.Chain.Block (HasSlogContext (slogContext), HasSlogGState (slogGState)) import Pos.Chain.Genesis as Genesis (Config) @@ -59,8 +57,7 @@ import Pos.Client.KeyStorage (MonadKeys (modifySecret), MonadKeysRead (getSecret), getSecretDefault, modifySecretDefault) import Pos.Context (HasNodeContext (nodeContext)) -import Pos.Core (SlotCount, SlotId) -import Pos.Core (HasPrimaryKey (primaryKey)) +import Pos.Core (HasPrimaryKey (primaryKey), SlotCount, SlotId) import Pos.Core.JsonLog (CanJsonLog (jsonLog)) import Pos.Core.Reporting (HasMisbehaviorMetrics (misbehaviorMetrics), MonadReporting (report)) @@ -263,6 +260,6 @@ instance MonadKeys PocMode where type instance MempoolExt PocMode = EmptyMempoolExt instance MonadTxpLocal PocMode where - txpNormalize pm = withReaderT _acRealModeContext . txNormalize pm + txpNormalize pm tvr = withReaderT _acRealModeContext . txNormalize pm tvr txpProcessTx genesisConfig txpConfig = withReaderT _acRealModeContext . txProcessTransaction genesisConfig txpConfig From 3adf0476a29d9fd3c8f6e17b3a933e0159570a46 Mon Sep 17 00:00:00 2001 From: Michael Hueschen Date: Wed, 30 Jan 2019 15:35:54 -0500 Subject: [PATCH 7/8] [DEVOPS-1131] Relocate generators & roundtrip tests --- chain/test/Test/Pos/Chain/Block/Gen.hs | 22 +++++-- chain/test/Test/Pos/Chain/Delegation/Gen.hs | 11 ++-- chain/test/Test/Pos/Chain/Ssc/Gen.hs | 16 +++-- chain/test/Test/Pos/Chain/Update/Gen.hs | 15 +++-- chain/test/Test/Pos/Chain/Update/Json.hs | 13 +++- crypto/test/Test/Pos/Crypto/Gen.hs | 1 + lib/test/Test/Pos/Launcher/Configuration.hs | 11 ++-- lib/test/Test/Pos/Launcher/Gen.hs | 70 ++++++++------------- 8 files changed, 86 insertions(+), 73 deletions(-) diff --git a/chain/test/Test/Pos/Chain/Block/Gen.hs b/chain/test/Test/Pos/Chain/Block/Gen.hs index 0ed26a79add..8e827bf2f6c 100644 --- a/chain/test/Test/Pos/Chain/Block/Gen.hs +++ b/chain/test/Test/Pos/Chain/Block/Gen.hs @@ -1,5 +1,6 @@ module Test.Pos.Chain.Block.Gen - ( genBlockBodyAttributes + ( genBlockConfiguration + , genBlockBodyAttributes , genBlockHeader , genBlockHeaderAttributes , genBlockSignature @@ -23,10 +24,11 @@ import Universum import Data.Coerce (coerce) import Hedgehog (Gen) import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range -import Pos.Chain.Block (BlockBodyAttributes, BlockHeader (..), - BlockHeaderAttributes, BlockSignature (..), - GenesisBlockHeader, GenesisBody (..), +import Pos.Chain.Block (BlockBodyAttributes, BlockConfiguration (..), + BlockHeader (..), BlockHeaderAttributes, + BlockSignature (..), GenesisBlockHeader, GenesisBody (..), GenesisConsensusData (..), GenesisProof (..), HeaderHash, MainBlockHeader, MainBody (..), MainConsensusData (..), MainExtraBodyData (..), MainExtraHeaderData (..), @@ -45,6 +47,18 @@ import Test.Pos.Core.Gen (genChainDifficulty, genEpochIndex, import Test.Pos.Crypto.Gen (genAbstractHash, genProxySignature, genPublicKey, genSecretKey, genSignature) + +genBlockConfiguration :: Gen BlockConfiguration +genBlockConfiguration = BlockConfiguration <$> Gen.int Range.constantBounded + <*> Gen.int Range.constantBounded + <*> Gen.int Range.constantBounded + <*> Gen.double (Range.constant 0 1) + <*> Gen.double (Range.constant 0 1) + <*> Gen.double (Range.constant 0 1) + <*> Gen.double (Range.constant 0 1) + <*> Gen.int Range.constantBounded + <*> (fromIntegral <$> Gen.int Range.constantBounded) + genBlockBodyAttributes :: Gen BlockBodyAttributes genBlockBodyAttributes = pure $ mkAttributes () diff --git a/chain/test/Test/Pos/Chain/Delegation/Gen.hs b/chain/test/Test/Pos/Chain/Delegation/Gen.hs index 76f548e2524..a642e85bace 100644 --- a/chain/test/Test/Pos/Chain/Delegation/Gen.hs +++ b/chain/test/Test/Pos/Chain/Delegation/Gen.hs @@ -1,5 +1,6 @@ module Test.Pos.Chain.Delegation.Gen - ( genDlgPayload + ( genDlgConfiguration + , genDlgPayload , genHeavyDlgIndex , genLightDlgIndices , genProxySKBlockInfo @@ -13,16 +14,18 @@ import Hedgehog (Gen) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import Pos.Chain.Delegation (DlgPayload (..), DlgUndo (..), - HeavyDlgIndex (..), LightDlgIndices (..), +import Pos.Chain.Delegation (DlgConfiguration (..), DlgPayload (..), + DlgUndo (..), HeavyDlgIndex (..), LightDlgIndices (..), ProxySKBlockInfo, ProxySKHeavy) import Pos.Crypto (ProtocolMagic, safeCreatePsk) - import Test.Pos.Core.Gen (genEpochIndex, genStakeholderId) import Test.Pos.Crypto.Gen (genPublicKey, genSafeSigner) import Test.Pos.Util.Gen (genHashSet) +genDlgConfiguration :: Gen DlgConfiguration +genDlgConfiguration = DlgConfiguration <$> (pure 500) <*> (pure 30) + genDlgPayload :: ProtocolMagic -> Gen DlgPayload genDlgPayload pm = UnsafeDlgPayload <$> Gen.list (Range.linear 0 5) (genProxySKHeavy pm) diff --git a/chain/test/Test/Pos/Chain/Ssc/Gen.hs b/chain/test/Test/Pos/Chain/Ssc/Gen.hs index 85042f07245..be4d55d1f42 100644 --- a/chain/test/Test/Pos/Chain/Ssc/Gen.hs +++ b/chain/test/Test/Pos/Chain/Ssc/Gen.hs @@ -1,5 +1,6 @@ module Test.Pos.Chain.Ssc.Gen - ( genAttackTarget + ( genSscConfiguration + , genAttackTarget , genCommitment , genCommitmentsMap , genCommitmentSignature @@ -30,11 +31,11 @@ import Pos.Binary.Class (asBinary) import Pos.Chain.Security (AttackTarget (..)) import Pos.Chain.Ssc (Commitment, CommitmentSignature, CommitmentsMap, InnerSharesMap, Opening, OpeningsMap, SharesDistribution, - SharesMap, SignedCommitment, SscPayload (..), SscProof, - VssCertificate (..), VssCertificatesHash, - VssCertificatesMap (..), mkCommitmentsMap, mkSscProof, - mkVssCertificate, mkVssCertificatesMap, - randCommitmentAndOpening) + SharesMap, SignedCommitment, SscConfiguration (..), + SscPayload (..), SscProof, VssCertificate (..), + VssCertificatesHash, VssCertificatesMap (..), + mkCommitmentsMap, mkSscProof, mkVssCertificate, + mkVssCertificatesMap, randCommitmentAndOpening) import Pos.Crypto (ProtocolMagic, deterministic, hash) import Test.Pos.Core.Gen (genEpochIndex, genStakeholderId, genWord16) @@ -42,6 +43,9 @@ import Test.Pos.Crypto.Gen (genDecShare, genPublicKey, genSecretKey, genSignature, genVssPublicKey) import Test.Pos.Util.Gen (genHashMap) +genSscConfiguration :: Gen SscConfiguration +genSscConfiguration = SscConfiguration <$> (pure 10) <*> (pure 3) <*> (pure False) + genCommitment :: Gen Commitment genCommitment = fst <$> genCommitmentOpening diff --git a/chain/test/Test/Pos/Chain/Update/Gen.hs b/chain/test/Test/Pos/Chain/Update/Gen.hs index 11097402bd6..7990dc8247c 100644 --- a/chain/test/Test/Pos/Chain/Update/Gen.hs +++ b/chain/test/Test/Pos/Chain/Update/Gen.hs @@ -1,5 +1,6 @@ module Test.Pos.Chain.Update.Gen - ( genApplicationName + ( genUpdateConfiguration + , genApplicationName , genBlockVersion , genBlockVersionData , genBlockVersionDataByTxFP @@ -38,10 +39,11 @@ import Pos.Chain.Update (ApplicationName (..), BlockVersion (..), ProposalState (..), SoftforkRule (..), SoftwareVersion (..), SystemTag (..), USUndo (..), UndecidedProposalState (..), UpAttributes, UpId, - UpdateData (..), UpdatePayload (..), UpdateProof, - UpdateProposal (..), UpdateProposalToSign (..), - UpdateProposals, UpdateVote (..), UpsExtra (..), VoteId, - VoteState (..), maybeToPrev, mkUpdateVote) + UpdateConfiguration (..), UpdateData (..), + UpdatePayload (..), UpdateProof, UpdateProposal (..), + UpdateProposalToSign (..), UpdateProposals, + UpdateVote (..), UpsExtra (..), VoteId, VoteState (..), + maybeToPrev, mkUpdateVote) import Pos.Core (SlotCount, TxFeePolicy) import Pos.Core.Attributes (mkAttributes) import Pos.Crypto (ProtocolMagic) @@ -56,6 +58,9 @@ import Test.Pos.Crypto.Gen (genAbstractHash, genPublicKey, import Test.Pos.Util.Gen (genHashMap, genHashSet) +genUpdateConfiguration :: Gen UpdateConfiguration +genUpdateConfiguration = UpdateConfiguration <$> genApplicationName <*> genBlockVersion <*> (pure 1) <*> genSystemTag + genApplicationName :: Gen ApplicationName genApplicationName = ApplicationName <$> Gen.text (Range.constant 0 10) Gen.alphaNum diff --git a/chain/test/Test/Pos/Chain/Update/Json.hs b/chain/test/Test/Pos/Chain/Update/Json.hs index f7ca4c6a51f..7b961adb3a3 100644 --- a/chain/test/Test/Pos/Chain/Update/Json.hs +++ b/chain/test/Test/Pos/Chain/Update/Json.hs @@ -11,11 +11,12 @@ import qualified Hedgehog as H import Test.Pos.Chain.Update.Gen (genApplicationName, genBlockVersionData, genSoftforkRule, genSoftwareVersion, - genSystemTag) + genSystemTag, genUpdateConfiguration) import Test.Pos.Util.Golden (eachOf) -import Test.Pos.Util.Tripping (discoverRoundTrip, +import Test.Pos.Util.Tripping (discoverRoundTrip, roundTripsAesonShow, roundTripsAesonYamlBuildable) + -------------------------------------------------------------------------------- -- BlockVersionData -------------------------------------------------------------------------------- @@ -55,6 +56,14 @@ roundTripSystemTag :: Property roundTripSystemTag = eachOf 1000 genSystemTag roundTripsAesonYamlBuildable +-------------------------------------------------------------------------------- +-- UpdateConfiguration +-------------------------------------------------------------------------------- + +roundTripUpdateConfiguration :: Property +roundTripUpdateConfiguration = + eachOf 1000 genUpdateConfiguration roundTripsAesonShow + -------------------------------------------------------------------------------- -- Main Testing Function -------------------------------------------------------------------------------- diff --git a/crypto/test/Test/Pos/Crypto/Gen.hs b/crypto/test/Test/Pos/Crypto/Gen.hs index 23cbae619b4..26406f6fd67 100644 --- a/crypto/test/Test/Pos/Crypto/Gen.hs +++ b/crypto/test/Test/Pos/Crypto/Gen.hs @@ -3,6 +3,7 @@ module Test.Pos.Crypto.Gen -- Protocol Magic Generator genProtocolMagic , genProtocolMagicId + , genRequiresNetworkMagic -- Sign Tag Generator , genSignTag diff --git a/lib/test/Test/Pos/Launcher/Configuration.hs b/lib/test/Test/Pos/Launcher/Configuration.hs index 144ead6d8d6..bba341dd5b2 100644 --- a/lib/test/Test/Pos/Launcher/Configuration.hs +++ b/lib/test/Test/Pos/Launcher/Configuration.hs @@ -4,18 +4,15 @@ import Hedgehog (Property) import qualified Hedgehog as H import Universum -import Test.Pos.Launcher.Gen (genConfiguration, genUpdate) +import Test.Pos.Core.ExampleHelpers (feedPM) +import Test.Pos.Launcher.Gen (genConfiguration) import Test.Pos.Util.Golden (eachOf) import Test.Pos.Util.Tripping (discoverRoundTrip, roundTripsAesonShow) + roundTripConfiguration :: Property roundTripConfiguration = - eachOf 1000 genConfiguration roundTripsAesonShow - --- move roundTripUpdateConfiguration to chain project -roundTripUpdateConfiguration :: Property -roundTripUpdateConfiguration = - eachOf 1000 genUpdate roundTripsAesonShow + eachOf 1000 (feedPM genConfiguration) roundTripsAesonShow tests :: IO Bool tests = H.checkParallel $$discoverRoundTrip diff --git a/lib/test/Test/Pos/Launcher/Gen.hs b/lib/test/Test/Pos/Launcher/Gen.hs index 0896e34e1e9..1dd2d214216 100644 --- a/lib/test/Test/Pos/Launcher/Gen.hs +++ b/lib/test/Test/Pos/Launcher/Gen.hs @@ -6,64 +6,44 @@ import qualified Hedgehog.Range as Range import Universum import Ntp.Client (NtpConfiguration (NtpConfiguration)) -import Pos.Chain.Block (BlockConfiguration (BlockConfiguration)) -import Pos.Chain.Delegation (DlgConfiguration (DlgConfiguration)) -import Pos.Chain.Genesis (StaticConfig (GCSrc)) -import Pos.Chain.Ssc (SscConfiguration (SscConfiguration)) -import Pos.Chain.Txp (TxpConfiguration (TxpConfiguration)) -import Pos.Chain.Update (UpdateConfiguration (UpdateConfiguration)) import Pos.Configuration (NodeConfiguration (NodeConfiguration)) -import Pos.Crypto.Configuration - (RequiresNetworkMagic (RequiresMagic, RequiresNoMagic)) -import Pos.Crypto.Hashing (unsafeMkAbstractHash) +import Pos.Crypto (ProtocolMagic) import Pos.Launcher.Configuration (Configuration (Configuration), ThrottleSettings (ThrottleSettings), WalletConfiguration (WalletConfiguration)) -import Test.Pos.Chain.Txp.Gen (genTxValidationRulesConfig) -import Test.Pos.Chain.Update.Gen (genApplicationName, genBlockVersion, - genSystemTag) +import Test.Pos.Chain.Block.Gen (genBlockConfiguration) +import Test.Pos.Chain.Delegation.Gen (genDlgConfiguration) +import Test.Pos.Chain.Genesis.Gen (genStaticConfig) +import Test.Pos.Chain.Ssc.Gen (genSscConfiguration) +import Test.Pos.Chain.Txp.Gen (genTxValidationRulesConfig, + genTxpConfiguration) +import Test.Pos.Chain.Update.Gen (genUpdateConfiguration) +import Test.Pos.Crypto.Gen (genRequiresNetworkMagic) --- TODO, move a lot of the chain specific generators into cardano-sl-chain -genConfiguration :: Gen Configuration -genConfiguration = Configuration <$> genGenesis <*> genNtp <*> genUpdate <*> genSsc <*> genDlg <*> genTxp <*> genBlock <*> genNode <*> genWallet <*> genReqNetMagic <*> genTxValidationRulesConfig +genConfiguration :: ProtocolMagic -> Gen Configuration +genConfiguration pm = Configuration <$> genStaticConfig pm <*> genNtpConfiguration <*> genUpdateConfiguration <*> genSscConfiguration <*> genDlgConfiguration <*> genTxpConfiguration <*> genBlockConfiguration <*> genNode <*> genWallet <*> genRequiresNetworkMagic <*> genTxValidationRulesConfig -genGenesis :: Gen StaticConfig --- TODO, GCSpec not covered -genGenesis = GCSrc <$> genstring <*> (pure $ unsafeMkAbstractHash mempty) +genNtpConfiguration :: Gen NtpConfiguration +genNtpConfiguration = NtpConfiguration <$> Gen.list (Range.constant 1 4) genString <*> Gen.integral (Range.constant 1 1000) <*> Gen.integral (Range.constant 1 1000) -genNtp :: Gen NtpConfiguration -genNtp = NtpConfiguration <$> Gen.list (Range.constant 1 4) genstring <*> Gen.integral (Range.constant 1 1000) <*> Gen.integral (Range.constant 1 1000) - -genstring :: Gen String -genstring = Gen.string (Range.constant 1 10) Gen.alphaNum - -genUpdate :: Gen UpdateConfiguration -genUpdate = UpdateConfiguration <$> genApplicationName <*> genBlockVersion <*> (pure 1) <*> genSystemTag - -genSsc :: Gen SscConfiguration -genSsc = SscConfiguration <$> (pure 10) <*> (pure 3) <*> (pure False) - -genDlg :: Gen DlgConfiguration -genDlg = DlgConfiguration <$> (pure 500) <*> (pure 30) - -genTxp :: Gen TxpConfiguration -genTxp = TxpConfiguration <$> (pure 200) <*> (pure mempty) - -genBlock :: Gen BlockConfiguration -genBlock = pure $ BlockConfiguration 1 2 3 4 5 6 7 8 9 +genString :: Gen String +genString = Gen.string (Range.constant 1 10) Gen.alphaNum genNode :: Gen NodeConfiguration -genNode = pure $ NodeConfiguration 1 2 3 4 True False True +genNode = NodeConfiguration <$> Gen.int Range.constantBounded + <*> Gen.int Range.constantBounded + <*> Gen.int Range.constantBounded + <*> Gen.int Range.constantBounded + <*> Gen.bool + <*> Gen.bool + <*> Gen.bool genWallet :: Gen WalletConfiguration genWallet = WalletConfiguration <$> Gen.maybe genThrottleSettings genThrottleSettings :: Gen ThrottleSettings -genThrottleSettings = ThrottleSettings <$> genword64 <*> genword64 <*> genword64 - -genword64 :: Gen Word64 -genword64 = Gen.word64 $ Range.constant 0 1000 +genThrottleSettings = ThrottleSettings <$> genWord64 <*> genWord64 <*> genWord64 -genReqNetMagic :: Gen RequiresNetworkMagic -genReqNetMagic = Gen.choice [ pure RequiresMagic, pure RequiresNoMagic ] +genWord64 :: Gen Word64 +genWord64 = Gen.word64 $ Range.constant 0 1000 From 269b1601a830651d1d38436400e6613fdfc3abe3 Mon Sep 17 00:00:00 2001 From: Michael Hueschen Date: Thu, 31 Jan 2019 10:56:55 -0500 Subject: [PATCH 8/8] [DEVOPS-1131] Use JSON+YAML roundtrip functions --- chain/test/Test/Pos/Chain/Update/Json.hs | 6 +++--- lib/test/Test/Pos/Launcher/Configuration.hs | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/chain/test/Test/Pos/Chain/Update/Json.hs b/chain/test/Test/Pos/Chain/Update/Json.hs index 7b961adb3a3..58916304a06 100644 --- a/chain/test/Test/Pos/Chain/Update/Json.hs +++ b/chain/test/Test/Pos/Chain/Update/Json.hs @@ -13,8 +13,8 @@ import Test.Pos.Chain.Update.Gen (genApplicationName, genBlockVersionData, genSoftforkRule, genSoftwareVersion, genSystemTag, genUpdateConfiguration) import Test.Pos.Util.Golden (eachOf) -import Test.Pos.Util.Tripping (discoverRoundTrip, roundTripsAesonShow, - roundTripsAesonYamlBuildable) +import Test.Pos.Util.Tripping (discoverRoundTrip, + roundTripsAesonYamlBuildable, roundTripsAesonYamlShow) -------------------------------------------------------------------------------- @@ -62,7 +62,7 @@ roundTripSystemTag = roundTripUpdateConfiguration :: Property roundTripUpdateConfiguration = - eachOf 1000 genUpdateConfiguration roundTripsAesonShow + roundTripsAesonYamlShow 1000 genUpdateConfiguration -------------------------------------------------------------------------------- -- Main Testing Function diff --git a/lib/test/Test/Pos/Launcher/Configuration.hs b/lib/test/Test/Pos/Launcher/Configuration.hs index bba341dd5b2..5d38a0de608 100644 --- a/lib/test/Test/Pos/Launcher/Configuration.hs +++ b/lib/test/Test/Pos/Launcher/Configuration.hs @@ -6,13 +6,13 @@ import Universum import Test.Pos.Core.ExampleHelpers (feedPM) import Test.Pos.Launcher.Gen (genConfiguration) -import Test.Pos.Util.Golden (eachOf) -import Test.Pos.Util.Tripping (discoverRoundTrip, roundTripsAesonShow) +import Test.Pos.Util.Tripping (discoverRoundTrip, + roundTripsAesonYamlShow) roundTripConfiguration :: Property roundTripConfiguration = - eachOf 1000 (feedPM genConfiguration) roundTripsAesonShow + roundTripsAesonYamlShow 1000 (feedPM genConfiguration) tests :: IO Bool tests = H.checkParallel $$discoverRoundTrip