{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}

-- | Provides MemoBytes internals
--
-- = Warning
--
-- This module is considered __internal__.
--
-- The contents of this module may change __in any way whatsoever__
-- and __without any warning__ between minor versions of this package.
module Cardano.Ledger.MemoBytes.Internal (
  MemoBytes (.., Memo),
  MemoHashIndex,
  Mem,
  mkMemoBytes,
  getMemoBytesType,
  getMemoBytesHash,
  memoBytes,
  memoBytesEra,
  shorten,
  showMemo,
  printMemo,
  shortToLazy,
  contentsEq,
  decodeMemoBytes,

  -- * Memoized
  Memoized (RawType),
  mkMemoized,
  mkMemoizedEra,
  decodeMemoized,
  getMemoSafeHash,
  getMemoRawType,
  zipMemoRawType,
  eqRawType,
  getMemoRawBytes,
  lensMemoRawType,
  getterMemoRawType,

  -- * MemoBytes MemPack instance definitions
  byteCountMemoBytes,
  packMemoBytesM,
  unpackMemoBytesM,

  -- * Raw equality
  EqRaw (..),
)
where

import Cardano.Crypto.Hash (HashAlgorithm (hashAlgorithmName))
import Cardano.Ledger.Binary (
  Annotated (..),
  Annotator (..),
  DecCBOR (decCBOR),
  Decoder,
  EncCBOR,
  Version,
  decodeAnnotated,
  decodeFullAnnotator,
  serialize,
  withSlice,
 )
import Cardano.Ledger.Binary.Coders (Encode, encode, runE)
import qualified Cardano.Ledger.Binary.Plain as Plain
import Cardano.Ledger.Core.Era (Era, eraProtVerLow)
import Cardano.Ledger.Hashes (HASH, SafeHash, SafeToHash (..))
import Control.DeepSeq (NFData (..))
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (fromStrict, toStrict)
import qualified Data.ByteString.Lazy as BSL
import Data.ByteString.Short (ShortByteString, fromShort, toShort)
import qualified Data.ByteString.Short as SBS (length)
import Data.Coerce
import Data.MemPack
import Data.MemPack.Buffer (Buffer)
import qualified Data.Text as T
import Data.Typeable
import GHC.Base (Type)
import GHC.Generics (Generic)
import Lens.Micro
import NoThunks.Class (AllowThunksIn (..), NoThunks (..))
import Prelude hiding (span)

-- ========================================================================

-- | Pair together a type @t@ and its serialization. Used to encode a type
--   that is serialized over the network, and to remember the original bytes
--   that were used to transmit it. Important since hashes are computed
--   from the serialization of a type, and EncCBOR instances do not have unique
--   serializations.
data MemoBytes t = Memo'
  { forall t. MemoBytes t -> t
mbRawType :: !t
  , forall t. MemoBytes t -> ShortByteString
mbBytes :: ShortByteString
  , forall t. MemoBytes t -> SafeHash (MemoHashIndex t)
mbHash :: SafeHash (MemoHashIndex t)
  }
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall t x. Rep (MemoBytes t) x -> MemoBytes t
forall t x. MemoBytes t -> Rep (MemoBytes t) x
$cto :: forall t x. Rep (MemoBytes t) x -> MemoBytes t
$cfrom :: forall t x. MemoBytes t -> Rep (MemoBytes t) x
Generic)
  deriving (Context -> MemoBytes t -> IO (Maybe ThunkInfo)
Proxy (MemoBytes t) -> String
forall t.
(Typeable t, NoThunks t) =>
Context -> MemoBytes t -> IO (Maybe ThunkInfo)
forall t. (Typeable t, NoThunks t) => Proxy (MemoBytes t) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (MemoBytes t) -> String
$cshowTypeOf :: forall t. (Typeable t, NoThunks t) => Proxy (MemoBytes t) -> String
wNoThunks :: Context -> MemoBytes t -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall t.
(Typeable t, NoThunks t) =>
Context -> MemoBytes t -> IO (Maybe ThunkInfo)
noThunks :: Context -> MemoBytes t -> IO (Maybe ThunkInfo)
$cnoThunks :: forall t.
(Typeable t, NoThunks t) =>
Context -> MemoBytes t -> IO (Maybe ThunkInfo)
NoThunks) via AllowThunksIn '["mbBytes", "mbHash"] (MemoBytes t)

