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