Fix tests, add more explanation to TODOs

carbolymer · ana-pantilie · commit 33edae70ec4f · 2025-09-23T16:13:41.000+03:00
diff --git a/cardano-cli/src/Cardano/CLI/Compatible/Json/Friendly.hs b/cardano-cli/src/Cardano/CLI/Compatible/Json/Friendly.hs
@@ -746,6 +746,7 @@ renderCertificate sbe = \case
               , "anchor " .= mbAnchor
               ]
         -- TODO: Dijkstra
+        -- Pattern is complete for Conway, we're missing COMPLETE pragma for Dijkstra in ledger to remove this error
         _ -> error "renderCertificate: Dijkstra"
  where
   conwayToObject
diff --git a/cardano-cli/src/Cardano/CLI/Environment.hs b/cardano-cli/src/Cardano/CLI/Environment.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
 -- | This module defines constants derived from the environment.
@@ -16,9 +17,11 @@ import Cardano.Api
   , CardanoEra (..)
   , NetworkId (..)
   , NetworkMagic (..)
+  , forEraMaybeEon
   )
 import Cardano.Api.Experimental qualified as Exp
 
+import Data.Type.Equality
 import Data.Word (Word32)
 import System.Environment qualified as IO
 import System.IO qualified as IO
@@ -43,21 +46,16 @@ getEnvCli = do
       , envCliAnyCardanoEra = mCardanoEra
       }
 
-anyCardanoEraToEra :: AnyCardanoEra -> Maybe (Exp.Era Exp.ConwayEra)
-anyCardanoEraToEra (AnyCardanoEra era) =
-  case era of
-    ByronEra -> Nothing
-    ShelleyEra -> Nothing
-    AllegraEra -> Nothing
-    MaryEra -> Nothing
-    AlonzoEra -> Nothing
-    BabbageEra -> Nothing
-    ConwayEra -> Just Exp.ConwayEra
-    DijkstraEra -> Nothing
-
-envCliEra :: EnvCli -> Maybe (Exp.Era Exp.ConwayEra)
+envCliEra
+  :: forall era
+   . Exp.IsEra era
+  => EnvCli
+  -> Maybe (Exp.Era era)
 envCliEra envCli = do
-  anyCardanoEraToEra =<< envCliAnyCardanoEra envCli
+  AnyCardanoEra cardanoEra <- envCliAnyCardanoEra envCli
+  era1 <- forEraMaybeEon cardanoEra
+  Refl <- testEquality era1 (Exp.useEra @era)
+  pure era1
 
 -- | If the environment variable @CARDANO_NODE_NETWORK_ID@ is set, then return the network id therein.
 -- Otherwise, return 'Nothing'.
diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Genesis/CreateTestnetData/Run.hs b/cardano-cli/src/Cardano/CLI/EraBased/Genesis/CreateTestnetData/Run.hs
@@ -28,7 +28,6 @@ where
 import Cardano.Api hiding (ConwayEra)
 import Cardano.Api.Ledger (StandardCrypto, StrictMaybe (SNothing))
 import Cardano.Api.Ledger qualified as L
-import Cardano.Ledger.Compactible qualified as L
 
 import Cardano.CLI.Byron.Genesis (NewDirectory (NewDirectory))
 import Cardano.CLI.Byron.Genesis qualified as Byron
@@ -57,17 +56,20 @@ import Cardano.CLI.Type.Error.NodeCmdError
 import Cardano.CLI.Type.Error.StakePoolCmdError
 import Cardano.CLI.Type.Key
 import Cardano.Crypto.Hash qualified as Crypto
+import Cardano.Ledger.Compactible qualified as L
 import Cardano.Prelude (canonicalEncodePretty)
 import Cardano.Protocol.Crypto qualified as C
 
+import RIO (throwString)
+
 import Control.DeepSeq (NFData, deepseq)
-import Control.Monad (forM, forM_, unless, void, when)
+import Control.Monad (forM, forM_, unless, when)
 import Data.Aeson.Encode.Pretty qualified as Aeson
 import Data.Bifunctor (Bifunctor (..))
 import Data.ByteString (ByteString)
 import Data.ByteString.Char8 qualified as BS
 import Data.ByteString.Lazy.Char8 qualified as LBS
-import Data.Function ((&))
+import Data.Functor
 import Data.Functor.Identity (Identity)
 import Data.ListMap (ListMap (..))
 import Data.Map.Strict (Map)
@@ -82,6 +84,7 @@ import Data.Word (Word64)
 import GHC.Exts (IsList (..))
 import GHC.Generics (Generic)
 import GHC.Num (Natural)
+import GHC.Stack
 import Lens.Micro ((^.))
 import System.Directory
 import System.FilePath ((</>))
