Fix and simplify ErrAssignReedemers

lib/api/src/Cardano/Wallet/Api/Http/Server/Error/AssignReedemers.hs

@@ -4,22 +4,12 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Cardano.Wallet.Api.Http.Server.Error.AssignReedemers () where
 
 import Prelude
 
-import Cardano.Ledger.Alonzo.Plutus.TxInfo
-    ( AlonzoContextError (..)
-    )
-import Cardano.Ledger.Babbage.TxInfo
-    ( BabbageContextError (..)
-    )
-import Cardano.Ledger.Conway.TxInfo
-    ( ConwayContextError (..)
-    )
 import Cardano.Wallet.Api.Http.Server.Error.IsServerError
     ( IsServerError (..)
     , apiError
@@ -32,19 +22,14 @@ import Fmt
     )
 import Internal.Cardano.Write.Tx
     ( IsRecentEra (..)
-    , RecentEra (RecentEraBabbage, RecentEraConway)
     )
 import Internal.Cardano.Write.Tx.Balance
     ( ErrAssignRedeemers (..)
     )
 import Servant.Server
-    ( ServerError
-    , err400
+    ( err400
     )
 
-import Cardano.Ledger.Alonzo.Plutus.Evaluate
-    ( TransactionScriptFailure (..)
-    )
 import qualified Data.Text as T
 
 instance IsRecentEra era => IsServerError (ErrAssignRedeemers era) where
@@ -56,7 +41,7 @@ instance IsRecentEra era => IsServerError (ErrAssignRedeemers era) where
                     , "redeemers:"
                     , pretty r <> ";"
                     , "Its execution is failing with the following error:"
-                    , T.pack failure <> "."
+                    , T.pack (show failure) <> "."
                     ]
         ErrAssignRedeemersTargetNotFound r ->
             apiError err400 RedeemerTargetNotFound
@@ -75,131 +60,3 @@ instance IsRecentEra era => IsServerError (ErrAssignRedeemers era) where
                     , "into a valid Plutus data:"
                     , pretty r <> "."
                     ]
-        ErrAssignRedeemersTranslationError (ContextError x) ->
-            case recentEra @era of
-                RecentEraBabbage -> fromBabbageContextError x
-                RecentEraConway -> fromConwayContextError x
-        _ -> error "todo"
-
-fromAlonzoContextError :: AlonzoContextError era -> ServerError
-fromAlonzoContextError = \case
-    TranslationLogicMissingInput inp ->
-        apiError err400 UnresolvedInputs
-            $ T.unwords
-                [ "The transaction I was given contains inputs I don't know"
-                , "about. Please ensure all foreign inputs are specified as "
-                , "part of the API request. The unknown input is:\n\n"
-                , T.pack $ show inp
-                ]
-    TimeTranslationPastHorizon t ->
-        apiError err400 PastHorizon
-            $ T.unwords
-                [ "The transaction's validity interval is past the horizon"
-                , "of safe slot-to-time conversions."
-                , "This may happen when I know about a future era"
-                , "which has not yet been confirmed on-chain. Try setting the"
-                , "bounds of the validity interval to be earlier.\n\n"
-                , "Here are the full details: " <> t
-                ]
-
-fromBabbageContextError
-    :: forall era
-     . IsRecentEra era
-    => BabbageContextError era
-    -> ServerError
-fromBabbageContextError = \case
-    AlonzoContextError e -> fromAlonzoContextError e
-    ByronTxOutInContext txOut ->
-        apiError err400 TranslationByronTxOutInContext
-            $ T.unwords
-                [ "The transaction I was given contains a Byron-style TxOut"
-                , "which is not supported when executing Plutus scripts. "
-                , "The offending TxOut is:\n\n"
-                , T.pack $ show txOut
-                ]
-    RedeemerPointerPointsToNothing ptr ->
-        apiError err400 RedeemerTargetNotFound
-            $ T.unwords
-                [ "I was unable to resolve one of your redeemers to the location"
-                , "indicated in the request payload:"
-                , T.pack $ show ptr
-                , "Please double-check both your serialised transaction and"
-                , "the provided redeemers."
-                ]
-    InlineDatumsNotSupported x ->
-        apiError err400 RedeemerInvalidData
-            $ T.unwords
-                [ "Inline datum is not supported in Plutus V1"
-                , "The offending data is:\n\n"
-                , T.pack $ show x
-                ]
-    ReferenceScriptsNotSupported x ->
-        apiError err400 RedeemerScriptFailure
-            $ T.unwords
-                [ "Reference scripts are not supported in Plutus V1"
-                , "The offending script is:\n\n"
-                , T.pack $ show x
-                ]
-    ReferenceInputsNotSupported x ->
-        apiError err400 UnresolvedInputs
-            $ T.unwords
-                [ "Reference inputs are not supported in Plutus V1"
-                , "The offending input is:\n\n"
-                , T.pack $ show x
-                ]
-
-fromConwayContextError
-    :: forall era
-     . IsRecentEra era
-    => ConwayContextError era
-    -> ServerError
-fromConwayContextError = \case
-    BabbageContextError e -> fromBabbageContextError e
-    CertificateNotSupported x ->
-        apiError err400 UnsupportedMediaType
-            $ T.unwords
-                [ "The transaction I was given contains a certificate which"
-                , "is not supported in the current era."
-                , "The offending certificate is:\n\n"
-                , T.pack $ show x
-                ]
-    PlutusPurposeNotSupported x ->
-        apiError err400 UnsupportedMediaType
-            $ T.unwords
-                [ "The transaction I was given contains a Plutus script"
-                , "which is not supported in the current era."
-                , "The offending script is:\n\n"
-                , T.pack $ show x
-                ]
-    CurrentTreasuryFieldNotSupported x ->
-        apiError err400 UnsupportedMediaType
-            $ T.unwords
-                [ "The transaction I was given contains a current treasury"
-                , "which is not supported in the current era."
-                , "The offending treasury is:\n\n"
-                , T.pack $ show x
-                ]
-    VotingProceduresFieldNotSupported x ->
-        apiError err400 UnsupportedMediaType
-            $ T.unwords
-                [ "The transaction I was given contains a voting procedure"
-                , "which is not supported in the current era."
-                , "The offending procedure is:\n\n"
-                , T.pack $ show x
-                ]
-    ProposalProceduresFieldNotSupported x ->
-        apiError err400 UnsupportedMediaType
-            $ T.unwords
-                [ "The transaction I was given contains a proposal procedure"
-                , "which is not supported in the current era."
-                , "The offending procedure is:\n\n"
-                , T.pack $ show x
-                ]
-    TreasuryDonationFieldNotSupported x ->
-        apiError err400 UnsupportedMediaType
-            $ T.unwords
-                [ "The transaction I was given contains a treasury donation"
-                , "which is not supported in the current era."
-                , "The offending donation is:\n\n"
-                , T.pack $ show x
-                ]

lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/Redeemers.hs

@@ -115,12 +115,11 @@ import qualified Data.Set as Set
 import qualified Data.Text as T
 
 data ErrAssignRedeemers era
-    = ErrAssignRedeemersScriptFailure Redeemer String
+    = ErrAssignRedeemersScriptFailure Redeemer (TransactionScriptFailure era)
     | ErrAssignRedeemersTargetNotFound Redeemer
     -- ^ The given redeemer target couldn't be located in the transaction.
     | ErrAssignRedeemersInvalidData Redeemer String
     -- ^ Redeemer's data isn't a valid Plutus' data.
-    | ErrAssignRedeemersTranslationError (TransactionScriptFailure era)
     deriving (Generic)
 
 deriving instance Eq (TransactionScriptFailure era)
@@ -196,12 +195,11 @@ assignScriptRedeemers pparams timeTranslation utxo redeemers tx = do
         & hoistScriptFailure indexedRedeemers
 
     hoistScriptFailure
-        :: Show scriptFailure
-        => Map (Alonzo.PlutusPurpose Alonzo.AsIx era) Redeemer
-        -> Map (Alonzo.PlutusPurpose Alonzo.AsIx era) (Either scriptFailure a)
+        :: Map (Alonzo.PlutusPurpose Alonzo.AsIx era) Redeemer
+        -> Map (Alonzo.PlutusPurpose Alonzo.AsIx era) (Either (TransactionScriptFailure era) a)
         -> Map (Alonzo.PlutusPurpose Alonzo.AsIx era) (Either (ErrAssignRedeemers era) a)
     hoistScriptFailure indexedRedeemers = Map.mapWithKey $ \ptr -> left $ \e ->
-        ErrAssignRedeemersScriptFailure (indexedRedeemers ! ptr) (show e)
+        ErrAssignRedeemersScriptFailure (indexedRedeemers ! ptr) e
 
     -- | Change execution units for each redeemers in the transaction to what
     -- they ought to be.

lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs

@@ -714,7 +714,8 @@ spec_balanceTx = describe "balanceTx" $ do
                 case balance (withValidityBeyondHorizon pingPong_2) of
                     Left
                         (ErrBalanceTxAssignRedeemers
-                            (ErrAssignRedeemersTranslationError
+                            (ErrAssignRedeemersScriptFailure
+                                _redeemer
                                 (ContextError
                                 (AlonzoContextError
                                 (TimeTranslationPastHorizon
@@ -1304,7 +1305,7 @@ prop_balanceTxValid
                     counterexample counterexampleText $ property False
             Left
                 (ErrBalanceTxAssignRedeemers
-                (ErrAssignRedeemersTranslationError e)) ->
+                (ErrAssignRedeemersScriptFailure _ e)) ->
                 prop_transactionScriptFailure e
             Left ErrBalanceTxUnableToCreateChange {} ->
                 label "unable to create change" $ property True