Fix CostModel json serialization

Author: lehins

bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs

@@ -170,10 +170,5 @@ preExecutePlutusV2 protocolVersion_ (PlutusScript _ (PlutusScriptSerialised scri
       , PlutusV2.txInfoRedeemers = PlutusV2.fromList []
       }
 
--- The order of the output list is important, but:
---  * This way of flattening it is not guaranteed to always be correct.
---  * There is no way to ensure that the list remains in the correct order.
--- However, we're bound to the type `Cardano.Api.ProtocolParameters.CostModel` which
--- might be changed from a key-value map to something providing stronger guarantees.
 flattenCostModel :: CostModel -> [Integer]
 flattenCostModel (CostModel cm) = cm

cardano-api/gen/Test/Gen/Cardano/Api.hs

@@ -8,8 +8,6 @@ module Test.Gen.Cardano.Api
   , genAlonzoGenesis
   ) where
 
-import           Cardano.Api.Shelley as Api
-
 import qualified Data.Map.Strict as Map
 import           Data.Word (Word64)
 
@@ -63,9 +61,6 @@ genPrice = do
     Nothing -> fail "genPrice: genRational should give us a bounded rational"
     Just p -> pure p
 
-genLanguage :: Gen Alonzo.Language
-genLanguage = return Alonzo.PlutusV1
-
 genPrices :: Gen Alonzo.Prices
 genPrices = do
   prMem'   <- genPrice
@@ -87,15 +82,11 @@ genExUnits = do
 
 genCostModels :: Gen Alonzo.CostModels
 genCostModels = do
-  CostModel cModel <- genCostModel
-  lang <- genLanguage
-  case Alonzo.mkCostModel lang cModel of
-    Left err -> error $ "genCostModels: " <> show err
-    Right alonzoCostModel ->
-      Alonzo.CostModels
-        <$> (conv <$> Gen.list (Range.linear 1 3) (return alonzoCostModel))
-        <*> pure mempty
-        <*> pure mempty
+  alonzoCostModel <- genCostModel
+  Alonzo.CostModels
+    <$> (conv <$> Gen.list (Range.linear 1 3) (return alonzoCostModel))
+    <*> pure mempty
+    <*> pure mempty
  where
   conv :: [Alonzo.CostModel] -> Map.Map Alonzo.Language Alonzo.CostModel
   conv [] = mempty

cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs

@@ -871,14 +871,14 @@ genUpdateProposal =
                      <*> genProtocolParametersUpdate)
     <*> genEpochNo
 
-genCostModel :: Gen CostModel
+genCostModel :: Gen Alonzo.CostModel
 genCostModel = do
   let costModelParams = Alonzo.getCostModelParams Plutus.testingCostModelV1
   eCostModel <- Alonzo.mkCostModel <$> genPlutusLanguage
                                    <*> mapM (const $ Gen.integral (Range.linear 0 5000)) costModelParams
   case eCostModel of
     Left err -> error $ "genCostModel: " <> show err
-    Right cModel -> return . CostModel $ Alonzo.getCostModelParams cModel
+    Right cModel -> return cModel
 
 genPlutusLanguage :: Gen Language
 genPlutusLanguage = Gen.element [PlutusV1, PlutusV2]
@@ -887,7 +887,7 @@ _genCostModels :: Gen (Map AnyPlutusScriptVersion CostModel)
 _genCostModels =
     Gen.map (Range.linear 0 (length plutusScriptVersions))
             ((,) <$> Gen.element plutusScriptVersions
-                 <*> genCostModel)
+                 <*> (Api.fromAlonzoCostModel <$> genCostModel))
   where
     plutusScriptVersions :: [AnyPlutusScriptVersion]
     plutusScriptVersions = [minBound..maxBound]

cardano-api/src/Cardano/Api.hs

