diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,13 @@ # Changelog for `cuddle` +## 1.6.0.0 + +* Remove `example` executable +* Make generator omit tags when zapped +* Add `renderCDDL` for pretty printing CDDL with trailing whitespace removal +* Fix CDDL pretty printing: remove spurious blank lines after commented fields, never break generic arguments across lines +* Fix prettyprinter adding an extra space at the start of comments + ## 1.5.0.0 * Fix custom validators not running when reached via type-specific validators diff --git a/bin/Main.hs b/bin/Main.hs --- a/bin/Main.hs +++ b/bin/Main.hs @@ -23,7 +23,7 @@ ) import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..), mapCDDLDropExt) import Codec.CBOR.Cuddle.Parser (ParserStage, pCDDL) -import Codec.CBOR.Cuddle.Pretty (PrettyStage) +import Codec.CBOR.Cuddle.Pretty (PrettyStage, renderCDDL) import Codec.CBOR.FlatTerm (toFlatTerm) import Codec.CBOR.Pretty (prettyHexEnc) import Codec.CBOR.Read (deserialiseFromBytes) @@ -48,13 +48,10 @@ import Prettyprinter ( LayoutOptions (..), PageWidth (..), - Pretty (pretty), defaultLayoutOptions, layoutPretty, - removeTrailingWhitespace, ) import Prettyprinter.Render.Terminal qualified as Ansi -import Prettyprinter.Render.Text qualified as PT import System.Exit (exitFailure, exitSuccess) import System.IO (hPutStrLn, stderr) import System.Random (newStdGen) @@ -348,9 +345,7 @@ | sort fOpts = fromRules $ sortCDDL res | otherwise = res layoutOptions = defaultLayoutOptions {layoutPageWidth = AvailablePerLine 80 1} - formattedText = - PT.renderStrict . removeTrailingWhitespace . layoutPretty layoutOptions . pretty $ - mapIndex @_ @_ @PrettyStage defs + formattedText = renderCDDL layoutOptions $ mapIndex @_ @_ @PrettyStage defs T.putStr formattedText Validate vOpts cddlFile -> do res <- tryParseFromFile cddlFile diff --git a/cddl/basic_assign.cddl b/cddl/basic_assign.cddl new file mode 100644 --- /dev/null +++ b/cddl/basic_assign.cddl @@ -0,0 +1,47 @@ +coin = uint +epoch = uint + +header = + [ header_body + , body_signature : $kes_signature + , test : coin / null + , withComment : null ; This is a comment + , true + ] + +header_body = [ + issuer : text +] + +$kes_signature = bytes .size 32 +unit_interval = [0 .. denominator, denominator] + +unit_int = unit_interval<4294967295> + +mysize = 16 + +sz1 = bytes .size 1 +sz2 = bytes .size 2 +sz32 = bytes .size 32 +sz16 = bytes .size mysize + +usz4 = uint .size 4 +usz8 = uint .size 8 + +group = (usz4, usz8 / mysize, header_body, { * uint => coin }) + +set = [ * a] +set2 = set + +coin_bag = set2 + +big_group = ( + "hello", + 32, + 8* 4, + & group, + uint, + unit_interval<3>, + 5 ...10, + h'11aaff3351bc' +) diff --git a/cddl/byron.cddl b/cddl/byron.cddl new file mode 100644 --- /dev/null +++ b/cddl/byron.cddl @@ -0,0 +1,209 @@ +; Cardano Byron blockchain CBOR schema + +block = [0, ebblock] + / [1, mainblock] + +mainblock = [ "header" : blockhead + , "body" : blockbody + , "extra" : [attributes] + ] + +ebblock = [ "header" : ebbhead + , "body" : [+ stakeholderid] + , extra : [attributes] + ] + +u8 = uint .lt 256 +u16 = uint .lt 65536 +u32 = uint +u64 = uint + +; Basic Cardano Types + +blake2b-256 = bytes .size 32 + +txid = blake2b-256 +blockid = blake2b-256 +updid = blake2b-256 +hash = blake2b-256 + +blake2b-224 = bytes .size 28 + +addressid = blake2b-224 +stakeholderid = blake2b-224 + +epochid = u64 +slotid = [ epoch: epochid, slot : u64 ] + +pubkey = bytes +signature = bytes + +; Attributes - at the moment we do not bother deserialising these, since they +; don't contain anything + +attributes = {* any => any} + +; Addresses + +addrdistr = [1] / [0, stakeholderid] + +addrtype = &("PubKey" : 0, "Script" : 1, "Redeem" : 2) / (u64 .gt 2) +addrattr = { ? 0 : addrdistr + , ? 1 : bytes} +address = [ #6.24(bytes .cbor ([addressid, addrattr, addrtype])), u64 ] + +; Transactions + +txin = [0, #6.24(bytes .cbor ([txid, u32]))] / [u8 .ne 0, encoded-cbor] +txout = [address, u64] + +tx = [[+ txin], [+ txout], attributes] + +txproof = [u32, hash, hash] + +twit = [0, #6.24(bytes .cbor ([pubkey, signature]))] + / [1, #6.24(bytes .cbor ([[u16, bytes], [u16, bytes]]))] + / [2, #6.24(bytes .cbor ([pubkey, signature]))] + / [u8 .gt 2, encoded-cbor] + +; Shared Seed Computation + +vsspubkey = bytes ; This is encoded using the 'Binary' instance + ; for Scrape.PublicKey +vsssec = bytes ; This is encoded using the 'Binary' instance + ; for Scrape.Secret. +vssenc = [bytes] ; This is encoded using the 'Binary' instance + ; for Scrape.EncryptedSi. + ; TODO work out why this seems to be in a length 1 array +vssdec = bytes ; This is encoded using the 'Binary' instance + ; for Scrape.DecryptedShare +vssproof = [bytes, bytes, bytes, [* bytes]] ; This is encoded using the + ; 'Binary' instance for Scrape.Proof + +ssccomm = [pubkey, [{vsspubkey => vssenc},vssproof], signature] +ssccomms = #6.258([* ssccomm]) + +sscopens = {stakeholderid => vsssec} + +sscshares = {addressid => [addressid, [* vssdec]]} + +ssccert = [vsspubkey, pubkey, epochid, signature] +ssccerts = #6.258([* ssccert]) + +ssc = [0, ssccomms, ssccerts] + / [1, sscopens, ssccerts] + / [2, sscshares, ssccerts] + / [3, ssccerts] + +sscproof = [0, hash, hash] + / [1, hash, hash] + / [2, hash, hash] + / [3, hash] + +; Delegation + +dlg = [ epoch : epochid + , issuer : pubkey + , delegate : pubkey + , certificate : signature + ] + +dlgsig = [dlg, signature] + +lwdlg = [ epochRange : [epochid, epochid] + , issuer : pubkey + , delegate : pubkey + , certificate : signature + ] + +lwdlgsig = [lwdlg, signature] + +; Updates + +bver = [u16, u16, u8] + +txfeepol = [0, #6.24(bytes .cbor ([bigint, bigint]))] + / [u8 .gt 0, encoded-cbor] + +bvermod = [ scriptVersion : [? u16] + , slotDuration : [? bigint] + , maxBlockSize : [? bigint] + , maxHeaderSize : [? bigint] + , maxTxSize : [? bigint] + , maxProposalSize : [? bigint] + , mpcThd : [? u64] + , heavyDelThd : [? u64] + , updateVoteThd : [? u64] + , updateProposalThd : [? u64] + , updateImplicit : [? u64] + , softForkRule : [? [u64, u64, u64]] + , txFeePolicy : [? txfeepol] + , unlockStakeEpoch : [? epochid] + ] + +updata = [ hash, hash, hash, hash ] + +upprop = [ "blockVersion" : bver + , "blockVersionMod" : bvermod + , "softwareVersion" : [ text, u32 ] + , "data" : #6.258([text, updata]) + , "attributes" : attributes + , "from" : pubkey + , "signature" : signature + ] + +upvote = [ "voter" : pubkey + , "proposalId" : updid + , "vote" : bool + , "signature" : signature + ] + +up = [ "proposal" : [? upprop] + , votes : [* upvote] + ] + +; Blocks + +difficulty = [u64] + +blocksig = [0, signature] + / [1, lwdlgsig] + / [2, dlgsig] + +blockcons = [slotid, pubkey, difficulty, blocksig] + +blockheadex = [ "blockVersion" : bver + , "softwareVersion" : [ text, u32 ] + , "attributes" : attributes + , "extraProof" : hash + ] + +blockproof = [ "txProof" : txproof + , "sscProof" : sscproof + , "dlgProof" : hash + , "updProof" : hash + ] + +blockhead = [ "protocolMagic" : u32 + , "prevBlock" : blockid + , "bodyProof" : blockproof + , "consensusData" : blockcons + , "extraData" : blockheadex + ] + +blockbody = [ "txPayload" : [* [tx, [* twit]]] + , "sscPayload" : ssc + , "dlgPayload" : [* dlg] + , "updPayload" : up + ] + +; Epoch Boundary Blocks + +ebbcons = [ epochid, difficulty ] + +ebbhead = [ "protocolMagic" : u32 + , "prevBlock" : blockid + , "bodyProof" : hash + , "consensusData" : ebbcons + , "extraData" : [attributes] + ] diff --git a/cddl/conway.cddl b/cddl/conway.cddl new file mode 100644 --- /dev/null +++ b/cddl/conway.cddl @@ -0,0 +1,683 @@ +; crypto.cddl +$hash28 /= bytes .size 28 +$hash32 /= bytes .size 32 + +$vkey /= bytes .size 32 + +$vrf_vkey /= bytes .size 32 +$vrf_cert /= [bytes, bytes .size 80] + +$kes_vkey /= bytes .size 32 +$kes_signature /= bytes .size 448 +signkeyKES = bytes .size 64 + +$signature /= bytes .size 64 + +; extra.cddl +; Conway era introduces an optional 258 tag for sets, which will become mandatory in the +; second era after Conway. We recommend all the tooling to account for this future breaking +; change sooner rather than later, in order to provide a smooth transition for their users. + +; This is an unordered set. Duplicate elements are not allowed and the order of elements is implementation specific. +set = #6.258([* a]) / [* a] + +; Just like `set`, but must contain at least one element. +nonempty_set = #6.258([+ a]) / [+ a] + +; This is a non-empty ordered set. Duplicate elements are not allowed and the order of elements will be preserved. +nonempty_oset = #6.258([+ a]) / [+ a] + +positive_int = 1 .. 18446744073709551615 + +unit_interval = #6.30([1, 2]) + ; unit_interval = #6.30([uint, uint]) + ; + ; Comment above depicts the actual definition for `unit_interval`. + ; + ; Unit interval is a number in the range between 0 and 1, which + ; means there are two extra constraints: + ; * numerator <= denominator + ; * denominator > 0 + ; + ; Relation between numerator and denominator cannot be expressed in CDDL, which + ; poses a problem for testing. We need to be able to generate random valid data + ; for testing implementation of our encoders/decoders. Which means we cannot use + ; the actual definition here and we hard code the value to 1/2 + + +nonnegative_interval = #6.30([uint, positive_int]) + + +address = + h'001000000000000000000000000000000000000000000000000000000011000000000000000000000000000000000000000000000000000000' / + h'102000000000000000000000000000000000000000000000000000000022000000000000000000000000000000000000000000000000000000' / + h'203000000000000000000000000000000000000000000000000000000033000000000000000000000000000000000000000000000000000000' / + h'304000000000000000000000000000000000000000000000000000000044000000000000000000000000000000000000000000000000000000' / + h'405000000000000000000000000000000000000000000000000000000087680203' / + h'506000000000000000000000000000000000000000000000000000000087680203' / + h'6070000000000000000000000000000000000000000000000000000000' / + h'7080000000000000000000000000000000000000000000000000000000' + +reward_account = + h'E090000000000000000000000000000000000000000000000000000000' / + h'F0A0000000000000000000000000000000000000000000000000000000' + +bounded_bytes = bytes .size (0..64) + ; the real bounded_bytes does not have this limit. it instead has a different + ; limit which cannot be expressed in CDDL. + ; The limit is as follows: + ; - bytes with a definite-length encoding are limited to size 0..64 + ; - for bytes with an indefinite-length CBOR encoding, each chunk is + ; limited to size 0..64 + ; ( reminder: in CBOR, the indefinite-length encoding of bytestrings + ; consists of a token #2.31 followed by a sequence of definite-length + ; encoded bytestrings and a stop code ) + +; a type for distinct values. +; The type parameter must support .size, for example: bytes or uint +distinct = a .size 8 / a .size 16 / a .size 20 / a .size 24 / a .size 30 / a .size 32 + +; conway.cddl +block = + [ header + , transaction_bodies : [* transaction_body] + , transaction_witness_sets : [* transaction_witness_set] + , auxiliary_data_set : {* transaction_index => auxiliary_data } + , invalid_transactions : [* transaction_index ] + ]; Valid blocks must also satisfy the following two constraints: + ; 1) the length of transaction_bodies and transaction_witness_sets + ; must be the same + ; 2) every transaction_index must be strictly smaller than the + ; length of transaction_bodies + +transaction = + [ transaction_body + , transaction_witness_set + , bool + , auxiliary_data / null + ] + +transaction_index = uint .size 2 + +header = + [ header_body + , body_signature : $kes_signature + ] + +header_body = + [ block_number : uint + , slot : uint + , prev_hash : $hash32 / null + , issuer_vkey : $vkey + , vrf_vkey : $vrf_vkey + , vrf_result : $vrf_cert ; replaces nonce_vrf and leader_vrf + , block_body_size : uint + , block_body_hash : $hash32 ; merkle triple root + , operational_cert + , [ protocol_version ] + ] + +operational_cert = + [ hot_vkey : $kes_vkey + , sequence_number : uint + , kes_period : uint + , sigma : $signature + ] + +next_major_protocol_version = 10 + +major_protocol_version = 1..next_major_protocol_version + +protocol_version = (major_protocol_version, uint) + +transaction_body = + { 0 : set ; inputs + , 1 : [* transaction_output] + , 2 : coin ; fee + , ? 3 : uint ; time to live + , ? 4 : certificates + , ? 5 : withdrawals + , ? 7 : auxiliary_data_hash + , ? 8 : uint ; validity interval start + , ? 9 : mint + , ? 11 : script_data_hash + , ? 13 : nonempty_set ; collateral inputs + , ? 14 : required_signers + , ? 15 : network_id + , ? 16 : transaction_output ; collateral return + , ? 17 : coin ; total collateral + , ? 18 : nonempty_set ; reference inputs + , ? 19 : voting_procedures ; New; Voting procedures + , ? 20 : proposal_procedures ; New; Proposal procedures + , ? 21 : coin ; New; current treasury value + , ? 22 : positive_coin ; New; donation + } + +voting_procedures = { + voter => { + gov_action_id => voting_procedure } } + +voting_procedure = + [ vote + , anchor / null + ] + +proposal_procedure = + [ deposit : coin + , reward_account + , gov_action + , anchor + ] + +proposal_procedures = nonempty_set + +certificates = nonempty_set + +gov_action = + [ parameter_change_action + // hard_fork_initiation_action + // treasury_withdrawals_action + // no_confidence + // update_committee + // new_constitution + // info_action + ] + +policy_hash = scripthash + +parameter_change_action = (0, gov_action_id / null, protocol_param_update, policy_hash / null) + +hard_fork_initiation_action = (1, gov_action_id / null, [protocol_version]) + +treasury_withdrawals_action = (2, { reward_account => coin }, policy_hash / null) + +no_confidence = (3, gov_action_id / null) + +update_committee = (4, gov_action_id / null, set, { committee_cold_credential => epoch }, unit_interval) + +new_constitution = (5, gov_action_id / null, constitution) + +constitution = + [ anchor + , scripthash / null + ] + +info_action = 6 + +; Constitutional Committee Hot KeyHash: 0 +; Constitutional Committee Hot ScriptHash: 1 +; DRep KeyHash: 2 +; DRep ScriptHash: 3 +; StakingPool KeyHash: 4 +voter = + [ 0, addr_keyhash + // 1, scripthash + // 2, addr_keyhash + // 3, scripthash + // 4, addr_keyhash + ] + +anchor = + [ anchor_url : url + , anchor_data_hash : $hash32 + ] + +; no - 0 +; yes - 1 +; abstain - 2 +vote = 0 .. 2 + +gov_action_id = + [ transaction_id : $hash32 + , gov_action_index : uint + ] + +required_signers = nonempty_set + +transaction_input = [ transaction_id : $hash32 + , index : uint + ] + +transaction_output = legacy_transaction_output / post_alonzo_transaction_output + +legacy_transaction_output = + [ address + , amount : value + , ? datum_hash : $hash32 + ] + +post_alonzo_transaction_output = + { 0 : address + , 1 : value + , ? 2 : datum_option ; datum option + , ? 3 : script_ref ; script reference + } + +script_data_hash = $hash32 +; This is a hash of data which may affect evaluation of a script. +; This data consists of: +; - The redeemers from the transaction_witness_set (the value of field 5). +; - The datums from the transaction_witness_set (the value of field 4). +; - The value in the costmdls map corresponding to the script's language +; (in field 18 of protocol_param_update.) +; (In the future it may contain additional protocol parameters.) +; +; Since this data does not exist in contiguous form inside a transaction, it needs +; to be independently constructed by each recipient. +; +; The bytestring which is hashed is the concatenation of three things: +; redeemers || datums || language views +; The redeemers are exactly the data present in the transaction witness set. +; Similarly for the datums, if present. If no datums are provided, the middle +; field is omitted (i.e. it is the empty/null bytestring). +; +; language views CDDL: +; { * language => script_integrity_data } +; +; This must be encoded canonically, using the same scheme as in +; RFC7049 section 3.9: +; - Maps, strings, and bytestrings must use a definite-length encoding +; - Integers must be as small as possible. +; - The expressions for map length, string length, and bytestring length +; must be as short as possible. +; - The keys in the map must be sorted as follows: +; - If two keys have different lengths, the shorter one sorts earlier. +; - If two keys have the same length, the one with the lower value +; in (byte-wise) lexical order sorts earlier. +; +; For PlutusV1 (language id 0), the language view is the following: +; - the value of costmdls map at key 0 (in other words, the script_integrity_data) +; is encoded as an indefinite length list and the result is encoded as a bytestring. +; (our apologies) +; For example, the script_integrity_data corresponding to the all zero costmodel for V1 +; would be encoded as (in hex): +; 58a89f00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000ff +; - the language ID tag is also encoded twice. first as a uint then as +; a bytestring. (our apologies) +; Concretely, this means that the language version for V1 is encoded as +; 4100 in hex. +; For PlutusV2 (language id 1), the language view is the following: +; - the value of costmdls map at key 1 is encoded as an definite length list. +; For example, the script_integrity_data corresponding to the all zero costmodel for V2 +; would be encoded as (in hex): +; 98af0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 +; - the language ID tag is encoded as expected. +; Concretely, this means that the language version for V2 is encoded as +; 01 in hex. +; For PlutusV3 (language id 2), the language view is the following: +; - the value of costmdls map at key 2 is encoded as a definite length list. +; +; Note that each Plutus language represented inside a transaction must have +; a cost model in the costmdls protocol parameter in order to execute, +; regardless of what the script integrity data is. +; +; Finally, note that in the case that a transaction includes datums but does not +; include the redeemers field, the script data format becomes (in hex): +; [ 80 | datums | A0 ] +; corresponding to a CBOR empty list and an empty map. +; Note that a transaction might include the redeemers field and it to the +; empty map, in which case the user supplied encoding of the empty map is used. + +; address = bytes +; reward_account = bytes + +; address format: +; [ 8 bit header | payload ]; +; +; shelley payment addresses: +; bit 7: 0 +; bit 6: base/other +; bit 5: pointer/enterprise [for base: stake cred is keyhash/scripthash] +; bit 4: payment cred is keyhash/scripthash +; bits 3-0: network id +; +; reward addresses: +; bits 7-5: 111 +; bit 4: credential is keyhash/scripthash +; bits 3-0: network id +; +; byron addresses: +; bits 7-4: 1000 + +; 0000: base address: keyhash28,keyhash28 +; 0001: base address: scripthash28,keyhash28 +; 0010: base address: keyhash28,scripthash28 +; 0011: base address: scripthash28,scripthash28 +; 0100: pointer address: keyhash28, 3 variable length uint +; 0101: pointer address: scripthash28, 3 variable length uint +; 0110: enterprise address: keyhash28 +; 0111: enterprise address: scripthash28 +; 1000: byron address +; 1110: reward account: keyhash28 +; 1111: reward account: scripthash28 +; 1001 - 1101: future formats + +certificate = + [ stake_registration + // stake_deregistration + // stake_delegation + // pool_registration + // pool_retirement + // reg_cert + // unreg_cert + // vote_deleg_cert + // stake_vote_deleg_cert + // stake_reg_deleg_cert + // vote_reg_deleg_cert + // stake_vote_reg_deleg_cert + // auth_committee_hot_cert + // resign_committee_cold_cert + // reg_drep_cert + // unreg_drep_cert + // update_drep_cert + ] + +stake_registration = (0, stake_credential) ; to be deprecated in era after Conway +stake_deregistration = (1, stake_credential) ; to be deprecated in era after Conway +stake_delegation = (2, stake_credential, pool_keyhash) + +; POOL +pool_registration = (3, pool_params) +pool_retirement = (4, pool_keyhash, epoch) + +; numbers 5 and 6 used to be the Genesis and MIR certificates respectively, +; which were deprecated in Conway + +; DELEG +reg_cert = (7, stake_credential, coin) +unreg_cert = (8, stake_credential, coin) +vote_deleg_cert = (9, stake_credential, drep) +stake_vote_deleg_cert = (10, stake_credential, pool_keyhash, drep) +stake_reg_deleg_cert = (11, stake_credential, pool_keyhash, coin) +vote_reg_deleg_cert = (12, stake_credential, drep, coin) +stake_vote_reg_deleg_cert = (13, stake_credential, pool_keyhash, drep, coin) + +; GOVCERT +auth_committee_hot_cert = (14, committee_cold_credential, committee_hot_credential) +resign_committee_cold_cert = (15, committee_cold_credential, anchor / null) +reg_drep_cert = (16, drep_credential, coin, anchor / null) +unreg_drep_cert = (17, drep_credential, coin) +update_drep_cert = (18, drep_credential, anchor / null) + + +delta_coin = int + +credential = + [ 0, addr_keyhash + // 1, scripthash + ] + +drep = + [ 0, addr_keyhash + // 1, scripthash + // 2 ; always abstain + // 3 ; always no confidence + ] + +stake_credential = credential +drep_credential = credential +committee_cold_credential = credential +committee_hot_credential = credential + +pool_params = ( operator: pool_keyhash + , vrf_keyhash: vrf_keyhash + , pledge: coin + , cost: coin + , margin: unit_interval + , reward_account: reward_account + , pool_owners: set + , relays: [* relay] + , pool_metadata: pool_metadata / null + ) + +port = uint .le 65535 +ipv4 = bytes .size 4 +ipv6 = bytes .size 16 +dns_name = tstr .size (0..128) + +single_host_addr = ( 0 + , port / null + , ipv4 / null + , ipv6 / null + ) +single_host_name = ( 1 + , port / null + , dns_name ; An A or AAAA DNS record + ) +multi_host_name = ( 2 + , dns_name ; A SRV DNS record + ) +relay = + [ single_host_addr + // single_host_name + // multi_host_name + ] + +pool_metadata = [url, pool_metadata_hash] +url = tstr .size (0..128) + +withdrawals = { + reward_account => coin } + +protocol_param_update = + { ? 0: coin ; minfee A + , ? 1: coin ; minfee B + , ? 2: uint ; max block body size + , ? 3: uint ; max transaction size + , ? 4: uint ; max block header size + , ? 5: coin ; key deposit + , ? 6: coin ; pool deposit + , ? 7: epoch ; maximum epoch + , ? 8: uint ; n_opt: desired number of stake pools + , ? 9: nonnegative_interval ; pool pledge influence + , ? 10: unit_interval ; expansion rate + , ? 11: unit_interval ; treasury growth rate + , ? 16: coin ; min pool cost + , ? 17: coin ; ada per utxo byte + , ? 18: costmdls ; cost models for script languages + , ? 19: ex_unit_prices ; execution costs + , ? 20: ex_units ; max tx ex units + , ? 21: ex_units ; max block ex units + , ? 22: uint ; max value size + , ? 23: uint ; collateral percentage + , ? 24: uint ; max collateral inputs + , ? 25: pool_voting_thresholds ; pool voting thresholds + , ? 26: drep_voting_thresholds ; DRep voting thresholds + , ? 27: uint ; min committee size + , ? 28: epoch ; committee term limit + , ? 29: epoch ; governance action validity period + , ? 30: coin ; governance action deposit + , ? 31: coin ; DRep deposit + , ? 32: epoch ; DRep inactivity period + } + +pool_voting_thresholds = + [ unit_interval ; motion no confidence + , unit_interval ; committee normal + , unit_interval ; committee no confidence + , unit_interval ; hard fork initiation + , unit_interval ; security relevant parameter voting threshold + ] + +drep_voting_thresholds = + [ unit_interval ; motion no confidence + , unit_interval ; committee normal + , unit_interval ; committee no confidence + , unit_interval ; update constitution + , unit_interval ; hard fork initiation + , unit_interval ; PP network group + , unit_interval ; PP economic group + , unit_interval ; PP technical group + , unit_interval ; PP governance group + , unit_interval ; treasury withdrawal + ] + +transaction_witness_set = + { ? 0: nonempty_set + , ? 1: nonempty_set + , ? 2: nonempty_set + , ? 3: nonempty_set + , ? 4: nonempty_set + , ? 5: redeemers + , ? 6: nonempty_set + , ? 7: nonempty_set + } + +; The real type of plutus_v1_script, plutus_v2_script and plutus_v3_script is bytes. +; However, because we enforce uniqueness when many scripts are supplied, +; we need to hack around for tests in order to avoid generating duplicates, +; since the cddl tool we use for roundtrip testing doesn't generate distinct collections. +plutus_v1_script = distinct +plutus_v2_script = distinct +plutus_v3_script = distinct + +plutus_data = + constr + / { * plutus_data => plutus_data } + / [ * plutus_data ] + / big_int + / bounded_bytes + +big_int = int / big_uint / big_nint +big_uint = #6.2(bounded_bytes) +big_nint = #6.3(bounded_bytes) + +constr = + #6.121([* a]) + / #6.122([* a]) + / #6.123([* a]) + / #6.124([* a]) + / #6.125([* a]) + / #6.126([* a]) + / #6.127([* a]) ; similarly for tag range: 6.1280 .. 6.1400 inclusive + / #6.102([uint, [* a]]) + +redeemers = + [ + [ tag: redeemer_tag, index: uint, data: plutus_data, ex_units: ex_units ] ] +; TODO: Add alternative implementation that reflects the reality more accuratly: +; / { + [ tag: redeemer_tag, index: uint ] => [ data: plutus_data, ex_units: ex_units ] } + +redeemer_tag = + 0 ; Spending + / 1 ; Minting + / 2 ; Certifying + / 3 ; Rewarding + / 4 ; Voting + / 5 ; Proposing + +ex_units = [mem: uint, steps: uint] + +ex_unit_prices = + [ mem_price: nonnegative_interval, step_price: nonnegative_interval ] + +language = 0 ; Plutus v1 + / 1 ; Plutus v2 + / 2 ; Plutus v3 + +potential_languages = 0 .. 255 + +; The format for costmdls is flexible enough to allow adding Plutus built-ins and language +; versions in the future. +; +costmdls = + { ? 0 : [ 166* int ] ; Plutus v1, only 166 integers are used, but more are accepted (and ignored) + , ? 1 : [ 175* int ] ; Plutus v2, only 175 integers are used, but more are accepted (and ignored) + , ? 2 : [ 223* int ] ; Plutus v3, only 223 integers are used, but more are accepted (and ignored) + , ? 3 : [ int ] ; Any 8-bit unsigned number can be used as a key. + } + +transaction_metadatum = + { * transaction_metadatum => transaction_metadatum } + / [ * transaction_metadatum ] + / int + / bytes .size (0..64) + / text .size (0..64) + +transaction_metadatum_label = uint +metadata = { * transaction_metadatum_label => transaction_metadatum } + +auxiliary_data = + metadata ; Shelley + / [ transaction_metadata: metadata ; Shelley-ma + , auxiliary_scripts: [ * native_script ] + ] + / #6.259({ ? 0 => metadata ; Alonzo and beyond + , ? 1 => [ * native_script ] + , ? 2 => [ * plutus_v1_script ] + , ? 3 => [ * plutus_v2_script ] + , ? 4 => [ * plutus_v3_script ] + }) + +vkeywitness = [ $vkey, $signature ] + +bootstrap_witness = + [ public_key : $vkey + , signature : $signature + , chain_code : bytes .size 32 + , attributes : bytes + ] + +native_script = + [ script_pubkey + // script_all + // script_any + // script_n_of_k + // invalid_before + ; Timelock validity intervals are half-open intervals [a, b). + ; This field specifies the left (included) endpoint a. + // invalid_hereafter + ; Timelock validity intervals are half-open intervals [a, b). + ; This field specifies the right (excluded) endpoint b. + ] + +script_pubkey = (0, addr_keyhash) +script_all = (1, [ * native_script ]) +script_any = (2, [ * native_script ]) +script_n_of_k = (3, n: uint, [ * native_script ]) +invalid_before = (4, uint) +invalid_hereafter = (5, uint) + +coin = uint + +multiasset = { + policy_id => { + asset_name => a } } +policy_id = scripthash +asset_name = bytes .size (0..32) + +negInt64 = -9223372036854775808 .. -1 +posInt64 = 1 .. 9223372036854775807 +nonZeroInt64 = negInt64 / posInt64 ; this is the same as the current int64 definition but without zero + +positive_coin = 1 .. 18446744073709551615 + +value = coin / [coin, multiasset] + +mint = multiasset + +int64 = -9223372036854775808 .. 9223372036854775807 + +network_id = 0 / 1 + +epoch = uint + +addr_keyhash = $hash28 +pool_keyhash = $hash28 + +vrf_keyhash = $hash32 +auxiliary_data_hash = $hash32 +pool_metadata_hash = $hash32 + +; To compute a script hash, note that you must prepend +; a tag to the bytes of the script before hashing. +; The tag is determined by the language. +; The tags in the Conway era are: +; "\x00" for multisig scripts +; "\x01" for Plutus V1 scripts +; "\x02" for Plutus V2 scripts +; "\x03" for Plutus V3 scripts +scripthash = $hash28 + +datum_hash = $hash32 +data = #6.24(bytes .cbor plutus_data) + +datum_option = [ 0, $hash32 // 1, data ] + +script_ref = #6.24(bytes .cbor script) + +script = [ 0, native_script // 1, plutus_v1_script // 2, plutus_v2_script // 3, plutus_v3_script ] diff --git a/cddl/costmdls_min.cddl b/cddl/costmdls_min.cddl new file mode 100644 --- /dev/null +++ b/cddl/costmdls_min.cddl @@ -0,0 +1,3 @@ +costmdls = + { 0 : [ 11* int ] ; Plutus v1, only 166 integers are used, but more are accepted (and ignored) + } diff --git a/cddl/issue80-min.cddl b/cddl/issue80-min.cddl new file mode 100644 --- /dev/null +++ b/cddl/issue80-min.cddl @@ -0,0 +1,8 @@ +main = test +set = [x] +test = [ + 1, + x, + set +] + diff --git a/cddl/pretty.cddl b/cddl/pretty.cddl new file mode 100644 --- /dev/null +++ b/cddl/pretty.cddl @@ -0,0 +1,13 @@ +set = [* a] + +a = [ 2*30 2 : uint + , ? 33 : bytes + , 4444 : set + , * 55 => uint + ] + +b = [1,uint,(3,4)] + +c = { 1: a +, 2: b ; hello +} diff --git a/cddl/shelley.cddl b/cddl/shelley.cddl new file mode 100644 --- /dev/null +++ b/cddl/shelley.cddl @@ -0,0 +1,288 @@ +; Shelley Types + +block = + [ header + , transaction_bodies : [* transaction_body] + , transaction_witness_sets : [* transaction_witness_set] + , transaction_metadata_set : + { * transaction_index => transaction_metadata } + ]; Valid blocks must also satisfy the following two constraints: + ; 1) the length of transaction_bodies and transaction_witness_sets + ; must be the same + ; 2) every transaction_index must be strictly smaller than the + ; length of transaction_bodies + +transaction = + [ transaction_body + , transaction_witness_set + , transaction_metadata / null + ] + +transaction_index = uint .size 2 + +header = + [ header_body + , body_signature : $kes_signature + ] + +header_body = + [ block_number : uint + , slot : uint + , prev_hash : $hash32 / null + , issuer_vkey : $vkey + , vrf_vkey : $vrf_vkey + , nonce_vrf : $vrf_cert + , leader_vrf : $vrf_cert + , block_body_size : uint + , block_body_hash : $hash32 ; merkle triple root + , operational_cert + , protocol_version + ] + +operational_cert = + ( hot_vkey : $kes_vkey + , sequence_number : uint + , kes_period : uint + , sigma : $signature + ) + +next_major_protocol_version = 3 + +major_protocol_version = 1..next_major_protocol_version + +protocol_version = (major_protocol_version, uint) + +transaction_body = + { 0 : set + , 1 : [* transaction_output] + , 2 : coin ; fee + , 3 : uint ; ttl + , ? 4 : [* certificate] + , ? 5 : withdrawals + , ? 6 : update + , ? 7 : metadata_hash + } + +transaction_input = [ transaction_id : $hash32 + , index : uint + ] + +transaction_output = [address, amount : coin] + +; address = bytes +; reward_account = bytes + +; address format: +; [ 8 bit header | payload ]; +; +; shelley payment addresses: +; bit 7: 0 +; bit 6: base/other +; bit 5: pointer/enterprise [for base: stake cred is keyhash/scripthash] +; bit 4: payment cred is keyhash/scripthash +; bits 3-0: network id +; +; reward addresses: +; bits 7-5: 111 +; bit 4: credential is keyhash/scripthash +; bits 3-0: network id +; +; byron addresses: +; bits 7-4: 1000 + +; 0000: base address: keyhash28,keyhash28 +; 0001: base address: scripthash28,keyhash28 +; 0010: base address: keyhash28,scripthash28 +; 0011: base address: scripthash28,scripthash28 +; 0100: pointer address: keyhash28, 3 variable length uint +; 0101: pointer address: scripthash28, 3 variable length uint +; 0110: enterprise address: keyhash28 +; 0111: enterprise address: scripthash28 +; 1000: byron address +; 1110: reward account: keyhash28 +; 1111: reward account: scripthash28 +; 1001 - 1101: future formats + +certificate = + [ stake_registration + // stake_deregistration + // stake_delegation + // pool_registration + // pool_retirement + // genesis_key_delegation + // move_instantaneous_rewards_cert + ] + +stake_registration = (0, stake_credential) +stake_deregistration = (1, stake_credential) +stake_delegation = (2, stake_credential, pool_keyhash) +pool_registration = (3, pool_params) +pool_retirement = (4, pool_keyhash, epoch) +genesis_key_delegation = (5, genesishash, genesis_delegate_hash, vrf_keyhash) +move_instantaneous_rewards_cert = (6, move_instantaneous_reward) + +move_instantaneous_reward = [ 0 / 1, { * stake_credential => coin } ] +; The first field determines where the funds are drawn from. +; 0 denotes the reserves, 1 denotes the treasury. + +stake_credential = + [ 0, addr_keyhash + // 1, scripthash + ] + +pool_params = ( operator: pool_keyhash + , vrf_keyhash: vrf_keyhash + , pledge: coin + , cost: coin + , margin: unit_interval + , reward_account: reward_account + , pool_owners: set + , relays: [* relay] + , pool_metadata: pool_metadata / null + ) + +port = uint .le 65535 +ipv4 = bytes .size 4 +ipv6 = bytes .size 16 +dns_name = tstr .size (0..64) + +single_host_addr = ( 0 + , port / null + , ipv4 / null + , ipv6 / null + ) +single_host_name = ( 1 + , port / null + , dns_name ; An A or AAAA DNS record + ) +multi_host_name = ( 2 + , dns_name ; A SRV DNS record + ) +relay = + [ single_host_addr + // single_host_name + // multi_host_name + ] + +pool_metadata = [url, metadata_hash] +url = tstr .size (0..64) + +withdrawals = { * reward_account => coin } + +update = [ proposed_protocol_parameter_updates + , epoch + ] + +proposed_protocol_parameter_updates = + { * genesishash => protocol_param_update } + +protocol_param_update = + { ? 0: uint ; minfee A + , ? 1: uint ; minfee B + , ? 2: uint ; max block body size + , ? 3: uint ; max transaction size + , ? 4: uint ; max block header size + , ? 5: coin ; key deposit + , ? 6: coin ; pool deposit + , ? 7: epoch ; maximum epoch + , ? 8: uint ; n_opt: desired number of stake pools + , ? 9: rational ; pool pledge influence + , ? 10: unit_interval ; expansion rate + , ? 11: unit_interval ; treasury growth rate + , ? 12: unit_interval ; d. decentralization constant + , ? 13: $nonce ; extra entropy + , ? 14: [protocol_version] ; protocol version + , ? 15: coin ; min utxo value + } + +transaction_witness_set = + { ?0 => [* vkeywitness ] + , ?1 => [* multisig_script ] + , ?2 => [* bootstrap_witness ] + ; In the future, new kinds of witnesses can be added like this: + ; , ?3 => [* monetary_policy_script ] + ; , ?4 => [* plutus_script ] + } + +transaction_metadatum = + { * transaction_metadatum => transaction_metadatum } + / [ * transaction_metadatum ] + / int + / bytes .size (0..64) + / text .size (0..64) + +transaction_metadatum_label = uint + +transaction_metadata = + { * transaction_metadatum_label => transaction_metadatum } + +vkeywitness = [ $vkey, $signature ] + +bootstrap_witness = + [ public_key : $vkey + , signature : $signature + , chain_code : bytes .size 32 + , attributes : bytes + ] + +multisig_script = + [ multisig_pubkey + // multisig_all + // multisig_any + // multisig_n_of_k + ] + +multisig_pubkey = (0, addr_keyhash) +multisig_all = (1, [ * multisig_script ]) +multisig_any = (2, [ * multisig_script ]) +multisig_n_of_k = (3, n: uint, [ * multisig_script ]) + +coin = uint +epoch = uint + +addr_keyhash = $hash28 +genesis_delegate_hash = $hash28 +pool_keyhash = $hash28 +genesishash = $hash28 + +vrf_keyhash = $hash32 +metadata_hash = $hash32 + +; To compute a script hash, note that you must prepend +; a tag to the bytes of the script before hashing. +; The tag is determined by the language. +; In the Shelley era there is only one such tag, +; namely "\x00" for multisig scripts. +scripthash = $hash28 + +$nonce /= [ 0 // 1, bytes .size 32 ] + +$hash28 /= bytes .size 28 +$hash32 /= bytes .size 32 + +$vkey /= bytes .size 32 + +$vrf_vkey /= bytes .size 32 +$vrf_cert /= [bytes, bytes .size 80] + +$kes_vkey /= bytes .size 32 +$kes_signature /= bytes .size 448 +signkeyKES = bytes .size 64 + +$signature /= bytes .size 64 + +finite_set = [* a] + +;unit_interval = #6.30([uint, uint]) +unit_interval = #6.30([1, 2]) + ; real unit_interval is: #6.30([uint, uint]) + ; but this produces numbers outside the unit interval + ; and can also produce a zero in the denominator + +rational = #6.30([uint, uint]) + +set = [* a] + +address = bytes + +reward_account = bytes diff --git a/cddl/validator.cddl b/cddl/validator.cddl new file mode 100644 --- /dev/null +++ b/cddl/validator.cddl @@ -0,0 +1,13 @@ +negative = nint + +anyfloat = f16 / f32 / f64 + +f16 = float16 +f32 = float32 +f64 = float64 + +bs = bstr / bytes +txt = tstr / text + +my_bigint = #6.2(bstr) +my_any = any diff --git a/cddl/validator/negative/args-to-postlude.cddl b/cddl/validator/negative/args-to-postlude.cddl new file mode 100644 --- /dev/null +++ b/cddl/validator/negative/args-to-postlude.cddl @@ -0,0 +1,1 @@ +x = uint<3> diff --git a/cddl/validator/negative/too-few-args.cddl b/cddl/validator/negative/too-few-args.cddl new file mode 100644 --- /dev/null +++ b/cddl/validator/negative/too-few-args.cddl @@ -0,0 +1,3 @@ +foo = [a, b] + +x = foo diff --git a/cddl/validator/negative/too-many-args.cddl b/cddl/validator/negative/too-many-args.cddl new file mode 100644 --- /dev/null +++ b/cddl/validator/negative/too-many-args.cddl @@ -0,0 +1,3 @@ +foo = [a] + +x = foo diff --git a/cddl/validator/negative/unknown-name.cddl b/cddl/validator/negative/unknown-name.cddl new file mode 100644 --- /dev/null +++ b/cddl/validator/negative/unknown-name.cddl @@ -0,0 +1,1 @@ +x = a diff --git a/cuddle.cabal b/cuddle.cabal --- a/cuddle.cabal +++ b/cuddle.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: cuddle -version: 1.5.0.0 +version: 1.6.0.0 synopsis: CDDL Generator and test utilities description: Cuddle is a library for generating and manipulating [CDDL](https://datatracker.ietf.org/doc/html/rfc8610). @@ -23,19 +23,15 @@ extra-doc-files: CHANGELOG.md tested-with: ghc ==9.6 || ==9.8 || ==9.10 || ==9.12 data-files: - example/cddl-files/*.cddl - example/cddl-files/validator/negative/*.cddl + cddl/*.cddl + cddl/validator/negative/*.cddl golden/*.txt + golden/pretty/*.txt source-repository head type: git location: https://github.com/input-output-hk/cuddle -flag example - description: Enable the example executable - manual: True - default: False - common warnings ghc-options: -Wall @@ -62,7 +58,7 @@ Codec.CBOR.Cuddle.Pretty.Utils build-depends: - QuickCheck >=2.14.3 && <2.18, + QuickCheck >=2.14.3, antigen ^>=0.4, base >=4.18 && <5, base16-bytestring >=1.0.2, @@ -95,30 +91,6 @@ hs-source-dirs: src default-language: GHC2021 -executable example - import: warnings - - if flag(example) - buildable: True - else - buildable: False - - default-language: GHC2021 - other-modules: - Conway - Monad - - hs-source-dirs: example - main-is: Main.hs - build-depends: - base, - bytestring, - cuddle, - megaparsec, - prettyprinter, - random, - text, - executable cuddle import: warnings default-language: GHC2021 @@ -161,6 +133,7 @@ Test.Codec.CBOR.Cuddle.CDDL.GeneratorSpec Test.Codec.CBOR.Cuddle.CDDL.Parser Test.Codec.CBOR.Cuddle.CDDL.Pretty + Test.Codec.CBOR.Cuddle.CDDL.Pretty.Golden Test.Codec.CBOR.Cuddle.CDDL.Validator Test.Codec.CBOR.Cuddle.CDDL.Validator.Golden Test.Codec.CBOR.Cuddle.Huddle diff --git a/example/Conway.hs b/example/Conway.hs deleted file mode 100644 --- a/example/Conway.hs +++ /dev/null @@ -1,972 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -{- HLINT ignore "Use camelCase" -} -{- HLINT ignore "Evaluate" -} - -module Conway where - -import Codec.CBOR.Cuddle.Huddle -import Data.Function (($)) -import Data.Semigroup ((<>)) -import Data.Text qualified as T -import Data.Word (Word64) -import GHC.Float (Double) -import GHC.Num (Integer) -import GHC.Show (Show (show)) - -default (Integer, Double) - -conway :: Huddle -conway = collectFrom [HIRule block] - -block :: Rule -block = - "block" - =:= arr - [ a header - , "transaction_bodies" ==> arr [0 <+ a transaction_body] - , "transaction_witness_sets" - ==> arr [0 <+ a transaction_witness_set] - , "auxiliary_data_set" - ==> mp [0 <+ asKey transaction_index ==> auxiliary_data] - , "invalid_transactions" ==> arr [0 <+ a transaction_index] - ] - -transaction :: Rule -transaction = - "transaction" - =:= arr - [ a transaction_body - , a transaction_witness_set - , a VBool - , a (auxiliary_data / VNil) - ] - -transaction_index :: Rule -transaction_index = "transaction_index" =:= VUInt `sized` (2 :: Word64) - -header :: Rule -header = "header" =:= arr [a header_body, "body_signature" ==> kes_signature] - -header_body :: Rule -header_body = - "header_body" - =:= arr - [ "block_number" ==> VUInt - , "slot" ==> VUInt - , "prev_hash" ==> hash32 - , "issuer_vkey" ==> vkey - , "vrf_vkey" ==> vkey - , "vrf_result" ==> vrf_cert - , "block_body_size" ==> VUInt - , "block_body_hash" ==> hash32 - , a operational_cert - , a (arr [a protocol_version]) - ] - -operational_cert :: Rule -operational_cert = - "operational_cert" - =:= arr - [ "hot_vkey" ==> kes_vkey - , "sequence_number" ==> VUInt - , "kes_period" ==> VUInt - , "sigma" ==> signature - ] - -protocol_version :: Named Group -protocol_version = "protocol_version" =:~ grp [a major_protocol_version, a VUInt] - -next_major_protocol_version :: Rule -next_major_protocol_version = "next_major_protocol_version" =:= (10 :: Integer) - -major_protocol_version :: Rule -major_protocol_version = "major_protocol_version" =:= (1 :: Integer) - -transaction_body :: Rule -transaction_body = - "transaction_body" - =:= mp - [ idx 0 ==> set transaction_index - , idx 1 ==> arr [0 <+ a transaction_output] - , idx 2 ==> coin - , opt (idx 3 ==> VUInt) - , opt (idx 4 ==> certificates) - , opt (idx 5 ==> withdrawals) - , opt (idx 7 ==> auxiliary_data_hash) - , opt (idx 8 ==> VUInt) - , opt (idx 9 ==> mint) - , opt (idx 11 ==> script_data_hash) - , opt (idx 13 ==> nonempty_set transaction_input) - , opt (idx 14 ==> required_signers) - , opt (idx 15 ==> network_id) - , opt (idx 16 ==> transaction_output) - , opt (idx 17 ==> coin) - , opt (idx 18 ==> nonempty_set transaction_input) - , opt (idx 19 ==> voting_procedures) - , opt (idx 20 ==> proposal_procedures) - , opt (idx 21 ==> coin) - , opt (idx 22 ==> positive_coin) - ] - -voting_procedures :: Rule -voting_procedures = - "voting_procedures" - =:= mp [1 <+ "voter" ==> mp [1 <+ "gov_action_id" ==> voting_procedure]] - -voting_procedure :: Rule -voting_procedure = "voting_procedure" =:= arr [a vote, a (anchor / VNil)] - -proposal_procedure :: Rule -proposal_procedure = - "proposal_procedure" - =:= arr - [ "deposit" ==> coin - , a reward_account - , a gov_action - , a anchor - ] - -proposal_procedures :: Rule -proposal_procedures = "proposal_procedures" =:= nonempty_set proposal_procedure - -certificates :: Rule -certificates = "certificates" =:= nonempty_set certificate - -gov_action :: Rule -gov_action = - "gov_action" - =:= arr - [ a - ( parameter_change_action - / hard_fork_initiation_action - / treasury_withdrawals_action - / no_confidence - / update_committee - / new_constitution - / info_action - ) - ] - -policy_hash :: Rule -policy_hash = "policy_hash" =:= scripthash - -parameter_change_action :: Named Group -parameter_change_action = - "parameter_change_action" - =:~ grp - [ 0 - , a (gov_action_id / VNil) - , a protocol_param_update - , a (policy_hash / VNil) - ] - -hard_fork_initiation_action :: Named Group -hard_fork_initiation_action = - "hard_fork_initiation_action" - =:~ grp [1, a (gov_action_id / VNil), a (arr [a protocol_version])] - -treasury_withdrawals_action :: Named Group -treasury_withdrawals_action = - "treasury_withdrawals_action" - =:~ grp [2, a (arr [asKey reward_account ==> coin / VInt]), a (policy_hash / VNil)] - -no_confidence :: Named Group -no_confidence = "no_confidence" =:~ grp [3, a (gov_action_id / VNil)] - -update_committee :: Named Group -update_committee = - "update_committee" - =:~ grp - [ 4 - , a (gov_action_id / VNil) - , a (set committee_cold_credential) - , a (arr [asKey committee_cold_credential ==> epoch]) - , a unit_interval - ] - -new_constitution :: Named Group -new_constitution = - "new_constitution" - =:~ grp [5, a (gov_action_id / VNil), a constitution] - -constitution :: Rule -constitution = - "constitution" - =:= arr - [ a anchor - , a (scripthash / VNil) - ] - -info_action :: Rule -info_action = "info_action" =:= int 6 - -voter :: Rule -voter = - "voter" - =:= arr [0, a addr_keyhash] - / arr [1, a scripthash] - / arr [2, a addr_keyhash] - / arr [3, a scripthash] - / arr [4, a addr_keyhash] - -anchor :: Rule -anchor = - "anchor" - =:= arr - [ "anchor_url" ==> url - , "anchor_data_hash" ==> hash32 - ] - -vote :: Rule -vote = "vote" =:= int 0 / int 1 / int 2 - -gov_action_id :: Rule -gov_action_id = - "gov_action_id" - =:= arr - [ "transaction_id" ==> hash32 - , "gov_action_index" ==> VUInt - ] - -required_signers :: Rule -required_signers = "required_signers" =:= nonempty_set addr_keyhash - -transaction_input :: Rule -transaction_input = - "transaction_input" - =:= arr - [ "transaction_id" ==> hash32 - , "index" ==> VUInt - ] - -transaction_output :: Rule -transaction_output = - "transaction_output" - =:= legacy_transaction_output - / post_alonzo_transaction_output - -legacy_transaction_output :: Rule -legacy_transaction_output = - "legacy_transaction_output" - =:= arr - [ a address - , "amount" ==> value - , opt ("datum_hash" ==> hash32) - ] - -post_alonzo_transaction_output :: Rule -post_alonzo_transaction_output = - "post_alonzo_transaction_output" - =:= arr - [ idx 0 ==> address - , idx 1 ==> value - , opt (idx 2 ==> datum_option) -- datum option - , opt (idx 3 ==> script_ref) -- script reference - ] - -script_data_hash :: Rule -script_data_hash = "script_data_hash" =:= hash32 - -certificate :: Rule -certificate = - "certificate" - =:= arr - [ a - ( stake_registration - / stake_deregistration - / stake_delegation - / pool_registration - / pool_retirement - / reg_cert - / unreg_cert - / vote_deleg_cert - / stake_vote_deleg_cert - / stake_reg_deleg_cert - / vote_reg_deleg_cert - / stake_vote_reg_deleg_cert - / auth_committee_hot_cert - / resign_committee_cold_cert - / reg_drep_cert - / unreg_drep_cert - / update_drep_cert - ) - ] - -stake_registration :: Named Group -stake_registration = "stake_registration" =:~ grp [0, a stake_credential] - -stake_deregistration :: Named Group -stake_deregistration = "stake_deregistration" =:~ grp [0, a stake_credential] - -stake_delegation :: Named Group -stake_delegation = - "stake_delegation" - =:~ grp [0, a stake_credential, a pool_keyhash] - --- POOL -pool_registration :: Named Group -pool_registration = "pool_registration" =:~ grp [3, a pool_params] - -pool_retirement :: Named Group -pool_retirement = "pool_retirement" =:~ grp [4, a pool_keyhash, a epoch] - --- numbers 5 and 6 used to be the Genesis and MIR certificates respectively, --- which were deprecated in Conway - --- DELEG -reg_cert :: Named Group -reg_cert = "reg_cert" =:~ grp [7, a stake_credential, a coin] - -unreg_cert :: Named Group -unreg_cert = "unreg_cert" =:~ grp [8, a stake_credential, a coin] - -vote_deleg_cert :: Named Group -vote_deleg_cert = "vote_deleg_cert" =:~ grp [9, a stake_credential, a drep] - -stake_vote_deleg_cert :: Named Group -stake_vote_deleg_cert = - "stake_vote_deleg_cert" - =:~ grp [10, a stake_credential, a pool_keyhash, a drep] - -stake_reg_deleg_cert :: Named Group -stake_reg_deleg_cert = - "stake_reg_deleg_cert" - =:~ grp [11, a stake_credential, a pool_keyhash, a coin] - -vote_reg_deleg_cert :: Named Group -vote_reg_deleg_cert = - "vote_reg_deleg_cert" - =:~ grp [12, a stake_credential, a drep, a coin] - -stake_vote_reg_deleg_cert :: Named Group -stake_vote_reg_deleg_cert = - "stake_vote_reg_deleg_cert" - =:~ grp [13, a stake_credential, a pool_keyhash, a drep, a coin] - --- GOVCERT -auth_committee_hot_cert :: Named Group -auth_committee_hot_cert = - "auth_committee_hot_cert" - =:~ grp [14, a committee_cold_credential, a committee_hot_credential] - -resign_committee_cold_cert :: Named Group -resign_committee_cold_cert = - "resign_committee_cold_cert" - =:~ grp [15, a committee_cold_credential, a (anchor / VNil)] - -reg_drep_cert :: Named Group -reg_drep_cert = "reg_drep_cert" =:~ grp [16, a drep_credential, a coin, a (anchor / VNil)] - -unreg_drep_cert :: Named Group -unreg_drep_cert = "unreg_drep_cert" =:~ grp [17, a drep_credential, a coin] - -update_drep_cert :: Named Group -update_drep_cert = "update_drep_cert" =:~ grp [18, a drep_credential, a (anchor / VNil)] - -delta_coin :: Rule -delta_coin = "delta_coin" =:= VUInt - -credential :: Rule -credential = - "credential" - =:= arr - [0, a addr_keyhash] - / arr [1, a scripthash] - -drep :: Rule -drep = - "drep" - =:= sarr [0, a addr_keyhash] - / sarr [1, a scripthash] - / int 2 -- always abstain - / int 3 -- always no confidence - -stake_credential :: Rule -stake_credential = "stake_credential" =:= credential - -drep_credential :: Rule -drep_credential = "drep_credential" =:= credential - -committee_cold_credential :: Rule -committee_cold_credential = "committee_cold_credential" =:= credential - -committee_hot_credential :: Rule -committee_hot_credential = "committee_hot_credential" =:= credential - -pool_params :: Named Group -pool_params = - "pool_params" - =:~ grp - [ "operator" ==> pool_keyhash - , "vrf_keyhash" ==> vrf_keyhash - , "pledge" ==> coin - , "cost" ==> coin - , "margin" ==> unit_interval - , "reward_account" ==> reward_account - , "pool_owners" ==> set addr_keyhash - , "relays" ==> arr [0 <+ a relay] - , "pool_metadata" ==> (pool_metadata / VNil) - ] - -port :: Rule -port = "port" =:= VUInt `le` 65535 - -ipv4 :: Rule -ipv4 = "ipv4" =:= VBytes `sized` (4 :: Word64) - -ipv6 :: Rule -ipv6 = "ipv6" =:= VBytes `sized` (16 :: Word64) - -dns_name :: Rule -dns_name = "dns_name" =:= VText `sized` (0 :: Word64, 128 :: Word64) - -single_host_addr :: Named Group -single_host_addr = - "single_host_addr" - =:~ grp - [ 0 - , a (port / VNil) - , a (ipv4 / VNil) - , a (ipv6 / VNil) - ] - -single_host_name :: Named Group -single_host_name = - "single_host_name" - =:~ grp - [ 1 - , a (port / VNil) - , a dns_name -- An A or AAAA DNS record - ] - -multi_host_name :: Named Group -multi_host_name = - "multi_host_name" - =:~ grp - [ 2 - , a dns_name -- A SRV DNS record - ] - -relay :: Rule -relay = - "relay" - =:= arr - [ a - ( single_host_addr - / single_host_name - / multi_host_name - ) - ] - -pool_metadata :: Rule -pool_metadata = "pool_metadata" =:= arr [a url, a pool_metadata_hash] - -url :: Rule -url = "url" =:= VText `sized` (0 :: Word64, 128 :: Word64) - -withdrawals :: Rule -withdrawals = "withdrawals" =:= mp [1 <+ asKey reward_account ==> coin] - -protocol_param_update :: Rule -protocol_param_update = - "protocol_param_update" - =:= mp - [ opt (idx 0 ==> coin) -- minfee A - , opt (idx 1 ==> coin) -- minfee B - , opt (idx 2 ==> VUInt) -- max block body size - , opt (idx 3 ==> VUInt) -- max transaction size - , opt (idx 4 ==> VUInt) -- max block header size - , opt (idx 5 ==> coin) -- key deposit - , opt (idx 6 ==> coin) -- pool deposit - , opt (idx 7 ==> epoch) -- maximum epoch - , opt (idx 8 ==> VUInt) -- n_opt: desired number of stake pools - , opt (idx 9 ==> nonnegative_interval) -- pool pledge influence - , opt (idx 10 ==> unit_interval) -- expansion rate - , opt (idx 11 ==> unit_interval) -- treasury growth rate - , opt (idx 16 ==> coin) -- min pool cost - , opt (idx 17 ==> coin) -- ada per utxo byte - , opt (idx 18 ==> costmdls) -- cost models for script languages - , opt (idx 19 ==> ex_unit_prices) -- execution costs - , opt (idx 20 ==> ex_units) -- max tx ex units - , opt (idx 21 ==> ex_units) -- max block ex units - , opt (idx 22 ==> VUInt) -- max value size - , opt (idx 23 ==> VUInt) -- collateral percentage - , opt (idx 24 ==> VUInt) -- max collateral inputs - , opt (idx 25 ==> pool_voting_thresholds) -- pool voting thresholds - , opt (idx 26 ==> drep_voting_thresholds) -- DRep voting thresholds - , opt (idx 27 ==> VUInt) -- min committee size - , opt (idx 28 ==> epoch) -- committee term limit - , opt (idx 29 ==> epoch) -- governance action validity period - , opt (idx 30 ==> coin) -- governance action deposit - , opt (idx 31 ==> coin) -- DRep deposit - , opt (idx 32 ==> epoch) -- DRep inactivity period - ] - -pool_voting_thresholds :: Rule -pool_voting_thresholds = - "pool_voting_thresholds" - =:= arr - [ a unit_interval -- motion no confidence - , a unit_interval -- committee normal - , a unit_interval -- committee no confidence - , a unit_interval -- hard fork initiation - , a unit_interval -- security relevant parameter voting threshold - ] - -drep_voting_thresholds :: Rule -drep_voting_thresholds = - "drep_voting_thresholds" - =:= arr - [ a unit_interval -- motion no confidence - , a unit_interval -- committee normal - , a unit_interval -- committee no confidence - , a unit_interval -- update constitution - , a unit_interval -- hard fork initiation - , a unit_interval -- PP network group - , a unit_interval -- PP economic group - , a unit_interval -- PP technical group - , a unit_interval -- PP governance group - , a unit_interval -- treasury withdrawal - ] - -transaction_witness_set :: Rule -transaction_witness_set = - "transaction_witness_set" - =:= mp - [ opt $ idx 0 ==> nonempty_set vkeywitness - , opt $ idx 1 ==> nonempty_set native_script - , opt $ idx 2 ==> nonempty_set bootstrap_witness - , opt $ idx 3 ==> nonempty_set plutus_v1_script - , opt $ idx 4 ==> nonempty_set plutus_data - , opt $ idx 5 ==> redeemers - , opt $ idx 6 ==> nonempty_set plutus_v2_script - , opt $ idx 7 ==> nonempty_set plutus_v3_script - ] - --- The real type of plutus_v1_script, plutus_v2_script and plutus_v3_script is bytes. --- However, because we enforce uniqueness when many scripts are supplied, --- we need to hack around for tests in order to avoid generating duplicates, --- since the cddl tool we use for roundtrip testing doesn't generate distinct collections. -plutus_v1_script :: Rule -plutus_v1_script = - comment - ( "The real type of plutus_v1_script, plutus_v2_script and plutus_v3_script is bytes.\n" - <> "However, because we enforce uniqueness when many scripts are supplied,\n" - <> "we need to hack around for tests in order to avoid generating duplicates,\n" - <> "since the cddl tool we use for roundtrip testing doesn't generate distinct collections.\n" - ) - $ "plutus_v1_script" =:= distinct VBytes - -plutus_v2_script :: Rule -plutus_v2_script = "plutus_v2_script" =:= distinct VBytes - -plutus_v3_script :: Rule -plutus_v3_script = "plutus_v3_script" =:= distinct VBytes - -plutus_data :: Rule -plutus_data = - "plutus_data" - =:= constr plutus_data - / smp [0 <+ asKey plutus_data ==> plutus_data] - / sarr [0 <+ a plutus_data] - / big_int - / bounded_bytes - -big_int :: Rule -big_int = "big_int" =:= VInt / big_VUInt / big_nint - -big_VUInt :: Rule -big_VUInt = "big_VUInt" =:= tag 2 bounded_bytes - -big_nint :: Rule -big_nint = "big_nint" =:= tag 3 bounded_bytes - -constr :: IsType0 x => x -> GRuleCall -constr = binding $ \x -> - "constr" - =:= tag 1 (arr [0 <+ a x]) - / tag 2 (arr [0 <+ a x]) - / tag 3 (arr [0 <+ a x]) - / tag 4 (arr [0 <+ a x]) - / tag 5 (arr [0 <+ a x]) - / tag 6 (arr [0 <+ a x]) - / tag 7 (arr [0 <+ a x]) - -- similarly for tag range: 6.1280 .. 6.1400 inclusive - / tag 2 (arr [a VUInt, a $ arr [0 <+ a x]]) - -redeemers :: Rule -redeemers = - "redeemers" - =:= sarr - [ 1 - <+ a - ( arr - [ "tag" ==> redeemer_tag - , "index" ==> VUInt - , "data" ==> plutus_data - , "ex_units" ==> ex_units - ] - ) - ] - / smp - [ 1 - <+ asKey (mp ["tag" ==> redeemer_tag, "index" ==> VUInt]) - ==> arr ["data" ==> plutus_data, "ex_units" ==> ex_units] - ] - -redeemer_tag :: Rule -redeemer_tag = - "redeemer_tag" - =:= int 0 -- Spending - / int 1 -- Minting - / int 2 -- Certifying - / int 3 -- Rewarding - / int 4 -- Voting - / int 5 -- Proposing - -ex_units :: Rule -ex_units = "ex_units" =:= arr ["mem" ==> VUInt, "steps" ==> VUInt] - -ex_unit_prices :: Rule -ex_unit_prices = - "ex_unit_prices" - =:= arr - [ "mem_price" ==> nonnegative_interval - , "step_price" ==> nonnegative_interval - ] - -language :: Rule -language = - "language" - =:= int 0 -- Plutus v1 - / int 1 -- Plutus v2 - / int 2 -- Plutus v3 - -potential_languages :: Rule -potential_languages = "potential_languages" =:= int 0 ... int 255 - --- The format for costmdls is flexible enough to allow adding Plutus built-ins and language --- versions in the future. --- -costmdls :: Rule -costmdls = - comment - "The format for costmdls is flexible enough to allow adding Plutus\n built-ins and language versions in the future." - $ "costmdls" - =:= mp - [ opt $ idx 0 ==> arr [166 <+ a VInt] -- Plutus v1, only 166 integers are used, but more are accepted (and ignored) - , opt $ idx 1 ==> arr [175 <+ a VInt] -- Plutus v2, only 175 integers are used, but more are accepted (and ignored) - , opt $ idx 2 ==> arr [223 <+ a VInt] -- Plutus v3, only 223 integers are used, but more are accepted (and ignored) - , opt $ idx 3 ==> arr [a VInt] -- Any 8-bit unsigned number can be used as a key. - ] - -transaction_metadatum :: Rule -transaction_metadatum = - "transaction_metadatum" - =:= smp [0 <+ asKey transaction_metadatum ==> transaction_metadatum] - / sarr [0 <+ a transaction_metadatum] - / VInt - / (VBytes `sized` (0 :: Word64, 64 :: Word64)) - / (VText `sized` (0 :: Word64, 64 :: Word64)) - -transaction_metadatum_label :: Rule -transaction_metadatum_label = "transaction_metadatum_label" =:= VUInt - -metadata :: Rule -metadata = - "metadata" - =:= mp - [ 0 - <+ asKey transaction_metadatum_label - ==> transaction_metadatum - ] - -auxiliary_data :: Rule -auxiliary_data = - "auxiliary_data" - =:= metadata -- Shelley - / sarr - [ "transaction_metadata" ==> metadata -- Shelley-ma - , "auxiliary_scripts" ==> arr [0 <+ a native_script] - ] - / smp - [ opt (idx 0 ==> metadata) -- Alonzo and beyond - , opt (idx 1 ==> arr [0 <+ a native_script]) - , opt (idx 2 ==> arr [0 <+ a plutus_v1_script]) - , opt (idx 3 ==> arr [0 <+ a plutus_v2_script]) - , opt (idx 4 ==> arr [0 <+ a plutus_v3_script]) - ] - -vkeywitness :: Rule -vkeywitness = "vkeywitness" =:= arr [a vkey, a signature] - -bootstrap_witness :: Rule -bootstrap_witness = - "bootstrap_witness" - =:= arr - [ "public_key" ==> vkey - , "signature" ==> signature - , "chain_code" ==> (VBytes `sized` (32 :: Word64)) - , "attributes" ==> VBytes - ] - -native_script :: Rule -native_script = - "native_script" - =:= arr - [ a - ( script_pubkey - / script_all - / script_any - / script_n_of_k - / invalid_before - -- Timelock validity intervals are half-open intervals [a, b). - -- This field specifies the left (included) endpoint a. - / invalid_hereafter - -- Timelock validity intervals are half-open intervals [a, b). - -- This field specifies the right (excluded) endpoint b. - ) - ] - -script_pubkey :: Named Group -script_pubkey = "script_pubkey" =:~ grp [0, a addr_keyhash] - -script_all :: Named Group -script_all = "script_all" =:~ grp [1, a (arr [0 <+ a native_script])] - -script_any :: Named Group -script_any = "script_any" =:~ grp [2, a (arr [0 <+ a native_script])] - -script_n_of_k :: Named Group -script_n_of_k = - "script_n_of_k" - =:~ grp [3, "n" ==> VUInt, a (arr [0 <+ a native_script])] - -invalid_before :: Named Group -invalid_before = "invalid_before" =:~ grp [4, a VUInt] - -invalid_hereafter :: Named Group -invalid_hereafter = "invalid_hereafter" =:~ grp [5, a VUInt] - -coin :: Rule -coin = "coin" =:= VUInt - -multiasset :: (Show a, IsType0 a) => a -> Rule -multiasset x = - "multiasset_" - <> T.pack (show x) - =:= mp [1 <+ asKey policy_id ==> mp [1 <+ asKey asset_name ==> x]] - -policy_id :: Rule -policy_id = "policy_id" =:= scripthash - -asset_name :: Rule -asset_name = "asset_name" =:= VBytes `sized` (0 :: Word64, 32 :: Word64) - -negInt64 :: Rule -negInt64 = "negInt64" =:= int (-9223372036854775808) ... int (-1) - -posInt64 :: Rule -posInt64 = "posInt64" =:= int 1 ... int 9223372036854775807 - -nonZeroInt64 :: Rule -nonZeroInt64 = "nonZeroInt64" =:= negInt64 / posInt64 -- this is the same as the current int64 definition but without zero - -positive_coin :: Rule -positive_coin = "positive_coin" =:= int 1 ... int 18446744073709551615 - -value :: Rule -value = "value" =:= coin / sarr [a coin, a (multiasset positive_coin)] - -mint :: Rule -mint = "mint" =:= multiasset nonZeroInt64 - -int64 :: Rule -int64 = "int64" =:= int (-9223372036854775808) ... int 9223372036854775807 - -network_id :: Rule -network_id = "network_id" =:= int 0 / int 1 - -epoch :: Rule -epoch = "epoch" =:= VUInt - -addr_keyhash :: Rule -addr_keyhash = "addr_keyhash" =:= hash28 - -pool_keyhash :: Rule -pool_keyhash = "pool_keyhash" =:= hash28 - -vrf_keyhash :: Rule -vrf_keyhash = "vrf_keyhash" =:= hash32 - -auxiliary_data_hash :: Rule -auxiliary_data_hash = "auxiliary_data_hash" =:= hash32 - -pool_metadata_hash :: Rule -pool_metadata_hash = "pool_metadata_hash" =:= hash32 - --- To compute a script hash, note that you must prepend --- a tag to the bytes of the script before hashing. --- The tag is determined by the language. --- The tags in the Conway era are: --- "\x00" for multisig scripts --- "\x01" for Plutus V1 scripts --- "\x02" for Plutus V2 scripts --- "\x03" for Plutus V3 scripts -scripthash :: Rule -scripthash = - comment - ( "To compute a script hash, note that you must prepend\n" - <> "a tag to the bytes of the script before hashing.\n" - <> "The tag is determined by the language.\n" - <> "The tags in the Conway era are:\n" - <> "\"\x00\" for multisig scripts\n" - <> "\"\x01\" for Plutus V1 scripts\n" - <> "\"\x02\" for Plutus V2 scripts\n" - <> "\"\x03\" for Plutus V3 scripts\n" - ) - $ "scripthash" =:= hash28 - -datum_hash :: Rule -datum_hash = "datum_hash" =:= hash32 - -data_a :: Rule -data_a = "data" =:= VBytes `cbor` plutus_data - -datum_option :: Rule -datum_option = "datum_option" =:= arr [0, a hash32] / arr [1, a data_a] - -script_ref :: Rule -script_ref = "script_ref" =:= VBytes `cbor` script - -script :: Rule -script = - "script" - =:= arr [0, a native_script] - / arr [1, a plutus_v1_script] - / arr [2, a plutus_v2_script] - / arr [3, a plutus_v3_script] - --------------------------------------------------------------------------------- --- Crypto --------------------------------------------------------------------------------- - -hash28 :: Rule -hash28 = "hash28" =:= VBytes `sized` (28 :: Word64) - -hash32 :: Rule -hash32 = "hash32" =:= VBytes `sized` (32 :: Word64) - -vkey :: Rule -vkey = "vkey" =:= VBytes `sized` (32 :: Word64) - -vrf_vkey :: Rule -vrf_vkey = "vrf_vkey" =:= VBytes `sized` (32 :: Word64) - -vrf_cert :: Rule -vrf_cert = "vrf_cert" =:= arr [a VBytes, a (VBytes `sized` (80 :: Word64))] - -kes_vkey :: Rule -kes_vkey = "kes_vkey" =:= VBytes `sized` (32 :: Word64) - -kes_signature :: Rule -kes_signature = "kes_signature" =:= VBytes `sized` (448 :: Word64) - -signkeyKES :: Rule -signkeyKES = "signkeyKES" =:= VBytes `sized` (64 :: Word64) - -signature :: Rule -signature = "signature" =:= VBytes `sized` (64 :: Word64) - --------------------------------------------------------------------------------- --- Extras --------------------------------------------------------------------------------- - --- Conway era introduces an optional 258 tag for sets, which will become mandatory in the --- second era after Conway. We recommend all the tooling to account for this future breaking --- change sooner rather than later, in order to provide a smooth transition for their users. - -set :: IsType0 t0 => t0 -> GRuleCall -set = binding $ \x -> "set" =:= arr [0 <+ a x] - -nonempty_set :: IsType0 t0 => t0 -> GRuleCall -nonempty_set = binding $ \x -> "nonempty_set" =:= set x - --- TODO Should we give this a name? -nonempty_oset :: IsType0 t0 => t0 -> GRuleCall -nonempty_oset = nonempty_set - -positive_int :: Rule -positive_int = "positive_int" =:= int 1 ... int 18446744073709551615 - -unit_interval :: Rule -unit_interval = "unit_interval" =:= tag 30 (arr [1, 2]) - --- unit_interval = tag 0 [uint, uint] --- --- Comment above depicts the actual definition for `unit_interval`. --- --- Unit interval is a number in the range between 0 and 1, which --- means there are two extra constraints: --- \* numerator <= denominator --- \* denominator > 0 --- --- Relation between numerator and denominator cannot be expressed in CDDL, which --- poses a problem for testing. We need to be able to generate random valid data --- for testing implementation of our encoders/decoders. Which means we cannot use --- the actual definition here and we hard code the value to 1/2 - --- nonnegative_interval = tag 0 [uint, positive_int] -nonnegative_interval :: Rule -nonnegative_interval = "nonnegative_interval" =:= tag 30 (arr [a VUInt, a positive_int]) - -address :: Rule -address = - "address" - =:= bstr - "001000000000000000000000000000000000000000000000000000000011000000000000000000000000000000000000000000000000000000" - / bstr - "102000000000000000000000000000000000000000000000000000000022000000000000000000000000000000000000000000000000000000" - / bstr - "203000000000000000000000000000000000000000000000000000000033000000000000000000000000000000000000000000000000000000" - / bstr - "304000000000000000000000000000000000000000000000000000000044000000000000000000000000000000000000000000000000000000" - / bstr "405000000000000000000000000000000000000000000000000000000087680203" - / bstr "506000000000000000000000000000000000000000000000000000000087680203" - / bstr "6070000000000000000000000000000000000000000000000000000000" - / bstr "7080000000000000000000000000000000000000000000000000000000" - -reward_account :: Rule -reward_account = - "reward_account" - =:= bstr "E090000000000000000000000000000000000000000000000000000000" - / bstr "F0A0000000000000000000000000000000000000000000000000000000" - -bounded_bytes :: Rule -bounded_bytes = "bounded_bytes" =:= VBytes `sized` (0 :: Word64, 64 :: Word64) - --- the real bounded_bytes does not have this limit. it instead has a different --- limit which cannot be expressed in CDDL. --- The limit is as follows: --- - bytes with a definite-length encoding are limited to size 0..64 --- - for bytes with an indefinite-length CBOR encoding, each chunk is --- limited to size 0..64 --- ( reminder: in CBOR, the indefinite-length encoding of bytestrings --- consists of a token #2.31 followed by a sequence of definite-length --- encoded bytestrings and a stop code ) - --- a type for distinct values. --- The type parameter must support .size, for example: bytes or uint - -distinct :: (IsType0 a, IsConstrainable a b) => a -> GRuleCall -distinct = binding $ \x -> - "distinct" - =:= (x `sized` (8 :: Word64)) - / (x `sized` (16 :: Word64)) - / (x `sized` (20 :: Word64)) - / (x `sized` (24 :: Word64)) - / (x `sized` (30 :: Word64)) - / (x `sized` (32 :: Word64)) diff --git a/example/Main.hs b/example/Main.hs deleted file mode 100644 --- a/example/Main.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module Main (main) where - -import Codec.CBOR.Cuddle.CBOR.Gen (generateCBORTerm) -import Codec.CBOR.Cuddle.CDDL (Name (..)) -import Codec.CBOR.Cuddle.CDDL.Resolve ( - asMap, - buildMonoCTree, - buildRefCTree, - buildResolvedCTree, - ) -import Codec.CBOR.Cuddle.Huddle (toCDDL) -import Codec.CBOR.Cuddle.Parser (pCDDL) -import Codec.CBOR.Cuddle.Pretty () -import Conway (conway) -import Data.Text qualified as T -import Data.Text.IO qualified as T -import Monad qualified -import Prettyprinter (Pretty (pretty)) -import Prettyprinter.Util (putDocW) -import System.Environment (getArgs) -import System.Random (getStdGen) -import Text.Megaparsec (ParseErrorBundle, Parsec, errorBundlePretty, runParser) - -main :: IO () -main = do - args <- getArgs - case args of - [fn] -> do - parseFromFile pCDDL fn >>= \case - Left err -> putStrLn $ errorBundlePretty err - Right res -> do - print res - putDocW 80 $ pretty res - putStrLn "\n" - putStrLn "--------------------------------------------------------------------------------" - putStrLn " As a CTree" - putStrLn "--------------------------------------------------------------------------------" - let refCTree = buildRefCTree (asMap res) - print refCTree - putStrLn "--------------------------------------------------------------------------------" - putStrLn " After name resolution" - putStrLn "--------------------------------------------------------------------------------" - let resolvedCTree = buildResolvedCTree refCTree - print resolvedCTree - putStrLn "--------------------------------------------------------------------------------" - putStrLn " After monomorphisation" - putStrLn "--------------------------------------------------------------------------------" - let monoCTree = buildMonoCTree <$> resolvedCTree - print monoCTree - [fn, name] -> do - putStrLn "--------------------------------------------------------------------------------" - putStrLn " Generating a term" - putStrLn "--------------------------------------------------------------------------------" - parseFromFile pCDDL fn >>= \case - Left err -> putStrLn $ errorBundlePretty err - Right res -> do - stdGen <- getStdGen - case buildMonoCTree =<< buildResolvedCTree (buildRefCTree (asMap res)) of - Left nre -> error $ show nre - Right mt -> - let term = generateCBORTerm mt (Name (T.pack name) mempty) stdGen - in print term - [] -> do - let cw = toCDDL conway - putDocW 80 $ pretty cw - putStrLn "--------------------------------------" - putDocW 80 $ pretty (toCDDL Monad.spec) - putStrLn "--------------------------------------" - putDocW 80 $ pretty (toCDDL Monad.spec2) - _ -> putStrLn "Expected filename" - -parseFromFile :: - Parsec e T.Text a -> - String -> - IO (Either (ParseErrorBundle T.Text e) a) -parseFromFile p file = runParser p file <$> T.readFile file diff --git a/example/Monad.hs b/example/Monad.hs deleted file mode 100644 --- a/example/Monad.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - -{- HLINT ignore "Use camelCase" -} - -module Monad where - -import Codec.CBOR.Cuddle.Comments ((//-)) -import Codec.CBOR.Cuddle.Huddle qualified as Huddle -import Codec.CBOR.Cuddle.Huddle.HuddleM -import Data.Word (Word64) - -hdl_set :: IsType0 t0 => t0 -> GRuleCall -hdl_set = Huddle.binding $ \x -> "set" Huddle.=:= arr [0 <+ a x] - -spec :: Huddle -spec = huddleDef $ mdo - transaction <- - "transaction" - =:= mp - [ idx 0 ==> set txIn - , idx 1 ==> set txOut - ] - txIn <- "txIn" =:= arr ["transaction_id" ==> hash32, "index" ==> txId] - txOut <- "txOut" =:= arr [idx 0 ==> address, idx 1 ==> value] - txId <- "txId" =:= VUInt `sized` (2 :: Word64) - address <- "address" =:= VBytes `sized` (32 :: Word64) - hash32 <- "hash32" =:= VBytes `sized` (32 :: Word64) - value <- "value" =:= VUInt - set <- include hdl_set - - setRootRules [transaction] - -spec2 :: Huddle -spec2 = - spec - <> huddleDef - ( mdo - set <- include hdl_set - txIn <- unsafeIncludeFromHuddle spec "txIn" - txOut <- unsafeIncludeFromHuddle spec "txOut" - _transaction <- - "transaction" - =:= mp - [ idx 0 ==> set txIn //- "Transaction inputs" - , idx 1 ==> set txOut //- "Transaction outputs" - , idx 2 ==> metadata //- "Metadata" - ] - metadata <- "metadata" =:= VBytes - _value <- "value" =:= mp ["token" ==> VText, "quantity" ==> VUInt] - pure () - ) diff --git a/example/cddl-files/basic_assign.cddl b/example/cddl-files/basic_assign.cddl deleted file mode 100644 --- a/example/cddl-files/basic_assign.cddl +++ /dev/null @@ -1,47 +0,0 @@ -coin = uint -epoch = uint - -header = - [ header_body - , body_signature : $kes_signature - , test : coin / null - , withComment : null ; This is a comment - , true - ] - -header_body = [ - issuer : text -] - -$kes_signature = bytes .size 32 -unit_interval = [0 .. denominator, denominator] - -unit_int = unit_interval<4294967295> - -mysize = 16 - -sz1 = bytes .size 1 -sz2 = bytes .size 2 -sz32 = bytes .size 32 -sz16 = bytes .size mysize - -usz4 = uint .size 4 -usz8 = uint .size 8 - -group = (usz4, usz8 / mysize, header_body, { * uint => coin }) - -set = [ * a] -set2 = set - -coin_bag = set2 - -big_group = ( - "hello", - 32, - 8* 4, - & group, - uint, - unit_interval<3>, - 5 ...10, - h'11aaff3351bc' -) diff --git a/example/cddl-files/byron.cddl b/example/cddl-files/byron.cddl deleted file mode 100644 --- a/example/cddl-files/byron.cddl +++ /dev/null @@ -1,209 +0,0 @@ -; Cardano Byron blockchain CBOR schema - -block = [0, ebblock] - / [1, mainblock] - -mainblock = [ "header" : blockhead - , "body" : blockbody - , "extra" : [attributes] - ] - -ebblock = [ "header" : ebbhead - , "body" : [+ stakeholderid] - , extra : [attributes] - ] - -u8 = uint .lt 256 -u16 = uint .lt 65536 -u32 = uint -u64 = uint - -; Basic Cardano Types - -blake2b-256 = bytes .size 32 - -txid = blake2b-256 -blockid = blake2b-256 -updid = blake2b-256 -hash = blake2b-256 - -blake2b-224 = bytes .size 28 - -addressid = blake2b-224 -stakeholderid = blake2b-224 - -epochid = u64 -slotid = [ epoch: epochid, slot : u64 ] - -pubkey = bytes -signature = bytes - -; Attributes - at the moment we do not bother deserialising these, since they -; don't contain anything - -attributes = {* any => any} - -; Addresses - -addrdistr = [1] / [0, stakeholderid] - -addrtype = &("PubKey" : 0, "Script" : 1, "Redeem" : 2) / (u64 .gt 2) -addrattr = { ? 0 : addrdistr - , ? 1 : bytes} -address = [ #6.24(bytes .cbor ([addressid, addrattr, addrtype])), u64 ] - -; Transactions - -txin = [0, #6.24(bytes .cbor ([txid, u32]))] / [u8 .ne 0, encoded-cbor] -txout = [address, u64] - -tx = [[+ txin], [+ txout], attributes] - -txproof = [u32, hash, hash] - -twit = [0, #6.24(bytes .cbor ([pubkey, signature]))] - / [1, #6.24(bytes .cbor ([[u16, bytes], [u16, bytes]]))] - / [2, #6.24(bytes .cbor ([pubkey, signature]))] - / [u8 .gt 2, encoded-cbor] - -; Shared Seed Computation - -vsspubkey = bytes ; This is encoded using the 'Binary' instance - ; for Scrape.PublicKey -vsssec = bytes ; This is encoded using the 'Binary' instance - ; for Scrape.Secret. -vssenc = [bytes] ; This is encoded using the 'Binary' instance - ; for Scrape.EncryptedSi. - ; TODO work out why this seems to be in a length 1 array -vssdec = bytes ; This is encoded using the 'Binary' instance - ; for Scrape.DecryptedShare -vssproof = [bytes, bytes, bytes, [* bytes]] ; This is encoded using the - ; 'Binary' instance for Scrape.Proof - -ssccomm = [pubkey, [{vsspubkey => vssenc},vssproof], signature] -ssccomms = #6.258([* ssccomm]) - -sscopens = {stakeholderid => vsssec} - -sscshares = {addressid => [addressid, [* vssdec]]} - -ssccert = [vsspubkey, pubkey, epochid, signature] -ssccerts = #6.258([* ssccert]) - -ssc = [0, ssccomms, ssccerts] - / [1, sscopens, ssccerts] - / [2, sscshares, ssccerts] - / [3, ssccerts] - -sscproof = [0, hash, hash] - / [1, hash, hash] - / [2, hash, hash] - / [3, hash] - -; Delegation - -dlg = [ epoch : epochid - , issuer : pubkey - , delegate : pubkey - , certificate : signature - ] - -dlgsig = [dlg, signature] - -lwdlg = [ epochRange : [epochid, epochid] - , issuer : pubkey - , delegate : pubkey - , certificate : signature - ] - -lwdlgsig = [lwdlg, signature] - -; Updates - -bver = [u16, u16, u8] - -txfeepol = [0, #6.24(bytes .cbor ([bigint, bigint]))] - / [u8 .gt 0, encoded-cbor] - -bvermod = [ scriptVersion : [? u16] - , slotDuration : [? bigint] - , maxBlockSize : [? bigint] - , maxHeaderSize : [? bigint] - , maxTxSize : [? bigint] - , maxProposalSize : [? bigint] - , mpcThd : [? u64] - , heavyDelThd : [? u64] - , updateVoteThd : [? u64] - , updateProposalThd : [? u64] - , updateImplicit : [? u64] - , softForkRule : [? [u64, u64, u64]] - , txFeePolicy : [? txfeepol] - , unlockStakeEpoch : [? epochid] - ] - -updata = [ hash, hash, hash, hash ] - -upprop = [ "blockVersion" : bver - , "blockVersionMod" : bvermod - , "softwareVersion" : [ text, u32 ] - , "data" : #6.258([text, updata]) - , "attributes" : attributes - , "from" : pubkey - , "signature" : signature - ] - -upvote = [ "voter" : pubkey - , "proposalId" : updid - , "vote" : bool - , "signature" : signature - ] - -up = [ "proposal" : [? upprop] - , votes : [* upvote] - ] - -; Blocks - -difficulty = [u64] - -blocksig = [0, signature] - / [1, lwdlgsig] - / [2, dlgsig] - -blockcons = [slotid, pubkey, difficulty, blocksig] - -blockheadex = [ "blockVersion" : bver - , "softwareVersion" : [ text, u32 ] - , "attributes" : attributes - , "extraProof" : hash - ] - -blockproof = [ "txProof" : txproof - , "sscProof" : sscproof - , "dlgProof" : hash - , "updProof" : hash - ] - -blockhead = [ "protocolMagic" : u32 - , "prevBlock" : blockid - , "bodyProof" : blockproof - , "consensusData" : blockcons - , "extraData" : blockheadex - ] - -blockbody = [ "txPayload" : [* [tx, [* twit]]] - , "sscPayload" : ssc - , "dlgPayload" : [* dlg] - , "updPayload" : up - ] - -; Epoch Boundary Blocks - -ebbcons = [ epochid, difficulty ] - -ebbhead = [ "protocolMagic" : u32 - , "prevBlock" : blockid - , "bodyProof" : hash - , "consensusData" : ebbcons - , "extraData" : [attributes] - ] diff --git a/example/cddl-files/conway.cddl b/example/cddl-files/conway.cddl deleted file mode 100644 --- a/example/cddl-files/conway.cddl +++ /dev/null @@ -1,683 +0,0 @@ -; crypto.cddl -$hash28 /= bytes .size 28 -$hash32 /= bytes .size 32 - -$vkey /= bytes .size 32 - -$vrf_vkey /= bytes .size 32 -$vrf_cert /= [bytes, bytes .size 80] - -$kes_vkey /= bytes .size 32 -$kes_signature /= bytes .size 448 -signkeyKES = bytes .size 64 - -$signature /= bytes .size 64 - -; extra.cddl -; Conway era introduces an optional 258 tag for sets, which will become mandatory in the -; second era after Conway. We recommend all the tooling to account for this future breaking -; change sooner rather than later, in order to provide a smooth transition for their users. - -; This is an unordered set. Duplicate elements are not allowed and the order of elements is implementation specific. -set = #6.258([* a]) / [* a] - -; Just like `set`, but must contain at least one element. -nonempty_set = #6.258([+ a]) / [+ a] - -; This is a non-empty ordered set. Duplicate elements are not allowed and the order of elements will be preserved. -nonempty_oset = #6.258([+ a]) / [+ a] - -positive_int = 1 .. 18446744073709551615 - -unit_interval = #6.30([1, 2]) - ; unit_interval = #6.30([uint, uint]) - ; - ; Comment above depicts the actual definition for `unit_interval`. - ; - ; Unit interval is a number in the range between 0 and 1, which - ; means there are two extra constraints: - ; * numerator <= denominator - ; * denominator > 0 - ; - ; Relation between numerator and denominator cannot be expressed in CDDL, which - ; poses a problem for testing. We need to be able to generate random valid data - ; for testing implementation of our encoders/decoders. Which means we cannot use - ; the actual definition here and we hard code the value to 1/2 - - -nonnegative_interval = #6.30([uint, positive_int]) - - -address = - h'001000000000000000000000000000000000000000000000000000000011000000000000000000000000000000000000000000000000000000' / - h'102000000000000000000000000000000000000000000000000000000022000000000000000000000000000000000000000000000000000000' / - h'203000000000000000000000000000000000000000000000000000000033000000000000000000000000000000000000000000000000000000' / - h'304000000000000000000000000000000000000000000000000000000044000000000000000000000000000000000000000000000000000000' / - h'405000000000000000000000000000000000000000000000000000000087680203' / - h'506000000000000000000000000000000000000000000000000000000087680203' / - h'6070000000000000000000000000000000000000000000000000000000' / - h'7080000000000000000000000000000000000000000000000000000000' - -reward_account = - h'E090000000000000000000000000000000000000000000000000000000' / - h'F0A0000000000000000000000000000000000000000000000000000000' - -bounded_bytes = bytes .size (0..64) - ; the real bounded_bytes does not have this limit. it instead has a different - ; limit which cannot be expressed in CDDL. - ; The limit is as follows: - ; - bytes with a definite-length encoding are limited to size 0..64 - ; - for bytes with an indefinite-length CBOR encoding, each chunk is - ; limited to size 0..64 - ; ( reminder: in CBOR, the indefinite-length encoding of bytestrings - ; consists of a token #2.31 followed by a sequence of definite-length - ; encoded bytestrings and a stop code ) - -; a type for distinct values. -; The type parameter must support .size, for example: bytes or uint -distinct = a .size 8 / a .size 16 / a .size 20 / a .size 24 / a .size 30 / a .size 32 - -; conway.cddl -block = - [ header - , transaction_bodies : [* transaction_body] - , transaction_witness_sets : [* transaction_witness_set] - , auxiliary_data_set : {* transaction_index => auxiliary_data } - , invalid_transactions : [* transaction_index ] - ]; Valid blocks must also satisfy the following two constraints: - ; 1) the length of transaction_bodies and transaction_witness_sets - ; must be the same - ; 2) every transaction_index must be strictly smaller than the - ; length of transaction_bodies - -transaction = - [ transaction_body - , transaction_witness_set - , bool - , auxiliary_data / null - ] - -transaction_index = uint .size 2 - -header = - [ header_body - , body_signature : $kes_signature - ] - -header_body = - [ block_number : uint - , slot : uint - , prev_hash : $hash32 / null - , issuer_vkey : $vkey - , vrf_vkey : $vrf_vkey - , vrf_result : $vrf_cert ; replaces nonce_vrf and leader_vrf - , block_body_size : uint - , block_body_hash : $hash32 ; merkle triple root - , operational_cert - , [ protocol_version ] - ] - -operational_cert = - [ hot_vkey : $kes_vkey - , sequence_number : uint - , kes_period : uint - , sigma : $signature - ] - -next_major_protocol_version = 10 - -major_protocol_version = 1..next_major_protocol_version - -protocol_version = (major_protocol_version, uint) - -transaction_body = - { 0 : set ; inputs - , 1 : [* transaction_output] - , 2 : coin ; fee - , ? 3 : uint ; time to live - , ? 4 : certificates - , ? 5 : withdrawals - , ? 7 : auxiliary_data_hash - , ? 8 : uint ; validity interval start - , ? 9 : mint - , ? 11 : script_data_hash - , ? 13 : nonempty_set ; collateral inputs - , ? 14 : required_signers - , ? 15 : network_id - , ? 16 : transaction_output ; collateral return - , ? 17 : coin ; total collateral - , ? 18 : nonempty_set ; reference inputs - , ? 19 : voting_procedures ; New; Voting procedures - , ? 20 : proposal_procedures ; New; Proposal procedures - , ? 21 : coin ; New; current treasury value - , ? 22 : positive_coin ; New; donation - } - -voting_procedures = { + voter => { + gov_action_id => voting_procedure } } - -voting_procedure = - [ vote - , anchor / null - ] - -proposal_procedure = - [ deposit : coin - , reward_account - , gov_action - , anchor - ] - -proposal_procedures = nonempty_set - -certificates = nonempty_set - -gov_action = - [ parameter_change_action - // hard_fork_initiation_action - // treasury_withdrawals_action - // no_confidence - // update_committee - // new_constitution - // info_action - ] - -policy_hash = scripthash - -parameter_change_action = (0, gov_action_id / null, protocol_param_update, policy_hash / null) - -hard_fork_initiation_action = (1, gov_action_id / null, [protocol_version]) - -treasury_withdrawals_action = (2, { reward_account => coin }, policy_hash / null) - -no_confidence = (3, gov_action_id / null) - -update_committee = (4, gov_action_id / null, set, { committee_cold_credential => epoch }, unit_interval) - -new_constitution = (5, gov_action_id / null, constitution) - -constitution = - [ anchor - , scripthash / null - ] - -info_action = 6 - -; Constitutional Committee Hot KeyHash: 0 -; Constitutional Committee Hot ScriptHash: 1 -; DRep KeyHash: 2 -; DRep ScriptHash: 3 -; StakingPool KeyHash: 4 -voter = - [ 0, addr_keyhash - // 1, scripthash - // 2, addr_keyhash - // 3, scripthash - // 4, addr_keyhash - ] - -anchor = - [ anchor_url : url - , anchor_data_hash : $hash32 - ] - -; no - 0 -; yes - 1 -; abstain - 2 -vote = 0 .. 2 - -gov_action_id = - [ transaction_id : $hash32 - , gov_action_index : uint - ] - -required_signers = nonempty_set - -transaction_input = [ transaction_id : $hash32 - , index : uint - ] - -transaction_output = legacy_transaction_output / post_alonzo_transaction_output - -legacy_transaction_output = - [ address - , amount : value - , ? datum_hash : $hash32 - ] - -post_alonzo_transaction_output = - { 0 : address - , 1 : value - , ? 2 : datum_option ; datum option - , ? 3 : script_ref ; script reference - } - -script_data_hash = $hash32 -; This is a hash of data which may affect evaluation of a script. -; This data consists of: -; - The redeemers from the transaction_witness_set (the value of field 5). -; - The datums from the transaction_witness_set (the value of field 4). -; - The value in the costmdls map corresponding to the script's language -; (in field 18 of protocol_param_update.) -; (In the future it may contain additional protocol parameters.) -; -; Since this data does not exist in contiguous form inside a transaction, it needs -; to be independently constructed by each recipient. -; -; The bytestring which is hashed is the concatenation of three things: -; redeemers || datums || language views -; The redeemers are exactly the data present in the transaction witness set. -; Similarly for the datums, if present. If no datums are provided, the middle -; field is omitted (i.e. it is the empty/null bytestring). -; -; language views CDDL: -; { * language => script_integrity_data } -; -; This must be encoded canonically, using the same scheme as in -; RFC7049 section 3.9: -; - Maps, strings, and bytestrings must use a definite-length encoding -; - Integers must be as small as possible. -; - The expressions for map length, string length, and bytestring length -; must be as short as possible. -; - The keys in the map must be sorted as follows: -; - If two keys have different lengths, the shorter one sorts earlier. -; - If two keys have the same length, the one with the lower value -; in (byte-wise) lexical order sorts earlier. -; -; For PlutusV1 (language id 0), the language view is the following: -; - the value of costmdls map at key 0 (in other words, the script_integrity_data) -; is encoded as an indefinite length list and the result is encoded as a bytestring. -; (our apologies) -; For example, the script_integrity_data corresponding to the all zero costmodel for V1 -; would be encoded as (in hex): -; 58a89f00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000ff -; - the language ID tag is also encoded twice. first as a uint then as -; a bytestring. (our apologies) -; Concretely, this means that the language version for V1 is encoded as -; 4100 in hex. -; For PlutusV2 (language id 1), the language view is the following: -; - the value of costmdls map at key 1 is encoded as an definite length list. -; For example, the script_integrity_data corresponding to the all zero costmodel for V2 -; would be encoded as (in hex): -; 98af0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 -; - the language ID tag is encoded as expected. -; Concretely, this means that the language version for V2 is encoded as -; 01 in hex. -; For PlutusV3 (language id 2), the language view is the following: -; - the value of costmdls map at key 2 is encoded as a definite length list. -; -; Note that each Plutus language represented inside a transaction must have -; a cost model in the costmdls protocol parameter in order to execute, -; regardless of what the script integrity data is. -; -; Finally, note that in the case that a transaction includes datums but does not -; include the redeemers field, the script data format becomes (in hex): -; [ 80 | datums | A0 ] -; corresponding to a CBOR empty list and an empty map. -; Note that a transaction might include the redeemers field and it to the -; empty map, in which case the user supplied encoding of the empty map is used. - -; address = bytes -; reward_account = bytes - -; address format: -; [ 8 bit header | payload ]; -; -; shelley payment addresses: -; bit 7: 0 -; bit 6: base/other -; bit 5: pointer/enterprise [for base: stake cred is keyhash/scripthash] -; bit 4: payment cred is keyhash/scripthash -; bits 3-0: network id -; -; reward addresses: -; bits 7-5: 111 -; bit 4: credential is keyhash/scripthash -; bits 3-0: network id -; -; byron addresses: -; bits 7-4: 1000 - -; 0000: base address: keyhash28,keyhash28 -; 0001: base address: scripthash28,keyhash28 -; 0010: base address: keyhash28,scripthash28 -; 0011: base address: scripthash28,scripthash28 -; 0100: pointer address: keyhash28, 3 variable length uint -; 0101: pointer address: scripthash28, 3 variable length uint -; 0110: enterprise address: keyhash28 -; 0111: enterprise address: scripthash28 -; 1000: byron address -; 1110: reward account: keyhash28 -; 1111: reward account: scripthash28 -; 1001 - 1101: future formats - -certificate = - [ stake_registration - // stake_deregistration - // stake_delegation - // pool_registration - // pool_retirement - // reg_cert - // unreg_cert - // vote_deleg_cert - // stake_vote_deleg_cert - // stake_reg_deleg_cert - // vote_reg_deleg_cert - // stake_vote_reg_deleg_cert - // auth_committee_hot_cert - // resign_committee_cold_cert - // reg_drep_cert - // unreg_drep_cert - // update_drep_cert - ] - -stake_registration = (0, stake_credential) ; to be deprecated in era after Conway -stake_deregistration = (1, stake_credential) ; to be deprecated in era after Conway -stake_delegation = (2, stake_credential, pool_keyhash) - -; POOL -pool_registration = (3, pool_params) -pool_retirement = (4, pool_keyhash, epoch) - -; numbers 5 and 6 used to be the Genesis and MIR certificates respectively, -; which were deprecated in Conway - -; DELEG -reg_cert = (7, stake_credential, coin) -unreg_cert = (8, stake_credential, coin) -vote_deleg_cert = (9, stake_credential, drep) -stake_vote_deleg_cert = (10, stake_credential, pool_keyhash, drep) -stake_reg_deleg_cert = (11, stake_credential, pool_keyhash, coin) -vote_reg_deleg_cert = (12, stake_credential, drep, coin) -stake_vote_reg_deleg_cert = (13, stake_credential, pool_keyhash, drep, coin) - -; GOVCERT -auth_committee_hot_cert = (14, committee_cold_credential, committee_hot_credential) -resign_committee_cold_cert = (15, committee_cold_credential, anchor / null) -reg_drep_cert = (16, drep_credential, coin, anchor / null) -unreg_drep_cert = (17, drep_credential, coin) -update_drep_cert = (18, drep_credential, anchor / null) - - -delta_coin = int - -credential = - [ 0, addr_keyhash - // 1, scripthash - ] - -drep = - [ 0, addr_keyhash - // 1, scripthash - // 2 ; always abstain - // 3 ; always no confidence - ] - -stake_credential = credential -drep_credential = credential -committee_cold_credential = credential -committee_hot_credential = credential - -pool_params = ( operator: pool_keyhash - , vrf_keyhash: vrf_keyhash - , pledge: coin - , cost: coin - , margin: unit_interval - , reward_account: reward_account - , pool_owners: set - , relays: [* relay] - , pool_metadata: pool_metadata / null - ) - -port = uint .le 65535 -ipv4 = bytes .size 4 -ipv6 = bytes .size 16 -dns_name = tstr .size (0..128) - -single_host_addr = ( 0 - , port / null - , ipv4 / null - , ipv6 / null - ) -single_host_name = ( 1 - , port / null - , dns_name ; An A or AAAA DNS record - ) -multi_host_name = ( 2 - , dns_name ; A SRV DNS record - ) -relay = - [ single_host_addr - // single_host_name - // multi_host_name - ] - -pool_metadata = [url, pool_metadata_hash] -url = tstr .size (0..128) - -withdrawals = { + reward_account => coin } - -protocol_param_update = - { ? 0: coin ; minfee A - , ? 1: coin ; minfee B - , ? 2: uint ; max block body size - , ? 3: uint ; max transaction size - , ? 4: uint ; max block header size - , ? 5: coin ; key deposit - , ? 6: coin ; pool deposit - , ? 7: epoch ; maximum epoch - , ? 8: uint ; n_opt: desired number of stake pools - , ? 9: nonnegative_interval ; pool pledge influence - , ? 10: unit_interval ; expansion rate - , ? 11: unit_interval ; treasury growth rate - , ? 16: coin ; min pool cost - , ? 17: coin ; ada per utxo byte - , ? 18: costmdls ; cost models for script languages - , ? 19: ex_unit_prices ; execution costs - , ? 20: ex_units ; max tx ex units - , ? 21: ex_units ; max block ex units - , ? 22: uint ; max value size - , ? 23: uint ; collateral percentage - , ? 24: uint ; max collateral inputs - , ? 25: pool_voting_thresholds ; pool voting thresholds - , ? 26: drep_voting_thresholds ; DRep voting thresholds - , ? 27: uint ; min committee size - , ? 28: epoch ; committee term limit - , ? 29: epoch ; governance action validity period - , ? 30: coin ; governance action deposit - , ? 31: coin ; DRep deposit - , ? 32: epoch ; DRep inactivity period - } - -pool_voting_thresholds = - [ unit_interval ; motion no confidence - , unit_interval ; committee normal - , unit_interval ; committee no confidence - , unit_interval ; hard fork initiation - , unit_interval ; security relevant parameter voting threshold - ] - -drep_voting_thresholds = - [ unit_interval ; motion no confidence - , unit_interval ; committee normal - , unit_interval ; committee no confidence - , unit_interval ; update constitution - , unit_interval ; hard fork initiation - , unit_interval ; PP network group - , unit_interval ; PP economic group - , unit_interval ; PP technical group - , unit_interval ; PP governance group - , unit_interval ; treasury withdrawal - ] - -transaction_witness_set = - { ? 0: nonempty_set - , ? 1: nonempty_set - , ? 2: nonempty_set - , ? 3: nonempty_set - , ? 4: nonempty_set - , ? 5: redeemers - , ? 6: nonempty_set - , ? 7: nonempty_set - } - -; The real type of plutus_v1_script, plutus_v2_script and plutus_v3_script is bytes. -; However, because we enforce uniqueness when many scripts are supplied, -; we need to hack around for tests in order to avoid generating duplicates, -; since the cddl tool we use for roundtrip testing doesn't generate distinct collections. -plutus_v1_script = distinct -plutus_v2_script = distinct -plutus_v3_script = distinct - -plutus_data = - constr - / { * plutus_data => plutus_data } - / [ * plutus_data ] - / big_int - / bounded_bytes - -big_int = int / big_uint / big_nint -big_uint = #6.2(bounded_bytes) -big_nint = #6.3(bounded_bytes) - -constr = - #6.121([* a]) - / #6.122([* a]) - / #6.123([* a]) - / #6.124([* a]) - / #6.125([* a]) - / #6.126([* a]) - / #6.127([* a]) ; similarly for tag range: 6.1280 .. 6.1400 inclusive - / #6.102([uint, [* a]]) - -redeemers = - [ + [ tag: redeemer_tag, index: uint, data: plutus_data, ex_units: ex_units ] ] -; TODO: Add alternative implementation that reflects the reality more accuratly: -; / { + [ tag: redeemer_tag, index: uint ] => [ data: plutus_data, ex_units: ex_units ] } - -redeemer_tag = - 0 ; Spending - / 1 ; Minting - / 2 ; Certifying - / 3 ; Rewarding - / 4 ; Voting - / 5 ; Proposing - -ex_units = [mem: uint, steps: uint] - -ex_unit_prices = - [ mem_price: nonnegative_interval, step_price: nonnegative_interval ] - -language = 0 ; Plutus v1 - / 1 ; Plutus v2 - / 2 ; Plutus v3 - -potential_languages = 0 .. 255 - -; The format for costmdls is flexible enough to allow adding Plutus built-ins and language -; versions in the future. -; -costmdls = - { ? 0 : [ 166* int ] ; Plutus v1, only 166 integers are used, but more are accepted (and ignored) - , ? 1 : [ 175* int ] ; Plutus v2, only 175 integers are used, but more are accepted (and ignored) - , ? 2 : [ 223* int ] ; Plutus v3, only 223 integers are used, but more are accepted (and ignored) - , ? 3 : [ int ] ; Any 8-bit unsigned number can be used as a key. - } - -transaction_metadatum = - { * transaction_metadatum => transaction_metadatum } - / [ * transaction_metadatum ] - / int - / bytes .size (0..64) - / text .size (0..64) - -transaction_metadatum_label = uint -metadata = { * transaction_metadatum_label => transaction_metadatum } - -auxiliary_data = - metadata ; Shelley - / [ transaction_metadata: metadata ; Shelley-ma - , auxiliary_scripts: [ * native_script ] - ] - / #6.259({ ? 0 => metadata ; Alonzo and beyond - , ? 1 => [ * native_script ] - , ? 2 => [ * plutus_v1_script ] - , ? 3 => [ * plutus_v2_script ] - , ? 4 => [ * plutus_v3_script ] - }) - -vkeywitness = [ $vkey, $signature ] - -bootstrap_witness = - [ public_key : $vkey - , signature : $signature - , chain_code : bytes .size 32 - , attributes : bytes - ] - -native_script = - [ script_pubkey - // script_all - // script_any - // script_n_of_k - // invalid_before - ; Timelock validity intervals are half-open intervals [a, b). - ; This field specifies the left (included) endpoint a. - // invalid_hereafter - ; Timelock validity intervals are half-open intervals [a, b). - ; This field specifies the right (excluded) endpoint b. - ] - -script_pubkey = (0, addr_keyhash) -script_all = (1, [ * native_script ]) -script_any = (2, [ * native_script ]) -script_n_of_k = (3, n: uint, [ * native_script ]) -invalid_before = (4, uint) -invalid_hereafter = (5, uint) - -coin = uint - -multiasset = { + policy_id => { + asset_name => a } } -policy_id = scripthash -asset_name = bytes .size (0..32) - -negInt64 = -9223372036854775808 .. -1 -posInt64 = 1 .. 9223372036854775807 -nonZeroInt64 = negInt64 / posInt64 ; this is the same as the current int64 definition but without zero - -positive_coin = 1 .. 18446744073709551615 - -value = coin / [coin, multiasset] - -mint = multiasset - -int64 = -9223372036854775808 .. 9223372036854775807 - -network_id = 0 / 1 - -epoch = uint - -addr_keyhash = $hash28 -pool_keyhash = $hash28 - -vrf_keyhash = $hash32 -auxiliary_data_hash = $hash32 -pool_metadata_hash = $hash32 - -; To compute a script hash, note that you must prepend -; a tag to the bytes of the script before hashing. -; The tag is determined by the language. -; The tags in the Conway era are: -; "\x00" for multisig scripts -; "\x01" for Plutus V1 scripts -; "\x02" for Plutus V2 scripts -; "\x03" for Plutus V3 scripts -scripthash = $hash28 - -datum_hash = $hash32 -data = #6.24(bytes .cbor plutus_data) - -datum_option = [ 0, $hash32 // 1, data ] - -script_ref = #6.24(bytes .cbor script) - -script = [ 0, native_script // 1, plutus_v1_script // 2, plutus_v2_script // 3, plutus_v3_script ] diff --git a/example/cddl-files/costmdls_min.cddl b/example/cddl-files/costmdls_min.cddl deleted file mode 100644 --- a/example/cddl-files/costmdls_min.cddl +++ /dev/null @@ -1,3 +0,0 @@ -costmdls = - { 0 : [ 11* int ] ; Plutus v1, only 166 integers are used, but more are accepted (and ignored) - } diff --git a/example/cddl-files/issue80-min.cddl b/example/cddl-files/issue80-min.cddl deleted file mode 100644 --- a/example/cddl-files/issue80-min.cddl +++ /dev/null @@ -1,8 +0,0 @@ -main = test -set = [x] -test = [ - 1, - x, - set -] - diff --git a/example/cddl-files/pretty.cddl b/example/cddl-files/pretty.cddl deleted file mode 100644 --- a/example/cddl-files/pretty.cddl +++ /dev/null @@ -1,13 +0,0 @@ -set = [* a] - -a = [ 2*30 2 : uint - , ? 33 : bytes - , 4444 : set - , * 55 => uint - ] - -b = [1,uint,(3,4)] - -c = { 1: a -, 2: b ; hello -} diff --git a/example/cddl-files/shelley.cddl b/example/cddl-files/shelley.cddl deleted file mode 100644 --- a/example/cddl-files/shelley.cddl +++ /dev/null @@ -1,288 +0,0 @@ -; Shelley Types - -block = - [ header - , transaction_bodies : [* transaction_body] - , transaction_witness_sets : [* transaction_witness_set] - , transaction_metadata_set : - { * transaction_index => transaction_metadata } - ]; Valid blocks must also satisfy the following two constraints: - ; 1) the length of transaction_bodies and transaction_witness_sets - ; must be the same - ; 2) every transaction_index must be strictly smaller than the - ; length of transaction_bodies - -transaction = - [ transaction_body - , transaction_witness_set - , transaction_metadata / null - ] - -transaction_index = uint .size 2 - -header = - [ header_body - , body_signature : $kes_signature - ] - -header_body = - [ block_number : uint - , slot : uint - , prev_hash : $hash32 / null - , issuer_vkey : $vkey - , vrf_vkey : $vrf_vkey - , nonce_vrf : $vrf_cert - , leader_vrf : $vrf_cert - , block_body_size : uint - , block_body_hash : $hash32 ; merkle triple root - , operational_cert - , protocol_version - ] - -operational_cert = - ( hot_vkey : $kes_vkey - , sequence_number : uint - , kes_period : uint - , sigma : $signature - ) - -next_major_protocol_version = 3 - -major_protocol_version = 1..next_major_protocol_version - -protocol_version = (major_protocol_version, uint) - -transaction_body = - { 0 : set - , 1 : [* transaction_output] - , 2 : coin ; fee - , 3 : uint ; ttl - , ? 4 : [* certificate] - , ? 5 : withdrawals - , ? 6 : update - , ? 7 : metadata_hash - } - -transaction_input = [ transaction_id : $hash32 - , index : uint - ] - -transaction_output = [address, amount : coin] - -; address = bytes -; reward_account = bytes - -; address format: -; [ 8 bit header | payload ]; -; -; shelley payment addresses: -; bit 7: 0 -; bit 6: base/other -; bit 5: pointer/enterprise [for base: stake cred is keyhash/scripthash] -; bit 4: payment cred is keyhash/scripthash -; bits 3-0: network id -; -; reward addresses: -; bits 7-5: 111 -; bit 4: credential is keyhash/scripthash -; bits 3-0: network id -; -; byron addresses: -; bits 7-4: 1000 - -; 0000: base address: keyhash28,keyhash28 -; 0001: base address: scripthash28,keyhash28 -; 0010: base address: keyhash28,scripthash28 -; 0011: base address: scripthash28,scripthash28 -; 0100: pointer address: keyhash28, 3 variable length uint -; 0101: pointer address: scripthash28, 3 variable length uint -; 0110: enterprise address: keyhash28 -; 0111: enterprise address: scripthash28 -; 1000: byron address -; 1110: reward account: keyhash28 -; 1111: reward account: scripthash28 -; 1001 - 1101: future formats - -certificate = - [ stake_registration - // stake_deregistration - // stake_delegation - // pool_registration - // pool_retirement - // genesis_key_delegation - // move_instantaneous_rewards_cert - ] - -stake_registration = (0, stake_credential) -stake_deregistration = (1, stake_credential) -stake_delegation = (2, stake_credential, pool_keyhash) -pool_registration = (3, pool_params) -pool_retirement = (4, pool_keyhash, epoch) -genesis_key_delegation = (5, genesishash, genesis_delegate_hash, vrf_keyhash) -move_instantaneous_rewards_cert = (6, move_instantaneous_reward) - -move_instantaneous_reward = [ 0 / 1, { * stake_credential => coin } ] -; The first field determines where the funds are drawn from. -; 0 denotes the reserves, 1 denotes the treasury. - -stake_credential = - [ 0, addr_keyhash - // 1, scripthash - ] - -pool_params = ( operator: pool_keyhash - , vrf_keyhash: vrf_keyhash - , pledge: coin - , cost: coin - , margin: unit_interval - , reward_account: reward_account - , pool_owners: set - , relays: [* relay] - , pool_metadata: pool_metadata / null - ) - -port = uint .le 65535 -ipv4 = bytes .size 4 -ipv6 = bytes .size 16 -dns_name = tstr .size (0..64) - -single_host_addr = ( 0 - , port / null - , ipv4 / null - , ipv6 / null - ) -single_host_name = ( 1 - , port / null - , dns_name ; An A or AAAA DNS record - ) -multi_host_name = ( 2 - , dns_name ; A SRV DNS record - ) -relay = - [ single_host_addr - // single_host_name - // multi_host_name - ] - -pool_metadata = [url, metadata_hash] -url = tstr .size (0..64) - -withdrawals = { * reward_account => coin } - -update = [ proposed_protocol_parameter_updates - , epoch - ] - -proposed_protocol_parameter_updates = - { * genesishash => protocol_param_update } - -protocol_param_update = - { ? 0: uint ; minfee A - , ? 1: uint ; minfee B - , ? 2: uint ; max block body size - , ? 3: uint ; max transaction size - , ? 4: uint ; max block header size - , ? 5: coin ; key deposit - , ? 6: coin ; pool deposit - , ? 7: epoch ; maximum epoch - , ? 8: uint ; n_opt: desired number of stake pools - , ? 9: rational ; pool pledge influence - , ? 10: unit_interval ; expansion rate - , ? 11: unit_interval ; treasury growth rate - , ? 12: unit_interval ; d. decentralization constant - , ? 13: $nonce ; extra entropy - , ? 14: [protocol_version] ; protocol version - , ? 15: coin ; min utxo value - } - -transaction_witness_set = - { ?0 => [* vkeywitness ] - , ?1 => [* multisig_script ] - , ?2 => [* bootstrap_witness ] - ; In the future, new kinds of witnesses can be added like this: - ; , ?3 => [* monetary_policy_script ] - ; , ?4 => [* plutus_script ] - } - -transaction_metadatum = - { * transaction_metadatum => transaction_metadatum } - / [ * transaction_metadatum ] - / int - / bytes .size (0..64) - / text .size (0..64) - -transaction_metadatum_label = uint - -transaction_metadata = - { * transaction_metadatum_label => transaction_metadatum } - -vkeywitness = [ $vkey, $signature ] - -bootstrap_witness = - [ public_key : $vkey - , signature : $signature - , chain_code : bytes .size 32 - , attributes : bytes - ] - -multisig_script = - [ multisig_pubkey - // multisig_all - // multisig_any - // multisig_n_of_k - ] - -multisig_pubkey = (0, addr_keyhash) -multisig_all = (1, [ * multisig_script ]) -multisig_any = (2, [ * multisig_script ]) -multisig_n_of_k = (3, n: uint, [ * multisig_script ]) - -coin = uint -epoch = uint - -addr_keyhash = $hash28 -genesis_delegate_hash = $hash28 -pool_keyhash = $hash28 -genesishash = $hash28 - -vrf_keyhash = $hash32 -metadata_hash = $hash32 - -; To compute a script hash, note that you must prepend -; a tag to the bytes of the script before hashing. -; The tag is determined by the language. -; In the Shelley era there is only one such tag, -; namely "\x00" for multisig scripts. -scripthash = $hash28 - -$nonce /= [ 0 // 1, bytes .size 32 ] - -$hash28 /= bytes .size 28 -$hash32 /= bytes .size 32 - -$vkey /= bytes .size 32 - -$vrf_vkey /= bytes .size 32 -$vrf_cert /= [bytes, bytes .size 80] - -$kes_vkey /= bytes .size 32 -$kes_signature /= bytes .size 448 -signkeyKES = bytes .size 64 - -$signature /= bytes .size 64 - -finite_set = [* a] - -;unit_interval = #6.30([uint, uint]) -unit_interval = #6.30([1, 2]) - ; real unit_interval is: #6.30([uint, uint]) - ; but this produces numbers outside the unit interval - ; and can also produce a zero in the denominator - -rational = #6.30([uint, uint]) - -set = [* a] - -address = bytes - -reward_account = bytes diff --git a/example/cddl-files/validator.cddl b/example/cddl-files/validator.cddl deleted file mode 100644 --- a/example/cddl-files/validator.cddl +++ /dev/null @@ -1,13 +0,0 @@ -negative = nint - -anyfloat = f16 / f32 / f64 - -f16 = float16 -f32 = float32 -f64 = float64 - -bs = bstr / bytes -txt = tstr / text - -my_bigint = #6.2(bstr) -my_any = any diff --git a/example/cddl-files/validator/negative/args-to-postlude.cddl b/example/cddl-files/validator/negative/args-to-postlude.cddl deleted file mode 100644 --- a/example/cddl-files/validator/negative/args-to-postlude.cddl +++ /dev/null @@ -1,1 +0,0 @@ -x = uint<3> diff --git a/example/cddl-files/validator/negative/too-few-args.cddl b/example/cddl-files/validator/negative/too-few-args.cddl deleted file mode 100644 --- a/example/cddl-files/validator/negative/too-few-args.cddl +++ /dev/null @@ -1,3 +0,0 @@ -foo = [a, b] - -x = foo diff --git a/example/cddl-files/validator/negative/too-many-args.cddl b/example/cddl-files/validator/negative/too-many-args.cddl deleted file mode 100644 --- a/example/cddl-files/validator/negative/too-many-args.cddl +++ /dev/null @@ -1,3 +0,0 @@ -foo = [a] - -x = foo diff --git a/example/cddl-files/validator/negative/unknown-name.cddl b/example/cddl-files/validator/negative/unknown-name.cddl deleted file mode 100644 --- a/example/cddl-files/validator/negative/unknown-name.cddl +++ /dev/null @@ -1,1 +0,0 @@ -x = a diff --git a/golden/pretty/basic_assign.txt b/golden/pretty/basic_assign.txt new file mode 100644 --- /dev/null +++ b/golden/pretty/basic_assign.txt @@ -0,0 +1,52 @@ +coin = uint + +epoch = uint + +header = + [ header_body + , body_signature : $kes_signature + , test : coin/ null + , withComment : null ; This is a comment + , true + ] + +header_body = [issuer : text] + +$kes_signature = bytes .size 32 + +unit_interval = [0 .. denominator, denominator] + +unit_int = unit_interval<4294967295> + +mysize = 16 + +sz1 = bytes .size 1 + +sz2 = bytes .size 2 + +sz32 = bytes .size 32 + +sz16 = bytes .size mysize + +usz4 = uint .size 4 + +usz8 = uint .size 8 + +group = (usz4, usz8/ mysize, header_body, {* uint => coin}) + +set = [* a] + +set2 = set + +coin_bag = set2 + +big_group = + ( "hello" + , 32 + , 8* 4 + , & group + , uint + , unit_interval<3> + , 5 ... 10 + , h'11aaff3351bc' + ) diff --git a/golden/pretty/conway.txt b/golden/pretty/conway.txt new file mode 100644 --- /dev/null +++ b/golden/pretty/conway.txt @@ -0,0 +1,717 @@ +; crypto.cddl +$hash28 /= bytes .size 28 + +$hash32 /= bytes .size 32 + +$vkey /= bytes .size 32 + +$vrf_vkey /= bytes .size 32 + +$vrf_cert /= [bytes, bytes .size 80] + +$kes_vkey /= bytes .size 32 + +$kes_signature /= bytes .size 448 + +signkeyKES = bytes .size 64 + +$signature /= bytes .size 64 + +; extra.cddl +; Conway era introduces an optional 258 tag for sets, which will become mandatory in the +; second era after Conway. We recommend all the tooling to account for this future breaking +; change sooner rather than later, in order to provide a smooth transition for their users. + +; This is an unordered set. Duplicate elements are not allowed and the order of elements is implementation specific. +set = #6.258([* a])/ [* a] + +; Just like `set`, but must contain at least one element. +nonempty_set = #6.258([+ a])/ [+ a] + +; This is a non-empty ordered set. Duplicate elements are not allowed and the order of elements will be preserved. +nonempty_oset = #6.258([+ a])/ [+ a] + +positive_int = 1 .. 18446744073709551615 + +unit_interval = + #6.30([1, 2]) ; unit_interval = #6.30([uint, uint]) + ; + ; Comment above depicts the actual definition for `unit_interval`. + ; + ; Unit interval is a number in the range between 0 and 1, which + ; means there are two extra constraints: + ; * numerator <= denominator + ; * denominator > 0 + ; + ; Relation between numerator and denominator cannot be expressed in CDDL, which + ; poses a problem for testing. We need to be able to generate random valid data + ; for testing implementation of our encoders/decoders. Which means we cannot use + ; the actual definition here and we hard code the value to 1/2 + +nonnegative_interval = #6.30([uint, positive_int]) + +address = + h'001000000000000000000000000000000000000000000000000000000011000000000000000000000000000000000000000000000000000000' + / h'102000000000000000000000000000000000000000000000000000000022000000000000000000000000000000000000000000000000000000' + / h'203000000000000000000000000000000000000000000000000000000033000000000000000000000000000000000000000000000000000000' + / h'304000000000000000000000000000000000000000000000000000000044000000000000000000000000000000000000000000000000000000' + / h'405000000000000000000000000000000000000000000000000000000087680203' + / h'506000000000000000000000000000000000000000000000000000000087680203' + / h'6070000000000000000000000000000000000000000000000000000000' + / h'7080000000000000000000000000000000000000000000000000000000' + +reward_account = + h'e090000000000000000000000000000000000000000000000000000000' + / h'f0a0000000000000000000000000000000000000000000000000000000' + +bounded_bytes = + bytes .size ( 0 .. 64 + ) ; the real bounded_bytes does not have this limit. it instead has a different + ; limit which cannot be expressed in CDDL. + ; The limit is as follows: + ; - bytes with a definite-length encoding are limited to size 0..64 + ; - for bytes with an indefinite-length CBOR encoding, each chunk is + ; limited to size 0..64 + ; ( reminder: in CBOR, the indefinite-length encoding of bytestrings + ; consists of a token #2.31 followed by a sequence of definite-length + ; encoded bytestrings and a stop code ) + +; a type for distinct values. +; The type parameter must support .size, for example: bytes or uint +distinct = + a .size 8/ a .size 16/ a .size 20/ a .size 24/ a .size 30/ a .size 32 + +; conway.cddl +block = + [ header + , transaction_bodies : [* transaction_body] + , transaction_witness_sets : [* transaction_witness_set] + , auxiliary_data_set : {* transaction_index => auxiliary_data} + , invalid_transactions : [* transaction_index] + ] ; Valid blocks must also satisfy the following two constraints: + ; 1) the length of transaction_bodies and transaction_witness_sets + ; must be the same + ; 2) every transaction_index must be strictly smaller than the + ; length of transaction_bodies + +transaction = + [transaction_body, transaction_witness_set, bool, auxiliary_data/ null] + +transaction_index = uint .size 2 + +header = [header_body, body_signature : $kes_signature] + +header_body = + [ block_number : uint + , slot : uint + , prev_hash : $hash32/ null + , issuer_vkey : $vkey + , vrf_vkey : $vrf_vkey + , vrf_result : $vrf_cert ; replaces nonce_vrf and leader_vrf + , block_body_size : uint + , block_body_hash : $hash32 ; merkle triple root + , operational_cert + , [protocol_version] + ] + +operational_cert = + [ hot_vkey : $kes_vkey + , sequence_number : uint + , kes_period : uint + , sigma : $signature + ] + +next_major_protocol_version = 10 + +major_protocol_version = 1 .. next_major_protocol_version + +protocol_version = (major_protocol_version, uint) + +transaction_body = + { 0 : set ; inputs + , 1 : [* transaction_output] + , 2 : coin ; fee + , ? 3 : uint ; time to live + , ? 4 : certificates + , ? 5 : withdrawals + , ? 7 : auxiliary_data_hash + , ? 8 : uint ; validity interval start + , ? 9 : mint + , ? 11 : script_data_hash + , ? 13 : nonempty_set ; collateral inputs + , ? 14 : required_signers + , ? 15 : network_id + , ? 16 : transaction_output ; collateral return + , ? 17 : coin ; total collateral + , ? 18 : nonempty_set ; reference inputs + , ? 19 : voting_procedures ; New; Voting procedures + , ? 20 : proposal_procedures ; New; Proposal procedures + , ? 21 : coin ; New; current treasury value + , ? 22 : positive_coin ; New; donation + } + +voting_procedures = {+ voter => {+ gov_action_id => voting_procedure}} + +voting_procedure = [vote, anchor/ null] + +proposal_procedure = [deposit : coin, reward_account, gov_action, anchor] + +proposal_procedures = nonempty_set + +certificates = nonempty_set + +gov_action = + [ parameter_change_action + // hard_fork_initiation_action + // treasury_withdrawals_action + // no_confidence + // update_committee + // new_constitution + // info_action + ] + +policy_hash = scripthash + +parameter_change_action = + (0, gov_action_id/ null, protocol_param_update, policy_hash/ null) + +hard_fork_initiation_action = (1, gov_action_id/ null, [protocol_version]) + +treasury_withdrawals_action = (2, {reward_account => coin}, policy_hash/ null) + +no_confidence = (3, gov_action_id/ null) + +update_committee = + ( 4 + , gov_action_id/ null + , set + , {committee_cold_credential => epoch} + , unit_interval + ) + +new_constitution = (5, gov_action_id/ null, constitution) + +constitution = [anchor, scripthash/ null] + +info_action = 6 + +; Constitutional Committee Hot KeyHash: 0 +; Constitutional Committee Hot ScriptHash: 1 +; DRep KeyHash: 2 +; DRep ScriptHash: 3 +; StakingPool KeyHash: 4 +voter = + [ 0, addr_keyhash + // 1, scripthash + // 2, addr_keyhash + // 3, scripthash + // 4, addr_keyhash + ] + +anchor = [anchor_url : url, anchor_data_hash : $hash32] + +; no - 0 +; yes - 1 +; abstain - 2 +vote = 0 .. 2 + +gov_action_id = [transaction_id : $hash32, gov_action_index : uint] + +required_signers = nonempty_set + +transaction_input = [transaction_id : $hash32, index : uint] + +transaction_output = legacy_transaction_output/ post_alonzo_transaction_output + +legacy_transaction_output = [address, amount : value, ? datum_hash : $hash32] + +post_alonzo_transaction_output = + { 0 : address + , 1 : value + , ? 2 : datum_option ; datum option + , ? 3 : script_ref ; script reference + } + +script_data_hash = + $hash32 ; This is a hash of data which may affect evaluation of a script. + ; This data consists of: + ; - The redeemers from the transaction_witness_set (the value of field 5). + ; - The datums from the transaction_witness_set (the value of field 4). + ; - The value in the costmdls map corresponding to the script's language + ; (in field 18 of protocol_param_update.) + ; (In the future it may contain additional protocol parameters.) + ; + ; Since this data does not exist in contiguous form inside a transaction, it needs + ; to be independently constructed by each recipient. + ; + ; The bytestring which is hashed is the concatenation of three things: + ; redeemers || datums || language views + ; The redeemers are exactly the data present in the transaction witness set. + ; Similarly for the datums, if present. If no datums are provided, the middle + ; field is omitted (i.e. it is the empty/null bytestring). + ; + ; language views CDDL: + ; { * language => script_integrity_data } + ; + ; This must be encoded canonically, using the same scheme as in + ; RFC7049 section 3.9: + ; - Maps, strings, and bytestrings must use a definite-length encoding + ; - Integers must be as small as possible. + ; - The expressions for map length, string length, and bytestring length + ; must be as short as possible. + ; - The keys in the map must be sorted as follows: + ; - If two keys have different lengths, the shorter one sorts earlier. + ; - If two keys have the same length, the one with the lower value + ; in (byte-wise) lexical order sorts earlier. + ; + ; For PlutusV1 (language id 0), the language view is the following: + ; - the value of costmdls map at key 0 (in other words, the script_integrity_data) + ; is encoded as an indefinite length list and the result is encoded as a bytestring. + ; (our apologies) + ; For example, the script_integrity_data corresponding to the all zero costmodel for V1 + ; would be encoded as (in hex): + ; 58a89f00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000ff + ; - the language ID tag is also encoded twice. first as a uint then as + ; a bytestring. (our apologies) + ; Concretely, this means that the language version for V1 is encoded as + ; 4100 in hex. + ; For PlutusV2 (language id 1), the language view is the following: + ; - the value of costmdls map at key 1 is encoded as an definite length list. + ; For example, the script_integrity_data corresponding to the all zero costmodel for V2 + ; would be encoded as (in hex): + ; 98af0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 + ; - the language ID tag is encoded as expected. + ; Concretely, this means that the language version for V2 is encoded as + ; 01 in hex. + ; For PlutusV3 (language id 2), the language view is the following: + ; - the value of costmdls map at key 2 is encoded as a definite length list. + ; + ; Note that each Plutus language represented inside a transaction must have + ; a cost model in the costmdls protocol parameter in order to execute, + ; regardless of what the script integrity data is. + ; + ; Finally, note that in the case that a transaction includes datums but does not + ; include the redeemers field, the script data format becomes (in hex): + ; [ 80 | datums | A0 ] + ; corresponding to a CBOR empty list and an empty map. + ; Note that a transaction might include the redeemers field and it to the + ; empty map, in which case the user supplied encoding of the empty map is used. + +; address = bytes +; reward_account = bytes + +; address format: +; [ 8 bit header | payload ]; +; +; shelley payment addresses: +; bit 7: 0 +; bit 6: base/other +; bit 5: pointer/enterprise [for base: stake cred is keyhash/scripthash] +; bit 4: payment cred is keyhash/scripthash +; bits 3-0: network id +; +; reward addresses: +; bits 7-5: 111 +; bit 4: credential is keyhash/scripthash +; bits 3-0: network id +; +; byron addresses: +; bits 7-4: 1000 + +; 0000: base address: keyhash28,keyhash28 +; 0001: base address: scripthash28,keyhash28 +; 0010: base address: keyhash28,scripthash28 +; 0011: base address: scripthash28,scripthash28 +; 0100: pointer address: keyhash28, 3 variable length uint +; 0101: pointer address: scripthash28, 3 variable length uint +; 0110: enterprise address: keyhash28 +; 0111: enterprise address: scripthash28 +; 1000: byron address +; 1110: reward account: keyhash28 +; 1111: reward account: scripthash28 +; 1001 - 1101: future formats + +certificate = + [ stake_registration + // stake_deregistration + // stake_delegation + // pool_registration + // pool_retirement + // reg_cert + // unreg_cert + // vote_deleg_cert + // stake_vote_deleg_cert + // stake_reg_deleg_cert + // vote_reg_deleg_cert + // stake_vote_reg_deleg_cert + // auth_committee_hot_cert + // resign_committee_cold_cert + // reg_drep_cert + // unreg_drep_cert + // update_drep_cert + ] + +stake_registration = (0, stake_credential) + +; to be deprecated in era after Conway +stake_deregistration = (1, stake_credential) + +; to be deprecated in era after Conway +stake_delegation = (2, stake_credential, pool_keyhash) + +; POOL +pool_registration = (3, pool_params) + +pool_retirement = (4, pool_keyhash, epoch) + +; numbers 5 and 6 used to be the Genesis and MIR certificates respectively, +; which were deprecated in Conway + +; DELEG +reg_cert = (7, stake_credential, coin) + +unreg_cert = (8, stake_credential, coin) + +vote_deleg_cert = (9, stake_credential, drep) + +stake_vote_deleg_cert = (10, stake_credential, pool_keyhash, drep) + +stake_reg_deleg_cert = (11, stake_credential, pool_keyhash, coin) + +vote_reg_deleg_cert = (12, stake_credential, drep, coin) + +stake_vote_reg_deleg_cert = (13, stake_credential, pool_keyhash, drep, coin) + +; GOVCERT +auth_committee_hot_cert = + (14, committee_cold_credential, committee_hot_credential) + +resign_committee_cold_cert = (15, committee_cold_credential, anchor/ null) + +reg_drep_cert = (16, drep_credential, coin, anchor/ null) + +unreg_drep_cert = (17, drep_credential, coin) + +update_drep_cert = (18, drep_credential, anchor/ null) + +delta_coin = int + +credential = [0, addr_keyhash// 1, scripthash] + +drep = + [ 0, addr_keyhash + // 1, scripthash + // 2 ; always abstain + // 3 ; always no confidence + ] + +stake_credential = credential + +drep_credential = credential + +committee_cold_credential = credential + +committee_hot_credential = credential + +pool_params = + ( operator : pool_keyhash + , vrf_keyhash : vrf_keyhash + , pledge : coin + , cost : coin + , margin : unit_interval + , reward_account : reward_account + , pool_owners : set + , relays : [* relay] + , pool_metadata : pool_metadata/ null + ) + +port = uint .le 65535 + +ipv4 = bytes .size 4 + +ipv6 = bytes .size 16 + +dns_name = tstr .size (0 .. 128) + +single_host_addr = (0, port/ null, ipv4/ null, ipv6/ null) + +single_host_name = + ( 1 + , port/ null + , dns_name ; An A or AAAA DNS record + ) + +multi_host_name = + ( 2 + , dns_name ; A SRV DNS record + ) + +relay = [single_host_addr// single_host_name// multi_host_name] + +pool_metadata = [url, pool_metadata_hash] + +url = tstr .size (0 .. 128) + +withdrawals = {+ reward_account => coin} + +protocol_param_update = + { ? 0 : coin ; minfee A + , ? 1 : coin ; minfee B + , ? 2 : uint ; max block body size + , ? 3 : uint ; max transaction size + , ? 4 : uint ; max block header size + , ? 5 : coin ; key deposit + , ? 6 : coin ; pool deposit + , ? 7 : epoch ; maximum epoch + , ? 8 : uint ; n_opt: desired number of stake pools + , ? 9 : nonnegative_interval ; pool pledge influence + , ? 10 : unit_interval ; expansion rate + , ? 11 : unit_interval ; treasury growth rate + , ? 16 : coin ; min pool cost + , ? 17 : coin ; ada per utxo byte + , ? 18 : costmdls ; cost models for script languages + , ? 19 : ex_unit_prices ; execution costs + , ? 20 : ex_units ; max tx ex units + , ? 21 : ex_units ; max block ex units + , ? 22 : uint ; max value size + , ? 23 : uint ; collateral percentage + , ? 24 : uint ; max collateral inputs + , ? 25 : pool_voting_thresholds ; pool voting thresholds + , ? 26 : drep_voting_thresholds ; DRep voting thresholds + , ? 27 : uint ; min committee size + , ? 28 : epoch ; committee term limit + , ? 29 : epoch ; governance action validity period + , ? 30 : coin ; governance action deposit + , ? 31 : coin ; DRep deposit + , ? 32 : epoch ; DRep inactivity period + } + +pool_voting_thresholds = + [ unit_interval ; motion no confidence + , unit_interval ; committee normal + , unit_interval ; committee no confidence + , unit_interval ; hard fork initiation + , unit_interval ; security relevant parameter voting threshold + ] + +drep_voting_thresholds = + [ unit_interval ; motion no confidence + , unit_interval ; committee normal + , unit_interval ; committee no confidence + , unit_interval ; update constitution + , unit_interval ; hard fork initiation + , unit_interval ; PP network group + , unit_interval ; PP economic group + , unit_interval ; PP technical group + , unit_interval ; PP governance group + , unit_interval ; treasury withdrawal + ] + +transaction_witness_set = + { ? 0 : nonempty_set + , ? 1 : nonempty_set + , ? 2 : nonempty_set + , ? 3 : nonempty_set + , ? 4 : nonempty_set + , ? 5 : redeemers + , ? 6 : nonempty_set + , ? 7 : nonempty_set + } + +; The real type of plutus_v1_script, plutus_v2_script and plutus_v3_script is bytes. +; However, because we enforce uniqueness when many scripts are supplied, +; we need to hack around for tests in order to avoid generating duplicates, +; since the cddl tool we use for roundtrip testing doesn't generate distinct collections. +plutus_v1_script = distinct + +plutus_v2_script = distinct + +plutus_v3_script = distinct + +plutus_data = + constr + / {* plutus_data => plutus_data} + / [* plutus_data] + / big_int + / bounded_bytes + +big_int = int/ big_uint/ big_nint + +big_uint = #6.2(bounded_bytes) + +big_nint = #6.3(bounded_bytes) + +constr = + #6.121([* a]) + / #6.122([* a]) + / #6.123([* a]) + / #6.124([* a]) + / #6.125([* a]) + / #6.126([* a]) + / #6.127( + [* a] + ) ; similarly for tag range: 6.1280 .. 6.1400 inclusive + / #6.102([uint, [* a]]) + +redeemers = + [ + [ tag : redeemer_tag + , index : uint + , data : plutus_data + , ex_units : ex_units + ] + ] ; TODO: Add alternative implementation that reflects the reality more accuratly: + ; / { + [ tag: redeemer_tag, index: uint ] => [ data: plutus_data, ex_units: ex_units ] } + +redeemer_tag = + 0 ; Spending + / 1 ; Minting + / 2 ; Certifying + / 3 ; Rewarding + / 4 ; Voting + / 5 ; Proposing + +ex_units = [mem : uint, steps : uint] + +ex_unit_prices = + [mem_price : nonnegative_interval, step_price : nonnegative_interval] + +language = + 0 ; Plutus v1 + / 1 ; Plutus v2 + / 2 ; Plutus v3 + +potential_languages = 0 .. 255 + +; The format for costmdls is flexible enough to allow adding Plutus built-ins and language +; versions in the future. +; +costmdls = + { ? 0 : [ 166* int + ] ; Plutus v1, only 166 integers are used, but more are accepted (and ignored) + , ? 1 : [ 175* int + ] ; Plutus v2, only 175 integers are used, but more are accepted (and ignored) + , ? 2 : [ 223* int + ] ; Plutus v3, only 223 integers are used, but more are accepted (and ignored) + , ? 3 : [ int + ] ; Any 8-bit unsigned number can be used as a key. + } + +transaction_metadatum = + {* transaction_metadatum => transaction_metadatum} + / [* transaction_metadatum] + / int + / bytes .size (0 .. 64) + / text .size (0 .. 64) + +transaction_metadatum_label = uint + +metadata = {* transaction_metadatum_label => transaction_metadatum} + +auxiliary_data = + metadata ; Shelley + / [ transaction_metadata : metadata ; Shelley-ma + , auxiliary_scripts : [* native_script] + ] + / #6.259( + { ? 0 => metadata ; Alonzo and beyond + , ? 1 => [* native_script] + , ? 2 => [* plutus_v1_script] + , ? 3 => [* plutus_v2_script] + , ? 4 => [* plutus_v3_script] + } + ) + +vkeywitness = [$vkey, $signature] + +bootstrap_witness = + [ public_key : $vkey + , signature : $signature + , chain_code : bytes .size 32 + , attributes : bytes + ] + +native_script = + [ script_pubkey + // script_all + // script_any + // script_n_of_k + // invalid_before ; Timelock validity intervals are half-open intervals [a, b). + ; This field specifies the left (included) endpoint a. + // invalid_hereafter ; Timelock validity intervals are half-open intervals [a, b). + ; This field specifies the right (excluded) endpoint b. + ] + +script_pubkey = (0, addr_keyhash) + +script_all = (1, [* native_script]) + +script_any = (2, [* native_script]) + +script_n_of_k = (3, n : uint, [* native_script]) + +invalid_before = (4, uint) + +invalid_hereafter = (5, uint) + +coin = uint + +multiasset = {+ policy_id => {+ asset_name => a}} + +policy_id = scripthash + +asset_name = bytes .size (0 .. 32) + +negInt64 = -9223372036854775808 .. -1 + +posInt64 = 1 .. 9223372036854775807 + +nonZeroInt64 = + negInt64 + / posInt64 ; this is the same as the current int64 definition but without zero + +positive_coin = 1 .. 18446744073709551615 + +value = coin/ [coin, multiasset] + +mint = multiasset + +int64 = -9223372036854775808 .. 9223372036854775807 + +network_id = 0/ 1 + +epoch = uint + +addr_keyhash = $hash28 + +pool_keyhash = $hash28 + +vrf_keyhash = $hash32 + +auxiliary_data_hash = $hash32 + +pool_metadata_hash = $hash32 + +; To compute a script hash, note that you must prepend +; a tag to the bytes of the script before hashing. +; The tag is determined by the language. +; The tags in the Conway era are: +; "\x00" for multisig scripts +; "\x01" for Plutus V1 scripts +; "\x02" for Plutus V2 scripts +; "\x03" for Plutus V3 scripts +scripthash = $hash28 + +datum_hash = $hash32 + +data = #6.24(bytes .cbor plutus_data) + +datum_option = [0, $hash32// 1, data] + +script_ref = #6.24(bytes .cbor script) + +script = + [ 0, native_script + // 1, plutus_v1_script + // 2, plutus_v2_script + // 3, plutus_v3_script + ] diff --git a/golden/pretty/costmdls_min.txt b/golden/pretty/costmdls_min.txt new file mode 100644 --- /dev/null +++ b/golden/pretty/costmdls_min.txt @@ -0,0 +1,4 @@ +costmdls = + { 0 : [ 11* int + ] ; Plutus v1, only 166 integers are used, but more are accepted (and ignored) + } diff --git a/golden/pretty/issue80-min.txt b/golden/pretty/issue80-min.txt new file mode 100644 --- /dev/null +++ b/golden/pretty/issue80-min.txt @@ -0,0 +1,5 @@ +main = test + +set = [x] + +test = [1, x, set] diff --git a/golden/pretty/pretty.txt b/golden/pretty/pretty.txt new file mode 100644 --- /dev/null +++ b/golden/pretty/pretty.txt @@ -0,0 +1,10 @@ +set = [* a] + +a = [2*30 2 : uint, ? 33 : bytes, 4444 : set, * 55 => uint] + +b = [1, uint, (3, 4)] + +c = + { 1 : a + , 2 : b ; hello + } diff --git a/src/Codec/CBOR/Cuddle/CBOR/Gen.hs b/src/Codec/CBOR/Cuddle/CBOR/Gen.hs --- a/src/Codec/CBOR/Cuddle/CBOR/Gen.hs +++ b/src/Codec/CBOR/Cuddle/CBOR/Gen.hs @@ -82,6 +82,7 @@ import Test.AntiGen ( AntiGen, antiChoose, + faultyBool, faultyNum, reweigh, runAntiGen, @@ -407,7 +408,7 @@ -- No term was produced, keep the index same x y = scale (\s -> max 0 (s - 1)) $ genNodes i x y optGenKV kNode vNode = sized $ \sz -> - frequency [(100, pure Nothing), (max 0 sz, ann $ tryGenKV 10 m kNode vNode)] + frequency [(1, pure Nothing), (max 0 sz, ann $ tryGenKV 10 m kNode vNode)] in case n of KV kNode vNode _ -> do @@ -558,16 +559,20 @@ -- | Generate a tagged value genTag :: HasCallStack => Word64 -> CTree GenPhase -> CBORGen WrappedTerm genTag t node = do - tag <- liftAntiGen $ faultyNum t - enc <- case tag of - n - | n == 2 || n == 3 -> - -- TODO remove this once `cborg` can decode indefinite bytes in bignums - withTwiddle False $ genForCTree node - _ -> genForCTree node - case enc of - S x -> pure $ S $ TTagged tag x - _ -> error "Tag controller does not correspond to a single term" + omitTag <- liftAntiGen $ faultyBool False + if omitTag + then genForCTree node + else do + tag <- liftAntiGen $ faultyNum t + enc <- case tag of + n + | n == 2 || n == 3 -> + -- TODO remove this once `cborg` can decode indefinite bytes in bignums + withTwiddle False $ genForCTree node + _ -> genForCTree node + case enc of + S x -> pure $ S $ TTagged tag x + _ -> error "Tag controller does not correspond to a single term" genForNode :: HasCallStack => Name -> CBORGen WrappedTerm genForNode = genForCTree <=< resolveRef diff --git a/src/Codec/CBOR/Cuddle/Comments.hs b/src/Codec/CBOR/Cuddle/Comments.hs --- a/src/Codec/CBOR/Cuddle/Comments.hs +++ b/src/Codec/CBOR/Cuddle/Comments.hs @@ -33,13 +33,8 @@ newtype Comment = Comment T.Text deriving (Eq, Ord, Generic, Show) - deriving newtype (Monoid) + deriving newtype (Semigroup, Monoid) deriving anyclass (ToExpr, Hashable) - -instance Semigroup Comment where - Comment "" <> x = x - x <> Comment "" = x - Comment x <> Comment y = Comment $ x <> "\n" <> y unComment :: Comment -> [T.Text] unComment (Comment c) = T.lines c diff --git a/src/Codec/CBOR/Cuddle/Parser.hs b/src/Codec/CBOR/Cuddle/Parser.hs --- a/src/Codec/CBOR/Cuddle/Parser.hs +++ b/src/Codec/CBOR/Cuddle/Parser.hs @@ -23,6 +23,7 @@ charInRange, pCommentBlock, space, + trailingSpace, ) import Control.Applicative.Combinators.NonEmpty qualified as NE import Data.ByteString.Base16 qualified as Base16 @@ -143,7 +144,7 @@ <$> between "<" ">" (NE.sepBy1 (space !*> pType1 <*! space) ",") pType0 :: Parser (Type0 ParserStage) -pType0 = Type0 <$> sepBy1' (space !*> pType1 <*! space) (try "/") +pType0 = Type0 <$> sepBy1' (space !*> pType1 <*! trailingSpace) (try "/") pType1 :: Parser (Type1 ParserStage) pType1 = do diff --git a/src/Codec/CBOR/Cuddle/Parser/Lexer.hs b/src/Codec/CBOR/Cuddle/Parser/Lexer.hs --- a/src/Codec/CBOR/Cuddle/Parser/Lexer.hs +++ b/src/Codec/CBOR/Cuddle/Parser/Lexer.hs @@ -4,8 +4,8 @@ Parser, charInRange, space, + trailingSpace, pComment, - sameLineComment, (|||), pCommentBlock, ) where @@ -13,12 +13,12 @@ import Codec.CBOR.Cuddle.Comments (Comment (..)) import Control.Applicative.Combinators.NonEmpty qualified as NE import Data.Foldable1 (Foldable1 (..)) -import Data.Functor (($>)) import Data.Text (Text) import Data.Void (Void) import Text.Megaparsec ( MonadParsec (..), Parsec, + many, sepEndBy, (<|>), ) @@ -35,7 +35,7 @@ pComment :: Parser Comment pComment = - Comment <$> label "comment" (char ';' *> takeWhileP Nothing validChar <* eol) + Comment . (<> "\n") <$> label "comment" (char ';' *> takeWhileP Nothing validChar <* eol) where validChar = charInRange '\x20' '\x7e' ||| charInRange '\x80' '\x10fffd' @@ -45,6 +45,24 @@ space :: Parser Comment space = mconcat <$> (L.space *> sepEndBy pComment L.space) -sameLineComment :: Parser Comment -sameLineComment = - try ((<>) <$> (L.hspace *> pComment) <*> space) <|> (L.space $> mempty) +-- | Non-greedy space consumer for use at construct boundaries. +-- Consumes a same-line comment and any immediately adjacent comment lines +-- (no blank line gap), then eats trailing blank lines. +-- Does NOT cross blank-line boundaries to consume further comment blocks. +trailingSpace :: Parser Comment +trailingSpace = do + _ <- L.hspace + comments <- sameLineComments + L.space + pure $ mconcat comments + where + sameLineComments = + ( do + c <- pComment + rest <- adjacentComments + pure (c : rest) + ) + <|> (eol *> adjacentComments) + <|> pure [] + + adjacentComments = many (try (L.hspace *> pComment)) diff --git a/src/Codec/CBOR/Cuddle/Pretty.hs b/src/Codec/CBOR/Cuddle/Pretty.hs --- a/src/Codec/CBOR/Cuddle/Pretty.hs +++ b/src/Codec/CBOR/Cuddle/Pretty.hs @@ -15,6 +15,7 @@ XTerm (..), XCddl (..), XRule (..), + renderCDDL, ) where import Codec.CBOR.Cuddle.CDDL @@ -40,12 +41,14 @@ import Data.Foldable (Foldable (..)) import Data.List.NonEmpty qualified as NE import Data.String (IsString, fromString) +import Data.Text (Text) import Data.Text qualified as T import Data.TreeDiff (ToExpr) import Data.Void (Void, absurd) import GHC.Generics (Generic) import Optics.Core ((^.)) import Prettyprinter +import Prettyprinter.Render.Text qualified as PT type data PrettyStage @@ -86,7 +89,7 @@ | PostComment prettyCommentNoBreak :: Comment -> Doc ann -prettyCommentNoBreak = align . vsep . toList . fmap (pretty . ("; " <>)) . unComment +prettyCommentNoBreak = align . vsep . toList . fmap (pretty . (";" <>)) . unComment prettyCommentNoBreakWS :: Comment -> Doc ann prettyCommentNoBreakWS cmt @@ -118,17 +121,15 @@ AssignExt -> "//=" instance Pretty (GenericArg PrettyStage) where - pretty (GenericArg (NE.toList -> l)) - | null (collectComments l) = group . cEncloseSep "<" ">" "," $ fmap pretty l - | otherwise = columnarListing "<" ">" "," . Columnar $ singletonRow . pretty <$> l + pretty (GenericArg l) = + "<" <> concatWith (\x y -> x <> "," <+> y) (pretty <$> NE.toList l) <> ">" instance Pretty (GenericParameter PrettyStage) where pretty (GenericParameter n (PrettyXTerm c)) = pretty n <> prettyCommentNoBreakWS c instance Pretty (GenericParameters PrettyStage) where - pretty (GenericParameters (NE.toList -> l)) - | null (collectComments l) = group . cEncloseSep "<" ">" "," $ pretty <$> l - | otherwise = columnarListing "<" ">" "," . Columnar $ singletonRow . pretty <$> l + pretty (GenericParameters l) = + "<" <> concatWith (\x y -> x <> "," <+> y) (pretty <$> NE.toList l) <> ">" instance Pretty (Type0 PrettyStage) where pretty t0@(Type0 (NE.toList -> l)) = @@ -273,3 +274,8 @@ PTAny -> "any" PTNil -> "nil" PTUndefined -> "undefined" + +-- | Render a pretty-stage CDDL to 'Text', removing trailing whitespace. +renderCDDL :: LayoutOptions -> CDDL PrettyStage -> Text +renderCDDL opts = + PT.renderStrict . removeTrailingWhitespace . layoutPretty opts . pretty diff --git a/src/Codec/CBOR/Cuddle/Pretty/Columnar.hs b/src/Codec/CBOR/Cuddle/Pretty/Columnar.hs --- a/src/Codec/CBOR/Cuddle/Pretty/Columnar.hs +++ b/src/Codec/CBOR/Cuddle/Pretty/Columnar.hs @@ -117,8 +117,11 @@ columnarSepBy :: Doc ann -> Columnar ann -> Doc ann columnarSepBy _ (Columnar []) = mempty columnarSepBy s (Columnar rows@(Row x : xs)) = - prettyRow columnWidths x <> line' <> prettyColumnar (Columnar $ prependRow <$> xs) + prettyRow columnWidths x <> rest where + rest + | null xs = mempty + | otherwise = line' <> prettyColumnar (Columnar $ prependRow <$> xs) prependRow (Row (Cell c al : cs)) = Row $ Cell (s <+> c) al : cs prependRow (Row []) = Row [] columnWidths = diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -4,6 +4,8 @@ import Test.Codec.CBOR.Cuddle.CDDL.Examples qualified as Examples import Test.Codec.CBOR.Cuddle.CDDL.GeneratorSpec qualified as Generator import Test.Codec.CBOR.Cuddle.CDDL.Parser (parserSpec) +import Test.Codec.CBOR.Cuddle.CDDL.Pretty (roundtripSpec) +import Test.Codec.CBOR.Cuddle.CDDL.Pretty.Golden qualified as PrettyGolden import Test.Codec.CBOR.Cuddle.CDDL.Validator qualified as Validator import Test.Codec.CBOR.Cuddle.CDDL.Validator.Golden qualified as ValidatorGolden import Test.Codec.CBOR.Cuddle.Huddle (huddleSpec) @@ -25,6 +27,9 @@ describe "Huddle" huddleSpec describe "Examples" Examples.spec describe "Generator" Generator.spec + describe "Pretty" $ do + describe "Golden" PrettyGolden.spec + describe "Roundtrip" roundtripSpec describe "Validator" $ do describe "Properties" Validator.spec describe "Golden" ValidatorGolden.spec diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Examples.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Examples.hs --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Examples.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Examples.hs @@ -46,18 +46,18 @@ spec = do describe "Validator" $ do describe "Positive" $ do - validateExpectSuccess "example/cddl-files/byron.cddl" - validateExpectSuccess "example/cddl-files/conway.cddl" - validateExpectSuccess "example/cddl-files/shelley.cddl" - validateExpectSuccess "example/cddl-files/basic_assign.cddl" - validateExpectSuccess "example/cddl-files/issue80-min.cddl" - validateExpectSuccess "example/cddl-files/pretty.cddl" + validateExpectSuccess "cddl/byron.cddl" + validateExpectSuccess "cddl/conway.cddl" + validateExpectSuccess "cddl/shelley.cddl" + validateExpectSuccess "cddl/basic_assign.cddl" + validateExpectSuccess "cddl/issue80-min.cddl" + validateExpectSuccess "cddl/pretty.cddl" describe "Negative" $ do - validateExpectFailure "example/cddl-files/validator/negative/unknown-name.cddl" $ + validateExpectFailure "cddl/validator/negative/unknown-name.cddl" $ UnboundReference "a" - validateExpectFailure "example/cddl-files/validator/negative/too-few-args.cddl" $ + validateExpectFailure "cddl/validator/negative/too-few-args.cddl" $ MismatchingArgs "foo" ["a", "b"] - validateExpectFailure "example/cddl-files/validator/negative/too-many-args.cddl" $ + validateExpectFailure "cddl/validator/negative/too-many-args.cddl" $ MismatchingArgs "foo" ["a"] - validateExpectFailure "example/cddl-files/validator/negative/args-to-postlude.cddl" $ + validateExpectFailure "cddl/validator/negative/args-to-postlude.cddl" $ ArgsToPostlude PTUInt [Literal (Value (VUInt 3) mempty)] diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Examples/Huddle.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Examples/Huddle.hs --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Examples/Huddle.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Examples/Huddle.hs @@ -26,6 +26,7 @@ listZeroOrMoreExample, mapNestedValueExample, deeplyNestedRefExample, + taggedUintExample, ) where import Codec.CBOR.Cuddle.CDDL (Name) @@ -43,6 +44,7 @@ idx, mp, opt, + tag, withCBORGen, (...), (=:=), @@ -305,3 +307,9 @@ barRef = "bar" =:= bazRef aRef = "a_ref" =:= barRef listRule = "list_rule" =:= arr [a VInt, a VInt] + +taggedUintExample :: Huddle +taggedUintExample = + collectFrom + [ HIRule $ "root" =:= tag 42 VBytes + ] diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/GeneratorSpec.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/GeneratorSpec.hs --- a/test/Test/Codec/CBOR/Cuddle/CDDL/GeneratorSpec.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/GeneratorSpec.hs @@ -30,12 +30,13 @@ refTermExample, sizeBytesExample, sizeTextExample, + taggedUintExample, ) import Test.Codec.CBOR.Cuddle.CDDL.Validator (expectInvalid, genAndValidateRule) import Test.Hspec (HasCallStack, Spec, describe, runIO, shouldSatisfy, xdescribe) import Test.Hspec.Core.Spec (SpecM) import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck (Gen, Property, Testable (..), counterexample) +import Test.QuickCheck (Gen, Property, Testable (..), classify, counterexample) import Text.Pretty.Simple (pShow) generateCDDL :: CTreeRoot GenPhase -> Gen Term @@ -138,3 +139,33 @@ TBytes "\x01\x02\x03\xff" -> True TBytesI "\x01\x02\x03\xff" -> True _ -> False + + describe "Tagged bytes zapping" $ do + taggedBytesCddl <- tryResolveHuddle taggedUintExample + let env = + GenEnv + { geRoot = mapIndex taggedBytesCddl + , geTwiddle = True + } + prop "labels zapped result" $ do + ZapResult {zrValue} <- + zapAntiGenResult 1 . runCBORGen env $ generateFromName "root" + let + isBytes TBytes {} = True + isBytes TBytesI {} = True + isBytes _ = False + tagOmitted = case zrValue of + TTagged {} -> False + _ -> True + tagChanged = case zrValue of + TTagged t _ -> t /= 42 + _ -> False + innerValueZapped = case zrValue of + TTagged 42 inner -> not (isBytes inner) + _ -> False + pure + . classify tagOmitted "tag omitted" + . classify tagChanged "tag changed" + . classify innerValueZapped "inner value zapped" + $ expectInvalid + (validateCBOR (toStrictByteString $ encodeTerm zrValue) "root" $ mapIndex taggedBytesCddl) diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Pretty.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Pretty.hs --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Pretty.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Pretty.hs @@ -4,6 +4,7 @@ module Test.Codec.CBOR.Cuddle.CDDL.Pretty ( spec, + roundtripSpec, ) where import Codec.CBOR.Cuddle.CDDL ( @@ -25,18 +26,23 @@ import Codec.CBOR.Cuddle.Huddle (HuddleItem (..), a, bstr, (<+), (=:=), (=:~)) import Codec.CBOR.Cuddle.Huddle qualified as H import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..)) -import Codec.CBOR.Cuddle.Pretty (PrettyStage, XRule (..)) +import Codec.CBOR.Cuddle.Parser (pCDDL) +import Codec.CBOR.Cuddle.Pretty (PrettyStage, XRule (..), renderCDDL) import Data.Default.Class (Default (..)) import Data.List.NonEmpty (NonEmpty (..)) import Data.Text qualified as T +import Data.Text.IO qualified as T import Data.TreeDiff (ToExpr (..), prettyExpr) +import Paths_cuddle (getDataFileName) import Prettyprinter (Pretty (..), defaultLayoutOptions, layoutPretty) import Prettyprinter.Render.String (renderString) import Test.Codec.CBOR.Cuddle.CDDL.Gen () import Test.HUnit (assertEqual) -import Test.Hspec (Expectation, Spec, describe, it, shouldBe, xit) +import Test.Hspec (Expectation, Spec, describe, it, runIO, shouldBe, xit) import Test.Hspec.QuickCheck (xprop) import Test.QuickCheck (counterexample) +import Text.Megaparsec (parse) +import Text.Megaparsec.Error (errorBundlePretty) import Prelude hiding ((/)) prettyPrintsTo :: (Pretty a, ToExpr a) => a -> String -> Expectation @@ -164,7 +170,7 @@ :| [] ) ) - `prettyPrintsTo` "[ 1 ; one\n, 2 ; two\n]" + `prettyPrintsTo` "[ 1 ;one\n, 2 ;two\n]" it "two elements with multiline comments" $ T2Array ( Group @@ -182,7 +188,7 @@ :| [] ) ) - `prettyPrintsTo` "[ 1 ; first\n ; multiline comment\n, 2 ; second\n ; multiline comment\n]" + `prettyPrintsTo` "[ 1 ;first\n ;multiline comment\n, 2 ;second\n ;multiline comment\n]" describe "Rule" $ do it "simple assignment" $ Rule @PrettyStage @@ -199,7 +205,7 @@ AssignEq (TOGType (Type0 (Type1 (T2Name (Name "b") mempty) Nothing mempty :| []))) (PrettyXRule "comment") - `prettyPrintsTo` "; comment\na = b" + `prettyPrintsTo` ";comment\na = b" xit "drep" $ drep `prettyPrintsTo` "drep = [0, addr_keyhash // 1, script_hash // 2 // 3]" @@ -214,14 +220,14 @@ `huddlePrettyPrintsTo` "a = true\n" it "simple assignment with comment" $ [HIRule $ H.comment "comment" $ "a" =:= H.bool True] - `huddlePrettyPrintsTo` "; comment\na = true\n" + `huddlePrettyPrintsTo` ";comment\na = true\n" it "comment and reference" $ let b = H.comment "this is rule 'b'" $ "b" =:= H.text "bee" in [ HIRule $ H.comment "comment" $ "a" =:= b ] - `huddlePrettyPrintsTo` "; comment\na = b\n\n; this is rule 'b'\nb = \"bee\"\n" + `huddlePrettyPrintsTo` ";comment\na = b\n\n;this is rule 'b'\nb = \"bee\"\n" it "bstr expects hex, not bytes" $ [ HIRule $ "a" =:= bstr "010200ff" ] @@ -234,18 +240,45 @@ in [ HIRule . H.comment "foo" $ "a" =:= b (H.bool True) ] - `huddlePrettyPrintsTo` "; foo\na = b\n\n; bar\nb = [* a0]\n" + `huddlePrettyPrintsTo` ";foo\na = b\n\n;bar\nb = [* a0]\n" describe "GroupDef" $ do it "simple pair" $ [HIGroup $ "a" =:~ [a $ H.bool True, a $ H.int 3]] `huddlePrettyPrintsTo` "a = (true, 3)\n" it "simple pair with comment" $ [HIGroup $ H.comment "comment" $ "a" =:~ [a $ H.bool True, a $ H.int 3]] - `huddlePrettyPrintsTo` "; comment\na = (true, 3)\n" + `huddlePrettyPrintsTo` ";comment\na = (true, 3)\n" it "comment and reference" $ let b = H.comment "bar" $ "b" =:~ [a $ H.int 2, a $ H.text "bee"] in [ HIGroup . H.comment "foo" $ "a" =:~ [a $ H.bool True, a b] ] - `huddlePrettyPrintsTo` "; foo\na = (true, b)\n\n; bar\nb = (2, \"bee\")\n" + `huddlePrettyPrintsTo` ";foo\na = (true, b)\n\n;bar\nb = (2, \"bee\")\n" + +roundtripSpec :: Spec +roundtripSpec = describe "Roundtrip (parse -> pretty -> parse)" $ do + prettyRoundtrip "basic_assign" "cddl/basic_assign.cddl" + prettyRoundtrip "pretty" "cddl/pretty.cddl" + prettyRoundtrip "costmdls_min" "cddl/costmdls_min.cddl" + prettyRoundtrip "issue80-min" "cddl/issue80-min.cddl" + prettyRoundtrip "conway" "cddl/conway.cddl" + +prettyRoundtrip :: String -> FilePath -> Spec +prettyRoundtrip testName cddlPath = do + original <- runIO $ do + absolutePath <- getDataFileName cddlPath + contents <- T.readFile absolutePath + case parse pCDDL "" contents of + Left err -> fail $ "Failed to parse CDDL:\n" <> errorBundlePretty err + Right x -> pure x + it testName $ do + let + prettyStage1 = mapIndex @_ @_ @PrettyStage original + rendered = renderCDDL defaultLayoutOptions prettyStage1 + case parse pCDDL "" rendered of + Left err -> + fail $ "Failed to re-parse pretty-printed CDDL:\n" <> errorBundlePretty err + Right reparsed -> + let prettyStage2 = mapIndex @_ @_ @PrettyStage reparsed + in prettyStage2 `shouldBe` prettyStage1 diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Pretty/Golden.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Pretty/Golden.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Pretty/Golden.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Codec.CBOR.Cuddle.CDDL.Pretty.Golden (spec) where + +import Codec.CBOR.Cuddle.IndexMappable (mapIndex) +import Codec.CBOR.Cuddle.Parser (pCDDL) +import Codec.CBOR.Cuddle.Pretty (PrettyStage, renderCDDL) +import Control.Monad ((<=<)) +import Data.Text.IO qualified as T +import Paths_cuddle (getDataFileName) +import Prettyprinter (defaultLayoutOptions) +import System.FilePath (()) +import Test.Hspec (Spec, describe, it, runIO) +import Test.Hspec.Golden (Golden (..)) +import Text.Megaparsec (parse) +import Text.Megaparsec.Error (errorBundlePretty) + +prettyPrintGolden :: String -> FilePath -> Spec +prettyPrintGolden testName cddlPath = do + cddl <- runIO $ do + absolutePath <- getDataFileName cddlPath + contents <- T.readFile absolutePath + case parse pCDDL "" contents of + Left err -> fail $ "Failed to parse CDDL:\n" <> errorBundlePretty err + Right x -> pure x + it testName $ + Golden + { goldenFile = "golden" "pretty" testName <> ".txt" + , readFromFile = T.readFile <=< getDataFileName + , writeToFile = \fp txt -> getDataFileName fp >>= (`T.writeFile` txt) + , actualFile = Nothing + , output = renderCDDL defaultLayoutOptions $ mapIndex @_ @_ @PrettyStage cddl + , encodePretty = show + , failFirstTime = False + } + +spec :: Spec +spec = describe "golden" $ do + prettyPrintGolden "basic_assign" "cddl/basic_assign.cddl" + prettyPrintGolden "pretty" "cddl/pretty.cddl" + prettyPrintGolden "costmdls_min" "cddl/costmdls_min.cddl" + prettyPrintGolden "issue80-min" "cddl/issue80-min.cddl" + prettyPrintGolden "conway" "cddl/conway.cddl" diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs @@ -294,13 +294,13 @@ spec :: Spec spec = describe "Validator" $ do describe "Generate and validate from file" $ do - genAndValidateFromFile "example/cddl-files/basic_assign.cddl" - genAndValidateFromFile "example/cddl-files/conway.cddl" - genAndValidateFromFile "example/cddl-files/costmdls_min.cddl" - genAndValidateFromFile "example/cddl-files/issue80-min.cddl" - genAndValidateFromFile "example/cddl-files/pretty.cddl" - genAndValidateFromFile "example/cddl-files/shelley.cddl" - genAndValidateFromFile "example/cddl-files/validator.cddl" + genAndValidateFromFile "cddl/basic_assign.cddl" + genAndValidateFromFile "cddl/conway.cddl" + genAndValidateFromFile "cddl/costmdls_min.cddl" + genAndValidateFromFile "cddl/issue80-min.cddl" + genAndValidateFromFile "cddl/pretty.cddl" + genAndValidateFromFile "cddl/shelley.cddl" + genAndValidateFromFile "cddl/validator.cddl" describe "Term tests" $ do describe "Maps and arrays" $ do describe "Positive" $ do