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

Commit d9a2e9d

Browse files
iohk-bors[bot]iohk-bors[bot]
committed
Try #3916:
2 parents cdc7728 + ae217c7 commit d9a2e9d

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

50 files changed

+2168
-40
lines changed

‎cabal.project.freeze

+3-4
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,7 @@ constraints: Cabal ==2.2.0.1,
2727
beam-migrate ==0.3.2.1,
2828
beam-sqlite ==0.3.2.3,
2929
bifunctors ==5.5.3,
30+
brick ==0.37.2,
3031
canonical-json ==0.5.0.1,
3132
case-insensitive ==1.2.0.11,
3233
cassava ==0.5.1.0,
@@ -99,7 +100,6 @@ constraints: Cabal ==2.2.0.1,
99100
mmorph ==1.1.2,
100101
monad-control ==1.0.2.3,
101102
mono-traversable ==1.0.9.0,
102-
mtl ==2.2.2,
103103
mwc-random ==0.13.6.0,
104104
neat-interpolation ==0.3.2.2,
105105
network ==2.6.3.6,
@@ -110,7 +110,6 @@ constraints: Cabal ==2.2.0.1,
110110
normaldistribution ==1.1.0.3,
111111
optparse-applicative ==0.14.3.0,
112112
optparse-simple ==0.1.0,
113-
parsec ==3.1.13.0,
114113
parser-combinators ==1.0.0,
115114
parsers ==0.12.9,
116115
pipes ==4.3.9,
@@ -147,7 +146,6 @@ constraints: Cabal ==2.2.0.1,
147146
split ==0.2.3.3,
148147
sqlite-simple ==0.4.16.0,
149148
sqlite-simple-errors ==0.6.1.0,
150-
stm ==2.4.5.1,
151149
stm-chans ==3.0.0.4,
152150
streaming-commons ==0.2.1.0,
153151
strict ==0.3.2,
@@ -159,14 +157,14 @@ constraints: Cabal ==2.2.0.1,
159157
tagged ==0.8.5,
160158
tar ==0.5.1.0,
161159
temporary ==1.3,
162-
text ==1.2.3.1,
163160
th-utilities ==0.2.0.1,
164161
these ==0.7.5,
165162
time-units ==1.0.0,
166163
tls ==1.4.1,
167164
transformers-base ==0.4.5.2,
168165
transformers-lift ==0.2.0.1,
169166
trifecta ==2,
167+
turtle ==1.5.12,
170168
universum ==1.2.0,
171169
unix-compat ==0.5.1,
172170
unliftio ==0.2.8.1,
@@ -175,6 +173,7 @@ constraints: Cabal ==2.2.0.1,
175173
uuid ==1.3.13,
176174
validation ==1,
177175
vector ==0.12.0.1,
176+
vty ==5.21,
178177
wai ==3.2.1.2,
179178
wai-app-static ==3.1.6.2,
180179
wai-cors ==0.2.6,

‎chain/src/Pos/Chain/Update/BlockVersion.hs

+2-8
Original file line numberDiff line numberDiff line change
@@ -9,9 +9,7 @@ import Universum
99

1010
import Data.Aeson.TH (defaultOptions, deriveJSON)
1111
import Data.SafeCopy (base, deriveSafeCopySimple)
12-
import Formatting (bprint, shown)
1312
import qualified Formatting.Buildable as Buildable
14-
import qualified Prelude
1513

1614
import Pos.Binary.Class (Cons (..), Field (..), deriveSimpleBi)
1715
import Pos.Util.Some (Some, liftLensSome)
@@ -21,14 +19,10 @@ data BlockVersion = BlockVersion
2119
{ bvMajor :: !Word16
2220
, bvMinor :: !Word16
2321
, bvAlt :: !Word8
24-
} deriving (Eq, Generic, Ord, Typeable)
25-
26-
instance Show BlockVersion where
27-
show BlockVersion {..} =
28-
intercalate "." [show bvMajor, show bvMinor, show bvAlt]
22+
} deriving (Eq, Generic, Ord, Typeable, Show)
2923