@@ -446,6 +446,8 @@ module Cardano.Api (
     ExecutionUnits(..),
     ExecutionUnitPrices(..),
     CostModel(..),
+    toAlonzoCostModel,
+    fromAlonzoCostModel,
 
     -- ** Script addresses
     -- | Making addresses from scripts.

cardano-api/src/Cardano/Api/ProtocolParameters.hs

@@ -79,7 +79,7 @@ import           Data.Either.Combinators (maybeToRight)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (isJust)
-import           Data.Maybe.Strict (StrictMaybe(..))
+import           Data.Maybe.Strict (StrictMaybe (..))
 import           Data.String (IsString)
 import           GHC.Generics
 import           Lens.Micro
@@ -323,7 +323,7 @@ instance FromJSON ProtocolParameters where
         <*> o .: "monetaryExpansion"
         <*> o .: "treasuryCut"
         <*> o .:? "utxoCostPerWord"
-        <*> o .:? "costModels" .!= Map.empty
+        <*> (fmap unCostModels <$> o .:? "costModels") .!= Map.empty
         <*> o .:? "executionUnitPrices"
         <*> o .:? "maxTxExecutionUnits"
         <*> o .:? "maxBlockExecutionUnits"
@@ -355,7 +355,7 @@ instance ToJSON ProtocolParameters where
       , "txFeePerByte"        .= protocolParamTxFeePerByte
       -- Alonzo era:
       , "utxoCostPerWord"        .= protocolParamUTxOCostPerWord
-      , "costModels"             .= protocolParamCostModels
+      , "costModels"             .= CostModels protocolParamCostModels
       , "executionUnitPrices"    .= protocolParamPrices
       , "maxTxExecutionUnits"    .= protocolParamMaxTxExUnits
       , "maxBlockExecutionUnits" .= protocolParamMaxBlockExUnits
@@ -776,9 +776,20 @@ fromAlonzoPrices Alonzo.Prices{Alonzo.prSteps, Alonzo.prMem} =
 
 newtype CostModel = CostModel [Integer]
   deriving (Eq, Show)
-  deriving newtype (ToJSON, FromJSON)
   deriving newtype (ToCBOR, FromCBOR)
 
+newtype CostModels = CostModels { unCostModels :: Map AnyPlutusScriptVersion CostModel }
+  deriving (Eq, Show)
+
+instance FromJSON CostModels where
+  parseJSON v = CostModels . fromAlonzoCostModels <$> parseJSON v
+
+instance ToJSON CostModels where
+  toJSON (CostModels costModels) =
+    case toAlonzoCostModels costModels of
+      Left err -> error $ "Invalid cost model was constructed: " ++ err
+      Right ledgerCostModels -> toJSON ledgerCostModels
+
 data InvalidCostModel = InvalidCostModel CostModel Alonzo.CostModelApplyError
   deriving Show
 

cardano-node-chairman/test/Main.hs

@@ -8,6 +8,7 @@ import           Data.String (IsString (..))
 import           Prelude
 
 import qualified System.Environment as E
+import           System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stdout, utf8)
 import qualified Test.Tasty as T
 import qualified Test.Tasty.Hedgehog as H
 import qualified Test.Tasty.Ingredients as T
@@ -35,6 +36,9 @@ ingredients = T.defaultIngredients
 
 main :: IO ()
 main = do
+  hSetBuffering stdout LineBuffering
+  hSetEncoding stdout utf8
+
   args <- E.getArgs
 
   E.withArgs args $ tests >>= T.defaultMainWithIngredients ingredients

cardano-node/src/Cardano/Node/Queries.hs

@@ -101,7 +101,7 @@ instance ConvertTxId ByronBlock where
 
 instance ConvertTxId (ShelleyBlock protocol c) where
   txIdToRawBytes (ShelleyTxId txId) =
-    Crypto.hashToBytes . Ledger.extractHash . Ledger._unTxId $ txId
+    Crypto.hashToBytes . Ledger.extractHash . Ledger.unTxId $ txId
 
 instance All ConvertTxId xs
       => ConvertTxId (HardForkBlock xs) where