-
Notifications
You must be signed in to change notification settings - Fork 20
/
Run.hs
176 lines (163 loc) · 7.82 KB
/
Run.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Cardano.Tools.DBSynthesizer.Run (
initialize
, synthesize
) where
import Cardano.Api.Any (displayError)
import Cardano.Api.Protocol.Types (protocolInfo)
import Cardano.Node.Protocol
import Cardano.Node.Types
import Cardano.Tools.DBSynthesizer.Forging
import Cardano.Tools.DBSynthesizer.Orphans ()
import Cardano.Tools.DBSynthesizer.Types
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 Ouroboros.Consensus.Config (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, SomeConsensusProtocol))
initialize NodeFilePaths{nfpConfig, nfpChainDB} creds synthOptions = do
relativeToConfig :: (FilePath -> FilePath) <-
(</>) . takeDirectory <$> makeAbsolute nfpConfig
runExceptT $ do
conf <- initConf relativeToConfig
proto <- initProtocol relativeToConfig conf
pure (conf, proto)
where
initConf :: (FilePath -> FilePath) -> ExceptT String IO DBSynthesizerConfig
initConf relativeToConfig = do
inp <- handleIOExceptT show (BS.readFile nfpConfig)
configStub <- adjustFilePaths relativeToConfig <$> readJson inp
shelleyGenesis <- readFileJson $ ncsShelleyGenesisFile configStub
_ <- hoistEither $ validateGenesis shelleyGenesis
let
protocolCredentials = ProtocolFilepaths {
byronCertFile = Nothing
, byronKeyFile = Nothing
, shelleyKESFile = credKESFile creds
, shelleyVRFFile = credVRFFile creds
, shelleyCertFile = credCertFile creds
, shelleyBulkCredsFile = credBulkFile creds
}
pure DBSynthesizerConfig {
confConfigStub = configStub
, confOptions = synthOptions
, confProtocolCredentials = protocolCredentials
, confShelleyGenesis = shelleyGenesis
, confDbDir = nfpChainDB
}
initProtocol :: (FilePath -> FilePath) -> DBSynthesizerConfig -> ExceptT String IO SomeConsensusProtocol
initProtocol relativeToConfig DBSynthesizerConfig{confConfigStub, confProtocolCredentials} = do
hfConfig :: NodeHardForkProtocolConfiguration <-
hoistEither hfConfig_
byronConfig :: NodeByronProtocolConfiguration <-
adjustFilePaths relativeToConfig <$> hoistEither byConfig_
let
cardanoConfig = NodeProtocolConfigurationCardano byronConfig shelleyConfig alonzoConfig conwayConfig hfConfig
firstExceptT displayError $
mkConsensusProtocol
cardanoConfig
(Just confProtocolCredentials)
where
shelleyConfig = NodeShelleyProtocolConfiguration (GenesisFile $ ncsShelleyGenesisFile confConfigStub) Nothing
alonzoConfig = NodeAlonzoProtocolConfiguration (GenesisFile $ ncsAlonzoGenesisFile confConfigStub) Nothing
conwayConfig = NodeConwayProtocolConfiguration (GenesisFile $ ncsConwayGenesisFile confConfigStub) Nothing
hfConfig_ = eitherParseJson $ ncsNodeConfig confConfigStub
byConfig_ = eitherParseJson $ ncsNodeConfig confConfigStub
readJson :: (Monad m, FromJSON a) => ByteString -> ExceptT String m a
readJson = hoistEither . eitherDecodeStrict'
readFileJson :: FromJSON a => FilePath -> ExceptT String IO a
readFileJson f = handleIOExceptT show (eitherDecodeFileStrict' f) >>= hoistEither
eitherParseJson :: FromJSON a => Aeson.Value -> Either String a
eitherParseJson v = case fromJSON v of
Error err -> Left err
Success a -> Right a
synthesize :: DBSynthesizerConfig -> SomeConsensusProtocol -> IO ForgeResult
synthesize DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir} (SomeConsensusProtocol _ runP) =
withRegistry $ \registry -> do
let
epochSize = sgEpochLength confShelleyGenesis
chunkInfo = Node.nodeImmutableDbChunkInfo (configStorage pInfoConfig)
dbArgs =
ChainDB.completeChainDbArgs
registry
InFuture.dontCheck
pInfoConfig
pInfoInitLedger
chunkInfo
(const True)
(Node.stdMkChainDbHasFS confDbDir)
$ ChainDB.defaultArgs
forgers <- blockForging
let fCount = length 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 = nullTracer
ChainDB.withDB (ChainDB.updateTracer dbTracer dbArgs) $ \chainDB -> do
slotNo <- do
tip <- atomically (ChainDB.getTipPoint chainDB)
pure $ case pointSlot tip of
Origin -> 0
At s -> succ s
putStrLn $ "--> starting at: " ++ show slotNo
runForge epochSize slotNo synthLimit chainDB forgers pInfoConfig
else do
putStrLn "--> no forgers found; leaving possibly existing ChainDB untouched"
pure $ ForgeResult 0
where
DBSynthesizerOptions
{ synthOpenMode
, synthLimit
} = confOptions
( ProtocolInfo
{ pInfoConfig
, pInfoInitLedger
}
, blockForging
) = protocolInfo runP
preOpenChainDB :: DBSynthesizerOpenMode -> FilePath -> IO ()
preOpenChainDB mode db =
doesDirectoryExist db >>= bool create checkMode
where
checkIsDB ls = length ls <= 3 && all (`elem` ["immutable", "ledger", "volatile"]) ls
loc = "preOpenChainDB: '" ++ db ++ "'"
create = createDirectoryIfMissing True db
checkMode = do
isChainDB <- checkIsDB <$> listDirectory db
case mode of
OpenCreate ->
fail $ loc ++ " already exists. Use -f to overwrite or -a to append."
OpenAppend | isChainDB ->
pure ()
OpenCreateForce | isChainDB ->
removePathForcibly db >> create
_ ->
fail $ loc ++ " is non-empty and does not look like a ChainDB. Aborting."