From f15d3124b6baed896466a5f2258ccd26807010af 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 4323e4f2604..1d2813ee9ac 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 be357754fa682db54129edf718b5979f8055c53d 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 1d2813ee9ac..172b49812b5 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, @@ -133,6 +135,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 @@ -166,6 +187,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 071a7d11691774ea120682c34adacea9124956e5 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 | 1 + cardano-api/cardano-api.cabal | 1 + .../src/Cardano/Api/Governance/Poll.hs | 254 ++++++++++++++++++ cardano-api/src/Cardano/Api/Shelley.hs | 10 + 4 files changed, 266 insertions(+) create mode 100644 cardano-api/src/Cardano/Api/Governance/Poll.hs diff --git a/cardano-api/ChangeLog.md b/cardano-api/ChangeLog.md index fa95f95a9fc..458c7e83072 100644 --- a/cardano-api/ChangeLog.md +++ b/cardano-api/ChangeLog.md @@ -84,6 +84,7 @@ - New generators in `gen` sublibrary: `genPositiveLovelace`, `genPositiveQuantity` and `genSignedNonZeroQuantity`. ([PR 5013](https://github.com/input-output-hk/cardano-node/pull/5013)) +- 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 diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 51f04e21660..fb9c5cb773f 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 6a550e426f1..13990328436 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(..), @@ -249,6 +258,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 cd70f911793314dfdd38f23afedb4923faf7f8de 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 fc933641464..abc7657c27d 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -334,6 +334,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 13990328436..f65bd9510e5 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 172b49812b5..2d477cc93d0 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, @@ -155,6 +158,13 @@ metaBytesChunks = BS.length BS.splitAt +-- ---------------------------------------------------------------------------- +-- TxMetadata class +-- + +class AsTxMetadata a where + asTxMetadata :: a -> TxMetadata + -- ---------------------------------------------------------------------------- -- Internal conversion functions -- From 09f94fc240636f67a843ff8e86374805def01ff3 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 | 199 +++++++++++++++++- .../src/Cardano/CLI/Shelley/Run/Key.hs | 1 + .../src/Cardano/CLI/Shelley/Run/Read.hs | 1 + 5 files changed, 209 insertions(+), 4 deletions(-) diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index abc7657c27d..e44109d16c5 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -339,6 +339,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 2d477cc93d0..3f8892e3b1d 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 (..), @@ -138,6 +137,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 f3041fb99f8..550c41834f1 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,14 +8,23 @@ 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) import Data.Aeson (eitherDecode) +import qualified Data.ByteString.Char8 as BSC 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.Encoding as Text +import qualified Data.Text.IO as Text +import qualified Data.Text.Read as Text +import Formatting (build, sformat) +import System.IO (stderr, stdin, stdout) import Cardano.Api import Cardano.Api.Shelley @@ -20,11 +32,17 @@ import Cardano.Api.Shelley import Cardano.CLI.Shelley.Key (VerificationKeyOrHashOrFile, readVerificationKeyOrHashOrFile, readVerificationKeyOrHashOrTextEnvFile) import Cardano.CLI.Shelley.Parsers +import Cardano.CLI.Shelley.Run.Key (SomeSigningKey (..), readSigningKeyFile) +import Cardano.CLI.Shelley.Run.Read (MetadataError, readFileTxMetadata, + renderMetadataError) import Cardano.CLI.Types +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) @@ -39,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 @@ -61,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 +220,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 fca13d54af119fbb1c99ae691eb5f9d9e505bfec 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 b78878b14c6..985b6418772 100644 --- a/cardano-cli/ChangeLog.md +++ b/cardano-cli/ChangeLog.md @@ -5,6 +5,23 @@ - Remove cardano-cli address build-script ([PR 4700](https://github.com/input-output-hk/cardano-node/pull/4700)) - Remove support for reading protocol parameters from Shelley genesis file ([PR 5053](https://github.com/input-output-hk/cardano-node/pull/5053)) +- 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 3fcf7d2ea5e..974fffea6b8 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs @@ -404,6 +404,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 @@ -414,6 +426,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 34651127a8b..b1e4d9ac503 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs @@ -1084,6 +1084,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 @@ -1145,6 +1154,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 550c41834f1..533f9afceba 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 988bc65002269e12a79fee3afb6dff633ad01173 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 e6a6e3da0a019249231744bcba11d32b1e237790 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 11d4564976e..82985119ba9 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -267,6 +267,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 164043789bc..99310432e55 100644 --- a/cardano-cli/test/cardano-cli-golden.hs +++ b/cardano-cli/test/cardano-cli-golden.hs @@ -26,5 +26,6 @@ main = do , 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 f5b37452a786dfb5acabbd4a8f6ba38e9bf2f075 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 3f7ebd35a81..5c32434b68a 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -110,6 +110,10 @@ module Test.Gen.Cardano.Api.Typed , genWitnessNetworkIdOrByronAddress , genRational + + , genGovernancePoll + , genGovernancePollAnswer + , genGovernancePollWitness ) where import Cardano.Api hiding (txIns) @@ -117,6 +121,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 (..), @@ -124,20 +129,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 @@ -149,6 +158,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) @@ -980,3 +990,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 3118844325b..7182f733dfe 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 Hedgehog (Property, forAll, tripping) import qualified Hedgehog as H @@ -174,6 +175,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 -- ----------------------------------------------------------------------------- @@ -208,4 +220,7 @@ tests = testGroup "Test.Cardano.Api.Typed.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 tx CBOR" "roundtrip tx CBOR" prop_roundtrip_tx_CBOR + , 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 ] From 472335038fecefa457fc25085290460fb2e64f41 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 e44109d16c5..3576583f27c 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -340,6 +340,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 3f8892e3b1d..5d210f0c671 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 @@ -153,7 +154,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. @@ -223,7 +257,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 ]