{-# 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)