3024
instance Buildable BlockVersion where
31-
build = bprint shown
25+
build BlockVersion{..} = fromString $ intercalate "." [show bvMajor, show bvMinor, show bvAlt]
3226

3327
instance Hashable BlockVersion
3428

‎chain/src/Pos/Chain/Update/Configuration.hs

+19-5
Original file line numberDiff line numberDiff line change
@@ -15,22 +15,29 @@ module Pos.Chain.Update.Configuration
1515
, curSoftwareVersion
1616

1717
, currentSystemTag
18+
19+
, ccApplicationName_L
20+
, ccLastKnownBlockVersion_L
21+
, ccApplicationVersion_L
22+
, ccSystemTag_L
1823
) where
1924

2025
import Universum
2126

22-
import Data.Aeson (FromJSON (..), ToJSON (..), genericToJSON,
23-
withObject, (.:), (.:?))
24-
import Data.Aeson.Options (defaultOptions)
27+
import Control.Lens (makeLensesWith)
28+
import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject,
29+
(.:), (.:?), (.=))
2530
import Data.Maybe (fromMaybe)
2631
import Data.Reflection (Given (..), give)
2732
import Distribution.System (buildArch, buildOS)
2833

29-
import Pos.Chain.Update.ApplicationName (ApplicationName)
34+
import Pos.Chain.Update.ApplicationName
35+
(ApplicationName (ApplicationName))
3036
import Pos.Chain.Update.BlockVersion (BlockVersion (..))
3137
import Pos.Chain.Update.SoftwareVersion (SoftwareVersion (..))
3238
import Pos.Chain.Update.SystemTag (SystemTag (..), archHelper,
3339
osHelper)
40+
import Pos.Util (postfixLFields)
3441

3542
----------------------------------------------------------------------------
3643
-- Config itself
@@ -57,8 +64,15 @@ data UpdateConfiguration = UpdateConfiguration
5764
}
5865
deriving (Eq, Generic, Show)
5966

67+
makeLensesWith postfixLFields ''UpdateConfiguration
68+
6069
instance ToJSON UpdateConfiguration where
61-
toJSON = genericToJSON defaultOptions
70+
toJSON (UpdateConfiguration (ApplicationName appname) lkbv appver (SystemTag systag)) = object [
71+
"applicationName" .= appname
72+
, "lastKnownBlockVersion" .= lkbv
73+
, "applicationVersion" .= appver
74+
, "systemTag" .= systag
75+
]
6276

6377
instance FromJSON UpdateConfiguration where
6478
parseJSON = withObject "UpdateConfiguration" $ \o -> do

‎client/src/Pos/Client/KeyStorage.hs

+1
Original file line numberDiff line numberDiff line change
@@ -71,6 +71,7 @@ getSecretKeys = AllUserSecrets <$> getSecretKeysPlain
7171
getSecretKeysPlain :: MonadKeysRead m => m [EncryptedSecretKey]
7272
getSecretKeysPlain = view usKeys <$> getSecret
7373

