{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE DerivingVia         #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving  #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}

module Ouroboros.Consensus.Storage.VolatileDB.API (
    -- * API
    VolatileDB (..)
    -- * Types
  , BlockInfo (..)
    -- * Errors
  , ApiMisuse (..)
  , UnexpectedFailure (..)
  , VolatileDBError (..)
    -- * Derived functionality
  , getIsMember
  , getKnownBlockComponent
  , getPredecessor
  , withDB
  ) where

import qualified Codec.CBOR.Read as CBOR
import qualified Data.ByteString.Lazy as Lazy
import           Data.Maybe (isJust)
import           Data.Set (Set)
import           Data.Typeable (Typeable)
import           Data.Word (Word16)
import           GHC.Generics (Generic)
import           GHC.Stack (HasCallStack)
import           NoThunks.Class (OnlyCheckWhnfNamed (..))

import           Ouroboros.Network.Block (MaxSlotNo)

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Util.IOLike

import           Ouroboros.Consensus.Storage.Common (BlockComponent (..))
import           Ouroboros.Consensus.Storage.FS.API.Types (FsError, FsPath)

{-------------------------------------------------------------------------------
  API
-------------------------------------------------------------------------------}

data VolatileDB m blk = VolatileDB {
      -- | Close the VolatileDB.
      --
      -- NOTE: idempotent after a manual closure, but not after an automatic
      -- closure in case of an 'UnexpectedFailure'. In that case, closing it
      -- again will cause a 'ClosedDBError' wrapping the original
      -- 'UnexpectedFailure' to be thrown.
      VolatileDB m blk -> HasCallStack => m ()
closeDB             :: HasCallStack => m ()
      -- | Return the request block component for the block with the given
      -- hash. When not in the VolatileDB, 'Nothing' is returned.
    , VolatileDB m blk
-> forall b.
   HasCallStack =>
   BlockComponent blk b -> HeaderHash blk -> m (Maybe b)
getBlockComponent   :: forall b. HasCallStack
                          => BlockComponent blk b
                          -> HeaderHash blk
                          -> m (Maybe b)
      -- | Store the given block in the VolatileDB.
      --
      -- Returns after the block has been written to disk.
    , VolatileDB m blk -> HasCallStack => blk -> m ()
putBlock            :: HasCallStack => blk -> m ()
      -- | Return a function that returns the successors of the block with the
      -- given hash.
      --
      -- This function will return a non-empty set for any block of which a
      -- predecessor has been added to the VolatileDB and will return an empty
      -- set if no successors for the given block have been added to the
      -- VolatileDB (yet).
      --
      -- Note that it is not required that the given block has been added to
      -- the VolatileDB.
    , VolatileDB m blk
-> HasCallStack => STM m (ChainHash blk -> Set (HeaderHash blk))
filterByPredecessor :: HasCallStack => STM m (ChainHash blk -> Set (HeaderHash blk))
      -- | Return a function that returns the 'BlockInfo' of the block with
      -- the given hash or 'Nothing' if the block is not found in the
      -- VolatileDB.
    , VolatileDB m blk
-> HasCallStack => STM m (HeaderHash blk -> Maybe (BlockInfo blk))
getBlockInfo        :: HasCallStack => STM m (HeaderHash blk -> Maybe (BlockInfo blk))
      -- | Try to remove all blocks with a slot number less than the given
      -- one.
      --
      -- = Context
      --
      -- When the current chain changes, blocks older than @k@, i.e., blocks
      -- that are followed by @k@ blocks or more, become /immutable/. Whenever
      -- this happens, we schedule a garbage collection on the VolatileDB that
      -- will try to remove blocks older than the most recent immutable block,
      -- as such blocks will never be adopted. There's no point in storing
      -- them anymore.
      --
      -- = Block number vs slot number
      --
      -- While we typically talk in terms of /block numbers/ when discussing
      -- immutability, i.e., /@k@ blocks/, we use /slot number/ for garbage
      -- collection. We schedule a garbage collection for blocks with a /slot
      -- number/ less than the slot number of the immutable block, as opposed
      -- to the block number. The reason for this is that the VolatileDB is
      -- not aware of block numbers, only of slot numbers.
      --
      -- By using slot numbers for garbage collection, we might not /yet/ have
      -- garbage collected some blocks that could never be adopted again and
      -- that we would have garbage collected when using block numbers. This
      -- is harmless. The opposite direction is more important and
      -- problematic: garbage collecting a block that we might want to adopt
      -- after all. Say we have mistakenly garbage collected such a block, in
      -- that case the following would be true:
      --
      -- 1. The block has a slot number older than the immutable block's slot
      --    number: otherwise we wouldn't have mistakenly garbage collected
      --    it.
      --
      -- 2. The block has a block number greater than the immutable block's
      --    block number: otherwise we wouldn't want to adopt it, as it would
      --    have been older than @k@.
      --
      -- 3. The block is a part of a fork fitting on the immutable block. As
      --    we cannot roll back this block, all forks we could ever adopt
      --    would have to go through this block.
      --
      -- As slot numbers grow monotonically within a chain, all forks starting
      -- after the immutable block will only contain blocks with slot numbers
      -- greater (or equal to in case of EBBs) than the immutable block's slot
      -- number. This directly contradicts (1), so we will /never/ garbage
      -- collect a block that we might still want to adopt.
      --
      -- = Less than vs. less than or equal to
      --
      -- Note that we remove blocks with a slot number /less than/ the given
      -- slot number, but not /equal to/ it. In practice, this off-by-one
      -- difference will not matter in terms of disk space usage, because as
      -- soon as the chain grows again by at least one block, those blocks
      -- will be removed anyway. The reason for @<@ opposed to @<=@ is to
      -- avoid issues with /EBBs/, which have the same slot number as the
      -- block after it.
    , VolatileDB m blk -> HasCallStack => SlotNo -> m ()
garbageCollect      :: HasCallStack => SlotNo -> m ()
      -- | Return the highest slot number ever stored by the VolatileDB.
    , VolatileDB m blk -> HasCallStack => STM m MaxSlotNo
getMaxSlotNo        :: HasCallStack => STM m MaxSlotNo
    }
  deriving Context -> VolatileDB m blk -> IO (Maybe ThunkInfo)
Proxy (VolatileDB m blk) -> String
(Context -> VolatileDB m blk -> IO (Maybe ThunkInfo))
-> (Context -> VolatileDB m blk -> IO (Maybe ThunkInfo))
-> (Proxy (VolatileDB m blk) -> String)
-> NoThunks (VolatileDB m blk)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *) blk.
Context -> VolatileDB m blk -> IO (Maybe ThunkInfo)
forall (m :: * -> *) blk. Proxy (VolatileDB m blk) -> String
showTypeOf :: Proxy (VolatileDB m blk) -> String
$cshowTypeOf :: forall (m :: * -> *) blk. Proxy (VolatileDB m blk) -> String
wNoThunks :: Context -> VolatileDB m blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) blk.
Context -> VolatileDB m blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> VolatileDB m blk -> IO (Maybe ThunkInfo)
$cnoThunks :: forall (m :: * -> *) blk.
Context -> VolatileDB m blk -> IO (Maybe ThunkInfo)
NoThunks via OnlyCheckWhnfNamed "VolatileDB" (VolatileDB m blk)

