{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | This module is a derivative of "Data.MemPack" but we provide something that
-- will be used to " index " the serialization.
--
-- The idea is that we can use this in the Cardano block to avoid serializing a
-- tag next to the TxOut, as the Ledger layer establishes the property that
-- TxOuts are forwards deserializable, meaning we can read them in any later
-- era.
module Ouroboros.Consensus.Util.IndexedMemPack
  ( IndexedMemPack (..)
  , MemPack (..)
  , indexedPackByteString
  , indexedPackByteArray
  , indexedUnpackError
  , indexedUnpackEither
  , unpackEither
  ) where

import qualified Control.Monad as Monad
import Control.Monad.ST
import Control.Monad.Trans.Fail
import Data.Array.Byte (ByteArray (..))
import Data.Bifunctor (first)
import Data.ByteString
import Data.MemPack
import Data.MemPack.Buffer
import Data.MemPack.Error
import Data.Proxy
import GHC.Stack
import Ouroboros.Consensus.Ledger.Tables.MapKind

-- | See 'MemPack'.
class IndexedMemPack l blk a where
  indexedPackedByteCount :: l blk EmptyMK -> a -> Int
  indexedPackM :: l blk EmptyMK -> a -> Pack s ()
  indexedUnpackM :: Buffer b => forall s. l blk EmptyMK -> Unpack s b a
  indexedTypeName :: Proxy a -> l blk EmptyMK -> String

indexedPackByteString ::
  forall a l blk. (IndexedMemPack l blk a, HasCallStack) => l blk EmptyMK -> a -> ByteString
indexedPackByteString :: forall a (l :: * -> (* -> * -> *) -> *) blk.
(IndexedMemPack l blk a, HasCallStack) =>
l blk EmptyMK -> a -> ByteString
indexedPackByteString l blk EmptyMK
idx = ByteArray -> ByteString
pinnedByteArrayToByteString (ByteArray -> ByteString) -> (a -> ByteArray) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> l blk EmptyMK -> a -> ByteArray
forall a (l :: * -> (* -> * -> *) -> *) blk.
(IndexedMemPack l blk a, HasCallStack) =>
Bool -> l blk EmptyMK -> a -> ByteArray
indexedPackByteArray Bool
True l blk EmptyMK
idx
{-# INLINE indexedPackByteString #-}

indexedPackByteArray ::
  forall a l blk.
  (IndexedMemPack l blk a, HasCallStack) =>
  Bool ->
  l blk EmptyMK ->
  a ->
  ByteArray
indexedPackByteArray :: forall a (l :: * -> (* -> * -> *) -> *) blk.
(IndexedMemPack l blk a, HasCallStack) =>
Bool -> l blk EmptyMK -> a -> ByteArray
indexedPackByteArray Bool
isPinned l blk EmptyMK
idx a
a =
  HasCallStack =>
Bool -> String -> Int -> (forall s. Pack s ()) -> ByteArray
Bool -> String -> Int -> (forall s. Pack s ()) -> ByteArray
packWithByteArray
    Bool
isPinned
    (Proxy a -> l blk EmptyMK -> String
forall (l :: * -> (* -> * -> *) -> *) blk a.
IndexedMemPack l blk a =>
Proxy a -> l blk EmptyMK -> String
indexedTypeName (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a) l blk EmptyMK
idx)
    (l blk EmptyMK -> a -> Int
forall (l :: * -> (* -> * -> *) -> *) blk a.
IndexedMemPack l blk a =>
l blk EmptyMK -> a -> Int
indexedPackedByteCount l blk EmptyMK
idx a
a)
    (l blk EmptyMK -> a -> Pack s ()
forall s. l blk EmptyMK -> a -> Pack s ()
forall (l :: * -> (* -> * -> *) -> *) blk a s.
IndexedMemPack l blk a =>
l blk EmptyMK -> a -> Pack s ()
indexedPackM l blk EmptyMK
idx a
a)
{-# INLINE indexedPackByteArray #-}

indexedUnpackError ::
  forall l blk a b. (Buffer b, IndexedMemPack l blk a, HasCallStack) => l blk EmptyMK -> b -> a
indexedUnpackError :: forall (l :: * -> (* -> * -> *) -> *) blk a b.
(Buffer b, IndexedMemPack l blk a, HasCallStack) =>
l blk EmptyMK -> b -> a
indexedUnpackError l blk EmptyMK
idx = Fail SomeError a -> a
forall e a. (Show e, HasCallStack) => Fail e a -> a
errorFail (Fail SomeError a -> a) -> (b -> Fail SomeError a) -> b -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l blk EmptyMK -> b -> Fail SomeError a
forall (l :: * -> (* -> * -> *) -> *) blk a b.
(IndexedMemPack l blk a, Buffer b, HasCallStack) =>
l blk EmptyMK -> b -> Fail SomeError a
indexedUnpackFail l blk EmptyMK
idx
{-# INLINEABLE indexedUnpackError #-}

indexedUnpackFail ::
  forall l blk a b.
  (IndexedMemPack l blk a, Buffer b, HasCallStack) => l blk EmptyMK -> b -> Fail SomeError a
indexedUnpackFail :: forall (l :: * -> (* -> * -> *) -> *) blk a b.
(IndexedMemPack l blk a, Buffer b, HasCallStack) =>
l blk EmptyMK -> b -> Fail SomeError a
indexedUnpackFail l blk EmptyMK
idx b
b = do
  let len :: Int
len = b -> Int
forall b. Buffer b => b -> Int
bufferByteCount b
b
  (a, consumedBytes) <- l blk EmptyMK -> b -> Fail SomeError (a, Int)
forall (l :: * -> (* -> * -> *) -> *) blk a b.
(IndexedMemPack l blk a, Buffer b, HasCallStack) =>
l blk EmptyMK -> b -> Fail SomeError (a, Int)
indexedUnpackLeftOver l blk EmptyMK
idx b
b
  Monad.when (consumedBytes /= len) $
    unpackFailNotFullyConsumed (indexedTypeName (Proxy @a) idx) consumedBytes len
  pure a
{-# INLINEABLE indexedUnpackFail #-}

indexedUnpackLeftOver ::
  forall l blk a b.
  (IndexedMemPack l blk a, Buffer b, HasCallStack) => l blk EmptyMK -> b -> Fail SomeError (a, Int)
indexedUnpackLeftOver :: forall (l :: * -> (* -> * -> *) -> *) blk a b.
(IndexedMemPack l blk a, Buffer b, HasCallStack) =>
l blk EmptyMK -> b -> Fail SomeError (a, Int)
indexedUnpackLeftOver l blk EmptyMK
idx b
b = Identity (Either [SomeError] (a, Int))
-> FailT SomeError Identity (a, Int)
forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT (Identity (Either [SomeError] (a, Int))
 -> FailT SomeError Identity (a, Int))
-> Identity (Either [SomeError] (a, Int))
-> FailT SomeError Identity (a, Int)
forall a b. (a -> b) -> a -> b
$ Either [SomeError] (a, Int)
-> Identity (Either [SomeError] (a, Int))
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [SomeError] (a, Int)
 -> Identity (Either [SomeError] (a, Int)))
-> Either [SomeError] (a, Int)
-> Identity (Either [SomeError] (a, Int))
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Either [SomeError] (a, Int)))
-> Either [SomeError] (a, Int)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either [SomeError] (a, Int)))
 -> Either [SomeError] (a, Int))