74+
{-# INLINE addSecretKey #-}
7475
addSecretKey :: MonadKeys m => EncryptedSecretKey -> m ()
7576
addSecretKey sk = modifySecret $ \us ->
7677
if view usKeys us `containsKey` sk

‎client/src/Pos/Client/Txp/Balances.hs

+1
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,7 @@ getBalanceFromUtxo :: MonadBalances m => GenesisData -> Address -> m Coin
3939
getBalanceFromUtxo genesisData addr =
4040
getTotalCoinsInUtxo <$> getOwnUtxo genesisData addr
4141

42+
{-# INLINE getOwnUtxosGenesis #-}
4243
getOwnUtxosGenesis :: Applicative m => GenesisData -> [Address] -> m Utxo
4344
getOwnUtxosGenesis genesisData addrs =
4445
pure $ filterUtxoByAddrs addrs $ genesisUtxo genesisData

‎cluster/app/demo/Main.hs

+1
Original file line numberDiff line numberDiff line change
@@ -80,6 +80,7 @@ main = void $ do
8080
putTextFromStart $ "..." <> nodeId <> " OK!"
8181
when (nodeType /= NodeEdge) $ putText
8282
$ "\n......address: " <> toText (env ! "LISTEN")
83+
-- todo, dont mapm over chars
8384
putTextLn
8485
$ "\n......api address: " <> toText (env ! "NODE_API_ADDRESS")
8586
<> "\n......doc address: " <> toText (env ! "NODE_DOC_ADDRESS")

‎db/src/Pos/DB/Block/Epoch.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -237,7 +237,7 @@ renderConsolidateError = \case
237237
CEBlockLookupFailed fn lsi h ->
238238
fn <> sformat (": block lookup failed on (" % build % ", " % build % ")") lsi h
239239
CEBBlockNotFound fn lsi hh ->
240-
fn <> sformat (": block mssing : " % build % " " % build) lsi hh
240+
fn <> sformat (": block missing : " % build % " " % build) lsi hh
241241

242242
-- -----------------------------------------------------------------------------
243243

‎db/src/Pos/DB/Txp/Logic/Local.hs

+2
Original file line numberDiff line numberDiff line change
@@ -63,6 +63,7 @@ type TxpProcessTransactionMode ctx m =
6363
, CanJsonLog m
6464
)
6565

66+
{-# INLINE txProcessTransaction #-}
6667
-- | Process transaction. 'TxId' is expected to be the hash of
6768
-- transaction in 'TxAux'. Separation is supported for optimization
6869
-- only.
@@ -199,6 +200,7 @@ txProcessTransactionAbstract epochSlots genesisConfig buildEnv txAction itw@(txI
199200
(Left err@(ToilTipsMismatch {})) -> reportError (pretty err)
200201
_ -> pass
201202

203+
{-# INLINE txNormalize #-}
202204
-- | 1. Recompute UtxoView by current MemPool
203205
-- | 2. Remove invalid transactions from MemPool
204206
-- | 3. Set new tip to txp local data

‎db/src/Pos/DB/Update/GState.hs

+9
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@ module Pos.DB.Update.GState
1616
, getMaxBlockSize
1717
, getSlottingData
1818
, getEpochProposers
19+
, getAllProposals
1920

2021
-- * Operations
2122
, UpdateOp (..)
@@ -209,6 +210,10 @@ initGStateUS genesisConfig = do
209210

210211
data PropIter
211212

213+
-- proposals added by PutProposal, and removed by DeleteProposal
214+
-- upModifierToBatch takes a list of proposals to add&delete
215+
-- listed via getAllProposals, getOldProposals, getDeepProposals, getProposalsByApp
216+
-- does not contain confirmed proposals
212217
instance DBIteratorClass PropIter where
213218
type IterKey PropIter = UpId
214219
type IterValue PropIter = ProposalState
@@ -219,6 +224,10 @@ proposalSource ::
219224
=> ConduitT () (IterType PropIter) (ResourceT m) ()
220225
proposalSource = dbIterSource GStateDB (Proxy @PropIter)
221226

227+
getAllProposals :: (MonadDBRead m, MonadUnliftIO m) => m [(UpId, ProposalState)]
228+
getAllProposals = do
229+
runConduitRes $ proposalSource .| CL.consume
230+
222231
-- TODO: it can be optimized by storing some index sorted by
223232
-- 'SlotId's, but I don't think it may be crucial.
224233
-- | Get all proposals which were issued no later than given slot.

‎default.nix

+1
Original file line numberDiff line numberDiff line change
@@ -271,6 +271,7 @@ let
271271
// { inherit (self.cardanoPackages)
272272
cardano-sl
273273
cardano-sl-auxx
274+
cardano-sl-script-runner
274275
cardano-sl-chain
275276
cardano-sl-cluster
276277
cardano-sl-core

‎infra/src/Pos/Infra/Shutdown/Logic.hs

+29-7
Original file line numberDiff line numberDiff line change
@@ -1,28 +1,50 @@
11
module Pos.Infra.Shutdown.Logic
22
( triggerShutdown
3+
, triggerShutdown'
34
, waitForShutdown
45
) where
56

7+
import System.Exit (ExitCode (ExitFailure))
68
import Universum
79

8-
import Control.Concurrent.STM (check, readTVar, writeTVar)
10+
import Control.Concurrent.STM (readTVar, retry, writeTVar)
911

1012
import Pos.Infra.InjectFail (FInject (..), testLogFInject)
1113
import Pos.Infra.Shutdown.Class (HasShutdownContext (..))
1214
import Pos.Infra.Shutdown.Types (ShutdownContext (..), shdnFInjects,
1315
shdnIsTriggered)
1416
import Pos.Util.Wlog (WithLogger, logInfo)
1517

16-
triggerShutdown
18+
{-# INLINE triggerShutdown' #-}
19+
triggerShutdown'
1720
:: (MonadIO m, MonadReader ctx m, WithLogger m, HasShutdownContext ctx)
18-
=> m ()
19-
triggerShutdown = do
21+
=> ExitCode -> m ()
22+
triggerShutdown' exitcode = do
2023
shutCtx <- view shutdownContext
2124
doFail <- liftIO $ testLogFInject (shutCtx ^. shdnFInjects) FInjIgnoreShutdown
25+
applyWrongCode <- liftIO $ testLogFInject (shutCtx ^. shdnFInjects) FInjApplyUpdateWrongExitCode
26+
let
27+
realCode = if applyWrongCode
28+
then ExitFailure 42 -- inject wrong exit code
29+
else exitcode
2230
unless doFail $ do
2331
logInfo "NODE SHUTDOWN TRIGGERED, WAITING FOR WORKERS TO TERMINATE"
24-
view (shutdownContext . shdnIsTriggered) >>= atomically . flip writeTVar True
32+
view (shutdownContext . shdnIsTriggered) >>= atomically . flip writeTVar (Just realCode)
33+
34+
{-# INLINE triggerShutdown #-}
35+
triggerShutdown
36+
:: (MonadIO m, MonadReader ctx m, WithLogger m, HasShutdownContext ctx)
37+
=> m ()
38+
triggerShutdown = triggerShutdown' $ ExitFailure 20 -- special exit code to indicate an update
2539

2640
-- | Wait for the shutdown var to be true.
27-
waitForShutdown :: ShutdownContext -> IO ()
28-
waitForShutdown (ShutdownContext shutdownTriggered _) = atomically (readTVar shutdownTriggered >>= check)
41+
waitForShutdown :: ShutdownContext -> IO ExitCode
42+
waitForShutdown (ShutdownContext shutdownTriggered _) = do
43+
let
44+
go :: STM ExitCode
45+
go = do
46+
res <- readTVar shutdownTriggered
47+
case res of
48+
Nothing -> retry
49+
Just a -> pure a
50+
atomically go

‎infra/src/Pos/Infra/Shutdown/Types.hs

+3-2
Original file line numberDiff line numberDiff line change
@@ -5,15 +5,16 @@ module Pos.Infra.Shutdown.Types
55
, shdnIsTriggered, shdnFInjects
66
) where
77

8+
import System.Exit (ExitCode)
89
import Universum
910

1011
import Control.Lens (makeLenses)
1112
import Pos.Infra.InjectFail (FInjects)
1213

1314
data ShutdownContext = ShutdownContext
14-
{ _shdnIsTriggered :: !(TVar Bool)
15+
{ _shdnIsTriggered :: !(TVar (Maybe ExitCode))
16+
-- ^ If this flag is `Just`, then workers should stop.
1517
, _shdnFInjects :: !(FInjects IO)
16-
-- ^ If this flag is `True`, then workers should stop.
1718
}
1819

1920
makeLenses ''ShutdownContext

‎lib/cardano-sl.cabal

+2
Original file line numberDiff line numberDiff line change
@@ -295,7 +295,9 @@ test-suite cardano-test
295295
Test.Pos.ConstantsSpec
296296
Test.Pos.Diffusion.BlockSpec
297297
Test.Pos.Genesis.CanonicalSpec
298+
Test.Pos.Launcher.Configuration
298299
Test.Pos.Launcher.ConfigurationSpec
300+
Test.Pos.Launcher.Gen
299301
Test.Pos.Launcher.Json
300302
Test.Pos.MerkleSpec
301303
Test.Pos.Infra.Slotting.TypesSpec

‎lib/src/Pos/Client/CLI/NodeOptions.hs

+23
Original file line numberDiff line numberDiff line change
@@ -17,16 +17,37 @@ module Pos.Client.CLI.NodeOptions
1717
, getSimpleNodeOptions
1818
, getNodeApiOptions
1919
, usageExample
20+
21+
, dbPath_L
22+
, rebuildDB_L
23+
, cnaAssetLockPath_L
24+
, devGenesisSecretI_L
25+
, publicKeyfilePath_L
26+
, keyfilePath_L
27+
, networkConfigOpts_L
28+
, jlPath_L
29+
, commonArgs_L
30+
, updateLatestPath_L
31+
, updateWithPackage_L
32+
, route53Params_L
33+
, enableMetrics_L
34+
, ekgParams_L
35+
, statsdParams_L
36+
, cnaDumpGenesisDataPath_L
37+
, cnaDumpConfiguration_L
38+
, cnaFInjectsSpec_L
2039
) where
2140

2241
import Universum
2342

43+
import Control.Lens (makeLensesWith)
2444
import Data.Version (showVersion)
2545
import NeatInterpolation (text)
2646
import Options.Applicative (Parser, auto, execParser, footerDoc,
2747
fullDesc, header, help, helper, info, infoOption, long,
2848
metavar, option, progDesc, showDefault, strOption, switch,
2949
value)
50+
import Pos.Util (postfixLFields)
3051
import Text.PrettyPrint.ANSI.Leijen (Doc)
3152

3253
import Paths_cardano_sl (version)
@@ -67,6 +88,8 @@ data CommonNodeArgs = CommonNodeArgs
6788
, cnaFInjectsSpec :: !FInjectsSpec
6889
} deriving Show
6990

91+
makeLensesWith postfixLFields ''CommonNodeArgs
92+
7093
commonNodeArgsParser :: Parser CommonNodeArgs
7194
commonNodeArgsParser = do
7295
dbPath <- optional $ strOption $

‎lib/src/Pos/Client/CLI/Options.hs

+11
Original file line numberDiff line numberDiff line change
@@ -18,14 +18,23 @@ module Pos.Client.CLI.Options
1818
, templateParser
1919

2020
, nodeIdOption
21+
22+
, logConfig_L
23+
, logPrefix_L
24+
, logConsoleOff_L
25+
, reportServers_L
26+
, updateServers_L
27+
, configurationOptions_L
2128
) where
2229

2330
import Universum
2431

32+
import Control.Lens (makeLensesWith)
2533
import Data.Default (def)
2634
import Data.Time.Units (fromMicroseconds)
2735
import qualified Options.Applicative as Opt
2836
import Options.Applicative.Builder.Internal (HasMetavar, HasName)
37+
import Pos.Util (postfixLFields)
2938
import Pos.Util.OptParse (fromParsec)
3039

3140
import Pos.Communication (NodeId)
@@ -44,6 +53,8 @@ data CommonArgs = CommonArgs
4453
, configurationOptions :: !ConfigurationOptions
4554
} deriving Show
4655

56+
makeLensesWith postfixLFields ''CommonArgs
57+
4758
commonArgsParser :: Opt.Parser CommonArgs
4859
commonArgsParser = do
4960
logConfig <- optionalLogConfig

‎lib/src/Pos/DB/DB.hs

+1
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@ import Pos.DB.Lrc (prepareLrcDB)
1717
import Pos.DB.Update (getAdoptedBVData)
1818
import Pos.GState.GState (prepareGStateDB)
1919

20+
{-# INLINE initNodeDBs #-}
2021
-- | Initialize DBs if necessary.
2122
initNodeDBs
2223
:: forall ctx m

0 commit comments

Comments
 (0)