Skip to content

Commit

Permalink
test cost model decoder round trip
Browse files Browse the repository at this point in the history
  • Loading branch information
carbolymer authored and palas committed Jul 6, 2024
1 parent e36ea30 commit b298536
Show file tree
Hide file tree
Showing 3 changed files with 107 additions and 62 deletions.
1 change: 1 addition & 0 deletions cardano-api/cardano-api.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -320,6 +320,7 @@ test-suite cardano-api-test
cardano-ledger-core:{cardano-ledger-core, testlib} >=1.8,
cardano-protocol-tpraos,
cardano-slotting,
cborg,
containers,
directory,
hedgehog >=1.1,
Expand Down
43 changes: 27 additions & 16 deletions cardano-api/internal/Cardano/Api/Genesis.hs
Original file line number Diff line number Diff line change
Expand Up @@ -61,9 +61,9 @@ import Cardano.Ledger.Shelley.Genesis (NominalDiffTimeMicro, ShelleyGe
emptyGenesisStaking)
import qualified Cardano.Ledger.Shelley.Genesis as Ledger
import qualified Ouroboros.Consensus.Shelley.Eras as Shelley
import qualified PlutusLedgerApi.Common as V2
import qualified PlutusLedgerApi.V2 as V2

import Control.Monad
import Control.Monad.Trans.Fail.String (errorFail)
import qualified Data.Aeson as A
import Data.ByteString (ByteString)
Expand All @@ -77,6 +77,7 @@ import Data.Map (Map)
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Ratio
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Time as Time
import Data.Typeable
Expand Down Expand Up @@ -239,36 +240,46 @@ decodeAlonzoGenesis (Just aeo) genesisBs = modifyError ("Cannot decode era-sensi
obj@(A.Object _) -> do
-- decode cost model into a map first
costModel :: Map V2.ParamName Int64 <- modifyError ("Decoding cost model object: " <> ) $ fromJsonE obj
setCostModelDefaultValues
. A.toJSON -- convert to an array representation of Int64 values
. fmap snd
. sortOn fst -- ensure proper order of params in the list
. toList
. (`M.union` costModelDefaultValues) -- add default values of missing params
$ costModel

let costModelWithDefaults =
sortOn fst
. toList
$ M.union costModel (M.fromList optionalCostModelDefaultValues)

-- check that we have all required params
unless (allCostModelParams == (fst <$> costModelWithDefaults)) $ do
let allCostModelParamsSet = fromList allCostModelParams
providedCostModelParamsSet = fromList $ fst <$> costModelWithDefaults
throwError $ "Missing V2 Plutus cost model parameters: "
<> show (toList $ S.difference allCostModelParamsSet providedCostModelParamsSet)

-- We have already have required params, we already added optional ones (which are trimmed later
-- if required). Continue processing further in array representation.
setCostModelDefaultValues . A.toJSON $ map snd costModelWithDefaults

A.Array vec
| V.length vec < costModelExpectedLength -> pure . A.Array . V.take costModelExpectedLength $ vec <> (A.toJSON <$> optionalCostModelDefaultValues)
-- here we rely on an assumption that params are in correct order, so that we can take only the
-- required ones for an era
| V.length vec < costModelExpectedLength -> pure . A.Array . V.take costModelExpectedLength $ vec <> (A.toJSON . snd <$> optionalCostModelDefaultValues)
| V.length vec > costModelExpectedLength -> pure . A.Array $ V.take costModelExpectedLength vec

other -> pure other

costModelExpectedLength :: Int
costModelExpectedLength
-- use all available parameters >= conway
| isConwayOnwards = length allCostModelParams
-- use only required params in < conway
| otherwise = L.costModelParamsCount L.PlutusV2 -- Babbage

optionalCostModelDefaultValues :: (Item l ~ Int64, IsList l) => l
optionalCostModelDefaultValues = fromList $ replicate (length optionalV2costModelParams) maxBound

costModelDefaultValues :: Map V2.ParamName Int64
costModelDefaultValues = fromList $ map (, maxBound) allCostModelParams
optionalCostModelDefaultValues :: (Item l ~ (V2.ParamName, Int64), IsList l) => l
optionalCostModelDefaultValues = fromList $ map (, maxBound) optionalV2costModelParams

allCostModelParams :: [V2.ParamName]
allCostModelParams = [minBound..maxBound]

optionalV2costModelParams :: [Text]
optionalV2costModelParams = map V2.showParamName
optionalV2costModelParams :: [V2.ParamName]
optionalV2costModelParams =
[ V2.IntegerToByteString'cpu'arguments'c0
, V2.IntegerToByteString'cpu'arguments'c1
, V2.IntegerToByteString'cpu'arguments'c2
Expand Down
125 changes: 79 additions & 46 deletions cardano-api/test/cardano-api-test/Test/Cardano/Api/Genesis.hs
Original file line number Diff line number Diff line change
Expand Up @@ -13,13 +13,17 @@ import Cardano.Api.Genesis
import qualified Cardano.Api.Ledger as L
import Cardano.Api.Shelley

import qualified Cardano.Binary as CBOR
import qualified Cardano.Binary as CB
import qualified Cardano.Ledger.Alonzo.Genesis as L
import qualified Cardano.Ledger.Binary as L
import qualified Cardano.Ledger.Plutus as L
import qualified PlutusLedgerApi.V2 as V2

import qualified Codec.CBOR.Decoding as CBOR
import qualified Codec.CBOR.Encoding as CBOR
import qualified Codec.CBOR.Write as CBOR
import qualified Data.ByteString.Lazy as LBS
import Data.Either
import Data.Int (Int64)
import qualified Data.Map.Strict as M
import Data.Maybe
Expand All @@ -40,51 +44,49 @@ prop_reading_plutus_v2_era_sensitive_costmodel
prop_reading_plutus_v2_era_sensitive_costmodel aeo cmf = H.propertyOnce $ do
H.noteShow_ $ "Era: " <> pshow aeo
H.noteShow_ $ "Cost model type: " <> show cmf
(genesis, costModelValues) <- loadPlutusV2CostModelFromGenesis aeo (getGenesisFile cmf)
(allCostModels, v2costModelValues) <- H.leftFailM $ loadPlutusV2CostModelFromGenesis (Just aeo) (getGenesisFile cmf)

H.noteShow_ costModelValues
H.noteShow_ v2costModelValues

let isConwayOnwards = isJust $ maybeEon @ConwayEraOnwards @era
last10CostModelValues = reverse . take 10 $ reverse costModelValues
last10CostModelValues = reverse . take 10 $ reverse v2costModelValues

if isConwayOnwards
then do
length costModelValues === 185
length v2costModelValues === 185
if getCostModelFileParamCount cmf < 185
then last10CostModelValues === replicate 10 maxBound
else last10CostModelValues === replicate 10 1
else
length costModelValues === 175

let genesisBs = CBOR.serialize genesis
genesis' <- H.leftFail $ decodeCborInEraAlonzoGenesis aeo genesisBs
genesis' === genesis

decodeCborInEraAlonzoGenesis
:: forall era. AlonzoEraOnwards era
-> LBS.ByteString
-> Either L.DecoderError L.AlonzoGenesis
decodeCborInEraAlonzoGenesis aeo = CBOR.decodeFullDecoder "AlonzoGenesis" fromEraCbor'
where
fromEraCbor' :: CBOR.Decoder s L.AlonzoGenesis
fromEraCbor' = alonzoEraOnwardsConstraints aeo $ do
-- error $ show $ eraProtVerLow (alonzoEraOnwardsToShelleyBasedEra aeo)
L.fromEraCBOR @(ShelleyLedgerEra era)
length v2costModelValues === 175

let allCostModelsBs = encodeCborInEraCostModels aeo allCostModels
allCostModels' <- H.leftFail $ decodeCborInEraCostModels aeo allCostModelsBs
allCostModels' === allCostModels

prop_reading_plutus_v2_costmodel
:: PlutusV2CostModelFormat
-> Property
prop_reading_plutus_v2_costmodel cmf = H.propertyOnce $ do
-- TODO
True === True
H.noteShow_ $ "Cost model type: " <> show cmf
mCostModelValues <- fmap snd <$> loadPlutusV2CostModelFromGenesis Nothing (getGenesisFile cmf)

H.noteShow_ mCostModelValues

if cmf == Map175
then do
H.assertWith mCostModelValues isLeft
else do
costModelValues <- H.leftFail mCostModelValues
length costModelValues === getCostModelFileParamCount cmf

prop_verify_plutus_v2_costmodel :: Property
prop_verify_plutus_v2_costmodel = H.propertyOnce $ do
let lastParamName = maxBound
last10Params = (toEnum . subtract 9 $ fromEnum lastParamName) `enumFromTo` lastParamName :: [V2.ParamName]
H.note_ "Check that last 10 params of PlutusV2 cost models are exactly the ones we expect"
-- TODO add comment why we need this
-- The conditional logic of trimming conway parameters in babbage relies on the fact that last 10 V2 params
-- are those below
last10Params ===
[ V2.IntegerToByteString'cpu'arguments'c0
, V2.IntegerToByteString'cpu'arguments'c1
Expand All @@ -106,7 +108,7 @@ data PlutusV2CostModelFormat
| Map185
| Array175
| Array185
deriving Show
deriving (Eq, Show)

getGenesisFile :: PlutusV2CostModelFormat -> FilePath
getGenesisFile = ("./test/cardano-api-test/files/input/genesis/spec.alonzo-v2-cost-model-" <>) . \case
Expand All @@ -126,34 +128,65 @@ loadPlutusV2CostModelFromGenesis
:: HasCallStack
=> MonadIO m
=> MonadTest m
=> AlonzoEraOnwards era
=> Maybe (AlonzoEraOnwards era)
-> FilePath
-> m (L.AlonzoGenesis, [Int64])
loadPlutusV2CostModelFromGenesis aeo filePath = withFrozenCallStack $ do
-> m (Either String (L.CostModels, [Int64]))
loadPlutusV2CostModelFromGenesis mAeo filePath = withFrozenCallStack . runExceptT $ do
genesisBs <- H.lbsReadFile filePath
genesis <- H.leftFailM . runExceptT $ decodeAlonzoGenesis (Just aeo) genesisBs
fmap ((genesis,) . L.getCostModelParams)
. H.nothingFail
costModels <- modifyError show $ L.agCostModels <$> decodeAlonzoGenesis mAeo genesisBs
liftEither
. fmap ((costModels,) . L.getCostModelParams)
. maybe (Left "No PlutusV2 model found") Right
. M.lookup L.PlutusV2
. L.costModelsValid
$ L.agCostModels genesis
$ L.costModelsValid costModels

decodeCborInEraCostModels
:: forall era. AlonzoEraOnwards era
-> LBS.ByteString
-> Either L.DecoderError L.CostModels
decodeCborInEraCostModels aeo = CB.decodeFullDecoder "AlonzoGenesis" fromEraCbor'
where
fromEraCbor' :: CBOR.Decoder s L.CostModels
fromEraCbor' = alonzoEraOnwardsConstraints aeo $ L.fromEraCBOR @(ShelleyLedgerEra era)

encodeCborInEraCostModels
:: forall era. AlonzoEraOnwards era
-> L.CostModels
-> LBS.ByteString
encodeCborInEraCostModels aeo = CBOR.toLazyByteString . toEraCbor'
where
toEraCbor' :: L.CostModels -> CBOR.Encoding
toEraCbor' = alonzoEraOnwardsConstraints aeo $ L.toEraCBOR @(ShelleyLedgerEra era)

-- * List all test cases

tests :: TestTree
tests = testGroup "Test.Cardano.Api.Genesis"
[ testProperty "Read Alonzo genesis with PlutusV2 cost model map with 175 params - Babbage" $ prop_reading_plutus_v2_era_sensitive_costmodel AlonzoEraOnwardsBabbage Map175
, testProperty "Read Alonzo genesis with PlutusV2 cost model map with 175 params - Conway" $ prop_reading_plutus_v2_era_sensitive_costmodel AlonzoEraOnwardsConway Map175
, testProperty "Read Alonzo genesis with PlutusV2 cost model map with 175 params - era insensitive" $ prop_reading_plutus_v2_costmodel Map175
, testProperty "Read Alonzo genesis with PlutusV2 cost model map with 185 params - Babbage" $ prop_reading_plutus_v2_era_sensitive_costmodel AlonzoEraOnwardsBabbage Map185
, testProperty "Read Alonzo genesis with PlutusV2 cost model map with 185 params - Conway" $ prop_reading_plutus_v2_era_sensitive_costmodel AlonzoEraOnwardsConway Map185
, testProperty "Read Alonzo genesis with PlutusV2 cost model map with 185 params - era insensitive" $ prop_reading_plutus_v2_costmodel Map185
, testProperty "Read Alonzo genesis with PlutusV2 cost model array with 175 params - Babbage" $ prop_reading_plutus_v2_era_sensitive_costmodel AlonzoEraOnwardsBabbage Array175
, testProperty "Read Alonzo genesis with PlutusV2 cost model array with 175 params - Conway" $ prop_reading_plutus_v2_era_sensitive_costmodel AlonzoEraOnwardsConway Array175
, testProperty "Read Alonzo genesis with PlutusV2 cost model array with 175 params - era insensitive" $ prop_reading_plutus_v2_costmodel Array175
, testProperty "Read Alonzo genesis with PlutusV2 cost model array with 185 params - Babbage" $ prop_reading_plutus_v2_era_sensitive_costmodel AlonzoEraOnwardsBabbage Array185
, testProperty "Read Alonzo genesis with PlutusV2 cost model array with 185 params - Conway" $ prop_reading_plutus_v2_era_sensitive_costmodel AlonzoEraOnwardsConway Array185
, testProperty "Read Alonzo genesis with PlutusV2 cost model array with 185 params - era insensitive" $ prop_reading_plutus_v2_costmodel Array185
, testProperty "Make sure that last 10 PlutusV2 cost model parameters are the ones we expect" prop_verify_plutus_v2_costmodel
[ testProperty "Read Alonzo genesis with PlutusV2 cost model map with 175 params - Babbage" $
prop_reading_plutus_v2_era_sensitive_costmodel AlonzoEraOnwardsBabbage Map175
, testProperty "Read Alonzo genesis with PlutusV2 cost model map with 175 params - Conway" $
prop_reading_plutus_v2_era_sensitive_costmodel AlonzoEraOnwardsConway Map175
, testProperty "Read Alonzo genesis with PlutusV2 cost model map with 175 params - era insensitive" $
prop_reading_plutus_v2_costmodel Map175
, testProperty "Read Alonzo genesis with PlutusV2 cost model map with 185 params - Babbage" $
prop_reading_plutus_v2_era_sensitive_costmodel AlonzoEraOnwardsBabbage Map185
, testProperty "Read Alonzo genesis with PlutusV2 cost model map with 185 params - Conway" $
prop_reading_plutus_v2_era_sensitive_costmodel AlonzoEraOnwardsConway Map185
, testProperty "Read Alonzo genesis with PlutusV2 cost model map with 185 params - era insensitive" $
prop_reading_plutus_v2_costmodel Map185
, testProperty "Read Alonzo genesis with PlutusV2 cost model array with 175 params - Babbage" $
prop_reading_plutus_v2_era_sensitive_costmodel AlonzoEraOnwardsBabbage Array175
, testProperty "Read Alonzo genesis with PlutusV2 cost model array with 175 params - Conway" $
prop_reading_plutus_v2_era_sensitive_costmodel AlonzoEraOnwardsConway Array175
, testProperty "Read Alonzo genesis with PlutusV2 cost model array with 175 params - era insensitive" $
prop_reading_plutus_v2_costmodel Array175
, testProperty "Read Alonzo genesis with PlutusV2 cost model array with 185 params - Babbage" $
prop_reading_plutus_v2_era_sensitive_costmodel AlonzoEraOnwardsBabbage Array185
, testProperty "Read Alonzo genesis with PlutusV2 cost model array with 185 params - Conway" $
prop_reading_plutus_v2_era_sensitive_costmodel AlonzoEraOnwardsConway Array185
, testProperty "Read Alonzo genesis with PlutusV2 cost model array with 185 params - era insensitive" $
prop_reading_plutus_v2_costmodel Array185
, testProperty "Make sure that last 10 PlutusV2 cost model parameters are the ones we expect"
prop_verify_plutus_v2_costmodel
]

0 comments on commit b298536

Please sign in to comment.