{-# 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.Tracer (nullTracer) 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.Fragment.InFuture as InFuture (dontCheck) 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 (withDB) import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB import Ouroboros.Consensus.Util.IOLike (atomically) import Ouroboros.Consensus.Util.ResourceRegistry 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 String -> String 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 ExceptT String IO (DBSynthesizerConfig, CardanoProtocolParams StandardCrypto) -> IO (Either String (DBSynthesizerConfig, CardanoProtocolParams StandardCrypto)) forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a) runExceptT (ExceptT String IO (DBSynthesizerConfig, CardanoProtocolParams StandardCrypto) -> IO (Either String (DBSynthesizerConfig, CardanoProtocolParams StandardCrypto))) -> ExceptT String IO (DBSynthesizerConfig, CardanoProtocolParams StandardCrypto) -> IO (Either String (DBSynthesizerConfig, CardanoProtocolParams StandardCrypto)) forall a b. (a -> b) -> a -> b $ do DBSynthesizerConfig conf <- (String -> String) -> ExceptT String IO DBSynthesizerConfig initConf String -> String relativeToConfig CardanoProtocolParams StandardCrypto proto <- (String -> String) -> DBSynthesizerConfig -> ExceptT String IO (CardanoProtocolParams StandardCrypto) initProtocol String -> String relativeToConfig DBSynthesizerConfig conf (DBSynthesizerConfig, CardanoProtocolParams StandardCrypto) -> ExceptT String IO (DBSynthesizerConfig, CardanoProtocolParams StandardCrypto) forall a. a -> ExceptT String IO a forall (f :: * -> *) a. Applicative f => a -> f a pure (DBSynthesizerConfig conf, CardanoProtocolParams StandardCrypto proto) where initConf :: (FilePath -> FilePath) -> ExceptT String IO DBSynthesizerConfig initConf :: (String -> String) -> ExceptT String IO DBSynthesizerConfig initConf String -> String relativeToConfig = do ByteString 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) NodeConfigStub configStub <- (String -> String) -> NodeConfigStub -> NodeConfigStub forall a. AdjustFilePaths a => (String -> String) -> a -> a adjustFilePaths String -> String relativeToConfig (NodeConfigStub -> NodeConfigStub) -> ExceptT String IO NodeConfigStub -> ExceptT String IO NodeConfigStub forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ByteString -> ExceptT String IO NodeConfigStub forall (m :: * -> *) a. (Monad m, FromJSON a) => ByteString -> ExceptT String m a readJson ByteString inp ShelleyGenesis StandardCrypto shelleyGenesis <- String -> ExceptT String IO (ShelleyGenesis StandardCrypto) forall a. FromJSON a => String -> ExceptT String IO a readFileJson (String -> ExceptT String IO (ShelleyGenesis StandardCrypto)) -> String -> ExceptT String IO (ShelleyGenesis StandardCrypto) forall a b. (a -> b) -> a -> b $ NodeConfigStub -> String ncsShelleyGenesisFile NodeConfigStub configStub () _ <- Either String () -> ExceptT String IO () forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a hoistEither (Either String () -> ExceptT String IO ()) -> Either String () -> ExceptT String IO () forall a b. (a -> b) -> a -> b $ ShelleyGenesis StandardCrypto -> Either String () forall c. PraosCrypto c => ShelleyGenesis c -> Either String () validateGenesis ShelleyGenesis StandardCrypto shelleyGenesis let protocolCredentials :: ProtocolFilepaths 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 } DBSynthesizerConfig -> ExceptT String IO DBSynthesizerConfig forall a. a -> ExceptT String IO a forall (f :: * -> *) a. Applicative f => a -> f a pure DBSynthesizerConfig { confConfigStub :: NodeConfigStub confConfigStub = NodeConfigStub configStub , confOptions :: DBSynthesizerOptions confOptions = DBSynthesizerOptions synthOptions , confProtocolCredentials :: ProtocolFilepaths confProtocolCredentials = ProtocolFilepaths protocolCredentials , confShelleyGenesis :: ShelleyGenesis StandardCrypto confShelleyGenesis = ShelleyGenesis StandardCrypto shelleyGenesis , confDbDir :: String confDbDir = String 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 NodeHardForkProtocolConfiguration 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_ NodeByronProtocolConfiguration byronConfig :: NodeByronProtocolConfiguration <- (String -> String) -> NodeByronProtocolConfiguration -> NodeByronProtocolConfiguration forall a. AdjustFilePaths a => (String -> String) -> a -> a adjustFilePaths String -> String relativeToConfig (NodeByronProtocolConfiguration -> NodeByronProtocolConfiguration) -> ExceptT String IO NodeByronProtocolConfiguration -> ExceptT String IO NodeByronProtocolConfiguration forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Either String NodeByronProtocolConfiguration -> ExceptT String IO NodeByronProtocolConfiguration forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a hoistEither Either String NodeByronProtocolConfiguration byConfig_ (CardanoProtocolInstantiationError -> String) -> ExceptT CardanoProtocolInstantiationError IO (CardanoProtocolParams StandardCrypto) -> ExceptT String IO (CardanoProtocolParams StandardCrypto) forall (m :: * -> *) x y a. Functor m => (x -> y) -> ExceptT x m a -> ExceptT y m a firstExceptT CardanoProtocolInstantiationError -> String forall e. Error e => e -> String displayError (ExceptT CardanoProtocolInstantiationError IO (CardanoProtocolParams StandardCrypto) -> ExceptT String IO (CardanoProtocolParams StandardCrypto)) -> ExceptT CardanoProtocolInstantiationError IO (CardanoProtocolParams StandardCrypto) -> ExceptT String IO (CardanoProtocolParams StandardCrypto) forall a b. (a -> b) -> a -> b $ NodeByronProtocolConfiguration -> NodeShelleyProtocolConfiguration -> NodeAlonzoProtocolConfiguration -> NodeConwayProtocolConfiguration -> NodeHardForkProtocolConfiguration -> Maybe ProtocolFilepaths -> ExceptT CardanoProtocolInstantiationError IO (CardanoProtocolParams StandardCrypto) mkConsensusProtocolCardano NodeByronProtocolConfiguration byronConfig NodeShelleyProtocolConfiguration shelleyConfig NodeAlonzoProtocolConfiguration alonzoConfig NodeConwayProtocolConfiguration conwayConfig NodeHardForkProtocolConfiguration hfConfig (ProtocolFilepaths -> Maybe ProtocolFilepaths forall a. a -> Maybe a Just ProtocolFilepaths 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) ) -> DBSynthesizerConfig -> (CardanoProtocolParams StandardCrypto) -> IO ForgeResult synthesize :: (TopLevelConfig (CardanoBlock StandardCrypto) -> GenTxs (CardanoBlock StandardCrypto)) -> DBSynthesizerConfig -> CardanoProtocolParams StandardCrypto -> IO ForgeResult synthesize TopLevelConfig (CardanoBlock StandardCrypto) -> GenTxs (CardanoBlock StandardCrypto) genTxs DBSynthesizerConfig{DBSynthesizerOptions confOptions :: DBSynthesizerConfig -> DBSynthesizerOptions confOptions :: DBSynthesizerOptions confOptions, ShelleyGenesis StandardCrypto confShelleyGenesis :: DBSynthesizerConfig -> ShelleyGenesis StandardCrypto confShelleyGenesis :: ShelleyGenesis StandardCrypto confShelleyGenesis, String confDbDir :: DBSynthesizerConfig -> String confDbDir :: String confDbDir} CardanoProtocolParams StandardCrypto runP = (ResourceRegistry IO -> IO ForgeResult) -> IO ForgeResult forall (m :: * -> *) a. (IOLike 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 StandardCrypto -> EpochSize forall c. ShelleyGenesis c -> EpochSize sgEpochLength ShelleyGenesis StandardCrypto 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) dbArgs :: Complete ChainDbArgs IO (CardanoBlock StandardCrypto) dbArgs = ResourceRegistry IO -> CheckInFuture IO (CardanoBlock StandardCrypto) -> TopLevelConfig (CardanoBlock StandardCrypto) -> ExtLedgerState (CardanoBlock StandardCrypto) -> ChunkInfo -> (CardanoBlock StandardCrypto -> Bool) -> (RelativeMountPoint -> SomeHasFS IO) -> (RelativeMountPoint -> SomeHasFS IO) -> Incomplete ChainDbArgs IO (CardanoBlock StandardCrypto) -> Complete ChainDbArgs IO (CardanoBlock StandardCrypto) forall (m :: * -> *) blk. (ConsensusProtocol (BlockProtocol blk), IOLike m) => ResourceRegistry m -> CheckInFuture m blk -> TopLevelConfig blk -> ExtLedgerState blk -> ChunkInfo -> (blk -> Bool) -> (RelativeMountPoint -> SomeHasFS m) -> (RelativeMountPoint -> SomeHasFS m) -> Incomplete ChainDbArgs m blk -> Complete ChainDbArgs m blk ChainDB.completeChainDbArgs ResourceRegistry IO registry CheckInFuture IO (CardanoBlock StandardCrypto) forall (m :: * -> *) blk. Monad m => CheckInFuture m blk InFuture.dontCheck TopLevelConfig (CardanoBlock StandardCrypto) pInfoConfig ExtLedgerState (CardanoBlock StandardCrypto) 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) (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 [BlockForging IO (CardanoBlock StandardCrypto)] forgers <- IO [BlockForging IO (CardanoBlock StandardCrypto)] blockForging let fCount :: Int fCount = [BlockForging IO (CardanoBlock StandardCrypto)] -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [BlockForging IO (CardanoBlock StandardCrypto)] forgers String -> IO () putStrLn (String -> IO ()) -> String -> IO () forall a b. (a -> b) -> a -> b $ String "--> forger count: " String -> String -> String forall a. [a] -> [a] -> [a] ++ Int -> String forall a. Show a => a -> String show Int fCount if Int fCount Int -> Int -> Bool forall a. Ord a => a -> a -> Bool > Int 0 then do String -> IO () putStrLn (String -> IO ()) -> String -> IO () forall a b. (a -> b) -> a -> b $ String "--> opening ChainDB on file system with mode: " String -> String -> String forall a. [a] -> [a] -> [a] ++ DBSynthesizerOpenMode -> String forall a. Show a => a -> String show DBSynthesizerOpenMode synthOpenMode DBSynthesizerOpenMode -> String -> IO () preOpenChainDB DBSynthesizerOpenMode synthOpenMode String confDbDir let dbTracer :: Tracer IO a dbTracer = Tracer IO a forall (m :: * -> *) a. Applicative m => Tracer m a nullTracer Complete ChainDbArgs IO (CardanoBlock StandardCrypto) -> (ChainDB IO (CardanoBlock StandardCrypto) -> IO ForgeResult) -> IO ForgeResult forall (m :: * -> *) blk a. (IOLike m, LedgerSupportsProtocol blk, BlockSupportsDiffusionPipelining blk, InspectLedger blk, HasHardForkHistory blk, ConvertRawHash blk, SerialiseDiskConstraints blk) => ChainDbArgs Identity m blk -> (ChainDB m blk -> m a) -> m a ChainDB.withDB (Tracer IO (TraceEvent (CardanoBlock StandardCrypto)) -> Complete ChainDbArgs IO (CardanoBlock StandardCrypto) -> Complete ChainDbArgs IO (CardanoBlock StandardCrypto) forall (m :: * -> *) blk (f :: * -> *). Tracer m (TraceEvent blk) -> ChainDbArgs f m blk -> ChainDbArgs f m blk ChainDB.updateTracer Tracer IO (TraceEvent (CardanoBlock StandardCrypto)) forall {a}. Tracer IO a dbTracer Complete ChainDbArgs IO (CardanoBlock StandardCrypto) dbArgs) ((ChainDB IO (CardanoBlock StandardCrypto) -> IO ForgeResult) -> IO ForgeResult) -> (ChainDB IO (CardanoBlock StandardCrypto) -> IO ForgeResult) -> IO ForgeResult forall a b. (a -> b) -> a -> b $ \ChainDB IO (CardanoBlock StandardCrypto) chainDB -> do SlotNo slotNo <- do Point (CardanoBlock StandardCrypto) 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) SlotNo -> IO SlotNo forall a. a -> IO a forall (f :: * -> *) a. Applicative f => a -> f a pure (SlotNo -> IO SlotNo) -> SlotNo -> IO SlotNo forall a b. (a -> b) -> a -> b $ case Point (CardanoBlock StandardCrypto) -> WithOrigin SlotNo forall {k} (block :: k). Point block -> WithOrigin SlotNo pointSlot Point (CardanoBlock StandardCrypto) tip of WithOrigin SlotNo Origin -> SlotNo 0 At SlotNo s -> SlotNo -> SlotNo forall a. Enum a => a -> a succ SlotNo s String -> IO () putStrLn (String -> IO ()) -> String -> IO () forall a b. (a -> b) -> a -> b $ String "--> starting at: " String -> String -> String forall a. [a] -> [a] -> [a] ++ SlotNo -> String forall a. Show a => a -> String show SlotNo slotNo EpochSize -> SlotNo -> ForgeLimit -> ChainDB IO (CardanoBlock StandardCrypto) -> [BlockForging IO (CardanoBlock StandardCrypto)] -> TopLevelConfig (CardanoBlock StandardCrypto) -> GenTxs (CardanoBlock StandardCrypto) -> IO ForgeResult forall blk. LedgerSupportsProtocol blk => EpochSize -> SlotNo -> ForgeLimit -> ChainDB IO blk -> [BlockForging IO blk] -> TopLevelConfig blk -> GenTxs blk -> IO ForgeResult runForge EpochSize epochSize SlotNo slotNo ForgeLimit synthLimit ChainDB IO (CardanoBlock StandardCrypto) chainDB [BlockForging IO (CardanoBlock StandardCrypto)] forgers TopLevelConfig (CardanoBlock StandardCrypto) pInfoConfig (GenTxs (CardanoBlock StandardCrypto) -> IO ForgeResult) -> GenTxs (CardanoBlock StandardCrypto) -> IO ForgeResult forall a b. (a -> b) -> a -> b $ TopLevelConfig (CardanoBlock StandardCrypto) -> GenTxs (CardanoBlock StandardCrypto) genTxs TopLevelConfig (CardanoBlock StandardCrypto) pInfoConfig else do String -> IO () putStrLn String "--> no forgers found; leaving possibly existing ChainDB untouched" ForgeResult -> IO ForgeResult forall a. a -> IO a forall (f :: * -> *) a. Applicative f => a -> f a pure (ForgeResult -> IO ForgeResult) -> ForgeResult -> IO ForgeResult forall a b. (a -> b) -> a -> b $ Int -> ForgeResult ForgeResult Int 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) pInfoInitLedger :: ExtLedgerState (CardanoBlock StandardCrypto) pInfoInitLedger :: forall b. ProtocolInfo b -> ExtLedgerState b 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 Bool 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 DBSynthesizerOpenMode 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)