demo-playground: update proposal/vote submission PoC

demo-playground/submit-canned-software-proposal.sh

@@ -0,0 +1,3 @@
+#!/bin/sh
+
+demo-playground/submit-proposal.sh software --app-name '"foo"' --version 1 --system-tag \"linux64\" --installer-hash '0123456789012345678901234567890123456789012345678901234567890123'

demo-playground/submit-proposal.sh

@@ -0,0 +1,17 @@
+#!/usr/bin/env bash
+
+now=`date "+%Y-%m-%d 00:00:00"`
+
+ptype=$1
+case ${ptype} in
+        protocol | software ) ;;
+        * ) echo "Usage:  $0 ( protocol | software ) [PROPOSAL-OPTION..]" >&2; exit 1;; esac
+shift
+
+set -x
+cabal new-run demo-playground -- \
+      --system-start "$now" \
+      propose-$ptype \
+      --topology demo-playground/simple-topology.json \
+      --node-id 0 \
+      $@

demo-playground/submit-vote-accept-upid.sh

@@ -0,0 +1,7 @@
+#!/bin/sh
+
+NODE=${1:-0}
+## XXX: invalid upid for testing
+UPID=${2:-0001020304050607080910111213141516171819202122232425262728293031}
+
+$(dirname $0)/submit-vote.sh ${NODE} ${UPID} accept

demo-playground/submit-vote-reject-upid.sh

@@ -0,0 +1,7 @@
+#!/bin/sh
+
+NODE=${1:-0}
+## XXX: invalid upid for testing
+UPID=${2:-0001020304050607080910111213141516171819202122232425262728293031}
+
+$(dirname $0)/submit-vote.sh ${NODE} ${UPID} reject

demo-playground/submit-vote.sh

@@ -0,0 +1,19 @@
+#!/bin/sh
+
+now=`date "+%Y-%m-%d 00:00:00"`
+
+NODE=$1
+UPID=$2
+VOTE=$3
+case ${VOTE} in
+        accept | reject ) ;;
+        * ) echo "Usage:  $0 NODEID UPID ( accept | reject )" >&2; exit 1;; esac
+
+set -x
+cabal new-run demo-playground -- \
+      --system-start "${now}" \
+      vote \
+      --topology demo-playground/simple-topology.json \
+      --node-id ${NODE} \
+      --${VOTE} \
+      --proposal-id "\"${UPID}\""

ouroboros-consensus/demo-playground/CLI.hs

@@ -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) (

ouroboros-consensus/demo-playground/Mock/TxSubmission.hs

@@ -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
 -------------------------------------------------------------------------------}
@@ -149,3 +203,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

ouroboros-consensus/demo-playground/Run.hs

@@ -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)
 

ouroboros-consensus/ouroboros-consensus.cabal

@@ -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,