WIP

cardano-api/cardano-api.cabal

@@ -133,6 +133,7 @@ library internal
     Cardano.Api.Rewards
     Cardano.Api.Script
     Cardano.Api.Experimental.Eras
+    Cardano.Api.Experimental.Fees
    -- Cardano.Api.Experimental.Script
     Cardano.Api.Experimental.Tx
     Cardano.Api.ScriptData

cardano-api/internal/Cardano/Api/Convenience/Construction.hs

@@ -16,12 +16,16 @@ where
 
 import           Cardano.Api.Address
 import           Cardano.Api.Certificate
+import Cardano.Api.Experimental.Tx
+import Data.Maybe
 import           Cardano.Api.Eon.ShelleyBasedEra
 import           Cardano.Api.Fees
 import           Cardano.Api.ProtocolParameters
 import           Cardano.Api.Query
 import           Cardano.Api.Tx.Body
 import           Cardano.Api.Tx.Sign
+import Cardano.Api.Experimental.Eras (sbeToEra)
+
 import           Cardano.Api.Utils
 
 import qualified Cardano.Ledger.Api as L
@@ -35,6 +39,7 @@ import           Data.Set (Set)
 import qualified Data.Set as Set
 import           Data.Text (Text)
 import qualified Data.Text as Text
+import Cardano.Api.Eras
 
 -- | Construct a balanced transaction.
 -- See Cardano.Api.Convenience.Query.queryStateForBalancedTx for a
@@ -72,7 +77,9 @@ constructBalancedTx
   stakeDelegDeposits
   drepDelegDeposits
   shelleyWitSigningKeys = do
-    BalancedTxBody _ txbody _txBalanceOutput _fee <-
+    let availableEra = fromMaybe (error "TODO") $ sbeToEra sbe
+
+    BalancedTxBody _ unsignedTx _txBalanceOutput _fee <- -- obtainCommonConstraints availableEra $
       makeTransactionBodyAutoBalance
         sbe
         systemStart
@@ -86,9 +93,14 @@ constructBalancedTx
         changeAddr
         mOverrideWits
 
-    let keyWits = map (makeShelleyKeyWitness sbe txbody) shelleyWitSigningKeys
-    return $ makeSignedTransaction keyWits txbody
+    let alternateKeyWits = map (makeKeyWitness availableEra unsignedTx) shelleyWitSigningKeys
+        signedTx = signTx availableEra [] alternateKeyWits unsignedTx 
 
+    caseShelleyToAlonzoOrBabbageEraOnwards
+      (const $ error "constructBalancedTx: TODO Fail")
+      (\w ->  return $ ShelleyTx sbe $ obtainShimConstraints w signedTx)
+      sbe 
+
 data TxInsExistError
   = TxInsDoNotExist [TxIn]
   | EmptyUTxO

cardano-api/internal/Cardano/Api/Experimental/Eras.hs

@@ -6,9 +6,11 @@ module Cardano.Api.Experimental.Eras
   , Era(..)
   , UseEra
   , AvailableErasToSbe
+  , SbeToAvailableEras
   , ToConstrainedEra
   , useEra
   , protocolVersionToSbe
+  , sbeToEra
   )
 where
 

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

@@ -0,0 +1 @@
+module Cardano.Api.Experimental.Fees where

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

@@ -1,15 +1,28 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 
 module Cardano.Api.Experimental.Tx where
 
+import           Cardano.Api.Eon.BabbageEraOnwards
 import           Cardano.Api.Eon.ShelleyBasedEra
+import Cardano.Api.Eras.Case
 import           Cardano.Api.Experimental.Eras
+import qualified Cardano.Ledger.SafeHash as L
+import qualified Cardano.Ledger.UTxO as L
+import qualified Cardano.Ledger.Keys as L
+import Cardano.Ledger.Hashes
+
 import           Cardano.Api.Feature
-import Data.Bifunctor
 import           Cardano.Api.ReexposeLedger (StrictMaybe (..), maybeToStrictMaybe)
 import qualified Cardano.Api.ReexposeLedger as L
 import           Cardano.Api.Tx.Body
