Skip to content
This repository was archived by the owner on Aug 18, 2020. It is now read-only.

Commit 857e0c1

Browse files
cleverca22cleverca22
committed
[DEVOPS-1131] improve the code style more, and implement proper shutdown
1 parent a8c4395 commit 857e0c1

10 files changed

+214
-110
lines changed

‎nix/overlays/required.nix

+2
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,8 @@ self: super: {
3434
cardano-sl-networking = addRealTimeTestLogs super.cardano-sl-networking;
3535
data-clist = doJailbreak super.data-clist;
3636
mtl = null;
37+
stm = null;
38+
text = null;
3739

3840
########################################################################
3941
# The base Haskell package builder

‎script-runner/AutomatedTestRunner.hs

+92-61
Original file line numberDiff line numberDiff line change
@@ -11,57 +11,58 @@
1111

1212
module AutomatedTestRunner (Example, getGenesisConfig, loadNKeys, doUpdate, onStartup, on, getScript, runScript, NodeType(..), startNode) where
1313

14+
import Brick hiding (on)
15+
import Brick.BChan
16+
import BrickUI
17+
import BrickUITypes
18+
import Control.Concurrent
19+
import Control.Concurrent.Async.Lifted.Safe
20+
import Control.Exception (throw)
21+
import Control.Lens (to)
22+
import Control.Monad.STM (orElse)
23+
import Data.Constraint (Dict(Dict))
24+
import Data.Default (Default(def))
25+
import Data.Ix (range)
1426
import Data.List ((!!))
27+
import Data.Reflection (Given, given, give)
1528
import Data.Version (showVersion)
1629
import Options.Applicative (Parser, execParser, footerDoc, fullDesc, header, help, helper, info, infoOption, long, progDesc)
1730
import Paths_cardano_sl (version)
1831
import Pos.Client.KeyStorage (getSecretKeysPlain, addSecretKey)
1932
import Pos.Crypto (emptyPassphrase, hash, hashHexF, withSafeSigners, noPassEncrypt)
33+
import Pos.DB.BlockIndex (getTipHeader)
2034
import Pos.Util.CompileInfo (CompileTimeInfo (ctiGitRevision), HasCompileInfo, compileInfo, withCompileInfo)
2135
import Prelude (show)
2236
import Text.PrettyPrint.ANSI.Leijen (Doc)
2337
import Universum hiding (when, show, on, state)
24-
import Control.Lens (to)
25-
import Pos.DB.BlockIndex (getTipHeader)
2638
import qualified Pos.Client.CLI as CLI
2739
import Pos.Launcher (HasConfigurations, NodeParams (npBehaviorConfig, npUserSecret, npNetworkConfig),
2840
NodeResources, WalletConfiguration,
2941
bracketNodeResources, loggerBracket,
3042
runNode, runRealMode, withConfigurations, InitModeContext)
31-
import Control.Exception (throw)
32-
import Data.Constraint (Dict(Dict))
33-
import Data.Default (Default(def))
34-
import Data.Reflection (Given, given, give)
3543
import Formatting (int, sformat, (%), Format)
36-
import PocMode (AuxxContext(AuxxContext, acRealModeContext), AuxxMode, realModeToAuxx)
44+
import Graphics.Vty (mkVty, defaultConfig, defAttr)
3745
import Ntp.Client (NtpConfiguration)
46+
import PocMode (AuxxContext(AuxxContext, acRealModeContext), AuxxMode, realModeToAuxx)
47+
import Pos.Chain.Block (LastKnownHeaderTag)
3848
import Pos.Chain.Genesis as Genesis (Config (configGeneratedSecrets, configProtocolMagic), configEpochSlots)
3949
import Pos.Chain.Txp (TxpConfiguration)
4050
import Pos.Chain.Update (UpdateData, SystemTag, mkUpdateProposalWSign, BlockVersion, SoftwareVersion, BlockVersionModifier, updateConfiguration)
4151
import Pos.Client.Update.Network (submitUpdateProposal)
4252
import Pos.Core (LocalSlotIndex, SlotId (SlotId, siEpoch, siSlot), mkLocalSlotIndex, EpochIndex(EpochIndex), SlotCount, getEpochIndex, getSlotIndex, difficultyL, getChainDifficulty, getBlockCount, getEpochOrSlot)
4353
import Pos.DB.DB (initNodeDBs)
4454
import Pos.DB.Txp (txpGlobalSettings)
45-
import Pos.Infra.DHT.Real.Param (KademliaParams)
4655
import Pos.Infra.Diffusion.Types (Diffusion, hoistDiffusion)
4756
import Pos.Infra.Network.Types (NetworkConfig (ncTopology, ncEnqueuePolicy, ncDequeuePolicy, ncFailurePolicy), Topology (TopologyAuxx), topologyDequeuePolicy, topologyEnqueuePolicy, topologyFailurePolicy, NodeId)
57+
import Pos.Infra.Shutdown (triggerShutdown)
4858
import Pos.Infra.Slotting.Util (onNewSlot, defaultOnNewSlotParams)
4959
import Pos.Util (logException, lensOf)
50-
import Control.Monad.STM (orElse)
5160
import Pos.Util.UserSecret (usVss, readUserSecret, usPrimKey, usKeys)
5261
import Pos.Util.Wlog (LoggerName)
5362
import Pos.WorkMode (RealMode, EmptyMempoolExt)
5463
import qualified Data.HashMap.Strict as HM
5564
import qualified Data.Map as Map
5665
import qualified Data.Text as T
57-
import Data.Ix (range)
58-
import Control.Concurrent.Async.Lifted.Safe
59-
import Brick hiding (on)
60-
import Brick.BChan
61-
import Graphics.Vty (mkVty, defaultConfig, defAttr)
62-
import Control.Concurrent
63-
import Pos.Chain.Block (LastKnownHeaderTag)
64-
import BrickUI
6566

6667
class TestScript a where
6768
getScript :: a -> Script
@@ -85,9 +86,7 @@ data Script = Script
8586
, startupActions :: [ SlotTrigger ]
8687
} deriving (Show, Generic)
8788