{------------------------------------------------------------------------------
  Types
------------------------------------------------------------------------------}

-- | The information that the user has to provide for each new block.
data BlockInfo blk = BlockInfo {
      BlockInfo blk -> HeaderHash blk
biHash         :: !(HeaderHash blk)
    , BlockInfo blk -> SlotNo
biSlotNo       :: !SlotNo
    , BlockInfo blk -> BlockNo
biBlockNo      :: !BlockNo
    , BlockInfo blk -> ChainHash blk
biPrevHash     :: !(ChainHash blk)
    , BlockInfo blk -> IsEBB
biIsEBB        :: !IsEBB
    , BlockInfo blk -> Word16
biHeaderOffset :: !Word16
    , BlockInfo blk -> Word16
biHeaderSize   :: !Word16
    }
  deriving (BlockInfo blk -> BlockInfo blk -> Bool
(BlockInfo blk -> BlockInfo blk -> Bool)
-> (BlockInfo blk -> BlockInfo blk -> Bool) -> Eq (BlockInfo blk)
forall blk.
StandardHash blk =>
BlockInfo blk -> BlockInfo blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockInfo blk -> BlockInfo blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
BlockInfo blk -> BlockInfo blk -> Bool
== :: BlockInfo blk -> BlockInfo blk -> Bool
$c== :: forall blk.
StandardHash blk =>
BlockInfo blk -> BlockInfo blk -> Bool
Eq, Int -> BlockInfo blk -> ShowS
[BlockInfo blk] -> ShowS
BlockInfo blk -> String
(Int -> BlockInfo blk -> ShowS)
-> (BlockInfo blk -> String)
-> ([BlockInfo blk] -> ShowS)
-> Show (BlockInfo blk)
forall blk. StandardHash blk => Int -> BlockInfo blk -> ShowS
forall blk. StandardHash blk => [BlockInfo blk] -> ShowS
forall blk. StandardHash blk => BlockInfo blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BlockInfo blk] -> ShowS
$cshowList :: forall blk. StandardHash blk => [BlockInfo blk] -> ShowS
show :: BlockInfo blk -> String
$cshow :: forall blk. StandardHash blk => BlockInfo blk -> String
showsPrec :: Int -> BlockInfo blk -> ShowS
$cshowsPrec :: forall blk. StandardHash blk => Int -> BlockInfo blk -> ShowS
Show, (forall x. BlockInfo blk -> Rep (BlockInfo blk) x)
-> (forall x. Rep (BlockInfo blk) x -> BlockInfo blk)
-> Generic (BlockInfo blk)
forall x. Rep (BlockInfo blk) x -> BlockInfo blk
forall x. BlockInfo blk -> Rep (BlockInfo blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (BlockInfo blk) x -> BlockInfo blk
forall blk x. BlockInfo blk -> Rep (BlockInfo blk) x
$cto :: forall blk x. Rep (BlockInfo blk) x -> BlockInfo blk
$cfrom :: forall blk x. BlockInfo blk -> Rep (BlockInfo blk) x
Generic, Context -> BlockInfo blk -> IO (Maybe ThunkInfo)
Proxy (BlockInfo blk) -> String
(Context -> BlockInfo blk -> IO (Maybe ThunkInfo))
-> (Context -> BlockInfo blk -> IO (Maybe ThunkInfo))
-> (Proxy (BlockInfo blk) -> String)
-> NoThunks (BlockInfo blk)
forall blk.
(StandardHash blk, Typeable blk) =>
Context -> BlockInfo blk -> IO (Maybe ThunkInfo)
forall blk.
(StandardHash blk, Typeable blk) =>
Proxy (BlockInfo blk) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (BlockInfo blk) -> String
$cshowTypeOf :: forall blk.
(StandardHash blk, Typeable blk) =>
Proxy (BlockInfo blk) -> String
wNoThunks :: Context -> BlockInfo blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk.
(StandardHash blk, Typeable blk) =>
Context -> BlockInfo blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> BlockInfo blk -> IO (Maybe ThunkInfo)
$cnoThunks :: forall blk.
(StandardHash blk, Typeable blk) =>
Context -> BlockInfo blk -> IO (Maybe ThunkInfo)
NoThunks)

