Revert to using an ill-defined TxProposalProcedures constructor

cardano-api/cardano-api.cabal

@@ -184,6 +184,7 @@ library internal
     data-default-class,
     deepseq,
     directory,
+    dlist,
     either,
     errors,
     filepath,
@@ -196,7 +197,6 @@ library internal
     mtl,
     network,
     optparse-applicative-fork,
-    ordered-containers,
     ouroboros-consensus ^>=0.20,
     ouroboros-consensus-cardano ^>=0.18,
     ouroboros-consensus-diffusion ^>=0.17,
@@ -327,7 +327,6 @@ test-suite cardano-api-test
     hedgehog-quickcheck,
     interpolatedstring-perl6,
     mtl,
-    ordered-containers,
     ouroboros-consensus,
     ouroboros-consensus-cardano,
     ouroboros-consensus-protocol,

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

@@ -1127,11 +1127,17 @@ genProposals :: Applicative (BuildTxWith build)
              -> 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)
   let sbe = conwayEraOnwardsToShelleyBasedEra w
-  proposalsWithWitnesses <- fmap fromList . forM proposals $ \proposal -> do
-    mWitness <- Gen.maybe (genScriptWitnessForStake sbe)
-    pure (proposal, pure mWitness)
-  pure $ TxProposalProcedures proposalsWithWitnesses
+  proposalsWithWitnesses <-
+    forM (extraProposals <> proposalsToBeWitnessed) $ \proposal ->
+      (proposal,) <$> genScriptWitnessForStake sbe
+  pure $ TxProposalProcedures (fromList proposals) (pure $ fromList proposalsWithWitnesses)
 
 genProposal :: ConwayEraOnwards era -> Gen (L.ProposalProcedure (ShelleyLedgerEra era))
 genProposal w =

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

@@ -8,6 +8,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
 
 -- | Fee calculation
 module Cardano.Api.Fees
@@ -84,10 +85,10 @@ import           Data.Bifunctor (bimap, first, second)
 import           Data.ByteString.Short (ShortByteString)
 import           Data.Function ((&))
 import qualified Data.List as List
-import qualified Data.Map.Ordered as OMap
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe
+import           Data.OSet.Strict (OSet)
 import qualified Data.OSet.Strict as OSet
 import           Data.Ratio
 import           Data.Set (Set)
@@ -250,11 +251,7 @@ estimateBalancedTxBody
         proposalProcedures :: OSet.OSet (L.ProposalProcedure (ShelleyLedgerEra era))
         proposalProcedures =
           maryEraOnwardsConstraints w $
-            case unFeatured <$> txProposalProcedures txbodycontent1 of
-              Nothing -> mempty
-              Just TxProposalProceduresNone -> mempty
-              Just (TxProposalProcedures pp) ->
-                fromList $ (map fst . toList) pp
+            maybe mempty (convProposalProcedures . unFeatured) (txProposalProcedures txbodycontent1)
 
         totalDeposits :: L.Coin
         totalDeposits =
@@ -1573,29 +1570,32 @@ substituteExecutionUnits
           (Featured era (TxVotingProcedures vProcedures (BuildTxWith $ fromList substitutedExecutionUnits)))
 
     mapScriptWitnessesProposals
-      :: forall build
-       . Applicative (BuildTxWith build)
-      => Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era))
+      :: Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era))
       -> Either
           (TxBodyErrorAutoBalance era)
           (Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)))
-    mapScriptWitnessesProposals Nothing = pure Nothing
-    mapScriptWitnessesProposals (Just (Featured _ TxProposalProceduresNone)) = pure Nothing
-    mapScriptWitnessesProposals (Just (Featured _ (TxProposalProcedures proposalProcedures))) = do
-      let substitutedExecutionUnits =
-            [ (proposal, mUpdatedWitness)
-            | (proposal, BuildTxWith mScriptWitness) <- toList proposalProcedures
-            , index <- maybeToList $ OMap.findIndex proposal proposalProcedures
-            , let mUpdatedWitness = substituteExecUnits (ScriptWitnessIndexProposing $ fromIntegral index) <$> mScriptWitness
+    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 sWitMap)))) = do
+      let proposals :: OSet (L.ProposalProcedure (ShelleyLedgerEra era))
+          proposals = shelleyBasedEraConstraints (shelleyBasedEra @era) $ convProposalProcedures txpp
+          allProposalsList = toList proposals
+          eSubstitutedExecutionUnits =
+            [ (proposal, updatedWitness)
+            | (proposal, scriptWitness) <- toList sWitMap
+            , index <- maybeToList $ List.elemIndex proposal allProposalsList
+            , let updatedWitness = substituteExecUnits (ScriptWitnessIndexProposing $ fromIntegral index) scriptWitness
             ]