pattern Memo :: t -> ShortByteString -> MemoBytes t
pattern $bMemo :: forall t. t -> ShortByteString -> MemoBytes t
$mMemo :: forall {r} {t}.
MemoBytes t -> (t -> ShortByteString -> r) -> ((# #) -> r) -> r
Memo memoType memoBytes <-
  Memo' memoType memoBytes _
  where
    Memo t
mt ShortByteString
mb = forall t. t -> ByteString -> MemoBytes t
mkMemoBytes t
mt (ShortByteString -> ByteString
shortToLazy ShortByteString
mb)

{-# COMPLETE Memo #-}

byteCountMemoBytes :: MemoBytes t -> Int
byteCountMemoBytes :: forall t. MemoBytes t -> Int
byteCountMemoBytes = forall a. MemPack a => a -> Int
packedByteCount forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. MemoBytes t -> ShortByteString
mbBytes

packMemoBytesM :: MemoBytes t -> Pack s ()
packMemoBytesM :: forall t s. MemoBytes t -> Pack s ()
packMemoBytesM = forall a s. MemPack a => a -> Pack s ()
packM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. MemoBytes t -> ShortByteString
mbBytes

unpackMemoBytesM ::
  forall t b.
  (Typeable t, DecCBOR (Annotator t), Buffer b) =>
  Version ->
  Unpack b (MemoBytes t)
unpackMemoBytesM :: forall t b.
(Typeable t, DecCBOR (Annotator t), Buffer b) =>
Version -> Unpack b (MemoBytes t)
unpackMemoBytesM Version
v = forall a b. (MemPack a, Buffer b) => Unpack b a
unpackM forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall t (m :: * -> *).
(Typeable t, DecCBOR (Annotator t), MonadFail m) =>
Version -> ByteString -> m (MemoBytes t)
decodeMemoBytes Version
v

decodeMemoBytes ::
  forall t m.
  (Typeable t, DecCBOR (Annotator t), MonadFail m) => Version -> ByteString -> m (MemoBytes t)
decodeMemoBytes :: forall t (m :: * -> *).
(Typeable t, DecCBOR (Annotator t), MonadFail m) =>
Version -> ByteString -> m (MemoBytes t)
decodeMemoBytes Version
v ByteString
bs =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall a.
Version
-> Text
-> (forall s. Decoder s (Annotator a))
-> ByteString
-> Either DecoderError a
decodeFullAnnotator
      Version
v
      (String -> Text
T.pack (forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy @t))))
      forall a s. DecCBOR a => Decoder s a
decCBOR
      (ByteString -> ByteString
BSL.fromStrict ByteString
bs)

type family MemoHashIndex (t :: Type) :: Type

deriving instance NFData t => NFData (MemoBytes t)

instance Typeable t => Plain.ToCBOR (MemoBytes t) where
  toCBOR :: MemoBytes t -> Encoding
toCBOR (Memo' t
_ ShortByteString
bytes SafeHash (MemoHashIndex t)
_hash) = ByteString -> Encoding
Plain.encodePreEncoded (ShortByteString -> ByteString
fromShort ShortByteString
bytes)

instance
  (Typeable t, DecCBOR (Annotator t)) =>
  DecCBOR (Annotator (MemoBytes t))
  where
  decCBOR :: forall s. Decoder s (Annotator (MemoBytes t))
decCBOR = do
    (Annotator FullByteString -> t
getT, Annotator FullByteString -> ByteString
getBytes) <- forall s a. Decoder s a -> Decoder s (a, Annotator ByteString)
withSlice forall a s. DecCBOR a => Decoder s a
decCBOR
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. (FullByteString -> a) -> Annotator a
Annotator (\FullByteString
fullbytes -> forall t. t -> ByteString -> MemoBytes t
mkMemoBytes (FullByteString -> t
getT FullByteString
fullbytes) (FullByteString -> ByteString
getBytes FullByteString
fullbytes)))

instance DecCBOR t => DecCBOR (MemoBytes t) where
  decCBOR :: forall s. Decoder s (MemoBytes t)
decCBOR = forall s t. Decoder s t -> Decoder s (MemoBytes t)
decodeMemoized forall a s. DecCBOR a => Decoder s a
decCBOR

-- | Both binary representation and Haskell types are compared.
instance Eq t => Eq (MemoBytes t) where
  MemoBytes t
