Merge pull request #726 from IntersectMBO/mgalazyn/refactor/replace-txproposalprocedure-with-pattern

Update TxProposalProcedures type to make invalid states irrepresentable

Author: carbolymer

cardano-api/cardano-api.cabal

@@ -194,7 +194,6 @@ library internal
     data-default-class,
     deepseq,
     directory,
-    dlist,
     either,
     errors,
     filepath,

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

@@ -260,38 +260,38 @@ genSimpleScript =
 -- plutus scripts as well as valid plutus scripts.
 genPlutusScript :: PlutusScriptVersion lang -> Gen (PlutusScript lang)
 genPlutusScript l =
-  case l of 
-    PlutusScriptV1 -> do 
+  case l of
+    PlutusScriptV1 -> do
       PlutusScript _ s <- genPlutusV1Script
       return s
-    PlutusScriptV2 -> do 
+    PlutusScriptV2 -> do
       PlutusScript _ s <- genPlutusV2Script
       return s
-    PlutusScriptV3 -> do 
+    PlutusScriptV3 -> do
       PlutusScript _ s <- genPlutusV3Script
       return s
 
 genValidPlutusScript :: PlutusScriptVersion lang -> Gen (PlutusScript lang)
 genValidPlutusScript l =
-  case l of 
-    PlutusScriptV1 -> do 
+  case l of
+    PlutusScriptV1 -> do
       PlutusScript _ s <- genValidPlutusV1Script
       return s
-    PlutusScriptV2 -> do 
+    PlutusScriptV2 -> do
       PlutusScript _ s <- genValidPlutusV2Script
       return s
-    PlutusScriptV3 -> do 
+    PlutusScriptV3 -> do
       PlutusScript _ s <- genValidPlutusV3Script
       return s
 
 genPlutusV1Script :: Gen (Script PlutusScriptV1)
-genPlutusV1Script = do 
+genPlutusV1Script = do
   v1Script <- Gen.element [v1Loop2024PlutusScriptHexDoubleEncoded,v1Loop2024PlutusScriptHex]
   let v1ScriptBytes = Base16.decodeLenient v1Script
   return . PlutusScript PlutusScriptV1 . PlutusScriptSerialised $ SBS.toShort v1ScriptBytes
 
 genValidPlutusV1Script :: Gen (Script PlutusScriptV1)
-genValidPlutusV1Script = do 
+genValidPlutusV1Script = do
   v1Script <- Gen.element [v1Loop2024PlutusScriptHex]
   let v1ScriptBytes = Base16.decodeLenient v1Script
   return . PlutusScript PlutusScriptV1 . PlutusScriptSerialised $ SBS.toShort v1ScriptBytes
@@ -310,14 +310,14 @@ genValidPlutusV2Script = do
 
 genPlutusV3Script :: Gen (Script PlutusScriptV3)
 genPlutusV3Script = do
-  v3AlwaysSucceedsPlutusScriptHex 
+  v3AlwaysSucceedsPlutusScriptHex
    <- Gen.element [v3AlwaysSucceedsPlutusScriptDoubleEncoded, v3AlwaysSucceedsPlutusScript]
   let v3ScriptBytes = Base16.decodeLenient v3AlwaysSucceedsPlutusScriptHex
   return . PlutusScript PlutusScriptV3 . PlutusScriptSerialised $ SBS.toShort v3ScriptBytes
 
 genValidPlutusV3Script :: Gen (Script PlutusScriptV3)
 genValidPlutusV3Script = do
-  v3AlwaysSucceedsPlutusScriptHex 
+  v3AlwaysSucceedsPlutusScriptHex
    <- Gen.element [v3AlwaysSucceedsPlutusScript]
   let v3ScriptBytes = Base16.decodeLenient v3AlwaysSucceedsPlutusScriptHex
   return . PlutusScript PlutusScriptV3 . PlutusScriptSerialised $ SBS.toShort v3ScriptBytes
@@ -1341,18 +1341,12 @@ genProposals :: Applicative (BuildTxWith build)
              => ConwayEraOnwards era
              -> Gen (TxProposalProcedures build era)
 genProposals w = conwayEraOnwardsConstraints w $ do
-  proposals <- Gen.list (Range.constant 0 10) (genProposal w)
-  proposalsToBeWitnessed <- Gen.subsequence proposals
-  -- We're generating also some extra proposals, purposely not included in the proposals list, which results
-  -- in an invalid state of 'TxProposalProcedures'.
-  -- We're doing it for the complete representation of possible values space of TxProposalProcedures.
-  -- Proposal procedures code in cardano-api should handle such invalid values just fine.
-  extraProposals <- Gen.list (Range.constant 0 10) (genProposal w)
+  proposals <- Gen.list (Range.constant 0 15) (genProposal w)
   let sbe = convert w
