{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE TypeFamilies               #-}

module Ouroboros.Consensus.Storage.Common (
    -- * Indexing
    tipIsGenesis
    -- * PrefixLen
  , PrefixLen (..)
  , addPrefixLen
  , takePrefix
    -- * BinaryBlockInfo
  , BinaryBlockInfo (..)
  , extractHeader
    -- * Iterator bounds
  , StreamFrom (..)
  , StreamTo (..)
  , validBounds
    -- * BlockComponent
  , BlockComponent (..)
    -- * Re-exports
  , SizeInBytes
  ) where

import           Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BL
import           Data.ByteString.Short (ShortByteString)
import qualified Data.ByteString.Short as Short
import           Data.Word
import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks)

import           Ouroboros.Network.DeltaQ (SizeInBytes)

import           Ouroboros.Consensus.Block

{-------------------------------------------------------------------------------
  Indexing
-------------------------------------------------------------------------------}

tipIsGenesis :: WithOrigin r -> Bool
tipIsGenesis :: WithOrigin r -> Bool
tipIsGenesis WithOrigin r
Origin        = Bool
True
tipIsGenesis (NotOrigin r
_) = Bool
False

{-------------------------------------------------------------------------------
  PrefixLen
-------------------------------------------------------------------------------}

-- | Number of bytes from the start of a block needed to reconstruct the
-- nested context.
--
-- See 'reconstructPrefixLen'.
newtype PrefixLen = PrefixLen {
      PrefixLen -> Word8
getPrefixLen :: Word8
    }
  deriving stock   (PrefixLen -> PrefixLen -> Bool
(PrefixLen -> PrefixLen -> Bool)
-> (PrefixLen -> PrefixLen -> Bool) -> Eq PrefixLen
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PrefixLen -> PrefixLen -> Bool
$c/= :: PrefixLen -> PrefixLen -> Bool
== :: PrefixLen -> PrefixLen -> Bool
$c== :: PrefixLen -> PrefixLen -> Bool
Eq, Eq PrefixLen
Eq PrefixLen
-> (PrefixLen -> PrefixLen -> Ordering)
-> (PrefixLen -> PrefixLen -> Bool)
-> (PrefixLen -> PrefixLen -> Bool)
-> (PrefixLen -> PrefixLen -> Bool)
-> (PrefixLen -> PrefixLen -> Bool)
-> (PrefixLen -> PrefixLen -> PrefixLen)
-> (PrefixLen -> PrefixLen -> PrefixLen)
-> Ord PrefixLen
PrefixLen -> PrefixLen -> Bool
PrefixLen -> PrefixLen -> Ordering
PrefixLen -> PrefixLen -> PrefixLen
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PrefixLen -> PrefixLen -> PrefixLen
$cmin :: PrefixLen -> PrefixLen -> PrefixLen
max :: PrefixLen -> PrefixLen -> PrefixLen
$cmax :: PrefixLen -> PrefixLen -> PrefixLen
>= :: PrefixLen -> PrefixLen -> Bool
$c>= :: PrefixLen -> PrefixLen -> Bool
> :: PrefixLen -> PrefixLen -> Bool
$c> :: PrefixLen -> PrefixLen -> Bool
<= :: PrefixLen -> PrefixLen -> Bool
$c<= :: PrefixLen -> PrefixLen -> Bool
< :: PrefixLen -> PrefixLen -> Bool
$c< :: PrefixLen -> PrefixLen -> Bool
compare :: PrefixLen -> PrefixLen -> Ordering
$ccompare :: PrefixLen -> PrefixLen -> Ordering
$cp1Ord :: Eq PrefixLen
Ord, Int -> PrefixLen -> ShowS
[PrefixLen] -> ShowS
PrefixLen -> String
(Int -> PrefixLen -> ShowS)
-> (PrefixLen -> String)
-> ([PrefixLen] -> ShowS)
-> Show PrefixLen
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrefixLen] -> ShowS
$cshowList :: [PrefixLen] -> ShowS
show :: PrefixLen -> String
$cshow :: PrefixLen -> String
showsPrec :: Int -> PrefixLen -> ShowS
$cshowsPrec :: Int -> PrefixLen -> ShowS
Show, (forall x. PrefixLen -> Rep PrefixLen x)
-> (forall x. Rep PrefixLen x -> PrefixLen) -> Generic PrefixLen
forall x. Rep PrefixLen x -> PrefixLen
forall x. PrefixLen -> Rep PrefixLen x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PrefixLen x -> PrefixLen
$cfrom :: forall x. PrefixLen -> Rep PrefixLen x
Generic)
  deriving newtype (Context -> PrefixLen -> IO (Maybe ThunkInfo)
Proxy PrefixLen -> String
(Context -> PrefixLen -> IO (Maybe ThunkInfo))
-> (Context -> PrefixLen -> IO (Maybe ThunkInfo))
-> (Proxy PrefixLen -> String)
-> NoThunks PrefixLen
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy PrefixLen -> String
$cshowTypeOf :: Proxy PrefixLen -> String
wNoThunks :: Context -> PrefixLen -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PrefixLen -> IO (Maybe ThunkInfo)
noThunks :: Context -> PrefixLen -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> PrefixLen -> IO (Maybe ThunkInfo)
NoThunks)

