Skip to content
Permalink
Browse files

CardanoConfiguration: more Partial-Options-Monoid-ification

  • Loading branch information...
deepfire committed Jul 11, 2019
1 parent ebfd9cd commit d87e0a4b87e8ac0eef328531ce0c8ecf26575cdb
@@ -76,7 +76,7 @@ createNetworkingFeature loggingLayer cardanoEnvironment cardanoConfiguration = d
-- the filesystem, so we give him the most flexible/powerful context, @IO@.
networkingConfiguration <- pure "THIS IS AN EXAMPLE OF A CONFIGURATION!"

putTextLn $ "The DB version" <> (show $ coDBSerializeVersion <$> ccCore cardanoConfiguration)
putTextLn $ "The DB version" <> (show $ coDBSerializeVersion $ ccCore cardanoConfiguration)

-- we construct the layer
networkingLayer <- (featureInit networkingCardanoFeatureInit) cardanoEnvironment loggingLayer cardanoConfiguration networkingConfiguration
@@ -10,8 +10,9 @@ import Cardano.Shell.Features.Logging (LoggingCLIArguments,
loggingParser)
import Cardano.Shell.Features.Networking (createNetworkingFeature)

import Cardano.Shell.Constants.Types (CardanoConfiguration (..),
Core (..))
import Cardano.Shell.Configuration.Lib (finaliseCardanoConfiguration)
import Cardano.Shell.Constants.Types (PartialCardanoConfiguration (..),
PartialCore (..))
import Cardano.Shell.Constants.CLI (configCoreCLIParser)
import Cardano.Shell.Lib
import Cardano.Shell.Presets (mainnetConfiguration)
@@ -22,7 +23,7 @@ import Options.Applicative

-- | The product type of all command line arguments.
-- All here being - from all the features.
data CLIArguments = CLIArguments !LoggingCLIArguments !Core
data CLIArguments = CLIArguments !LoggingCLIArguments !PartialCore

main :: IO ()
main = do
@@ -82,19 +83,19 @@ main = do
-- anytime.
-- Another interesting thing is that we stack the effects ONLY when we use a function from
-- another layer, and we don't get all the effects, just the ones the function contains.
initializeAllFeatures :: CardanoConfiguration -> CardanoEnvironment -> IO ([CardanoFeature], LoggingLayer)
initializeAllFeatures cardanoConfiguration cardanoEnvironment = do
initializeAllFeatures :: PartialCardanoConfiguration -> CardanoEnvironment -> IO ([CardanoFeature], LoggingLayer)
initializeAllFeatures partialConfig cardanoEnvironment = do

-- Here we parse the __CLI__ arguments for the actual application.
CLIArguments loggingCLIArguments coreConfig <- execParser parserWithInfo
CLIArguments loggingCLIArguments coreCLI <- execParser parserWithInfo

-- TODO(KS): Looks like we might need to include lenses at some point?
let cardanoConfiguration' = cardanoConfiguration { ccCore = ccCore cardanoConfiguration <> pure coreConfig }
finalConfig <- either (throwIO . ConfigurationError) pure $
finaliseCardanoConfiguration $ partialConfig { pccCore = pccCore partialConfig <> pure coreCLI }

-- Here we initialize all the features
(loggingLayer, loggingFeature) <- createLoggingFeature cardanoEnvironment cardanoConfiguration' loggingCLIArguments
(loggingLayer, loggingFeature) <- createLoggingFeature cardanoEnvironment finalConfig loggingCLIArguments

(_ , networkFeature) <- createNetworkingFeature loggingLayer cardanoEnvironment cardanoConfiguration'
(_ , networkFeature) <- createNetworkingFeature loggingLayer cardanoEnvironment finalConfig

