{-# 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 (
VolatileDB (..)
, BlockInfo (..)
, ApiMisuse (..)
, UnexpectedFailure (..)
, VolatileDBError (..)
, 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.Consensus.Block
import Ouroboros.Consensus.Storage.Common (BlockComponent (..))
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Network.Block (MaxSlotNo)
import System.FS.API.Types (FsError, FsPath)
data VolatileDB m blk = VolatileDB {
forall (m :: * -> *) blk. VolatileDB m blk -> HasCallStack => m ()
closeDB :: HasCallStack => m ()
, forall (m :: * -> *) blk.
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)
, forall (m :: * -> *) blk.
VolatileDB m blk -> HasCallStack => blk -> m ()
putBlock :: HasCallStack => blk -> m ()
, forall (m :: * -> *) blk.
VolatileDB m blk
-> HasCallStack => STM m (ChainHash blk -> Set (HeaderHash blk))
filterByPredecessor :: HasCallStack => STM m (ChainHash blk -> Set (HeaderHash blk))
, forall (m :: * -> *) blk.
VolatileDB m blk
-> HasCallStack => STM m (HeaderHash blk -> Maybe (BlockInfo blk))
getBlockInfo :: HasCallStack => STM m (HeaderHash blk -> Maybe (BlockInfo blk))
, forall (m :: * -> *) blk.
VolatileDB m blk -> HasCallStack => SlotNo -> m ()
garbageCollect :: HasCallStack => SlotNo -> m ()
, forall (m :: * -> *) blk.
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
$cnoThunks :: forall (m :: * -> *) blk.
Context -> VolatileDB m blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> VolatileDB m blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) blk.
Context -> VolatileDB m blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> VolatileDB m blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *) blk. Proxy (VolatileDB m blk) -> String
showTypeOf :: Proxy (VolatileDB m blk) -> String
NoThunks via OnlyCheckWhnfNamed "VolatileDB" (VolatileDB m blk)
data BlockInfo blk = BlockInfo {
forall blk. BlockInfo blk -> HeaderHash blk
biHash :: !(HeaderHash blk)
, forall blk. BlockInfo blk -> SlotNo
biSlotNo :: !SlotNo
, forall blk. BlockInfo blk -> BlockNo
biBlockNo :: !BlockNo
, forall blk. BlockInfo blk -> ChainHash blk
biPrevHash :: !(ChainHash blk)
, forall blk. BlockInfo blk -> IsEBB
biIsEBB :: !IsEBB
, :: !Word16
, :: !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
$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
/= :: 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
$cshowsPrec :: forall blk. StandardHash blk => Int -> BlockInfo blk -> ShowS
showsPrec :: Int -> BlockInfo blk -> ShowS
$cshow :: forall blk. StandardHash blk => BlockInfo blk -> String
show :: BlockInfo blk -> String
$cshowList :: forall blk. StandardHash blk => [BlockInfo blk] -> ShowS
showList :: [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
$cfrom :: forall blk x. BlockInfo blk -> Rep (BlockInfo blk) x
from :: forall x. BlockInfo blk -> Rep (BlockInfo blk) x
$cto :: forall blk x. Rep (BlockInfo blk) x -> BlockInfo blk
to :: forall x. Rep (BlockInfo blk) x -> BlockInfo blk
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
$cnoThunks :: forall blk.
(StandardHash blk, Typeable blk) =>
Context -> BlockInfo blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> BlockInfo blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk.
(StandardHash blk, Typeable blk) =>
Context -> BlockInfo blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> BlockInfo blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall blk.
(StandardHash blk, Typeable blk) =>
Proxy (BlockInfo blk) -> String
showTypeOf :: Proxy (BlockInfo blk) -> String
NoThunks)
data VolatileDBError blk =
ApiMisuse ApiMisuse
| 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 =
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
$cshowsPrec :: Int -> ApiMisuse -> ShowS
showsPrec :: Int -> ApiMisuse -> ShowS
$cshow :: ApiMisuse -> String
show :: ApiMisuse -> String
$cshowList :: [ApiMisuse] -> ShowS
showList :: [ApiMisuse] -> ShowS
Show)
data UnexpectedFailure blk =
FileSystemError FsError
| ParseError FsPath (RealPoint blk) CBOR.DeserialiseFailure
| TrailingDataError FsPath (RealPoint blk) Lazy.ByteString
| MissingBlockError (HeaderHash blk)
| CorruptBlockError (HeaderHash blk)
deriving instance (Typeable blk, StandardHash blk) => Show (UnexpectedFailure blk)
withDB ::
(HasCallStack, MonadThrow m)
=> m (VolatileDB m blk)
-> (VolatileDB m blk -> m a)
-> m a
withDB :: forall (m :: * -> *) blk a.
(HasCallStack, MonadThrow m) =>
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 a b c. m a -> (a -> m b) -> (a -> m c) -> m c
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 ()
VolatileDB m blk -> HasCallStack => m ()
forall (m :: * -> *) blk. VolatileDB m blk -> HasCallStack => m ()
closeDB
getIsMember ::
Functor (STM m)
=> VolatileDB m blk
-> STM m (HeaderHash blk -> Bool)
getIsMember :: forall (m :: * -> *) blk.
Functor (STM m) =>
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 a b. (a -> b) -> STM m a -> STM m b
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))
VolatileDB m blk
-> HasCallStack => 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 :: forall (m :: * -> *) blk.
Functor (STM m) =>
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 a b. (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((BlockInfo blk -> ChainHash blk)
-> Maybe (BlockInfo blk) -> Maybe (ChainHash blk)
forall a b. (a -> b) -> Maybe a -> Maybe b
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))
VolatileDB m blk
-> HasCallStack => 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 :: forall (m :: * -> *) blk b.
(MonadThrow m, HasHeader blk) =>
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
-> forall b.
HasCallStack =>
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
Left VolatileDBError blk
err -> VolatileDBError blk -> m b
forall e a. Exception e => e -> m a
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 :: forall (proxy :: * -> *) blk b.
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
$ 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