addPrefixLen :: Word8 -> PrefixLen -> PrefixLen
addPrefixLen :: Word8 -> PrefixLen -> PrefixLen
addPrefixLen Word8
m (PrefixLen Word8
n) = Word8 -> PrefixLen
PrefixLen (Word8
m Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
n)

takePrefix :: PrefixLen -> BL.ByteString -> ShortByteString
takePrefix :: PrefixLen -> ByteString -> ShortByteString
takePrefix (PrefixLen Word8
n) =
    ByteString -> ShortByteString
Short.toShort (ByteString -> ShortByteString)
-> (ByteString -> ByteString) -> ByteString -> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> ByteString -> ByteString
BL.take (Word8 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n)

{-------------------------------------------------------------------------------
  BinaryBlockInfo
-------------------------------------------------------------------------------}

-- | Information about the serialised block.
data BinaryBlockInfo = BinaryBlockInfo
  { BinaryBlockInfo -> Word16
headerOffset :: !Word16
    -- ^ The offset within the serialised block at which the header starts.
  , BinaryBlockInfo -> Word16
headerSize   :: !Word16
    -- ^ How many bytes the header is long. Extracting the 'headerSize' bytes
    -- from serialised block starting from 'headerOffset' should yield the
    -- header. Before passing the extracted bytes to the decoder for headers,
    -- an envelope can be around using 'nodeAddHeaderEnvelope'.

    -- In the future, i.e. Shelley, we might want to extend this to include a
    -- field to tell where the transaction body ends and where the transaction
    -- witnesses begin so we can only extract the transaction body.
  } deriving (BinaryBlockInfo -> BinaryBlockInfo -> Bool
(BinaryBlockInfo -> BinaryBlockInfo -> Bool)
-> (BinaryBlockInfo -> BinaryBlockInfo -> Bool)
-> Eq BinaryBlockInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BinaryBlockInfo -> BinaryBlockInfo -> Bool
$c/= :: BinaryBlockInfo -> BinaryBlockInfo -> Bool
== :: BinaryBlockInfo -> BinaryBlockInfo -> Bool
$c== :: BinaryBlockInfo -> BinaryBlockInfo -> Bool
Eq, Int -> BinaryBlockInfo -> ShowS
[BinaryBlockInfo] -> ShowS
BinaryBlockInfo -> String
(Int -> BinaryBlockInfo -> ShowS)
-> (BinaryBlockInfo -> String)
-> ([BinaryBlockInfo] -> ShowS)
-> Show BinaryBlockInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BinaryBlockInfo] -> ShowS
$cshowList :: [BinaryBlockInfo] -> ShowS
show :: BinaryBlockInfo -> String
$cshow :: BinaryBlockInfo -> String
showsPrec :: Int -> BinaryBlockInfo -> ShowS
$cshowsPrec :: Int -> BinaryBlockInfo -> ShowS
Show, (forall x. BinaryBlockInfo -> Rep BinaryBlockInfo x)
-> (forall x. Rep BinaryBlockInfo x -> BinaryBlockInfo)
-> Generic BinaryBlockInfo
forall x. Rep BinaryBlockInfo x -> BinaryBlockInfo
forall x. BinaryBlockInfo -> Rep BinaryBlockInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BinaryBlockInfo x -> BinaryBlockInfo
$cfrom :: forall x. BinaryBlockInfo -> Rep BinaryBlockInfo x
Generic)