-- Here we return all the features.
let allCardanoFeatures :: [CardanoFeature]
@@ -1,5 +1,10 @@
{-# LANGUAGE RecordWildCards #-}

module Cardano.Shell.Configuration.Lib
( mkLauncher
( finaliseCardanoConfiguration
, finaliseCore
, finaliseGenesis
, mkLauncher
, mkTopology
, mkOSConfig
, mkInstallerConfig
@@ -8,13 +13,19 @@ module Cardano.Shell.Configuration.Lib
, mkLoggingConfig
, mkNetworkConfig
, mkWalletConfig
-- Tools
, lastToEither
) where

import Cardano.Prelude

import Dhall (auto, input)

import Cardano.Shell.Configuration.Types (BlockchainConfig,
import Cardano.Shell.Constants.Types ( CardanoConfiguration (..), PartialCardanoConfiguration (..)
, Core(..), PartialCore(..)
, Genesis(..), PartialGenesis(..))
import Cardano.Shell.Configuration.Types (
BlockchainConfig,
Cluster (..),
InstallerConfig, Launcher,
Launcher, LoggingConfig,
@@ -23,6 +34,50 @@ import Cardano.Shell.Configuration.Types (BlockchainConfig,
WalletConfig, renderCluster,
renderOS)

lastToEither :: Text -> Last a -> Either Text a
lastToEither errMsg (Last x) = maybe (Left errMsg) Right x

--
-- The finalise* family of functions are supposed to be called at the very last stage
-- in the partial options monoid approach, after all the parametrisation layers have been merged,
-- and we're intending to use the resultant config -- they ensure that all values are defined.
--
finaliseCardanoConfiguration :: PartialCardanoConfiguration -> Either Text CardanoConfiguration
finaliseCardanoConfiguration PartialCardanoConfiguration{..} = do
ccLogPath <- lastToEither "Unspecified ccLogPath" pccLogPath
ccLogConfig <- lastToEither "Unspecified ccLogConfig" pccLogConfig
ccDBPath <- lastToEither "Unspecified ccDBPath" pccDBPath
ccApplicationLockFile <- lastToEither "Unspecified ccApplicationLockFile"
pccApplicationLockFile
ccCore <- join $ finaliseCore <$>
lastToEither "Unspecified ccCore" pccCore
ccNTP <- lastToEither "Unspecified ccNTP" pccNTP
ccUpdate <- lastToEither "Unspecified ccUpdate" pccUpdate
ccTXP <- lastToEither "Unspecified ccTXP" pccTXP
ccSSC <- lastToEither "Unspecified ccSSC" pccSSC
ccDLG <- lastToEither "Unspecified ccDLG" pccDLG
ccBlock <- lastToEither "Unspecified ccBlock" pccBlock
ccNode <- lastToEither "Unspecified ccNode" pccNode
ccTLS <- lastToEither "Unspecified ccTLS" pccTLS
ccWallet <- lastToEither "Unspecified ccWallet" pccWallet

pure CardanoConfiguration{..}

finaliseCore :: PartialCore -> Either Text Core
finaliseCore PartialCore{..} = do
coGenesis <- join $ finaliseGenesis <$>
lastToEither "Unspecified coGenesis" pcoGenesis
coRequiresNetworkMagic <- lastToEither "Unspecified coRequiresNetworkMagic" pcoRequiresNetworkMagic
coDBSerializeVersion <- lastToEither "Unspecified coDBSerializeVersion" pcoDBSerializeVersion
pure Core{..}

finaliseGenesis :: PartialGenesis -> Either Text Genesis
finaliseGenesis PartialGenesis{..} = do
geSrc <- lastToEither "Unspecified geSrc" pgeSrc
geGenesisHash <- lastToEither "Unspecified geGenesisHash" pgeGenesisHash
gePrevBlockHash <- lastToEither "Unspecified gePrevBlockHash" pgePrevBlockHash
pure Genesis{..}

-- | Generate 'TopologyConfig' with given 'Cluster'
mkTopology :: Cluster -> IO TopologyConfig
mkTopology cluster = input auto topologyPath
@@ -19,13 +19,16 @@ import Cardano.Shell.Constants.Types
lastOption :: Parser a -> Parser (Last a)
lastOption parser = Last <$> optional parser

lastStrOption :: IsString a => Mod OptionFields a -> Parser (Last a)
lastStrOption args = Last <$> optional (strOption args)

--------------------------------------------------------------------------------
-- Core
--------------------------------------------------------------------------------

-- | The parser for the logging specific arguments.
configCoreCLIParser :: Parser Core
configCoreCLIParser = Core
configCoreCLIParser :: Parser PartialCore
configCoreCLIParser = PartialCore
<$> lastOption parseGenesis
<*> lastOption parseNetworkMagic
<*> lastOption parseDBVersion
@@ -56,20 +59,20 @@ parseDBVersion =
)

-- | CLI parser for @Genesis@.
parseGenesis :: Parser Genesis
parseGenesis :: Parser PartialGenesis
parseGenesis =
Genesis
<$> strOption
PartialGenesis
<$> lastStrOption
( long "src-file-path"
<> metavar "SRC-FILE-PATH"
<> help "The filepath to the genesis file."
)
<*> strOption
<*> lastStrOption
( long "genesis-hash"
<> metavar "GENESIS-HASH"
<> help "The genesis hash value."
)
<*> strOption
<*> lastStrOption
( long "prev-block-hash"
<> metavar "PREV-BLOCK-HASH"
<> help "The hash of the previous block."
@@ -1,11 +1,12 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}

module Cardano.Shell.Constants.Types
( CardanoConfiguration (..)
, Core (..)
( CardanoConfiguration (..), PartialCardanoConfiguration (..)
, Core (..), PartialCore (..)
-- * specific for @Core@
, RequireNetworkMagic (..)
, Genesis (..)
, Genesis (..), PartialGenesis (..)
, Spec (..)
, Initializer (..)
-- * rest
@@ -49,7 +50,7 @@ data CardanoConfiguration = CardanoConfiguration
-- ^ The location of the application lock file that is used
-- as a semaphore se we can run just one application
-- instance at a time.
, ccCore :: !(Last Core)
, ccCore :: !Core
, ccNTP :: !NTP
, ccUpdate :: !Update
, ccTXP :: !TXP
@@ -61,6 +62,23 @@ data CardanoConfiguration = CardanoConfiguration
, ccWallet :: !Wallet
} deriving (Eq, Show)

data PartialCardanoConfiguration = PartialCardanoConfiguration
{ pccLogPath :: !(Last FilePath)
, pccLogConfig :: !(Last FilePath)
, pccDBPath :: !(Last FilePath)
, pccApplicationLockFile :: !(Last FilePath)
, pccCore :: !(Last PartialCore)
, pccNTP :: !(Last NTP)
, pccUpdate :: !(Last Update)
, pccTXP :: !(Last TXP)
, pccSSC :: !(Last SSC)
, pccDLG :: !(Last DLG)
, pccBlock :: !(Last Block)
, pccNode :: !(Last Node)
, pccTLS :: !(Last TLS)
, pccWallet :: !(Last Wallet)
} deriving (Eq, Show)

-- | Do we require network magic or not?
-- Network magic allows the differentiation from mainnet and testnet.
data RequireNetworkMagic
@@ -70,28 +88,34 @@ data RequireNetworkMagic

-- | Core configuration.
data Core = Core
{ coGenesis :: !(Last Genesis)
{ coGenesis :: !Genesis
-- ^ Genesis information
, coRequiresNetworkMagic :: !(Last RequireNetworkMagic)
, coRequiresNetworkMagic :: !RequireNetworkMagic
-- ^ Do we require the network byte indicator for mainnet, testnet or staging?
, coDBSerializeVersion :: !(Last Integer)
, coDBSerializeVersion :: !Integer
-- ^ Versioning for values in node's DB.
} deriving (Eq, Show, Generic)

instance Semigroup Core where
data PartialCore = PartialCore
{ pcoGenesis :: !(Last PartialGenesis)
, pcoRequiresNetworkMagic :: !(Last RequireNetworkMagic)
, pcoDBSerializeVersion :: !(Last Integer)
} deriving (Eq, Show, Generic)

instance Semigroup PartialCore where
core1 <> core2 =
Core
{ coGenesis = coGenesis core1 <> coGenesis core2
, coRequiresNetworkMagic = coRequiresNetworkMagic core1 <> coRequiresNetworkMagic core2
, coDBSerializeVersion = coDBSerializeVersion core1 <> coDBSerializeVersion core2
PartialCore
{ pcoGenesis = pcoGenesis core1 <> pcoGenesis core2
, pcoRequiresNetworkMagic = pcoRequiresNetworkMagic core1 <> pcoRequiresNetworkMagic core2
, pcoDBSerializeVersion = pcoDBSerializeVersion core1 <> pcoDBSerializeVersion core2
}

instance Monoid Core where
instance Monoid PartialCore where
mempty =
Core
{ coGenesis = mempty
, coRequiresNetworkMagic = mempty
, coDBSerializeVersion = mempty
PartialCore
{ pcoGenesis = mempty
, pcoRequiresNetworkMagic = mempty
, pcoDBSerializeVersion = mempty
}

-- | The genesis section.
@@ -109,20 +133,26 @@ data Genesis = Genesis
, gePrevBlockHash :: !Text
} deriving (Eq, Show, Generic)

instance Semigroup Genesis where
data PartialGenesis = PartialGenesis
{ pgeSrc :: !(Last FilePath)
, pgeGenesisHash :: !(Last Text)
, pgePrevBlockHash :: !(Last Text)
} deriving (Eq, Show, Generic)

instance Semigroup PartialGenesis where
genesis1 <> genesis2 =
Genesis
{ geSrc = geSrc genesis1 <> geSrc genesis2
, geGenesisHash = geGenesisHash genesis1 <> geGenesisHash genesis2
, gePrevBlockHash = gePrevBlockHash genesis1 <> gePrevBlockHash genesis2
PartialGenesis
{ pgeSrc = pgeSrc genesis1 <> pgeSrc genesis2
, pgeGenesisHash = pgeGenesisHash genesis1 <> pgeGenesisHash genesis2
, pgePrevBlockHash = pgePrevBlockHash genesis1 <> pgePrevBlockHash genesis2
}

instance Monoid Genesis where
instance Monoid PartialGenesis where
mempty =
Genesis
{ geSrc = mempty
, geGenesisHash = mempty
, gePrevBlockHash = mempty
PartialGenesis
{ pgeSrc = mempty
, pgeGenesisHash = mempty
, pgePrevBlockHash = mempty
}

data Spec = Spec
@@ -35,7 +35,7 @@ import Cardano.Shell.Types (ApplicationEnvironment (..),
CardanoEnvironment, CardanoFeature (..),
initializeCardanoEnvironment)

import Cardano.Shell.Constants.Types (CardanoConfiguration (..))
import Cardano.Shell.Constants.Types (CardanoConfiguration (..), PartialCardanoConfiguration (..))

import Cardano.Shell.Presets (mainnetConfiguration)

@@ -48,6 +48,7 @@ data GeneralException
| FileNotFoundException FilePath
| ApplicationAlreadyRunningException
| LockFileDoesNotExist FilePath
| ConfigurationError Text
deriving (Eq)

instance Exception GeneralException
@@ -57,6 +58,7 @@ instance Buildable GeneralException where
build (FileNotFoundException filePath) = bprint ("File not found on path '"%stext%"'.") (strConv Lenient filePath)
build ApplicationAlreadyRunningException = bprint "Application is already running. Please shut down the application first."
build (LockFileDoesNotExist filePath) = bprint ("Lock file not found on path '"%stext%"'.") (strConv Lenient filePath)
build (ConfigurationError etext) = bprint ("Configuration error: "%stext%".") etext

-- | Instance so we can see helpful error messages when something goes wrong.
instance Show GeneralException where
@@ -147,7 +149,7 @@ runCardanoApplicationWithFeatures _ cardanoFeatures cardanoApplication = do
pure ()


type AllFeaturesInitFunction = CardanoConfiguration -> CardanoEnvironment -> IO [CardanoFeature]
type AllFeaturesInitFunction = PartialCardanoConfiguration -> CardanoEnvironment -> IO [CardanoFeature]


-- | The wrapper for the application providing modules.

0 comments on commit d87e0a4

Please sign in to comment.
You can’t perform that action at this time.