Merge pull request #4973 from IntersectMBO/lehins/export-previously-internal-parts

Make `MemoBytes` interface safe

Author: lehins

eras/allegra/impl/CHANGELOG.md

@@ -1,8 +1,11 @@
 # Version history for `cardano-ledger-allegra`
 
-## 1.7.0.1
+## 1.8.0.0
 
-*
+* Expose access to `AllegraTxBodyRaw` and `TimelockRaw`
+* Expose constructor `MkAllegraTxBody` and `MkTimelock`
+* Deprecate `TimelockConstr`
+* Rename `atbrTxFee` to `atbrFee` for consistency
 
 ## 1.7.0.0
 

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

@@ -1,6 +1,6 @@
 cabal-version: 3.0
 name: cardano-ledger-allegra
-version: 1.7.0.1
+version: 1.8.0.0
 license: Apache-2.0
 maintainer: operations@iohk.io
 author: IOHK

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

@@ -14,7 +14,6 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
 {-# LANGUAGE ViewPatterns #-}
@@ -34,11 +33,10 @@ module Cardano.Ledger.Allegra.Scripts (
   getTimeStartTimelock,
   mkTimeExpireTimelock,
   getTimeExpireTimelock,
-  Timelock,
+  Timelock (MkTimelock, TimelockConstr),
   pattern RequireTimeExpire,
   pattern RequireTimeStart,
-  TimelockRaw,
-  pattern TimelockConstr,
+  TimelockRaw (..),
   inInterval,
   showTimelock,
   evalTimelock,
@@ -78,11 +76,11 @@ import Cardano.Ledger.MemoBytes (
   byteCountMemoBytes,
   decodeMemoized,
   getMemoRawType,
-  mkMemoBytes,
   mkMemoizedEra,
   packMemoBytesM,
   unpackMemoBytesM,
  )
+import Cardano.Ledger.MemoBytes.Internal (mkMemoBytes)
 import Cardano.Ledger.Shelley.Scripts (
   ShelleyEraScript (..),
   nativeMultiSigTag,
@@ -97,6 +95,7 @@ import Data.Aeson (ToJSON (..), (.=))
 import qualified Data.Aeson as Aeson
 import Data.ByteString.Lazy (fromStrict)
 import Data.ByteString.Short (fromShort)
+import Data.Foldable as F (foldl')
 import Data.MemPack
 import Data.Sequence.Strict as Seq (StrictSeq (Empty, (:<|)))
 import qualified Data.Sequence.Strict as SSeq
@@ -137,13 +136,13 @@ instance ToJSON ValidityInterval where
 -- ==================================================================
 
 data TimelockRaw era
-  = Signature !(KeyHash 'Witness)
-  | AllOf !(StrictSeq (Timelock era)) -- NOTE that Timelock and
-  | AnyOf !(StrictSeq (Timelock era)) -- TimelockRaw are mutually recursive.
-  | MOfN !Int !(StrictSeq (Timelock era))
-  | -- Note that the Int may be negative in which case (MOfN (-2) [..]) is always True
-    TimeStart !SlotNo -- The start time
-  | TimeExpire !SlotNo -- The time it expires
+  = TimelockSignature !(KeyHash 'Witness)
+  | TimelockAllOf !(StrictSeq (Timelock era)) -- NOTE that Timelock and
+  | TimelockAnyOf !(StrictSeq (Timelock era)) -- TimelockRaw are mutually recursive.
+  | TimelockMOf !Int !(StrictSeq (Timelock era))
+  | -- Note that the Int may be negative in which case (TimelockMOf (-2) [..]) is always True
+    TimelockTimeStart !SlotNo -- The start time
+  | TimelockTimeExpire !SlotNo -- The time it expires
   deriving (Eq, Generic, NFData)
 
 class ShelleyEraScript era => AllegraEraScript era where
@@ -167,51 +166,51 @@ translateTimelock ::
   ) =>
   Timelock era1 ->
   Timelock era2
-translateTimelock (TimelockConstr (Memo tl bs)) =
-  let rewrap rtl = TimelockConstr $ mkMemoBytes rtl (fromStrict $ fromShort bs)
+translateTimelock (MkTimelock (Memo tl bs)) =
+  let rewrap rtl = MkTimelock $ mkMemoBytes rtl (fromStrict $ fromShort bs)
    in case tl of
-        Signature s -> rewrap $ Signature s
-        AllOf l -> rewrap . AllOf $ translateTimelock <$> l
-        AnyOf l -> rewrap . AnyOf $ translateTimelock <$> l
-        MOfN n l -> rewrap $ MOfN n (translateTimelock <$> l)
-        TimeStart x -> rewrap $ TimeStart x
-        TimeExpire x -> rewrap $ TimeExpire x
+        TimelockSignature s -> rewrap $ TimelockSignature s
+        TimelockAllOf l -> rewrap . TimelockAllOf $ translateTimelock <$> l
+        TimelockAnyOf l -> rewrap . TimelockAnyOf $ translateTimelock <$> l
+        TimelockMOf n l -> rewrap $ TimelockMOf n (translateTimelock <$> l)
+        TimelockTimeStart x -> rewrap $ TimelockTimeStart x
+        TimelockTimeExpire x -> rewrap $ TimelockTimeExpire x
 
 -- These coding choices are chosen so that a MultiSig script
 -- can be deserialised as a Timelock script
 
 instance Era era => EncCBOR (TimelockRaw era) where
   encCBOR =
     encode . \case
-      Signature hash -> Sum Signature 0 !> To hash
-      AllOf xs -> Sum AllOf 1 !> To xs
-      AnyOf xs -> Sum AnyOf 2 !> To xs
-      MOfN m xs -> Sum MOfN 3 !> To m !> To xs
-      TimeStart m -> Sum TimeStart 4 !> To m
-      TimeExpire m -> Sum TimeExpire 5 !> To m
+      TimelockSignature hash -> Sum TimelockSignature 0 !> To hash
+      TimelockAllOf xs -> Sum TimelockAllOf 1 !> To xs
+      TimelockAnyOf xs -> Sum TimelockAnyOf 2 !> To xs
+      TimelockMOf m xs -> Sum TimelockMOf 3 !> To m !> To xs
+      TimelockTimeStart m -> Sum TimelockTimeStart 4 !> To m
+      TimelockTimeExpire m -> Sum TimelockTimeExpire 5 !> To m
 
 -- This instance allows us to derive instance DecCBOR (Annotator (Timelock era)).
 -- Since Timelock is a newtype around (Memo (Timelock era)).
 instance Era era => DecCBOR (Annotator (TimelockRaw era)) where
   decCBOR = decode (Summands "TimelockRaw" decRaw)
     where
       decRaw :: Word -> Decode 'Open (Annotator (TimelockRaw era))
-      decRaw 0 = Ann (SumD Signature <! From)
-      decRaw 1 = Ann (SumD AllOf) <*! D (sequence <$> decCBOR)
-      decRaw 2 = Ann (SumD AnyOf) <*! D (sequence <$> decCBOR)
-      decRaw 3 = Ann (SumD MOfN) <*! Ann From <*! D (sequence <$> decCBOR)
-      decRaw 4 = Ann (SumD TimeStart <! From)
-      decRaw 5 = Ann (SumD TimeExpire <! From)
+      decRaw 0 = Ann (SumD TimelockSignature <! From)
+      decRaw 1 = Ann (SumD TimelockAllOf) <*! D (sequence <$> decCBOR)
+      decRaw 2 = Ann (SumD TimelockAnyOf) <*! D (sequence <$> decCBOR)
+      decRaw 3 = Ann (SumD TimelockMOf) <*! Ann From <*! D (sequence <$> decCBOR)
+      decRaw 4 = Ann (SumD TimelockTimeStart <! From)
+      decRaw 5 = Ann (SumD TimelockTimeExpire <! From)
       decRaw n = Invalid n
 
 instance Era era => DecCBOR (TimelockRaw era) where
   decCBOR = decode $ Summands "TimelockRaw" $ \case
-    0 -> SumD Signature <! From
-    1 -> SumD AllOf <! From
-    2 -> SumD AnyOf <! From
-    3 -> SumD MOfN <! From <! From
-    4 -> SumD TimeStart <! From
-    5 -> SumD TimeExpire <! From
+    0 -> SumD TimelockSignature <! From
+    1 -> SumD TimelockAllOf <! From
+    2 -> SumD TimelockAnyOf <! From
+    3 -> SumD TimelockMOf <! From <! From
+    4 -> SumD TimelockTimeStart <! From
+    5 -> SumD TimelockTimeExpire <! From
     n -> Invalid n
 
 -- =================================================================
@@ -220,20 +219,25 @@ instance Era era => DecCBOR (TimelockRaw era) where
 -- They rely on memoBytes, and TimelockRaw to memoize each constructor of Timelock
 -- =================================================================
 
-newtype Timelock era = TimelockConstr (MemoBytes (TimelockRaw era))
+newtype Timelock era = MkTimelock (MemoBytes (TimelockRaw era))
   deriving (Eq, Generic)
   deriving newtype (ToCBOR, NFData, SafeToHash)
 
+pattern TimelockConstr :: MemoBytes (TimelockRaw era) -> Timelock era
+pattern TimelockConstr timelockRaw = MkTimelock timelockRaw
+{-# COMPLETE TimelockConstr #-}
+{-# DEPRECATED TimelockConstr "In favor of more consistently name `MkTimelock`" #-}
+
 instance Era era => MemPack (Timelock era) where
-  packedByteCount (TimelockConstr mb) = byteCountMemoBytes mb
-  packM (TimelockConstr mb) = packMemoBytesM mb
-  unpackM = TimelockConstr <$> unpackMemoBytesM (eraProtVerLow @era)
+  packedByteCount (MkTimelock mb) = byteCountMemoBytes mb
+  packM (MkTimelock mb) = packMemoBytesM mb
+  unpackM = MkTimelock <$> unpackMemoBytesM (eraProtVerLow @era)
 
 instance Era era => NoThunks (Timelock era)
 instance Era era => EncCBOR (Timelock era)
 
 instance Era era => DecCBOR (Timelock era) where
-  decCBOR = TimelockConstr <$> decodeMemoized decCBOR
+  decCBOR = MkTimelock <$> decodeMemoized decCBOR
 
 instance Memoized (Timelock era) where
   type RawType (Timelock era) = TimelockRaw era
@@ -244,7 +248,7 @@ instance EqRaw (Timelock era) where
   eqRaw = eqTimelockRaw
 
 instance Era era => DecCBOR (Annotator (Timelock era)) where
-  decCBOR = fmap TimelockConstr <$> decCBOR
+  decCBOR = fmap MkTimelock <$> decCBOR
 
 -- | Since Timelock scripts are a strictly backwards compatible extension of
 -- MultiSig scripts, we can use the same 'scriptPrefixTag' tag here as we did
@@ -306,39 +310,39 @@ pattern RequireTimeStart mslot <- (getTimeStart -> Just mslot)
   #-}
 
 mkRequireSignatureTimelock :: forall era. Era era => KeyHash 'Witness -> Timelock era
-mkRequireSignatureTimelock = mkMemoizedEra @era . Signature
+mkRequireSignatureTimelock = mkMemoizedEra @era . TimelockSignature
 getRequireSignatureTimelock :: Timelock era -> Maybe (KeyHash 'Witness)
-getRequireSignatureTimelock (TimelockConstr (Memo (Signature kh) _)) = Just kh
+getRequireSignatureTimelock (MkTimelock (Memo (TimelockSignature kh) _)) = Just kh
 getRequireSignatureTimelock _ = Nothing
 
 mkRequireAllOfTimelock :: forall era. Era era => StrictSeq (Timelock era) -> Timelock era
-mkRequireAllOfTimelock = mkMemoizedEra @era . AllOf
+mkRequireAllOfTimelock = mkMemoizedEra @era . TimelockAllOf
 getRequireAllOfTimelock :: Timelock era -> Maybe (StrictSeq (Timelock era))
-getRequireAllOfTimelock (TimelockConstr (Memo (AllOf ms) _)) = Just ms
+getRequireAllOfTimelock (MkTimelock (Memo (TimelockAllOf ms) _)) = Just ms
 getRequireAllOfTimelock _ = Nothing
 
 mkRequireAnyOfTimelock :: forall era. Era era => StrictSeq (Timelock era) -> Timelock era
-mkRequireAnyOfTimelock = mkMemoizedEra @era . AnyOf
+mkRequireAnyOfTimelock = mkMemoizedEra @era . TimelockAnyOf
 getRequireAnyOfTimelock :: Timelock era -> Maybe (StrictSeq (Timelock era))
-getRequireAnyOfTimelock (TimelockConstr (Memo (AnyOf ms) _)) = Just ms
+getRequireAnyOfTimelock (MkTimelock (Memo (TimelockAnyOf ms) _)) = Just ms
 getRequireAnyOfTimelock _ = Nothing
 
 mkRequireMOfTimelock :: forall era. Era era => Int -> StrictSeq (Timelock era) -> Timelock era
-mkRequireMOfTimelock n = mkMemoizedEra @era . MOfN n
+mkRequireMOfTimelock n = mkMemoizedEra @era . TimelockMOf n
 getRequireMOfTimelock :: Timelock era -> Maybe (Int, StrictSeq (Timelock era))
-getRequireMOfTimelock (TimelockConstr (Memo (MOfN n ms) _)) = Just (n, ms)
+getRequireMOfTimelock (MkTimelock (Memo (TimelockMOf n ms) _)) = Just (n, ms)
 getRequireMOfTimelock _ = Nothing
 
 mkTimeStartTimelock :: forall era. Era era => SlotNo -> Timelock era
-mkTimeStartTimelock = mkMemoizedEra @era . TimeStart
+mkTimeStartTimelock = mkMemoizedEra @era . TimelockTimeStart
 getTimeStartTimelock :: Timelock era -> Maybe SlotNo
-getTimeStartTimelock (TimelockConstr (Memo (TimeStart mslot) _)) = Just mslot
+getTimeStartTimelock (MkTimelock (Memo (TimelockTimeStart mslot) _)) = Just mslot
 getTimeStartTimelock _ = Nothing
 
 mkTimeExpireTimelock :: forall era. Era era => SlotNo -> Timelock era
-mkTimeExpireTimelock = mkMemoizedEra @era . TimeExpire
+mkTimeExpireTimelock = mkMemoizedEra @era . TimelockTimeExpire
 getTimeExpireTimelock :: Timelock era -> Maybe SlotNo
-getTimeExpireTimelock (TimelockConstr (Memo (TimeExpire mslot) _)) = Just mslot
+getTimeExpireTimelock (MkTimelock (Memo (TimelockTimeExpire mslot) _)) = Just mslot
 getTimeExpireTimelock _ = Nothing
 
 -- =================================================================
@@ -390,13 +394,13 @@ inInterval slot (ValidityInterval (SJust bottom) (SJust top)) =
 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
+showTimelock (RequireAllOf xs) = "(AllOf " ++ F.foldl' accum ")" xs
   where
     accum ans x = showTimelock x ++ " " ++ ans
-showTimelock (RequireAnyOf xs) = "(AnyOf " ++ foldl accum ")" xs
+showTimelock (RequireAnyOf xs) = "(AnyOf " ++ F.foldl' accum ")" xs
   where
     accum ans x = showTimelock x ++ " " ++ ans
-showTimelock (RequireMOf m xs) = "(MOf " ++ show m ++ " " ++ foldl accum ")" xs
+showTimelock (RequireMOf m xs) = "(MOf " ++ show m ++ " " ++ F.foldl' accum ")" xs
   where
     accum ans x = showTimelock x ++ " " ++ ans
 showTimelock (RequireSignature hash) = "(Signature " ++ show hash ++ ")"
@@ -409,10 +413,10 @@ eqTimelockRaw t1 t2 = go (getMemoRawType t1) (getMemoRawType t2)
     seqEq Empty Empty = True
     seqEq (x :<| xs) (y :<| ys) = eqTimelockRaw x y && seqEq xs ys
     seqEq _ _ = False
-    go (Signature kh1) (Signature kh2) = kh1 == kh2
-    go (AllOf ts1) (AllOf ts2) = seqEq ts1 ts2
-    go (AnyOf ts1) (AnyOf ts2) = seqEq ts1 ts2
-    go (MOfN n1 ts1) (MOfN n2 ts2) = n1 == n2 && seqEq ts1 ts2
-    go (TimeStart sn1) (TimeStart sn2) = sn1 == sn2
-    go (TimeExpire sn1) (TimeExpire sn2) = sn1 == sn2
+    go (TimelockSignature kh1) (TimelockSignature kh2) = kh1 == kh2
+    go (TimelockAllOf ts1) (TimelockAllOf ts2) = seqEq ts1 ts2
+    go (TimelockAnyOf ts1) (TimelockAnyOf ts2) = seqEq ts1 ts2
+    go (TimelockMOf n1 ts1) (TimelockMOf n2 ts2) = n1 == n2 && seqEq ts1 ts2
+    go (TimelockTimeStart sn1) (TimelockTimeStart sn2) = sn1 == sn2
+    go (TimelockTimeExpire sn1) (TimelockTimeExpire sn2) = sn1 == sn2
     go _ _ = False

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

@@ -1,6 +1,7 @@
 module Cardano.Ledger.Allegra.TxBody (
   AllegraEraTxBody (..),
   AllegraTxBody (
+    MkAllegraTxBody,
     AllegraTxBody,
     atbAuxDataHash,
     atbCerts,

eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody/Internal.hs

@@ -12,7 +12,6 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
 {-# LANGUAGE ViewPatterns #-}
@@ -30,7 +29,7 @@
 module Cardano.Ledger.Allegra.TxBody.Internal (
   AllegraEraTxBody (..),
   AllegraTxBody (
-    ..,
+    MkAllegraTxBody,
     AllegraTxBody,
     atbAuxDataHash,
     atbCerts,
@@ -102,7 +101,7 @@ data AllegraTxBodyRaw ma era = AllegraTxBodyRaw
   , atbrOutputs :: !(StrictSeq (TxOut era))
   , atbrCerts :: !(StrictSeq (TxCert era))
   , atbrWithdrawals :: !Withdrawals
-  , atbrTxFee :: !Coin
+  , atbrFee :: !Coin
   , atbrValidityInterval :: !ValidityInterval
   , atbrUpdate :: !(StrictMaybe (Update era))
   , atbrAuxDataHash :: !(StrictMaybe TxAuxDataHash)
@@ -134,10 +133,13 @@ instance (DecCBOR ma, Monoid ma, AllegraEraTxBody era) => DecCBOR (AllegraTxBody
           "AllegraTxBodyRaw"
           emptyAllegraTxBodyRaw
           bodyFields
-          [(0, "atbrInputs"), (1, "atbrOutputs"), (2, "atbrTxFee")]
+          [(0, "atbrInputs"), (1, "atbrOutputs"), (2, "atbrFee")]
       )
 
-instance AllegraEraTxBody era => DecCBOR (Annotator (AllegraTxBodyRaw () era)) where
+instance
+  (DecCBOR m, Monoid m, AllegraEraTxBody era) =>
+  DecCBOR (Annotator (AllegraTxBodyRaw m era))
+  where
   decCBOR = pure <$> decCBOR
 
 -- Sparse encodings of AllegraTxBodyRaw, the key values are fixed by backward compatibility
@@ -167,7 +169,7 @@ instance
 bodyFields :: (DecCBOR ma, EraTxOut era, EraTxCert era) => Word -> Field (AllegraTxBodyRaw ma era)
 bodyFields 0 = field (\x tx -> tx {atbrInputs = x}) From
 bodyFields 1 = field (\x tx -> tx {atbrOutputs = x}) From
-bodyFields 2 = field (\x tx -> tx {atbrTxFee = x}) From
+bodyFields 2 = field (\x tx -> tx {atbrFee = x}) From
 bodyFields 3 =
   ofield
     ( \x tx ->
@@ -209,7 +211,7 @@ emptyAllegraTxBodyRaw =
 -- ===========================================================================
 -- Wrap it all up in a newtype, hiding the insides with a pattern construtor.
 
-newtype AllegraTxBody e = TxBodyConstr (MemoBytes (AllegraTxBodyRaw () e))
+newtype AllegraTxBody e = MkAllegraTxBody (MemoBytes (AllegraTxBodyRaw () e))
   deriving newtype (SafeToHash, ToCBOR, DecCBOR)
 
 instance Memoized (AllegraTxBody era) where
@@ -279,7 +281,7 @@ pattern AllegraTxBody
         , atbrOutputs = atbOutputs
         , atbrCerts = atbCerts
         , atbrWithdrawals = atbWithdrawals
-        , atbrTxFee = atbTxFee
+        , atbrFee = atbTxFee
         , atbrValidityInterval = atbValidityInterval
         , atbrUpdate = atbUpdate
         , atbrAuxDataHash = atbAuxDataHash
@@ -301,7 +303,7 @@ pattern AllegraTxBody
             , atbrOutputs = outputs
             , atbrCerts = certs
             , atbrWithdrawals = withdrawals
-            , atbrTxFee = txFee
+            , atbrFee = txFee
             , atbrValidityInterval = validityInterval
             , atbrUpdate = update
             , atbrAuxDataHash = auxDataHash
@@ -326,8 +328,7 @@ instance EraTxBody AllegraEra where
   {-# INLINEABLE outputsTxBodyL #-}
 
   feeTxBodyL =
-    lensMemoRawType @AllegraEra atbrTxFee $
-      \txBodyRaw fee -> txBodyRaw {atbrTxFee = fee}
+    lensMemoRawType @AllegraEra atbrFee $ \txBodyRaw fee -> txBodyRaw {atbrFee = fee}
   {-# INLINEABLE feeTxBodyL #-}
 
   auxDataHashTxBodyL =