88-
data SlotTrigger = SlotTrigger
89-
{ stAction :: Dict HasConfigurations -> Diffusion AuxxMode -> AuxxMode ()
90-
}
89+
data SlotTrigger = SlotTrigger (Dict HasConfigurations -> Diffusion AuxxMode -> AuxxMode ())
9190

9291
instance Show SlotTrigger where
9392
show _ = "IO ()"
@@ -105,6 +104,7 @@ instance HasEpochSlots => TestScript (Example a) where
105104
instance TestScript Script where
106105
getScript = identity
107106

107+
data NodeHandle = NodeHandle (Async ())
108108

109109
data EpochSlots = EpochSlots { epochSlots :: SlotCount, config :: Config }
110110
type HasEpochSlots = Given EpochSlots
@@ -142,42 +142,49 @@ getScriptRunnerOptions = execParser programInfo
142142
loggerName :: LoggerName
143143
loggerName = "script-runner"
144144

145-
thing :: (TestScript a, HasCompileInfo) => ScriptRunnerOptions -> (HasEpochSlots => IO a) -> BChan CustomEvent -> IO ()
146-
thing opts@ScriptRunnerOptions{..} scriptGetter eventChan = do
145+
thing :: (TestScript a, HasCompileInfo) => ScriptRunnerOptions -> InputParams a -> IO ()
146+
thing opts@ScriptRunnerOptions{..} inputParams = do
147147
let
148148
conf = CLI.configurationOptions (CLI.commonArgs cArgs)
149149
cArgs@CLI.CommonNodeArgs{..} = srCommonNodeArgs
150-
withConfigurations Nothing cnaDumpGenesisDataPath cnaDumpConfiguration conf (runWithConfig opts scriptGetter eventChan)
150+
withConfigurations Nothing cnaDumpGenesisDataPath cnaDumpConfiguration conf (runWithConfig opts inputParams)
151151

