{-# 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
            }