From 992820f9ad2fc6b44e26668691896f3caca36d02 Mon Sep 17 00:00:00 2001 From: paolino Date: Sat, 20 Apr 2024 08:16:33 +0000 Subject: [PATCH 1/2] Change FileOf definition --- .../cardano-wallet-benchmarks.cabal | 2 + lib/benchmarks/exe/latency-bench.hs | 38 ++-- .../cardano-wallet-integration.cabal | 2 + .../Test/Integration/Framework/Logging.hs | 28 ++- .../Test/Integration/Framework/Setup.hs | 75 ++++---- .../scenarios/Test/Integration/Run.hs | 13 +- .../Cardano/Wallet/Launch/Cluster/Cluster.hs | 20 +- .../Wallet/Launch/Cluster/ClusterEra.hs | 41 +++-- .../Cardano/Wallet/Launch/Cluster/ClusterM.hs | 15 +- .../Cardano/Wallet/Launch/Cluster/Config.hs | 15 +- .../Wallet/Launch/Cluster/ConfiguredPool.hs | 173 ++++++++++-------- .../Cardano/Wallet/Launch/Cluster/Faucet.hs | 61 +++--- .../Cardano/Wallet/Launch/Cluster/FileOf.hs | 71 ++++++- .../Wallet/Launch/Cluster/GenesisFiles.hs | 53 +++--- .../Wallet/Launch/Cluster/KeyRegistration.hs | 35 ++-- .../Cardano/Wallet/Launch/Cluster/Logging.hs | 70 ++++--- .../Launch/Cluster/MonetaryPolicyScript.hs | 37 ++-- .../Launch/Cluster/Node/GenNodeConfig.hs | 54 +++--- .../Wallet/Launch/Cluster/Node/GenTopology.hs | 22 ++- .../Wallet/Launch/Cluster/Node/NodeParams.hs | 13 +- .../Wallet/Launch/Cluster/Node/Relay.hs | 33 ++-- .../Launch/Cluster/PoolMetadataServer.hs | 32 ++-- .../Wallet/Launch/Cluster/SinkAddress.hs | 24 ++- .../Launch/Cluster/StakeCertificates.hs | 30 +-- .../lib/Cardano/Wallet/Launch/Cluster/Tx.hs | 28 ++- .../lib/Cardano/Wallet/LocalCluster.hs | 32 +++- lib/local-cluster/local-cluster.cabal | 1 + lib/unit/cardano-wallet-unit.cabal | 1 + .../Cardano/Wallet/Shelley/NetworkSpec.hs | 159 +++++++++------- 29 files changed, 713 insertions(+), 465 deletions(-) diff --git a/lib/benchmarks/cardano-wallet-benchmarks.cabal b/lib/benchmarks/cardano-wallet-benchmarks.cabal index 7c0998560a4..1969ffb57f9 100644 --- a/lib/benchmarks/cardano-wallet-benchmarks.cabal +++ b/lib/benchmarks/cardano-wallet-benchmarks.cabal @@ -128,6 +128,7 @@ benchmark latency , cardano-wallet-application-extras , cardano-wallet-benchmarks , cardano-wallet-integration:framework + , cardano-wallet-launcher , cardano-wallet-network-layer , cardano-wallet-primitive , directory @@ -144,6 +145,7 @@ benchmark latency , local-cluster , mtl , optparse-applicative + , pathtype , resourcet , servant-client , temporary-extra diff --git a/lib/benchmarks/exe/latency-bench.hs b/lib/benchmarks/exe/latency-bench.hs index 16a7c398117..74462cde225 100644 --- a/lib/benchmarks/exe/latency-bench.hs +++ b/lib/benchmarks/exe/latency-bench.hs @@ -7,7 +7,6 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Main where @@ -84,13 +83,18 @@ import Cardano.Wallet.Faucet import Cardano.Wallet.Launch.Cluster ( Config (..) , FaucetFunds (..) - , FileOf (..) , RunningNode (..) , defaultPoolConfigs , testnetMagicToNatural , withCluster , withFaucet ) +import Cardano.Wallet.Launch.Cluster.FileOf + ( DirOf (..) + , mkRelDirOf + , newAbsolutizer + , toFilePath + ) import Cardano.Wallet.LocalCluster ( clusterConfigsDirParser ) @@ -199,13 +203,15 @@ import System.Directory import System.Environment.Extended ( isEnvSet ) -import System.FilePath - ( () - ) import System.IO.Temp.Extra ( SkipCleanup (..) , withSystemTempDir ) +import System.Path + ( absDir + , relDir + , () + ) import Test.Integration.Framework.DSL ( Context (..) , eventually @@ -638,19 +644,22 @@ withShelleyServer tracers action = withFaucet $ \faucetClientEnv -> do withServer cfgTestnetMagic faucetFunds setupAction = do skipCleanup <- SkipCleanup <$> isEnvSet "NO_CLEANUP" withSystemTempDir stdoutTextTracer "latency" skipCleanup $ \dir -> do - let db = dir "wallets" - createDirectory db + let testDir = absDir dir + db = testDir relDir "wallets" + createDirectory $ toFilePath db CommandLineOptions{clusterConfigsDir} <- parseCommandLineOptions clusterEra <- Cluster.clusterEraFromEnv cfgNodeLogging <- Cluster.logFileConfigFromEnv - (Just (Cluster.clusterEraToString clusterEra)) + $ Just + $ mkRelDirOf + $ Cluster.clusterEraToString clusterEra let clusterConfig = Cluster.Config { cfgStakePools = pure (NE.head defaultPoolConfigs) , cfgLastHardFork = clusterEra , cfgNodeLogging - , cfgClusterDir = FileOf @"cluster" dir + , cfgClusterDir = DirOf testDir , cfgClusterConfigs = clusterConfigsDir , cfgTestnetMagic , cfgShelleyGenesisMods = @@ -678,7 +687,7 @@ withShelleyServer tracers action = withFaucet $ \faucetClientEnv -> do (NTestnet . fromIntegral $ testnetMagicToNatural testnetMagic) [] -- pool certificates tracers - (Just db) + (Just $ toFilePath db) Nothing -- db decorator "127.0.0.1" (ListenOnPort 8_090) @@ -703,12 +712,15 @@ era = maxBound -- Command line options -------------------------------------------------------- newtype CommandLineOptions = CommandLineOptions - {clusterConfigsDir :: FileOf "cluster-configs"} + {clusterConfigsDir :: DirOf "cluster-configs"} deriving stock (Show) parseCommandLineOptions :: IO CommandLineOptions -parseCommandLineOptions = +parseCommandLineOptions = do + absolutizer <- newAbsolutizer O.execParser $ O.info - (fmap CommandLineOptions clusterConfigsDirParser <**> O.helper) + (fmap CommandLineOptions (clusterConfigsDirParser absolutizer) + <**> O.helper + ) (O.progDesc "Cardano Wallet's Latency Benchmark") diff --git a/lib/integration/cardano-wallet-integration.cabal b/lib/integration/cardano-wallet-integration.cabal index a6be17bd2c4..a7e748412fb 100644 --- a/lib/integration/cardano-wallet-integration.cabal +++ b/lib/integration/cardano-wallet-integration.cabal @@ -92,6 +92,7 @@ library framework , network-uri , resourcet , retry + , pathtype , serialise , servant-client , string-interpolate @@ -155,6 +156,7 @@ library scenarios , lens-aeson , local-cluster , memory + , pathtype , pretty-simple , resourcet , servant-client diff --git a/lib/integration/framework/Test/Integration/Framework/Logging.hs b/lib/integration/framework/Test/Integration/Framework/Logging.hs index c63cdb2c833..ce40031854f 100644 --- a/lib/integration/framework/Test/Integration/Framework/Logging.hs +++ b/lib/integration/framework/Test/Integration/Framework/Logging.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} module Test.Integration.Framework.Logging @@ -40,6 +41,11 @@ import Cardano.Wallet.Launch.Cluster , testMinSeverityFromEnv , walletMinSeverityFromEnv ) +import Cardano.Wallet.Launch.Cluster.FileOf + ( DirOf (..) + , mkRelDirOf + , toFilePath + ) import Cardano.Wallet.Shelley ( Tracers , setupTracers @@ -52,9 +58,6 @@ import Control.Tracer ( Tracer (..) , contramap ) -import Data.Maybe - ( fromMaybe - ) import Data.Text ( Text ) @@ -64,8 +67,9 @@ import Data.Text.Class import Network.URI ( URI ) -import System.FilePath - ( () +import System.Path + ( relFile + , () ) import Test.Integration.Framework.Context ( PoolGarbageCollectionEvent (..) @@ -130,21 +134,25 @@ instance HasSeverityAnnotation TestsLog where | otherwise -> Warning withTracers - :: FilePath + :: DirOf "cluster" -> ((Tracer IO TestsLog, Tracers IO) -> IO a) -> IO a withTracers testDir action = do let getLogOutputs getMinSev name = do minSev <- getMinSev eraStr <- clusterEraToString <$> clusterEraFromEnv - logDir <- fromMaybe testDir <$> testLogDirFromEnv (Just eraStr) + mLogDir <- testLogDirFromEnv $ Just $ mkRelDirOf eraStr + let logDir = case mLogDir of + Just d -> absDirOf d + Nothing -> absDirOf testDir -- re-purpose the "cluster" dir pure - [ LogToFile (logDir name) (min minSev Info) + [ LogToFile (toFilePath $ logDir name) (min minSev Info) , LogToStdStreams minSev ] - walletLogOutputs <- getLogOutputs walletMinSeverityFromEnv "wallet.log" - testLogOutputs <- getLogOutputs testMinSeverityFromEnv "test.log" + walletLogOutputs <- getLogOutputs walletMinSeverityFromEnv + $ relFile "wallet.log" + testLogOutputs <- getLogOutputs testMinSeverityFromEnv $ relFile "test.log" withLogging walletLogOutputs $ \(sb, (cfg, walTr)) -> do ekgEnabled >>= flip when (EKG.plugin cfg walTr sb >>= loadPlugin sb) diff --git a/lib/integration/framework/Test/Integration/Framework/Setup.hs b/lib/integration/framework/Test/Integration/Framework/Setup.hs index 28964ea5c50..dd6b172ca6b 100644 --- a/lib/integration/framework/Test/Integration/Framework/Setup.hs +++ b/lib/integration/framework/Test/Integration/Framework/Setup.hs @@ -74,6 +74,10 @@ import Cardano.Wallet.Launch.Cluster import Cardano.Wallet.Launch.Cluster.ClusterEra ( nodeOutputFileFromEnv ) +import Cardano.Wallet.Launch.Cluster.FileOf + ( DirOf (..) + , toFilePath + ) import Cardano.Wallet.Network.Implementation.Ouroboros ( tunedForMainnetPipeliningStrategy ) @@ -167,13 +171,16 @@ import System.Environment.Extended import System.Exit ( ExitCode ) -import System.FilePath - ( () - ) import System.IO.Temp.Extra ( SkipCleanup (..) , withSystemTempDir ) +import System.Path + ( absDir + , relDir + , relFile + , () + ) import Test.Integration.Framework.Context ( Context (..) , PoolGarbageCollectionEvent (..) @@ -217,7 +224,7 @@ import qualified Data.Text as T -- | Do all the program setup required for integration tests, create a temporary -- directory, and pass this info to the main hspec action. -withTestsSetup :: (FilePath -> (Tracer IO TestsLog, Tracers IO) -> IO a) -> IO a +withTestsSetup :: (DirOf "cluster" -> (Tracer IO TestsLog, Tracers IO) -> IO a) -> IO a withTestsSetup action = do -- Handle SIGTERM properly installSignalHandlersNoLogging @@ -235,8 +242,9 @@ withTestsSetup action = do -- This temporary directory will contain logs, and all other data -- produced by the integration tests. withSystemTempDir stdoutTextTracer "test" skipCleanup - $ \testDir -> - withTracers testDir $ action testDir + $ \testDir -> do + let clusterDir = DirOf $ absDir testDir + withTracers clusterDir $ action clusterDir mkFaucetFunds :: Cluster.TestnetMagic -> FaucetM FaucetFunds mkFaucetFunds testnetMagic = do @@ -275,11 +283,11 @@ mkFaucetFunds testnetMagic = do data TestingCtx = TestingCtx { testnetMagic :: Cluster.TestnetMagic - , testDir :: FilePath + , testDir :: DirOf "cluster" , tr :: Tracer IO TestsLog , tracers :: Tracers IO , localClusterEra :: ClusterEra - , testDataDir :: FileOf "test-data" + , testDataDir :: DirOf "test-data" } -- A decorator for the pool database that records all calls to the @@ -309,7 +317,7 @@ recordPoolGarbageCollectionEvents TestingCtx{..} eventsRef = withServer :: TestingCtx - -> FileOf "cluster-configs" + -> DirOf "cluster-configs" -> FaucetFunds -> Pool.DBDecorator IO -> Maybe (FileOf "node-output") @@ -330,13 +338,13 @@ withServer bracketTracer' tr "withServer" $ do let tr' = contramap MsgCluster tr era <- clusterEraFromEnv - withSMASH tr' testDir $ \smashUrl -> do + withSMASH tr' (toFilePath . absDirOf $ testDir) $ \smashUrl -> do let clusterConfig = Cluster.Config { cfgStakePools = Cluster.defaultPoolConfigs , cfgLastHardFork = era , cfgNodeLogging = LogFileConfig Info Nothing Info - , cfgClusterDir = FileOf @"cluster" testDir + , cfgClusterDir = testDir , cfgClusterConfigs = clusterConfigs , cfgTestnetMagic = testnetMagic , cfgShelleyGenesisMods = [] @@ -362,28 +370,29 @@ onClusterStart (RunningNode nodeConnection genesisData vData) = do let (networkParameters, block0, genesisPools) = fromGenesisData genesisData - let db = testDir "wallets" - createDirectory db + let db = absDirOf testDir relDir "wallets" + createDirectory $ toFilePath db listen <- walletListenFromEnv envFromText - let testMetadata = pathOf testDataDir "token-metadata.json" - withMetadataServer (queryServerStatic testMetadata) $ \tokenMetaUrl -> do - serveWallet - (NodeSource nodeConnection vData (SyncTolerance 10)) - networkParameters - tunedForMainnetPipeliningStrategy - (NTestnet (fromIntegral (sgNetworkMagic genesisData))) - genesisPools - tracers - (Just db) - (Just dbDecorator) - "127.0.0.1" - listen - Nothing - Nothing - (Just tokenMetaUrl) - block0 - (callback nodeConnection networkParameters) - `withException` (traceWith tr . MsgServerError) + let testMetadata = absDirOf testDataDir relFile "token-metadata.json" + withMetadataServer (queryServerStatic $ toFilePath testMetadata) + $ \tokenMetaUrl -> do + serveWallet + (NodeSource nodeConnection vData (SyncTolerance 10)) + networkParameters + tunedForMainnetPipeliningStrategy + (NTestnet (fromIntegral (sgNetworkMagic genesisData))) + genesisPools + tracers + (Just $ toFilePath db) + (Just dbDecorator) + "127.0.0.1" + listen + Nothing + Nothing + (Just tokenMetaUrl) + block0 + (callback nodeConnection networkParameters) + `withException` (traceWith tr . MsgServerError) -- threadDelay $ 3 * 60 * 1_000_000 -- Wait 3 minutes for the node to start -- exitSuccess @@ -446,7 +455,7 @@ setupContext { cfgStakePools = error "cfgStakePools: unused" , cfgLastHardFork = localClusterEra , cfgNodeLogging = error "cfgNodeLogging: unused" - , cfgClusterDir = FileOf @"cluster" testDir + , cfgClusterDir = testDir , cfgClusterConfigs = clusterConfigs , cfgTestnetMagic = testnetMagic , cfgShelleyGenesisMods = [] diff --git a/lib/integration/scenarios/Test/Integration/Run.hs b/lib/integration/scenarios/Test/Integration/Run.hs index 2610cc2bdd3..4771c918b64 100644 --- a/lib/integration/scenarios/Test/Integration/Run.hs +++ b/lib/integration/scenarios/Test/Integration/Run.hs @@ -21,6 +21,10 @@ import Cardano.Wallet.Launch.Cluster.ClusterEra ( ignoreInBabbage , ignoreInConway ) +import Cardano.Wallet.Launch.Cluster.FileOf + ( DirOf (..) + , absolutize + ) import Cardano.Wallet.Primitive.NetworkId ( NetworkDiscriminant (..) ) @@ -36,6 +40,10 @@ import GHC.TypeNats import System.Environment ( lookupEnv ) +import System.Path + ( absDir + , absRel + ) import Test.Hspec ( mapSubject ) @@ -97,9 +105,10 @@ main = withTestsSetup $ \testDir (tr, tracers) -> do _noConway = ignoreInConway localClusterEra _noBabbage = ignoreInBabbage localClusterEra testnetMagic = Cluster.TestnetMagic (natVal (Proxy @netId)) - testDataDir <- - FileOf . fromMaybe "." + testDataDir <- do + dir <- fromMaybe "." <$> lookupEnv "CARDANO_WALLET_TEST_DATA" + DirOf <$> absolutize (absRel dir) let testingCtx = TestingCtx{..} hspecMain $ do describe "No backend required" diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Cluster.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Cluster.hs index bd6abbf7377..d8917ba81d5 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Cluster.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Cluster.hs @@ -41,7 +41,7 @@ import Cardano.Wallet.Launch.Cluster.Faucet , sendFaucetAssetsTo ) import Cardano.Wallet.Launch.Cluster.FileOf - ( FileOf (..) + ( DirOf (..) , changeFileOf ) import Cardano.Wallet.Launch.Cluster.GenesisFiles @@ -111,12 +111,12 @@ import Data.List import Data.List.NonEmpty ( NonEmpty ((:|)) ) -import System.Directory - ( createDirectoryIfMissing - ) import System.Exit ( ExitCode (..) ) +import System.Path.Directory + ( createDirectoryIfMissing + ) import UnliftIO.Async ( async , link @@ -172,11 +172,11 @@ withCluster withCluster config@Config{..} faucetFunds onClusterStart = runClusterM config $ bracketTracer' "withCluster" $ do - let clusterDir = pathOf cfgClusterDir + let clusterDir = absDirOf cfgClusterDir traceClusterLog $ MsgHardFork cfgLastHardFork withPoolMetadataServer $ \metadataServer -> do liftIO $ createDirectoryIfMissing True clusterDir - traceClusterLog $ MsgStartingCluster clusterDir + traceClusterLog $ MsgStartingCluster cfgClusterDir liftIO resetGlobals configuredPools <- configurePools metadataServer cfgStakePools @@ -209,7 +209,7 @@ withCluster config@Config{..} faucetFunds onClusterStart = runClusterM config cfgLastHardFork pool0port cfgNodeLogging - nodeOutputFile + cfgNodeOutputFile liftIO $ operatePool pool0 pool0Cfg $ \runningPool0 -> runClusterM config $ do extraClusterSetupUsingNode configuredPools runningPool0 @@ -227,7 +227,8 @@ withCluster config@Config{..} faucetFunds onClusterStart = runClusterM config , extraLogDir = Nothing , minSeverityFile = Info } - , nodeParamsOutputFile = nodeOutputFile + , nodeParamsOutputFile + = cfgNodeOutputFile } launchPools others @@ -241,7 +242,6 @@ withCluster config@Config{..} faucetFunds onClusterStart = runClusterM config where FaucetFunds pureAdaFunds maryAllegraFunds massiveWalletFunds = faucetFunds - nodeOutputFile = pathOf <$> cfgNodeOutputFile -- Important cluster setup to run without rollbacks extraClusterSetupUsingNode :: NonEmpty ConfiguredPool -> RunningNode -> ClusterM () @@ -315,7 +315,7 @@ withCluster config@Config{..} faucetFunds onClusterStart = runClusterM config cfgLastHardFork (port, peers) cfgNodeLogging - nodeOutputFile + cfgNodeOutputFile asyncs <- forM (zip (NE.toList configuredPools) ports) $ \(configuredPool, (port, peers)) -> do async $ handle onException $ do diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/ClusterEra.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/ClusterEra.hs index 714b227720b..8807994b5fe 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/ClusterEra.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/ClusterEra.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeApplications #-} module Cardano.Wallet.Launch.Cluster.ClusterEra ( ClusterEra (..) @@ -17,25 +16,23 @@ where import Prelude import Cardano.Wallet.Launch.Cluster.FileOf - ( FileOf (..) + ( DirOf (..) + , FileOf (..) + , absolutize ) import Data.Char ( toLower ) -import Data.Functor - ( (<&>) - ) -import Data.Maybe - ( fromMaybe - ) import System.Environment.Extended ( lookupEnvNonEmpty ) import System.Exit ( die ) -import System.FilePath - ( () +import System.Path + ( absRel + , relDir + , () ) data ClusterEra @@ -69,16 +66,24 @@ clusterEraFromEnv = do "conway" -> pure ConwayHardFork _ -> die $ var ++ ": unknown era" -localClusterConfigsFromEnv :: IO (FileOf "cluster-configs") -localClusterConfigsFromEnv = - lookupEnvNonEmpty "LOCAL_CLUSTER_CONFIGS" - <&> FileOf @"cluster-configs" - . fromMaybe - (".." "local-cluster" "test" "data" "cluster-configs") +localClusterConfigsFromEnv :: IO (DirOf "cluster-configs") +localClusterConfigsFromEnv = do + mConfigsPath <- lookupEnvNonEmpty "LOCAL_CLUSTER_CONFIGS" + let configPath = case mConfigsPath of + Just path -> absRel path + Nothing -> + absRel ".." + relDir "local-cluster" + relDir "test" + relDir "data" + relDir "cluster-configs" + DirOf <$> absolutize configPath nodeOutputFileFromEnv :: IO (Maybe (FileOf "node-output")) -nodeOutputFileFromEnv = fmap FileOf - <$> lookupEnvNonEmpty "LOCAL_CLUSTER_NODE_OUTPUT_FILE" +nodeOutputFileFromEnv = do + mNodeOutput <- fmap absRel + <$> lookupEnvNonEmpty "LOCAL_CLUSTER_NODE_OUTPUT_FILE" + fmap FileOf <$> absolutize `traverse` mNodeOutput clusterEraToString :: ClusterEra -> String clusterEraToString = \case diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/ClusterM.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/ClusterM.hs index 88b12a4e819..0c9fcccca51 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/ClusterM.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/ClusterM.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} @@ -21,10 +22,9 @@ import Cardano.BM.Extra ) import Cardano.Wallet.Launch.Cluster.Config ( Config (..) - , NodePathSegment (..) ) import Cardano.Wallet.Launch.Cluster.FileOf - ( FileOf (..) + ( DirOf (..) ) import Cardano.Wallet.Launch.Cluster.Logging ( ClusterLog (..) @@ -45,8 +45,9 @@ import Control.Tracer import Data.Text ( Text ) -import System.FilePath - ( () +import System.Path + ( RelDir + , () ) newtype ClusterM a = ClusterM @@ -83,7 +84,7 @@ bracketTracer' name f = do $ bracketTracer (contramap (MsgBracket name) cfgTracer) $ withConfig f -askNodeDir :: NodePathSegment -> ClusterM FilePath -askNodeDir (NodePathSegment nodeSegment) = do +askNodeDir :: RelDir -> ClusterM (DirOf "node") +askNodeDir nodeSegment = do Config{..} <- ask - pure $ pathOf cfgClusterDir nodeSegment + pure $ DirOf $ absDirOf cfgClusterDir nodeSegment diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Config.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Config.hs index 6d08545d0d4..efa2c85b478 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Config.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Config.hs @@ -1,13 +1,11 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} module Cardano.Wallet.Launch.Cluster.Config ( Config (..) , ShelleyGenesisModifier , TestnetMagic (..) - , NodePathSegment (..) ) where @@ -27,7 +25,8 @@ import Cardano.Wallet.Launch.Cluster.ClusterEra ( ClusterEra ) import Cardano.Wallet.Launch.Cluster.FileOf - ( FileOf + ( DirOf + , FileOf ) import Cardano.Wallet.Launch.Cluster.Logging ( ClusterLog (..) @@ -54,11 +53,11 @@ data Config = Config -- ^ Stake pools to register. , cfgLastHardFork :: ClusterEra -- ^ Which era to use. - , cfgNodeLogging :: LogFileConfig + , cfgNodeLogging :: LogFileConfig DirOf -- ^ Log severity for node. - , cfgClusterDir :: FileOf "cluster" + , cfgClusterDir :: DirOf "cluster" -- ^ Root directory for cluster data. - , cfgClusterConfigs :: FileOf "cluster-configs" + , cfgClusterConfigs :: DirOf "cluster-configs" -- ^ Directory containing data for cluster setup. , cfgTestnetMagic :: TestnetMagic -- ^ Testnet magic to use. @@ -67,7 +66,3 @@ data Config = Config , cfgTracer :: Tracer IO ClusterLog , cfgNodeOutputFile :: Maybe (FileOf "node-output") } - -newtype NodePathSegment = NodePathSegment FilePath - deriving stock (Show) - deriving newtype (Eq, Ord) diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/ConfiguredPool.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/ConfiguredPool.hs index ed9e4bd8372..6e1a8e08678 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/ConfiguredPool.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/ConfiguredPool.hs @@ -60,15 +60,17 @@ import Cardano.Wallet.Launch.Cluster.ClusterM ) import Cardano.Wallet.Launch.Cluster.Config ( Config (..) - , NodePathSegment (..) ) import Cardano.Wallet.Launch.Cluster.Faucet ( faucetAmt , takeFaucet ) import Cardano.Wallet.Launch.Cluster.FileOf - ( FileOf (..) + ( DirOf (..) + , FileOf (..) + , absFilePathOf , changeFileOf + , toFilePath ) import Cardano.Wallet.Launch.Cluster.Logging ( ClusterLog (..) @@ -147,11 +149,14 @@ import Data.Word.Odd import GHC.TypeLits ( Symbol ) -import System.Directory - ( createDirectoryIfMissing +import System.Path + ( RelDir + , relDir + , relFile + , () ) -import System.FilePath - ( () +import System.Path.Directory + ( createDirectoryIfMissing ) import Test.Utils.StaticServer ( withStaticServer @@ -196,44 +201,44 @@ configurePools metadataServer = -- | Create a key pair for a node KES operational key genKesKeyPair - :: NodePathSegment + :: RelDir -> ClusterM (FileOf "kes-prv" , FileOf "kes-pub") genKesKeyPair nodeSegment = do - poolDir <- askNodeDir nodeSegment - let kesPrv = FileOf @"kes-prv" $ poolDir "kes.prv" - let kesPub = FileOf @"kes-pub" $ poolDir "kes.pub" + DirOf poolDir <- askNodeDir nodeSegment + let kesPrv = poolDir relFile "kes.prv" + kesPub = poolDir relFile "kes.pub" cli [ "node" , "key-gen-KES" , "--verification-key-file" - , pathOf kesPub + , toFilePath kesPub , "--signing-key-file" - , pathOf kesPrv + , toFilePath kesPrv ] - pure (kesPrv, kesPub) + pure (FileOf kesPrv, FileOf kesPub) -- | Create a key pair for a node VRF operational key genVrfKeyPair - :: NodePathSegment + :: RelDir -> ClusterM (FileOf "vrf-prv" , FileOf "vrf-pub") genVrfKeyPair nodeSegment = do - poolDir <- askNodeDir nodeSegment - let vrfPrv = FileOf @"vrf-prv" $ poolDir "vrf.prv" - let vrfPub = FileOf @"vrf-pub" $ poolDir "vrf.pub" + DirOf poolDir <- askNodeDir nodeSegment + let vrfPrv = poolDir relFile "vrf.prv" + vrfPub = poolDir relFile "vrf.pub" cli [ "node" , "key-gen-VRF" , "--verification-key-file" - , pathOf vrfPub + , toFilePath vrfPub , "--signing-key-file" - , pathOf vrfPrv + , toFilePath vrfPrv ] - pure (vrfPrv, vrfPub) + pure (FileOf @"vrf-prv" vrfPrv, FileOf @"vrf-pub" vrfPub) -- | Write a key pair for a node operator's offline key and a new certificate -- issue counter writeOperatorKeyPair - :: NodePathSegment + :: RelDir -> PoolRecipe -> ClusterM ( FileOf "op-prv" @@ -241,18 +246,18 @@ writeOperatorKeyPair , FileOf "op-cnt" ) writeOperatorKeyPair nodeSegment recipe = do - poolDir <- askNodeDir nodeSegment + poolDirPath@(DirOf poolDir) <- askNodeDir nodeSegment let (_pId, pub, prv, count) = operatorKeys recipe - traceClusterLog $ MsgGenOperatorKeyPair poolDir + traceClusterLog $ MsgGenOperatorKeyPair poolDirPath - let opPub = poolDir "op.pub" - let opPrv = poolDir "op.prv" - let opCount = poolDir "op.count" + let opPub = poolDir relFile "op.pub" + let opPrv = poolDir relFile "op.prv" + let opCount = poolDir relFile "op.count" liftIO $ do - Aeson.encodeFile opPub pub - Aeson.encodeFile opPrv prv - Aeson.encodeFile opCount count + Aeson.encodeFile (toFilePath opPub) pub + Aeson.encodeFile (toFilePath opPrv) prv + Aeson.encodeFile (toFilePath opCount) count pure ( FileOf @"op-prv" opPrv @@ -262,44 +267,44 @@ writeOperatorKeyPair nodeSegment recipe = do -- | Issue a node operational certificate issueOpCert - :: NodePathSegment + :: RelDir -> FileOf "kes-pub" -> FileOf "op-prv" -> FileOf "op-cnt" - -> ClusterM FilePath -issueOpCert nodeSegment kesPub opPrv opCount = do - poolDir <- askNodeDir nodeSegment - let file = poolDir "op.cert" + -> ClusterM (FileOf "op-cert") +issueOpCert nodeSegment (FileOf kesPub) (FileOf opPrv) (FileOf opCount) = do + DirOf poolDir <- askNodeDir nodeSegment + let opCertPath = poolDir relFile "op.cert" cli [ "node" , "issue-op-cert" , "--kes-verification-key-file" - , pathOf kesPub + , toFilePath kesPub , "--cold-signing-key-file" - , pathOf opPrv + , toFilePath opPrv , "--operational-certificate-issue-counter-file" - , pathOf opCount + , toFilePath opCount , "--kes-period" , "0" , "--out-file" - , file + , toFilePath opCertPath ] - pure file + pure $ FileOf opCertPath -- | Create a stake address key pair genStakeAddrKeyPair :: (FileOf "stake-prv", FileOf "stake-pub") -> ClusterM () -genStakeAddrKeyPair (stakePrv, stakePub) = do +genStakeAddrKeyPair (FileOf stakePrv, FileOf stakePub) = do Config{..} <- ask cli [ clusterEraToString cfgLastHardFork , "stake-address" , "key-gen" , "--verification-key-file" - , pathOf stakePub + , toFilePath stakePub , "--signing-key-file" - , pathOf stakePrv + , toFilePath stakePrv ] readFailVerificationKeyOrFile @@ -310,12 +315,12 @@ readFailVerificationKeyOrFile => AsType keyrole -> FileOf s -> ClusterM (VerificationKey keyrole) -readFailVerificationKeyOrFile role op = +readFailVerificationKeyOrFile role (FileOf op) = liftIO $ either (error . show) id <$> readVerificationKeyOrFile role - (VerificationKeyFilePath $ File $ pathOf op) + (VerificationKeyFilePath $ File $ toFilePath op) stakePoolIdFromOperatorVerKey :: HasCallStack @@ -370,13 +375,13 @@ stakingAddrFromVkFile stakePub = do (Ledger.StakeRefBase (Ledger.KeyHashObj delegKH)) preparePoolRetirement - :: NodePathSegment + :: RelDir -> [FileOf "retirement-cert"] -> ClusterM (FileOf "retirement-tx", FileOf "faucet-prv") preparePoolRetirement nodeSegment certs = do Config{..} <- ask - poolDir <- askNodeDir nodeSegment - let file = poolDir "tx.raw" + DirOf poolDir <- askNodeDir nodeSegment + let transactionFile = poolDir relFile "tx.raw" (faucetInput, faucetPrv) <- takeFaucet cli $ [ clusterEraToString cfgLastHardFork @@ -389,31 +394,34 @@ preparePoolRetirement nodeSegment certs = do , "--fee" , show faucetAmt , "--out-file" - , file + , toFilePath transactionFile ] - ++ mconcat ((\cert -> ["--certificate-file", pathOf cert]) <$> certs) + ++ mconcat + ((\(FileOf cert) -> ["--certificate-file", toFilePath cert]) + <$> certs + ) - pure (FileOf file, faucetPrv) + pure (FileOf transactionFile, faucetPrv) issuePoolRetirementCert - :: NodePathSegment + :: RelDir -- ^ Node relative path -> FileOf "op-pub" - -> Word31 + -> Word31 -- ^ Retirement epoch -> ClusterM (FileOf "retirement-cert") -issuePoolRetirementCert nodeSegment opPub retirementEpoch = do +issuePoolRetirementCert nodeSegment (FileOf opPub) retirementEpoch = do lastHardFork <- asks cfgLastHardFork - poolDir <- askNodeDir nodeSegment - let file = poolDir "pool-retirement.cert" + DirOf poolDir <- askNodeDir nodeSegment + let file = poolDir relFile "pool-retirement.cert" cli [ clusterEraToString lastHardFork , "stake-pool" , "deregistration-certificate" , "--cold-verification-key-file" - , pathOf opPub + , toFilePath opPub , "--epoch" , show retirementEpoch , "--out-file" - , file + , toFilePath file ] pure $ FileOf @"retirement-cert" file @@ -428,17 +436,18 @@ configurePool metadataServer recipe = do UnliftClusterM withConfig Config{..} <- askUnliftClusterM -- Use pool-specific dir let name = "pool-" <> show i - nodeSegment = NodePathSegment name - poolDir <- askNodeDir nodeSegment - liftIO $ createDirectoryIfMissing False poolDir + nodeRelativePath :: RelDir + nodeRelativePath = relDir name + poolDirPath@(DirOf poolDir) <- askNodeDir nodeRelativePath + liftIO $ createDirectoryIfMissing True poolDir -- Generate/assign keys - (vrfPrv, vrfPub) <- genVrfKeyPair nodeSegment - (kesPrv, kesPub) <- genKesKeyPair nodeSegment - (opPrv, opPub, opCount) <- writeOperatorKeyPair nodeSegment recipe - opCert <- issueOpCert nodeSegment kesPub opPrv opCount - let ownerPub = FileOf @"stake-pub" $ poolDir "stake.pub" - let ownerPrv = FileOf @"stake-prv" $ poolDir "stake.prv" + (vrfPrv, vrfPub) <- genVrfKeyPair nodeRelativePath + (kesPrv, kesPub) <- genKesKeyPair nodeRelativePath + (opPrv, opPub, opCount) <- writeOperatorKeyPair nodeRelativePath recipe + opCert <- issueOpCert nodeRelativePath kesPub opPrv opCount + let ownerPub = FileOf @"stake-pub" $ poolDir relFile "stake.pub" + let ownerPrv = FileOf @"stake-prv" $ poolDir relFile "stake.prv" genStakeAddrKeyPair (ownerPrv, ownerPub) let metadataURL = urlFromPoolIndex metadataServer i @@ -455,34 +464,36 @@ configurePool metadataServer recipe = do nodeOutput = nodeParams let logCfg' = setLoggingName name logCfg - topology <- withConfig $ genTopology nodeSegment peers - withStaticServer poolDir $ \url -> do - traceWith cfgTracer $ MsgStartedStaticServer poolDir url + topology <- withConfig $ genTopology nodeRelativePath peers + withStaticServer (toFilePath poolDir) $ \url -> do + traceWith cfgTracer $ MsgStartedStaticServer url poolDirPath (nodeConfig, genesisData, vd) <- withConfig $ genNodeConfig - nodeSegment + nodeRelativePath (Tagged @"node-name" mempty) genesisFiles hardForks logCfg' - let cfg = + let + cfg = CardanoNodeConfig - { nodeDir = poolDir - , nodeConfigFile = pathOf @"node-config" nodeConfig - , nodeTopologyFile = pathOf @"topology" topology - , nodeDatabaseDir = "db" + { nodeDir = toFilePath poolDir + , nodeConfigFile = absFilePathOf nodeConfig + , nodeTopologyFile = absFilePathOf topology + , nodeDatabaseDir = toFilePath + $ poolDir relDir "db" , nodeDlgCertFile = Nothing , nodeSignKeyFile = Nothing - , nodeOpCertFile = Just opCert - , nodeKesKeyFile = Just $ pathOf @"kes-prv" kesPrv - , nodeVrfKeyFile = Just $ pathOf @"vrf-prv" vrfPrv + , nodeOpCertFile = Just $ absFilePathOf opCert + , nodeKesKeyFile = Just $ absFilePathOf kesPrv + , nodeVrfKeyFile = Just $ absFilePathOf vrfPrv , nodePort = Just (NodePort port) , nodeLoggingHostname = Just name , nodeExecutable = Nothing - , nodeOutputFile = nodeOutput + , nodeOutputFile = absFilePathOf <$> nodeOutput } withConfig @@ -539,10 +550,10 @@ configurePool metadataServer recipe = do -- @registerViaTx@, but this seems to work regardless. (We -- do want to submit it here for the sake of babbage) let retire e = do - retCert <- issuePoolRetirementCert nodeSegment opPub e + retCert <- issuePoolRetirementCert nodeRelativePath opPub e (rawTx, faucetPrv) <- preparePoolRetirement - nodeSegment + nodeRelativePath [retCert] signAndSubmitTx socket diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Faucet.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Faucet.hs index 53c9acf39a9..3cced8920be 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Faucet.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Faucet.hs @@ -37,8 +37,10 @@ import Cardano.Wallet.Launch.Cluster.Config ( Config (..) ) import Cardano.Wallet.Launch.Cluster.FileOf - ( FileOf (..) + ( DirOf (..) + , FileOf (..) , changeFileOf + , toFilePath ) import Cardano.Wallet.Launch.Cluster.MonetaryPolicyScript ( writeMonetaryPolicyScriptFile @@ -122,13 +124,16 @@ import Servant.Client import System.Directory ( listDirectory ) -import System.FilePath - ( (<.>) - , () - ) import System.IO.Unsafe ( unsafePerformIO ) +import System.Path + ( AbsFile + , relDir + , relFile + , (<.>) + , () + ) import qualified Cardano.Address as Address import qualified Cardano.Address as CA @@ -155,11 +160,10 @@ takeFaucet = do Config{..} <- ask i <- liftIO $ modifyMVar faucetIndex (\i -> pure (i + 1, i)) let basename = - pathOf cfgClusterConfigs - "faucet-addrs" - "faucet" - <> show i - base58Addr <- liftIO $ BS.readFile $ basename <> ".addr" + absDirOf cfgClusterConfigs + relDir "faucet-addrs" + relFile ("faucet" <> show i) + base58Addr <- liftIO $ BS.readFile $ toFilePath $ basename <.> "addr" let addr = fromMaybe (error $ "decodeBase58 failed for " ++ show base58Addr) . decodeBase58 bitcoinAlphabet @@ -168,7 +172,7 @@ takeFaucet = do $ T.decodeUtf8 base58Addr let txin = B8.unpack (convertToBase Base16 (blake2b256 addr)) <> "#0" - let signingKey = basename <> ".shelley.key" + let signingKey = basename <.> "shelley.key" pure (Tagged @"tx-in" txin, FileOf @"faucet-prv" signingKey) readFaucetAddresses @@ -176,20 +180,20 @@ readFaucetAddresses => ClusterM [Address] readFaucetAddresses = do Config{..} <- ask - let faucetDataPath = pathOf cfgClusterConfigs "faucet-addrs" - allFileNames <- liftIO $ listDirectory faucetDataPath - let addrFileNames = filter (".addr" `isSuffixOf`) allFileNames + let faucetDataPath = absDirOf cfgClusterConfigs relDir "faucet-addrs" + allFileNames <- liftIO $ listDirectory (toFilePath faucetDataPath) + let addrFileNames = relFile <$> filter (".addr" `isSuffixOf`) allFileNames liftIO $ forM addrFileNames $ readAddress . (faucetDataPath ) where - readAddress :: HasCallStack => FilePath -> IO Address + readAddress :: HasCallStack => AbsFile -> IO Address readAddress addrFile = do - rawFileContents <- TIO.readFile addrFile + rawFileContents <- TIO.readFile $ toFilePath addrFile let base58EncodedAddress = T.strip rawFileContents case Address.fromBase58 base58EncodedAddress of Just address -> pure address Nothing -> error - $ "Failed to base58-decode address file: " <> addrFile + $ "Failed to base58-decode address file: " <> show addrFile -- | List of faucets also referenced in the shelley 'genesis.yaml' faucetIndex :: MVar Int @@ -286,9 +290,9 @@ sendFaucet -> ClusterM () sendFaucet conn what targets = do Config{..} <- ask - let clusterDir = cfgClusterDir + let DirOf clusterDir = cfgClusterDir (faucetInput, faucetPrv) <- takeFaucet - let file = pathOf clusterDir "faucet-tx.raw" + let file = clusterDir relFile "faucet-tx.raw" let mkOutput addr (TokenBundle (Coin c) tokens) = [ "--tx-out" @@ -331,22 +335,23 @@ sendFaucet conn what targets = do "--fee" , show (faucetAmt - total) , "--out-file" - , file + , toFilePath file ] ++ concatMap (uncurry mkOutput . fmap fst) targets ++ mkMint targetAssets - ++ (concatMap (\f -> ["--minting-script-file", pathOf f]) scripts) + ++ (concatMap + (\f -> ["--minting-script-file", toFilePath (absFileOf f)]) + scripts + ) policyKeys <- forM (nub $ concatMap (snd . snd) targets) - $ \(skey, keyHash) -> do - f <- writePolicySigningKey keyHash skey - pure $ FileOf @"signing-key" $ pathOf f + $ \(skey, keyHash) -> writePolicySigningKey keyHash skey signAndSubmitTx conn (FileOf @"tx-body" file) - (changeFileOf faucetPrv : policyKeys) + (changeFileOf faucetPrv : (changeFileOf <$> policyKeys)) (Tagged @"name" $ what ++ " faucet tx") writePolicySigningKey @@ -357,9 +362,9 @@ writePolicySigningKey -> ClusterM (FileOf "policy-signing-key") -- ^ Returns the filename written writePolicySigningKey keyHash cborHex = do - outputDir <- asks cfgClusterDir - let keyFile = pathOf outputDir keyHash <.> "skey" - liftIO $ Aeson.encodeFile keyFile + DirOf outputDir <- asks cfgClusterDir + let keyFile = outputDir relFile keyHash <.> "skey" + liftIO $ Aeson.encodeFile (toFilePath keyFile) $ object [ "type" .= Aeson.String "PaymentSigningKeyShelley_ed25519" , "description" .= Aeson.String "Payment Signing Key" diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/FileOf.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/FileOf.hs index 5d835f91fbb..ce90cd0c430 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/FileOf.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/FileOf.hs @@ -2,10 +2,20 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} module Cardano.Wallet.Launch.Cluster.FileOf ( FileOf (..) + , DirOf (..) + , RelDirOf (..) , changeFileOf + , absFilePathOf + , mkRelDirOf + , toFilePath + , newAbsolutizer + , Absolutizer (..) + , absolutize ) where @@ -14,10 +24,69 @@ import Prelude import GHC.TypeLits ( Symbol ) +import System.Directory + ( getCurrentDirectory + ) +import System.Path + ( AbsDir + , AbsFile + , Path + , RelDir + , absDir + , dynamicMakeAbsolute + , relDir + , toString + ) +import System.Path.Part + ( Abs + , AbsRel + ) + +import qualified System.Path.PartClass as C + +-- | An absolute path with a type-level tag +newtype FileOf (s :: Symbol) = FileOf {absFileOf :: AbsFile} + deriving stock (Show) + deriving newtype (Eq, Ord) + +-- | Shortcut to get string filepath from a FileOf +absFilePathOf :: FileOf a -> FilePath +absFilePathOf (FileOf fp) = toFilePath fp -newtype FileOf (s :: Symbol) = FileOf {pathOf :: FilePath} +-- | An absolute directory with a type-level tag +newtype DirOf (s :: Symbol) = DirOf {absDirOf :: AbsDir} deriving stock (Show) deriving newtype (Eq, Ord) +-- | A relative directory with a type-level tag +newtype RelDirOf (s :: Symbol) = RelDirOf {relDirOf :: RelDir} + deriving stock (Show) + deriving newtype (Eq, Ord) + +-- | Shortcut to build a RelDirOf from a string filepath +mkRelDirOf :: FilePath -> RelDirOf s +mkRelDirOf = RelDirOf . relDir + changeFileOf :: FileOf a -> FileOf b changeFileOf (FileOf fp) = FileOf fp + +-- | De-type a path +toFilePath :: (C.AbsRel ar, C.FileDir r) => Path ar r -> FilePath +toFilePath = toString + +-- | A function to turn relative paths into absolute paths in IO +absolutize :: Path AbsRel t -> IO (Path Abs t) +absolutize x = do + Absolutizer f <- newAbsolutizer + pure $ f x + +-- | A facility to turn relative paths into absolute paths. +newtype Absolutizer = Absolutizer + { runAbsolutizer :: forall t. Path AbsRel t -> Path Abs t + } + +-- | Use the current working directory to create an 'Absolutizer' +newAbsolutizer :: IO Absolutizer +newAbsolutizer = do + cwd <- absDir <$> getCurrentDirectory + pure $ Absolutizer $ dynamicMakeAbsolute cwd diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/GenesisFiles.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/GenesisFiles.hs index 57cd8549ddd..a3affdb2489 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/GenesisFiles.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/GenesisFiles.hs @@ -56,7 +56,9 @@ import Cardano.Wallet.Launch.Cluster.Config , TestnetMagic (testnetMagicToNatural) ) import Cardano.Wallet.Launch.Cluster.FileOf - ( FileOf (..) + ( DirOf (..) + , FileOf (..) + , toFilePath ) import Cardano.Wallet.Launch.Cluster.UnsafeInterval ( unsafeNonNegativeInterval @@ -101,8 +103,8 @@ import Data.Time.Clock.POSIX import System.Directory ( copyFile ) -import System.FilePath - ( () +import System.Path hiding + ( FilePath ) import qualified Cardano.Ledger.Api.Tx.Address as Ledger @@ -112,10 +114,10 @@ import qualified Data.Aeson as Aeson import qualified Data.ListMap as ListMap data GenesisFiles = GenesisFiles - { byronGenesis :: FilePath - , shelleyGenesis :: FilePath - , alonzoGenesis :: FilePath - , conwayGenesis :: FilePath + { byronGenesis :: FileOf "genesis-byron" + , shelleyGenesis :: FileOf "genesis-shelley" + , alonzoGenesis :: FileOf "genesis-alonzo" + , conwayGenesis :: FileOf "genesis-conway" } deriving stock (Show, Eq) @@ -230,30 +232,39 @@ generateGenesis initialFunds genesisMods = do } genesisMods - let shelleyGenesis = pathOf cfgClusterDir "shelley-genesis.json" - Aeson.encodeFile shelleyGenesis shelleyGenesisData + let byronFileOf, shelleyFileOf, alonzoFileOf, conwayFileOf + :: DirOf x -> AbsFile + byronFileOf x = absDirOf x relFile "byron-genesis.json" + shelleyFileOf x = absDirOf x relFile "shelley-genesis.json" + alonzoFileOf x = absDirOf x relFile "alonzo-genesis.json" + conwayFileOf x = absDirOf x relFile "conway-genesis.json" + + let shelleyGenesis = shelleyFileOf cfgClusterDir + Aeson.encodeFile (toFilePath shelleyGenesis) shelleyGenesisData let fileToAeson :: FilePath -> IO Aeson.Value fileToAeson f = Aeson.eitherDecodeFileStrict f >>= either fail pure - let byronGenesis = pathOf cfgClusterDir "genesis-byron.json" - fileToAeson (pathOf cfgClusterConfigs "byron-genesis.json") + let byronGenesis = byronFileOf cfgClusterDir + fileToAeson (toFilePath $ byronFileOf cfgClusterConfigs) >>= withAddedKey "startTime" (round @_ @Int $ utcTimeToPOSIXSeconds systemStart) - >>= Aeson.encodeFile byronGenesis + >>= Aeson.encodeFile (toFilePath byronGenesis) - let alonzoGenesis = pathOf cfgClusterDir "genesis-alonzo.json" - fileToAeson (pathOf cfgClusterConfigs "alonzo-genesis.json") - >>= Aeson.encodeFile alonzoGenesis + let alonzoGenesis = alonzoFileOf cfgClusterDir + fileToAeson (toFilePath $ alonzoFileOf cfgClusterConfigs) + >>= Aeson.encodeFile (toFilePath alonzoGenesis) - let conwayGenesis = pathOf cfgClusterDir "genesis-conway.json" - copyFile (pathOf cfgClusterConfigs "conway-genesis.json") conwayGenesis + let conwayGenesis = conwayFileOf cfgClusterDir + copyFile + (toFilePath $ conwayFileOf cfgClusterConfigs) + (toFilePath conwayGenesis) pure GenesisFiles - { byronGenesis - , shelleyGenesis - , alonzoGenesis - , conwayGenesis + { byronGenesis = FileOf byronGenesis + , shelleyGenesis = FileOf shelleyGenesis + , alonzoGenesis = FileOf alonzoGenesis + , conwayGenesis = FileOf conwayGenesis } diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/KeyRegistration.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/KeyRegistration.hs index 538c3b787f5..a679e4f30f4 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/KeyRegistration.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/KeyRegistration.hs @@ -29,7 +29,9 @@ import Cardano.Wallet.Launch.Cluster.Faucet , takeFaucet ) import Cardano.Wallet.Launch.Cluster.FileOf - ( FileOf (..) + ( DirOf (..) + , FileOf (..) + , toFilePath ) import Cardano.Wallet.Launch.Cluster.SinkAddress ( genSinkAddress @@ -47,8 +49,9 @@ import Data.Tagged ( Tagged (..) , untag ) -import System.FilePath - ( () +import System.Path + ( relFile + , () ) import qualified Data.Aeson as Aeson @@ -64,22 +67,20 @@ prepareStakeKeyRegistration ) prepareStakeKeyRegistration = do Config{..} <- ask - let file = pathOf cfgClusterDir "tx.raw" + let transactionPath = absDirOf cfgClusterDir relFile "tx.raw" let stakePub = - FileOf @"stake-pub" - $ pathOf cfgClusterDir "pre-registered-stake.vkey" + absDirOf cfgClusterDir relFile "pre-registered-stake.vkey" stakePrv = - FileOf @"stake-prv" - $ pathOf cfgClusterDir "pre-registered-stake.skey" + absDirOf cfgClusterDir relFile "pre-registered-stake.skey" liftIO $ do let (pub, prv) = preRegisteredStakeKeyPair - Aeson.encodeFile (pathOf stakePub) pub - Aeson.encodeFile (pathOf stakePrv) prv + Aeson.encodeFile (toFilePath stakePub) pub + Aeson.encodeFile (toFilePath stakePrv) prv (faucetInput, faucetPrv) <- takeFaucet - cert <- + FileOf cert <- issueStakeVkCert (Tagged @"prefix" "pre-registered") - stakePub + (FileOf stakePub) sink <- genSinkAddress Nothing cli [ clusterEraToString cfgLastHardFork @@ -94,8 +95,12 @@ prepareStakeKeyRegistration = do , "--fee" , show (faucetAmt - depositAmt - 1_000_000) , "--certificate-file" - , pathOf cert + , toFilePath cert , "--out-file" - , file + , toFilePath transactionPath ] - pure (FileOf @"reg-tx" file, faucetPrv, stakePrv) + pure + ( FileOf @"reg-tx" transactionPath + , faucetPrv + , FileOf @"stake-prv" $ stakePrv + ) diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Logging.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Logging.hs index 59d2ee411aa..6c44f5386de 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Logging.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Logging.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} module Cardano.Wallet.Launch.Cluster.Logging ( ClusterLog (..) @@ -38,8 +41,11 @@ import Cardano.Wallet.Launch.Cluster.ClusterEra ( ClusterEra , clusterEraToString ) -import Control.Monad - ( liftM2 +import Cardano.Wallet.Launch.Cluster.FileOf + ( DirOf (..) + , FileOf (..) + , RelDirOf (..) + , absolutize ) import Data.Char ( toLower @@ -50,9 +56,6 @@ import Data.Text import Data.Text.Class ( ToText (..) ) -import System.Directory - ( makeAbsolute - ) import System.Environment.Extended ( lookupEnvNonEmpty ) @@ -60,15 +63,15 @@ import System.Exit ( ExitCode (..) , die ) -import System.FilePath - ( () - ) -import System.FilePath.Posix - ( (<.>) - ) import System.IO.Temp.Extra ( TempDirLog ) +import System.Path + ( absRel + , relFile + , (<.>) + , () + ) import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.Text as T @@ -78,9 +81,9 @@ import qualified Data.Text.Encoding.Error as T data ClusterLog = -- | How many pools MsgRegisteringStakePools Int - | MsgStartingCluster FilePath + | MsgStartingCluster (DirOf "cluster") | MsgLauncher String LauncherLog - | MsgStartedStaticServer String FilePath + | MsgStartedStaticServer String (DirOf "node") | MsgRegisteringPoolMetadataInSMASH String String | MsgRegisteringPoolMetadata String String | MsgTempDir TempDirLog @@ -91,7 +94,7 @@ data ClusterLog | MsgSocketIsReady CardanoNodeConn | MsgStakeDistribution String ExitCode BL8.ByteString BL8.ByteString | MsgDebug Text - | MsgGenOperatorKeyPair FilePath + | MsgGenOperatorKeyPair (DirOf "node") | MsgCLI [String] | MsgHardFork ClusterEra deriving stock (Show) @@ -99,7 +102,7 @@ data ClusterLog instance ToText ClusterLog where toText = \case MsgStartingCluster dir -> - "Configuring cluster in " <> T.pack dir + "Configuring cluster in " <> T.pack (show dir) MsgRegisteringPoolMetadata url hash -> T.pack $ unwords @@ -125,7 +128,7 @@ instance ToText ClusterLog where T.pack name <> " " <> toText msg MsgStartedStaticServer baseUrl fp -> "Started a static server for " - <> T.pack fp + <> T.pack (show fp) <> " at " <> T.pack baseUrl MsgTempDir msg -> toText msg @@ -164,7 +167,7 @@ instance ToText ClusterLog where <> indent err MsgDebug msg -> msg MsgGenOperatorKeyPair dir -> - "Generating stake pool operator key pair in " <> T.pack dir + "Generating stake pool operator key pair in " <> T.pack (show dir) MsgCLI args -> T.pack $ unwords ("cardano-cli" : args) MsgHardFork era -> "Hard fork to " <> T.pack (clusterEraToString era) @@ -206,21 +209,22 @@ instance HasSeverityAnnotation ClusterLog where bracketTracer' :: Tracer IO ClusterLog -> Text -> IO a -> IO a bracketTracer' tr name = bracketTracer (contramap (MsgBracket name) tr) -data LogFileConfig = LogFileConfig +data LogFileConfig a = LogFileConfig { minSeverityTerminal :: Severity -- ^ Minimum logging severity - , extraLogDir :: Maybe FilePath + , extraLogDir :: Maybe (a "node-logs") -- ^ Optional additional output to log file , minSeverityFile :: Severity -- ^ Minimum logging severity for 'extraLogFile' } - deriving stock (Show) + +deriving stock instance Show (a "node-logs") => Show (LogFileConfig a) logFileConfigFromEnv - :: Maybe String + :: Maybe (RelDirOf "log-subdir") -- ^ Optional extra subdir for TESTS_LOGDIR. E.g. @Just "alonzo"@ and -- @Just "mary"@ to keep them separate. - -> IO LogFileConfig + -> IO (LogFileConfig DirOf) logFileConfigFromEnv subdir = LogFileConfig <$> nodeMinSeverityFromEnv @@ -263,14 +267,22 @@ testMinSeverityFromEnv = -- | Directory for extra logging. Buildkite will set this environment variable -- and upload logs in it automatically. -testLogDirFromEnv :: Maybe String -> IO (Maybe FilePath) +testLogDirFromEnv + :: Maybe (RelDirOf "log-subdir") + -> IO (Maybe (DirOf "node-logs")) testLogDirFromEnv msubdir = do - rel <- lookupEnvNonEmpty "TESTS_LOGDIR" - makeAbsolute `traverse` case msubdir of - Just subdir -> liftM2 () rel (Just subdir) - Nothing -> rel + mLogDir <- fmap absRel <$> lookupEnvNonEmpty "TESTS_LOGDIR" + mAbsLogDir <- absolutize `traverse` mLogDir + pure $ do + RelDirOf subdir <- msubdir + absLogDir <- mAbsLogDir + pure $ DirOf $ absLogDir subdir -setLoggingName :: String -> LogFileConfig -> LogFileConfig +setLoggingName + :: String + -> LogFileConfig DirOf + -> LogFileConfig FileOf setLoggingName name cfg = cfg{extraLogDir = filename <$> extraLogDir cfg} where - filename = ( (name <.> "log")) + filename :: DirOf "node-logs" -> FileOf "node-logs" + filename (DirOf dir) = FileOf (dir (relFile name <.> "log")) diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/MonetaryPolicyScript.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/MonetaryPolicyScript.hs index 47c08f68f73..5177f42245d 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/MonetaryPolicyScript.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/MonetaryPolicyScript.hs @@ -20,7 +20,9 @@ import Cardano.Wallet.Launch.Cluster.Config ( Config (..) ) import Cardano.Wallet.Launch.Cluster.FileOf - ( FileOf (..) + ( DirOf (..) + , FileOf (..) + , toFilePath ) import Control.Monad.IO.Class ( MonadIO (..) @@ -38,8 +40,10 @@ import Data.Generics.Labels import Data.Text ( Text ) -import System.FilePath - ( (<.>) +import System.Path + ( AbsFile + , relFile + , (<.>) , () ) import UnliftIO.Exception @@ -55,17 +59,17 @@ import qualified Data.Text as T genMonetaryPolicyScript :: ClusterM (String, (String, String)) genMonetaryPolicyScript = do - outputDir <- asks cfgClusterDir - let policyPub = pathOf outputDir "policy.pub" - let policyPrv = pathOf outputDir "policy.prv" + DirOf outputDir <- asks cfgClusterDir + let policyPub = outputDir relFile "policy.pub" + let policyPrv = outputDir relFile "policy.prv" cli [ "address" , "key-gen" , "--verification-key-file" - , policyPub + , toFilePath policyPub , "--signing-key-file" - , policyPrv + , toFilePath policyPrv ] skey <- liftIO $ T.unpack <$> readKeyFromFile policyPrv vkeyHash <- @@ -73,15 +77,15 @@ genMonetaryPolicyScript = do [ "address" , "key-hash" , "--payment-verification-key-file" - , policyPub + , toFilePath policyPub ] - script <- writeMonetaryPolicyScriptFile vkeyHash + FileOf script <- writeMonetaryPolicyScriptFile vkeyHash policyId <- cliLine [ "transaction" , "policyid" , "--script-file" - , pathOf script + , toFilePath script ] pure (policyId, (skey, vkeyHash)) @@ -92,9 +96,9 @@ writeMonetaryPolicyScriptFile -> ClusterM (FileOf "policy-script") -- ^ Returns the filename written writeMonetaryPolicyScriptFile keyHash = do - outputDir <- asks cfgClusterDir - let scriptFile = pathOf outputDir keyHash <.> "script" - liftIO $ Aeson.encodeFile scriptFile + DirOf outputDir <- asks cfgClusterDir + let scriptFile = outputDir (relFile keyHash <.> "script") + liftIO $ Aeson.encodeFile (toFilePath scriptFile) $ object [ "type" .= Aeson.String "sig" , "keyHash" .= keyHash @@ -102,9 +106,10 @@ writeMonetaryPolicyScriptFile keyHash = do pure $ FileOf scriptFile -- | Dig in to a @cardano-cli@ TextView key file to get the hex-encoded key. -readKeyFromFile :: FilePath -> IO Text +readKeyFromFile :: AbsFile -> IO Text readKeyFromFile f = do - textView <- either throwString pure =<< Aeson.eitherDecodeFileStrict' f + textView <- either throwString pure =<< + Aeson.eitherDecodeFileStrict' (toFilePath f) either throwString pure $ Aeson.parseEither (Aeson.withObject "TextView" (.: "cborHex")) diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/GenNodeConfig.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/GenNodeConfig.hs index 7bf24dcbeba..d6d68755e17 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/GenNodeConfig.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/GenNodeConfig.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} module Cardano.Wallet.Launch.Cluster.Node.GenNodeConfig @@ -37,10 +36,12 @@ import Cardano.Wallet.Launch.Cluster.ClusterM ) import Cardano.Wallet.Launch.Cluster.Config ( Config (..) - , NodePathSegment ) import Cardano.Wallet.Launch.Cluster.FileOf - ( FileOf (..) + ( DirOf (..) + , FileOf (..) + , absFilePathOf + , toFilePath ) import Cardano.Wallet.Launch.Cluster.GenesisFiles ( GenesisFiles (..) @@ -63,35 +64,39 @@ import Data.Generics.Labels import Data.Maybe ( catMaybes ) +import Data.Tagged + ( Tagged + , untag + ) import Ouroboros.Network.Magic ( NetworkMagic (..) ) import Ouroboros.Network.NodeToClient ( NodeToClientVersionData (..) ) -import System.FilePath - ( () +import System.Path + ( AbsFile + , RelDir + , relFile + , (<.>) + , () ) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Key as Aeson import qualified Data.Aeson.KeyMap as Aeson -import Data.Tagged - ( Tagged - , untag - ) import qualified Data.Text as T import qualified Data.Yaml as Yaml genNodeConfig - :: NodePathSegment + :: RelDir -- ^ A top-level directory where to put the configuration. -> Tagged "node-name" String -- Node name -> GenesisFiles -- ^ Genesis block start time -> ClusterEra -- ^ Last era to hard fork into. - -> LogFileConfig + -> LogFileConfig FileOf -- ^ Minimum severity level for logging and optional /extra/ logging output -> ClusterM ( FileOf "node-config" @@ -100,7 +105,7 @@ genNodeConfig ) genNodeConfig nodeSegment name genesisFiles clusterEra logCfg = do Config{..} <- ask - poolDir <- askNodeDir nodeSegment + DirOf poolDir <- askNodeDir nodeSegment let LogFileConfig severity mExtraLogFile extraSev = logCfg let GenesisFiles { byronGenesis @@ -124,26 +129,31 @@ genNodeConfig nodeSegment name genesisFiles clusterEra logCfg = do map fileScribe $ catMaybes [ Just ("cardano-node.log", severity) - , (,extraSev) . T.pack <$> mExtraLogFile + , case mExtraLogFile of + Just (FileOf file) -> Just + (T.pack $ toFilePath file, extraSev) + Nothing -> Nothing ] let poolNodeConfig = - poolDir ("node" <> untag name <> "-config.yaml") - + poolDir relFile ("node" <> untag name <> "-config") <.> "yaml" + nodeConfigPath :: AbsFile + nodeConfigPath = absDirOf cfgClusterConfigs + relFile "node-config.json" liftIO - $ Yaml.decodeFileThrow (pathOf cfgClusterConfigs "node-config.json") - >>= withAddedKey "ShelleyGenesisFile" shelleyGenesis - >>= withAddedKey "ByronGenesisFile" byronGenesis - >>= withAddedKey "AlonzoGenesisFile" alonzoGenesis - >>= withAddedKey "ConwayGenesisFile" conwayGenesis + $ Yaml.decodeFileThrow (toFilePath nodeConfigPath) + >>= withAddedKey "ShelleyGenesisFile" (absFilePathOf shelleyGenesis) + >>= withAddedKey "ByronGenesisFile" (absFilePathOf byronGenesis) + >>= withAddedKey "AlonzoGenesisFile" (absFilePathOf alonzoGenesis) + >>= withAddedKey "ConwayGenesisFile" (absFilePathOf conwayGenesis) >>= withHardForks clusterEra >>= withAddedKey "minSeverity" Debug >>= withScribes scribes >>= withObject (addMinSeverityStdout severity) - >>= Yaml.encodeFile poolNodeConfig + >>= Yaml.encodeFile (toFilePath poolNodeConfig) -- Parameters - genesisData <- Yaml.decodeFileThrow shelleyGenesis + genesisData <- Yaml.decodeFileThrow $ absFilePathOf shelleyGenesis let networkMagic = NetworkMagic $ sgNetworkMagic genesisData pure ( FileOf @"node-config" poolNodeConfig diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/GenTopology.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/GenTopology.hs index b4981123de0..a30589f6f41 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/GenTopology.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/GenTopology.hs @@ -12,11 +12,10 @@ import Cardano.Wallet.Launch.Cluster.ClusterM ( ClusterM , askNodeDir ) -import Cardano.Wallet.Launch.Cluster.Config - ( NodePathSegment - ) import Cardano.Wallet.Launch.Cluster.FileOf - ( FileOf (..) + ( DirOf (..) + , FileOf (..) + , toFilePath ) import Control.Monad.Reader ( MonadIO (..) @@ -24,22 +23,25 @@ import Control.Monad.Reader import Data.Aeson ( (.=) ) -import System.FilePath - ( () +import System.Path + ( RelDir + , relFile + , (<.>) + , () ) import qualified Data.Aeson as Aeson -- | Generate a topology file from a list of peers. genTopology - :: NodePathSegment + :: RelDir -> [Int] -> ClusterM (FileOf "topology") genTopology nodeSegment peers = do - nodeDir <- askNodeDir nodeSegment - let file = nodeDir "node.topology" + DirOf nodeDir <- askNodeDir nodeSegment + let file = nodeDir relFile "node" <.> "topology" liftIO - $ Aeson.encodeFile file + $ Aeson.encodeFile (toFilePath file) $ Aeson.object ["Producers" .= map encodePeer peers] pure $ FileOf @"topology" file where diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/NodeParams.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/NodeParams.hs index eb1b46865b9..bc7a92883fa 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/NodeParams.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/NodeParams.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} module Cardano.Wallet.Launch.Cluster.Node.NodeParams @@ -14,6 +15,10 @@ import Cardano.BM.Tracing import Cardano.Wallet.Launch.Cluster.ClusterEra ( ClusterEra (BabbageHardFork) ) +import Cardano.Wallet.Launch.Cluster.FileOf + ( DirOf (..) + , FileOf (..) + ) import Cardano.Wallet.Launch.Cluster.GenesisFiles ( GenesisFiles ) @@ -29,19 +34,19 @@ data NodeParams = NodeParams -- ^ Era to hard fork into. , nodePeers :: (Int, [Int]) -- ^ A list of ports used by peers and this node - , nodeLogConfig :: LogFileConfig + , nodeLogConfig :: LogFileConfig DirOf -- ^ The node will always log to "cardano-node.log" relative to the -- config. This option can set the minimum severity and add another output -- file. - , nodeParamsOutputFile :: Maybe FilePath + , nodeParamsOutputFile :: Maybe (FileOf "node-output") } deriving stock (Show) singleNodeParams :: GenesisFiles -> Severity - -> Maybe (FilePath, Severity) - -> Maybe FilePath + -> Maybe (DirOf "node-logs", Severity) + -> Maybe (FileOf "node-output") -> NodeParams singleNodeParams genesisFiles severity extraLogFile = NodeParams genesisFiles BabbageHardFork (0, []) LogFileConfig diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/Relay.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/Relay.hs index 75dd1960590..ad7d0c43b66 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/Relay.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/Relay.hs @@ -19,11 +19,10 @@ import Cardano.Wallet.Launch.Cluster.ClusterM , askNodeDir , bracketTracer' ) -import Cardano.Wallet.Launch.Cluster.Config - ( NodePathSegment (..) - ) import Cardano.Wallet.Launch.Cluster.FileOf - ( FileOf (..) + ( DirOf (..) + , absFilePathOf + , toFilePath ) import Cardano.Wallet.Launch.Cluster.Logging ( setLoggingName @@ -49,8 +48,12 @@ import Control.Monad.Reader import Data.Tagged ( Tagged (..) ) -import System.Directory - ( createDirectory +import System.Path + ( relDir + , () + ) +import System.Path.Directory + ( createDirectoryIfMissing ) -- | Launches a @cardano-node@ with the given configuration which will not forge @@ -71,12 +74,11 @@ withRelayNode -> ClusterM a withRelayNode params onClusterStart = do let name = "node" - nodeSegment = NodePathSegment name - nodeDir' <- askNodeDir nodeSegment + nodeSegment = relDir name + DirOf nodeDirPath <- askNodeDir nodeSegment let NodeParams genesisFiles hardForks (port, peers) logCfg _ = params bracketTracer' "withRelayNode" $ do - liftIO $ createDirectory nodeDir' - + liftIO $ createDirectoryIfMissing True nodeDirPath let logCfg' = setLoggingName name logCfg (config, genesisData, vd) <- genNodeConfig @@ -89,10 +91,10 @@ withRelayNode params onClusterStart = do let cfg = CardanoNodeConfig - { nodeDir = nodeDir' - , nodeConfigFile = pathOf config - , nodeTopologyFile = pathOf topology - , nodeDatabaseDir = "db" + { nodeDir = toFilePath nodeDirPath + , nodeConfigFile = absFilePathOf config + , nodeTopologyFile = absFilePathOf topology + , nodeDatabaseDir = toFilePath $ nodeDirPath relDir "db" , nodeDlgCertFile = Nothing , nodeSignKeyFile = Nothing , nodeOpCertFile = Nothing @@ -101,7 +103,8 @@ withRelayNode params onClusterStart = do , nodePort = Just (NodePort port) , nodeLoggingHostname = Just name , nodeExecutable = Nothing - , nodeOutputFile = nodeParamsOutputFile params + , nodeOutputFile = absFilePathOf + <$> nodeParamsOutputFile params } let onClusterStart' socket = onClusterStart (RunningNode socket genesisData vd) diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/PoolMetadataServer.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/PoolMetadataServer.hs index b6cdc0343fe..a47c43d5fb6 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/PoolMetadataServer.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/PoolMetadataServer.hs @@ -20,7 +20,8 @@ import Cardano.Wallet.Launch.Cluster.Config ( Config (..) ) import Cardano.Wallet.Launch.Cluster.FileOf - ( FileOf (..) + ( DirOf (..) + , toFilePath ) import Cardano.Wallet.Launch.Cluster.Logging ( ClusterLog (MsgRegisteringPoolMetadata) @@ -35,11 +36,15 @@ import Data.ByteArray.Encoding ( Base (Base16) , convertToBase ) -import System.Directory - ( createDirectoryIfMissing +import System.Path + ( RelFile + , relDir + , relFile + , (<.>) + , () ) -import System.FilePath - ( () +import System.Path.Directory + ( createDirectoryIfMissing ) import Test.Utils.StaticServer ( withStaticServer @@ -60,17 +65,20 @@ withPoolMetadataServer -> ClusterM a withPoolMetadataServer action = do UnliftClusterM withConfig Config{..} <- askUnliftClusterM - let metadir = pathOf cfgClusterDir "pool-metadata" + let metadir = absDirOf cfgClusterDir relDir "pool-metadata" liftIO $ do - createDirectoryIfMissing False metadir - withStaticServer metadir $ \baseURL -> do - let _urlFromPoolIndex i = baseURL metadataFileName i + createDirectoryIfMissing True metadir + withStaticServer (toFilePath metadir) $ \baseURL -> do + let _urlFromPoolIndex i = + baseURL <> toFilePath (metadataFileName i) withConfig $ action PoolMetadataServer { registerMetadataForPoolIndex = \i metadata -> do let metadataBytes = Aeson.encode metadata - BL8.writeFile (metadir (metadataFileName i)) metadataBytes + BL8.writeFile + (toFilePath $ metadir (metadataFileName i)) + metadataBytes let hash = blake2b256 (BL.toStrict metadataBytes) traceWith cfgTracer $ MsgRegisteringPoolMetadata @@ -79,5 +87,5 @@ withPoolMetadataServer action = do , urlFromPoolIndex = _urlFromPoolIndex } where - metadataFileName :: Int -> FilePath - metadataFileName i = show i <> ".json" + metadataFileName :: Int -> RelFile + metadataFileName i = relFile (show i) <.> "json" diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/SinkAddress.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/SinkAddress.hs index d46eb583459..2e67334d71c 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/SinkAddress.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/SinkAddress.hs @@ -20,13 +20,17 @@ import Cardano.Wallet.Launch.Cluster.Config , TestnetMagic (testnetMagicToNatural) ) import Cardano.Wallet.Launch.Cluster.FileOf - ( FileOf (..) + ( DirOf (..) + , FileOf (..) + , absFilePathOf + , toFilePath ) import Control.Monad.Reader ( MonadReader (..) ) -import System.FilePath - ( () +import System.Path + ( relFile + , () ) genSinkAddress @@ -35,16 +39,16 @@ genSinkAddress -> ClusterM String genSinkAddress stakePub = do Config{..} <- ask - let outputDir = cfgClusterDir - let sinkPrv = pathOf outputDir "sink.prv" - let sinkPub = pathOf outputDir "sink.pub" + let DirOf outputDir = cfgClusterDir + let sinkPrv = outputDir relFile "sink.prv" + let sinkPub = outputDir relFile "sink.pub" cli [ "address" , "key-gen" , "--signing-key-file" - , sinkPrv + , toFilePath sinkPrv , "--verification-key-file" - , sinkPub + , toFilePath sinkPub ] cliLine $ [ "address" @@ -52,8 +56,8 @@ genSinkAddress stakePub = do , "--testnet-magic" , show (testnetMagicToNatural cfgTestnetMagic) , "--payment-verification-key-file" - , sinkPub + , toFilePath sinkPub ] ++ case stakePub of Nothing -> [] - Just key -> ["--stake-verification-key-file", pathOf key] + Just key -> ["--stake-verification-key-file", absFilePathOf key] diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/StakeCertificates.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/StakeCertificates.hs index 6a2b550cf1f..a487bc12401 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/StakeCertificates.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/StakeCertificates.hs @@ -22,7 +22,9 @@ import Cardano.Wallet.Launch.Cluster.Config ( Config (..) ) import Cardano.Wallet.Launch.Cluster.FileOf - ( FileOf (..) + ( DirOf (..) + , FileOf (..) + , toFilePath ) import Control.Monad.Reader ( asks @@ -33,8 +35,10 @@ import Data.Tagged ( Tagged (..) , untag ) -import System.FilePath - ( () +import System.Path + ( relFile + , (<.>) + , () ) -- | Create a stake address registration certificate from a vk @@ -42,25 +46,25 @@ issueStakeVkCert :: Tagged "prefix" String -> FileOf "stake-pub" -> ClusterM (FileOf "stake-vk-cert") -issueStakeVkCert prefix stakePub = do - outputDir <- asks cfgClusterDir +issueStakeVkCert prefix (FileOf stakePub) = do + DirOf outputDir <- asks cfgClusterDir lastHardFork <- asks cfgLastHardFork - let file = pathOf outputDir untag prefix <> "-stake.cert" + let certPath = outputDir relFile (untag prefix <> "-stake") <.> "cert" cli $ [ clusterEraToString lastHardFork , "stake-address" , "registration-certificate" , "--staking-verification-key-file" - , pathOf stakePub + , toFilePath stakePub , "--out-file" - , file + , toFilePath certPath ] <> case lastHardFork of BabbageHardFork -> [] ConwayHardFork -> [ "--key-reg-deposit-amt" , "1000000" ] - pure $ FileOf file + pure $ FileOf certPath -- | Create a stake address registration certificate from a script issueStakeScriptCert @@ -68,14 +72,14 @@ issueStakeScriptCert -> FilePath -> ClusterM (FileOf "stake-script-cert") issueStakeScriptCert prefix stakeScript = do - outputDir <- asks cfgClusterDir - let file = pathOf outputDir untag prefix <> "-stake.cert" + DirOf outputDir <- asks cfgClusterDir + let certPath = outputDir relFile (untag prefix <> "-stake") <.> "cert" cli [ "stake-address" , "registration-certificate" , "--stake-script-file" , stakeScript , "--out-file" - , file + , toFilePath certPath ] - pure $ FileOf file + pure $ FileOf certPath diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Tx.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Tx.hs index 605d2a6f01d..2da9a1170a9 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Tx.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Tx.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} module Cardano.Wallet.Launch.Cluster.Tx ( signAndSubmitTx @@ -28,7 +27,10 @@ import Cardano.Wallet.Launch.Cluster.Config , TestnetMagic (testnetMagicToNatural) ) import Cardano.Wallet.Launch.Cluster.FileOf - ( FileOf (..) + ( DirOf (..) + , FileOf (..) + , absFilePathOf + , toFilePath ) import Control.Monad.Reader ( MonadIO (..) @@ -43,6 +45,9 @@ import Data.Tagged import System.IO.Temp ( emptyTempFile ) +import System.Path + ( absFile + ) import qualified Data.Text as T @@ -55,21 +60,26 @@ signTx -> ClusterM (FileOf "tx-signed") signTx rawTx keys = do Config{..} <- ask - let outputDir = cfgClusterDir - file <- liftIO $ emptyTempFile (pathOf outputDir) "tx-signed.json" + let DirOf outputDir = cfgClusterDir + signedTxPath <- + fmap absFile + $ liftIO + $ emptyTempFile (toFilePath outputDir) "tx-signed.json" cli $ [ clusterEraToString cfgLastHardFork , "transaction" , "sign" , "--tx-body-file" - , pathOf rawTx + , absFilePathOf rawTx , "--testnet-magic" , show (testnetMagicToNatural cfgTestnetMagic) , "--out-file" - , file + , toFilePath signedTxPath ] - ++ concatMap (\key -> ["--signing-key-file", pathOf key]) keys - pure $ FileOf @"tx-signed" file + ++ concatMap + (\key -> ["--signing-key-file", absFilePathOf key]) + keys + pure $ FileOf signedTxPath -- | Submit a transaction through a running node. submitTx @@ -86,7 +96,7 @@ submitTx conn name signedTx = do , "transaction" , "submit" , "--tx-file" - , pathOf signedTx + , absFilePathOf signedTx , "--testnet-magic" , show (testnetMagicToNatural cfgTestnetMagic) , "--cardano-mode" diff --git a/lib/local-cluster/lib/Cardano/Wallet/LocalCluster.hs b/lib/local-cluster/lib/Cardano/Wallet/LocalCluster.hs index 0262548abc3..8846c726e37 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/LocalCluster.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/LocalCluster.hs @@ -35,7 +35,10 @@ import Cardano.Wallet.Launch.Cluster , withFaucet ) import Cardano.Wallet.Launch.Cluster.FileOf - ( FileOf (..) + ( Absolutizer (..) + , DirOf (..) + , mkRelDirOf + , newAbsolutizer ) import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) @@ -63,6 +66,10 @@ import System.IO.Temp.Extra ( SkipCleanup (..) , withSystemTempDir ) +import System.Path + ( absDir + , absRel + ) import UnliftIO.Concurrent ( threadDelay ) @@ -205,7 +212,9 @@ main = withUtf8 $ do clusterEra <- Cluster.clusterEraFromEnv cfgNodeLogging <- Cluster.logFileConfigFromEnv - (Just (Cluster.clusterEraToString clusterEra)) + $ Just + $ mkRelDirOf + $ Cluster.clusterEraToString clusterEra CommandLineOptions{clusterConfigsDir} <- parseCommandLineOptions withSystemTempDir tr "test-cluster" skipCleanup $ \clusterPath -> do let clusterCfg = @@ -213,7 +222,7 @@ main = withUtf8 $ do { cfgStakePools = Cluster.defaultPoolConfigs , cfgLastHardFork = clusterEra , cfgNodeLogging - , cfgClusterDir = FileOf clusterPath + , cfgClusterDir = DirOf (absDir clusterPath) , cfgClusterConfigs = clusterConfigsDir , cfgTestnetMagic = Cluster.TestnetMagic 42 , cfgShelleyGenesisMods = [over #sgSlotLength \_ -> 0.2] @@ -257,26 +266,29 @@ main = withUtf8 $ do Nothing , WC.walletByronGenesisForTestnet = Just - $ clusterDir Path. [Path.relfile|genesis-byron.json|] + $ clusterDir Path. [Path.relfile|byron-genesis.json|] } ) (WC.stop . fst) threadDelay maxBound -- wait for Ctrl+C newtype CommandLineOptions = CommandLineOptions - {clusterConfigsDir :: FileOf "cluster-configs"} + {clusterConfigsDir :: DirOf "cluster-configs"} deriving stock (Show) parseCommandLineOptions :: IO CommandLineOptions -parseCommandLineOptions = +parseCommandLineOptions = do + absolutizer <- newAbsolutizer O.execParser $ O.info - (fmap CommandLineOptions clusterConfigsDirParser <**> O.helper) + ( fmap CommandLineOptions (clusterConfigsDirParser absolutizer) + <**> O.helper + ) (O.progDesc "Local Cluster for testing") -clusterConfigsDirParser :: O.Parser (FileOf "cluster-configs") -clusterConfigsDirParser = - FileOf +clusterConfigsDirParser :: Absolutizer -> O.Parser (DirOf "cluster-configs") +clusterConfigsDirParser (Absolutizer absOf) = + DirOf . absOf . absRel <$> O.strOption ( O.long "cluster-configs" <> O.metavar "LOCAL_CLUSTER_CONFIGS" diff --git a/lib/local-cluster/local-cluster.cabal b/lib/local-cluster/local-cluster.cabal index 2dedf1a8529..fad36356981 100644 --- a/lib/local-cluster/local-cluster.cabal +++ b/lib/local-cluster/local-cluster.cabal @@ -110,6 +110,7 @@ library , ouroboros-network-api , path , path-io + , pathtype , resourcet , retry , servant-client diff --git a/lib/unit/cardano-wallet-unit.cabal b/lib/unit/cardano-wallet-unit.cabal index 250417dbb2f..6437c2064cb 100644 --- a/lib/unit/cardano-wallet-unit.cabal +++ b/lib/unit/cardano-wallet-unit.cabal @@ -144,6 +144,7 @@ test-suite unit , ouroboros-consensus , ouroboros-network , ouroboros-network-api + , pathtype , persistent , persistent-sqlite , pretty-simple diff --git a/lib/unit/test/unit/Cardano/Wallet/Shelley/NetworkSpec.hs b/lib/unit/test/unit/Cardano/Wallet/Shelley/NetworkSpec.hs index 37fd1c41534..0ca38dacb66 100644 --- a/lib/unit/test/unit/Cardano/Wallet/Shelley/NetworkSpec.hs +++ b/lib/unit/test/unit/Cardano/Wallet/Shelley/NetworkSpec.hs @@ -22,13 +22,15 @@ import Cardano.Wallet.Launch.Cluster , ClusterLog (..) , Config (..) , FaucetFunds (..) - , FileOf (..) , LogFileConfig (..) , RunningNode (..) , defaultPoolConfigs , localClusterConfigsFromEnv , withCluster ) +import Cardano.Wallet.Launch.Cluster.FileOf + ( DirOf (..) + ) import Cardano.Wallet.Network ( NetworkLayer (..) ) @@ -80,6 +82,9 @@ import System.IO.Temp.Extra ( SkipCleanup (..) , withSystemTempDir ) +import System.Path + ( absDir + ) import Test.Hspec ( Spec , beforeAll @@ -141,21 +146,28 @@ concurrentConnectionSpec = describe "NetworkLayer regression test #1708" $ do traceSpec $ it "Parallel local socket connections" $ \tr -> withTestNode nullTracer $ \np sock vData -> do let sTol = SyncTolerance 60 - tasks <- replicateM 10 $ async $ - withNetworkLayer tr + tasks <- replicateM 10 + $ async + $ withNetworkLayer + tr tunedForMainnetPipeliningStrategy - np sock vData sTol $ \nl -> do - -- Wait for the first tip result from the node - waiter <- newEmptyMVar - race_ - (watchNodeTip nl (putMVar waiter)) - (takeMVar waiter) + np + sock + vData + sTol + $ \nl -> do + -- Wait for the first tip result from the node + waiter <- newEmptyMVar + race_ + (watchNodeTip nl (putMVar waiter)) + (takeMVar waiter) void $ waitAnyCancel tasks observerSpec :: Spec observerSpec = sequential $ describe "Observer" $ do it "can fetch all observed keys, but not any other keys" - $ property $ \keys1 keys2 -> monadicIO $ do + $ property + $ \keys1 keys2 -> monadicIO $ do (observer, refresh, _trVar) <- run mockObserver run $ mapM_ (startObserving observer) keys1 run $ refresh True @@ -166,11 +178,13 @@ observerSpec = sequential $ describe "Observer" $ do observedValues <- run $ queryKeys observer keys1 - assertEqual "observed keys return expected values" + assertEqual + "observed keys return expected values" observedValues (fromKeysWith (Just . length) keys1) - assertEqual "unobserved keys are all Nothing when queried" + assertEqual + "unobserved keys are all Nothing when queried" unobservedValues (allNothing unobservedKeys) @@ -188,7 +202,7 @@ observerSpec = sequential $ describe "Observer" $ do -- They also use smaller @it@ blocks, with more @describe@ nesting, -- than much of the rest of the wallet tests. This is done for -- concise and readable test output. - let k = ("k"::String) + let k = ("k" :: String) let v = length k describe "startObserving" $ do it "(query k) returns Nothing before startObserving" @@ -197,7 +211,8 @@ observerSpec = sequential $ describe "Observer" $ do trVar `shouldHaveTraced` [] refresh True (query observer k) `shouldReturn` Nothing - trVar `shouldHaveTraced` + shouldHaveTraced + trVar [ MsgWillFetch Set.empty , MsgDidFetch Map.empty ] @@ -207,12 +222,13 @@ observerSpec = sequential $ describe "Observer" $ do startObserving observer k refresh True let expectedValue = length k - (query observer k)`shouldReturn` Just expectedValue + query observer k `shouldReturn` Just expectedValue -- NOTE: Depends on the @refresh@ call from the previous test. it "traced MsgAddedObserver, MsgWillFetch, MsgDidFetch" $ \(_, _, trVar) -> do - trVar `shouldHaveTraced` + shouldHaveTraced + trVar [ MsgAddedObserver k , MsgWillFetch $ Set.singleton k , MsgDidFetch $ Map.singleton k v @@ -223,10 +239,11 @@ observerSpec = sequential $ describe "Observer" $ do it "(query k) is still v" $ \(observer, refresh, trVar) -> do startObserving observer k - (query observer k) `shouldReturn` (Just v) + query observer k `shouldReturn` Just v refresh True - (query observer k) `shouldReturn` (Just v) - trVar `shouldHaveTraced` + query observer k `shouldReturn` Just v + shouldHaveTraced + trVar [ MsgWillFetch $ Set.singleton k , MsgDidFetch $ Map.singleton k v ] @@ -235,23 +252,24 @@ observerSpec = sequential $ describe "Observer" $ do it "(query k) returns the existing v" $ \(observer, refresh, _) -> do refresh False - (query observer k) `shouldReturn` Just v + query observer k `shouldReturn` Just v it "only MsgWillFetch is traced" $ \(_, _, trVar) -> do - trVar `shouldHaveTraced` - [ MsgWillFetch $ Set.singleton k - ] + shouldHaveTraced + trVar + [ MsgWillFetch $ Set.singleton k + ] - describe "stopObserving" $ - it "makes (query k) return Nothing" - $ \(observer, refresh, _) -> do - stopObserving observer k - (query observer k) `shouldReturn` Nothing - refresh True - (query observer k) `shouldReturn` Nothing + describe "stopObserving" + $ it "makes (query k) return Nothing" + $ \(observer, refresh, _) -> do + stopObserving observer k + query observer k `shouldReturn` Nothing + refresh True + query observer k `shouldReturn` Nothing where - -- | Expects given messages to have been traced /and/ clears the @TVar@. + -- \| Expects given messages to have been traced /and/ clears the @TVar@. -- -- NOTE: Reverses the contents in the @TVar@ to get a chronological order. shouldHaveTraced :: (Show log, Eq log) => TVar [log] -> [log] -> IO () @@ -262,29 +280,33 @@ observerSpec = sequential $ describe "Observer" $ do fromKeysWith :: Ord k => (k -> v) -> Set k -> Map k v fromKeysWith f = Map.fromList - . map (\k -> (k, f k)) - . Set.toList + . map (\k -> (k, f k)) + . Set.toList queryKeys :: (Monad m, Ord k) => Observer m k v -> Set k -> m (Map k (Maybe v)) - queryKeys observer keys = Map.fromList <$> mapM - (\k -> query observer k >>= \v -> return (k, v)) - (Set.toList keys) + queryKeys observer keys = + Map.fromList + <$> mapM + (\k -> query observer k >>= \v -> return (k, v)) + (Set.toList keys) mockObserver - :: IO ( Observer IO String Int - , Bool -> IO () - , TVar [ObserverLog String Int] - ) + :: IO + ( Observer IO String Int + , Bool -> IO () + , TVar [ObserverLog String Int] + ) mockObserver = do trVar <- newTVarIO [] (ob, refresh) <- newObserver (traceInTVarIO trVar) fetch return (ob, refresh, trVar) where - fetch True keys = pure - $ Just - $ Map.fromList - $ map (\x -> (x,length x)) - $ Set.toList keys + fetch True keys = + pure + $ Just + $ Map.fromList + $ map (\x -> (x, length x)) + $ Set.toList keys fetch False _ = pure Nothing -- Assert equiality in monadic properties with nice counterexamples @@ -300,11 +322,15 @@ observerSpec = sequential $ describe "Observer" $ do let flag = if condition then "✓" else "✗" monitor (counterexample $ description <> " " <> flag) unless condition $ do - monitor $ counterexample $ fmt $ indentF 4 $ mconcat - [ build $ show a - , "\n/=\n" - , build $ show b - ] + monitor + $ counterexample + $ fmt + $ indentF 4 + $ mconcat + [ build $ show a + , "\n/=\n" + , build $ show b + ] assert condition withTestNode @@ -313,21 +339,22 @@ withTestNode -> IO a withTestNode tr action = do skipCleanup <- SkipCleanup <$> isEnvSet "NO_CLEANUP" - withSystemTempDir (contramap MsgTempDir tr) "network-spec" skipCleanup $ - \dir -> do + withSystemTempDir (contramap MsgTempDir tr) "network-spec" skipCleanup + $ \dir -> do cfgClusterConfigs <- localClusterConfigsFromEnv - let clusterConfig = Cluster.Config - { cfgStakePools = defaultPoolConfigs - , cfgLastHardFork = BabbageHardFork - , cfgNodeLogging = LogFileConfig Info Nothing Info - , cfgClusterDir = FileOf @"cluster" dir - , cfgClusterConfigs - , cfgTestnetMagic = Cluster.TestnetMagic 42 - , cfgShelleyGenesisMods = [] - , cfgTracer = tr - , cfgNodeOutputFile = Nothing - } - withCluster clusterConfig (FaucetFunds [] [] []) $ - \(RunningNode sock genesisData vData) -> do - let (np, _, _ ) = fromGenesisData genesisData + let clusterConfig = + Cluster.Config + { cfgStakePools = defaultPoolConfigs + , cfgLastHardFork = BabbageHardFork + , cfgNodeLogging = LogFileConfig Info Nothing Info + , cfgClusterDir = DirOf @"cluster" $ absDir dir + , cfgClusterConfigs + , cfgTestnetMagic = Cluster.TestnetMagic 42 + , cfgShelleyGenesisMods = [] + , cfgTracer = tr + , cfgNodeOutputFile = Nothing + } + withCluster clusterConfig (FaucetFunds [] [] []) + $ \(RunningNode sock genesisData vData) -> do + let (np, _, _) = fromGenesisData genesisData action np sock vData From 37e5d4e4e6cfe2b6691fef1bdaa05fc73d461267 Mon Sep 17 00:00:00 2001 From: paolino Date: Mon, 22 Apr 2024 14:53:43 +0000 Subject: [PATCH 2/2] Subsitute `path` lib with `pathtype` --- .../lib/Cardano/Node/Cli/Launcher.hs | 40 ++++---- .../lib/Cardano/Wallet/Cli/Launcher.hs | 36 +++---- .../lib/Cardano/Wallet/LocalCluster.hs | 36 ++++--- lib/local-cluster/local-cluster.cabal | 2 - lib/wallet-e2e/cardano-wallet-e2e.cabal | 8 +- lib/wallet-e2e/exe/Main.hs | 8 +- lib/wallet-e2e/src/Cardano/Wallet/Spec.hs | 6 +- .../src/Cardano/Wallet/Spec/Effect/Trace.hs | 32 +++---- .../Wallet/Spec/Interpreters/Config.hs | 3 +- .../Cardano/Wallet/Spec/Interpreters/Pure.hs | 21 ++-- .../src/Cardano/Wallet/Spec/Lib/Paths.hs | 26 ----- .../src/Cardano/Wallet/Spec/Network/Local.hs | 25 ++--- .../Cardano/Wallet/Spec/Network/Node/Cli.hs | 6 +- .../Cardano/Wallet/Spec/Network/Preprod.hs | 36 ++++--- .../Cardano/Wallet/Spec}/Options.hs | 95 +++++++++---------- 15 files changed, 169 insertions(+), 211 deletions(-) delete mode 100644 lib/wallet-e2e/src/Cardano/Wallet/Spec/Lib/Paths.hs rename lib/wallet-e2e/{exe => src/Cardano/Wallet/Spec}/Options.hs (52%) diff --git a/lib/local-cluster/lib/Cardano/Node/Cli/Launcher.hs b/lib/local-cluster/lib/Cardano/Node/Cli/Launcher.hs index 1e867ebf44d..7add0de7c70 100644 --- a/lib/local-cluster/lib/Cardano/Node/Cli/Launcher.hs +++ b/lib/local-cluster/lib/Cardano/Node/Cli/Launcher.hs @@ -1,23 +1,25 @@ -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-} module Cardano.Node.Cli.Launcher where import Prelude -import Path - ( Abs - , Dir - , File - , Path - , relfile +import Cardano.Wallet.Launch.Cluster.FileOf + ( DirOf (..) + , FileOf + , absFilePathOf , toFilePath - , () ) import System.IO ( IOMode (AppendMode) , openFile ) +import System.Path + ( AbsFile + , relFile + , () + ) import System.Process.Typed ( Process , proc @@ -30,8 +32,8 @@ import System.Process.Typed start :: NodeProcessConfig -> IO (NodeInstance, NodeApi) start NodeProcessConfig{..} = do - let nodeSocket = nodeDir [relfile|node.sock|] - let nodeLog = nodeDir [relfile|node.log|] + let nodeSocket = absDirOf nodeDir relFile "node.sock" + let nodeLog = absDirOf nodeDir relFile "node.log" handle <- openFile (toFilePath nodeLog) AppendMode putStrLn $ "Writing node logs to " <> toFilePath nodeLog nodeProcess <- @@ -42,11 +44,11 @@ start NodeProcessConfig{..} = do "cardano-node" [ "run" , "--config" - , toFilePath nodeConfig + , absFilePathOf nodeConfig , "--topology" - , toFilePath nodeTopology + , absFilePathOf nodeTopology , "--database-path" - , toFilePath nodeDatabase + , toFilePath $ absDirOf nodeDatabase , "--socket-path" , toFilePath nodeSocket , "+RTS" @@ -62,16 +64,16 @@ stop (NodeInstance process) = do -------------------------------------------------------------------------------- -- Data types ------------------------------------------------------------------ -newtype NodeApi = NodeApi (Path Abs File) +newtype NodeApi = NodeApi AbsFile -nodeApiSocket :: NodeApi -> Path Abs File +nodeApiSocket :: NodeApi -> AbsFile nodeApiSocket (NodeApi socket) = socket data NodeProcessConfig = NodeProcessConfig - { nodeDir :: Path Abs Dir - , nodeConfig :: Path Abs File - , nodeTopology :: Path Abs File - , nodeDatabase :: Path Abs Dir + { nodeDir :: DirOf "node" + , nodeConfig :: FileOf "node-config" + , nodeTopology :: FileOf "node-topology" + , nodeDatabase :: DirOf "db" } newtype NodeInstance = NodeInstance (Process () () ()) diff --git a/lib/local-cluster/lib/Cardano/Wallet/Cli/Launcher.hs b/lib/local-cluster/lib/Cardano/Wallet/Cli/Launcher.hs index 4684b57d69f..5a4d686537f 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Cli/Launcher.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Cli/Launcher.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-} module Cardano.Wallet.Cli.Launcher @@ -17,25 +17,25 @@ import Cardano.Node.Cli.Launcher ( NodeApi , nodeApiSocket ) +import Cardano.Wallet.Launch.Cluster.FileOf + ( DirOf (..) + , FileOf (..) + , toFilePath + ) import Data.Maybe ( fromMaybe ) import Data.Text ( Text ) -import Path - ( Abs - , Dir - , File - , Path - , relfile - , toFilePath - , () - ) import System.IO ( IOMode (AppendMode) , openFile ) +import System.Path + ( relFile + , () + ) import System.Process.Typed ( Process , proc @@ -55,12 +55,12 @@ data WalletApi = WalletApi } data WalletProcessConfig = WalletProcessConfig - { walletDir :: Path Abs Dir + { walletDir :: DirOf "wallet" , walletNodeApi :: NodeApi - , walletDatabase :: Path Abs Dir + , walletDatabase :: DirOf "db" , walletListenHost :: Maybe Text , walletListenPort :: Maybe Int - , walletByronGenesisForTestnet :: Maybe (Path Abs File) + , walletByronGenesisForTestnet :: Maybe (FileOf "byron-genesis-testnet") } start :: WalletProcessConfig -> IO (WalletInstance, WalletApi) @@ -74,7 +74,7 @@ start WalletProcessConfig{..} = do , walletInstanceApiHost = host , walletInstanceApiPort = port } - let walletLog = walletDir [relfile|wallet.log|] + let walletLog = absDirOf walletDir relFile "wallet.log" handle <- openFile (toFilePath walletLog) AppendMode putStrLn $ "Writing wallet logs to " <> toFilePath walletLog process <- @@ -87,12 +87,14 @@ start WalletProcessConfig{..} = do , case walletByronGenesisForTestnet of Nothing -> [ "--mainnet" ] - Just waleltByronGenesis -> - [ "--testnet", toFilePath waleltByronGenesis ] + Just walletByronGenesis -> + [ "--testnet", toFilePath + $ absFileOf walletByronGenesis + ] , [ "--node-socket" , toFilePath (nodeApiSocket walletNodeApi) , "--database" - , toFilePath walletDatabase + , toFilePath $ absDirOf walletDatabase , "--listen-address" , T.unpack host , "--port" diff --git a/lib/local-cluster/lib/Cardano/Wallet/LocalCluster.hs b/lib/local-cluster/lib/Cardano/Wallet/LocalCluster.hs index 8846c726e37..76820710dbe 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/LocalCluster.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/LocalCluster.hs @@ -2,12 +2,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Cardano.Wallet.LocalCluster where @@ -31,14 +28,17 @@ import Cardano.Wallet.Faucet ( runFaucetM ) import Cardano.Wallet.Launch.Cluster - ( FaucetFunds (..) + ( Config (..) + , FaucetFunds (..) , withFaucet ) import Cardano.Wallet.Launch.Cluster.FileOf ( Absolutizer (..) , DirOf (..) + , FileOf (..) , mkRelDirOf , newAbsolutizer + , toFilePath ) import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) @@ -59,6 +59,9 @@ import Control.Monad.Trans.Resource import Main.Utf8 ( withUtf8 ) +import System.Directory + ( createDirectoryIfMissing + ) import System.Environment.Extended ( isEnvSet ) @@ -69,6 +72,10 @@ import System.IO.Temp.Extra import System.Path ( absDir , absRel + , parse + , relDir + , relFile + , () ) import UnliftIO.Concurrent ( threadDelay @@ -79,8 +86,6 @@ import qualified Cardano.Wallet.Cli.Launcher as WC import qualified Cardano.Wallet.Faucet as Faucet import qualified Cardano.Wallet.Launch.Cluster as Cluster import qualified Options.Applicative as O -import qualified Path -import qualified Path.IO as PathIO -- | -- # OVERVIEW @@ -242,12 +247,14 @@ main = withUtf8 $ do , massiveWalletFunds = [] } $ \node -> do - clusterDir <- Path.parseAbsDir clusterPath - let walletDir = clusterDir Path. [Path.reldir|wallet|] - PathIO.createDirIfMissing False walletDir + let clusterDir = absDir clusterPath + let walletDir = clusterDir relDir "wallet" + createDirectoryIfMissing True $ toFilePath walletDir nodeSocket <- - Path.parseAbsFile . nodeSocketFile - $ Cluster.runningNodeSocketPath node + case parse . nodeSocketFile + $ Cluster.runningNodeSocketPath node of + Left e -> error e + Right p -> pure p runResourceT do (_releaseKey, (_walletInstance, _walletApi)) <- @@ -255,18 +262,19 @@ main = withUtf8 $ do ( WC.start WC.WalletProcessConfig { WC.walletDir = - walletDir + DirOf walletDir , WC.walletNodeApi = NC.NodeApi nodeSocket , WC.walletDatabase = - clusterDir Path. [Path.reldir|db|] + DirOf $ clusterDir relDir "db" , WC.walletListenHost = Nothing , WC.walletListenPort = Nothing , WC.walletByronGenesisForTestnet = Just - $ clusterDir Path. [Path.relfile|byron-genesis.json|] + $ FileOf $ clusterDir + relFile "byron-genesis.json" } ) (WC.stop . fst) diff --git a/lib/local-cluster/local-cluster.cabal b/lib/local-cluster/local-cluster.cabal index fad36356981..c104ba76b53 100644 --- a/lib/local-cluster/local-cluster.cabal +++ b/lib/local-cluster/local-cluster.cabal @@ -108,8 +108,6 @@ library , optparse-applicative , ouroboros-network , ouroboros-network-api - , path - , path-io , pathtype , resourcet , retry diff --git a/lib/wallet-e2e/cardano-wallet-e2e.cabal b/lib/wallet-e2e/cardano-wallet-e2e.cabal index ecc49e1aebf..f7e2d3a6df9 100644 --- a/lib/wallet-e2e/cardano-wallet-e2e.cabal +++ b/lib/wallet-e2e/cardano-wallet-e2e.cabal @@ -72,8 +72,8 @@ library , http-client ^>=0.7.13.1 , http-types ^>=0.12.3 , local-cluster ^>=0.1 - , path ^>=0.9.2 - , path-io ^>=1.7.0 + , optparse-applicative ^>=0.17.1 + , pathtype , random ^>=1.2.1.1 , relude ^>=1.2.0.0 , resourcet ^>=1.3 @@ -87,6 +87,7 @@ library exposed-modules: Cardano.Wallet.Spec + Cardano.Wallet.Spec.Options Cardano.Wallet.Spec.Data.AdaBalance Cardano.Wallet.Spec.Data.Network.Info Cardano.Wallet.Spec.Data.Network.NodeStatus @@ -104,7 +105,6 @@ library Cardano.Wallet.Spec.Interpreters.Config Cardano.Wallet.Spec.Interpreters.Effectfully Cardano.Wallet.Spec.Interpreters.Pure - Cardano.Wallet.Spec.Lib.Paths Cardano.Wallet.Spec.Network.Configured Cardano.Wallet.Spec.Network.Local Cardano.Wallet.Spec.Network.Manual @@ -121,12 +121,10 @@ executable wallet-e2e hs-source-dirs: exe main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N - other-modules: Options build-depends: , base , cardano-wallet-e2e , optparse-applicative ^>=0.17.1 - , path , relude , sydtest , tagged diff --git a/lib/wallet-e2e/exe/Main.hs b/lib/wallet-e2e/exe/Main.hs index e866dfdf06f..4ac2697cab5 100644 --- a/lib/wallet-e2e/exe/Main.hs +++ b/lib/wallet-e2e/exe/Main.hs @@ -1,17 +1,15 @@ -module Main where - import qualified Test.Syd.OptParse as SydTest import Cardano.Wallet.Spec ( effectsSpec , walletSpec ) +import Cardano.Wallet.Spec.Options + ( withTestOptions + ) import Main.Utf8 ( withUtf8 ) -import Options - ( withTestOptions - ) import Test.Syd ( sydTestWith ) diff --git a/lib/wallet-e2e/src/Cardano/Wallet/Spec.hs b/lib/wallet-e2e/src/Cardano/Wallet/Spec.hs index 68c1b2a9c9f..96beb19bdb8 100644 --- a/lib/wallet-e2e/src/Cardano/Wallet/Spec.hs +++ b/lib/wallet-e2e/src/Cardano/Wallet/Spec.hs @@ -8,15 +8,15 @@ import qualified Cardano.Wallet.Spec.Network.Local as Local import qualified Cardano.Wallet.Spec.Network.Manual as Manual import qualified Cardano.Wallet.Spec.Network.Preprod as Preprod +import Cardano.Wallet.Launch.Cluster.FileOf + ( DirOf + ) import Cardano.Wallet.Spec.Interpreters.Config ( TraceConfiguration ) import Cardano.Wallet.Spec.Interpreters.Effectfully ( story ) -import Cardano.Wallet.Spec.Lib.Paths - ( DirOf - ) import Cardano.Wallet.Spec.Network.Configured ( ConfiguredNetwork ) diff --git a/lib/wallet-e2e/src/Cardano/Wallet/Spec/Effect/Trace.hs b/lib/wallet-e2e/src/Cardano/Wallet/Spec/Effect/Trace.hs index 12e35834048..1f4c65e047a 100644 --- a/lib/wallet-e2e/src/Cardano/Wallet/Spec/Effect/Trace.hs +++ b/lib/wallet-e2e/src/Cardano/Wallet/Spec/Effect/Trace.hs @@ -5,15 +5,16 @@ module Cardano.Wallet.Spec.Effect.Trace where import qualified Data.Sequence as Seq +import Cardano.Wallet.Launch.Cluster.FileOf + ( DirOf (..) + , toFilePath + ) import Cardano.Wallet.Spec.Interpreters.Config ( TraceConfiguration (..) ) import Data.Sequence ( (|>) ) -import Data.Tagged - ( Tagged (..) - ) import Effectful ( Eff , Effect @@ -28,19 +29,19 @@ import Effectful.State.Static.Local import Effectful.TH ( makeEffect ) -import Path - ( parseRelFile - , toFilePath - , () - ) -import Path.IO - ( ensureDir - ) import Prelude hiding ( modify , runState , trace ) +import System.Path + ( relFile + , (<.>) + , () + ) +import System.Path.Directory + ( createDirectoryIfMissing + ) data FxTrace :: Effect where Trace :: Text -> FxTrace m () @@ -52,10 +53,9 @@ runTracePure = reinterpret (runState Seq.empty) \_ (Trace msg) -> modify (|> msg) recordTraceLog :: TraceConfiguration -> String -> Seq Text -> IO () -recordTraceLog (TraceConfiguration (Tagged outDir)) storyLabel log = do - ensureDir outDir - fileName <- - parseRelFile - $ [if c == ' ' then '_' else c | c <- storyLabel] <> ".log" +recordTraceLog (TraceConfiguration (DirOf outDir)) storyLabel log = do + createDirectoryIfMissing True outDir + let fileName = relFile + [if c == ' ' then '_' else c | c <- storyLabel] <.> "log" let outFile = outDir fileName writeFile (toFilePath outFile) $ toString $ unlines $ toList log diff --git a/lib/wallet-e2e/src/Cardano/Wallet/Spec/Interpreters/Config.hs b/lib/wallet-e2e/src/Cardano/Wallet/Spec/Interpreters/Config.hs index 146e012573c..3085681151a 100644 --- a/lib/wallet-e2e/src/Cardano/Wallet/Spec/Interpreters/Config.hs +++ b/lib/wallet-e2e/src/Cardano/Wallet/Spec/Interpreters/Config.hs @@ -1,6 +1,5 @@ module Cardano.Wallet.Spec.Interpreters.Config where - -import Cardano.Wallet.Spec.Lib.Paths +import Cardano.Wallet.Launch.Cluster.FileOf ( DirOf ) diff --git a/lib/wallet-e2e/src/Cardano/Wallet/Spec/Interpreters/Pure.hs b/lib/wallet-e2e/src/Cardano/Wallet/Spec/Interpreters/Pure.hs index 6000652eb34..e04eef542fe 100644 --- a/lib/wallet-e2e/src/Cardano/Wallet/Spec/Interpreters/Pure.hs +++ b/lib/wallet-e2e/src/Cardano/Wallet/Spec/Interpreters/Pure.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} - module Cardano.Wallet.Spec.Interpreters.Pure ( pureStory , PureStory @@ -11,6 +9,9 @@ import qualified Effectful.Error.Static as E import Cardano.Mnemonic ( SomeMnemonic (..) ) +import Cardano.Wallet.Launch.Cluster.FileOf + ( DirOf (..) + ) import Cardano.Wallet.Spec.Effect.Assert ( FxAssert , runAssertFailsFast @@ -34,9 +35,6 @@ import Cardano.Wallet.Spec.Interpreters.Config import Cardano.Wallet.Unsafe ( unsafeMkMnemonic ) -import Data.Tagged - ( Tagged (..) - ) import Effectful ( Eff , runPureEff @@ -48,11 +46,9 @@ import Effectful.Fail import GHC.IO ( unsafePerformIO ) -import Path.IO - ( makeAbsolute - ) -import Path.Posix - ( reldir +import System.Path + ( absRel + , dynamicMakeAbsoluteFromCwd ) import Test.Syd ( TestDefM @@ -75,9 +71,10 @@ defaultTraceConfiguration :: TraceConfiguration defaultTraceConfiguration = TraceConfiguration { traceConfigurationDir = - Tagged @"tracing-dir" + DirOf @"tracing-dir" $ unsafePerformIO - $ makeAbsolute [reldir|lib/wallet-e2e/test-output|] + $ dynamicMakeAbsoluteFromCwd + $ absRel "lib/wallet-e2e/test-output" } pureStory :: String -> PureStory a -> TestDefM outers () () diff --git a/lib/wallet-e2e/src/Cardano/Wallet/Spec/Lib/Paths.hs b/lib/wallet-e2e/src/Cardano/Wallet/Spec/Lib/Paths.hs deleted file mode 100644 index cb587498d42..00000000000 --- a/lib/wallet-e2e/src/Cardano/Wallet/Spec/Lib/Paths.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Cardano.Wallet.Spec.Lib.Paths where - -import Data.Tagged - ( Tagged (..) - , untag - ) -import Path - ( Abs - , Dir - , Path - , SomeBase (..) - ) -import Path.IO - ( AnyPath (..) - ) - -type DirOf x = Tagged x (Path Abs Dir) -type SomeDirOf x = Tagged x (SomeBase Dir) - -makeDirAbsolute :: SomeDirOf x -> IO (DirOf x) -makeDirAbsolute = fmap Tagged . makeAbsolute' . untag - -makeAbsolute' :: SomeBase Dir -> IO (Path Abs Dir) -makeAbsolute' = \case - Abs absDir -> pure absDir - Rel relDir -> makeAbsolute relDir diff --git a/lib/wallet-e2e/src/Cardano/Wallet/Spec/Network/Local.hs b/lib/wallet-e2e/src/Cardano/Wallet/Spec/Network/Local.hs index 73b8a96be22..18700a77b65 100644 --- a/lib/wallet-e2e/src/Cardano/Wallet/Spec/Network/Local.hs +++ b/lib/wallet-e2e/src/Cardano/Wallet/Spec/Network/Local.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} - module Cardano.Wallet.Spec.Network.Local ( configuredNetwork ) where @@ -9,8 +7,9 @@ import qualified Cardano.Wallet.Spec.Network.Wait as Wait import Cardano.Wallet.Cli.Launcher ( WalletApi (..) ) -import Cardano.Wallet.Spec.Lib.Paths - ( DirOf +import Cardano.Wallet.Launch.Cluster.FileOf + ( DirOf (..) + , toFilePath ) import Cardano.Wallet.Spec.Network.Configured ( ConfiguredNetwork (..) @@ -19,17 +18,13 @@ import Control.Monad.Trans.Resource ( ResourceT , allocate ) -import Data.Tagged - ( untag - ) -import Path - ( relfile - , toFilePath - , () - ) import System.IO ( openFile ) +import System.Path + ( relFile + , () + ) import System.Process.Typed ( Process , proc @@ -44,7 +39,7 @@ configuredNetwork :: DirOf "state" -> DirOf "config" -> ResourceT IO ConfiguredNetwork -configuredNetwork stateDir clusterConfigsDir = do +configuredNetwork (DirOf stateDir) (DirOf clusterConfigsDir) = do walletApi <- startCluster unlessM (Wait.untilWalletIsConnected walletApi) do @@ -63,7 +58,7 @@ configuredNetwork stateDir clusterConfigsDir = do startLocalClusterProcess :: IO (Process () () ()) startLocalClusterProcess = do - let clusterLog = untag stateDir [relfile|cluster.log|] + let clusterLog = stateDir relFile "cluster.log" handle <- openFile (toFilePath clusterLog) AppendMode putStrLn $ "Writing cluster logs to " <> toFilePath clusterLog startProcess @@ -71,5 +66,5 @@ configuredNetwork stateDir clusterConfigsDir = do $ setStdout (useHandleClose handle) $ proc "local-cluster" [ "--cluster-configs" - , toFilePath (untag clusterConfigsDir) + , toFilePath clusterConfigsDir ] diff --git a/lib/wallet-e2e/src/Cardano/Wallet/Spec/Network/Node/Cli.hs b/lib/wallet-e2e/src/Cardano/Wallet/Spec/Network/Node/Cli.hs index 8e8d04dfae9..98e522ffca3 100644 --- a/lib/wallet-e2e/src/Cardano/Wallet/Spec/Network/Node/Cli.hs +++ b/lib/wallet-e2e/src/Cardano/Wallet/Spec/Network/Node/Cli.hs @@ -9,13 +9,13 @@ import Cardano.Node.Cli.Launcher ( NodeApi , nodeApiSocket ) +import Cardano.Wallet.Launch.Cluster.FileOf + ( toFilePath + ) import Data.Aeson ( withObject , (.:) ) -import Path - ( toFilePath - ) import Prelude hiding ( stderr , stdout diff --git a/lib/wallet-e2e/src/Cardano/Wallet/Spec/Network/Preprod.hs b/lib/wallet-e2e/src/Cardano/Wallet/Spec/Network/Preprod.hs index 93b8ee0da58..65285e3158b 100644 --- a/lib/wallet-e2e/src/Cardano/Wallet/Spec/Network/Preprod.hs +++ b/lib/wallet-e2e/src/Cardano/Wallet/Spec/Network/Preprod.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} - module Cardano.Wallet.Spec.Network.Preprod ( configuredNetwork ) where @@ -14,8 +12,9 @@ import Cardano.Node.Cli.Launcher import Cardano.Wallet.Cli.Launcher ( WalletProcessConfig (..) ) -import Cardano.Wallet.Spec.Lib.Paths - ( DirOf +import Cardano.Wallet.Launch.Cluster.FileOf + ( DirOf (DirOf) + , FileOf (..) ) import Cardano.Wallet.Spec.Network.Configured ( ConfiguredNetwork (..) @@ -24,12 +23,9 @@ import Control.Monad.Trans.Resource ( ResourceT , allocate ) -import Data.Tagged - ( untag - ) -import Path - ( reldir - , relfile +import System.Path + ( relDir + , relFile , () ) @@ -37,7 +33,7 @@ configuredNetwork :: DirOf "state" -> DirOf "config" -> ResourceT IO ConfiguredNetwork -configuredNetwork stateDir nodeConfigDir = do +configuredNetwork (DirOf stateDir) (DirOf nodeConfigDir) = do nodeApi <- startNode walletApi <- startWallet nodeApi @@ -56,32 +52,32 @@ configuredNetwork stateDir nodeConfigDir = do } where startNode = do - let nodeDir = untag stateDir [reldir|node|] + let nodeDir = stateDir relDir "node" let nodeProcessConfig = NodeProcessConfig - { nodeDir + { nodeDir = DirOf nodeDir , nodeConfig = - untag nodeConfigDir [relfile|config.json|] + FileOf $ nodeConfigDir relFile "config.json" , nodeTopology = - untag nodeConfigDir [relfile|topology.json|] + FileOf $ nodeConfigDir relFile "topology.json" , nodeDatabase = - nodeDir [reldir|db|] + DirOf $ nodeDir relDir "db" } (_nodeReleaseKey, (_nodeInstance, nodeApi)) <- allocate (Node.start nodeProcessConfig) (Node.stop . fst) pure nodeApi startWallet nodeApi = do - let walletDir = untag stateDir [reldir|wallet|] + let walletDir = stateDir relDir "wallet" let walletProcessConfig = WalletProcessConfig - { walletDir - , walletDatabase = walletDir [reldir|db|] + { walletDir = DirOf walletDir + , walletDatabase = DirOf $ walletDir relDir "db" , walletNodeApi = nodeApi , walletListenHost = Nothing , walletListenPort = Nothing , walletByronGenesisForTestnet = Just $ - untag nodeConfigDir [relfile|byron-genesis.json|] + FileOf $ nodeConfigDir relFile "byron-genesis.json" } (_walletReleaseKey, (_walletInstance, walletApi)) <- allocate (Wallet.start walletProcessConfig) (Wallet.stop . fst) diff --git a/lib/wallet-e2e/exe/Options.hs b/lib/wallet-e2e/src/Cardano/Wallet/Spec/Options.hs similarity index 52% rename from lib/wallet-e2e/exe/Options.hs rename to lib/wallet-e2e/src/Cardano/Wallet/Spec/Options.hs index d1967ff1959..b48216c6141 100644 --- a/lib/wallet-e2e/exe/Options.hs +++ b/lib/wallet-e2e/src/Cardano/Wallet/Spec/Options.hs @@ -1,20 +1,16 @@ -module Options where - -import qualified Options.Applicative as OptParse +module Cardano.Wallet.Spec.Options where +import Cardano.Wallet.Launch.Cluster.FileOf + ( Absolutizer (..) + , DirOf (..) + , newAbsolutizer + ) import Cardano.Wallet.Spec ( TestNetworkConfig (..) ) import Cardano.Wallet.Spec.Interpreters.Config ( TraceConfiguration (..) ) -import Cardano.Wallet.Spec.Lib.Paths - ( SomeDirOf - , makeDirAbsolute - ) -import Data.Tagged - ( Tagged (..) - ) import Options.Applicative ( Parser , eitherReader @@ -24,43 +20,48 @@ import Options.Applicative , option , short ) -import Path - ( parseSomeDir +import System.Path + ( Abs + , parse ) +import qualified Options.Applicative as OptParse +import qualified System.Path.PartClass as Path + withTestOptions :: (TestNetworkConfig -> TraceConfiguration -> IO b) -> IO b withTestOptions action = do + absolutizer <- newAbsolutizer TestOptions{..} :: TestOptions <- OptParse.execParser $ OptParse.info - (parserTestOptions OptParse.<**> OptParse.helper) + (parserTestOptions absolutizer OptParse.<**> OptParse.helper) (OptParse.fullDesc <> OptParse.progDesc "E2E Wallet test suite") - testNetwork <- testNetworkOptionsToConfig testNetworkOptions traceConfiguration <- do - absTraceDir <- - makeDirAbsolute - $ testGlobalOptionsTraceOutput testGlobalOptions + let absTraceDir = testGlobalOptionsTraceOutput testGlobalOptions pure $ TraceConfiguration absTraceDir - action testNetwork traceConfiguration + action testNetworkConfig traceConfiguration -parserTestOptions :: Parser TestOptions -parserTestOptions = TestOptions <$> parserNetworkOptions <*> parserGlobalOptions +parserTestOptions :: Absolutizer -> Parser TestOptions +parserTestOptions absolutizer = + TestOptions + <$> parserNetworkOptions absolutizer + <*> parserGlobalOptions absolutizer data TestOptions = TestOptions - { testNetworkOptions :: TestNetworkOptions + { testNetworkConfig :: TestNetworkConfig , testGlobalOptions :: TestGlobalOptions } newtype TestGlobalOptions = TestGlobalOptions - { testGlobalOptionsTraceOutput :: SomeDirOf "tracing-dir" + { testGlobalOptionsTraceOutput :: DirOf "tracing-dir" } -parserGlobalOptions :: Parser TestGlobalOptions -parserGlobalOptions = TestGlobalOptions <$> traceOutputOption +parserGlobalOptions :: Absolutizer -> Parser TestGlobalOptions +parserGlobalOptions absolutizer = TestGlobalOptions <$> traceOutputOption where - traceOutputOption :: Parser (SomeDirOf "tracing-dir") = + traceOutputOption :: Parser (DirOf "tracing-dir") = option - (eitherReader (bimap show Tagged . parseSomeDir)) + (eitherReader (bimap show DirOf . parseAbs absolutizer)) ( long "tracing-dir" <> short 't' <> metavar "TRACE_OUTPUT_DIR" @@ -68,32 +69,22 @@ parserGlobalOptions = TestGlobalOptions <$> traceOutputOption "Absolute or relative directory path to save trace output" ) -data TestNetworkOptions - = TestNetworkOptionManual - | TestNetworkOptionLocal (SomeDirOf "state") (SomeDirOf "config") - | TestNetworkOptionPreprod (SomeDirOf "state") (SomeDirOf "config") - -testNetworkOptionsToConfig :: TestNetworkOptions -> IO TestNetworkConfig -testNetworkOptionsToConfig = \case - TestNetworkOptionManual -> - pure TestNetworkManual - TestNetworkOptionLocal stateDir nodeConfigsDir -> do - absStateDir <- makeDirAbsolute stateDir - absNodeConfigsDir <- makeDirAbsolute nodeConfigsDir - pure (TestNetworkLocal absStateDir absNodeConfigsDir) - TestNetworkOptionPreprod stateDir nodeConfigsDir -> do - absStateDir <- makeDirAbsolute stateDir - absNodeConfigsDir <- makeDirAbsolute nodeConfigsDir - pure (TestNetworkPreprod absStateDir absNodeConfigsDir) +parseAbs :: Path.FileDir t => Absolutizer -> String -> Either String (Abs t) +parseAbs (Absolutizer absolutizer) str = do + dir <- parse str + pure $ absolutizer dir -parserNetworkOptions :: Parser TestNetworkOptions -parserNetworkOptions = OptParse.subparser $ cmdManual <> cmdLocal <> cmdPreprod +parserNetworkOptions + :: Absolutizer + -> Parser TestNetworkConfig +parserNetworkOptions absolutizer = + OptParse.subparser $ cmdManual <> cmdLocal <> cmdPreprod where cmdManual = OptParse.command "manual" ( OptParse.info - (pure TestNetworkOptionManual) + (pure TestNetworkManual) ( OptParse.progDesc "Relies on a node and wallet started manually." ) @@ -102,7 +93,7 @@ parserNetworkOptions = OptParse.subparser $ cmdManual <> cmdLocal <> cmdPreprod OptParse.command "local" ( OptParse.info - ( TestNetworkOptionLocal + ( TestNetworkLocal <$> stateDirOption <*> nodeConfigsDirOption ) @@ -112,7 +103,7 @@ parserNetworkOptions = OptParse.subparser $ cmdManual <> cmdLocal <> cmdPreprod OptParse.command "preprod" ( OptParse.info - ( TestNetworkOptionPreprod + ( TestNetworkPreprod <$> stateDirOption <*> nodeConfigsDirOption ) @@ -120,9 +111,9 @@ parserNetworkOptions = OptParse.subparser $ cmdManual <> cmdLocal <> cmdPreprod "Automatically starts a preprod node and wallet." ) ) - stateDirOption :: Parser (SomeDirOf "state") = + stateDirOption :: Parser (DirOf "state") = option - (eitherReader (bimap show Tagged . parseSomeDir)) + (eitherReader (bimap show DirOf . parseAbs absolutizer)) ( long "state-dir" <> short 's' <> metavar "STATE_DIR" @@ -130,9 +121,9 @@ parserNetworkOptions = OptParse.subparser $ cmdManual <> cmdLocal <> cmdPreprod "Absolute or relative directory path \ \ to save node and wallet state" ) - nodeConfigsDirOption :: Parser (SomeDirOf "config") = + nodeConfigsDirOption :: Parser (DirOf "config") = option - (eitherReader (bimap show Tagged . parseSomeDir)) + (eitherReader (bimap show DirOf . parseAbs absolutizer)) ( long "node-configs-dir" <> short 'c' <> metavar "NODE_CONFIGS_DIR"