152-
runWithConfig :: (TestScript a, HasCompileInfo, HasConfigurations) => ScriptRunnerOptions -> (HasEpochSlots => IO a) -> BChan CustomEvent -> Genesis.Config -> WalletConfiguration -> TxpConfiguration -> NtpConfiguration -> IO ()
153-
runWithConfig ScriptRunnerOptions{..} scriptGetter eventChan genesisConfig _walletConfig txpConfig _ntpConfig = do
152+
maybeAddPeers :: [NodeId] -> NodeParams -> NodeParams
153+
maybeAddPeers [] params = params
154+
maybeAddPeers peers nodeParams = nodeParams { npNetworkConfig = (npNetworkConfig nodeParams) { ncTopology = TopologyAuxx peers } }
155+
156+
addQueuePolicies :: NodeParams -> NodeParams
157+
addQueuePolicies nodeParams = do
158+
let
159+
topology = ncTopology $ npNetworkConfig nodeParams
160+
nodeParams { npNetworkConfig = (npNetworkConfig nodeParams)
161+
{ ncEnqueuePolicy = topologyEnqueuePolicy topology
162+
, ncDequeuePolicy = topologyDequeuePolicy topology
163+
, ncFailurePolicy = topologyFailurePolicy topology
164+
}
165+
}
166+
167+
runWithConfig :: (TestScript a, HasCompileInfo, HasConfigurations) => ScriptRunnerOptions -> InputParams a -> Genesis.Config -> WalletConfiguration -> TxpConfiguration -> NtpConfiguration -> IO ()
168+
runWithConfig ScriptRunnerOptions{..} inputParams genesisConfig _walletConfig txpConfig _ntpConfig = do
154169
let
155170
cArgs@CLI.CommonNodeArgs {..} = srCommonNodeArgs
156-
nArgs =
157-
CLI.NodeArgs {behaviorConfigPath = Nothing}
171+
nArgs = CLI.NodeArgs {behaviorConfigPath = Nothing}
158172
(nodeParams', _mSscParams) <- CLI.getNodeParams loggerName cArgs nArgs (configGeneratedSecrets genesisConfig)
159173
let
160-
topology :: Topology KademliaParams
161-
topology = TopologyAuxx srPeers
162-
nodeParams = nodeParams' {
163-
npNetworkConfig = (npNetworkConfig nodeParams')
164-
{ ncTopology = topology
165-
, ncEnqueuePolicy = topologyEnqueuePolicy topology
166-
, ncDequeuePolicy = topologyDequeuePolicy topology
167-
, ncFailurePolicy = topologyFailurePolicy topology
168-
}
169-
}
174+
nodeParams = addQueuePolicies $ maybeAddPeers srPeers $ nodeParams'
170175
epochSlots = configEpochSlots genesisConfig
171176
vssSK = fromMaybe (error "no user secret given") (npUserSecret nodeParams ^. usVss)
172177
sscParams = CLI.gtSscParams cArgs vssSK (npBehaviorConfig nodeParams)
173178
thing1 = txpGlobalSettings genesisConfig txpConfig
174179
thing2 :: ReaderT InitModeContext IO ()
175180
thing2 = initNodeDBs genesisConfig
176-
script <- liftIO $ withEpochSlots epochSlots genesisConfig scriptGetter
177-
bracketNodeResources genesisConfig nodeParams sscParams thing1 thing2 (thing3 genesisConfig txpConfig script eventChan)
181+
script <- liftIO $ withEpochSlots epochSlots genesisConfig (ipScriptGetter inputParams)
182+
let
183+
inputParams' = InputParams2 (ipEventChan inputParams) (ipReplyChan inputParams) script
184+
bracketNodeResources genesisConfig nodeParams sscParams thing1 thing2 (thing3 genesisConfig txpConfig inputParams')
178185

179-
thing3 :: (TestScript a, HasCompileInfo, HasConfigurations) => Config -> TxpConfiguration -> a -> BChan CustomEvent -> NodeResources () -> IO ()
180-
thing3 genesisConfig txpConfig script eventChan nr = do
186+
thing3 :: (TestScript a, HasCompileInfo, HasConfigurations) => Config -> TxpConfiguration -> InputParams2 a -> NodeResources () -> IO ()
187+
thing3 genesisConfig txpConfig inputParams nr = do
181188
let
182189
toRealMode :: AuxxMode a -> RealMode EmptyMempoolExt a
183190
toRealMode auxxAction = do
@@ -188,15 +195,24 @@ thing3 genesisConfig txpConfig script eventChan nr = do
188195
thing5 :: Diffusion AuxxMode -> AuxxMode ()
189196
thing5 = runNode genesisConfig txpConfig nr thing4
190197
thing4 :: [ (Text, Diffusion AuxxMode -> AuxxMode ()) ]
191-
thing4 = workers genesisConfig script eventChan
198+
thing4 = workers genesisConfig inputParams
192199
runRealMode updateConfiguration genesisConfig txpConfig nr thing2
193200

194-
workers :: (HasConfigurations, TestScript a) => Genesis.Config -> a -> BChan CustomEvent -> [ (Text, Diffusion AuxxMode -> AuxxMode ()) ]
195-
workers genesisConfig script eventChan =
196-
[ ( T.pack "worker1", worker1 genesisConfig script eventChan)
197-
, ( "worker2", worker2 eventChan)
201+
workers :: (HasConfigurations, TestScript a) => Genesis.Config -> InputParams2 a -> [ (Text, Diffusion AuxxMode -> AuxxMode ()) ]
202+
workers genesisConfig InputParams2{ip2EventChan,ip2Script,ip2ReplyChan} =
203+
[ ( T.pack "worker1", worker1 genesisConfig ip2Script ip2EventChan)
204+
, ( "worker2", worker2 ip2EventChan)
205+
, ( "brick reply worker", brickReplyWorker ip2ReplyChan)
198206
]
199207

208+
brickReplyWorker :: HasConfigurations => BChan Reply -> Diffusion AuxxMode -> AuxxMode ()
209+
brickReplyWorker replyChan diffusion = do
210+
reply <- liftIO $ readBChan replyChan
211+
case reply of
212+
TriggerShutdown -> do
213+
triggerShutdown
214+
brickReplyWorker replyChan diffusion
215+
200216
worker2 :: HasConfigurations => BChan CustomEvent -> Diffusion AuxxMode -> AuxxMode ()
201217
worker2 eventChan diffusion = do
202218
localTip <- getTipHeader
@@ -208,7 +224,7 @@ worker2 eventChan diffusion = do
208224
f (Just v) = Just $ getBlockCount v
209225
f Nothing = Nothing
210226
liftIO $ do
211-
writeBChan eventChan $ NodeInfoEvent (getBlockCount localHeight) (getEpochOrSlot localTip) (f globalHeight)
227+
writeBChan eventChan $ CENodeInfo $ NodeInfo (getBlockCount localHeight) (getEpochOrSlot localTip) (f globalHeight)
212228
threadDelay 100000
213229
worker2 eventChan diffusion
214230

@@ -217,8 +233,7 @@ worker1 genesisConfig script eventChan diffusion = do
217233
let
218234
handler :: SlotId -> AuxxMode ()
219235
handler slotid = do
220-
liftIO $ writeBChan eventChan $ SlotStart (getEpochIndex $ siEpoch slotid) (getSlotIndex $ siSlot slotid)
221-
print slotid
236+
liftIO $ writeBChan eventChan $ CESlotStart $ SlotStart (getEpochIndex $ siEpoch slotid) (getSlotIndex $ siSlot slotid)
222237
case Map.lookup slotid (slotTriggers realScript) of
223238
Just (SlotTrigger act) -> runAction act
224239
Nothing -> pure ()
@@ -235,37 +250,53 @@ worker1 genesisConfig script eventChan diffusion = do
235250
pure ()
236251
realWorker `catch` errhandler @SomeException
237252

253+
data TestScript a => InputParams a = InputParams
254+
{ ipEventChan :: BChan CustomEvent
255+
, ipReplyChan :: BChan Reply
256+
, ipScriptGetter :: HasEpochSlots => IO a
257+
}
258+
data TestScript a => InputParams2 a = InputParams2
259+
{ ip2EventChan :: BChan CustomEvent
260+
, ip2ReplyChan :: BChan Reply
261+
, ip2Script :: a
262+
}
263+
238264
runScript :: TestScript a => (HasEpochSlots => IO a) -> IO ()
239265
runScript scriptGetter = withCompileInfo $ do
240-
(eventChan, asyncUi) <- runUI
266+
(eventChan, replyChan, asyncUi) <- runUI
241267
opts <- getScriptRunnerOptions
242268
let
269+
inputParams = InputParams eventChan replyChan scriptGetter
243270
loggingParams = CLI.loggingParams loggerName (srCommonNodeArgs opts)
244271
loggerBracket "script-runner" loggingParams . logException "script-runner" $ do
245-
thing opts scriptGetter eventChan
272+
thing opts inputParams
246273
pure ()
247274
liftIO $ writeBChan eventChan QuitEvent
248275
finalState <- wait asyncUi
249-
print finalState
276+
--print finalState
277+
pure ()
250278

251-
runUI :: IO (BChan CustomEvent, Async AppState)
279+
runUI :: IO (BChan CustomEvent, BChan Reply, Async AppState)
252280
runUI = do
253281
eventChan <- newBChan 10
282+
replyChan <- newBChan 10
254283
let
255284
app = App
256285
{ appDraw = ui
257-
, appChooseCursor = \_ _ -> Nothing
286+
, appChooseCursor = showFirstCursor
258287
, appHandleEvent = handleEvent
259288
, appStartEvent = \x -> pure x
260289
, appAttrMap = const $ attrMap defAttr []
261290
}
262291
state :: AppState
263-
state = AppState 0 Nothing "" Nothing
292+
state = AppState 0 Nothing "" Nothing replyChan
264293
go :: IO AppState
265294
go = do
266-
customMain (mkVty defaultConfig) (Just eventChan) app state
295+
finalState <- customMain (mkVty defaultConfig) (Just eventChan) app state
296+
writeBChan replyChan TriggerShutdown
297+
pure finalState
267298
brick <- async go
268-
pure (eventChan, brick)
299+
pure (eventChan, replyChan, brick)
269300

270301
getGenesisConfig :: Example Config
271302
getGenesisConfig = do
@@ -356,14 +387,14 @@ loadNKeys n = do
356387
addSecretKey $ noPassEncrypt primSk
357388
mapM_ loadKey (range (0,n - 1))
358389

359-
data NodeHandle = NodeHandle
360-
361390
startNode :: NodeType -> IO NodeHandle
362391
startNode (Core idx) = do
363392
let
364-
params = [ "--configuration-file", "../lib/configuration.yaml"
393+
_params = [ "--configuration-file", "../lib/configuration.yaml"
365394
, "--system-start", "1543100429"
366395
, "--db-path", "poc-state/core" <> (show idx) <> "-db"
367396
, "--keyfile", "poc-state/secret" <> (show idx) <> ".key"
368397
]
369-
pure undefined
398+
later <- async $ do
399+
pure ()
400+
pure $ NodeHandle later

‎script-runner/BlockParser.hs

+3-3
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
{-# LANGUAGE NoImplicitPrelude #-}
22
{-# LANGUAGE OverloadedStrings #-}
33

4-
module BlockParser where
4+
module BlockParser (file1, file2, printBlock) where
55

66
import Universum hiding (when, openFile)
77
import Codec.CBOR.Read (deserialiseFromBytes)
@@ -21,8 +21,8 @@ printBlock filename = do
2121
raw <- LBS.readFile filename
2222
let
2323
blockraw :: LBS.ByteString
24-
undoraw :: LBS.ByteString
25-
Right ("", (blockraw, undoraw)) = deserialiseFromBytes decode raw
24+
_undoraw :: LBS.ByteString
25+
Right ("", (blockraw, _undoraw)) = deserialiseFromBytes decode raw
2626
block :: Block
2727
Right ("", block) = deserialiseFromBytes decode blockraw
2828
case block of

0 commit comments

Comments
 (0)