@@ -19,6 +32,8 @@ import qualified Cardano.Ledger.Alonzo.TxBody as L
 import qualified Cardano.Ledger.Api as L
 import qualified Cardano.Ledger.Conway.TxBody as L
 import qualified Cardano.Ledger.Core as Ledger
+import qualified Cardano.Ledger.Babbage as Ledger
+import qualified Cardano.Ledger.Conway as Ledger
 
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
@@ -30,21 +45,22 @@ import           Lens.Micro
 -- except key witnesses
 newtype UnsignedTx era
   = UnsignedTx (Ledger.Tx (ToConstrainedEra era))
-
+
+instance UseEra era => Show (UnsignedTx era) where
+    showsPrec p (UnsignedTx tx) = case useEra @era of
+        BabbageEra -> showsPrec p (tx :: Ledger.Tx Ledger.Babbage)
+        ConwayEra -> showsPrec p (tx :: Ledger.Tx Ledger.Conway)
+
 newtype UnsignedTxError
   = UnsignedTxError TxBodyError
 
 -- NB: The type classes at the top level type signature here are
 -- common to both the current era and the upcoming era.
 makeUnsignedTx
-  :: Ledger.EraCrypto (ToConstrainedEra era) ~ L.StandardCrypto
-  => L.AlonzoEraTx (ToConstrainedEra era)
-  => L.BabbageEraTxBody (ToConstrainedEra era)
-  => ShelleyLedgerEra (AvailableErasToSbe era) ~ ToConstrainedEra era
-  => Era era
+  :: Era era
   -> TxBodyContent BuildTx (AvailableErasToSbe era)
-  -> Either UnsignedTxError (UnsignedTx era)
-makeUnsignedTx era bc = do
+  -> Either TxBodyError (UnsignedTx era)
+makeUnsignedTx era bc = obtainCommonConstraints era $ do
   let sbe = protocolVersionToSbe era
 
       -- cardano-api types
@@ -112,11 +128,11 @@ eraSpecificLedgerTxBody
   :: Era era
   -> Ledger.TxBody (ToConstrainedEra era)
   -> TxBodyContent BuildTx (AvailableErasToSbe era)
-  -> Either UnsignedTxError (Ledger.TxBody (ToConstrainedEra era))
+  -> Either TxBodyError (Ledger.TxBody (ToConstrainedEra era))
 eraSpecificLedgerTxBody BabbageEra ledgerbody bc = do
   let sbe = protocolVersionToSbe BabbageEra
 
-  setUpdateProposal <- first UnsignedTxError $ convTxUpdateProposal sbe (txUpdateProposal bc)
+  setUpdateProposal <- convTxUpdateProposal sbe (txUpdateProposal bc)
 
   return $ ledgerbody  & L.updateTxBodyL .~ setUpdateProposal
 eraSpecificLedgerTxBody ConwayEra ledgerbody bc =
@@ -131,18 +147,86 @@ eraSpecificLedgerTxBody ConwayEra ledgerbody bc =
           & L.treasuryDonationTxBodyL .~ maybe (L.Coin 0) unFeatured treasuryDonation
           & L.currentTreasuryValueTxBodyL .~ L.maybeToStrictMaybe (unFeatured <$> currentTresuryValue)
 
+
+hashTxBody 
+  :: L.HashAnnotated (Ledger.TxBody era) EraIndependentTxBody L.StandardCrypto 
+  => L.TxBody era -> L.Hash L.StandardCrypto EraIndependentTxBody
+hashTxBody = L.extractHash @L.StandardCrypto . L.hashAnnotated
+
+makeKeyWitness
+  :: Era era 
+  -> UnsignedTx era --L.TxBody (ToConstrainedEra era)
+  -> ShelleyWitnessSigningKey
+  -> L.WitVKey L.Witness L.StandardCrypto
+makeKeyWitness era (UnsignedTx unsignedTx) wsk = obtainCommonConstraints era $ 
+     let txbody = unsignedTx ^. L.bodyTxL
+         txhash :: L.Hash L.StandardCrypto EraIndependentTxBody
+         txhash = obtainCommonConstraints era $ hashTxBody txbody
+         sk = toShelleySigningKey wsk
+         vk = getShelleyKeyWitnessVerificationKey sk
+         signature = makeShelleySignature txhash sk
+     in L.WitVKey vk signature
+
+
 signTx
