{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} module Cardano.Tools.DBSynthesizer.Run ( initialize , synthesize ) where import Cardano.Api.Any (displayError) import Cardano.Node.Protocol.Cardano (mkConsensusProtocolCardano) import Cardano.Node.Types import Cardano.Tools.DBSynthesizer.Forging import Cardano.Tools.DBSynthesizer.Orphans () import Cardano.Tools.DBSynthesizer.Types import Control.Monad (filterM) import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither, runExceptT) import Control.ResourceRegistry import Control.Tracer import Data.Aeson as Aeson (FromJSON, Result (..), Value, eitherDecodeFileStrict', eitherDecodeStrict', fromJSON) import Data.Bool (bool) import Data.ByteString as BS (ByteString, readFile) import qualified Data.Set as Set import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Cardano.Node import Ouroboros.Consensus.Config (TopLevelConfig, configStorage) import qualified Ouroboros.Consensus.Node as Node (stdMkChainDbHasFS) import qualified Ouroboros.Consensus.Node.InitStorage as Node (nodeImmutableDbChunkInfo) import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..)) import Ouroboros.Consensus.Shelley.Node (ShelleyGenesis (..), validateGenesis) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB (getTipPoint) import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB import Ouroboros.Consensus.Storage.LedgerDB.V1.Args as LedgerDB.V1 import Ouroboros.Consensus.Util.IOLike (atomically) import Ouroboros.Network.Block import Ouroboros.Network.Point (WithOrigin (..)) import System.Directory import System.FilePath (takeDirectory, (</>)) initialize :: NodeFilePaths -> NodeCredentials -> DBSynthesizerOptions -> IO (Either String (DBSynthesizerConfig, CardanoProtocolParams StandardCrypto)) initialize :: NodeFilePaths -> NodeCredentials -> DBSynthesizerOptions -> IO (Either String (DBSynthesizerConfig, CardanoProtocolParams StandardCrypto)) initialize NodeFilePaths{String nfpConfig :: String nfpConfig :: NodeFilePaths -> String nfpConfig, String nfpChainDB :: String nfpChainDB :: NodeFilePaths -> String nfpChainDB} NodeCredentials creds DBSynthesizerOptions synthOptions = do relativeToConfig :: (FilePath -> FilePath) <- String -> String -> String (</>) (String -> String -> String) -> (String -> String) -> String -> String -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> String takeDirectory (String -> String -> String) -> IO String -> IO (String -> String) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> String -> IO String makeAbsolute String nfpConfig runExceptT $ do conf <- initConf relativeToConfig proto <- initProtocol relativeToConfig conf pure (conf, proto) where initConf :: (FilePath -> FilePath) -> ExceptT String IO DBSynthesizerConfig initConf :: (String -> String) -> ExceptT String IO DBSynthesizerConfig initConf String -> String relativeToConfig = do inp <- (IOException -> String) -> IO ByteString -> ExceptT String IO ByteString forall (m :: * -> *) x a. MonadIO m => (IOException -> x) -> IO a -> ExceptT x m a handleIOExceptT IOException -> String forall a. Show a => a -> String show (String -> IO ByteString BS.readFile String nfpConfig) configStub <- adjustFilePaths relativeToConfig <$> readJson inp shelleyGenesis <- readFileJson $ ncsShelleyGenesisFile configStub _ <- hoistEither $ validateGenesis shelleyGenesis let protocolCredentials = ProtocolFilepaths { byronCertFile :: Maybe String byronCertFile = Maybe String forall a. Maybe a Nothing , byronKeyFile :: Maybe String byronKeyFile = Maybe String forall a. Maybe a Nothing , shelleyKESFile :: Maybe String shelleyKESFile = NodeCredentials -> Maybe String credKESFile NodeCredentials creds , shelleyVRFFile :: Maybe String shelleyVRFFile = NodeCredentials -> Maybe String credVRFFile NodeCredentials creds , shelleyCertFile :: Maybe String shelleyCertFile = NodeCredentials -> Maybe String credCertFile NodeCredentials creds , shelleyBulkCredsFile :: Maybe String shelleyBulkCredsFile = NodeCredentials -> Maybe String credBulkFile NodeCredentials creds } pure DBSynthesizerConfig { confConfigStub = configStub , confOptions = synthOptions , confProtocolCredentials = protocolCredentials , confShelleyGenesis = shelleyGenesis , confDbDir = nfpChainDB } initProtocol :: (FilePath -> FilePath) -> DBSynthesizerConfig -> ExceptT String IO (CardanoProtocolParams StandardCrypto) initProtocol :: (String -> String) -> DBSynthesizerConfig -> ExceptT String IO (CardanoProtocolParams StandardCrypto) initProtocol String -> String relativeToConfig DBSynthesizerConfig{NodeConfigStub confConfigStub :: DBSynthesizerConfig -> NodeConfigStub confConfigStub :: NodeConfigStub confConfigStub, ProtocolFilepaths confProtocolCredentials :: DBSynthesizerConfig -> ProtocolFilepaths confProtocolCredentials :: ProtocolFilepaths confProtocolCredentials} = do hfConfig :: NodeHardForkProtocolConfiguration <- Either String NodeHardForkProtocolConfiguration -> ExceptT String IO NodeHardForkProtocolConfiguration forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a hoistEither Either String NodeHardForkProtocolConfiguration hfConfig_ byronConfig :: NodeByronProtocolConfiguration <- adjustFilePaths relativeToConfig <$> hoistEither byConfig_ firstExceptT displayError $ mkConsensusProtocolCardano byronConfig shelleyConfig alonzoConfig conwayConfig hfConfig (Just confProtocolCredentials) where shelleyConfig :: NodeShelleyProtocolConfiguration shelleyConfig = GenesisFile -> Maybe GenesisHash -> NodeShelleyProtocolConfiguration NodeShelleyProtocolConfiguration (String -> GenesisFile GenesisFile (String -> GenesisFile) -> String -> GenesisFile forall a b. (a -> b) -> a -> b $ NodeConfigStub -> String ncsShelleyGenesisFile NodeConfigStub confConfigStub) Maybe GenesisHash forall a. Maybe a Nothing alonzoConfig :: NodeAlonzoProtocolConfiguration alonzoConfig = GenesisFile -> Maybe GenesisHash -> NodeAlonzoProtocolConfiguration NodeAlonzoProtocolConfiguration (String -> GenesisFile GenesisFile (String -> GenesisFile) -> String -> GenesisFile forall a b. (a -> b) -> a -> b $ NodeConfigStub -> String ncsAlonzoGenesisFile NodeConfigStub confConfigStub) Maybe GenesisHash forall a. Maybe a Nothing conwayConfig :: NodeConwayProtocolConfiguration conwayConfig = GenesisFile -> Maybe GenesisHash -> NodeConwayProtocolConfiguration NodeConwayProtocolConfiguration (String -> GenesisFile GenesisFile (String -> GenesisFile) -> String -> GenesisFile forall a b. (a -> b) -> a -> b $ NodeConfigStub -> String ncsConwayGenesisFile NodeConfigStub confConfigStub) Maybe GenesisHash forall a. Maybe a Nothing hfConfig_ :: Either String NodeHardForkProtocolConfiguration hfConfig_ = Value -> Either String NodeHardForkProtocolConfiguration forall a. FromJSON a => Value -> Either String a eitherParseJson (Value -> Either String NodeHardForkProtocolConfiguration) -> Value -> Either String NodeHardForkProtocolConfiguration forall a b. (a -> b) -> a -> b $ NodeConfigStub -> Value ncsNodeConfig NodeConfigStub confConfigStub byConfig_ :: Either String NodeByronProtocolConfiguration byConfig_ = Value -> Either String NodeByronProtocolConfiguration forall a. FromJSON a => Value -> Either String a eitherParseJson (Value -> Either String NodeByronProtocolConfiguration) -> Value -> Either String NodeByronProtocolConfiguration forall a b. (a -> b) -> a -> b $ NodeConfigStub -> Value ncsNodeConfig NodeConfigStub confConfigStub readJson :: (Monad m, FromJSON a) => ByteString -> ExceptT String m a readJson :: forall (m :: * -> *) a. (Monad m, FromJSON a) => ByteString -> ExceptT String m a readJson = Either String a -> ExceptT String m a forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a hoistEither (Either String a -> ExceptT String m a) -> (ByteString -> Either String a) -> ByteString -> ExceptT String m a forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> Either String a forall a. FromJSON a => ByteString -> Either String a eitherDecodeStrict' readFileJson :: FromJSON a => FilePath -> ExceptT String IO a readFileJson :: forall a. FromJSON a => String -> ExceptT String IO a readFileJson String f = (IOException -> String) -> IO (Either String a) -> ExceptT String IO (Either String a) forall (m :: * -> *) x a. MonadIO m => (IOException -> x) -> IO a -> ExceptT x m a handleIOExceptT IOException -> String forall a. Show a => a -> String show (String -> IO (Either String a) forall a. FromJSON a => String -> IO (Either String a) eitherDecodeFileStrict' String f) ExceptT String IO (Either String a) -> (Either String a -> ExceptT String IO a) -> ExceptT String IO a forall a b. ExceptT String IO a -> (a -> ExceptT String IO b) -> ExceptT String IO b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= Either String a -> ExceptT String IO a forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a hoistEither eitherParseJson :: FromJSON a => Aeson.Value -> Either String a eitherParseJson :: forall a. FromJSON a => Value -> Either String a eitherParseJson Value v = case Value -> Result a forall a. FromJSON a => Value -> Result a fromJSON Value v of Error String err -> String -> Either String a forall a b. a -> Either a b Left String err Success a a -> a -> Either String a forall a b. b -> Either a b Right a a synthesize :: ( TopLevelConfig (CardanoBlock StandardCrypto) -> GenTxs (CardanoBlock StandardCrypto) mk ) -> DBSynthesizerConfig -> (CardanoProtocolParams StandardCrypto) -> IO ForgeResult synthesize :: forall mk. (TopLevelConfig (CardanoBlock StandardCrypto) -> GenTxs (CardanoBlock StandardCrypto) mk) -> DBSynthesizerConfig -> CardanoProtocolParams StandardCrypto -> IO ForgeResult synthesize TopLevelConfig (CardanoBlock StandardCrypto) -> GenTxs (CardanoBlock StandardCrypto) mk genTxs DBSynthesizerConfig{DBSynthesizerOptions confOptions :: DBSynthesizerConfig -> DBSynthesizerOptions confOptions :: DBSynthesizerOptions confOptions, ShelleyGenesis confShelleyGenesis :: DBSynthesizerConfig -> ShelleyGenesis confShelleyGenesis :: ShelleyGenesis confShelleyGenesis, String confDbDir :: DBSynthesizerConfig -> String confDbDir :: String confDbDir} CardanoProtocolParams StandardCrypto runP = (ResourceRegistry IO -> IO ForgeResult) -> IO ForgeResult forall (m :: * -> *) a. (MonadSTM m, MonadMask m, MonadThread m, HasCallStack) => (ResourceRegistry m -> m a) -> m a withRegistry ((ResourceRegistry IO -> IO ForgeResult) -> IO ForgeResult) -> (ResourceRegistry IO -> IO ForgeResult) -> IO ForgeResult forall a b. (a -> b) -> a -> b $ \ResourceRegistry IO registry -> do let epochSize :: EpochSize epochSize = ShelleyGenesis -> EpochSize sgEpochLength ShelleyGenesis confShelleyGenesis chunkInfo :: ChunkInfo chunkInfo = StorageConfig (CardanoBlock StandardCrypto) -> ChunkInfo forall blk. NodeInitStorage blk => StorageConfig blk -> ChunkInfo Node.nodeImmutableDbChunkInfo (TopLevelConfig (CardanoBlock StandardCrypto) -> StorageConfig (CardanoBlock StandardCrypto) forall blk. TopLevelConfig blk -> StorageConfig blk configStorage TopLevelConfig (CardanoBlock StandardCrypto) pInfoConfig) bss :: LedgerDbFlavorArgs f m bss = FlushFrequency -> BackingStoreArgs f m -> LedgerDbFlavorArgs f m forall (f :: * -> *) (m :: * -> *). FlushFrequency -> BackingStoreArgs f m -> LedgerDbFlavorArgs f m LedgerDB.V1.V1Args FlushFrequency LedgerDB.V1.DisableFlushing BackingStoreArgs f m forall (f :: * -> *) (m :: * -> *). BackingStoreArgs f m InMemoryBackingStoreArgs flavargs :: LedgerDbFlavorArgs f m flavargs = LedgerDbFlavorArgs f m -> LedgerDbFlavorArgs f m forall (f :: * -> *) (m :: * -> *). LedgerDbFlavorArgs f m -> LedgerDbFlavorArgs f m LedgerDB.LedgerDbFlavorArgsV1 LedgerDbFlavorArgs f m forall {f :: * -> *} {m :: * -> *}. LedgerDbFlavorArgs f m bss dbArgs :: Complete ChainDbArgs IO (CardanoBlock StandardCrypto) dbArgs = ResourceRegistry IO -> TopLevelConfig (CardanoBlock StandardCrypto) -> ExtLedgerState (CardanoBlock StandardCrypto) ValuesMK -> ChunkInfo -> (CardanoBlock StandardCrypto -> Bool) -> (RelativeMountPoint -> SomeHasFS IO) -> (RelativeMountPoint -> SomeHasFS IO) -> Complete LedgerDbFlavorArgs IO -> Incomplete ChainDbArgs IO (CardanoBlock StandardCrypto) -> Complete ChainDbArgs IO (CardanoBlock StandardCrypto) forall (m :: * -> *) blk. (ConsensusProtocol (BlockProtocol blk), IOLike m) => ResourceRegistry m -> TopLevelConfig blk -> ExtLedgerState blk ValuesMK -> ChunkInfo -> (blk -> Bool) -> (RelativeMountPoint -> SomeHasFS m) -> (RelativeMountPoint -> SomeHasFS m) -> Complete LedgerDbFlavorArgs m -> Incomplete ChainDbArgs m blk -> Complete ChainDbArgs m blk ChainDB.completeChainDbArgs ResourceRegistry IO registry TopLevelConfig (CardanoBlock StandardCrypto) pInfoConfig ExtLedgerState (CardanoBlock StandardCrypto) ValuesMK pInfoInitLedger ChunkInfo chunkInfo (Bool -> CardanoBlock StandardCrypto -> Bool forall a b. a -> b -> a const Bool True) (String -> RelativeMountPoint -> SomeHasFS IO Node.stdMkChainDbHasFS String confDbDir) (String -> RelativeMountPoint -> SomeHasFS IO Node.stdMkChainDbHasFS String confDbDir) Complete LedgerDbFlavorArgs IO forall {f :: * -> *} {m :: * -> *}. LedgerDbFlavorArgs f m flavargs (Incomplete ChainDbArgs IO (CardanoBlock StandardCrypto) -> Complete ChainDbArgs IO (CardanoBlock StandardCrypto)) -> Incomplete ChainDbArgs IO (CardanoBlock StandardCrypto) -> Complete ChainDbArgs IO (CardanoBlock StandardCrypto) forall a b. (a -> b) -> a -> b $ Incomplete ChainDbArgs IO (CardanoBlock StandardCrypto) forall (m :: * -> *) blk. Monad m => Incomplete ChainDbArgs m blk ChainDB.defaultArgs forgers <- IO [BlockForging IO (CardanoBlock StandardCrypto)] blockForging let fCount = [BlockForging IO (CardanoBlock StandardCrypto)] -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [BlockForging IO (CardanoBlock StandardCrypto)] forgers putStrLn $ "--> forger count: " ++ show fCount if fCount > 0 then do putStrLn $ "--> opening ChainDB on file system with mode: " ++ show synthOpenMode preOpenChainDB synthOpenMode confDbDir let dbTracer = Tracer IO a forall (m :: * -> *) a. Applicative m => Tracer m a nullTracer ChainDB.withDB (ChainDB.updateTracer dbTracer dbArgs) $ \ChainDB IO (CardanoBlock StandardCrypto) chainDB -> do slotNo <- do tip <- STM IO (Point (CardanoBlock StandardCrypto)) -> IO (Point (CardanoBlock StandardCrypto)) forall a. HasCallStack => STM IO a -> IO a forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (ChainDB IO (CardanoBlock StandardCrypto) -> STM IO (Point (CardanoBlock StandardCrypto)) forall (m :: * -> *) blk. ChainDB m blk -> STM m (Point blk) ChainDB.getTipPoint ChainDB IO (CardanoBlock StandardCrypto) chainDB) pure $ case pointSlot tip of WithOrigin SlotNo Origin -> SlotNo 0 At SlotNo s -> SlotNo -> SlotNo forall a. Enum a => a -> a succ SlotNo s putStrLn $ "--> starting at: " ++ show slotNo runForge epochSize slotNo synthLimit chainDB forgers pInfoConfig $ genTxs pInfoConfig else do putStrLn "--> no forgers found; leaving possibly existing ChainDB untouched" pure $ ForgeResult 0 where DBSynthesizerOptions { DBSynthesizerOpenMode synthOpenMode :: DBSynthesizerOpenMode synthOpenMode :: DBSynthesizerOptions -> DBSynthesizerOpenMode synthOpenMode , ForgeLimit synthLimit :: ForgeLimit synthLimit :: DBSynthesizerOptions -> ForgeLimit synthLimit } = DBSynthesizerOptions confOptions ( ProtocolInfo { TopLevelConfig (CardanoBlock StandardCrypto) pInfoConfig :: TopLevelConfig (CardanoBlock StandardCrypto) pInfoConfig :: forall b. ProtocolInfo b -> TopLevelConfig b pInfoConfig , ExtLedgerState (CardanoBlock StandardCrypto) ValuesMK pInfoInitLedger :: ExtLedgerState (CardanoBlock StandardCrypto) ValuesMK pInfoInitLedger :: forall b. ProtocolInfo b -> ExtLedgerState b ValuesMK pInfoInitLedger } , IO [BlockForging IO (CardanoBlock StandardCrypto)] blockForging ) = CardanoProtocolParams StandardCrypto -> (ProtocolInfo (CardanoBlock StandardCrypto), IO [BlockForging IO (CardanoBlock StandardCrypto)]) forall c (m :: * -> *). (IOLike m, CardanoHardForkConstraints c) => CardanoProtocolParams c -> (ProtocolInfo (CardanoBlock c), m [BlockForging m (CardanoBlock c)]) protocolInfoCardano CardanoProtocolParams StandardCrypto runP preOpenChainDB :: DBSynthesizerOpenMode -> FilePath -> IO () preOpenChainDB :: DBSynthesizerOpenMode -> String -> IO () preOpenChainDB DBSynthesizerOpenMode mode String db = String -> IO Bool doesDirectoryExist String db IO Bool -> (Bool -> IO ()) -> IO () forall a b. IO a -> (a -> IO b) -> IO b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= IO () -> IO () -> Bool -> IO () forall a. a -> a -> Bool -> a bool IO () create IO () checkMode where checkIsDB :: [String] -> Bool checkIsDB [String] ls = [String] -> Set String forall a. Ord a => [a] -> Set a Set.fromList [String] ls Set String -> Set String -> Bool forall a. Ord a => Set a -> Set a -> Bool `Set.isSubsetOf` Set String chainDBDirs chainDBDirs :: Set String chainDBDirs = [String] -> Set String forall a. Ord a => [a] -> Set a Set.fromList [String "immutable", String "ledger", String "volatile", String "gsm"] loc :: String loc = String "preOpenChainDB: '" String -> String -> String forall a. [a] -> [a] -> [a] ++ String db String -> String -> String forall a. [a] -> [a] -> [a] ++ String "'" create :: IO () create = Bool -> String -> IO () createDirectoryIfMissing Bool True String db checkMode :: IO () checkMode = do isChainDB <- [String] -> Bool checkIsDB ([String] -> Bool) -> IO [String] -> IO Bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> String -> IO [String] listSubdirectories String db case mode of DBSynthesizerOpenMode OpenCreate -> String -> IO () forall a. String -> IO a forall (m :: * -> *) a. MonadFail m => String -> m a fail (String -> IO ()) -> String -> IO () forall a b. (a -> b) -> a -> b $ String loc String -> String -> String forall a. [a] -> [a] -> [a] ++ String " already exists. Use -f to overwrite or -a to append." DBSynthesizerOpenMode OpenAppend | Bool isChainDB -> () -> IO () forall a. a -> IO a forall (f :: * -> *) a. Applicative f => a -> f a pure () DBSynthesizerOpenMode OpenCreateForce | Bool isChainDB -> String -> IO () removePathForcibly String db IO () -> IO () -> IO () forall a b. IO a -> IO b -> IO b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> IO () create DBSynthesizerOpenMode _ -> String -> IO () forall a. String -> IO a forall (m :: * -> *) a. MonadFail m => String -> m a fail (String -> IO ()) -> String -> IO () forall a b. (a -> b) -> a -> b $ String loc String -> String -> String forall a. [a] -> [a] -> [a] ++ String " is non-empty and does not look like a ChainDB" String -> String -> String forall a. Semigroup a => a -> a -> a <> String " (i.e. it contains directories other than" String -> String -> String forall a. Semigroup a => a -> a -> a <> String " 'immutable'/'ledger'/'volatile'/'gsm'). Aborting." listSubdirectories :: String -> IO [String] listSubdirectories String path = (String -> IO Bool) -> [String] -> IO [String] forall (m :: * -> *) a. Applicative m => (a -> m Bool) -> [a] -> m [a] filterM String -> IO Bool isDir ([String] -> IO [String]) -> IO [String] -> IO [String] forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< String -> IO [String] listDirectory String path where isDir :: String -> IO Bool isDir String p = String -> IO Bool doesDirectoryExist (String path String -> String -> String </> String p)