x == :: MemoBytes t -> MemoBytes t -> Bool
== MemoBytes t
y = forall t. MemoBytes t -> ShortByteString
mbBytes MemoBytes t
x forall a. Eq a => a -> a -> Bool
== forall t. MemoBytes t -> ShortByteString
mbBytes MemoBytes t
y Bool -> Bool -> Bool
&& forall t. MemoBytes t -> t
mbRawType MemoBytes t
x forall a. Eq a => a -> a -> Bool
== forall t. MemoBytes t -> t
mbRawType MemoBytes t
y

instance Show t => Show (MemoBytes t) where
  show :: MemoBytes t -> String
show (Memo' t
y ShortByteString
_ SafeHash (MemoHashIndex t)
h) =
    forall a. Show a => a -> String
show t
y
      forall a. Semigroup a => a -> a -> a
<> String
" ("
      forall a. Semigroup a => a -> a -> a
<> forall h (proxy :: * -> *). HashAlgorithm h => proxy h -> String
hashAlgorithmName (forall {k} (t :: k). Proxy t
Proxy :: Proxy HASH)
      forall a. Semigroup a => a -> a -> a
<> String
": "
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SafeHash (MemoHashIndex t)
h
      forall a. Semigroup a => a -> a -> a
<> String
")"

instance SafeToHash (MemoBytes t) where
  originalBytes :: MemoBytes t -> ByteString
originalBytes = ShortByteString -> ByteString
fromShort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. MemoBytes t -> ShortByteString
mbBytes
  originalBytesSize :: MemoBytes t -> Int
originalBytesSize = ShortByteString -> Int
SBS.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. MemoBytes t -> ShortByteString
mbBytes

-- | Turn a lazy bytestring into a short bytestring.
shorten :: BSL.ByteString -> ShortByteString
shorten :: ByteString -> ShortByteString
shorten ByteString
x = ByteString -> ShortByteString
toShort (ByteString -> ByteString
toStrict ByteString
x)

-- | Useful when deriving DecCBOR(Annotator T)
-- deriving via (Mem T) instance DecCBOR (Annotator T)
type Mem t = Annotator (MemoBytes t)

-- | Smart constructor
mkMemoBytes :: forall t. t -> BSL.ByteString -> MemoBytes t
mkMemoBytes :: forall t. t -> ByteString -> MemoBytes t
mkMemoBytes t
t ByteString
bsl =
  forall t.
t -> ShortByteString -> SafeHash (MemoHashIndex t) -> MemoBytes t
Memo'
    t
t
    (ByteString -> ShortByteString
toShort ByteString
bs)
    (forall t i. SafeToHash t => Proxy i -> t -> SafeHash i
makeHashWithExplicitProxys (forall {k} (t :: k). Proxy t
Proxy @(MemoHashIndex t)) ByteString
bs)
  where
    bs :: ByteString
bs = ByteString -> ByteString
toStrict ByteString
bsl

-- | Turn a MemoBytes into a string, Showing both its internal structure and its original bytes.
--   Useful since the Show instance of MemoBytes does not display the original bytes.
showMemo :: Show t => MemoBytes t -> String
showMemo :: forall t. Show t => MemoBytes t -> String
showMemo (Memo' t
t ShortByteString
b SafeHash (MemoHashIndex t)
_) = String
"(Memo " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
t forall a. [a] -> [a] -> [a]
++ String
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ShortByteString
b forall a. [a] -> [a] -> [a]
++ String
")"

printMemo :: Show t => MemoBytes t -> IO ()
printMemo :: forall t. Show t => MemoBytes t -> IO ()
printMemo MemoBytes t
x = String -> IO ()
putStrLn (forall t. Show t => MemoBytes t -> String
showMemo MemoBytes t
x)

-- | Create MemoBytes from its CBOR encoding
memoBytes :: Version -> Encode w t -> MemoBytes t
memoBytes :: forall (w :: Wrapped) t. Version -> Encode w t -> MemoBytes t
memoBytes Version
v Encode w t
t = forall t. t -> ByteString -> MemoBytes t
mkMemoBytes (forall (w :: Wrapped) t. Encode w t -> t
runE Encode w t
t) (forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
v (forall (w :: Wrapped) t. Encode w t -> Encoding
encode Encode w t
t))

