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

Commit

Permalink
[CDEC-369] Remove HasProtocolConstants in favour of parameters
Browse files Browse the repository at this point in the history
  • Loading branch information
@ruhatch @erikd
ruhatch authored and erikd committed Jun 30, 2018
1 parent b328d66 commit 9779582
Show file tree
Hide file tree
Showing 193 changed files with 3,542 additions and 2,881 deletions.
93 changes: 59 additions & 34 deletions auxx/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,7 +14,8 @@ import System.Wlog (LoggerName, logInfo)

import qualified Pos.Client.CLI as CLI
import Pos.Context (NodeContext (..))
import Pos.Core (ConfigurationError, epochSlots)
import Pos.Core (ConfigurationError, ProtocolConstants,
pcBlkSecurityParam)
import Pos.Crypto (ProtocolMagic)
import Pos.DB.DB (initNodeDBs)
import Pos.Infra.Diffusion.Types (Diffusion, hoistDiffusion)
Expand Down Expand Up @@ -72,64 +73,88 @@ correctNodeParams AuxxOptions {..} np = do
, ncTcpAddr = TCP.Unaddressable
}

runNodeWithSinglePlugin ::
(HasConfigurations, HasCompileInfo)
runNodeWithSinglePlugin
:: (HasConfigurations, HasCompileInfo)
=> ProtocolMagic
-> ProtocolConstants
-> NodeResources EmptyMempoolExt
-> (Diffusion AuxxMode -> AuxxMode ())
-> Diffusion AuxxMode -> AuxxMode ()
runNodeWithSinglePlugin pm nr plugin =
runNode pm nr [plugin]
-> Diffusion AuxxMode
-> AuxxMode ()
runNodeWithSinglePlugin pm pc nr plugin =
runNode pm pc nr [plugin]

action :: HasCompileInfo => AuxxOptions -> Either WithCommandAction Text -> Production ()
action
:: HasCompileInfo
=> AuxxOptions
-> Either WithCommandAction Text
-> Production ()
action opts@AuxxOptions {..} command = do
let pa = either printAction (const putText) command
case aoStartMode of
Automatic
->
handle @_ @ConfigurationException (\_ -> runWithoutNode pa)
. handle @_ @ConfigurationError (\_ -> runWithoutNode pa)
$ withConfigurations Nothing conf (runWithConfig pa)
Light
-> runWithoutNode pa
_ -> withConfigurations Nothing conf (runWithConfig pa)

Automatic ->
handle @_ @ConfigurationException (\_ -> runWithoutNode pa)
. handle @_ @ConfigurationError (\_ -> runWithoutNode pa)
$ withConfigurations Nothing conf (runWithConfig pa)
Light -> runWithoutNode pa
_ -> withConfigurations Nothing conf (runWithConfig pa)
where
runWithoutNode :: PrintAction Production -> Production ()
runWithoutNode printAction = printAction "Mode: light" >> rawExec Nothing Nothing opts Nothing command
runWithoutNode printAction =
printAction "Mode: light"
>> rawExec Nothing Nothing Nothing opts Nothing command

runWithConfig :: HasConfigurations => PrintAction Production -> NtpConfiguration -> ProtocolMagic -> Production ()
runWithConfig printAction ntpConfig pm = do
runWithConfig
:: HasConfigurations
=> PrintAction Production
-> NtpConfiguration
-> ProtocolMagic
-> ProtocolConstants
-> Production ()
runWithConfig printAction ntpConfig pm pc = do
printAction "Mode: with-config"
CLI.printInfoOnStart aoCommonNodeArgs ntpConfig
(nodeParams, tempDbUsed) <-
correctNodeParams opts =<< CLI.getNodeParams loggerName cArgs nArgs

let toRealMode :: AuxxMode a -> RealMode EmptyMempoolExt a
let
toRealMode :: AuxxMode a -> RealMode EmptyMempoolExt a
toRealMode auxxAction = do
realModeContext <- ask
let auxxContext =
AuxxContext
let auxxContext = AuxxContext
{ acRealModeContext = realModeContext
, acTempDbUsed = tempDbUsed }
, acTempDbUsed = tempDbUsed
}
lift $ runReaderT auxxAction auxxContext
vssSK = fromMaybe (error "no user secret given")
(npUserSecret nodeParams ^. usVss)
sscParams = CLI.gtSscParams cArgs vssSK (npBehaviorConfig nodeParams)
sscParams =
CLI.gtSscParams cArgs vssSK (npBehaviorConfig nodeParams)