-      final <- fmap fromList . forM substitutedExecutionUnits $ \(p, meExecUnits) ->
-        case meExecUnits of
-          Nothing -> pure (p, pure Nothing)
-          Just eExecUnits -> do
-            -- TODO aggregate errors instead of shortcircuiting here
-            execUnits <- eExecUnits
-            pure (p, pure $ pure execUnits)
-      pure . mkFeatured $ TxProposalProcedures final
+
+      substitutedExecutionUnits <- traverseScriptWitnesses eSubstitutedExecutionUnits
+
+      return $
+        Just
+          ( Featured
+              era
+              (TxProposalProcedures osetProposalProcedures (BuildTxWith $ fromList substitutedExecutionUnits))
+          )
 
     mapScriptWitnessesMinting
       :: TxMintValue BuildTx era
@@ -1624,8 +1624,8 @@ substituteExecutionUnits
                 fromList final
 
 traverseScriptWitnesses
-  :: [(a, Either l r)]
-  -> Either l [(a, r)]
+  :: [(a, Either (TxBodyErrorAutoBalance era) (ScriptWitness ctx era))]
+  -> Either (TxBodyErrorAutoBalance era) [(a, ScriptWitness ctx era)]
 traverseScriptWitnesses =
   traverse (\(item, eScriptWitness) -> eScriptWitness >>= (\sWit -> Right (item, sWit)))
 

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

@@ -11,7 +11,6 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -115,6 +114,8 @@ module Cardano.Api.Tx.Body
   , TxVotingProcedures (..)
   , mkTxVotingProcedures
   , TxProposalProcedures (..)
+  , mkTxProposalProcedures
+  , convProposalProcedures
 
     -- ** Building vs viewing transactions
   , BuildTxWith (..)
@@ -242,19 +243,19 @@ import qualified Data.Aeson.Types as Aeson
 import           Data.Bifunctor (Bifunctor (..))
 import           Data.ByteString (ByteString)
 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)
 import qualified Data.List as List
 import qualified Data.List.NonEmpty as NonEmpty
-import           Data.Map.Ordered.Strict (OMap)
-import qualified Data.Map.Ordered.Strict as OMap
 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           Data.Scientific (toBoundedInteger)
 import qualified Data.Sequence.Strict as Seq
 import           Data.Set (Set)
@@ -1272,17 +1273,41 @@ mkTxVotingProcedures votingProcedures = do
 
 data TxProposalProcedures build era where
   TxProposalProceduresNone :: TxProposalProcedures build era
+  -- | Create Tx proposal procedures. Prefer 'mkTxProposalProcedures' smart constructor to using this constructor
+  -- directly.
   TxProposalProcedures
     :: Ledger.EraPParams (ShelleyLedgerEra era)
-    => OMap
-        (L.ProposalProcedure (ShelleyLedgerEra era))
-        (BuildTxWith build (Maybe (ScriptWitness WitCtxStake 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.
     -> TxProposalProcedures build era
 
 deriving instance Eq (TxProposalProcedures build era)
 
 deriving instance Show (TxProposalProcedures build era)
 
+-- | A smart constructor for 'TxProposalProcedures'. It makes sure that the value produced is consistent - the
+-- witnessed proposals are also present in the first constructor parameter.
+mkTxProposalProcedures
+  :: forall era build
+   . Applicative (BuildTxWith build)
+  => 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, mempty) proposalsWithWitnessesList
+  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
+
 -- ----------------------------------------------------------------------------
 -- Transaction body content
 --
@@ -1857,21 +1882,12 @@ fromLedgerProposalProcedures
   -> Ledger.TxBody (ShelleyLedgerEra era)
   -> Maybe (Featured ConwayEraOnwards era (TxProposalProcedures ViewTx era))
 fromLedgerProposalProcedures sbe body =
-  forShelleyBasedEraInEonMaybe sbe $ \w -> do
-    let lpp
-          :: [ ( L.ProposalProcedure (ShelleyLedgerEra era)
-               , BuildTxWith ViewTx (Maybe (ScriptWitness WitCtxStake era))
-               )
-             ]
-        lpp =
-          conwayEraOnwardsConstraints w $
-            map (,ViewTx) $
-              toList $
-                body ^. L.proposalProceduresTxBodyL
-    Featured w $
-      conwayEraOnwardsConstraints w $
-        TxProposalProcedures $
-          fromList lpp
+  forShelleyBasedEraInEonMaybe sbe $ \w ->
+    conwayEraOnwardsConstraints w $
+      Featured w $
+        TxProposalProcedures
+          (body ^. L.proposalProceduresTxBodyL)
+          ViewTx
 
 fromLedgerVotingProcedures
   :: ()
@@ -2445,16 +2461,20 @@ convReferenceInputs txInsReference =
     TxInsReferenceNone -> mempty
     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
   :: forall era build
    . IsShelleyBasedEra era
   => TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era))
 convProposalProcedures TxProposalProceduresNone =
   shelleyBasedEraConstraints (shelleyBasedEra @era) mempty