@@ -373,9 +376,9 @@ runGenesisCreateTestNetDataCmd
     stuffedUtxoAddrs <-
       liftIO $ Lazy.replicateM (fromIntegral numStuffedUtxo) $ genStuffedAddress network
 
-    let conwayGenesis' =
-          addDRepsToConwayGenesis dRepKeys (map snd delegatorKeys) conwayGenesis
-            & addCommitteeToConwayGenesis ccColdKeys
+    conwayGenesis' <-
+      addDRepsToConwayGenesis dRepKeys (map snd delegatorKeys) conwayGenesis
+        <&> addCommitteeToConwayGenesis ccColdKeys
 
     let stake = second L.ppId . mkDelegationMapEntry <$> delegations
         stakePools = [(L.ppId poolParams', poolParams') | poolParams' <- snd . mkDelegationMapEntry <$> delegations]
@@ -467,15 +470,20 @@ runGenesisCreateTestNetDataCmd
         toCredential (CommitteeColdKeyHash v) = L.KeyHashObj v
 
     addDRepsToConwayGenesis
-      :: [VerificationKey DRepKey]
+      :: forall m
+       . HasCallStack
+      => MonadIO m
+      => [VerificationKey DRepKey]
       -> [VerificationKey StakeKey]
       -> L.ConwayGenesis
-      -> L.ConwayGenesis
-    addDRepsToConwayGenesis dRepKeys stakingKeys conwayGenesis =
-      conwayGenesis
-        { L.cgDelegs = delegs (zip stakingKeys (case dRepKeys of [] -> []; _ -> cycle dRepKeys))
-        , L.cgInitialDReps = initialDReps (L.ucppDRepDeposit $ L.cgUpgradePParams conwayGenesis) dRepKeys
-        }
+      -> m L.ConwayGenesis
+    addDRepsToConwayGenesis dRepKeys stakingKeys conwayGenesis = do
+      cgInitialDReps <- initialDReps (L.ucppDRepDeposit $ L.cgUpgradePParams conwayGenesis) dRepKeys
+      pure $
+        conwayGenesis
+          { L.cgDelegs = delegs (zip stakingKeys (case dRepKeys of [] -> []; _ -> cycle dRepKeys))
+          , L.cgInitialDReps
+          }
      where
       delegs
         :: [(VerificationKey StakeKey, VerificationKey DRepKey)]
@@ -491,17 +499,22 @@ runGenesisCreateTestNetDataCmd
       initialDReps
         :: Lovelace
         -> [VerificationKey DRepKey]
-        -> ListMap (L.Credential L.DRepRole) L.DRepState
-      initialDReps minDeposit =
-        fromList
-          . map
+        -> m (ListMap (L.Credential L.DRepRole) L.DRepState)
+      initialDReps minDeposit verificationKeys = do
+        drepDeposit <-
+          maybe
+            (throwString ("Initial DRep deposit value cannot be compacted: " <> show minDeposit))
+            pure
+            (L.toCompact $ max (L.Coin 1_000_000) minDeposit)
+        pure
+          . fromList
+          $ map
             ( \c ->
                 ( verificationKeyToDRepCredential c
                 , L.DRepState
                     { L.drepExpiry = EpochNo 1_000
                     , L.drepAnchor = SNothing
-                    -- FIXME: toCompactPartial might be unsafe here
-                    , L.drepDeposit = L.toCompactPartial $ max (L.Coin 1_000_000) minDeposit
+                    , L.drepDeposit
                     , L.drepDelegs = Set.empty -- We don't need to populate this field (field "initialDReps"."keyHash-*"."delegators" in the JSON)
                     -- because its content is derived from the "delegs" field ("cgDelegs" above). In other words, when the Conway genesis is applied,
                     -- DRep delegations are computed from the "delegs" field. In the future the "delegators" field may
@@ -510,6 +523,7 @@ runGenesisCreateTestNetDataCmd
                     }
                 )
             )
+            verificationKeys
 
       verificationKeyToDRepCredential
         :: VerificationKey DRepKey -> L.Credential L.DRepRole
diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Governance/Actions/Run.hs b/cardano-cli/src/Cardano/CLI/EraBased/Governance/Actions/Run.hs
@@ -377,7 +377,14 @@ addCostModelsToEraBasedProtocolParametersUpdate
 addCostModelsToEraBasedProtocolParametersUpdate
   AlonzoEraOnwardsDijkstra
   _
-  _ = error "addCostModelsToEraBasedProtocolParametersUpdate: Dijkstra not supported yet" -- TODO: Dijkstra
+  _ =
+    -- TODO: Dijkstra
+    -- Add new protocol parameters from
+    -- https://github.com/IntersectMBO/cardano-ledger/blob/master/eras/dijkstra/src/Cardano/Ledger/Dijkstra/PParams.hs#L75
+    -- to
+    -- https://github.com/IntersectMBO/cardano-api/blob/master/cardano-api/src/Cardano/Api/ProtocolParameters.hs#L190
+    -- and remove this `error`
+    error "addCostModelsToEraBasedProtocolParametersUpdate: Dijkstra not supported yet"
 
 runGovernanceActionTreasuryWithdrawalCmd
   :: forall era e
diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/Run/Hash.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/Run/Hash.hs
@@ -4,16 +4,16 @@
 
 module Test.Cli.Run.Hash where
 
--- import Control.Monad (void)
--- import Control.Monad.Catch (MonadCatch)
--- import Control.Monad.Trans.Resource (MonadResource)
--- import GHC.Stack
+import Control.Monad (void)
+import Control.Monad.Catch (MonadCatch)
+import Control.Monad.Trans.Resource (MonadResource)
+import GHC.Stack
 
 import Test.Cardano.CLI.Util
 
-import Hedgehog (Property)
--- import Hedgehog qualified as H
--- import Hedgehog.Extras qualified as H
+import Hedgehog
+import Hedgehog qualified as H
+import Hedgehog.Extras qualified as H
 
 hprop_hash_trip :: Property
 hprop_hash_trip =
@@ -27,31 +27,30 @@ hprop_hash_trip =
 -- @cardano-cli --text --out-file file2@ yields
 -- similar @file1@ and @file2@ files.
 hash_trip_fun
-  -- :: (MonadTest m, MonadCatch m, MonadResource m, H.MonadBaseControl IO m, HasCallStack)
-  :: String -> m ()
+  :: (MonadTest m, MonadCatch m, MonadResource m, H.MonadBaseControl IO m, HasCallStack)
+  => String -> m ()
 hash_trip_fun input =
-  undefined input
-  -- H.moduleWorkspace "tmp" $ \tempDir -> do
-  --   hashFile <- noteTempFile tempDir "hash.txt"
-
-  --   hash <-
-  --     execCardanoCLI
-  --       [ "hash"
-  --       , "anchor-data"
-  --       , "--text"
-  --       , input
-  --       ]
-
-  --   void $
-  --     execCardanoCLI
-  --       [ "hash"
-  --       , "anchor-data"
-  --       , "--text"
-  --       , input
-  --       , "--out-file"
-  --       , hashFile
-  --       ]
-
-  --   hashFromFile <- H.readFile hashFile
-
-  --   H.diff hash (==) hashFromFile
+  H.moduleWorkspace "tmp" $ \tempDir -> do
+    hashFile <- noteTempFile tempDir "hash.txt"
+
+    hash <-
+      execCardanoCLI
+        [ "hash"
+        , "anchor-data"
+        , "--text"
+        , input
+        ]
+
+    void $
+      execCardanoCLI
+        [ "hash"
+        , "anchor-data"
+        , "--text"
+        , input
+        , "--out-file"
+        , hashFile
+        ]
+
+    hashFromFile <- H.readFile hashFile
+
+    H.diff hash (==) hashFromFile
diff --git a/cardano-cli/test/cardano-cli-test/files/input/conway/create-cardano/genesis.conway.spec.json b/cardano-cli/test/cardano-cli-test/files/input/conway/create-cardano/genesis.conway.spec.json
@@ -25,7 +25,7 @@
   "dRepDeposit": 0,
   "dRepActivity": 0,
   "minFeeRefScriptCostPerByte": 0,
-  "plutusV3CostModel": [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],
+  "plutusV3CostModel": [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],
   "constitution": {
     "anchor": {
       "url": "",
diff --git a/cardano-cli/test/cardano-cli-test/files/input/conway/genesis.conway.spec.json b/cardano-cli/test/cardano-cli-test/files/input/conway/genesis.conway.spec.json
@@ -25,7 +25,7 @@
   "dRepDeposit": 0,
   "dRepActivity": 0,
   "minFeeRefScriptCostPerByte": 0,
-  "plutusV3CostModel": [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],
+  "plutusV3CostModel": [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],
   "constitution": {
     "anchor": {
       "url": "",

Original file line number	Diff line number	Diff line change
`@@ -746,6 +746,7 @@ renderCertificate sbe = \case`
`746`	`746`	`, "anchor " .= mbAnchor`
`747`	`747`	`]`
`748`	`748`	`-- TODO: Dijkstra`
	`749`	`+ -- Pattern is complete for Conway, we're missing COMPLETE pragma for Dijkstra in ledger to remove this error`
`749`	`750`	`_ -> error "renderCertificate: Dijkstra"`
`750`	`751`	`where`
`751`	`752`	`conwayToObject`