wip

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

@@ -15,13 +15,27 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Cardano.Ledger.Allegra.Scripts (
+  AllegraEraScript (..),
+  mkRequireSignatureTimelock,
+  getRequireSignatureTimelock,
+  mkRequireAllOfTimelock,
+  getRequireAllOfTimelock,
+  mkRequireAnyOfTimelock,
+  getRequireAnyOfTimelock,
+  mkRequireMOfTimelock,
+  getRequireMOfTimelock,
+  mkTimeStartTimelock,
+  getTimeStartTimelock,
+  mkTimeExpireTimelock,
+  getTimeExpireTimelock,
   Timelock (
-    RequireSignature,
-    RequireAllOf,
+    -- RequireSignature,
+    -- RequireAllOf,
     RequireAnyOf,
     RequireMOf,
     RequireTimeExpire,
@@ -74,7 +88,13 @@ import Cardano.Ledger.MemoBytes (
   mkMemoized,
  )
 import Cardano.Ledger.SafeHash (SafeToHash)
-import Cardano.Ledger.Shelley.Scripts (nativeMultiSigTag)
+import Cardano.Ledger.Shelley.Scripts (
+  ShelleyEraScript (..),
+  nativeMultiSigTag,
+  pattern RequireAllOfX,
+  pattern RequireSignatureX,
+ )
+
 import qualified Cardano.Ledger.Shelley.Scripts as Shelley
 import Cardano.Slotting.Slot (SlotNo (..))
 import Control.DeepSeq (NFData (..))
@@ -130,6 +150,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)
@@ -208,8 +235,8 @@ 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
+    RequireSignatureX keyHash -> undefined -- RequireSignatureX keyHash
+    RequireAllOfX sigs -> undefined -- 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
 
@@ -219,6 +246,58 @@ instance Crypto c => EraScript (AllegraEra c) where
 
   fromNativeScript = id
 
+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 => [Timelock era] -> Timelock era
+mkRequireAnyOfTimelock = mkMemoized . AnyOf . Seq.fromList
+getRequireAnyOfTimelock :: Era era => [Timelock era] -> Maybe [Timelock era]
+getRequireAnyOfTimelock = undefined
+
+mkRequireMOfTimelock :: Era era => Int -> [Timelock era] -> Timelock era
+mkRequireMOfTimelock n = mkMemoized . MOfN n . Seq.fromList
+getRequireMOfTimelock :: Era era => [Timelock era] -> Maybe [Timelock era]
+getRequireMOfTimelock = undefined
+
+mkTimeStartTimelock :: Era era => SlotNo -> Timelock era
+mkTimeStartTimelock = mkMemoized . TimeStart
+getTimeStartTimelock :: Era era => Timelock era -> Maybe SlotNo
+getTimeStartTimelock = undefined
+
+mkTimeExpireTimelock :: Era era => SlotNo -> Timelock era
+mkTimeExpireTimelock = mkMemoized . TimeExpire
+getTimeExpireTimelock :: Era era => Timelock era -> Maybe SlotNo
+getTimeExpireTimelock = undefined
+
+instance Crypto c => ShelleyEraScript (AllegraEra c) where
+  mkRequireSignature = mkRequireSignatureTimelock
+  getRequireSignature = getRequireSignatureTimelock
+
+  mkRequireAllOf = mkRequireAllOfTimelock
+  getRequireAllOf = getRequireAllOfTimelock
+
+  mkRequireAnyOf = undefined
+  getRequireAnyOf = undefined
+
+  mkRequireMOf = undefined
+  getRequireMOf = undefined
+
+instance Crypto c => AllegraEraScript (AllegraEra c) where
+  mkTimeStart = mkTimeStartTimelock
+  getTimeStart = getTimeStartTimelock
+
+  mkTimeExpire = RequireTimeExpire
+  getTimeExpire = getTimeExpireTimelock
+
 instance EqRaw (Timelock era) where
   eqRaw = eqTimelockRaw
 
@@ -227,15 +306,15 @@ deriving via
   instance
     Era era => DecCBOR (Annotator (Timelock era))
 
-pattern RequireSignature :: Era era => KeyHash 'Witness (EraCrypto era) -> Timelock era
-pattern RequireSignature akh <- (getMemoRawType -> Signature akh)
-  where
-    RequireSignature akh = mkMemoized (Signature akh)
+-- pattern RequireSignature :: Era era => KeyHash 'Witness (EraCrypto era) -> Timelock era
+-- pattern RequireSignature akh <- (getMemoRawType -> Signature akh)
+--   where
+--     RequireSignature akh = mkMemoized (Signature akh)
 
-pattern RequireAllOf :: Era era => StrictSeq (Timelock era) -> Timelock era
-pattern RequireAllOf ms <- (getMemoRawType -> AllOf ms)
-  where
-    RequireAllOf ms = mkMemoized (AllOf ms)
+-- pattern RequireAllOf :: Era era => StrictSeq (Timelock era) -> Timelock era
+-- pattern RequireAllOf ms <- (getMemoRawType -> AllOf ms)
+--   where
+--     RequireAllOf ms = mkMemoized (AllOf ms)
 
 pattern RequireAnyOf :: Era era => StrictSeq (Timelock era) -> Timelock era
 pattern RequireAnyOf ms <- (getMemoRawType -> AnyOf ms)
@@ -257,14 +336,14 @@ pattern RequireTimeStart mslot <- (getMemoRawType -> TimeStart mslot)
   where
     RequireTimeStart mslot = mkMemoized (TimeStart mslot)
 
-{-# COMPLETE
-  RequireSignature
-  , RequireAllOf
-  , RequireAnyOf
-  , RequireMOf
-  , RequireTimeExpire
-  , RequireTimeStart
-  #-}
+-- {-# COMPLETE
+--   RequireSignature
+--   , RequireAllOf
+--   , RequireAnyOf
+--   , RequireMOf
+--   , RequireTimeExpire
+--   , RequireTimeStart
+--   #-}
 
 -- =================================================================
 -- Evaluating and validating a Timelock
@@ -280,10 +359,11 @@ ltePosInfty SNothing _ = False -- ∞ > j
 ltePosInfty (SJust i) j = i <= j
 
 evalTimelock ::
-  Era era =>
+  AllegraEraScript era =>
   Set.Set (KeyHash 'Witness (EraCrypto era)) ->
   ValidityInterval ->
-  Timelock era ->
+  -- Timelock era ->
+  NativeScript era ->
   Bool
 evalTimelock vhks (ValidityInterval txStart txExp) = go
   where
@@ -293,12 +373,13 @@ 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
+      -- RequireTimeStart lockStart -> lockStart `lteNegInfty` txStart
+      -- RequireTimeExpire lockExp -> txExp `ltePosInfty` lockExp
+      RequireSignatureX hash -> hash `Set.member` vhks
+      RequireAllOfX xs -> all go xs
+      -- RequireAnyOf xs -> any go xs
+      -- RequireMOf m xs -> isValidMOf m xs
+      _ -> undefined
 
 -- =========================================================
 -- Operations on Timelock scripts
@@ -312,19 +393,20 @@ 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
-  where
-    accum ans x = showTimelock x ++ " " ++ ans
-showTimelock (RequireAnyOf xs) = "(AnyOf " ++ foldl accum ")" xs
-  where
-    accum ans x = showTimelock x ++ " " ++ ans
-showTimelock (RequireMOf m xs) = "(MOf " ++ show m ++ " " ++ foldl accum ")" xs
-  where
-    accum ans x = showTimelock x ++ " " ++ ans
-showTimelock (RequireSignature hash) = "(Signature " ++ show hash ++ ")"
+showTimelock :: AllegraEraScript era => NativeScript era -> String
+-- showTimelock (RequireTimeStart (SlotNo i)) = "(Start >= " ++ show i ++ ")"
+-- showTimelock (RequireTimeExpire (SlotNo i)) = "(Expire < " ++ show i ++ ")"
+-- showTimelock (RequireAllOf xs) = "(AllOf " ++ foldl accum ")" xs
+--   where
+--     accum ans x = showTimelock x ++ " " ++ ans
+-- showTimelock (RequireAnyOf xs) = "(AnyOf " ++ foldl accum ")" xs
+--   where
+--     accum ans x = showTimelock x ++ " " ++ ans
+-- showTimelock (RequireMOf m xs) = "(MOf " ++ show m ++ " " ++ foldl accum ")" xs
+--   where
+--     accum ans x = showTimelock x ++ " " ++ ans
+showTimelock (RequireSignatureX hash) = "(Signature " ++ show hash ++ ")"
+showTimeLock _ = undefined
 
 -- | 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 (..), Timelock, 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)

eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Arbitrary.hs

@@ -14,7 +14,7 @@ module Test.Cardano.Ledger.Allegra.Arbitrary (
 ) where
 
 import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure)
-import Cardano.Ledger.Allegra.Scripts (Timelock (..), ValidityInterval (..))
+import Cardano.Ledger.Allegra.Scripts (AllegraEraScript (..), Timelock (..), ValidityInterval (..))
 import Cardano.Ledger.Allegra.TxAuxData (AllegraTxAuxData (..))
 import Cardano.Ledger.Allegra.TxBody (AllegraTxBody (AllegraTxBody))
 import Cardano.Ledger.Binary (EncCBOR)
@@ -44,37 +44,40 @@ maxTimelockListLens :: Int
 maxTimelockListLens = 5
 
 sizedTimelock ::
-  Era era =>
+  AllegraEraScript era =>
   Int ->
-  Gen (Timelock era)
-sizedTimelock 0 = RequireSignature . KeyHash . mkDummyHash <$> (arbitrary :: Gen Int)
-sizedTimelock n =
-  oneof
-    [ RequireSignature . KeyHash . mkDummyHash <$> (arbitrary :: Gen Int)
-    , RequireAllOf
-        <$> ( fromList
-                <$> resize
-                  maxTimelockListLens
-                  (listOf (sizedTimelock (n - 1)))
-            )
-    , RequireAnyOf
-        <$> ( fromList
-                <$> resize
-                  maxTimelockListLens
-                  (listOf (sizedTimelock (n - 1)))
-            )
-    , do
-        subs <- resize maxTimelockListLens (listOf (sizedTimelock (n - 1)))
-        let i = length subs
-        RequireMOf <$> choose (0, i) <*> pure (fromList subs)
-    , RequireTimeStart <$> arbitrary
-    , RequireTimeExpire <$> arbitrary
-    ]
+  Gen (NativeScript era)
+sizedTimelock = undefined
+
+-- sizedTimelock 0 = RequireSignature . KeyHash . mkDummyHash <$> (arbitrary :: Gen Int)
+-- sizedTimelock n =
+--   oneof
+--     [ RequireSignature . KeyHash . mkDummyHash <$> (arbitrary :: Gen Int)
+--     , RequireAllOf
+--         <$> ( fromList
+--                 <$> resize
+--                   maxTimelockListLens
+--                   (listOf (sizedTimelock (n - 1)))
+--             )
+--     , RequireAnyOf
+--         <$> ( fromList
+--                 <$> resize
+--                   maxTimelockListLens
+--                   (listOf (sizedTimelock (n - 1)))
+--             )
+--     , do
+--         subs <- resize maxTimelockListLens (listOf (sizedTimelock (n - 1)))
+--         let i = length subs
+--         RequireMOf <$> choose (0, i) <*> pure (fromList subs)
+--     , RequireTimeStart <$> arbitrary
+--     , RequireTimeExpire <$> arbitrary
+--     ]
 
 -- TODO Generate metadata with script preimages
 instance
   forall era.
-  ( EncCBOR (Script era)
+  ( AllegraEraScript era
+  , EncCBOR (Script era)
   , Arbitrary (Script era)
   , Era era
   ) =>
@@ -95,7 +98,7 @@ instance
     genMetadata' @era >>= \case
       ShelleyTxAuxData m -> AllegraTxAuxData m <$> (genScriptSeq @era)
 
-genScriptSeq :: Era era => Gen (StrictSeq (Timelock era))
+genScriptSeq :: AllegraEraScript era => Gen (StrictSeq (Timelock era))
 genScriptSeq = do
   n <- choose (0, 3)
   l <- vectorOf n arbitrary
@@ -131,8 +134,8 @@ instance
       <*> scale (`div` 15) arbitrary
       <*> arbitrary
 
-instance Era era => Arbitrary (Timelock era) where
-  arbitrary = sizedTimelock maxTimelockDepth
+instance AllegraEraScript era => Arbitrary (Timelock era) where
+  arbitrary = undefined -- sizedTimelock maxTimelockDepth
 
 instance Arbitrary ValidityInterval where
   arbitrary = genericArbitraryU