{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.HardFork.Combinator.Node.InitStorage () where import Data.Proxy import Data.SOP.BasicFunctors import Data.SOP.Index import Data.SOP.Strict 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.Node.InitStorage 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 forall (proxy :: [*] -> *). proxy xs -> ProofNonEmpty xs isNonEmpty (forall (t :: [*]). Proxy t forall {k} (t :: k). Proxy t Proxy @xs) of ProofNonEmpty {} -> StorageConfig x -> ChunkInfo forall blk. NodeInitStorage blk => StorageConfig blk -> ChunkInfo nodeImmutableDbChunkInfo (NP StorageConfig (x : xs1) -> StorageConfig x forall {k} (f :: k -> *) (x :: k) (xs :: [k]). NP f (x : xs) -> f x hd NP StorageConfig xs NP StorageConfig (x : xs1) 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 forall (proxy :: [*] -> *). proxy xs -> ProofNonEmpty xs isNonEmpty (forall (t :: [*]). Proxy t forall {k} (t :: k). Proxy t Proxy @xs) of ProofNonEmpty {} -> NS (K Bool) xs -> CollapseTo NS Bool forall (xs :: [*]) a. SListIN NS xs => NS (K a) xs -> CollapseTo NS a 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 (forall {k} (t :: k). Proxy t forall (t :: * -> Constraint). Proxy t Proxy @SingleEraBlock) StorageConfig a -> I a -> K Bool a 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 :: forall blk. NodeInitStorage blk => 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 :: forall (m :: * -> *). IOLike m => 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 forall (proxy :: [*] -> *). proxy xs -> ProofNonEmpty xs isNonEmpty (forall (t :: [*]). Proxy t 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 (xs :: [*]) a. SListIN NS xs => NS (K a) xs -> CollapseTo NS a 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 Index xs a -> StorageConfig a -> LedgerState a -> K (m ()) a 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 :: forall a. SingleEraBlock a => Index xs a -> StorageConfig a -> LedgerState a -> K (m ()) a 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 () forall (m :: * -> *). IOLike m => StorageConfig blk -> InitChainDB m blk -> m () nodeInitChainDB StorageConfig blk cfg' 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 {k} (f :: k -> *) a b (x :: k) (xs :: [k]). (Coercible a (f x), Coercible b (NS f xs)) => Proxy f -> Index xs x -> a -> b injectNS' (forall {k} (t :: k). Proxy t forall (t :: * -> *). Proxy t Proxy @I) Index xs blk index , getCurrentLedger :: m (LedgerState blk) getCurrentLedger = LedgerState blk -> m (LedgerState blk) forall a. a -> m a forall (m :: * -> *) a. Monad m => a -> m a return LedgerState blk currentLedger }