{------------------------------------------------------------------------------
  Errors
------------------------------------------------------------------------------}

-- | Errors which might arise when working with this database.
data VolatileDBError blk =
    -- | An error thrown because of incorrect usage of the VolatileDB
    -- by the user.
    ApiMisuse ApiMisuse

    -- | An unexpected failure thrown because something went wrong.
  | UnexpectedFailure (UnexpectedFailure blk)

deriving instance (StandardHash blk, Typeable blk) => Show (VolatileDBError blk)

instance (StandardHash blk, Typeable blk) => Exception (VolatileDBError blk) where
  displayException :: VolatileDBError blk -> String
displayException = \case
      ApiMisuse {} ->
        String
"VolatileDB incorrectly used, indicative of a bug"
      UnexpectedFailure (FileSystemError FsError
fse) ->
        FsError -> String
forall e. Exception e => e -> String
displayException FsError
fse
      UnexpectedFailure {} ->
        String
"The VolatileDB got corrupted, full validation will be enabled for the next startup"

newtype ApiMisuse =
    -- | The VolatileDB was closed. In case it was automatically closed
    -- because an unexpected error was thrown during a read operation or any
    -- exception was thrown during a write operation, that exception is
    -- embedded.
    ClosedDBError (Maybe SomeException)
  deriving (Int -> ApiMisuse -> ShowS
[ApiMisuse] -> ShowS
ApiMisuse -> String
(Int -> ApiMisuse -> ShowS)
-> (ApiMisuse -> String)
-> ([ApiMisuse] -> ShowS)
-> Show ApiMisuse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApiMisuse] -> ShowS
$cshowList :: [ApiMisuse] -> ShowS
show :: ApiMisuse -> String
$cshow :: ApiMisuse -> String
showsPrec :: Int -> ApiMisuse -> ShowS
$cshowsPrec :: Int -> ApiMisuse -> ShowS
Show)