memoBytesEra :: forall era w t. Era era => Encode w t -> MemoBytes t
memoBytesEra :: forall era (w :: Wrapped) t. Era era => Encode w t -> MemoBytes t
memoBytesEra = forall (w :: Wrapped) t. Version -> Encode w t -> MemoBytes t
memoBytes (forall era. Era era => Version
eraProtVerLow @era)

-- | Helper function. Converts a short bytestring to a lazy bytestring.
shortToLazy :: ShortByteString -> BSL.ByteString
shortToLazy :: ShortByteString -> ByteString
shortToLazy = ByteString -> ByteString
fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> ByteString
fromShort

-- | Returns true if the contents of the MemoBytes are equal
contentsEq :: Eq t => MemoBytes t -> MemoBytes t -> Bool
contentsEq :: forall t. Eq t => MemoBytes t -> MemoBytes t -> Bool
contentsEq MemoBytes t
x MemoBytes t
y = forall t. MemoBytes t -> t
mbRawType MemoBytes t
x forall a. Eq a => a -> a -> Bool
== forall t. MemoBytes t -> t
mbRawType MemoBytes t
y

-- | Extract the inner type of the MemoBytes
getMemoBytesType :: MemoBytes t -> t
getMemoBytesType :: forall t. MemoBytes t -> t
getMemoBytesType = forall t. MemoBytes t -> t
mbRawType

-- | Extract the hash value of the binary representation of the MemoBytes
getMemoBytesHash :: MemoBytes t -> SafeHash (MemoHashIndex t)
getMemoBytesHash :: forall t. MemoBytes t -> SafeHash (MemoHashIndex t)
getMemoBytesHash = forall t. MemoBytes t -> SafeHash (MemoHashIndex t)
mbHash

-- | Class that relates the actual type with its raw and byte representations
class Memoized t where
  type RawType t = (r :: Type) | r -> t

  -- | This is a coercion from the memoized type to the MemoBytes. This implementation
  -- cannot be changed since `getMemoBytes` is not exported, therefore it will only work
  -- on newtypes around `MemoBytes`
  getMemoBytes :: t -> MemoBytes (RawType t)
  default getMemoBytes ::
    Coercible t (MemoBytes (RawType t)) =>
    t ->
    MemoBytes (RawType t)
  getMemoBytes = coerce :: forall a b. Coercible a b => a -> b
coerce

  -- | This is a coercion from the MemoBytes to the memoized type. This implementation
  -- cannot be changed since `warpMemoBytes` is not exported, therefore it will only work
  -- on newtypes around `MemoBytes`
  wrapMemoBytes :: MemoBytes (RawType t) -> t
  default wrapMemoBytes ::
    Coercible (MemoBytes (RawType t)) t =>
    MemoBytes (RawType t) ->
    t
  wrapMemoBytes = coerce :: forall a b. Coercible a b => a -> b
coerce

-- | Construct memoized type from the raw type using its EncCBOR instance
mkMemoized :: forall t. (EncCBOR (RawType t), Memoized t) => Version -> RawType t -> t
mkMemoized :: forall t.
(EncCBOR (RawType t), Memoized t) =>
Version -> RawType t -> t
mkMemoized Version
v RawType t
rawType = forall t. Memoized t => MemoBytes (RawType t) -> t
wrapMemoBytes (forall t. t -> ByteString -> MemoBytes t
mkMemoBytes RawType t
rawType (forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
v RawType t
rawType))

mkMemoizedEra :: forall era t. (Era era, EncCBOR (RawType t), Memoized t) => RawType t -> t
mkMemoizedEra :: forall era t.
(Era era, EncCBOR (RawType t), Memoized t) =>
RawType t -> t
mkMemoizedEra = forall t.
(EncCBOR (RawType t), Memoized t) =>
Version -> RawType t -> t
mkMemoized (forall era. Era era => Version
eraProtVerLow @era)

decodeMemoized :: Decoder s t -> Decoder s (MemoBytes t)
decodeMemoized :: forall s t. Decoder s t -> Decoder s (MemoBytes t)
decodeMemoized Decoder s t
rawTypeDecoder = do
  Annotated t
rawType ByteString
lazyBytes <- forall s a. Decoder s a -> Decoder s (Annotated a ByteString)
decodeAnnotated Decoder s t
rawTypeDecoder
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall t. t -> ByteString -> MemoBytes t
mkMemoBytes t
rawType ByteString
lazyBytes