bracketNodeResources nodeParams sscParams (txpGlobalSettings pm) (initNodeDBs pm epochSlots) $ \nr -> Production $
let NodeContext {..} = nrContext nr
modifier = if aoStartMode == WithNode
then runNodeWithSinglePlugin pm nr
else identity
auxxModeAction = modifier (auxxPlugin pm opts command)
in runRealMode pm nr $ \diffusion ->
toRealMode (auxxModeAction (hoistDiffusion realModeToAuxx toRealMode diffusion))
bracketNodeResources (pcBlkSecurityParam pc)
nodeParams
sscParams
(txpGlobalSettings pm)
(initNodeDBs pm pc)
$ \nr ->
Production
$ let
NodeContext {..} = nrContext nr
modifier = if aoStartMode == WithNode
then runNodeWithSinglePlugin pm pc nr
else identity
auxxModeAction =
modifier (auxxPlugin pm pc opts command)
in
runRealMode pm pc nr $ \diffusion ->
toRealMode $ auxxModeAction $ hoistDiffusion
realModeToAuxx
toRealMode
diffusion

cArgs@CLI.CommonNodeArgs {..} = aoCommonNodeArgs
conf = CLI.configurationOptions (CLI.commonArgs cArgs)
nArgs =
CLI.NodeArgs {behaviorConfigPath = Nothing}
nArgs = CLI.NodeArgs {behaviorConfigPath = Nothing}

main :: IO ()
main = withCompileInfo $ do
Expand Down
50 changes: 28 additions & 22 deletions auxx/src/Command/BlockGen.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,7 +13,7 @@ import System.Wlog (logInfo)

import Pos.AllSecrets (mkAllSecretsSimple)
import Pos.Client.KeyStorage (getSecretKeysPlain)
import Pos.Core (gdBootStakeholders, genesisData)
import Pos.Core (ProtocolConstants, gdBootStakeholders, genesisData)
import Pos.Crypto (ProtocolMagic, encToSecret)
import Pos.Generator.Block (BlockGenParams (..), genBlocks,
tgpTxCountRange)
Expand All @@ -25,26 +25,32 @@ import Pos.Util.CompileInfo (withCompileInfo)
import Lang.Value (GenBlocksParams (..))
import Mode (MonadAuxxMode)


generateBlocks :: MonadAuxxMode m => ProtocolMagic -> GenBlocksParams -> m ()
generateBlocks pm GenBlocksParams{..} = withStateLock HighPriority ApplyBlock $ \_ -> do
seed <- liftIO $ maybe randomIO pure bgoSeed
logInfo $ "Generating with seed " <> show seed

allSecrets <- mkAllSecretsSimple . map encToSecret <$> getSecretKeysPlain

