X

eras/allegra/impl/cardano-ledger-allegra.cabal

@@ -102,7 +102,6 @@ library testlib
         bytestring,
         cardano-ledger-allegra,
         cardano-crypto-class,
-        cardano-ledger-binary:{cardano-ledger-binary, testlib},
         cardano-ledger-core:{cardano-ledger-core, testlib},
         cardano-ledger-shelley:{cardano-ledger-shelley, testlib},
         cardano-strict-containers,

eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs

@@ -15,18 +15,27 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Cardano.Ledger.Allegra.Scripts (
-  Timelock (
-    RequireSignature,
-    RequireAllOf,
-    RequireAnyOf,
-    RequireMOf,
-    RequireTimeExpire,
-    RequireTimeStart
-  ),
+  AllegraEraScript (..),
+  mkRequireSignatureTimelock,
+  getRequireSignatureTimelock,
+  mkRequireAllOfTimelock,
+  getRequireAllOfTimelock,
+  mkRequireAnyOfTimelock,
+  getRequireAnyOfTimelock,
+  mkRequireMOfTimelock,
+  getRequireMOfTimelock,
+  mkTimeStartTimelock,
+  getTimeStartTimelock,
+  mkTimeExpireTimelock,
+  getTimeExpireTimelock,
+  Timelock,
+  pattern RequireTimeExpireX,
+  pattern RequireTimeStartX,
   TimelockRaw,
   pattern TimelockConstr,
   inInterval,
@@ -62,7 +71,7 @@ import Cardano.Ledger.Binary.Coders (
   (<*!),
  )
 import Cardano.Ledger.Core
-import Cardano.Ledger.Crypto (Crypto, HASH)
+import Cardano.Ledger.Crypto (Crypto, HASH, StandardCrypto)
 import Cardano.Ledger.Keys (KeyHash (..), KeyRole (Witness))
 import Cardano.Ledger.MemoBytes (
   EqRaw (..),
@@ -74,15 +83,22 @@ import Cardano.Ledger.MemoBytes (
   mkMemoized,
  )
 import Cardano.Ledger.SafeHash (SafeToHash)
-import Cardano.Ledger.Shelley.Scripts (nativeMultiSigTag)
-import qualified Cardano.Ledger.Shelley.Scripts as Shelley
+import Cardano.Ledger.Shelley.Scripts (
+  ShelleyEraScript (..),
+  nativeMultiSigTag,
+  pattern RequireAllOfX,
+  pattern RequireAnyOfX,
+  pattern RequireMOfX,
+  pattern RequireSignatureX,
+ )
+
 import Cardano.Slotting.Slot (SlotNo (..))
 import Control.DeepSeq (NFData (..))
 import Data.Aeson (ToJSON (..), (.=))
 import qualified Data.Aeson as Aeson
 import Data.ByteString.Lazy (fromStrict)
 import Data.ByteString.Short (fromShort)
-import Data.Sequence.Strict as Seq (StrictSeq (Empty, (:<|)), fromList)
+import Data.Sequence.Strict as Seq (StrictSeq (Empty, (:<|)))
 import qualified Data.Sequence.Strict as SSeq
 import qualified Data.Set as Set (Set, member)
 import GHC.Generics (Generic)
@@ -130,6 +146,13 @@ data TimelockRaw era
   | TimeExpire !SlotNo -- The time it expires
   deriving (Eq, Generic, NFData)
 
+class ShelleyEraScript era => AllegraEraScript era where
+  mkTimeStart :: SlotNo -> NativeScript era
+  getTimeStart :: NativeScript era -> Maybe (SlotNo)
+
+  mkTimeExpire :: SlotNo -> NativeScript era
+  getTimeExpire :: NativeScript era -> Maybe (SlotNo)
+
 deriving instance Era era => NoThunks (TimelockRaw era)
 
 deriving instance HashAlgorithm (HASH (EraCrypto era)) => Show (TimelockRaw era)
@@ -200,6 +223,14 @@ instance Memoized Timelock where
 
 deriving instance HashAlgorithm (HASH (EraCrypto era)) => Show (Timelock era)
 
+instance EqRaw (Timelock era) where
+  eqRaw = eqTimelockRaw
+
+deriving via
+  Mem TimelockRaw era
+  instance
+    Era era => DecCBOR (Annotator (Timelock era))
+
 -- | Since Timelock scripts are a strictly backwards compatible extension of
 -- MultiSig scripts, we can use the same 'scriptPrefixTag' tag here as we did
 -- for the ValidateScript instance in MultiSig
@@ -208,64 +239,96 @@ instance Crypto c => EraScript (AllegraEra c) where
   type NativeScript (AllegraEra c) = Timelock (AllegraEra c)
 
   upgradeScript = \case
-    Shelley.RequireSignature keyHash -> RequireSignature keyHash
-    Shelley.RequireAllOf sigs -> RequireAllOf $ Seq.fromList $ map upgradeScript sigs
-    Shelley.RequireAnyOf sigs -> RequireAnyOf $ Seq.fromList $ map upgradeScript sigs
-    Shelley.RequireMOf n sigs -> RequireMOf n $ Seq.fromList $ map upgradeScript sigs
+    RequireSignatureX keyHash -> RequireSignatureX keyHash
+    RequireAllOfX sigs -> RequireAllOfX $ upgradeScript <$> sigs
+    RequireAnyOfX sigs -> RequireAnyOfX $ upgradeScript <$> sigs
+    RequireMOfX n sigs -> RequireMOfX n $ upgradeScript <$> sigs
 
   scriptPrefixTag _script = nativeMultiSigTag -- "\x00"
 
   getNativeScript = Just
 
   fromNativeScript = id
 
-instance EqRaw (Timelock era) where
-  eqRaw = eqTimelockRaw
+instance Crypto c => ShelleyEraScript (AllegraEra c) where
+  {-# SPECIALIZE instance ShelleyEraScript (AllegraEra StandardCrypto) #-}
 
-deriving via
-  Mem TimelockRaw era
-  instance
-    Era era => DecCBOR (Annotator (Timelock era))
+  mkRequireSignature = mkRequireSignatureTimelock
+  getRequireSignature = getRequireSignatureTimelock
 
-pattern RequireSignature :: Era era => KeyHash 'Witness (EraCrypto era) -> Timelock era
-pattern RequireSignature akh <- (getMemoRawType -> Signature akh)
-  where
-    RequireSignature akh = mkMemoized (Signature akh)
+  mkRequireAllOf = mkRequireAllOfTimelock
+  getRequireAllOf = getRequireAllOfTimelock
 
-pattern RequireAllOf :: Era era => StrictSeq (Timelock era) -> Timelock era
-pattern RequireAllOf ms <- (getMemoRawType -> AllOf ms)
-  where
-    RequireAllOf ms = mkMemoized (AllOf ms)
+  mkRequireAnyOf = mkRequireAnyOfTimelock
+  getRequireAnyOf = getRequireAnyOfTimelock
 
-pattern RequireAnyOf :: Era era => StrictSeq (Timelock era) -> Timelock era
-pattern RequireAnyOf ms <- (getMemoRawType -> AnyOf ms)
-  where
-    RequireAnyOf ms = mkMemoized (AnyOf ms)
+  mkRequireMOf = mkRequireMOfTimelock
+  getRequireMOf = getRequireMOfTimelock
 
-pattern RequireMOf :: Era era => Int -> StrictSeq (Timelock era) -> Timelock era
-pattern RequireMOf n ms <- (getMemoRawType -> MOfN n ms)
-  where
-    RequireMOf n ms = mkMemoized (MOfN n ms)
+instance Crypto c => AllegraEraScript (AllegraEra c) where
+  {-# SPECIALIZE instance AllegraEraScript (AllegraEra StandardCrypto) #-}
 
-pattern RequireTimeExpire :: Era era => SlotNo -> Timelock era
-pattern RequireTimeExpire mslot <- (getMemoRawType -> TimeExpire mslot)
+  mkTimeStart = mkTimeStartTimelock
+  getTimeStart = getTimeStartTimelock
+
+  mkTimeExpire = mkTimeExpireTimelock
+  getTimeExpire = getTimeExpireTimelock
+
+pattern RequireTimeExpireX :: AllegraEraScript era => SlotNo -> NativeScript era
+pattern RequireTimeExpireX mslot <- (getTimeExpire -> Just mslot)
   where
-    RequireTimeExpire mslot = mkMemoized (TimeExpire mslot)
+    RequireTimeExpireX mslot = mkTimeExpire mslot
 
-pattern RequireTimeStart :: Era era => SlotNo -> Timelock era
-pattern RequireTimeStart mslot <- (getMemoRawType -> TimeStart mslot)
+pattern RequireTimeStartX :: AllegraEraScript era => SlotNo -> NativeScript era
+pattern RequireTimeStartX mslot <- (getTimeStart -> Just mslot)
   where
-    RequireTimeStart mslot = mkMemoized (TimeStart mslot)
+    RequireTimeStartX mslot = mkTimeStart mslot
 
 {-# COMPLETE
-  RequireSignature
-  , RequireAllOf
-  , RequireAnyOf
-  , RequireMOf
-  , RequireTimeExpire
-  , RequireTimeStart
+  RequireSignatureX
+  , RequireAllOfX
+  , RequireAnyOfX
+  , RequireMOfX
+  , RequireTimeExpireX
+  , RequireTimeStartX
   #-}
 
+mkRequireSignatureTimelock :: Era era => KeyHash 'Witness (EraCrypto era) -> Timelock era
+mkRequireSignatureTimelock = mkMemoized . Signature
+getRequireSignatureTimelock :: Era era => Timelock era -> Maybe (KeyHash 'Witness (EraCrypto era))
+getRequireSignatureTimelock (TimelockConstr (Memo (Signature kh) _)) = Just kh
+getRequireSignatureTimelock _ = Nothing
+
+mkRequireAllOfTimelock :: Era era => StrictSeq (Timelock era) -> Timelock era
+mkRequireAllOfTimelock = mkMemoized . AllOf
+getRequireAllOfTimelock :: Era era => Timelock era -> Maybe (StrictSeq (Timelock era))
+getRequireAllOfTimelock (TimelockConstr (Memo (AllOf ms) _)) = Just ms
+getRequireAllOfTimelock _ = Nothing
+
+mkRequireAnyOfTimelock :: Era era => StrictSeq (Timelock era) -> Timelock era
+mkRequireAnyOfTimelock = mkMemoized . AnyOf
+getRequireAnyOfTimelock :: Era era => Timelock era -> Maybe (StrictSeq (Timelock era))
+getRequireAnyOfTimelock (TimelockConstr (Memo (AnyOf ms) _)) = Just ms
+getRequireAnyOfTimelock _ = Nothing
+
+mkRequireMOfTimelock :: Era era => Int -> StrictSeq (Timelock era) -> Timelock era
+mkRequireMOfTimelock n = mkMemoized . MOfN n
+getRequireMOfTimelock :: Era era => Timelock era -> Maybe (Int, (StrictSeq (Timelock era)))
+getRequireMOfTimelock (TimelockConstr (Memo (MOfN n ms) _)) = Just (n, ms)
+getRequireMOfTimelock _ = Nothing
+
+mkTimeStartTimelock :: Era era => SlotNo -> Timelock era
+mkTimeStartTimelock = mkMemoized . TimeStart
+getTimeStartTimelock :: Era era => Timelock era -> Maybe SlotNo
+getTimeStartTimelock (TimelockConstr (Memo (TimeStart mslot) _)) = Just mslot
+getTimeStartTimelock _ = Nothing
+
+mkTimeExpireTimelock :: Era era => SlotNo -> Timelock era
+mkTimeExpireTimelock = mkMemoized . TimeExpire
+getTimeExpireTimelock :: Era era => Timelock era -> Maybe SlotNo
+getTimeExpireTimelock (TimelockConstr (Memo (TimeExpire mslot) _)) = Just mslot
+getTimeExpireTimelock _ = Nothing
+
 -- =================================================================
 -- Evaluating and validating a Timelock
 
@@ -280,10 +343,10 @@ ltePosInfty SNothing _ = False -- ∞ > j
 ltePosInfty (SJust i) j = i <= j
 
 evalTimelock ::
-  Era era =>
+  AllegraEraScript era =>
   Set.Set (KeyHash 'Witness (EraCrypto era)) ->
   ValidityInterval ->
-  Timelock era ->
+  NativeScript era ->
   Bool
 evalTimelock vhks (ValidityInterval txStart txExp) = go
   where
@@ -293,12 +356,12 @@ evalTimelock vhks (ValidityInterval txStart txExp) = go
     isValidMOf n (ts SSeq.:<| tss) =
       n <= 0 || if go ts then isValidMOf (n - 1) tss else isValidMOf n tss
     go = \case
-      RequireTimeStart lockStart -> lockStart `lteNegInfty` txStart
-      RequireTimeExpire lockExp -> txExp `ltePosInfty` lockExp
-      RequireSignature hash -> hash `Set.member` vhks
-      RequireAllOf xs -> all go xs
-      RequireAnyOf xs -> any go xs
-      RequireMOf m xs -> isValidMOf m xs
+      RequireTimeStartX lockStart -> lockStart `lteNegInfty` txStart
+      RequireTimeExpireX lockExp -> txExp `ltePosInfty` lockExp
+      RequireSignatureX hash -> hash `Set.member` vhks
+      RequireAllOfX xs -> all go xs
+      RequireAnyOfX xs -> any go xs
+      RequireMOfX m xs -> isValidMOf m xs
 
 -- =========================================================
 -- Operations on Timelock scripts
@@ -312,19 +375,19 @@ inInterval slot (ValidityInterval (SJust bottom) SNothing) = bottom <= slot
 inInterval slot (ValidityInterval (SJust bottom) (SJust top)) =
   bottom <= slot && slot < top
 
-showTimelock :: Era era => Timelock era -> String
-showTimelock (RequireTimeStart (SlotNo i)) = "(Start >= " ++ show i ++ ")"
-showTimelock (RequireTimeExpire (SlotNo i)) = "(Expire < " ++ show i ++ ")"
-showTimelock (RequireAllOf xs) = "(AllOf " ++ foldl accum ")" xs
+showTimelock :: AllegraEraScript era => NativeScript era -> String
+showTimelock (RequireTimeStartX (SlotNo i)) = "(Start >= " ++ show i ++ ")"
+showTimelock (RequireTimeExpireX (SlotNo i)) = "(Expire < " ++ show i ++ ")"
+showTimelock (RequireAllOfX xs) = "(AllOf " ++ foldl accum ")" xs
   where
     accum ans x = showTimelock x ++ " " ++ ans
-showTimelock (RequireAnyOf xs) = "(AnyOf " ++ foldl accum ")" xs
+showTimelock (RequireAnyOfX xs) = "(AnyOf " ++ foldl accum ")" xs
   where
     accum ans x = showTimelock x ++ " " ++ ans
-showTimelock (RequireMOf m xs) = "(MOf " ++ show m ++ " " ++ foldl accum ")" xs
+showTimelock (RequireMOfX m xs) = "(MOf " ++ show m ++ " " ++ foldl accum ")" xs
   where
     accum ans x = showTimelock x ++ " " ++ ans
-showTimelock (RequireSignature hash) = "(Signature " ++ show hash ++ ")"
+showTimelock (RequireSignatureX hash) = "(Signature " ++ show hash ++ ")"
 
 -- | Check the equality of two underlying types, while ignoring their binary
 -- representation, which `Eq` instance normally does. This is used for testing.

eras/allegra/impl/src/Cardano/Ledger/Allegra/Tx.hs

@@ -13,14 +13,15 @@ where
 
 import Cardano.Ledger.Allegra.Era (AllegraEra)
 import Cardano.Ledger.Allegra.PParams ()
-import Cardano.Ledger.Allegra.Scripts (Timelock, evalTimelock)
+import Cardano.Ledger.Allegra.Scripts (AllegraEraScript (..), evalTimelock)
 import Cardano.Ledger.Allegra.TxAuxData ()
 import Cardano.Ledger.Allegra.TxBody (AllegraEraTxBody (..))
 import Cardano.Ledger.Allegra.TxWits ()
 import Cardano.Ledger.Core (
   EraTx (..),
   EraTxAuxData (upgradeTxAuxData),
   EraTxWits (..),
+  NativeScript,
   upgradeTxBody,
  )
 import Cardano.Ledger.Crypto (Crypto, StandardCrypto)
@@ -75,7 +76,7 @@ instance Crypto c => EraTx (AllegraEra c) where
 -- We still need to correctly compute the witness set for TxBody as well.
 
 validateTimelock ::
-  (EraTx era, AllegraEraTxBody era) => Tx era -> Timelock era -> Bool
+  (EraTx era, AllegraEraTxBody era, AllegraEraScript era) => Tx era -> NativeScript era -> Bool
 validateTimelock tx timelock = evalTimelock vhks (tx ^. bodyTxL . vldtTxBodyL) timelock
   where
     vhks = Set.map witVKeyHash (tx ^. witsTxL . addrTxWitsL)