From 1a7ff280000a196027f6b234856b054a214cac5e Mon Sep 17 00:00:00 2001 From: KtorZ Date: Thu, 6 Apr 2023 15:48:05 +0200 Subject: [PATCH 01/10] Expose bytes and text limit constraints on metadata value. Useful to have accessible from external modules that need to construct metadata values. --- cardano-api/src/Cardano/Api/TxMetadata.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/cardano-api/src/Cardano/Api/TxMetadata.hs b/cardano-api/src/Cardano/Api/TxMetadata.hs index 7b8c1ab7de4..3e7c9b24fbc 100644 --- a/cardano-api/src/Cardano/Api/TxMetadata.hs +++ b/cardano-api/src/Cardano/Api/TxMetadata.hs @@ -15,6 +15,8 @@ module Cardano.Api.TxMetadata ( -- * Validating metadata validateTxMetadata, TxMetadataRangeError (..), + txMetadataTextStringMaxByteLength, + txMetadataByteStringMaxLength, -- * Conversion to\/from JSON TxMetadataJsonSchema (..), From ac4e13dd60c96d6015292a9512b1ac423e791f24 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Thu, 6 Apr 2023 15:52:51 +0200 Subject: [PATCH 02/10] Add 'meta{Bytes,Text}chunks helper smart-constructors for TxMetadataValue It is quite common to need to construct long text or bytestring and, it is annoying to have to handle that at call-site every single time. Instead, we can provide smart constructors that takes care of splitting the text or byte string into reasonably-sized chunks. Note that we could also implement a version of those functions that is *more flexible* and only constructs chunks when needed; otherwise returning a plain MetaText or MetaBytes when they fit. For example, in CDDL, we would represent such a text string as: ``` arbitrary_text = text .size (0..64) / [ * text .size (0..64) ] ``` For the sake of keeping things simple however, those functions only implement the list variation. --- cardano-api/src/Cardano/Api/TxMetadata.hs | 41 +++++++++++++++++++++++ 1 file changed, 41 insertions(+) diff --git a/cardano-api/src/Cardano/Api/TxMetadata.hs b/cardano-api/src/Cardano/Api/TxMetadata.hs index 3e7c9b24fbc..a2872edb03b 100644 --- a/cardano-api/src/Cardano/Api/TxMetadata.hs +++ b/cardano-api/src/Cardano/Api/TxMetadata.hs @@ -11,6 +11,8 @@ module Cardano.Api.TxMetadata ( -- * Constructing metadata TxMetadataValue(..), makeTransactionMetadata, + metaTextChunks, + metaBytesChunks, -- * Validating metadata validateTxMetadata, @@ -127,6 +129,25 @@ instance SerialiseAsCBOR TxMetadata where makeTransactionMetadata :: Map Word64 TxMetadataValue -> TxMetadata makeTransactionMetadata = TxMetadata +-- | Create a 'TxMetadataValue' from a 'Text' as a list of chunks of an +-- acceptable size. +metaTextChunks :: Text -> TxMetadataValue +metaTextChunks = + TxMetaList . chunks + txMetadataTextStringMaxByteLength + TxMetaText + (BS.length . Text.encodeUtf8) + Text.splitAt + +-- | Create a 'TxMetadataValue' from a 'ByteString' as a list of chunks of an +-- accaptable size. +metaBytesChunks :: ByteString -> TxMetadataValue +metaBytesChunks = + TxMetaList . chunks + txMetadataByteStringMaxLength + TxMetaBytes + BS.length + BS.splitAt -- ---------------------------------------------------------------------------- -- Internal conversion functions @@ -160,6 +181,26 @@ fromShelleyMetadatum (Shelley.Map xs) = TxMetaMap fromShelleyMetadatum v) | (k,v) <- xs ] +-- | Transform a string-like structure into chunks with a maximum size; Chunks +-- are filled from left to right. +chunks + :: Int + -- ^ Chunk max size (inclusive) + -> (str -> chunk) + -- ^ Hoisting + -> (str -> Int) + -- ^ Measuring + -> (Int -> str -> (str, str)) + -- ^ Splitting + -> str + -- ^ String + -> [chunk] +chunks maxLength strHoist strLength strSplitAt str + | strLength str > maxLength = + let (h, t) = strSplitAt maxLength str + in strHoist h : chunks maxLength strHoist strLength strSplitAt t + | otherwise = + [strHoist str] -- ---------------------------------------------------------------------------- -- Validate tx metadata From 03ec89d1168802f5966afd30beccc7f3bd30f575 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Thu, 6 Apr 2023 15:59:47 +0200 Subject: [PATCH 03/10] Define new Governance.Poll types and high-level interface This module is really meant to be driven by the cardano-cli or any client implementation that seeks to (re-)implement the SPO on-chain poll functionality. --- cardano-api/ChangeLog.md | 4 +- cardano-api/cardano-api.cabal | 1 + .../src/Cardano/Api/Governance/Poll.hs | 254 ++++++++++++++++++ cardano-api/src/Cardano/Api/Shelley.hs | 10 + 4 files changed, 268 insertions(+), 1 deletion(-) create mode 100644 cardano-api/src/Cardano/Api/Governance/Poll.hs diff --git a/cardano-api/ChangeLog.md b/cardano-api/ChangeLog.md index 8bebef41db5..a88dfc811ac 100644 --- a/cardano-api/ChangeLog.md +++ b/cardano-api/ChangeLog.md @@ -30,7 +30,7 @@ - **Breaking change** - `queryExpr` to return `IO (Either UnsupportedNtcVersionError a)` instead of `IO a`. ([PR4788](https://github.com/input-output-hk/cardano-node/pull/4788)) - + - **Breaking change** - Remove distinction between multisig and timelock scripts([PR4763](https://github.com/input-output-hk/cardano-node/pull/4763)) - **Breaking change** Change return type of `queryNodeLocalState` to new `AcquiringFailure` type. @@ -42,6 +42,8 @@ - Auto-balance multi asset transactions ([PR 4450](https://github.com/input-output-hk/cardano-node/pull/4450)) +- New 'Governance.Poll' API implementing [CIP-0094](https://github.com/cardano-foundation/CIPs/pull/496) ([PR 5050](https://github.com/input-output-hk/cardano-node/pull/5050)) + ### Bugs - Allow reading text envelopes from pipes ([PR 4384](https://github.com/input-output-hk/cardano-node/pull/4384)) diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 280c9bb4e2f..fc7d2d662b0 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -67,6 +67,7 @@ library Cardano.Api.Fees Cardano.Api.Genesis Cardano.Api.GenesisParameters + Cardano.Api.Governance.Poll Cardano.Api.Hash Cardano.Api.HasTypeProxy Cardano.Api.InMode diff --git a/cardano-api/src/Cardano/Api/Governance/Poll.hs b/cardano-api/src/Cardano/Api/Governance/Poll.hs new file mode 100644 index 00000000000..9e8fb257d00 --- /dev/null +++ b/cardano-api/src/Cardano/Api/Governance/Poll.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | An API for driving on-chain poll for SPOs. +-- +-- Polls are done on-chain through transaction metadata and authenticated via +-- stake pool credentials (either VRF public key or Ed25519 cold key). +-- +-- The goal is to gather opinions on governance matters such as protocol +-- parameters updates. This standard is meant to be an inclusive interim +-- solution while the work on a larger governance framework such as +-- CIP-1694 continues. +module Cardano.Api.Governance.Poll( + -- * Type Proxies + AsType(..), + + -- * Types + GovernancePoll (..), + GovernancePollAnswer (..), + GovernancePollWitness (..), + + -- * Errors + GovernancePollError (..), + renderGovernancePollError, + + -- * Functions + hashGovernancePoll, + signPollAnswerWith, + verifyPollAnswer, + ) where + +import Control.Monad (unless, when) +import Data.String (IsString(..)) +import Data.Text (Text) + +import Cardano.Api.HasTypeProxy +import Cardano.Api.Hash +import Cardano.Api.SerialiseCBOR +import Cardano.Api.SerialiseRaw +import Cardano.Api.SerialiseTextEnvelope +import Cardano.Api.SerialiseUsing +import Cardano.Api.TxMetadata + +import Cardano.Ledger.Crypto (HASH, StandardCrypto, VRF) +import Cardano.Ledger.Keys (KeyRole(..), SignedDSIGN, SignKeyDSIGN, + SignKeyVRF, VKey(..), VerKeyVRF, signedDSIGN, verifySignedDSIGN) + +import qualified Cardano.Crypto.DSIGN as DSIGN +import qualified Cardano.Crypto.Hash as Hash +import Cardano.Crypto.Util (SignableRepresentation(..)) +import qualified Cardano.Crypto.VRF as VRF + + +-- ---------------------------------------------------------------------------- +-- Governance Poll +-- + +-- | A governance poll declaration meant to be created by one of the genesis +-- delegates and directed towards SPOs. +-- +-- A poll is made of a question and some pre-defined answers to chose from. +-- There's an optional nonce used to make poll unique (as things down the line +-- are based on their hashes) if the same question/answers need to be asked +-- multiple times. +data GovernancePoll = GovernancePoll + { govPollQuestion :: Text + -- ^ A question as a human readable text; the text can be arbitrarily large. + , govPollAnswers :: [Text] + -- ^ Answers as human readable texts; their positions are used for answering. + , govPollNonce :: Maybe Word + -- ^ An optional nonce to make the poll unique if needs be. + } + deriving Show + +instance HasTextEnvelope GovernancePoll where + textEnvelopeType _ = "GovernancePoll" + +instance HasTypeProxy GovernancePoll where + data AsType GovernancePoll = AsGovernancePoll + proxyToAsType _ = AsGovernancePoll + +instance SerialiseAsCBOR GovernancePoll where + serialiseToCBOR = + error "not implemented" + + deserialiseFromCBOR AsGovernancePoll _bs = + error "not implemented" + + +-- ---------------------------------------------------------------------------- +-- Governance Poll Hash +-- + +newtype instance Hash GovernancePoll = + GovernancePollHash (Hash.Hash (HASH StandardCrypto) GovernancePoll) + deriving stock (Eq, Ord) + deriving (Show, IsString) via UsingRawBytesHex (Hash GovernancePoll) + +instance SerialiseAsRawBytes (Hash GovernancePoll) where + serialiseToRawBytes = + error "not implemented" + + deserialiseFromRawBytes (AsHash AsGovernancePoll) _bs = + error "not implemented" + +hashGovernancePoll :: GovernancePoll -> Hash GovernancePoll +hashGovernancePoll = + GovernancePollHash . hashWith @(HASH StandardCrypto) serialiseToCBOR + + +-- ---------------------------------------------------------------------------- +-- Governance Poll Answer +-- + +-- | An (unauthenticated) answer to a poll from an SPO referring to a poll by +-- hash digest value. +data GovernancePollAnswer = GovernancePollAnswer + { govAnsPoll :: Hash GovernancePoll + -- ^ The target poll + , govAnsChoice :: Word + -- ^ The (0-based) index of the chosen answer from that poll + } + deriving Show + +instance HasTypeProxy GovernancePollAnswer where + data AsType GovernancePollAnswer = AsGovernancePollAnswer + proxyToAsType _ = AsGovernancePollAnswer + +instance SignableRepresentation GovernancePollAnswer where + getSignableRepresentation = + error "not implemented" + +instance SerialiseAsCBOR GovernancePollAnswer where + serialiseToCBOR = + error "not implemented" + + deserialiseFromCBOR AsGovernancePollAnswer _bs = + error "not implemented" + + +-- ---------------------------------------------------------------------------- +-- Governance Poll Witness +-- + +-- | A governance poll witness, effectively authenticating a +-- 'GovernancePollAnswer' using either a VRF proof or a digital signature from a +-- cold key. +data GovernancePollWitness + = GovernancePollWitnessVRF + (VerKeyVRF StandardCrypto) + (VRF.CertVRF (VRF StandardCrypto)) + | GovernancePollWitnessColdKey + (VKey 'Witness StandardCrypto) + (SignedDSIGN StandardCrypto GovernancePollAnswer) + deriving Show + +instance HasTypeProxy GovernancePollWitness where + data AsType GovernancePollWitness = AsGovernancePollWitness + proxyToAsType _ = AsGovernancePollWitness + +instance SerialiseAsCBOR GovernancePollWitness where + serialiseToCBOR = + error "not implemented" + + deserialiseFromCBOR AsGovernancePollWitness _bs = + error "not implemented" + +signPollAnswerWith + :: GovernancePollAnswer + -> Either (SignKeyVRF StandardCrypto) (SignKeyDSIGN StandardCrypto) + -> GovernancePollWitness +signPollAnswerWith answer = + either + (\sk -> GovernancePollWitnessVRF + (VRF.deriveVerKeyVRF sk) + (snd $ VRF.evalVRF () answer sk) + ) + (\sk -> GovernancePollWitnessColdKey + (VKey (DSIGN.deriveVerKeyDSIGN sk)) + (signedDSIGN @StandardCrypto sk answer) + ) + +-- ---------------------------------------------------------------------------- +-- Governance Poll Verification +-- + +data GovernancePollError + = ErrGovernancePollMismatch + | ErrGovernancePollInvalidAnswer GovernancePollInvalidAnswerError + | ErrGovernancePollInvalidWitness + deriving Show + +data GovernancePollInvalidAnswerError = GovernancePollInvalidAnswerError + { invalidAnswerAcceptableAnswers :: [(Word, Text)] + , invalidAnswerReceivedAnswer :: Word + } + deriving Show + +renderGovernancePollError :: GovernancePollError -> Text +renderGovernancePollError err = + case err of + ErrGovernancePollMismatch -> + "Answer's poll doesn't match provided poll (hash mismatch)." + ErrGovernancePollInvalidAnswer invalidAnswer -> + mconcat + [ "Invalid answer (" + , textShow (invalidAnswerReceivedAnswer invalidAnswer) + , ") not part of the poll." + , "\n" + , "Accepted answers:" + , "\n" + , Text.intercalate "\n" + [ mconcat + [ textShow ix + , " → " + , answer + ] + | (ix, answer) <- invalidAnswerAcceptableAnswers invalidAnswer + ] + ] + ErrGovernancePollInvalidWitness -> + "Invalid witness for the answer: the proof / signature doesn't hold." + +verifyPollAnswer + :: GovernancePoll + -> GovernancePollAnswer + -> GovernancePollWitness + -> Either GovernancePollError () +verifyPollAnswer poll answer witness = do + when (hashGovernancePoll poll /= govAnsPoll answer) $ + Left ErrGovernancePollMismatch + + when (govAnsChoice answer >= fromIntegral (length (govPollAnswers poll))) $ do + let invalidAnswerReceivedAnswer = govAnsChoice answer + let invalidAnswerAcceptableAnswers = zip [0..] (govPollAnswers poll) + Left $ ErrGovernancePollInvalidAnswer $ GovernancePollInvalidAnswerError + { invalidAnswerReceivedAnswer + , invalidAnswerAcceptableAnswers + } + + unless isValid $ + Left ErrGovernancePollInvalidWitness + where + isValid = + case witness of + GovernancePollWitnessVRF vk proof -> + VRF.verifyVRF () vk answer (undefined, proof) + GovernancePollWitnessColdKey vk sig -> + verifySignedDSIGN vk answer sig diff --git a/cardano-api/src/Cardano/Api/Shelley.hs b/cardano-api/src/Cardano/Api/Shelley.hs index c77df8331fb..146f8a020be 100644 --- a/cardano-api/src/Cardano/Api/Shelley.hs +++ b/cardano-api/src/Cardano/Api/Shelley.hs @@ -228,6 +228,15 @@ module Cardano.Api.Shelley AcquiringFailure(..), SystemStart(..), + -- ** Governance + GovernancePoll (..), + GovernancePollAnswer (..), + GovernancePollWitness (..), + GovernancePollError (..), + renderGovernancePollError, + hashGovernancePoll, + signPollAnswerWith, + verifyPollAnswer, -- ** Various calculations LeadershipError(..), @@ -250,6 +259,7 @@ import Cardano.Api.Block import Cardano.Api.Certificate import Cardano.Api.Eras import Cardano.Api.Genesis +import Cardano.Api.Governance.Poll import Cardano.Api.InMode import Cardano.Api.IPC import Cardano.Api.Keys.Byron From 8f51170e351c94d94ba2805fa2a1a5d9f1a5f751 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Thu, 6 Apr 2023 16:05:10 +0200 Subject: [PATCH 04/10] Implement (de)serialization methods for GovernancePoll objects This commit also introduces a new type-class 'AsTxMetadata' to hint to the fact that the chosen representation on-the-wire for those various types is a transaction metadata value. The serialization to CBOR becomes then straightforward once we've converted the type into a 'MetadataValue'. Similarly, the deserialization is made simpler by first deserializing an opaque 'MetadataValue', and then inspecting it to see if it has the expected shape. --- cardano-api/src/Cardano/Api.hs | 1 + .../src/Cardano/Api/Governance/Poll.hs | 293 ++++++++++++++++-- cardano-api/src/Cardano/Api/Shelley.hs | 3 + cardano-api/src/Cardano/Api/TxMetadata.hs | 10 + 4 files changed, 288 insertions(+), 19 deletions(-) diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index e4340a7a5e1..2f940b19e11 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -335,6 +335,7 @@ module Cardano.Api ( -- * Transaction metadata -- | Embedding additional structured data within transactions. TxMetadata(..), + AsTxMetadata(..), -- ** Constructing metadata TxMetadataValue(..), diff --git a/cardano-api/src/Cardano/Api/Governance/Poll.hs b/cardano-api/src/Cardano/Api/Governance/Poll.hs index 9e8fb257d00..288bb8f81a3 100644 --- a/cardano-api/src/Cardano/Api/Governance/Poll.hs +++ b/cardano-api/src/Cardano/Api/Governance/Poll.hs @@ -34,9 +34,17 @@ module Cardano.Api.Governance.Poll( verifyPollAnswer, ) where -import Control.Monad (unless, when) +import Control.Arrow (left) +import Control.Monad (foldM, unless, when) +import Data.Either.Combinators (maybeToRight) +import Data.Function ((&)) +import qualified Data.Map.Strict as Map import Data.String (IsString(..)) import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.Text.Lazy.Builder as Text.Builder +import Data.Word (Word64) import Cardano.Api.HasTypeProxy import Cardano.Api.Hash @@ -45,16 +53,50 @@ import Cardano.Api.SerialiseRaw import Cardano.Api.SerialiseTextEnvelope import Cardano.Api.SerialiseUsing import Cardano.Api.TxMetadata +import Cardano.Api.Utils +import Cardano.Binary (DecoderError(..)) import Cardano.Ledger.Crypto (HASH, StandardCrypto, VRF) import Cardano.Ledger.Keys (KeyRole(..), SignedDSIGN, SignKeyDSIGN, SignKeyVRF, VKey(..), VerKeyVRF, signedDSIGN, verifySignedDSIGN) import qualified Cardano.Crypto.DSIGN as DSIGN +import Cardano.Crypto.Hash (hashFromBytes, hashToBytes, hashWith) import qualified Cardano.Crypto.Hash as Hash import Cardano.Crypto.Util (SignableRepresentation(..)) import qualified Cardano.Crypto.VRF as VRF +-- | Associated metadata label as defined in CIP-0094 +pollMetadataLabel :: Word64 +pollMetadataLabel = 94 + +-- | Key used to identify the question in a poll metadata object +pollMetadataKeyQuestion :: TxMetadataValue +pollMetadataKeyQuestion = TxMetaNumber 0 + +-- | Key used to identify the possible answers in a poll metadata object +pollMetadataKeyAnswers :: TxMetadataValue +pollMetadataKeyAnswers = TxMetaNumber 1 + +-- | Key used to identify the question hash in a poll metadata object +pollMetadataKeyPoll :: TxMetadataValue +pollMetadataKeyPoll = TxMetaNumber 2 + +-- | Key used to identify a chosen answer in a poll metadata object +pollMetadataKeyChoice :: TxMetadataValue +pollMetadataKeyChoice = TxMetaNumber 3 + +-- | Key used to identify a VRF proof witness in a poll metadata object +pollMetadataKeyWitnessVRF :: TxMetadataValue +pollMetadataKeyWitnessVRF = TxMetaNumber 4 + +-- | Key used to identify a cold key witness in a poll metadata object +pollMetadataKeyWitnessColdKey :: TxMetadataValue +pollMetadataKeyWitnessColdKey = TxMetaNumber 5 + +-- | Key used to identify the optional nonce in a poll metadata object +pollMetadataKeyNonce :: TxMetadataValue +pollMetadataKeyNonce = TxMetaText "_" -- ---------------------------------------------------------------------------- -- Governance Poll @@ -84,29 +126,74 @@ instance HasTypeProxy GovernancePoll where data AsType GovernancePoll = AsGovernancePoll proxyToAsType _ = AsGovernancePoll +instance AsTxMetadata GovernancePoll where + asTxMetadata GovernancePoll{govPollQuestion, govPollAnswers, govPollNonce} = + makeTransactionMetadata $ Map.fromList + [ ( pollMetadataLabel + , TxMetaMap $ + [ ( pollMetadataKeyQuestion, metaTextChunks govPollQuestion ) + , ( pollMetadataKeyAnswers, TxMetaList (metaTextChunks <$> govPollAnswers) ) + ] ++ + case govPollNonce of + Nothing -> [] + Just nonce -> + [ ( pollMetadataKeyNonce, TxMetaNumber (toInteger nonce) ) + ] + ) + ] + instance SerialiseAsCBOR GovernancePoll where serialiseToCBOR = - error "not implemented" - - deserialiseFromCBOR AsGovernancePoll _bs = - error "not implemented" - + serialiseToCBOR . asTxMetadata + + deserialiseFromCBOR AsGovernancePoll bs = do + metadata <- deserialiseFromCBOR AsTxMetadata bs + withNestedMap lbl pollMetadataLabel metadata $ \values -> + GovernancePoll + -- Question + <$> ( let key = pollMetadataKeyQuestion in case lookup key values of + Just x -> + expectTextChunks (fieldPath lbl key) x + Nothing -> + Left $ missingField (fieldPath lbl key) + ) + -- Answers + <*> ( let key = pollMetadataKeyAnswers in case lookup key values of + Just (TxMetaList xs) -> + traverse (expectTextChunks (fieldPath lbl key)) xs + Just _ -> + Left $ malformedField (fieldPath lbl key) "List of Text (answers)" + Nothing -> + Left $ missingField (fieldPath lbl key) + ) + -- Nonce (optional) + <*> ( let key = pollMetadataKeyNonce in case lookup key values of + Just (TxMetaNumber nonce) -> + Just <$> expectWord (fieldPath lbl key) nonce + Nothing -> + pure Nothing + Just _ -> + Left $ malformedField (fieldPath lbl key) "Number (nonce)" + ) + where + lbl = "GovernancePoll" -- ---------------------------------------------------------------------------- -- Governance Poll Hash -- newtype instance Hash GovernancePoll = - GovernancePollHash (Hash.Hash (HASH StandardCrypto) GovernancePoll) + GovernancePollHash { unGovernancePollHash :: Hash.Hash (HASH StandardCrypto) GovernancePoll } deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash GovernancePoll) instance SerialiseAsRawBytes (Hash GovernancePoll) where serialiseToRawBytes = - error "not implemented" + hashToBytes . unGovernancePollHash - deserialiseFromRawBytes (AsHash AsGovernancePoll) _bs = - error "not implemented" + deserialiseFromRawBytes (AsHash AsGovernancePoll) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash(GovernancePoll)") $ + GovernancePollHash <$> hashFromBytes bs hashGovernancePoll :: GovernancePoll -> Hash GovernancePoll hashGovernancePoll = @@ -133,14 +220,54 @@ instance HasTypeProxy GovernancePollAnswer where instance SignableRepresentation GovernancePollAnswer where getSignableRepresentation = - error "not implemented" + hashToBytes . hashWith @(HASH StandardCrypto) (serialiseToCBOR . asTxMetadata) + +instance AsTxMetadata GovernancePollAnswer where + asTxMetadata GovernancePollAnswer{govAnsPoll, govAnsChoice} = + makeTransactionMetadata $ Map.fromList + [ ( pollMetadataLabel + , TxMetaMap + [ ( pollMetadataKeyPoll, TxMetaBytes (serialiseToRawBytes govAnsPoll) ) + , ( pollMetadataKeyChoice, TxMetaNumber (toInteger govAnsChoice) ) + ] + ) + ] instance SerialiseAsCBOR GovernancePollAnswer where serialiseToCBOR = - error "not implemented" - - deserialiseFromCBOR AsGovernancePollAnswer _bs = - error "not implemented" + serialiseToCBOR . asTxMetadata + + deserialiseFromCBOR AsGovernancePollAnswer bs = do + metadata <- deserialiseFromCBOR AsTxMetadata bs + withNestedMap lbl pollMetadataLabel metadata $ \values -> + GovernancePollAnswer + -- Poll + <$> ( let key = pollMetadataKeyPoll in case lookup key values of + Nothing -> + Left $ missingField (fieldPath lbl key) + Just x -> + expectHash key x + ) + -- Answer + <*> ( let key = pollMetadataKeyChoice in case lookup key values of + Just (TxMetaNumber n) -> + expectWord (fieldPath lbl key) n + Just _ -> + Left $ malformedField (fieldPath lbl key) "Number (answer index)" + Nothing -> + Left $ missingField (fieldPath lbl key) + ) + where + lbl = "GovernancePollAnswer" + + expectHash key value = + case value of + TxMetaBytes bytes -> + left + (DecoderErrorCustom (fieldPath lbl key) . Text.pack . unSerialiseAsRawBytesError) + (deserialiseFromRawBytes (AsHash AsGovernancePoll) bytes) + _ -> + Left (malformedField (fieldPath lbl key) "Bytes (32 bytes hash digest)") -- ---------------------------------------------------------------------------- @@ -163,12 +290,68 @@ instance HasTypeProxy GovernancePollWitness where data AsType GovernancePollWitness = AsGovernancePollWitness proxyToAsType _ = AsGovernancePollWitness +instance AsTxMetadata GovernancePollWitness where + asTxMetadata witness = + makeTransactionMetadata $ Map.fromList + [ ( pollMetadataLabel + , TxMetaMap + [ case witness of + GovernancePollWitnessVRF vk proof -> + ( pollMetadataKeyWitnessVRF + , TxMetaList + -- NOTE (1): VRF keys are 32-byte long. + -- NOTE (2): VRF proofs are 80-byte long. + [ TxMetaBytes $ VRF.rawSerialiseVerKeyVRF vk + , metaBytesChunks (VRF.rawSerialiseCertVRF proof) + ] + ) + GovernancePollWitnessColdKey (VKey vk) (DSIGN.SignedDSIGN sig) -> + ( pollMetadataKeyWitnessColdKey + , TxMetaList + -- NOTE (1): Ed25519 keys are 32-byte long. + -- NOTE (2): Ed25519 signatures are 64-byte long. + [ TxMetaBytes $ DSIGN.rawSerialiseVerKeyDSIGN vk + , TxMetaBytes $ DSIGN.rawSerialiseSigDSIGN sig + ] + ) + ] + ) + ] + instance SerialiseAsCBOR GovernancePollWitness where serialiseToCBOR = - error "not implemented" - - deserialiseFromCBOR AsGovernancePollWitness _bs = - error "not implemented" + serialiseToCBOR . asTxMetadata + + deserialiseFromCBOR AsGovernancePollWitness bs = do + metadata <- deserialiseFromCBOR AsTxMetadata bs + withNestedMap lbl pollMetadataLabel metadata $ \values -> + tryWitnessVRF values $ + tryColdKey values $ + Left $ missingField (fieldPath lbl (TxMetaText "{4|5}")) + where + lbl = "GovernancePollWitness" + + tryWitnessVRF values orElse = + let k = pollMetadataKeyWitnessVRF in case lookup k values of + Just (TxMetaList [TxMetaBytes vk, TxMetaList[TxMetaBytes proofHead, TxMetaBytes proofTail]]) -> + expectJust (fieldPath lbl k) $ GovernancePollWitnessVRF + <$> VRF.rawDeserialiseVerKeyVRF vk + <*> VRF.rawDeserialiseCertVRF (proofHead <> proofTail) + Just _ -> + Left $ malformedField (fieldPath lbl k) "List" + Nothing -> + orElse + + tryColdKey values orElse = + let k = pollMetadataKeyWitnessColdKey in case lookup k values of + Just (TxMetaList [TxMetaBytes vk, TxMetaBytes sig]) -> + expectJust (fieldPath lbl k) $ GovernancePollWitnessColdKey + <$> fmap VKey (DSIGN.rawDeserialiseVerKeyDSIGN vk) + <*> fmap DSIGN.SignedDSIGN (DSIGN.rawDeserialiseSigDSIGN sig) + Just _ -> + Left $ malformedField (fieldPath lbl k) "List" + Nothing -> + orElse signPollAnswerWith :: GovernancePollAnswer @@ -252,3 +435,75 @@ verifyPollAnswer poll answer witness = do VRF.verifyVRF () vk answer (undefined, proof) GovernancePollWitnessColdKey vk sig -> verifySignedDSIGN vk answer sig + + +-- ---------------------------------------------------------------------------- +-- Decoder Helpers +-- + +withNestedMap + :: Text + -> Word64 + -> TxMetadata + -> ([(TxMetadataValue, TxMetadataValue)] -> Either DecoderError a) + -> Either DecoderError a +withNestedMap lbl topLevelLabel (TxMetadata m) continueWith = + case Map.lookup topLevelLabel m of + Just (TxMetaMap values) -> + continueWith values + Nothing -> + Left $ DecoderErrorCustom lbl + ("missing expected label: " <> textShow topLevelLabel) + Just _ -> + Left $ DecoderErrorCustom lbl + "malformed data; expected a key:value map" + +expectJust :: Text -> Maybe a -> Either DecoderError a +expectJust lbl = + maybe + (Left (DecoderErrorCustom lbl "malformed field(s)")) + Right + +expectTextChunks :: Text -> TxMetadataValue -> Either DecoderError Text +expectTextChunks lbl value = + case value of + TxMetaList xs -> + foldM expectText mempty xs + & maybe + (Left (malformedField (lbl <> "[i]") "Text")) + (Right . Text.Lazy.toStrict . Text.Builder.toLazyText) + _ -> + Left (malformedField lbl "List") + where + expectText acc x = + case x of + TxMetaText txt -> Just (acc <> Text.Builder.fromText txt) + _ -> Nothing + +expectWord :: Text -> Integer -> Either DecoderError Word +expectWord lbl n + | n >= 0 && n < toInteger (maxBound :: Word) = + pure (fromInteger n) + | otherwise = + Left $ DecoderErrorCustom lbl + "invalid number; must be non-negative word" + +missingField :: Text -> DecoderError +missingField lbl = + DecoderErrorCustom lbl + "missing mandatory field" + +malformedField :: Text -> Text -> DecoderError +malformedField lbl hint = + DecoderErrorCustom lbl + ("malformed field; must be: " <> hint) + +fieldPath + :: Text + -- ^ Label + -> TxMetadataValue + -- ^ Field key + -> Text +fieldPath lbl (TxMetaNumber i) = lbl <> "." <> textShow i +fieldPath lbl (TxMetaText t) = lbl <> "." <> t +fieldPath lbl _ = lbl <> ".?" diff --git a/cardano-api/src/Cardano/Api/Shelley.hs b/cardano-api/src/Cardano/Api/Shelley.hs index 146f8a020be..67a4b904754 100644 --- a/cardano-api/src/Cardano/Api/Shelley.hs +++ b/cardano-api/src/Cardano/Api/Shelley.hs @@ -19,6 +19,9 @@ module Cardano.Api.Shelley -- * Hashes Hash(..), + -- * Type Proxies + AsType(..), + -- * Payment addresses -- | Constructing and inspecting Shelley payment addresses Address(ShelleyAddress), diff --git a/cardano-api/src/Cardano/Api/TxMetadata.hs b/cardano-api/src/Cardano/Api/TxMetadata.hs index a2872edb03b..f8e8ef07d7a 100644 --- a/cardano-api/src/Cardano/Api/TxMetadata.hs +++ b/cardano-api/src/Cardano/Api/TxMetadata.hs @@ -8,6 +8,9 @@ module Cardano.Api.TxMetadata ( -- * Types TxMetadata (TxMetadata), + -- * Class + AsTxMetadata (..), + -- * Constructing metadata TxMetadataValue(..), makeTransactionMetadata, @@ -149,6 +152,13 @@ metaBytesChunks = BS.length BS.splitAt +-- ---------------------------------------------------------------------------- +-- TxMetadata class +-- + +class AsTxMetadata a where + asTxMetadata :: a -> TxMetadata + -- ---------------------------------------------------------------------------- -- Internal conversion functions -- From 346e1757da6bd6524cd7b90da0cad57ca6f570b7 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Thu, 6 Apr 2023 16:08:38 +0200 Subject: [PATCH 05/10] Define commands behavior for {create,answer,verify}-poll These commands are pretty straightforward to write by leveraging the newly introduced Cardano.Api.Governance.Poll API. One may ask why use sometimes files, sometimes stderr and sometimes stdout in implementing those commands. As a rule of thumb: - stdout = relevant content that should be structured to be piped into other tools or send to files - stderr = debug information useful to communicate context and details to users A command-line that outputs interactive debug information on stdout is arguably doing something wrong; unless it's the main terminal output of the application (e.g. printing structured logs on stdout). Then, why stdout rather than a file? Because I find the UX a lot better that way. Command lines with too many params are arguably hard to process; and using file as the medium of exchanges makes it harder / prevent piping into other tools easily. When printing structured results on stdout, one can always redirect the output to a file should they want it; so IMO stdout should always be the default; and files used only when necessary. Here I am only using an output file in the case of create-poll as a "build artifact". It allows to produce two outputs with distinct purpose; the file is meant to be shared as file, and thus it makes sense to treat it as such from the CLI as well. It also makes it clearer for users (even though that's going to be only super users here) what is meant to be shared and what is metadata. --- cardano-api/src/Cardano/Api.hs | 1 + cardano-api/src/Cardano/Api/TxMetadata.hs | 11 +- .../src/Cardano/CLI/Shelley/Run/Governance.hs | 197 +++++++++++++++++- .../src/Cardano/CLI/Shelley/Run/Key.hs | 1 + .../src/Cardano/CLI/Shelley/Run/Read.hs | 1 + 5 files changed, 207 insertions(+), 4 deletions(-) diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 2f940b19e11..7a3348ccfcc 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -340,6 +340,7 @@ module Cardano.Api ( -- ** Constructing metadata TxMetadataValue(..), makeTransactionMetadata, + mergeTransactionMetadata, -- ** Validating metadata validateTxMetadata, diff --git a/cardano-api/src/Cardano/Api/TxMetadata.hs b/cardano-api/src/Cardano/Api/TxMetadata.hs index f8e8ef07d7a..007fdff7b62 100644 --- a/cardano-api/src/Cardano/Api/TxMetadata.hs +++ b/cardano-api/src/Cardano/Api/TxMetadata.hs @@ -14,14 +14,13 @@ module Cardano.Api.TxMetadata ( -- * Constructing metadata TxMetadataValue(..), makeTransactionMetadata, + mergeTransactionMetadata, metaTextChunks, metaBytesChunks, -- * Validating metadata validateTxMetadata, TxMetadataRangeError (..), - txMetadataTextStringMaxByteLength, - txMetadataByteStringMaxLength, -- * Conversion to\/from JSON TxMetadataJsonSchema (..), @@ -132,6 +131,14 @@ instance SerialiseAsCBOR TxMetadata where makeTransactionMetadata :: Map Word64 TxMetadataValue -> TxMetadata makeTransactionMetadata = TxMetadata +mergeTransactionMetadata + :: (TxMetadataValue -> TxMetadataValue -> TxMetadataValue) + -> TxMetadata + -> TxMetadata + -> TxMetadata +mergeTransactionMetadata merge (TxMetadata m1) (TxMetadata m2) = + TxMetadata $ Map.unionWith merge m1 m2 + -- | Create a 'TxMetadataValue' from a 'Text' as a list of chunks of an -- acceptable size. metaTextChunks :: Text -> TxMetadataValue diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Governance.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Governance.hs index 7951de93159..e7fc74a698a 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Governance.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Governance.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Cardano.CLI.Shelley.Run.Governance ( ShelleyGovernanceCmdError , renderShelleyGovernanceError @@ -5,6 +8,7 @@ module Cardano.CLI.Shelley.Run.Governance ) where import Control.Monad (unless, when) +import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, left, newExceptT, onLeft) @@ -12,8 +16,15 @@ import Data.Aeson (eitherDecode) import qualified Data.ByteString.Lazy as LB import Data.Function ((&)) import qualified Data.List as List +import Data.String(fromString) import Data.Text (Text) import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import qualified Data.Text.Read as Text +import qualified Data.Text.Encoding as Text +import qualified Data.ByteString.Char8 as BSC +import Formatting (sformat, build) +import System.IO (stderr, stdout, stdin) import Cardano.Api import Cardano.Api.Shelley @@ -22,11 +33,16 @@ import Cardano.CLI.Shelley.Key (VerificationKeyOrHashOrFile, readVerificationKeyOrHashOrFile, readVerificationKeyOrHashOrTextEnvFile) import Cardano.CLI.Shelley.Parsers import Cardano.CLI.Types +import Cardano.CLI.Shelley.Run.Key (SomeSigningKey(..), readSigningKeyFile) +import Cardano.CLI.Shelley.Run.Read (MetadataError, readFileTxMetadata, + renderMetadataError) +import Cardano.Binary (DecoderError) import Cardano.Ledger.Alonzo.Scripts (CostModels (..)) +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Keys (SignKeyDSIGN, SignKeyVRF) import qualified Cardano.Ledger.Shelley.TxBody as Shelley - data ShelleyGovernanceCmdError = ShelleyGovernanceCmdTextEnvReadError !(FileError TextEnvelopeError) | ShelleyGovernanceCmdKeyReadError !(FileError InputDecodeError) @@ -41,6 +57,16 @@ data ShelleyGovernanceCmdError -- ^ Number of reward amounts | ShelleyGovernanceCmdCostModelsJsonDecodeErr !FilePath !Text | ShelleyGovernanceCmdEmptyCostModel !FilePath + | ShelleyGovernanceCmdUnexpectedKeyType + ![TextEnvelopeType] + -- ^ Expected key types + | ShelleyGovernanceCmdPollOutOfBoundAnswer + !Int + -- ^ Maximum answer index + | ShelleyGovernanceCmdPollInvalidChoice + | ShelleyGovernanceCmdMetadataError !MetadataError + | ShelleyGovernanceCmdDecoderError !DecoderError + | ShelleyGovernanceCmdVerifyPollError !GovernancePollError deriving Show renderShelleyGovernanceError :: ShelleyGovernanceCmdError -> Text @@ -63,7 +89,19 @@ renderShelleyGovernanceError err = "The decoded cost model was empty at: " <> Text.pack fp ShelleyGovernanceCmdCostModelReadError err' -> "Error reading the cost model: " <> Text.pack (displayError err') - + ShelleyGovernanceCmdUnexpectedKeyType expected -> + "Unexpected poll key type; expected one of: " + <> Text.intercalate ", " (textShow <$> expected) + ShelleyGovernanceCmdPollOutOfBoundAnswer nMax -> + "Poll answer out of bounds. Choices are between 0 and " <> textShow nMax + ShelleyGovernanceCmdPollInvalidChoice -> + "Invalid choice. Please choose from the available answers." + ShelleyGovernanceCmdMetadataError metadataError -> + renderMetadataError metadataError + ShelleyGovernanceCmdDecoderError decoderError -> + "Unable to decode metadata: " <> sformat build decoderError + ShelleyGovernanceCmdVerifyPollError pollError -> + renderGovernancePollError pollError runGovernanceCmd :: GovernanceCmd -> ExceptT ShelleyGovernanceCmdError IO () runGovernanceCmd (GovernanceMIRPayStakeAddressesCertificate mirpot vKeys rewards out) = @@ -180,3 +218,158 @@ runGovernanceUpdateProposal (OutputFile upFile) eNo genVerKeyFiles upPprams mCos firstExceptT ShelleyGovernanceCmdTextEnvWriteError . newExceptT $ writeLazyByteStringFile upFile $ textEnvelopeToJSON Nothing upProp +runGovernanceCreatePoll + :: Text + -> [Text] + -> Maybe Word + -> OutputFile + -> ExceptT ShelleyGovernanceCmdError IO () +runGovernanceCreatePoll govPollQuestion govPollAnswers govPollNonce out = do + let poll = GovernancePoll{ govPollQuestion, govPollAnswers, govPollNonce } + + let description = fromString $ "An on-chain poll for SPOs: " <> Text.unpack govPollQuestion + firstExceptT ShelleyGovernanceCmdTextEnvWriteError . newExceptT $ + writeFileTextEnvelope (unOutputFile out) (Just description) poll + + let metadata = asTxMetadata poll + & metadataToJson TxMetadataJsonDetailedSchema + + let outPath = unOutputFile out + & Text.encodeUtf8 . Text.pack + + liftIO $ do + BSC.hPutStrLn stderr $ mconcat + [ "Poll created successfully.\n" + , "Please submit a transaction using the resulting metadata.\n" + ] + BSC.hPutStrLn stdout (prettyPrintJSON metadata) + BSC.hPutStrLn stderr $ mconcat + [ "\n" + , "Hint (1): Use '--json-metadata-detailed-schema' and '--metadata-json-file' " + , "from the build or build-raw commands.\n" + , "Hint (2): You can redirect the standard output of this command to a JSON " + , "file to capture metadata.\n\n" + , "Note: A serialized version of the poll suitable for sharing with " + , "participants has been generated at '" <> outPath <> "'." + ] + +runGovernanceAnswerPoll + :: FilePath + -> SigningKeyFile + -- ^ VRF or Ed25519 cold key + -> Maybe Word + -- ^ Answer index + -> ExceptT ShelleyGovernanceCmdError IO () +runGovernanceAnswerPoll pollFile skFile maybeChoice = do + poll <- firstExceptT ShelleyGovernanceCmdTextEnvReadError . newExceptT $ + readFileTextEnvelope AsGovernancePoll pollFile + + credentials <- readVRFOrColdSigningKeyFile skFile + + choice <- case maybeChoice of + Nothing -> do + askInteractively poll + Just ix -> do + validateChoice poll ix + liftIO $ BSC.hPutStrLn stderr $ Text.encodeUtf8 $ Text.intercalate "\n" + [ govPollQuestion poll + , "→ " <> (govPollAnswers poll !! fromIntegral ix) + , "" + ] + pure ix + + let pollAnswer = GovernancePollAnswer + { govAnsPoll = hashGovernancePoll poll + , govAnsChoice = choice + } + let witness = pollAnswer `signPollAnswerWith` credentials + + let metadata = + mergeTransactionMetadata + ( \l r -> case (l, r) of + (TxMetaMap xs, TxMetaMap ys) -> TxMetaMap (xs <> ys) + _ -> error "unreachable" + ) + (asTxMetadata pollAnswer) + (asTxMetadata witness) + & metadataToJson TxMetadataJsonDetailedSchema + + liftIO $ do + BSC.hPutStrLn stderr $ mconcat + [ "Poll answer created successfully.\n" + , "Please submit a transaction using the resulting metadata.\n" + ] + BSC.hPutStrLn stdout (prettyPrintJSON metadata) + BSC.hPutStrLn stderr $ mconcat + [ "\n" + , "Hint (1): Use '--json-metadata-detailed-schema' and '--metadata-json-file' " + , "from the build or build-raw commands.\n" + , "Hint (2): You can redirect the standard output of this command to a JSON " + , "file to capture metadata." + ] + where + readVRFOrColdSigningKeyFile + :: SigningKeyFile + -> ExceptT + ShelleyGovernanceCmdError + IO + (Either (SignKeyVRF StandardCrypto) (SignKeyDSIGN StandardCrypto)) + readVRFOrColdSigningKeyFile filepath = do + someSk <- firstExceptT ShelleyGovernanceCmdKeyReadError $ + readSigningKeyFile filepath + case someSk of + AVrfSigningKey (VrfSigningKey sk) -> + pure (Left sk) + AStakePoolSigningKey (StakePoolSigningKey sk) -> + pure (Right sk) + _anythingElse -> + left $ ShelleyGovernanceCmdUnexpectedKeyType + [ textEnvelopeType (AsSigningKey AsVrfKey) + , textEnvelopeType (AsSigningKey AsStakePoolKey) + ] + + validateChoice :: GovernancePoll -> Word -> ExceptT ShelleyGovernanceCmdError IO () + validateChoice GovernancePoll{govPollAnswers} ix = do + let maxAnswerIndex = length govPollAnswers - 1 + when (fromIntegral ix > maxAnswerIndex) $ left $ + ShelleyGovernanceCmdPollOutOfBoundAnswer maxAnswerIndex + + askInteractively :: GovernancePoll -> ExceptT ShelleyGovernanceCmdError IO Word + askInteractively poll@GovernancePoll{govPollQuestion, govPollAnswers} = do + liftIO $ BSC.hPutStrLn stderr $ Text.encodeUtf8 $ Text.intercalate "\n" + ( govPollQuestion + : [ "[" <> textShow ix <> "] " <> answer + | (ix :: Int, answer) <- zip [0..] govPollAnswers + ] + ) + liftIO $ BSC.hPutStrLn stderr "" + liftIO $ BSC.hPutStr stderr "Please indicate an answer (by index): " + txt <- liftIO $ Text.hGetLine stdin + liftIO $ BSC.hPutStrLn stderr "" + case Text.decimal txt of + Right (choice, rest) | Text.null rest -> + choice <$ validateChoice poll choice + _ -> + left ShelleyGovernanceCmdPollInvalidChoice + +runGovernanceVerifyPoll + :: FilePath + -> FilePath + -> ExceptT ShelleyGovernanceCmdError IO () +runGovernanceVerifyPoll pollFile metadataFile = do + poll <- firstExceptT ShelleyGovernanceCmdTextEnvReadError . newExceptT $ + readFileTextEnvelope AsGovernancePoll pollFile + + metadata <- firstExceptT ShelleyGovernanceCmdMetadataError $ + readFileTxMetadata TxMetadataJsonDetailedSchema (MetadataFileJSON metadataFile) + + answer <- firstExceptT ShelleyGovernanceCmdDecoderError . newExceptT $ pure $ + deserialiseFromCBOR AsGovernancePollAnswer (serialiseToCBOR metadata) + + witness <- firstExceptT ShelleyGovernanceCmdDecoderError . newExceptT $ pure $ + deserialiseFromCBOR AsGovernancePollWitness (serialiseToCBOR metadata) + + firstExceptT ShelleyGovernanceCmdVerifyPollError . newExceptT $ pure $ + verifyPollAnswer poll answer witness + + liftIO $ BSC.hPutStrLn stderr "Ok." diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Key.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Key.hs index 7fd333ef7f1..393f55732d2 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Key.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Key.hs @@ -7,6 +7,7 @@ module Cardano.CLI.Shelley.Run.Key , SomeSigningKey(..) , renderShelleyKeyCmdError , runKeyCmd + , readSigningKeyFile -- * Exports for testing , decodeBech32 diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Read.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Read.hs index 8078b7c0186..fa95095a531 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Read.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Read.hs @@ -100,6 +100,7 @@ data MetadataError | MetadataErrorValidationError !FilePath ![(Word64, TxMetadataRangeError)] | MetadataErrorDecodeError !FilePath !CBOR.DecoderError | MetadataErrorNotAvailableInEra AnyCardanoEra + deriving Show renderMetadataError :: MetadataError -> Text renderMetadataError (MetadataErrorFile fileErr) = From 9f6f09c5522bb36fe8a736f8b8727f220dc91ef2 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Thu, 6 Apr 2023 16:11:33 +0200 Subject: [PATCH 06/10] Wire newly introduce governance commands in the CLI Mostly plumbing and parser implementation following what already exists. --- cardano-cli/ChangeLog.md | 17 ++++ .../src/Cardano/CLI/Shelley/Commands.hs | 15 ++++ .../src/Cardano/CLI/Shelley/Parsers.hs | 81 +++++++++++++++++++ .../src/Cardano/CLI/Shelley/Run/Governance.hs | 6 ++ 4 files changed, 119 insertions(+) diff --git a/cardano-cli/ChangeLog.md b/cardano-cli/ChangeLog.md index 1c4ce46ba78..dbdae3a42fa 100644 --- a/cardano-cli/ChangeLog.md +++ b/cardano-cli/ChangeLog.md @@ -4,6 +4,23 @@ - Remove cardano-cli address build-script ([PR 4700](https://github.com/input-output-hk/cardano-node/pull/4700)) +- New commands for on-chain SPOs polls under `shelley governance`: + - `create-poll`: + For the current governing entities, as a means to create new polls. + + - `answer-poll`: + For participants who want to answer a given poll. + + - `verify-poll`: + For anyone who seek to verify a poll entry (e.g. explorers) + + The commands are built to fit and play nicely within the cardano-cli. + The poll and answers structures are based on transaction metadata and + require to be embedded in an actual transaction. The added commands + however only works from metadata and raw "GovernancePoll" envelopes. + + See [CIP proposal](https://github.com/cardano-foundation/CIPs/pull/496) for details. + ### Features - Default to the ledger's CDDL format for transaction body creation by removing flags `--cddl-format` and `--cli-format` from `build` and `build-raw` ([PR 4303](https://github.com/input-output-hk/cardano-node/pull/4303)) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs index 36a8a4f1b4e..311483287dc 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs @@ -416,6 +416,18 @@ data GovernanceCmd [VerificationKeyFile] ProtocolParametersUpdate (Maybe FilePath) + | GovernanceCreatePoll + Text -- Prompt + [Text] -- Choices + (Maybe Word) -- Nonce + OutputFile + | GovernanceAnswerPoll + FilePath -- Poll file + SigningKeyFile + (Maybe Word) -- Answer index + | GovernanceVerifyPoll + FilePath -- Poll file + FilePath -- Metadata JSON file deriving Show renderGovernanceCmd :: GovernanceCmd -> Text @@ -426,6 +438,9 @@ renderGovernanceCmd cmd = GovernanceMIRTransfer _ _ TransferToTreasury -> "governance create-mir-certificate transfer-to-treasury" GovernanceMIRTransfer _ _ TransferToReserves -> "governance create-mir-certificate transfer-to-reserves" GovernanceUpdateProposal {} -> "governance create-update-proposal" + GovernanceCreatePoll{} -> "governance create-poll" + GovernanceAnswerPoll{} -> "governance answer-poll" + GovernanceVerifyPoll{} -> "governance verify-poll" data TextViewCmd = TextViewInfo !FilePath (Maybe OutputFile) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index d1517f74cc3..98acb1b76c5 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs @@ -1092,6 +1092,15 @@ pGovernanceCmd = , subParser "create-update-proposal" $ Opt.info pUpdateProposal $ Opt.progDesc "Create an update proposal" + , subParser "create-poll" + $ Opt.info pGovernanceCreatePoll + $ Opt.progDesc "Create an SPO poll" + , subParser "answer-poll" + $ Opt.info pGovernanceAnswerPoll + $ Opt.progDesc "Answer an SPO poll" + , subParser "verify-poll" + $ Opt.info pGovernanceVerifyPoll + $ Opt.progDesc "Verify an answer to a given SPO poll" ] where mirCertParsers :: Parser GovernanceCmd @@ -1153,6 +1162,78 @@ pGovernanceCmd = <*> pProtocolParametersUpdate <*> optional pCostModels + pGovernanceCreatePoll :: Parser GovernanceCmd + pGovernanceCreatePoll = + GovernanceCreatePoll + <$> pPollQuestion + <*> some pPollAnswer + <*> optional pPollNonce + <*> pOutputFile + + pGovernanceAnswerPoll :: Parser GovernanceCmd + pGovernanceAnswerPoll = + GovernanceAnswerPoll + <$> pPollFile + <*> pSigningKeyFile Input + <*> optional pPollAnswerIndex + + pGovernanceVerifyPoll :: Parser GovernanceCmd + pGovernanceVerifyPoll = + GovernanceVerifyPoll + <$> pPollFile + <*> pPollMetadataFile + + +pPollQuestion :: Parser Text +pPollQuestion = + Opt.strOption + ( Opt.long "question" + <> Opt.metavar "STRING" + <> Opt.help "The question for the poll." + ) + +pPollAnswer :: Parser Text +pPollAnswer = + Opt.strOption + ( Opt.long "answer" + <> Opt.metavar "STRING" + <> Opt.help "A possible choice for the poll. The option is repeatable." + ) + +pPollAnswerIndex :: Parser Word +pPollAnswerIndex = + Opt.option auto + ( Opt.long "answer" + <> Opt.metavar "INT" + <> Opt.help "The index of the chosen answer in the poll. Optional. Asked interactively if omitted." + ) + +pPollFile :: Parser FilePath +pPollFile = + Opt.strOption + ( Opt.long "poll-file" + <> Opt.metavar "FILE" + <> Opt.help "Filepath to the ongoing poll." + <> Opt.completer (Opt.bashCompleter "file") + ) + +pPollNonce :: Parser Word +pPollNonce = + Opt.option auto + ( Opt.long "nonce" + <> Opt.metavar "UINT" + <> Opt.help "An (optional) nonce for non-replayability." + ) + +pPollMetadataFile :: Parser FilePath +pPollMetadataFile = + Opt.strOption + ( Opt.long "metadata-file" + <> Opt.metavar "FILE" + <> Opt.help "Filepath of the metadata file, in (detailed) JSON format." + <> Opt.completer (Opt.bashCompleter "file") + ) + pTransferAmt :: Parser Lovelace pTransferAmt = Opt.option (readerFromParsecParser parseLovelace) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Governance.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Governance.hs index e7fc74a698a..06e7a2e8ba4 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Governance.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Governance.hs @@ -112,6 +112,12 @@ runGovernanceCmd (GovernanceGenesisKeyDelegationCertificate genVk genDelegVk vrf runGovernanceGenesisKeyDelegationCertificate genVk genDelegVk vrfVk out runGovernanceCmd (GovernanceUpdateProposal out eNo genVKeys ppUp mCostModelFp) = runGovernanceUpdateProposal out eNo genVKeys ppUp mCostModelFp +runGovernanceCmd (GovernanceCreatePoll prompt choices nonce out) = + runGovernanceCreatePoll prompt choices nonce out +runGovernanceCmd (GovernanceAnswerPoll poll sk ix) = + runGovernanceAnswerPoll poll sk ix +runGovernanceCmd (GovernanceVerifyPoll poll metadata) = + runGovernanceVerifyPoll poll metadata runGovernanceMIRCertificatePayStakeAddrs :: Shelley.MIRPot From 9e63ec9473256904b3840b53f393b51bad654cd7 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Thu, 6 Apr 2023 16:12:01 +0200 Subject: [PATCH 07/10] Introduce a new test helper function: tryExecCardanoCLI This is meant as a way to assert on *expected failures*! Sadly, `try` or other exception handling mechanisms do not work inside of the `TestT` monad, so I had to extract and lift the error to be able to catch it and assert on it. Yet, I need to assert on failures and thus, failures should not crash the test early but be assertable as a possible execution outcome. There's maybe something more clever to do but I only had a day and a half to spend on all this so I'd rather "get it done". --- cardano-cli/test/Test/OptParse.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/cardano-cli/test/Test/OptParse.hs b/cardano-cli/test/Test/OptParse.hs index a273302615d..41038b6197d 100644 --- a/cardano-cli/test/Test/OptParse.hs +++ b/cardano-cli/test/Test/OptParse.hs @@ -3,6 +3,7 @@ module Test.OptParse , checkTextEnvelopeFormat , equivalence , execCardanoCLI + , tryExecCardanoCLI , propertyOnce , withSnd , noteInputFile @@ -16,7 +17,10 @@ import Cardano.Api import Cardano.CLI.Shelley.Run.Read +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (runExceptT) import Control.Monad.IO.Class (MonadIO (..)) +import Data.Function ((&)) import GHC.Stack (CallStack, HasCallStack) import qualified Hedgehog as H import qualified Hedgehog.Extras.Test.Process as H @@ -37,6 +41,20 @@ execCardanoCLI -- ^ Captured stdout execCardanoCLI = GHC.withFrozenCallStack $ H.execFlex "cardano-cli" "CARDANO_CLI" +tryExecCardanoCLI + :: [String] + -- ^ Arguments to the CLI command + -> H.PropertyT IO (Either H.Failure String) + -- ^ Captured stdout, or error in case of failures +tryExecCardanoCLI args = + GHC.withFrozenCallStack (H.execFlex "cardano-cli" "CARDANO_CLI") args + & H.unPropertyT + & H.unTest + & runExceptT + & lift + & H.TestT + & H.PropertyT + -- | Checks that the 'tvType' and 'tvDescription' are equivalent between two files. checkTextEnvelopeFormat :: (MonadTest m, MonadIO m, HasCallStack) From d6a1f638ab4fa772ee5109e0500b6dfdac3fa4db Mon Sep 17 00:00:00 2001 From: KtorZ Date: Thu, 6 Apr 2023 16:13:38 +0200 Subject: [PATCH 08/10] Write automated tests to cover newly introduced SPO on-chain poll commands Fixture keys were generated using the command-line itself. The set of tests cover quite extensively the various commands, as well as a few 'negative' test scenarios. It is more complicated to cover the interactive part of the 'answer-poll' command through those tests; and this is therefore left as manual test. Instructions for executing the sequence will also be provided with the introduction of the commands (e.g. in the description of [PR#5050](https://github.com/input-output-hk/cardano-node/pull/5050). --- cardano-cli/cardano-cli.cabal | 3 + cardano-cli/test/Test/Golden/Shelley.hs | 35 +++++++++- .../Golden/Shelley/Governance/AnswerPoll.hs | 61 ++++++++++++++++++ .../Golden/Shelley/Governance/CreatePoll.hs | 56 ++++++++++++++++ .../Golden/Shelley/Governance/VerifyPoll.hs | 64 +++++++++++++++++++ cardano-cli/test/cardano-cli-golden.hs | 1 + .../governance/answer-cold-tempered.json | 37 +++++++++++ .../shelley/governance/answer-cold.json | 37 +++++++++++ .../governance/answer-vrf-tempered.json | 44 +++++++++++++ .../golden/shelley/governance/answer-vrf.json | 44 +++++++++++++ .../data/golden/shelley/governance/cold.sk | 5 ++ .../data/golden/shelley/governance/cold.vk | 5 ++ .../shelley/governance/create-long.json | 47 ++++++++++++++ .../golden/shelley/governance/create.json | 41 ++++++++++++ .../golden/shelley/governance/poll-long.json | 5 ++ .../data/golden/shelley/governance/poll.json | 5 ++ .../data/golden/shelley/governance/vrf.sk | 5 ++ .../data/golden/shelley/governance/vrf.vk | 5 ++ 18 files changed, 498 insertions(+), 2 deletions(-) create mode 100644 cardano-cli/test/Test/Golden/Shelley/Governance/AnswerPoll.hs create mode 100644 cardano-cli/test/Test/Golden/Shelley/Governance/CreatePoll.hs create mode 100644 cardano-cli/test/Test/Golden/Shelley/Governance/VerifyPoll.hs create mode 100644 cardano-cli/test/data/golden/shelley/governance/answer-cold-tempered.json create mode 100644 cardano-cli/test/data/golden/shelley/governance/answer-cold.json create mode 100644 cardano-cli/test/data/golden/shelley/governance/answer-vrf-tempered.json create mode 100644 cardano-cli/test/data/golden/shelley/governance/answer-vrf.json create mode 100644 cardano-cli/test/data/golden/shelley/governance/cold.sk create mode 100644 cardano-cli/test/data/golden/shelley/governance/cold.vk create mode 100644 cardano-cli/test/data/golden/shelley/governance/create-long.json create mode 100644 cardano-cli/test/data/golden/shelley/governance/create.json create mode 100644 cardano-cli/test/data/golden/shelley/governance/poll-long.json create mode 100644 cardano-cli/test/data/golden/shelley/governance/poll.json create mode 100644 cardano-cli/test/data/golden/shelley/governance/vrf.sk create mode 100644 cardano-cli/test/data/golden/shelley/governance/vrf.vk diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 6bc1c540421..68a6356bbe5 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -268,6 +268,9 @@ test-suite cardano-cli-golden Test.Golden.Shelley.Genesis.KeyGenGenesis Test.Golden.Shelley.Genesis.KeyGenUtxo Test.Golden.Shelley.Genesis.KeyHash + Test.Golden.Shelley.Governance.AnswerPoll + Test.Golden.Shelley.Governance.CreatePoll + Test.Golden.Shelley.Governance.VerifyPoll Test.Golden.Shelley.Key.ConvertCardanoAddressKey Test.Golden.Shelley.Metadata.StakePoolMetadata Test.Golden.Shelley.MultiSig.Address diff --git a/cardano-cli/test/Test/Golden/Shelley.hs b/cardano-cli/test/Test/Golden/Shelley.hs index 65497b13689..cc2e3b63661 100644 --- a/cardano-cli/test/Test/Golden/Shelley.hs +++ b/cardano-cli/test/Test/Golden/Shelley.hs @@ -1,9 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} module Test.Golden.Shelley - ( keyTests + ( keyConversionTests + , keyTests , certificateTests - , keyConversionTests + , governancePollTests , metadataTests , multiSigTests , txTests @@ -18,6 +19,20 @@ import Test.Golden.Shelley.Genesis.KeyGenDelegate (golden_shelleyGenes import Test.Golden.Shelley.Genesis.KeyGenGenesis (golden_shelleyGenesisKeyGenGenesis) import Test.Golden.Shelley.Genesis.KeyGenUtxo (golden_shelleyGenesisKeyGenUtxo) import Test.Golden.Shelley.Genesis.KeyHash (golden_shelleyGenesisKeyHash) + +import Test.Golden.Shelley.Governance.AnswerPoll + (golden_shelleyGovernanceAnswerPollCold, + golden_shelleyGovernanceAnswerPollInvalidAnswer, + golden_shelleyGovernanceAnswerPollVrf) +import Test.Golden.Shelley.Governance.CreatePoll + (golden_shelleyGovernanceCreatePoll, + golden_shelleyGovernanceCreateLongPoll) +import Test.Golden.Shelley.Governance.VerifyPoll + (golden_shelleyGovernanceVerifyPollCold, + golden_shelleyGovernanceVerifyPollColdTempered, + golden_shelleyGovernanceVerifyPollVrf, + golden_shelleyGovernanceVerifyPollVrfTempered) + import Test.Golden.Shelley.Key.ConvertCardanoAddressKey (golden_convertCardanoAddressByronSigningKey, golden_convertCardanoAddressIcarusSigningKey, @@ -168,3 +183,19 @@ multiSigTests = , ("golden_shelleyTransactionAssembleWitness_SigningKey", golden_shelleyTransactionAssembleWitness_SigningKey) , ("golden_shelleyTransactionSigningKeyWitness", golden_shelleyTransactionSigningKeyWitness) ] + +governancePollTests :: IO Bool +governancePollTests = + H.checkSequential + $ H.Group "Governance Poll Goldens" + [ ("golden_shelleyGovernanceCreatePoll", golden_shelleyGovernanceCreatePoll) + , ("golden_shelleyGovernanceCreateLongPoll", golden_shelleyGovernanceCreateLongPoll) + , ("golden_shelleyGovernanceAnswerPoll(VRF)", golden_shelleyGovernanceAnswerPollVrf) + , ("golden_shelleyGovernanceAnswerPoll(Cold key)", golden_shelleyGovernanceAnswerPollCold) + , ("golden_shelleyGovernanceAnswerPoll(Invalid)", golden_shelleyGovernanceAnswerPollInvalidAnswer) + , ("golden_shelleyGovernanceVerifyPoll(VRF)", golden_shelleyGovernanceVerifyPollVrf) + , ("golden_shelleyGovernanceVerifyPoll(VRF, tempered)", golden_shelleyGovernanceVerifyPollVrfTempered) + , ("golden_shelleyGovernanceVerifyPoll(Cold Key)", golden_shelleyGovernanceVerifyPollCold) + , ("golden_shelleyGovernanceVerifyPoll(Cold Key, tempered)", golden_shelleyGovernanceVerifyPollColdTempered) + ] + diff --git a/cardano-cli/test/Test/Golden/Shelley/Governance/AnswerPoll.hs b/cardano-cli/test/Test/Golden/Shelley/Governance/AnswerPoll.hs new file mode 100644 index 00000000000..14932f5fd62 --- /dev/null +++ b/cardano-cli/test/Test/Golden/Shelley/Governance/AnswerPoll.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Golden.Shelley.Governance.AnswerPoll + ( golden_shelleyGovernanceAnswerPollVrf + , golden_shelleyGovernanceAnswerPollCold + , golden_shelleyGovernanceAnswerPollInvalidAnswer + ) where + +import Hedgehog (Property) +import Test.OptParse + +import qualified Hedgehog as H +import qualified Hedgehog.Extras.Test.File as H + +{- HLINT ignore "Use camelCase" -} + +golden_shelleyGovernanceAnswerPollVrf :: Property +golden_shelleyGovernanceAnswerPollVrf = propertyOnce $ do + pollFile <- noteInputFile "test/data/golden/shelley/governance/poll.json" + vrfKeyFile <- noteInputFile "test/data/golden/shelley/governance/vrf.sk" + + stdout <- execCardanoCLI + [ "governance", "answer-poll" + , "--poll-file", pollFile + , "--signing-key-file", vrfKeyFile + , "--answer", "0" + ] + + noteInputFile "test/data/golden/shelley/governance/answer-vrf.json" + >>= H.readFile + >>= (H.===) stdout + +golden_shelleyGovernanceAnswerPollCold :: Property +golden_shelleyGovernanceAnswerPollCold = propertyOnce $ do + pollFile <- noteInputFile "test/data/golden/shelley/governance/poll.json" + coldKeyFile <- noteInputFile "test/data/golden/shelley/governance/cold.sk" + + stdout <- execCardanoCLI + [ "governance", "answer-poll" + , "--poll-file", pollFile + , "--signing-key-file", coldKeyFile + , "--answer", "1" + ] + + noteInputFile "test/data/golden/shelley/governance/answer-cold.json" + >>= H.readFile + >>= (H.===) stdout + +golden_shelleyGovernanceAnswerPollInvalidAnswer :: Property +golden_shelleyGovernanceAnswerPollInvalidAnswer = propertyOnce $ do + pollFile <- noteInputFile "test/data/golden/shelley/governance/poll.json" + vrfKeyFile <- noteInputFile "test/data/golden/shelley/governance/vrf.sk" + + result <- tryExecCardanoCLI + [ "governance", "answer-poll" + , "--poll-file", pollFile + , "--signing-key-file", vrfKeyFile + , "--answer", "3" + ] + + either (const H.success) (const H.failure) result diff --git a/cardano-cli/test/Test/Golden/Shelley/Governance/CreatePoll.hs b/cardano-cli/test/Test/Golden/Shelley/Governance/CreatePoll.hs new file mode 100644 index 00000000000..eb1c86301ea --- /dev/null +++ b/cardano-cli/test/Test/Golden/Shelley/Governance/CreatePoll.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Golden.Shelley.Governance.CreatePoll + ( golden_shelleyGovernanceCreatePoll + , golden_shelleyGovernanceCreateLongPoll + ) where + +import Control.Monad (void) +import Hedgehog (Property) +import Test.OptParse + +import qualified Hedgehog as H +import qualified Hedgehog.Extras.Test.Base as H +import qualified Hedgehog.Extras.Test.File as H + +{- HLINT ignore "Use camelCase" -} + +golden_shelleyGovernanceCreatePoll :: Property +golden_shelleyGovernanceCreatePoll = + propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do + pollFile <- noteTempFile tempDir "poll.json" + + stdout <- execCardanoCLI + [ "governance", "create-poll" + , "--question", "Pineapples on pizza?" + , "--answer", "yes" + , "--answer", "no" + , "--out-file", pollFile + ] + + void $ H.readFile pollFile + noteInputFile "test/data/golden/shelley/governance/create.json" + >>= H.readFile + >>= (H.===) stdout + H.assertFileOccurences 1 "GovernancePoll" pollFile + H.assertEndsWithSingleNewline pollFile + +golden_shelleyGovernanceCreateLongPoll :: Property +golden_shelleyGovernanceCreateLongPoll = + propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do + pollFile <- noteTempFile tempDir "poll.json" + + stdout <- execCardanoCLI + [ "governance", "create-poll" + , "--question", "What is the most adequate topping to put on a pizza (please consider all possibilities and take time to answer)?" + , "--answer", "pineapples" + , "--answer", "only traditional topics should go on a pizza, this isn't room for jokes" + , "--out-file", pollFile + ] + + void $ H.readFile pollFile + noteInputFile "test/data/golden/shelley/governance/create-long.json" + >>= H.readFile + >>= (H.===) stdout + H.assertFileOccurences 1 "GovernancePoll" pollFile + H.assertEndsWithSingleNewline pollFile diff --git a/cardano-cli/test/Test/Golden/Shelley/Governance/VerifyPoll.hs b/cardano-cli/test/Test/Golden/Shelley/Governance/VerifyPoll.hs new file mode 100644 index 00000000000..a1078a13908 --- /dev/null +++ b/cardano-cli/test/Test/Golden/Shelley/Governance/VerifyPoll.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Golden.Shelley.Governance.VerifyPoll + ( golden_shelleyGovernanceVerifyPollVrf + , golden_shelleyGovernanceVerifyPollVrfTempered + , golden_shelleyGovernanceVerifyPollCold + , golden_shelleyGovernanceVerifyPollColdTempered + ) where + +import Control.Monad (void) +import Hedgehog (Property) +import Test.OptParse + +import qualified Hedgehog as H + +{- HLINT ignore "Use camelCase" -} + +golden_shelleyGovernanceVerifyPollVrf :: Property +golden_shelleyGovernanceVerifyPollVrf = propertyOnce $ do + pollFile <- noteInputFile "test/data/golden/shelley/governance/poll.json" + metadataFile <- noteInputFile "test/data/golden/shelley/governance/answer-vrf.json" + + void $ execCardanoCLI + [ "governance", "verify-poll" + , "--poll-file", pollFile + , "--metadata-file", metadataFile + ] + +golden_shelleyGovernanceVerifyPollCold :: Property +golden_shelleyGovernanceVerifyPollCold = propertyOnce $ do + pollFile <- noteInputFile "test/data/golden/shelley/governance/poll.json" + metadataFile <- noteInputFile "test/data/golden/shelley/governance/answer-cold.json" + + void $ execCardanoCLI + [ "governance", "verify-poll" + , "--poll-file", pollFile + , "--metadata-file", metadataFile + ] + +golden_shelleyGovernanceVerifyPollVrfTempered :: Property +golden_shelleyGovernanceVerifyPollVrfTempered = propertyOnce $ do + pollFile <- noteInputFile "test/data/golden/shelley/governance/poll.json" + metadataFile <- noteInputFile "test/data/golden/shelley/governance/answer-vrf-tempered.json" + + result <- tryExecCardanoCLI + [ "governance", "verify-poll" + , "--poll-file", pollFile + , "--metadata-file", metadataFile + ] + + either (const H.success) (const H.failure) result + +golden_shelleyGovernanceVerifyPollColdTempered :: Property +golden_shelleyGovernanceVerifyPollColdTempered = propertyOnce $ do + pollFile <- noteInputFile "test/data/golden/shelley/governance/poll.json" + metadataFile <- noteInputFile "test/data/golden/shelley/governance/answer-cold-tempered.json" + + result <- tryExecCardanoCLI + [ "governance", "verify-poll" + , "--poll-file", pollFile + , "--metadata-file", metadataFile + ] + + either (const H.success) (const H.failure) result diff --git a/cardano-cli/test/cardano-cli-golden.hs b/cardano-cli/test/cardano-cli-golden.hs index 08bef2acda5..58553421d1e 100644 --- a/cardano-cli/test/cardano-cli-golden.hs +++ b/cardano-cli/test/cardano-cli-golden.hs @@ -22,5 +22,6 @@ main = , Test.Golden.Shelley.metadataTests , Test.Golden.Shelley.multiSigTests , Test.Golden.Shelley.txTests + , Test.Golden.Shelley.governancePollTests , Test.Golden.TxView.txViewTests ] diff --git a/cardano-cli/test/data/golden/shelley/governance/answer-cold-tempered.json b/cardano-cli/test/data/golden/shelley/governance/answer-cold-tempered.json new file mode 100644 index 00000000000..88bb15a154d --- /dev/null +++ b/cardano-cli/test/data/golden/shelley/governance/answer-cold-tempered.json @@ -0,0 +1,37 @@ +{ + "94": { + "map": [ + { + "k": { + "int": 2 + }, + "v": { + "bytes": "820c311ced91f8c2bb9b5c7f446379063c9a077a1098d73498d17e9ea27045af" + } + }, + { + "k": { + "int": 3 + }, + "v": { + "int": 1 + } + }, + { + "k": { + "int": 5 + }, + "v": { + "list": [ + { + "bytes": "29ade2115fbcbc17f063eec41ec0d358ccc5b52c2bccb47c0918727695619a68" + }, + { + "bytes": "6458ff100279aed89b0ea08a57ddbf3b77e7c6802b8c23840da7df80b60f37c0ddd445499d247d27d7e7adaa189db001d0f1eddc2229daa6be7509c43cc23501" + } + ] + } + } + ] + } +} diff --git a/cardano-cli/test/data/golden/shelley/governance/answer-cold.json b/cardano-cli/test/data/golden/shelley/governance/answer-cold.json new file mode 100644 index 00000000000..b30708b3c4c --- /dev/null +++ b/cardano-cli/test/data/golden/shelley/governance/answer-cold.json @@ -0,0 +1,37 @@ +{ + "94": { + "map": [ + { + "k": { + "int": 2 + }, + "v": { + "bytes": "29093fd43fc30ba31e306af06ce8537390e1668ae7496fe53d53684683c3762c" + } + }, + { + "k": { + "int": 3 + }, + "v": { + "int": 1 + } + }, + { + "k": { + "int": 5 + }, + "v": { + "list": [ + { + "bytes": "29ade2115fbcbc17f063eec41ec0d358ccc5b52c2bccb47c0918727695619a68" + }, + { + "bytes": "6458ff100279aed89b0ea08a57ddbf3b77e7c6802b8c23840da7df80b60f37c0ddd445499d247d27d7e7adaa189db001d0f1eddc2229daa6be7509c43cc23501" + } + ] + } + } + ] + } +} diff --git a/cardano-cli/test/data/golden/shelley/governance/answer-vrf-tempered.json b/cardano-cli/test/data/golden/shelley/governance/answer-vrf-tempered.json new file mode 100644 index 00000000000..0b45e71ad94 --- /dev/null +++ b/cardano-cli/test/data/golden/shelley/governance/answer-vrf-tempered.json @@ -0,0 +1,44 @@ +{ + "94": { + "map": [ + { + "k": { + "int": 2 + }, + "v": { + "bytes": "29093fd43fc30ba31e306af06ce8537390e1668ae7496fe53d53684683c3762c" + } + }, + { + "k": { + "int": 3 + }, + "v": { + "int": 1 + } + }, + { + "k": { + "int": 4 + }, + "v": { + "list": [ + { + "bytes": "2dc2fa217af8b52251c4cdf538fa106cbf0b5beac3e74d05f97ceb33c0147a2c" + }, + { + "list": [ + { + "bytes": "c1c4d0cf60529f091431c456bf528b23d384f641afc536d1347b0889e9fd45d47e422249ac4bb5bdd75c205ea35c1ef2d89d96c0f06070590a98db7dba659647" + }, + { + "bytes": "9a440df4e70830b22b86accbeab7bc07" + } + ] + } + ] + } + } + ] + } +} diff --git a/cardano-cli/test/data/golden/shelley/governance/answer-vrf.json b/cardano-cli/test/data/golden/shelley/governance/answer-vrf.json new file mode 100644 index 00000000000..de4d1dbcfc1 --- /dev/null +++ b/cardano-cli/test/data/golden/shelley/governance/answer-vrf.json @@ -0,0 +1,44 @@ +{ + "94": { + "map": [ + { + "k": { + "int": 2 + }, + "v": { + "bytes": "29093fd43fc30ba31e306af06ce8537390e1668ae7496fe53d53684683c3762c" + } + }, + { + "k": { + "int": 3 + }, + "v": { + "int": 0 + } + }, + { + "k": { + "int": 4 + }, + "v": { + "list": [ + { + "bytes": "2dc2fa217af8b52251c4cdf538fa106cbf0b5beac3e74d05f97ceb33c0147a2c" + }, + { + "list": [ + { + "bytes": "c1c4d0cf60529f091431c456bf528b23d384f641afc536d1347b0889e9fd45d47e422249ac4bb5bdd75c205ea35c1ef2d89d96c0f06070590a98db7dba659647" + }, + { + "bytes": "9a440df4e70830b22b86accbeab7bc07" + } + ] + } + ] + } + } + ] + } +} diff --git a/cardano-cli/test/data/golden/shelley/governance/cold.sk b/cardano-cli/test/data/golden/shelley/governance/cold.sk new file mode 100644 index 00000000000..c766daf4dda --- /dev/null +++ b/cardano-cli/test/data/golden/shelley/governance/cold.sk @@ -0,0 +1,5 @@ +{ + "type": "StakePoolSigningKey_ed25519", + "description": "Stake Pool Operator Signing Key", + "cborHex": "58201d298ffa1544da0a5b2ea544728fc1ba7d2ae7c60e1d37da03895019740dd00a" +} diff --git a/cardano-cli/test/data/golden/shelley/governance/cold.vk b/cardano-cli/test/data/golden/shelley/governance/cold.vk new file mode 100644 index 00000000000..a58782c0855 --- /dev/null +++ b/cardano-cli/test/data/golden/shelley/governance/cold.vk @@ -0,0 +1,5 @@ +{ + "type": "StakePoolVerificationKey_ed25519", + "description": "Stake Pool Operator Verification Key", + "cborHex": "582029ade2115fbcbc17f063eec41ec0d358ccc5b52c2bccb47c0918727695619a68" +} diff --git a/cardano-cli/test/data/golden/shelley/governance/create-long.json b/cardano-cli/test/data/golden/shelley/governance/create-long.json new file mode 100644 index 00000000000..4adc5955729 --- /dev/null +++ b/cardano-cli/test/data/golden/shelley/governance/create-long.json @@ -0,0 +1,47 @@ +{ + "94": { + "map": [ + { + "k": { + "int": 0 + }, + "v": { + "list": [ + { + "string": "What is the most adequate topping to put on a pizza (please cons" + }, + { + "string": "ider all possibilities and take time to answer)?" + } + ] + } + }, + { + "k": { + "int": 1 + }, + "v": { + "list": [ + { + "list": [ + { + "string": "pineapples" + } + ] + }, + { + "list": [ + { + "string": "only traditional topics should go on a pizza, this isn't room fo" + }, + { + "string": "r jokes" + } + ] + } + ] + } + } + ] + } +} diff --git a/cardano-cli/test/data/golden/shelley/governance/create.json b/cardano-cli/test/data/golden/shelley/governance/create.json new file mode 100644 index 00000000000..35c4821c3e8 --- /dev/null +++ b/cardano-cli/test/data/golden/shelley/governance/create.json @@ -0,0 +1,41 @@ +{ + "94": { + "map": [ + { + "k": { + "int": 0 + }, + "v": { + "list": [ + { + "string": "Pineapples on pizza?" + } + ] + } + }, + { + "k": { + "int": 1 + }, + "v": { + "list": [ + { + "list": [ + { + "string": "yes" + } + ] + }, + { + "list": [ + { + "string": "no" + } + ] + } + ] + } + } + ] + } +} diff --git a/cardano-cli/test/data/golden/shelley/governance/poll-long.json b/cardano-cli/test/data/golden/shelley/governance/poll-long.json new file mode 100644 index 00000000000..fe4480afeaf --- /dev/null +++ b/cardano-cli/test/data/golden/shelley/governance/poll-long.json @@ -0,0 +1,5 @@ +{ + "type": "GovernancePoll", + "description": "An on-chain poll for SPOs: What is the most adequate topping to put on a pizza (please consider all possibilities and take time to answer)?", + "cborHex": "a1185ea2008278405768617420697320746865206d6f737420616465717561746520746f7070696e6720746f20707574206f6e20612070697a7a612028706c6561736520636f6e7378306964657220616c6c20706f73736962696c697469657320616e642074616b652074696d6520746f20616e73776572293f0182816a70696e656170706c65738278406f6e6c7920747261646974696f6e616c20746f706963732073686f756c6420676f206f6e20612070697a7a612c20746869732069736e277420726f6f6d20666f6772206a6f6b6573" +} diff --git a/cardano-cli/test/data/golden/shelley/governance/poll.json b/cardano-cli/test/data/golden/shelley/governance/poll.json new file mode 100644 index 00000000000..8bca3767712 --- /dev/null +++ b/cardano-cli/test/data/golden/shelley/governance/poll.json @@ -0,0 +1,5 @@ +{ + "type": "GovernancePoll", + "description": "An on-chain poll for SPOs: Pineapples on pizza?", + "cborHex": "a1185ea200817450696e656170706c6573206f6e2070697a7a613f0182816379657381626e6f" +} diff --git a/cardano-cli/test/data/golden/shelley/governance/vrf.sk b/cardano-cli/test/data/golden/shelley/governance/vrf.sk new file mode 100644 index 00000000000..cce48ab8dbf --- /dev/null +++ b/cardano-cli/test/data/golden/shelley/governance/vrf.sk @@ -0,0 +1,5 @@ +{ + "type": "VrfSigningKey_PraosVRF", + "description": "VRF Signing Key", + "cborHex": "5840b23fa897c1fc869d081e4818ea0ac533c1efaccb888cb57d8a40f6582783045d2dc2fa217af8b52251c4cdf538fa106cbf0b5beac3e74d05f97ceb33c0147a2c" +} diff --git a/cardano-cli/test/data/golden/shelley/governance/vrf.vk b/cardano-cli/test/data/golden/shelley/governance/vrf.vk new file mode 100644 index 00000000000..5f63434a64e --- /dev/null +++ b/cardano-cli/test/data/golden/shelley/governance/vrf.vk @@ -0,0 +1,5 @@ +{ + "type": "VrfVerificationKey_PraosVRF", + "description": "VRF Verification Key", + "cborHex": "58202dc2fa217af8b52251c4cdf538fa106cbf0b5beac3e74d05f97ceb33c0147a2c" +} From 4ed6fac5c43716dd58c52069b08c5eb2b93b3a30 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Fri, 14 Apr 2023 11:08:20 +0200 Subject: [PATCH 09/10] Add roundtrip serialization property tests for GovernancePoll{Answer, Witness} MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ``` roundtrip GovernancePoll CBOR: OK (0.09s) ✓ roundtrip GovernancePoll CBOR passed 100 tests. roundtrip GovernancePollAnswer CBOR: OK ✓ roundtrip GovernancePollAnswer CBOR passed 100 tests. roundtrip GovernancePollWitness CBOR: OK (0.01s) ✓ roundtrip GovernancePollWitness CBOR passed 100 tests. ``` --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 55 +++++++++++++++++++ .../src/Cardano/Api/Governance/Poll.hs | 9 +-- .../test/Test/Cardano/Api/Typed/CBOR.hs | 15 +++++ 3 files changed, 75 insertions(+), 4 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index b5e5072f5c4..a4cd5abd6f6 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -106,6 +106,10 @@ module Test.Gen.Cardano.Api.Typed , genWitnessNetworkIdOrByronAddress , genRational + + , genGovernancePoll + , genGovernancePollAnswer + , genGovernancePollWitness ) where import Cardano.Api hiding (txIns) @@ -113,6 +117,7 @@ import qualified Cardano.Api as Api import Cardano.Api.Byron (KeyWitness (ByronKeyWitness), WitnessNetworkIdOrByronAddress (..)) import Cardano.Api.Shelley (Hash (..), KESPeriod (KESPeriod), + GovernancePoll (..), GovernancePollAnswer (..), GovernancePollWitness (..), OperationalCertificateIssueCounter (OperationalCertificateIssueCounter), PlutusScript (PlutusScriptSerialised), ProtocolParameters (ProtocolParameters), ReferenceScript (..), ReferenceTxInsScriptsInlineDatumsSupportedInEra (..), @@ -120,20 +125,24 @@ import Cardano.Api.Shelley (Hash (..), KESPeriod (KESPeriod), refInsScriptsAndInlineDatsSupportedInEra) +import Control.Applicative (optional) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Short as SBS import Data.Coerce import Data.Int (Int64) import Data.Map.Strict (Map) +import Data.Maybe (fromMaybe) import Data.Ratio (Ratio, (%)) import Data.String import Data.Word (Word64) import Numeric.Natural (Natural) import qualified Cardano.Binary as CBOR +import qualified Cardano.Crypto.DSIGN as DSIGN import qualified Cardano.Crypto.Hash as Crypto import qualified Cardano.Crypto.Seed as Crypto +import qualified Cardano.Crypto.VRF as VRF import qualified Cardano.Ledger.Shelley.TxBody as Ledger (EraIndependentTxBody) import qualified Test.Cardano.Ledger.Alonzo.PlutusScripts as Plutus @@ -145,6 +154,7 @@ import qualified Cardano.Crypto.Hash.Class as CRYPTO import Cardano.Ledger.Alonzo.Language (Language (..)) import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo import Cardano.Ledger.SafeHash (unsafeMakeSafeHash) +import Cardano.Ledger.Keys (VKey(..)) import Test.Cardano.Chain.UTxO.Gen (genVKWitness) import Test.Cardano.Crypto.Gen (genProtocolMagicId) @@ -957,3 +967,48 @@ genHashScriptData = ScriptDataHash . unsafeMakeSafeHash . mkDummyHash <$> Gen.in genScriptDataSupportedInAlonzoEra :: Gen (ScriptDataSupportedInEra AlonzoEra) genScriptDataSupportedInAlonzoEra = pure ScriptDataInAlonzoEra + +genGovernancePoll :: Gen GovernancePoll +genGovernancePoll = + GovernancePoll + <$> Gen.text (Range.linear 1 255) Gen.unicodeAll + <*> Gen.list (Range.constant 1 10) (Gen.text (Range.linear 1 255) Gen.unicodeAll) + <*> optional (Gen.word (Range.constant 0 100)) + +genGovernancePollAnswer :: Gen GovernancePollAnswer +genGovernancePollAnswer = + GovernancePollAnswer + <$> genGovernancePollHash + <*> Gen.word (Range.constant 0 10) + where + genGovernancePollHash = + GovernancePollHash . mkDummyHash <$> Gen.int (Range.linear 0 10) + +genGovernancePollWitness :: Gen GovernancePollWitness +genGovernancePollWitness = + Gen.choice + [ GovernancePollWitnessVRF + <$> fmap + unsafeDeserialiseVerKeyVRF + (Gen.bytes $ Range.singleton 32) + <*> fmap + unsafeDeserialiseCertVRF + (Gen.bytes $ Range.singleton 80) + , GovernancePollWitnessColdKey + <$> fmap + (VKey . unsafeDeserialiseVerKeyDSIGN) + (Gen.bytes $ Range.singleton 32) + <*> fmap + (DSIGN.SignedDSIGN . unsafeDeserialiseSigDSIGN) + (Gen.bytes $ Range.singleton 64) + ] + where + unsafeDeserialiseVerKeyVRF = + fromMaybe (error "unsafeDeserialiseVerKeyVRF") . VRF.rawDeserialiseVerKeyVRF + unsafeDeserialiseCertVRF = + fromMaybe (error "unsafeDeserialiseCertVRF") . VRF.rawDeserialiseCertVRF + + unsafeDeserialiseVerKeyDSIGN = + fromMaybe (error "unsafeDeserialiseVerKeyDSIGN") . DSIGN.rawDeserialiseVerKeyDSIGN + unsafeDeserialiseSigDSIGN = + fromMaybe (error "unsafeDeserialiseSigDSIGN") . DSIGN.rawDeserialiseSigDSIGN diff --git a/cardano-api/src/Cardano/Api/Governance/Poll.hs b/cardano-api/src/Cardano/Api/Governance/Poll.hs index 288bb8f81a3..318a7aa37c3 100644 --- a/cardano-api/src/Cardano/Api/Governance/Poll.hs +++ b/cardano-api/src/Cardano/Api/Governance/Poll.hs @@ -17,7 +17,8 @@ -- CIP-1694 continues. module Cardano.Api.Governance.Poll( -- * Type Proxies - AsType(..), + AsType (..), + Hash (..), -- * Types GovernancePoll (..), @@ -117,7 +118,7 @@ data GovernancePoll = GovernancePoll , govPollNonce :: Maybe Word -- ^ An optional nonce to make the poll unique if needs be. } - deriving Show + deriving (Show, Eq) instance HasTextEnvelope GovernancePoll where textEnvelopeType _ = "GovernancePoll" @@ -212,7 +213,7 @@ data GovernancePollAnswer = GovernancePollAnswer , govAnsChoice :: Word -- ^ The (0-based) index of the chosen answer from that poll } - deriving Show + deriving (Show, Eq) instance HasTypeProxy GovernancePollAnswer where data AsType GovernancePollAnswer = AsGovernancePollAnswer @@ -284,7 +285,7 @@ data GovernancePollWitness | GovernancePollWitnessColdKey (VKey 'Witness StandardCrypto) (SignedDSIGN StandardCrypto GovernancePollAnswer) - deriving Show + deriving (Show, Eq) instance HasTypeProxy GovernancePollWitness where data AsType GovernancePollWitness = AsGovernancePollWitness diff --git a/cardano-api/test/Test/Cardano/Api/Typed/CBOR.hs b/cardano-api/test/Test/Cardano/Api/Typed/CBOR.hs index bd691425342..902e8abf227 100644 --- a/cardano-api/test/Test/Cardano/Api/Typed/CBOR.hs +++ b/cardano-api/test/Test/Cardano/Api/Typed/CBOR.hs @@ -8,6 +8,7 @@ module Test.Cardano.Api.Typed.CBOR import Cardano.Api +import Cardano.Api.Shelley (AsType(..)) import Data.Proxy (Proxy (..)) import Data.String (IsString (..)) import Hedgehog (Property, forAll, tripping) @@ -168,6 +169,17 @@ prop_roundtrip_TxWitness_Cddl = H.property $ do x <- forAll $ genShelleyKeyWitness $ shelleyBasedToCardanoEra sbe tripping x (serialiseWitnessLedgerCddl sbe) (deserialiseWitnessLedgerCddl sbe) +prop_roundtrip_GovernancePoll_CBOR :: Property +prop_roundtrip_GovernancePoll_CBOR = + roundtrip_CBOR AsGovernancePoll genGovernancePoll + +prop_roundtrip_GovernancePollAnswer_CBOR :: Property +prop_roundtrip_GovernancePollAnswer_CBOR = + roundtrip_CBOR AsGovernancePollAnswer genGovernancePollAnswer + +prop_roundtrip_GovernancePollWitness_CBOR :: Property +prop_roundtrip_GovernancePollWitness_CBOR = + roundtrip_CBOR AsGovernancePollWitness genGovernancePollWitness -- ----------------------------------------------------------------------------- @@ -205,5 +217,8 @@ tests = testGroup "Test.Cardano.Api.Typed.CBOR" , testPropertyNamed "roundtrip txbody CBOR" "roundtrip txbody CBOR" prop_roundtrip_txbody_CBOR , testPropertyNamed "roundtrip Tx Cddl" "roundtrip Tx Cddl" prop_roundtrip_Tx_Cddl , testPropertyNamed "roundtrip TxWitness Cddl" "roundtrip TxWitness Cddl" prop_roundtrip_TxWitness_Cddl + , testPropertyNamed "roundtrip GovernancePoll CBOR" "roundtrip GovernancePoll CBOR" prop_roundtrip_GovernancePoll_CBOR + , testPropertyNamed "roundtrip GovernancePollAnswer CBOR" "roundtrip GovernancePollAnswer CBOR" prop_roundtrip_GovernancePollAnswer_CBOR + , testPropertyNamed "roundtrip GovernancePollWitness CBOR" "roundtrip GovernancePollWitness CBOR" prop_roundtrip_GovernancePollWitness_CBOR , testGroup "roundtrip tx CBOR" test_roundtrip_tx_CBOR ] From 160f67b01a41d1167707a3b1d920dc4c4403f220 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Fri, 14 Apr 2023 14:00:23 +0200 Subject: [PATCH 10/10] Add property tests for 'chunks', and fix 'metaTextChunks' MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ``` Cardano.Api Test.Cardano.Api.Metadata valid & rountrip text chunks: OK (0.03s) ✓ valid & roundtrip text chunks passed 100 tests. Empty chunks 3% ▌··················· ✓ 1% Single chunks 26% █████▏·············· ✓ 5% Many chunks 71% ██████████████▏····· ✓ 25% valid & rountrip bytes chunks: OK ✓ valid & roundtrip bytes chunks passed 100 tests. Empty chunks 3% ▌··················· ✓ 1% Single chunks 55% ███████████········· ✓ 5% Many chunks 42% ████████▍··········· ✓ 25% ``` Turns out there were two issues: - Empty {text,byte}strings would generate a singleton chunk with an empty value; which is okay semantically but ugly; empty strings now generate an empty chunk. - Metadata values measure the length of UTF-8-encoded strings, which means we can't rely on default text functions to split a text string. This is likely an overkill in many situation in the context of PR#5050 since most questions / answers will be in plain english. However, we can now put emojis and crazy unicode characters in there without problems. --- cardano-api/src/Cardano/Api.hs | 2 + cardano-api/src/Cardano/Api/TxMetadata.hs | 40 ++++++++++++++-- cardano-api/test/Test/Cardano/Api/Metadata.hs | 48 ++++++++++++++++++- 3 files changed, 86 insertions(+), 4 deletions(-) diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 7a3348ccfcc..1ddde4e7c51 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -341,6 +341,8 @@ module Cardano.Api ( TxMetadataValue(..), makeTransactionMetadata, mergeTransactionMetadata, + metaTextChunks, + metaBytesChunks, -- ** Validating metadata validateTxMetadata, diff --git a/cardano-api/src/Cardano/Api/TxMetadata.hs b/cardano-api/src/Cardano/Api/TxMetadata.hs index 007fdff7b62..f3d1b1d03ef 100644 --- a/cardano-api/src/Cardano/Api/TxMetadata.hs +++ b/cardano-api/src/Cardano/Api/TxMetadata.hs @@ -59,7 +59,7 @@ import qualified Data.Aeson.Key as Aeson import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.Aeson.Text as Aeson.Text import qualified Data.Attoparsec.ByteString.Char8 as Atto -import Data.Bifunctor (first) +import Data.Bifunctor (bimap, first) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as Base16 @@ -75,6 +75,7 @@ import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Vector as Vector import Data.Word @@ -147,7 +148,40 @@ metaTextChunks = txMetadataTextStringMaxByteLength TxMetaText (BS.length . Text.encodeUtf8) - Text.splitAt + utf8SplitAt + where + fromBuilder = Text.Lazy.toStrict . Text.Builder.toLazyText + + -- 'Text.splitAt' is no good here, because our measurement is on UTF-8 + -- encoded text strings; So a char of size 1 in a text string may be + -- encoded over multiple UTF-8 bytes. + -- + -- Thus, no choice than folding over each char and manually implementing + -- splitAt that counts utf8 bytes. Using builders for slightly more + -- efficiency. + utf8SplitAt n = + bimap fromBuilder fromBuilder . snd . Text.foldl + (\(len, (left, right)) char -> + -- NOTE: + -- Starting from text >= 2.0.0.0, one can use: + -- + -- Data.Text.Internal.Encoding.Utf8#utf8Length + -- + let sz = BS.length (Text.encodeUtf8 (Text.singleton char)) in + if len + sz > n then + ( n + 1 -- Higher than 'n' to always trigger the predicate + , ( left + , right <> Text.Builder.singleton char + ) + ) + else + ( len + sz + , ( left <> Text.Builder.singleton char + , right + ) + ) + ) + (0, (mempty, mempty)) -- | Create a 'TxMetadataValue' from a 'ByteString' as a list of chunks of an -- accaptable size. @@ -217,7 +251,7 @@ chunks maxLength strHoist strLength strSplitAt str let (h, t) = strSplitAt maxLength str in strHoist h : chunks maxLength strHoist strLength strSplitAt t | otherwise = - [strHoist str] + [strHoist str | strLength str > 0] -- ---------------------------------------------------------------------------- -- Validate tx metadata diff --git a/cardano-api/test/Test/Cardano/Api/Metadata.hs b/cardano-api/test/Test/Cardano/Api/Metadata.hs index 356d881b681..eb5324ab4ce 100644 --- a/cardano-api/test/Test/Cardano/Api/Metadata.hs +++ b/cardano-api/test/Test/Cardano/Api/Metadata.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} module Test.Cardano.Api.Metadata ( tests @@ -9,8 +10,9 @@ module Test.Cardano.Api.Metadata import Cardano.Api import Data.ByteString (ByteString) +import Data.Maybe (mapMaybe) import Data.Word (Word64) -import Hedgehog (Property, property, (===)) +import Hedgehog (Gen, Property, property, (===)) import Test.Gen.Cardano.Api.Metadata import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testPropertyNamed) @@ -18,6 +20,8 @@ import Test.Tasty.Hedgehog (testPropertyNamed) import qualified Data.Aeson as Aeson import qualified Data.Map.Strict as Map import qualified Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range -- ---------------------------------------------------------------------------- -- Golden / unit tests @@ -118,6 +122,46 @@ prop_metadata_roundtrip_via_schema_json = Hedgehog.property $ do Right md === (metadataFromJson TxMetadataJsonDetailedSchema . metadataToJson TxMetadataJsonDetailedSchema) md +prop_metadata_chunks + :: (Show str, Eq str, Monoid str) + => Gen str + -> (str -> TxMetadataValue) + -> (TxMetadataValue -> Maybe str) + -> Property +prop_metadata_chunks genStr toMetadataValue extractChunk = Hedgehog.property $ do + str <- Hedgehog.forAll genStr + case toMetadataValue str of + metadataValue@(TxMetaList chunks) -> do + Hedgehog.cover 1 "Empty chunks" (null chunks) + Hedgehog.cover 5 "Single chunks" (length chunks == 1) + Hedgehog.cover 25 "Many chunks" (length chunks > 1) + str === mconcat (mapMaybe extractChunk chunks) + Right () === validateTxMetadata metadata + where + metadata = makeTransactionMetadata (Map.singleton 0 metadataValue) + _ -> + Hedgehog.failure + +prop_metadata_text_chunks :: Property +prop_metadata_text_chunks = + prop_metadata_chunks + (Gen.text (Range.linear 0 255) Gen.unicodeAll) + metaTextChunks + (\case + TxMetaText chunk -> Just chunk + _ -> Nothing + ) + +prop_metadata_bytes_chunks :: Property +prop_metadata_bytes_chunks = + prop_metadata_chunks + (Gen.bytes (Range.linear 0 255)) + metaBytesChunks + (\case + TxMetaBytes chunk -> Just chunk + _ -> Nothing + ) + -- ---------------------------------------------------------------------------- -- Automagically collecting all the tests -- @@ -135,4 +179,6 @@ tests = testGroup "Test.Cardano.Api.Metadata" , testPropertyNamed "noschema json roundtrip via metadata" "noschema json roundtrip via metadata" prop_noschema_json_roundtrip_via_metadata , testPropertyNamed "schema json roundtrip via metadata" "schema json roundtrip via metadata" prop_schema_json_roundtrip_via_metadata , testPropertyNamed "metadata roundtrip via schema json" "metadata roundtrip via schema json" prop_metadata_roundtrip_via_schema_json + , testPropertyNamed "valid & rountrip text chunks" "valid & roundtrip text chunks" prop_metadata_text_chunks + , testPropertyNamed "valid & rountrip bytes chunks" "valid & roundtrip bytes chunks" prop_metadata_bytes_chunks ]