-- | Extract the header from the given 'ByteString' using the
-- 'BinaryBlockInfo'.
extractHeader :: BinaryBlockInfo -> ByteString -> ByteString
extractHeader :: BinaryBlockInfo -> ByteString -> ByteString
extractHeader BinaryBlockInfo { Word16
headerOffset :: Word16
headerOffset :: BinaryBlockInfo -> Word16
headerOffset, Word16
headerSize :: Word16
headerSize :: BinaryBlockInfo -> Word16
headerSize } =
      Int64 -> ByteString -> ByteString
BL.take (Word16 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
headerSize)
    (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> ByteString -> ByteString
BL.drop (Word16 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
headerOffset)

{-------------------------------------------------------------------------------
  Iterator bounds
-------------------------------------------------------------------------------}

-- | The lower bound for an iterator
--
-- Hint: use @'StreamFromExclusive' 'genesisPoint'@ to start streaming from
-- Genesis.
data StreamFrom blk =
    StreamFromInclusive !(RealPoint blk)
  | StreamFromExclusive !(Point     blk)
  deriving stock    (Int -> StreamFrom blk -> ShowS
[StreamFrom blk] -> ShowS
StreamFrom blk -> String
(Int -> StreamFrom blk -> ShowS)
-> (StreamFrom blk -> String)
-> ([StreamFrom blk] -> ShowS)
-> Show (StreamFrom blk)
forall blk. StandardHash blk => Int -> StreamFrom blk -> ShowS
forall blk. StandardHash blk => [StreamFrom blk] -> ShowS
forall blk. StandardHash blk => StreamFrom blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StreamFrom blk] -> ShowS
$cshowList :: forall blk. StandardHash blk => [StreamFrom blk] -> ShowS
show :: StreamFrom blk -> String
$cshow :: forall blk. StandardHash blk => StreamFrom blk -> String
showsPrec :: Int -> StreamFrom blk -> ShowS
$cshowsPrec :: forall blk. StandardHash blk => Int -> StreamFrom blk -> ShowS
Show, StreamFrom blk -> StreamFrom blk -> Bool
(StreamFrom blk -> StreamFrom blk -> Bool)
-> (StreamFrom blk -> StreamFrom blk -> Bool)
-> Eq (StreamFrom blk)
forall blk.
StandardHash blk =>
StreamFrom blk -> StreamFrom blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StreamFrom blk -> StreamFrom blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
StreamFrom blk -> StreamFrom blk -> Bool
== :: StreamFrom blk -> StreamFrom blk -> Bool
$c== :: forall blk.
StandardHash blk =>
StreamFrom blk -> StreamFrom blk -> Bool
Eq, (forall x. StreamFrom blk -> Rep (StreamFrom blk) x)
-> (forall x. Rep (StreamFrom blk) x -> StreamFrom blk)
-> Generic (StreamFrom blk)
forall x. Rep (StreamFrom blk) x -> StreamFrom blk
forall x. StreamFrom blk -> Rep (StreamFrom blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (StreamFrom blk) x -> StreamFrom blk
forall blk x. StreamFrom blk -> Rep (StreamFrom blk) x
$cto :: forall blk x. Rep (StreamFrom blk) x -> StreamFrom blk
$cfrom :: forall blk x. StreamFrom blk -> Rep (StreamFrom blk) x
Generic)
  deriving anyclass (Context -> StreamFrom blk -> IO (Maybe ThunkInfo)
Proxy (StreamFrom blk) -> String
(Context -> StreamFrom blk -> IO (Maybe ThunkInfo))
-> (Context -> StreamFrom blk -> IO (Maybe ThunkInfo))
-> (Proxy (StreamFrom blk) -> String)
-> NoThunks (StreamFrom blk)
forall blk.
(StandardHash blk, Typeable blk) =>
Context -> StreamFrom blk -> IO (Maybe ThunkInfo)
forall blk.
(StandardHash blk, Typeable blk) =>
Proxy (StreamFrom blk) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (StreamFrom blk) -> String
$cshowTypeOf :: forall blk.
(StandardHash blk, Typeable blk) =>
Proxy (StreamFrom blk) -> String
wNoThunks :: Context -> StreamFrom blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk.
(StandardHash blk, Typeable blk) =>
Context -> StreamFrom blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> StreamFrom blk -> IO (Maybe ThunkInfo)
$cnoThunks :: forall blk.
(StandardHash blk, Typeable blk) =>
Context -> StreamFrom blk -> IO (Maybe ThunkInfo)
NoThunks)

newtype StreamTo blk =
    StreamToInclusive (RealPoint blk)
  deriving stock    (Int -> StreamTo blk -> ShowS
[StreamTo blk] -> ShowS
StreamTo blk -> String
(Int -> StreamTo blk -> ShowS)
-> (StreamTo blk -> String)
-> ([StreamTo blk] -> ShowS)
-> Show (StreamTo blk)
forall blk. StandardHash blk => Int -> StreamTo blk -> ShowS
forall blk. StandardHash blk => [StreamTo blk] -> ShowS
forall blk. StandardHash blk => StreamTo blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StreamTo blk] -> ShowS
$cshowList :: forall blk. StandardHash blk => [StreamTo blk] -> ShowS
show :: StreamTo blk -> String
$cshow :: forall blk. StandardHash blk => StreamTo blk -> String
showsPrec :: Int -> StreamTo blk -> ShowS
$cshowsPrec :: forall blk. StandardHash blk => Int -> StreamTo blk -> ShowS
Show, StreamTo blk -> StreamTo blk -> Bool
(StreamTo blk -> StreamTo blk -> Bool)
-> (StreamTo blk -> StreamTo blk -> Bool) -> Eq (StreamTo blk)
forall blk.
StandardHash blk =>
StreamTo blk -> StreamTo blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StreamTo blk -> StreamTo blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
StreamTo blk -> StreamTo blk -> Bool
== :: StreamTo blk -> StreamTo blk -> Bool
$c== :: forall blk.
StandardHash blk =>
StreamTo blk -> StreamTo blk -> Bool
Eq, (forall x. StreamTo blk -> Rep (StreamTo blk) x)
-> (forall x. Rep (StreamTo blk) x -> StreamTo blk)
-> Generic (StreamTo blk)
forall x. Rep (StreamTo blk) x -> StreamTo blk
forall x. StreamTo blk -> Rep (StreamTo blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (StreamTo blk) x -> StreamTo blk
forall blk x. StreamTo blk -> Rep (StreamTo blk) x
$cto :: forall blk x. Rep (StreamTo blk) x -> StreamTo blk
$cfrom :: forall blk x. StreamTo blk -> Rep (StreamTo blk) x
Generic)
  deriving anyclass (Context -> StreamTo blk -> IO (Maybe ThunkInfo)
Proxy (StreamTo blk) -> String
(Context -> StreamTo blk -> IO (Maybe ThunkInfo))
-> (Context -> StreamTo blk -> IO (Maybe ThunkInfo))
-> (Proxy (StreamTo blk) -> String)
-> NoThunks (StreamTo blk)
forall blk.
(StandardHash blk, Typeable blk) =>
Context -> StreamTo blk -> IO (Maybe ThunkInfo)
forall blk.
(StandardHash blk, Typeable blk) =>
Proxy (StreamTo blk) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (StreamTo blk) -> String
$cshowTypeOf :: forall blk.
(StandardHash blk, Typeable blk) =>
Proxy (StreamTo blk) -> String
wNoThunks :: Context -> StreamTo blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk.
(StandardHash blk, Typeable blk) =>
Context -> StreamTo blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> StreamTo blk -> IO (Maybe ThunkInfo)
$cnoThunks :: forall blk.
(StandardHash blk, Typeable blk) =>
Context -> StreamTo blk -> IO (Maybe ThunkInfo)
NoThunks)

-- | Check whether the bounds make sense
--
-- An example of bounds that don't make sense:
--
-- > StreamFromExclusive (BlockPoint 3 ..)
-- > StreamToInclusive   (RealPoint  3 ..)
--
-- This function does not check whether the bounds correspond to existing
-- blocks.
validBounds :: StandardHash blk => StreamFrom blk -> StreamTo blk -> Bool
validBounds :: StreamFrom blk -> StreamTo blk -> Bool
validBounds StreamFrom blk
from (StreamToInclusive (RealPoint SlotNo
sto HeaderHash blk
hto)) =
    case StreamFrom blk
from of
      StreamFromExclusive Point blk
GenesisPoint         -> Bool
True
      -- EBBs spoil the fun again: when 'StreamFromExclusive' refers to an EBB
      -- in slot X and 'StreamToInclusive' to the regular block in the same slot
      -- X, the bound is still valid. Without EBBs, we would have @sfrom < sto@.
      --
      -- We /can/ rule out streaming exclusively from the block to the same
      -- block.
      StreamFromExclusive (BlockPoint SlotNo
sfrom HeaderHash blk
hfrom) -> HeaderHash blk
hfrom HeaderHash blk -> HeaderHash blk -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderHash blk
hto Bool -> Bool -> Bool
&& SlotNo
sfrom SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo
sto
      StreamFromInclusive (RealPoint  SlotNo
sfrom HeaderHash blk
_)     -> SlotNo
sfrom SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo
sto

{-------------------------------------------------------------------------------
  BlockComponent
-------------------------------------------------------------------------------}

-- | Which component of the block to read from a database: the whole block,
-- its header, its hash, the block size, ..., or combinations thereof.
--
-- NOTE: when requesting multiple components, we will not optimise/cache them.
data BlockComponent blk a where
  -- | Verify the integrity of the block by checking its signature and/or
  -- hashes. The interpreter should throw an exception when the block does not
  -- pass the check.
  GetVerifiedBlock :: BlockComponent blk blk
  GetBlock         :: BlockComponent blk blk
  GetRawBlock      :: BlockComponent blk ByteString
  GetHeader        :: BlockComponent blk (Header blk)
  GetRawHeader     :: BlockComponent blk ByteString
  GetHash          :: BlockComponent blk (HeaderHash blk)
  GetSlot          :: BlockComponent blk SlotNo
  GetIsEBB         :: BlockComponent blk IsEBB
  GetBlockSize     :: BlockComponent blk Word32
  GetHeaderSize    :: BlockComponent blk Word16
  GetNestedCtxt    :: BlockComponent blk (SomeSecond (NestedCtxt Header) blk)
  GetPure          :: a
                   -> BlockComponent blk a
  GetApply         :: BlockComponent blk (a -> b)
                   -> BlockComponent blk a
                   -> BlockComponent blk b

instance Functor (BlockComponent blk) where
  fmap :: (a -> b) -> BlockComponent blk a -> BlockComponent blk b
fmap a -> b
f = ((a -> b) -> BlockComponent blk (a -> b)
forall a blk. a -> BlockComponent blk a
GetPure a -> b
f BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent blk b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>)

instance Applicative (BlockComponent blk) where
  pure :: a -> BlockComponent blk a
pure  = a -> BlockComponent blk a
forall a blk. a -> BlockComponent blk a
GetPure
  <*> :: BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent blk b
(<*>) = BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent blk b
forall blk a b.
BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent blk b
GetApply