data UnexpectedFailure blk =
    FileSystemError FsError

    -- | A block failed to parse
  | ParseError FsPath (RealPoint blk) CBOR.DeserialiseFailure

    -- | When parsing a block we got some trailing data
  | TrailingDataError FsPath (RealPoint blk) Lazy.ByteString

    -- | Block missing
    --
    -- This exception gets thrown when a block that we /know/ it should be in
    -- the VolatileDB, nonetheless was not found.
    --
    -- This exception will be thrown by @getKnownBlockComponent@.
  | MissingBlockError (HeaderHash blk)

    -- | A (parsed) block did not pass the integrity check.
    --
    -- This exception gets thrown when a block doesn't pass the integrity check
    -- done for 'GetVerifiedBlock'.
    --
    -- NOTE: we do not check the integrity of a block when it is added to the
    -- VolatileDB. While this exception typically means the block has been
    -- corrupted, it could also mean the block didn't pass the check at the time
    -- it was added.
  | CorruptBlockError (HeaderHash blk)

deriving instance (Typeable blk, StandardHash blk) => Show (UnexpectedFailure blk)

{-------------------------------------------------------------------------------
  Derived functionality
-------------------------------------------------------------------------------}

-- | Open the database using the given function, perform the given action
-- using the database, and closes the database using its 'closeDB' function,
-- in case of success or when an exception was raised.
withDB ::
     (HasCallStack, MonadThrow m)
  => m (VolatileDB m blk)
     -- ^ How to open the database
  -> (VolatileDB m blk -> m a)
     -- ^ Action to perform using the database
  -> m a
withDB :: m (VolatileDB m blk) -> (VolatileDB m blk -> m a) -> m a
withDB m (VolatileDB m blk)
openDB = m (VolatileDB m blk)
-> (VolatileDB m blk -> m ()) -> (VolatileDB m blk -> m a) -> m a
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket m (VolatileDB m blk)
openDB VolatileDB m blk -> m ()
forall (m :: * -> *) blk. VolatileDB m blk -> HasCallStack => m ()
closeDB

getIsMember ::
     Functor (STM m)
  => VolatileDB m blk
  -> STM m (HeaderHash blk -> Bool)
getIsMember :: VolatileDB m blk -> STM m (HeaderHash blk -> Bool)
getIsMember = ((HeaderHash blk -> Maybe (BlockInfo blk))
 -> HeaderHash blk -> Bool)
-> STM m (HeaderHash blk -> Maybe (BlockInfo blk))
-> STM m (HeaderHash blk -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe (BlockInfo blk) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (BlockInfo blk) -> Bool)
-> (HeaderHash blk -> Maybe (BlockInfo blk))
-> HeaderHash blk
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (STM m (HeaderHash blk -> Maybe (BlockInfo blk))
 -> STM m (HeaderHash blk -> Bool))
-> (VolatileDB m blk
    -> STM m (HeaderHash blk -> Maybe (BlockInfo blk)))
