Skip to content
Permalink
Browse files

demo-playground: update proposal/vote submission PoC

  • Loading branch information...
deepfire committed Jun 13, 2019
1 parent faed668 commit c79bbc4e0be197e1b2fa6c9ebe1552aeeae76b0c
@@ -0,0 +1,3 @@
#!/bin/sh

demo-playground/submit-proposal.sh software --app-name '"foo"' --version 1 --system-tag \"linux64\" --installer-hash '0123456789012345678901234567890123456789012345678901234567890123'
@@ -3,6 +3,7 @@ module CLI (
, TopologyInfo(..)
, Command(..)
, Protocol(..)
, USSArgs(..)
, fromProtocol
, parseCLI
-- * Handy re-exports
@@ -14,15 +15,20 @@ module CLI (
, progDesc
) where

import Data.Either (either)
import Data.Foldable (asum)
import Data.Semigroup ((<>))
import Data.Maybe (fromMaybe)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Word (Word64)
import Options.Applicative

import Ouroboros.Consensus.BlockchainTime
import Ouroboros.Consensus.Demo
import qualified Ouroboros.Consensus.Ledger.Mock as Mock
import Ouroboros.Consensus.Node (NodeId (..))
import Ouroboros.Consensus.Update
import Ouroboros.Consensus.Util

import Mock.TxSubmission (command', parseMockTx)
@@ -31,6 +37,10 @@ import Topology (TopologyInfo (..))
import qualified Cardano.BM.Data.Severity as Monitoring

import qualified Cardano.Crypto.Hashing as Crypto
import qualified Cardano.Chain.Update as Update
import qualified Cardano.Chain.Common as Chain
import qualified Cardano.Chain.Slotting as Chain

import qualified Test.Cardano.Chain.Genesis.Dummy as Dummy

data CLI = CLI {
@@ -42,8 +52,11 @@ data CLI = CLI {
}

data Command =
SimpleNode TopologyInfo Protocol
| TxSubmitter TopologyInfo Mock.Tx
SimpleNode TopologyInfo Protocol
| TxSubmitter TopologyInfo Mock.Tx
| ProtoProposer TopologyInfo USSArgs
| SoftProposer TopologyInfo USSArgs
| Voter TopologyInfo USSArgs

data Protocol =
BFT
@@ -134,8 +147,105 @@ parseCommand = subparser $ mconcat [
SimpleNode <$> parseTopologyInfo <*> parseProtocol
, command' "submit" "Submit a transaction." $
TxSubmitter <$> parseTopologyInfo <*> parseMockTx
, command' "propose-protocol" "Submit a protocol-only update proposal." $
ProtoProposer <$> parseTopologyInfo <*> (ProposeProtocol <$> parseProposalBodyProto)
, command' "propose-software" "Submit a software-only update proposal." $
SoftProposer <$> parseTopologyInfo <*> (ProposeSoftware <$> parseProposalBodySoft)
, command' "vote" "Submit a vote." $
Voter <$> parseTopologyInfo <*> parseVote
]

parseProposalBodyProto :: Parser MProposalBody
parseProposalBodyProto = MProposalBody
<$> (Just <$> parseProtocolVersion)
<*> (Just <$> parseProtocolParametersUpdate)
<*> pure Nothing
<*> pure mempty

parseProtocolVersion :: Parser Update.ProtocolVersion
parseProtocolVersion = Update.ProtocolVersion
<$> option auto (long "major")
<*> option auto (long "minor")
<*> option auto (long "alt")

parseProtocolParametersUpdate :: Parser Update.ProtocolParametersUpdate
parseProtocolParametersUpdate = Update.ProtocolParametersUpdate
<$> optional (option auto (
long "script-version"))
<*> optional (option (undefined) ( -- XXX
long "slot-duration"))
<*> optional (option auto (
long "max-block-size"))
<*> optional (option auto (
long "max-header-size"))
<*> optional (option auto (
long "max-tx-size"))
<*> optional (option auto (
long "max-proposal-size"))
<*> optional (option (Chain.LovelacePortion <$> auto) (
long "mpc-thd"))
<*> optional (option (Chain.LovelacePortion <$> auto) (
long "heavy-del-thd"))
<*> optional (option (Chain.LovelacePortion <$> auto) (
long "update-vote-thd"))
<*> optional (option (Chain.LovelacePortion <$> auto) (
long "update-proposal-thd"))
<*> optional (option (Chain.FlatSlotId <$> auto) (
long "update-implicit"))
<*> optional parseSoftforkRule
<*> optional parseTxFeePolicy
<*> optional (option (Chain.EpochIndex <$> auto) (
long "unlock-stake-epoch"))

parseTxFeePolicy :: Parser Chain.TxFeePolicy
parseTxFeePolicy = (Chain.TxFeePolicyTxSizeLinear <$>) $ Chain.TxSizeLinear
<$> (option (mkLovelace <$> auto) (long "txfee-policy-a"))
<*> (option (mkLovelace <$> auto) (long "txfee-policy-b"))
where mkLovelace :: Word64 -> Chain.Lovelace
mkLovelace = either (\err -> error (show err)) id . Chain.mkLovelace

parseSoftforkRule :: Parser Update.SoftforkRule
parseSoftforkRule = Update.SoftforkRule
<$> option (Chain.LovelacePortion <$> auto) (long "init-thd")
<*> option (Chain.LovelacePortion <$> auto) (long "min-thd")
<*> option (Chain.LovelacePortion <$> auto) (long "thd-decrement")

parseProposalBodySoft :: Parser MProposalBody
parseProposalBodySoft = MProposalBody
<$> pure Nothing
<*> pure Nothing
<*> (Just <$> parseSoftwareVersion)
<*> (interpretPairs <$> many parseSystemTagAppHash)
where
parseSoftwareVersion :: Parser Update.SoftwareVersion
parseSoftwareVersion = Update.SoftwareVersion
<$> option (Update.ApplicationName <$> auto) (long "app-name")
<*> option (auto) (long "version")
parseSystemTagAppHash :: Parser (Update.SystemTag, Update.InstallerHash)
parseSystemTagAppHash = (,) <$> parseSystemTag <*> parseInstallerHash
parseSystemTag = option (Update.SystemTag <$> auto) (long "system-tag")
parseInstallerHash = option (Update.InstallerHash <$> auto) (long "installer-hash")
interpretPairs :: [(Update.SystemTag, Update.InstallerHash)]
-> Map Update.SystemTag Update.InstallerHash
interpretPairs = Map.fromList

parseVote :: Parser USSArgs
parseVote = SubmitVote
<$> parseUpId
<*> asum [ flag' True $ mconcat [
long "accept"
, help "Vote for the proposal"
]
, flag' False $ mconcat [
long "reject"
, help "Vote against the proposal"
]]

parseUpId :: Parser Update.UpId
parseUpId = option (decodeHash <$> auto)
(long "proposal-id")
where decodeHash = either (\err -> error (show err)) id . Crypto.decodeHash

parseNodeId :: Parser NodeId
parseNodeId =
option (fmap CoreId auto) (
@@ -10,7 +10,9 @@ module Mock.TxSubmission (
command'
, parseMockTx
, handleTxSubmission
, handleUSSASubmission
, spawnMempoolListener
, spawnUSSAListener
) where

import Codec.Serialise (decode, hPutSerialise)
@@ -30,6 +32,7 @@ import Ouroboros.Consensus.Demo
import qualified Ouroboros.Consensus.Ledger.Mock as Mock
import Ouroboros.Consensus.Mempool
import Ouroboros.Consensus.Node (NodeId (..), NodeKernel (..))
import Ouroboros.Consensus.Update
import Ouroboros.Consensus.Util.CBOR (Decoder (..), initDecoderIO)
import Ouroboros.Consensus.Util.Condense

@@ -95,6 +98,57 @@ withValidatedNode tinfo act = do
Nothing -> error "Target node not found."
Just _ -> act tinfo

{-------------------------------------------------------------------------------
USSA (Update System Stimulus Args) smuggling
-------------------------------------------------------------------------------}
-- | Very roughly validate US stimulus args.
basicValidateUSSA :: USSArgs -> Maybe String

basicValidateUSSA (SubmitVote _upid _forAgainst) = Nothing

basicValidateUSSA (ProposeSoftware mprop) =
case mprop of
MProposalBody Nothing Nothing (Just _) hashes ->
if M.null hashes
then Just "software proposal mentions no payloads"
else Nothing
MProposalBody _ _ (Just _) _ -> Just "software proposal has protocol elements"
MProposalBody _ _ Nothing _ -> Just "software proposal missing software version"

basicValidateUSSA (ProposeProtocol mprop) =
case mprop of
MProposalBody (Just _) (Just _) Nothing _ -> Nothing
MProposalBody (Just _) (Just _) _ _ -> Just "protocol proposal has software elements"
MProposalBody Nothing (Just _) _ _ -> Just "protocol proposal missing protocol version"
MProposalBody _ Nothing _ _ -> Just "protocol proposal missing protocol parameters update"

-- | Submission side.
handleUSSASubmission :: TopologyInfo -> USSArgs -> IO ()
handleUSSASubmission tinfo ussa =
withValidatedNode tinfo $ \_ -> do
case basicValidateUSSA ussa of
Nothing -> withUSSAPipe (node tinfo) WriteMode False $ \h -> do
hPutSerialise h ussa
Just err ->
error $ "Update system stimulus malformed: " <> err <> ". Stimulus: " <> show ussa

-- | Node side.
readIncomingUSSArgs
:: RunDemo p
=> Tracer IO String
-> NodeKernel IO NodeId (Block p) (Header p)
-> Decoder IO
-> IO ()
readIncomingUSSArgs tracer kernel Decoder{..} = forever $ do
ussa :: USSArgs <- decodeNext decode
let mErr = basicValidateUSSA ussa
case mErr of
Just err ->
traceWith tracer $ "Update system stimulus malformed: " <> err <> ". Stimulus: " <> show ussa
Nothing -> do
traceWith tracer $ "Locally submitted update system stimulus not obviously malformed, processing: " <> show ussa
atomically $ writeTQueue (getUSSAQueue kernel) ussa

{-------------------------------------------------------------------------------
Tx smuggling
-------------------------------------------------------------------------------}
@@ -150,3 +204,11 @@ spawnMempoolListener
-> NodeKernel IO NodeId (Block p) (Header p)
-> IO (Async.Async ())
spawnMempoolListener = spawnListener namedTxPipeFor readIncomingTx

spawnUSSAListener
:: RunDemo p
=> Tracer IO String
-> NodeId
-> NodeKernel IO NodeId (Block p) (Header p)
-> IO (Async.Async ())
spawnUSSAListener = spawnListener namedUSSAPipeFor readIncomingUSSArgs
@@ -64,12 +64,19 @@ runNode cli@CLI{..} = do
-- If the user asked to submit a transaction, we don't have to spin up a
-- full node, we simply transmit it and exit.
case command of
TxSubmitter topology tx ->
handleTxSubmission topology tx
SimpleNode topology protocol -> do
Some p <- fromProtocol protocol
case runDemo p of
Dict -> handleSimpleNode p cli topology
TxSubmitter topology tx ->
handleTxSubmission topology tx
ProtoProposer topology stim ->
handleUSSASubmission topology stim
SoftProposer topology stim ->
handleUSSASubmission topology stim
Voter topology stim ->
handleUSSASubmission topology stim

-- Inlined byron-proxy/src/exec/Logging.hs:defaultLoggerConfig, so as to avoid
-- introducing merge conflicts due to refactoring. Should be factored after merges.
-- | It's called `Representation` but is closely related to the `Configuration`
@@ -124,7 +131,7 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do
let callbacks :: NodeCallbacks IO (Block p)
callbacks = NodeCallbacks {
produceDRG = drgNew
, produceBlock = \proof _l slot prevPoint prevBlockNo txs -> do
, produceBlock = \proof els slot prevPoint prevBlockNo txs ussArgs -> do
let curNo :: BlockNo
curNo = succ prevBlockNo

@@ -135,10 +142,12 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do
-- to include all of them would be maximum block size, which
-- we ignore for now.
demoForgeBlock pInfoConfig
els
slot
curNo
prevHash
txs
ussArgs
proof
}

@@ -179,6 +188,9 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do
-- Spawn the thread which listens to the mempool.
mempoolThread <- spawnMempoolListener tracer myNodeId kernel

-- Spawn the update system stimulus listener
usThread <- spawnUSSAListener tracer myNodeId kernel

forM_ (producers nodeSetup) (addUpstream' pInfo kernel)
forM_ (consumers nodeSetup) (addDownstream' pInfo kernel)

@@ -64,6 +64,7 @@ library
Ouroboros.Consensus.Protocol.Test
Ouroboros.Consensus.Protocol.ExtNodeConfig
Ouroboros.Consensus.Protocol.ModChainSel
Ouroboros.Consensus.Update
Ouroboros.Consensus.Util
Ouroboros.Consensus.Util.AnchoredFragment
Ouroboros.Consensus.Util.CBOR
@@ -225,6 +226,14 @@ executable demo-playground
cardano-prelude,
iohk-monitoring,

cardano-binary,
cardano-crypto-test,
cardano-ledger,
cardano-prelude-test,
memory,
primitive,
time,

aeson,
async,
bytestring,
@@ -82,6 +82,7 @@ import Ouroboros.Consensus.Protocol.ExtNodeConfig
import Ouroboros.Consensus.Protocol.LeaderSchedule
import Ouroboros.Consensus.Protocol.PBFT
import Ouroboros.Consensus.Protocol.Praos
import Ouroboros.Consensus.Update
import Ouroboros.Consensus.Util
import Ouroboros.Consensus.Util.Condense

@@ -434,19 +435,23 @@ class ( OuroborosTag p

demoForgeBlock :: (HasNodeState p m, MonadRandom m)
=> NodeConfig p
-> ExtLedgerState (Block p) -- ^ Current ledger state
-> SlotNo -- ^ Current slot
-> BlockNo -- ^ Current block number
-> ChainHash (Header p) -- ^ Previous hash
-> [GenTx (Block p)] -- ^ Txs to add in the block
-> [USSArgs]
-> IsLeader p
-> m (Block p)
default demoForgeBlock :: IsSimple p
=> (HasNodeState p m, MonadRandom m)
=> NodeConfig p
-> ExtLedgerState (Block p) -- ^ Current ledger state
-> SlotNo -- ^ Current slot
-> BlockNo -- ^ Current block number
-> ChainHash (Header p) -- ^ Previous hash
-> [GenTx (Block p)] -- ^ Txs to add in the block
-> [USSArgs]
-> IsLeader p
-> m (Block p)

0 comments on commit c79bbc4

Please sign in to comment.
You can’t perform that action at this time.