-convProposalProcedures (TxProposalProcedures pp) =
-  shelleyBasedEraConstraints (shelleyBasedEra @era) $
-    fromList $
-      fst <$> toList pp
+convProposalProcedures (TxProposalProcedures pp bWits) =
+  shelleyBasedEraConstraints (shelleyBasedEra @era) $ do
+    let wits = fromMaybe mempty $ buildTxWithToMaybe bWits
+    pp |>< fromList (Map.keys wits)
 
 convVotingProcedures :: TxVotingProcedures build era -> L.VotingProcedures (ShelleyLedgerEra era)
 convVotingProcedures txVotingProcedures =
@@ -3278,11 +3298,14 @@ collectTxBodyScriptWitnesses
       :: TxProposalProcedures BuildTx era
       -> [(ScriptWitnessIndex, AnyScriptWitness era)]
     scriptWitnessesProposing TxProposalProceduresNone = []
-    scriptWitnessesProposing (TxProposalProcedures proposalProcedures) =
-      [ (ScriptWitnessIndexProposing (fromIntegral ix), AnyScriptWitness witness)
-      | (p, BuildTxWith (Just witness)) <- toList proposalProcedures
-      , ix <- maybeToList $ OMap.findIndex p proposalProcedures
-      ]
+    scriptWitnessesProposing (TxProposalProcedures proposalProcedures (BuildTxWith mScriptWitnesses))
+      | Map.null mScriptWitnesses = []
+      | otherwise =
+          [ (ScriptWitnessIndexProposing ix, AnyScriptWitness witness)
+          | let proposalsList = toList proposalProcedures
+          , (ix, proposal) <- zip [0 ..] proposalsList
+          , witness <- maybeToList (Map.lookup proposal mScriptWitnesses)
+          ]
 
 -- This relies on the TxId Ord instance being consistent with the
 -- Ledger.TxId Ord instance via the toShelleyTxId conversion

cardano-api/src/Cardano/Api.hs

@@ -367,11 +367,14 @@ module Cardano.Api
   , TxVotingProcedures (..)
   , mkTxVotingProcedures
   , TxProposalProcedures (..)
+  , mkTxProposalProcedures
+  , convProposalProcedures
 
     -- ** Building vs viewing transactions
   , BuildTxWith (..)
   , BuildTx
   , ViewTx
+  , buildTxWithToMaybe
 
     -- ** Fee calculation
   , LedgerEpochInfo (..)

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 
 module Test.Cardano.Api.Typed.TxBody
@@ -10,7 +11,6 @@ import qualified Cardano.Api.Ledger as L
 import           Cardano.Api.Shelley (ReferenceScript (..), ShelleyLedgerEra,
                    refScriptToShelleyScript)
 
-import           Data.Map.Ordered.Strict (OMap)
 import           Data.Maybe (isJust)
 import           Data.Type.Equality (TestEquality (testEquality))
 import           GHC.Exts (IsList (..))
@@ -90,8 +90,8 @@ prop_roundtrip_txbodycontent_conway_fields = H.property $ do
   -- Convert ledger body back via 'getTxBodyContent' and 'fromLedgerTxBody'
   let (TxBody content') = body
 
-  let proposals = fmap (fmap fst . toList) . getProposalProcedures . unFeatured <$> txProposalProcedures content
-      proposals' = fmap (fmap fst . toList) . getProposalProcedures . unFeatured <$> txProposalProcedures content'
+  let proposals = getProposalProcedures . unFeatured <$> txProposalProcedures content
+      proposals' = getProposalProcedures . unFeatured <$> txProposalProcedures content'
       votes = getVotingProcedures . unFeatured <$> txVotingProcedures content
       votes' = getVotingProcedures . unFeatured <$> txVotingProcedures content'
       currTreasury = unFeatured <$> txCurrentTreasuryValue content
@@ -107,14 +107,11 @@ prop_roundtrip_txbodycontent_conway_fields = H.property $ do
   getVotingProcedures TxVotingProceduresNone = Nothing
   getVotingProcedures (TxVotingProcedures vps _) = Just vps
   getProposalProcedures
-    :: TxProposalProcedures build era
-    -> Maybe
-        ( OMap
-            (L.ProposalProcedure (ShelleyLedgerEra era))
-            (BuildTxWith build (Maybe (ScriptWitness WitCtxStake era)))
-        )
+    :: IsShelleyBasedEra era
+    => TxProposalProcedures build era
+    -> Maybe [L.ProposalProcedure (ShelleyLedgerEra era)]
   getProposalProcedures TxProposalProceduresNone = Nothing
-  getProposalProcedures (TxProposalProcedures pps) = Just pps
+  getProposalProcedures txpp@(TxProposalProcedures _ _) = Just . toList $ convProposalProcedures txpp
 
 tests :: TestTree
 tests =