wIP

cardano-api/internal/Cardano/Api/Protocol/AvailableEras.hs

@@ -18,6 +18,7 @@ module Cardano.Api.Protocol.AvailableEras
   , Era (..)
   , ToConstrainedEra
   , UseEra
+  , ToConstrainedEraClass(..)
   , AvailableErasToSbe
   , useEra
   , protocolVersionToSbe
@@ -30,6 +31,7 @@ import qualified Cardano.Api.Eras.Core as Api
 import qualified Cardano.Ledger.Babbage as Ledger
 import qualified Cardano.Ledger.Conway as Ledger
 
+import           Data.Kind
 import           GHC.TypeLits
 
 -- | Users typically interact with the latest features on the mainnet or experiment with features
@@ -42,14 +44,23 @@ data AvailableEras
 
 -- Allows us to gradually change the api without breaking things.
 -- This will eventually be removed.
-type family AvailableErasToSbe era where
+type family AvailableErasToSbe era = (r :: Type) | r -> era where
   AvailableErasToSbe BabbageEra = Api.BabbageEra
   AvailableErasToSbe ConwayEra = Api.ConwayEra
 
-type family ToConstrainedEra (era :: AvailableEras) where
+type family ToConstrainedEra (era :: AvailableEras) = (r :: Type) | r -> era where
   ToConstrainedEra BabbageEra = Ledger.Babbage
   ToConstrainedEra ConwayEra = Ledger.Conway
 
