{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.HardFork.Combinator.Node.InitStorage () where import Data.SOP.Strict import Ouroboros.Consensus.Node.InitStorage import Ouroboros.Consensus.Util.SOP import Ouroboros.Consensus.HardFork.Combinator.Abstract import Ouroboros.Consensus.HardFork.Combinator.AcrossEras import Ouroboros.Consensus.HardFork.Combinator.Basics import qualified Ouroboros.Consensus.HardFork.Combinator.State as State import Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB (..)) instance CanHardFork xs => NodeInitStorage (HardForkBlock xs) where -- We use the chunk info from the first era nodeImmutableDbChunkInfo :: StorageConfig (HardForkBlock xs) -> ChunkInfo nodeImmutableDbChunkInfo StorageConfig (HardForkBlock xs) cfg = case Proxy xs -> ProofNonEmpty xs forall a (xs :: [a]) (proxy :: [a] -> *). IsNonEmpty xs => proxy xs -> ProofNonEmpty xs isNonEmpty (Proxy xs forall k (t :: k). Proxy t Proxy @xs) of ProofNonEmpty {} -> StorageConfig x -> ChunkInfo forall blk. NodeInitStorage blk => StorageConfig blk -> ChunkInfo nodeImmutableDbChunkInfo (NP StorageConfig (x : xs) -> StorageConfig x forall k (f :: k -> *) (x :: k) (xs :: [k]). NP f (x : xs) -> f x hd NP StorageConfig xs NP StorageConfig (x : xs) cfgs) where cfgs :: NP StorageConfig xs cfgs = PerEraStorageConfig xs -> NP StorageConfig xs forall (xs :: [*]). PerEraStorageConfig xs -> NP StorageConfig xs getPerEraStorageConfig (StorageConfig (HardForkBlock xs) -> PerEraStorageConfig xs forall (xs :: [*]). StorageConfig (HardForkBlock xs) -> PerEraStorageConfig xs hardForkStorageConfigPerEra StorageConfig (HardForkBlock xs) cfg) -- Dispatch based on the era nodeCheckIntegrity :: StorageConfig (HardForkBlock xs) -> HardForkBlock xs -> Bool nodeCheckIntegrity StorageConfig (HardForkBlock xs) cfg (HardForkBlock (OneEraBlock NS I xs blk)) = case Proxy xs -> ProofNonEmpty xs forall a (xs :: [a]) (proxy :: [a] -> *). IsNonEmpty xs => proxy xs -> ProofNonEmpty xs isNonEmpty (Proxy xs forall k (t :: k). Proxy t Proxy @xs) of ProofNonEmpty {} -> NS (K Bool) xs -> CollapseTo NS Bool forall k l (h :: (k -> *) -> l -> *) (xs :: l) a. (HCollapse h, SListIN h xs) => h (K a) xs -> CollapseTo h a hcollapse (NS (K Bool) xs -> CollapseTo NS Bool) -> NS (K Bool) xs -> CollapseTo NS Bool forall a b. (a -> b) -> a -> b $ Proxy SingleEraBlock -> (forall a. SingleEraBlock a => StorageConfig a -> I a -> K Bool a) -> Prod NS StorageConfig xs -> NS I xs -> NS (K Bool) xs forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint) (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *) (f' :: k -> *) (f'' :: k -> *). (AllN (Prod h) c xs, HAp h, HAp (Prod h)) => proxy c -> (forall (a :: k). c a => f a -> f' a -> f'' a) -> Prod h f xs -> h f' xs -> h f'' xs hczipWith (Proxy SingleEraBlock forall k (t :: k). Proxy t Proxy @SingleEraBlock) forall blk. NodeInitStorage blk => StorageConfig blk -> I blk -> K Bool blk forall a. SingleEraBlock a => StorageConfig a -> I a -> K Bool a aux Prod NS StorageConfig xs NP StorageConfig xs cfgs NS I xs blk where cfgs :: NP StorageConfig xs cfgs = PerEraStorageConfig xs -> NP StorageConfig xs forall (xs :: [*]). PerEraStorageConfig xs -> NP StorageConfig xs getPerEraStorageConfig (StorageConfig (HardForkBlock xs) -> PerEraStorageConfig xs forall (xs :: [*]). StorageConfig (HardForkBlock xs) -> PerEraStorageConfig xs hardForkStorageConfigPerEra StorageConfig (HardForkBlock xs) cfg) aux :: NodeInitStorage blk => StorageConfig blk -> I blk -> K Bool blk aux :: StorageConfig blk -> I blk -> K Bool blk aux StorageConfig blk cfg' (I blk blk') = Bool -> K Bool blk forall k a (b :: k). a -> K a b K (Bool -> K Bool blk) -> Bool -> K Bool blk forall a b. (a -> b) -> a -> b $ StorageConfig blk -> blk -> Bool forall blk. NodeInitStorage blk => StorageConfig blk -> blk -> Bool nodeCheckIntegrity StorageConfig blk cfg' blk blk' -- Call the 'nodeInitChainDB' of the era in which the current ledger is. -- -- In most cases, this will be the first era, except when one or more hard -- forks are statically scheduled at the first slot. nodeInitChainDB :: StorageConfig (HardForkBlock xs) -> InitChainDB m (HardForkBlock xs) -> m () nodeInitChainDB StorageConfig (HardForkBlock xs) cfg (InitChainDB m (HardForkBlock xs) initChainDB :: InitChainDB m (HardForkBlock xs)) = case Proxy xs -> ProofNonEmpty xs forall a (xs :: [a]) (proxy :: [a] -> *). IsNonEmpty xs => proxy xs -> ProofNonEmpty xs isNonEmpty (Proxy xs forall k (t :: k). Proxy t Proxy @xs) of ProofNonEmpty {} -> do LedgerState (HardForkBlock xs) currentLedger <- InitChainDB m (HardForkBlock xs) -> m (LedgerState (HardForkBlock xs)) forall (m :: * -> *) blk. InitChainDB m blk -> m (LedgerState blk) getCurrentLedger InitChainDB m (HardForkBlock xs) initChainDB NS (K (m ())) xs -> CollapseTo NS (m ()) forall k l (h :: (k -> *) -> l -> *) (xs :: l) a. (HCollapse h, SListIN h xs) => h (K a) xs -> CollapseTo h a hcollapse (NS (K (m ())) xs -> CollapseTo NS (m ())) -> NS (K (m ())) xs -> CollapseTo NS (m ()) forall a b. (a -> b) -> a -> b $ Proxy SingleEraBlock -> (forall a. SingleEraBlock a => Index xs a -> StorageConfig a -> LedgerState a -> K (m ()) a) -> NP StorageConfig xs -> NS LedgerState xs -> NS (K (m ())) xs forall k (h :: (k -> *) -> [k] -> *) (c :: k -> Constraint) (xs :: [k]) (proxy :: (k -> Constraint) -> *) (f1 :: k -> *) (f2 :: k -> *) (f3 :: k -> *). (HAp h, All c xs, Prod h ~ NP) => proxy c -> (forall (a :: k). c a => Index xs a -> f1 a -> f2 a -> f3 a) -> NP f1 xs -> h f2 xs -> h f3 xs hcizipWith Proxy SingleEraBlock proxySingle forall a. SingleEraBlock a => Index xs a -> StorageConfig a -> LedgerState a -> K (m ()) a aux NP StorageConfig xs cfgs (HardForkState LedgerState xs -> NS LedgerState xs forall (xs :: [*]) (f :: * -> *). SListI xs => HardForkState f xs -> NS f xs State.tip (LedgerState (HardForkBlock xs) -> HardForkState LedgerState xs forall (xs :: [*]). LedgerState (HardForkBlock xs) -> HardForkState LedgerState xs hardForkLedgerStatePerEra LedgerState (HardForkBlock xs) currentLedger)) where cfgs :: NP StorageConfig xs cfgs = PerEraStorageConfig xs -> NP StorageConfig xs forall (xs :: [*]). PerEraStorageConfig xs -> NP StorageConfig xs getPerEraStorageConfig (StorageConfig (HardForkBlock xs) -> PerEraStorageConfig xs forall (xs :: [*]). StorageConfig (HardForkBlock xs) -> PerEraStorageConfig xs hardForkStorageConfigPerEra StorageConfig (HardForkBlock xs) cfg) aux :: SingleEraBlock blk => Index xs blk -> StorageConfig blk -> LedgerState blk -> K (m ()) blk aux :: Index xs blk -> StorageConfig blk -> LedgerState blk -> K (m ()) blk aux Index xs blk index StorageConfig blk cfg' LedgerState blk currentLedger = m () -> K (m ()) blk forall k a (b :: k). a -> K a b K (m () -> K (m ()) blk) -> m () -> K (m ()) blk forall a b. (a -> b) -> a -> b $ StorageConfig blk -> InitChainDB m blk -> m () forall blk (m :: * -> *). (NodeInitStorage blk, IOLike m) => StorageConfig blk -> InitChainDB m blk -> m () nodeInitChainDB StorageConfig blk cfg' InitChainDB :: forall (m :: * -> *) blk. (blk -> m ()) -> m (LedgerState blk) -> InitChainDB m blk InitChainDB { addBlock :: blk -> m () addBlock = InitChainDB m (HardForkBlock xs) -> HardForkBlock xs -> m () forall (m :: * -> *) blk. InitChainDB m blk -> blk -> m () addBlock InitChainDB m (HardForkBlock xs) initChainDB (HardForkBlock xs -> m ()) -> (blk -> HardForkBlock xs) -> blk -> m () forall b c a. (b -> c) -> (a -> b) -> a -> c . Proxy I -> Index xs blk -> blk -> HardForkBlock xs forall a1 (f :: a1 -> *) a2 b (x :: a1) (xs :: [a1]). (Coercible a2 (f x), Coercible b (NS f xs)) => Proxy f -> Index xs x -> a2 -> b injectNS' (Proxy I forall k (t :: k). Proxy t Proxy @I) Index xs blk index , getCurrentLedger :: m (LedgerState blk) getCurrentLedger = LedgerState blk -> m (LedgerState blk) forall (m :: * -> *) a. Monad m => a -> m a return LedgerState blk currentLedger }