let bgenParams =
BlockGenParams
{ _bgpSecrets = allSecrets
, _bgpGenStakeholders = gdBootStakeholders genesisData
, _bgpBlockCount = fromIntegral bgoBlockN
-- tx generation is disalbed for now
, _bgpTxGenParams = def & tgpTxCountRange .~ (0,0)
, _bgpInplaceDB = True
, _bgpSkipNoKey = True
generateBlocks
:: MonadAuxxMode m
=> ProtocolMagic
-> ProtocolConstants
-> GenBlocksParams
-> m ()
generateBlocks pm pc GenBlocksParams {..} =
withStateLock HighPriority ApplyBlock $ \_ -> do
seed <- liftIO $ maybe randomIO pure bgoSeed
logInfo $ "Generating with seed " <> show seed

allSecrets <-
mkAllSecretsSimple . map encToSecret <$> getSecretKeysPlain

let bgenParams = BlockGenParams
{ _bgpSecrets = allSecrets
, _bgpGenStakeholders = gdBootStakeholders genesisData
, _bgpBlockCount = fromIntegral bgoBlockN
-- tx generation is disabled for now
, _bgpTxGenParams = def & tgpTxCountRange .~ (0, 0)
, _bgpInplaceDB = True
, _bgpSkipNoKey = True
, _bgpTxpGlobalSettings = txpGlobalSettings pm
}
withCompileInfo $ evalRandT (genBlocks pm bgenParams (const ())) (mkStdGen seed)
-- We print it twice because there can be a ton of logs and
-- you don't notice the first message.
logInfo $ "Generated with seed " <> show seed
withCompileInfo $ evalRandT (genBlocks pm pc bgenParams (const ()))
(mkStdGen seed)
-- We print it twice because there can be a ton of logs and
-- you don't notice the first message.
logInfo $ "Generated with seed " <> show seed
51 changes: 32 additions & 19 deletions auxx/src/Command/Proc.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,9 +18,9 @@ import qualified Text.JSON.Canonical as CanonicalJSON

import Pos.Client.KeyStorage (addSecretKey, getSecretKeysPlain)
import Pos.Client.Txp.Balances (getBalance)
import Pos.Core (AddrStakeDistribution (..), Address,
HeavyDlgIndex (..), SoftwareVersion (..), StakeholderId,
addressHash, mkMultiKeyDistr, unsafeGetCoin)
import Pos.Core (AddrStakeDistribution (..), HeavyDlgIndex (..),
ProtocolConstants, SoftwareVersion (..), StakeholderId,
addressHash, mkMultiKeyDistr, pcEpochSlots, unsafeGetCoin)
import Pos.Core.Common (AddrAttributes (..), AddrSpendingData (..),
makeAddress)
import Pos.Core.Configuration (genesisSecretKeys)
Expand Down Expand Up @@ -59,14 +59,16 @@ import Mode (MonadAuxxMode, deriveHDAddressAuxx,
makePubKeyAddressAuxx)
import Repl (PrintAction)

createCommandProcs ::
forall m. (MonadIO m, CanLog m, HasLoggerName m)
createCommandProcs
:: forall m
. (MonadIO m, CanLog m, HasLoggerName m)
=> Maybe ProtocolMagic
-> Maybe ProtocolConstants
-> Maybe (Dict (MonadAuxxMode m))
-> PrintAction m
-> Maybe (Diffusion m)
-> [CommandProc m]
createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \commands -> [
createCommandProcs mpm mpc hasAuxxMode printAction mDiffusion = rights . fix $ \commands -> [

return CommandProc
{ cpName = "L"
Expand Down Expand Up @@ -97,6 +99,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm
},

let name = "addr" in
needsProtocolConstants name >>= \pc ->
needsAuxxMode name >>= \Dict ->
return CommandProc
{ cpName = name
Expand All @@ -108,7 +111,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm
, cpExec = \(pk', mDistr) -> do
pk <- toLeft pk'
addr <- case mDistr of
Nothing -> makePubKeyAddressAuxx pk
Nothing -> makePubKeyAddressAuxx (pcEpochSlots pc) pk
Just distr -> return $
makeAddress (PubKeyASD pk) (AddrAttributes Nothing distr)
return $ ValueAddress addr
Expand All @@ -118,6 +121,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm
},

let name = "addr-hd" in
needsProtocolConstants name >>= \pc ->
needsAuxxMode name >>= \Dict ->
return CommandProc
{ cpName = name
Expand All @@ -128,7 +132,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm
sk <- evaluateWHNF (sks !! i) -- WHNF is sufficient to force possible errors
-- from using (!!). I'd use NF but there's no
-- NFData instance for secret keys.
addrHD <- deriveHDAddressAuxx sk
addrHD <- deriveHDAddressAuxx (pcEpochSlots pc) sk
return $ ValueAddress addrHD
, cpHelp = "address of the HD wallet for the specified public key"
},
Expand Down Expand Up @@ -185,13 +189,16 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm
return . procConst "false" $ ValueBool False,

let name = "balance" in
needsProtocolConstants name >>= \pc ->
needsAuxxMode name >>= \Dict ->
return CommandProc
{ cpName = name
, cpArgumentPrepare = identity
, cpArgumentConsumer = getArg (tyAddress `tyEither` tyPublicKey `tyEither` tyInt) "addr"
, cpExec = \addr' -> do
addr <- toLeft addr'
addr <-
either return (makePubKeyAddressAuxx $ pcEpochSlots pc) <=<
traverse (either return getPublicKeyFromIndex) $ addr'
balance <- getBalance addr
return $ ValueNumber (fromIntegral . unsafeGetCoin $ balance)
, cpHelp = "check the amount of coins on the specified address"
Expand All @@ -209,6 +216,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm

let name = "send-to-all-genesis" in
needsProtocolMagic name >>= \pm ->
needsProtocolConstants name >>= \pc ->
needsDiffusion name >>= \diffusion ->
needsAuxxMode name >>= \Dict ->
return CommandProc
Expand All @@ -222,7 +230,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm
stagpTpsSentFile <- getArg tyFilePath "file"
return Tx.SendToAllGenesisParams{..}
, cpExec = \stagp -> do
Tx.sendToAllGenesis pm diffusion stagp
Tx.sendToAllGenesis pm (pcEpochSlots pc) diffusion stagp
return ValueUnit
, cpHelp = "create and send transactions from all genesis addresses \
\ for <duration> seconds, <delay> in ms. <conc> is the \
Expand All @@ -244,6 +252,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm

let name = "send" in
needsProtocolMagic name >>= \pm ->
needsProtocolConstants name >>= \pc ->
needsDiffusion name >>= \diffusion ->
needsAuxxMode name >>= \Dict ->
return CommandProc
Expand All @@ -253,7 +262,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm
(,) <$> getArg tyInt "i"
<*> getArgSome tyTxOut "out"
, cpExec = \(i, outputs) -> do
Tx.send pm diffusion i outputs
Tx.send pm (pcEpochSlots pc) diffusion i outputs
return ValueUnit
, cpHelp = "send from #i to specified transaction outputs \
\ (use 'tx-out' to build them)"
Expand Down Expand Up @@ -400,6 +409,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm

let name = "generate-blocks" in
needsProtocolMagic name >>= \pm ->
needsProtocolConstants name >>= \pc ->
needsAuxxMode name >>= \Dict ->
return CommandProc
{ cpName = name
Expand All @@ -409,7 +419,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm
bgoSeed <- getArgOpt tyInt "seed"
return GenBlocksParams{..}
, cpExec = \params -> do
generateBlocks pm params
generateBlocks pm pc params
return ValueUnit
, cpHelp = "generate <n> blocks"
},
Expand Down Expand Up @@ -454,6 +464,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm

let name = "rollback" in
needsProtocolMagic name >>= \pm ->
needsProtocolConstants name >>= \pc ->
needsAuxxMode name >>= \Dict ->
return CommandProc
{ cpName = name
Expand All @@ -463,24 +474,26 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm
rpDumpPath <- getArg tyFilePath "dump-file"
pure RollbackParams{..}
, cpExec = \RollbackParams{..} -> do
Rollback.rollbackAndDump pm rpNum rpDumpPath
Rollback.rollbackAndDump pm pc rpNum rpDumpPath
return ValueUnit
, cpHelp = ""
},

let name = "listaddr" in
needsProtocolConstants name >>= \pc ->
needsAuxxMode name >>= \Dict ->
return CommandProc
{ cpName = name
, cpArgumentPrepare = identity
, cpArgumentConsumer = do pure ()
, cpExec = \() -> do
let epochSlots = pcEpochSlots pc
sks <- getSecretKeysPlain
printAction "Available addresses:"
for_ (zip [0 :: Int ..] sks) $ \(i, sk) -> do
let pk = encToPublic sk
addr <- makePubKeyAddressAuxx pk
addrHD <- deriveHDAddressAuxx sk
addr <- makePubKeyAddressAuxx epochSlots pk
addrHD <- deriveHDAddressAuxx epochSlots sk
printAction $
sformat (" #"%int%": addr: "%build%"\n"%
" pk: "%fullPublicKeyF%"\n"%
Expand All @@ -489,7 +502,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm
i addr pk (addressHash pk) addrHD
walletMB <- (^. usWallet) <$> (view userSecret >>= atomically . readTVar)
whenJust walletMB $ \wallet -> do
addrHD <- deriveHDAddressAuxx (_wusRootKey wallet)
addrHD <- deriveHDAddressAuxx epochSlots (_wusRootKey wallet)
printAction $
sformat (" Wallet address:\n"%
" HD addr: "%build)
Expand Down Expand Up @@ -517,6 +530,9 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm
needsProtocolMagic :: Name -> Either UnavailableCommand ProtocolMagic
needsProtocolMagic name =
maybe (Left $ UnavailableCommand name "ProtocolMagic is not available") Right mpm
needsProtocolConstants :: Name -> Either UnavailableCommand ProtocolConstants
needsProtocolConstants name =
maybe (Left $ UnavailableCommand name "ProtocolConstants are not available") Right mpc

procConst :: Applicative m => Name -> Value -> CommandProc m
procConst name value =
Expand All @@ -540,9 +556,6 @@ instance MonadAuxxMode m => ToLeft m PublicKey Int where
instance MonadAuxxMode m => ToLeft m StakeholderId PublicKey where
toLeft = return . either identity addressHash

instance MonadAuxxMode m => ToLeft m Address PublicKey where
toLeft = either return makePubKeyAddressAuxx

getPublicKeyFromIndex :: MonadAuxxMode m => Int -> m PublicKey
getPublicKeyFromIndex i = do
sks <- getSecretKeysPlain
Expand Down
Loading

0 comments on commit 9779582

Please sign in to comment.