-  proposalsWithWitnesses <-
-    forM (extraProposals <> proposalsToBeWitnessed) $ \proposal ->
-      (proposal,) <$> genScriptWitnessForStake sbe
-  pure $ TxProposalProcedures (fromList proposals) (pure $ fromList proposalsWithWitnesses)
+  proposalsWithMaybeWitnesses <-
+    forM proposals $ \proposal ->
+      (proposal,) <$> Gen.maybe (genScriptWitnessForStake sbe)
+  pure $ mkTxProposalProcedures proposalsWithMaybeWitnesses
 
 genProposal :: ConwayEraOnwards era -> Gen (L.ProposalProcedure (ShelleyLedgerEra era))
 genProposal w =

cardano-api/internal/Cardano/Api/Fees.hs

@@ -1535,28 +1535,25 @@ substituteExecutionUnits
           (Featured era (TxVotingProcedures vProcedures (BuildTxWith $ fromList substitutedExecutionUnits)))
 
     mapScriptWitnessesProposals
-      :: Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era))
+      :: Maybe (Featured ConwayEraOnwards era (TxProposalProcedures BuildTx era))
       -> Either
            (TxBodyErrorAutoBalance era)
-           (Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)))
+           (Maybe (Featured ConwayEraOnwards era (TxProposalProcedures BuildTx era)))
     mapScriptWitnessesProposals Nothing = return Nothing
-    mapScriptWitnessesProposals (Just (Featured _ TxProposalProceduresNone)) = return Nothing
-    mapScriptWitnessesProposals (Just (Featured _ (TxProposalProcedures _ ViewTx))) = return Nothing
-    mapScriptWitnessesProposals (Just (Featured era txpp@(TxProposalProcedures osetProposalProcedures (BuildTxWith _)))) = do
+    mapScriptWitnessesProposals (Just (Featured era txpp)) = do
       let eSubstitutedExecutionUnits =
             [ (proposal, updatedWitness)
             | (ix, proposal, scriptWitness) <- indexTxProposalProcedures txpp
             , let updatedWitness = substituteExecUnits ix scriptWitness
             ]
-
       substitutedExecutionUnits <- traverseScriptWitnesses eSubstitutedExecutionUnits
 
-      return $
-        Just
-          ( Featured
-              era
-              (TxProposalProcedures osetProposalProcedures (BuildTxWith $ fromList substitutedExecutionUnits))
-          )
+      pure $
+        Just $
+          Featured era $
+            conwayEraOnwardsConstraints era $
+              mkTxProposalProcedures $
+                second Just <$> substitutedExecutionUnits
 
     mapScriptWitnessesMinting
       :: TxMintValue BuildTx era

cardano-api/internal/Cardano/Api/Tx/Body.hs

@@ -296,9 +296,7 @@ import           Data.Bifunctor (Bifunctor (..))
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString.Base16 as Base16
 import qualified Data.ByteString.Char8 as BSC
-import qualified Data.DList as DList
 import           Data.Foldable (for_)
-import qualified Data.Foldable as Foldable
 import           Data.Function (on)
 import           Data.Functor (($>))
 import           Data.List (sortBy)
@@ -309,7 +307,7 @@ import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe
 import           Data.Monoid
-import           Data.OSet.Strict (OSet, (|><))
+import           Data.OSet.Strict (OSet)
 import qualified Data.OSet.Strict as OSet
 import           Data.Scientific (toBoundedInteger)
 import qualified Data.Sequence.Strict as Seq
@@ -1466,18 +1464,19 @@ indexTxVotingProcedures (TxVotingProcedures vProcedures (BuildTxWith sWitMap)) =
 -- ----------------------------------------------------------------------------
 -- Proposals within transactions (era-dependent)
 --
-
+-- A proposal procedure houses a governance action that is required to be voted into acceptance when submitted.
 data TxProposalProcedures build era where
+  -- | No proposals in transaction..
   TxProposalProceduresNone :: TxProposalProcedures build era
-  -- | Create Tx proposal procedures. Prefer 'mkTxProposalProcedures' smart constructor to using this constructor
-  -- directly.
+  -- | Represents proposal procedures present in transaction.
   TxProposalProcedures
     :: Ledger.EraPParams (ShelleyLedgerEra era)
-    => OSet (L.ProposalProcedure (ShelleyLedgerEra era))
-    -- ^ a set of proposals
-    -> BuildTxWith build (Map (L.ProposalProcedure (ShelleyLedgerEra era)) (ScriptWitness WitCtxStake era))
-    -- ^ a map of witnesses for the proposals. If the proposals are not added to the first constructor
-    -- parameter too, the sky will fall on your head.
+    => OMap
+         (L.ProposalProcedure (ShelleyLedgerEra era))
+         ( BuildTxWith
+             build
+             (Maybe (ScriptWitness WitCtxStake era))
+         )
     -> TxProposalProcedures build era
 
 deriving instance Eq (TxProposalProcedures build era)