-> (forall s. ST s (Either [SomeError] (a, Int)))
-> Either [SomeError] (a, Int)
forall a b. (a -> b) -> a -> b
$ FailT SomeError (ST s) (a, Int)
-> ST s (Either [SomeError] (a, Int))
forall e (m :: * -> *) a. FailT e m a -> m (Either [e] a)
runFailAggT (FailT SomeError (ST s) (a, Int)
 -> ST s (Either [SomeError] (a, Int)))
-> FailT SomeError (ST s) (a, Int)
-> ST s (Either [SomeError] (a, Int))
forall a b. (a -> b) -> a -> b
$ l blk EmptyMK -> b -> FailT SomeError (ST s) (a, Int)
forall (l :: * -> (* -> * -> *) -> *) blk a b s.
(IndexedMemPack l blk a, Buffer b, HasCallStack) =>
l blk EmptyMK -> b -> FailT SomeError (ST s) (a, Int)
indexedUnpackLeftOverST l blk EmptyMK
idx b
b
{-# INLINEABLE indexedUnpackLeftOver #-}

indexedUnpackLeftOverST ::
  forall l blk a b s.
  (IndexedMemPack l blk a, Buffer b, HasCallStack) =>
  l blk EmptyMK -> b -> FailT SomeError (ST s) (a, Int)
indexedUnpackLeftOverST :: forall (l :: * -> (* -> * -> *) -> *) blk a b s.
(IndexedMemPack l blk a, Buffer b, HasCallStack) =>
l blk EmptyMK -> b -> FailT SomeError (ST s) (a, Int)
indexedUnpackLeftOverST l blk EmptyMK
idx b
b = do
  let len :: Int
len = b -> Int
forall b. Buffer b => b -> Int
bufferByteCount b
b
  res@(_, consumedBytes) <- StateT Int (FailT SomeError (ST s)) a
-> Int -> FailT SomeError (ST s) (a, Int)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Unpack s b a -> b -> StateT Int (FailT SomeError (ST s)) a
forall s b a.
Unpack s b a -> b -> StateT Int (FailT SomeError (ST s)) a
runUnpack (l blk EmptyMK -> Unpack s b a
forall s. l blk EmptyMK -> Unpack s b a
forall b s. Buffer b => l blk EmptyMK -> Unpack s b a
forall (l :: * -> (* -> * -> *) -> *) blk a b s.
(IndexedMemPack l blk a, Buffer b) =>
l blk EmptyMK -> Unpack s b a
indexedUnpackM l blk EmptyMK
idx) b
b) Int
0
  Monad.when (consumedBytes > len) $ errorLeftOver (indexedTypeName (Proxy @a) idx) consumedBytes len
  pure res
{-# INLINEABLE indexedUnpackLeftOverST #-}

indexedUnpackEither ::
  forall l blk a b.
  (IndexedMemPack l blk a, Buffer b, HasCallStack) => l blk EmptyMK -> b -> Either SomeError a
indexedUnpackEither :: forall (l :: * -> (* -> * -> *) -> *) blk a b.
(IndexedMemPack l blk a, Buffer b, HasCallStack) =>
l blk EmptyMK -> b -> Either SomeError a
indexedUnpackEither l blk EmptyMK
idx = ([SomeError] -> SomeError)
-> Either [SomeError] a -> Either SomeError a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [SomeError] -> SomeError
fromMultipleErrors (Either [SomeError] a -> Either SomeError a)
-> (b -> Either [SomeError] a) -> b -> Either SomeError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fail SomeError a -> Either [SomeError] a
forall e a. Fail e a -> Either [e] a
runFailAgg (Fail SomeError a -> Either [SomeError] a)
-> (b -> Fail SomeError a) -> b -> Either [SomeError] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l blk EmptyMK -> b -> Fail SomeError a
forall (l :: * -> (* -> * -> *) -> *) blk a b.
(IndexedMemPack l blk a, Buffer b, HasCallStack) =>
l blk EmptyMK -> b -> Fail SomeError a
indexedUnpackFail l blk EmptyMK
idx
{-# INLINEABLE indexedUnpackEither #-}

unpackEither ::
  forall a b.
  (MemPack a, Buffer b, HasCallStack) => b -> Either SomeError a
unpackEither :: forall a b.
(MemPack a, Buffer b, HasCallStack) =>
b -> Either SomeError a
unpackEither = ([SomeError] -> SomeError)
-> Either [SomeError] a -> Either SomeError a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [SomeError] -> SomeError
fromMultipleErrors (Either [SomeError] a -> Either SomeError a)
-> (b -> Either [SomeError] a) -> b -> Either SomeError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fail SomeError a -> Either [SomeError] a
forall e a. Fail e a -> Either [e] a
runFailAgg (Fail SomeError a -> Either [SomeError] a)
-> (b -> Fail SomeError a) -> b -> Either [SomeError] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Fail SomeError a
forall a b.
(MemPack a, Buffer b, HasCallStack) =>
b -> Fail SomeError a
unpackFail
{-# INLINEABLE unpackEither #-}

errorLeftOver :: HasCallStack => String -> Int -> Int -> a
errorLeftOver :: forall a. HasCallStack => String -> Int -> Int -> a
errorLeftOver String
name Int
consumedBytes Int
len =
  String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$
    String
"Potential buffer overflow. Some bug in 'unpackM' was detected while unpacking " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". Consumed " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
showBytes (Int
consumedBytes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" more than allowed from a buffer of length "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len
{-# NOINLINE errorLeftOver #-}

unpackFailNotFullyConsumed :: Applicative m => String -> Int -> Int -> FailT SomeError m a
unpackFailNotFullyConsumed :: forall (m :: * -> *) a.
Applicative m =>
String -> Int -> Int -> FailT SomeError m a
unpackFailNotFullyConsumed String
name Int
consumedBytes Int
len =
  SomeError -> FailT SomeError m a
forall (m :: * -> *) e a. Applicative m => e -> FailT e m a
failT (SomeError -> FailT SomeError m a)
-> SomeError -> FailT SomeError m a
forall a b. (a -> b) -> a -> b
$
    NotFullyConsumedError -> SomeError
forall e. Error e => e -> SomeError
toSomeError (NotFullyConsumedError -> SomeError)
-> NotFullyConsumedError -> SomeError
forall a b. (a -> b) -> a -> b
$
      NotFullyConsumedError
        { notFullyConsumedRead :: Int
notFullyConsumedRead = Int
consumedBytes
        , notFullyConsumedAvailable :: Int
notFullyConsumedAvailable = Int
len
        , notFullyConsumedTypeName :: String
notFullyConsumedTypeName = String
name
        }
{-# NOINLINE unpackFailNotFullyConsumed #-}