+class ToConstrainedEraClass (era :: AvailableEras) where
+  type ToConstrainedEraClassType era :: Type
+
+instance ToConstrainedEraClass BabbageEra where
+  type ToConstrainedEraClassType BabbageEra = Ledger.Babbage
+
+instance ToConstrainedEraClass ConwayEra where
+  type ToConstrainedEraClassType ConwayEra = Ledger.Conway
+
 {- | Represents the eras in Cardano's blockchain.
 
 Instead of enumerating every possible era, we use two constructors:

cardano-api/internal/Cardano/Api/Scripts/New.hs

@@ -26,19 +26,28 @@ import           Cardano.Api.TxIn
 import qualified Cardano.Binary as CBOR
 import qualified Cardano.Ledger.Allegra.Scripts as Ledger
 import qualified Cardano.Ledger.Alonzo.Scripts as Ledger
+import qualified Cardano.Ledger.Alonzo.TxBody as Ledger
 import qualified Cardano.Ledger.Alonzo.TxWits as Ledger
 import qualified Cardano.Ledger.Babbage as Ledger
 import           Cardano.Ledger.Binary
 import qualified Cardano.Ledger.Binary.Plain as Plain
 import qualified Cardano.Ledger.Conway as Ledger
+import qualified Cardano.Ledger.Conway.Governance as Ledger
+import qualified Cardano.Ledger.Conway.Scripts as Ledger
 import qualified Cardano.Ledger.Core as Ledger
+import           Cardano.Ledger.Crypto (StandardCrypto)
 import qualified Cardano.Ledger.Plutus.Data as Ledger
+import qualified Cardano.Ledger.TxIn as Ledger
 
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as LBS
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
+import           Data.Maybe.Strict
+import           Data.Set (Set)
 import           Data.Typeable
+import           Data.Word
+import           Lens.Micro
 
 {-
 In the current api we have PlutusScript which is a wrapper around ShortByteString
@@ -190,8 +199,8 @@ data SimpleScriptWitness era
 
 deriving instance Eq (Ledger.TxWits (ToConstrainedEra era)) => Eq (SimpleScriptWitness era)
 
-
 createPlutusScriptWitness
+
   :: Ledger.Script (ToConstrainedEra era) ~ Ledger.AlonzoScript (ToConstrainedEra era)
   => Ledger.AlonzoEraScript (ToConstrainedEra era)
   => Era era
@@ -263,6 +272,95 @@ createSimpleReferenceScriptWitness era refInput  =   case era of
     UpcomingEraInternal -> SimpleScriptWitnessRefInput refInput
 
 
+data RedeemerConstructionError item container
+  = ItemToBeWitnessedNotFound item container
+
+
+
+createTxInRedeemer
+  :: Ledger.AlonzoEraScript (ToConstrainedEraClassType era)
+  => Ledger.EraCrypto (ToConstrainedEraClassType era) ~ StandardCrypto
+  => Era era
+  -> Ledger.TxIn StandardCrypto -- ^ Input to be witnessed by
+  -> Set (Ledger.TxIn StandardCrypto)
+  -> Ledger.BinaryData (ToConstrainedEraClassType era)
+  -> Ledger.ExUnits
+  -> Either (RedeemerConstructionError (Ledger.TxIn StandardCrypto) (Set (Ledger.TxIn StandardCrypto))) (SingleRedeemer era)
+createTxInRedeemer era toBeWitnessed allTxInputs binData exUnits =
+  createSingleRedeemerMapEntry era toBeWitnessed allTxInputs Ledger.mkSpendingPurpose binData exUnits
+
+createVotingRedeemer
+  :: Ledger.ConwayEraScript (ToConstrainedEraClassType era)
+  => Era era
+  -> Ledger.Voter StandardCrypto -- ^ Input to be witnessed by
+  -> Set (Ledger.Voter StandardCrypto)
+  -> Ledger.BinaryData (ToConstrainedEraClassType era)
+  -> Ledger.ExUnits
+  -> Either (RedeemerConstructionError (Ledger.Voter StandardCrypto) (Set (Ledger.Voter StandardCrypto))) (SingleRedeemer era)
+createVotingRedeemer era toBeWitnessed allTxInputs binData exUnits =
+  case era of
+    CurrentEraInternal ->
+      createSingleRedeemerMapEntry CurrentEraInternal toBeWitnessed allTxInputs Ledger.mkVotingPurpose binData exUnits
+    UpcomingEraInternal ->
+      createSingleRedeemerMapEntry UpcomingEraInternal toBeWitnessed allTxInputs Ledger.mkVotingPurpose binData exUnits
+
+
+
+type SingleRedeemer era = (Map (Ledger.PlutusPurpose Ledger.AsIx (ToConstrainedEraClassType era)) (Ledger.Data (ToConstrainedEraClassType era), Ledger.ExUnits))
+
+-- Helper functions
+-- TODO: It would be useful to have a type class that
+-- maps era -> [Language] i.e allowed script languages in a given era
+createSingleRedeemerMapEntry
+  :: forall item container era. Ledger.Indexable item container
+  => Ledger.Era (ToConstrainedEraClassType era)
+  => Era era
+  -> item -- ^ Item to be witnessed (TxIn, Cert, etc)
+  -> container -- ^ All items in transaction
+  -> (Ledger.AsIx Word32 item -> Ledger.PlutusPurpose Ledger.AsIx (ToConstrainedEraClassType era))
+  -> Ledger.BinaryData (ToConstrainedEraClassType era)
+  -> Ledger.ExUnits
+  -> Either (RedeemerConstructionError item container) (SingleRedeemer era)
+createSingleRedeemerMapEntry era toBeWitnessed allThings toPlutusPurpose redeemerBinaryData exunits =
+  case era of
+    CurrentEraInternal -> createRedeemer
+    UpcomingEraInternal -> createRedeemer
+ where
+  createRedeemer
+    :: Either (RedeemerConstructionError item container) (SingleRedeemer era)
+  createRedeemer = do
+      let asItem = Ledger.AsItem toBeWitnessed
+
+      index <- maybe
+                 (Left $ ItemToBeWitnessedNotFound toBeWitnessed allThings)
+                  Right $ strictMaybeToMaybe $ Ledger.indexOf asItem allThings
+
+      let plutusPurpose = toPlutusPurpose index
+          redeemerData = Ledger.binaryDataToData redeemerBinaryData
+
+      return $ Map.singleton plutusPurpose (redeemerData, exunits)
+
+
+getAllPlutusScripts
+  :: Ledger.EraTxWits (ToConstrainedEra era)
+  => [PlutusScriptWitness era]
+  -> [Ledger.Script (ToConstrainedEra era)]
+getAllPlutusScripts [] = []
+getAllPlutusScripts plutusScriptWits =
+  mconcat [ Map.elems $ txWits ^. Ledger.scriptTxWitsL
+          | PlutusScriptWitness txWits <- plutusScriptWits
+          ]
+
+getAllSimpleScripts
+  :: Ledger.EraTxWits (ToConstrainedEra era)
+  => [SimpleScriptWitness era]
+  -> [Ledger.Script (ToConstrainedEra era)]
+getAllSimpleScripts [] = []
+getAllSimpleScripts simpleScriptWits =
+  mconcat [ Map.elems $ txWits ^. Ledger.scriptTxWitsL
+          | SimpleScriptWitness txWits <- simpleScriptWits
+          ]
+
 class ConstrainedDecoder (availableera :: AvailableEras) era | availableera -> era where
   fromEraCBORConstrained :: (Ledger.Era era, DecCBOR t) => Plain.Decoder s t