-- | Extract memoized SafeHash
getMemoSafeHash :: Memoized t => t -> SafeHash (MemoHashIndex (RawType t))
getMemoSafeHash :: forall t. Memoized t => t -> SafeHash (MemoHashIndex (RawType t))
getMemoSafeHash t
t = forall t. MemoBytes t -> SafeHash (MemoHashIndex t)
mbHash (forall t. Memoized t => t -> MemoBytes (RawType t)
getMemoBytes t
t)

-- | Extract the raw type from the memoized version
getMemoRawType :: Memoized t => t -> RawType t
getMemoRawType :: forall t. Memoized t => t -> RawType t
getMemoRawType t
t = forall t. MemoBytes t -> t
mbRawType (forall t. Memoized t => t -> MemoBytes (RawType t)
getMemoBytes t
t)

-- | Extract the raw bytes from the memoized version
getMemoRawBytes :: Memoized t => t -> ShortByteString
getMemoRawBytes :: forall t. Memoized t => t -> ShortByteString
getMemoRawBytes t
t = forall t. MemoBytes t -> ShortByteString
mbBytes (forall t. Memoized t => t -> MemoBytes (RawType t)
getMemoBytes t
t)

-- | This is a helper function that operates on raw types of two memoized types.
zipMemoRawType ::
  (Memoized t1, Memoized t2) =>
  (RawType t1 -> RawType t2 -> a) ->
  t1 ->
  t2 ->
  a
zipMemoRawType :: forall t1 t2 a.
(Memoized t1, Memoized t2) =>
(RawType t1 -> RawType t2 -> a) -> t1 -> t2 -> a
zipMemoRawType RawType t1 -> RawType t2 -> a
f t1
x t2
y = RawType t1 -> RawType t2 -> a
f (forall t. Memoized t => t -> RawType t
getMemoRawType t1
x) (forall t. Memoized t => t -> RawType t
getMemoRawType t2
y)

eqRawType ::
  forall t.
  (Memoized t, Eq (RawType t)) =>
  t ->
  t ->
  Bool
eqRawType :: forall t. (Memoized t, Eq (RawType t)) => t -> t -> Bool
eqRawType = forall t1 t2 a.
(Memoized t1, Memoized t2) =>
(RawType t1 -> RawType t2 -> a) -> t1 -> t2 -> a
zipMemoRawType @t forall a. Eq a => a -> a -> Bool
(==)

-- | This is a helper Lens creator for any Memoized type.
lensMemoRawType ::
  forall era t a b.
  (Era era, EncCBOR (RawType t), Memoized t) =>
  (RawType t -> a) ->
  (RawType t -> b -> RawType t) ->
  Lens t t a b
lensMemoRawType :: forall era t a b.
(Era era, EncCBOR (RawType t), Memoized t) =>
(RawType t -> a) -> (RawType t -> b -> RawType t) -> Lens t t a b
lensMemoRawType RawType t -> a
getter RawType t -> b -> RawType t
setter =
  forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (RawType t -> a
getter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Memoized t => t -> RawType t
getMemoRawType) (\t
t b
b -> forall era t.
(Era era, EncCBOR (RawType t), Memoized t) =>
RawType t -> t
mkMemoizedEra @era forall a b. (a -> b) -> a -> b
$ RawType t -> b -> RawType t
setter (forall t. Memoized t => t -> RawType t
getMemoRawType t
t) b
b)
{-# INLINEABLE lensMemoRawType #-}

-- | This is a helper SimpleGetter creator for any Memoized type
getterMemoRawType ::
  Memoized t =>
  (RawType t -> a) ->
  SimpleGetter t a
getterMemoRawType :: forall t a. Memoized t => (RawType t -> a) -> SimpleGetter t a
getterMemoRawType RawType t -> a
getter =
  forall s a. (s -> a) -> SimpleGetter s a
to (RawType t -> a
getter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Memoized t => t -> RawType t
getMemoRawType)
{-# INLINEABLE getterMemoRawType #-}

-- | Type class that implements equality on the Haskell type, ignoring any of the
-- potentially memoized binary representation of the type.
class EqRaw a where
  eqRaw :: a -> a -> Bool
  default eqRaw :: (a ~ t, Memoized t, Eq (RawType t)) => a -> a -> Bool
  eqRaw = forall t. (Memoized t, Eq (RawType t)) => t -> t -> Bool
eqRawType