-> VolatileDB m blk
-> STM m (HeaderHash blk -> Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VolatileDB m blk -> STM m (HeaderHash blk -> Maybe (BlockInfo blk))
forall (m :: * -> *) blk.
VolatileDB m blk
-> HasCallStack => STM m (HeaderHash blk -> Maybe (BlockInfo blk))
getBlockInfo

getPredecessor ::
     Functor (STM m)
  => VolatileDB m blk
  -> STM m (HeaderHash blk -> Maybe (ChainHash blk))
getPredecessor :: VolatileDB m blk -> STM m (HeaderHash blk -> Maybe (ChainHash blk))
getPredecessor = ((HeaderHash blk -> Maybe (BlockInfo blk))
 -> HeaderHash blk -> Maybe (ChainHash blk))
-> STM m (HeaderHash blk -> Maybe (BlockInfo blk))
-> STM m (HeaderHash blk -> Maybe (ChainHash blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((BlockInfo blk -> ChainHash blk)
-> Maybe (BlockInfo blk) -> Maybe (ChainHash blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BlockInfo blk -> ChainHash blk
forall blk. BlockInfo blk -> ChainHash blk
biPrevHash (Maybe (BlockInfo blk) -> Maybe (ChainHash blk))
-> (HeaderHash blk -> Maybe (BlockInfo blk))
-> HeaderHash blk
-> Maybe (ChainHash blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (STM m (HeaderHash blk -> Maybe (BlockInfo blk))
 -> STM m (HeaderHash blk -> Maybe (ChainHash blk)))
-> (VolatileDB m blk
    -> STM m (HeaderHash blk -> Maybe (BlockInfo blk)))
-> VolatileDB m blk
-> STM m (HeaderHash blk -> Maybe (ChainHash blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VolatileDB m blk -> STM m (HeaderHash blk -> Maybe (BlockInfo blk))
forall (m :: * -> *) blk.
VolatileDB m blk
-> HasCallStack => STM m (HeaderHash blk -> Maybe (BlockInfo blk))
getBlockInfo

getKnownBlockComponent ::
     (MonadThrow m, HasHeader blk)
  => VolatileDB m blk
  -> BlockComponent blk b
  -> HeaderHash blk
  -> m b
getKnownBlockComponent :: VolatileDB m blk -> BlockComponent blk b -> HeaderHash blk -> m b
getKnownBlockComponent VolatileDB m blk
db BlockComponent blk b
blockComponent HeaderHash blk
hash = do
    Either (VolatileDBError blk) b
mBlock <- VolatileDB m blk
-> HeaderHash blk -> Maybe b -> Either (VolatileDBError blk) b
forall (proxy :: * -> *) blk b.
proxy blk
-> HeaderHash blk -> Maybe b -> Either (VolatileDBError blk) b
mustExist VolatileDB m blk
db HeaderHash blk
hash (Maybe b -> Either (VolatileDBError blk) b)
-> m (Maybe b) -> m (Either (VolatileDBError blk) b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      VolatileDB m blk
-> BlockComponent blk b -> HeaderHash blk -> m (Maybe b)
forall (m :: * -> *) blk.
VolatileDB m blk
-> forall b.
   HasCallStack =>
   BlockComponent blk b -> HeaderHash blk -> m (Maybe b)
getBlockComponent VolatileDB m blk
db BlockComponent blk b
blockComponent HeaderHash blk
hash
    case Either (VolatileDBError blk) b
mBlock of
      Right b
b  -> b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
      Left VolatileDBError blk
err -> VolatileDBError blk -> m b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO VolatileDBError blk
err

mustExist ::
     forall proxy blk b.
     proxy blk
  -> HeaderHash blk
  -> Maybe b
  -> Either (VolatileDBError blk) b
mustExist :: proxy blk
-> HeaderHash blk -> Maybe b -> Either (VolatileDBError blk) b
mustExist proxy blk
_ HeaderHash blk
hash = \case
    Maybe b
Nothing -> VolatileDBError blk -> Either (VolatileDBError blk) b
forall a b. a -> Either a b
Left  (VolatileDBError blk -> Either (VolatileDBError blk) b)
-> VolatileDBError blk -> Either (VolatileDBError blk) b
forall a b. (a -> b) -> a -> b
$ UnexpectedFailure blk -> VolatileDBError blk
forall blk. UnexpectedFailure blk -> VolatileDBError blk
UnexpectedFailure (UnexpectedFailure blk -> VolatileDBError blk)
-> UnexpectedFailure blk -> VolatileDBError blk
forall a b. (a -> b) -> a -> b
$ HeaderHash blk -> UnexpectedFailure blk
forall blk. HeaderHash blk -> UnexpectedFailure blk
MissingBlockError @blk HeaderHash blk
hash
    Just b
b  -> b -> Either (VolatileDBError blk) b
forall a b. b -> Either a b
Right (b -> Either (VolatileDBError blk) b)
-> b -> Either (VolatileDBError blk) b
forall a b. (a -> b) -> a -> b
$ b
b