@@ -1492,27 +1491,21 @@ mkTxProposalProcedures
   => IsShelleyBasedEra era
   => [(L.ProposalProcedure (ShelleyLedgerEra era), Maybe (ScriptWitness WitCtxStake era))]
   -> TxProposalProcedures build era
-mkTxProposalProcedures proposalsWithWitnessesList = do
-  let (proposals, proposalsWithWitnesses) =
-        bimap toList toList $
-          Foldable.foldl' partitionProposals mempty proposalsWithWitnessesList
+mkTxProposalProcedures proposals = do
   shelleyBasedEraConstraints (shelleyBasedEra @era) $
-    TxProposalProcedures (fromList proposals) (pure $ fromList proposalsWithWitnesses)
- where
-  partitionProposals (ps, pws) (p, Nothing) =
-    (DList.snoc ps p, pws) -- add a proposal to the list
-  partitionProposals (ps, pws) (p, Just w) =
-    (DList.snoc ps p, DList.snoc pws (p, w)) -- add a proposal both to the list and to the witnessed list
+    TxProposalProcedures $
+      fromList $
+        map (second pure) proposals
 
 -- | Index proposal procedures by their order ('Ord').
 indexTxProposalProcedures
   :: TxProposalProcedures BuildTx era
   -> [(ScriptWitnessIndex, L.ProposalProcedure (ShelleyLedgerEra era), ScriptWitness WitCtxStake era)]
 indexTxProposalProcedures TxProposalProceduresNone = []
-indexTxProposalProcedures txpp@(TxProposalProcedures _ (BuildTxWith witnesses)) = do
-  let allProposalsList = toList $ convProposalProcedures txpp
+indexTxProposalProcedures (TxProposalProcedures proposals) = do
+  let allProposalsList = fst <$> toList proposals
   [ (ScriptWitnessIndexProposing $ fromIntegral ix, proposal, scriptWitness)
-    | (proposal, scriptWitness) <- toList witnesses
+    | (proposal, BuildTxWith (Just scriptWitness)) <- toList proposals
     , ix <- maybeToList $ List.elemIndex proposal allProposalsList
     ]
 
@@ -2228,9 +2221,8 @@ fromLedgerProposalProcedures sbe body =
   forShelleyBasedEraInEonMaybe sbe $ \w ->
     conwayEraOnwardsConstraints w $
       Featured w $
-        TxProposalProcedures
-          (body ^. L.proposalProceduresTxBodyL)
-          ViewTx
+        mkTxProposalProcedures
+          (fmap (,Nothing) . toList $ body ^. L.proposalProceduresTxBodyL)
 
 fromLedgerVotingProcedures
   :: ()
@@ -2821,15 +2813,10 @@ convReferenceInputs txInsReference =
     TxInsReference _ refTxins -> fromList $ map toShelleyTxIn refTxins
 
 -- | Returns an OSet of proposals from 'TxProposalProcedures'.
---
--- If 'pws' in 'TxProposalProcedures pps (BuildTxWith pws)' contained proposals not present in 'pps', the'll
--- be sorted ascendingly and snoc-ed to 'pps' if they're not present in 'pps'.
 convProposalProcedures
   :: TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era))
 convProposalProcedures TxProposalProceduresNone = OSet.empty
-convProposalProcedures (TxProposalProcedures pp bWits) = do
-  let wits = fromMaybe mempty $ buildTxWithToMaybe bWits
-  pp |>< fromList (Map.keys wits)
+convProposalProcedures (TxProposalProcedures proposals) = fromList $ fst <$> toList proposals
 
 convVotingProcedures :: TxVotingProcedures build era -> L.VotingProcedures (ShelleyLedgerEra era)
 convVotingProcedures txVotingProcedures =

cardano-api/internal/Cardano/Api/Tx/Compatible.hs

@@ -84,7 +84,7 @@ createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote
                     txb & L.updateTxBodyL .~ SJust ledgerPParamsUpdate
 
           pure (updateTxBody, [])
-        NoPParamsUpdate _ -> do
+        NoPParamsUpdate _ ->
           pure (mempty, [])
         ProposalProcedures conwayOnwards proposalProcedures -> do
           let proposals = convProposalProcedures proposalProcedures

cardano-api/test/cardano-api-test/Test/Cardano/Api/TxBody.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedLists #-}
@@ -105,7 +106,7 @@ prop_roundtrip_txbodycontent_conway_fields = H.property $ do
     :: TxProposalProcedures build era
     -> Maybe [L.ProposalProcedure (ShelleyLedgerEra era)]
   getProposalProcedures TxProposalProceduresNone = Nothing
-  getProposalProcedures txpp@(TxProposalProcedures _ _) = Just . toList $ convProposalProcedures txpp
+  getProposalProcedures (TxProposalProcedures pp) = Just $ fst <$> toList pp
 
 tests :: TestTree
 tests =