{-# 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.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) {------------------------------------------------------------------------------- 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. forall (m :: * -> *) blk. 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. , 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) -- | Store the given block in the VolatileDB. -- -- Returns after the block has been written to disk. , forall (m :: * -> *) blk. 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 -- successor 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. , forall (m :: * -> *) blk. 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. , forall (m :: * -> *) blk. 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. , forall (m :: * -> *) blk. VolatileDB m blk -> HasCallStack => SlotNo -> m () garbageCollect :: HasCallStack => SlotNo -> m () -- | Return the highest slot number ever stored by the VolatileDB. , 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) {------------------------------------------------------------------------------ Types ------------------------------------------------------------------------------} -- | The information that the user has to provide for each new block. 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 , forall blk. BlockInfo blk -> Word16 biHeaderOffset :: !Word16 , forall blk. 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 $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) {------------------------------------------------------------------------------ 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 $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 -- | 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 :: 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