-  :: L.EraTx (ToConstrainedEra era)
-  => Ledger.EraCrypto (ToConstrainedEra era) ~ L.StandardCrypto
-  => [KeyWitness (AvailableErasToSbe era)]
+  :: Era era
+  -> [L.BootstrapWitness L.StandardCrypto]
+  -> [L.WitVKey L.Witness L.StandardCrypto]
   -> UnsignedTx era
   -> Ledger.Tx (ToConstrainedEra era)
-signTx apiKeyWits (UnsignedTx unsigned) =
+signTx era bootstrapWits shelleyKeyWits (UnsignedTx unsigned) = obtainCommonConstraints era $ 
   let currentScriptWitnesses = unsigned ^. L.witsTxL
-      keyWits = L.mkBasicTxWits
+      keyWits = obtainCommonConstraints era $ L.mkBasicTxWits
                   & L.addrTxWitsL
-                     .~ Set.fromList [w | ShelleyKeyWitness _ w <- apiKeyWits]
+                     .~ Set.fromList shelleyKeyWits
                   & L.bootAddrTxWitsL
-                     .~ Set.fromList [w | ShelleyBootstrapWitness _ w <- apiKeyWits]
+                     .~ Set.fromList bootstrapWits
       signedTx = unsigned & L.witsTxL .~ (keyWits <> currentScriptWitnesses)
   in signedTx
+
+
+obtainCommonConstraints
+  :: Era era
+  -> (EraCommonConstraints era => a) 
+  -> a 
+obtainCommonConstraints BabbageEra x = x
+obtainCommonConstraints ConwayEra x = x
+
+
+type EraCommonConstraints era 
+  = ( L.AlonzoEraTx (ToConstrainedEra era)
+    , L.BabbageEraTxBody (ToConstrainedEra era)  
+    , L.EraTx (ToConstrainedEra era)
+    , L.EraUTxO (ToConstrainedEra era)  
+    , Ledger.EraCrypto (ToConstrainedEra era) ~ L.StandardCrypto
+    , ShelleyLedgerEra (AvailableErasToSbe era)  ~ ToConstrainedEra era
+    , L.HashAnnotated (Ledger.TxBody (ToConstrainedEra era)) EraIndependentTxBody L.StandardCrypto
+    )
+
+-- Compatibility related. Will be removed once the old api has been deprecated and deleted.
+
+convertTxBodyToUnsignedTx :: ShelleyBasedEra era -> TxBody era -> UnsignedTx (SbeToAvailableEras era) 
+convertTxBodyToUnsignedTx sbe txbody = 
+  caseShelleyToAlonzoOrBabbageEraOnwards
+  (const $ error "convertTxBodyToUnsignedTx: Error")
+  (\w -> let ShelleyTx _ unsignedLedgerTx = makeSignedTransaction [] txbody
+         in UnsignedTx $ obtainShimConstraints w unsignedLedgerTx
+
+  )
+  sbe
+
+-- We need these constraints in order to propagate the new 
+-- experimental api without changing the existing api
+type EraShimConstraints era =
+  ( ToConstrainedEra (SbeToAvailableEras era) ~ ShelleyLedgerEra era
+  , AvailableErasToSbe (SbeToAvailableEras era) ~ era
+  , L.EraTx (ToConstrainedEra (SbeToAvailableEras era))
+  )
+
+
+obtainShimConstraints
+  :: BabbageEraOnwards era
+  -> (EraShimConstraints era => a) 
+  -> a
+obtainShimConstraints BabbageEraOnwardsBabbage x = x
+obtainShimConstraints BabbageEraOnwardsConway x = x