{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Storage.LedgerDB.LedgerDB (
    -- * LedgerDB
    Checkpoint (..)
  , LedgerDB (..)
  , LedgerDB'
  , LedgerDbCfg (..)
  , configLedgerDb
  ) where

import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerCfg (..),
                     ExtLedgerState)
import           Ouroboros.Consensus.Protocol.Abstract (ConsensusProtocol)
import           Ouroboros.Network.AnchoredSeq (Anchorable (..),
                     AnchoredSeq (..))
import qualified Ouroboros.Network.AnchoredSeq as AS

{-------------------------------------------------------------------------------
  LedgerDB
-------------------------------------------------------------------------------}

-- | Internal state of the ledger DB
--
-- The ledger DB looks like
--
-- > anchor |> snapshots <| current
--
-- where @anchor@ records the oldest known snapshot and @current@ the most
-- recent. The anchor is the oldest point we can roll back to.
--
-- We take a snapshot after each block is applied and keep in memory a window
-- of the last @k@ snapshots. We have verified empirically (#1936) that the
-- overhead of keeping @k@ snapshots in memory is small, i.e., about 5%
-- compared to keeping a snapshot every 100 blocks. This is thanks to sharing
-- between consecutive snapshots.
--
-- As an example, suppose we have @k = 6@. The ledger DB grows as illustrated
-- below, where we indicate the anchor number of blocks, the stored snapshots,
-- and the current ledger.
--
-- > anchor |> #   [ snapshots ]                   <| tip
-- > ---------------------------------------------------------------------------
-- > G      |> (0) [ ]                             <| G
-- > G      |> (1) [ L1]                           <| L1
-- > G      |> (2) [ L1,  L2]                      <| L2
-- > G      |> (3) [ L1,  L2,  L3]                 <| L3
-- > G      |> (4) [ L1,  L2,  L3,  L4]            <| L4
-- > G      |> (5) [ L1,  L2,  L3,  L4,  L5]       <| L5
-- > G      |> (6) [ L1,  L2,  L3,  L4,  L5,  L6]  <| L6
-- > L1     |> (6) [ L2,  L3,  L4,  L5,  L6,  L7]  <| L7
-- > L2     |> (6) [ L3,  L4,  L5,  L6,  L7,  L8]  <| L8
-- > L3     |> (6) [ L4,  L5,  L6,  L7,  L8,  L9]  <| L9   (*)
-- > L4     |> (6) [ L5,  L6,  L7,  L8,  L9,  L10] <| L10
-- > L5     |> (6) [*L6,  L7,  L8,  L9,  L10, L11] <| L11
-- > L6     |> (6) [ L7,  L8,  L9,  L10, L11, L12] <| L12
-- > L7     |> (6) [ L8,  L9,  L10, L12, L12, L13] <| L13
-- > L8     |> (6) [ L9,  L10, L12, L12, L13, L14] <| L14
--
-- The ledger DB must guarantee that at all times we are able to roll back @k@
-- blocks. For example, if we are on line (*), and roll back 6 blocks, we get
--
-- > L3 |> []
newtype LedgerDB l = LedgerDB {
      -- | Ledger states
      forall l.
LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints :: AnchoredSeq
                               (WithOrigin SlotNo)
                               (Checkpoint l)
                               (Checkpoint l)
    }
  deriving ((forall x. LedgerDB l -> Rep (LedgerDB l) x)
-> (forall x. Rep (LedgerDB l) x -> LedgerDB l)
-> Generic (LedgerDB l)
forall x. Rep (LedgerDB l) x -> LedgerDB l
forall x. LedgerDB l -> Rep (LedgerDB l) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l x. Rep (LedgerDB l) x -> LedgerDB l
forall l x. LedgerDB l -> Rep (LedgerDB l) x
$cfrom :: forall l x. LedgerDB l -> Rep (LedgerDB l) x
from :: forall x. LedgerDB l -> Rep (LedgerDB l) x
$cto :: forall l x. Rep (LedgerDB l) x -> LedgerDB l
to :: forall x. Rep (LedgerDB l) x -> LedgerDB l
Generic)

type LedgerDB' blk = LedgerDB (ExtLedgerState blk)

deriving instance Show     l => Show     (LedgerDB l)
deriving instance Eq       l => Eq       (LedgerDB l)
deriving instance NoThunks l => NoThunks (LedgerDB l)

type instance HeaderHash (LedgerDB l) = HeaderHash l

instance IsLedger l => GetTip (LedgerDB l) where
  getTip :: LedgerDB l -> Point (LedgerDB l)
getTip = Point l -> Point (LedgerDB l)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint
         (Point l -> Point (LedgerDB l))
-> (LedgerDB l -> Point l) -> LedgerDB l -> Point (LedgerDB l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l -> Point l
forall l. GetTip l => l -> Point l
getTip
         (l -> Point l) -> (LedgerDB l -> l) -> LedgerDB l -> Point l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Checkpoint l -> l)
-> (Checkpoint l -> l) -> Either (Checkpoint l) (Checkpoint l) -> l
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Checkpoint l -> l
forall l. Checkpoint l -> l
unCheckpoint Checkpoint l -> l
forall l. Checkpoint l -> l
unCheckpoint
         (Either (Checkpoint l) (Checkpoint l) -> l)
-> (LedgerDB l -> Either (Checkpoint l) (Checkpoint l))
-> LedgerDB l
-> l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
-> Either (Checkpoint l) (Checkpoint l)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AS.head
         (AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
 -> Either (Checkpoint l) (Checkpoint l))
-> (LedgerDB l
    -> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l))
-> LedgerDB l
-> Either (Checkpoint l) (Checkpoint l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
forall l.
LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints

-- | Internal newtype wrapper around a ledger state @l@ so that we can define a
-- non-blanket 'Anchorable' instance.
newtype Checkpoint l = Checkpoint {
      forall l. Checkpoint l -> l
unCheckpoint :: l
    }
  deriving ((forall x. Checkpoint l -> Rep (Checkpoint l) x)
-> (forall x. Rep (Checkpoint l) x -> Checkpoint l)
-> Generic (Checkpoint l)
forall x. Rep (Checkpoint l) x -> Checkpoint l
forall x. Checkpoint l -> Rep (Checkpoint l) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l x. Rep (Checkpoint l) x -> Checkpoint l
forall l x. Checkpoint l -> Rep (Checkpoint l) x
$cfrom :: forall l x. Checkpoint l -> Rep (Checkpoint l) x
from :: forall x. Checkpoint l -> Rep (Checkpoint l) x
$cto :: forall l x. Rep (Checkpoint l) x -> Checkpoint l
to :: forall x. Rep (Checkpoint l) x -> Checkpoint l
Generic)

deriving instance Show     l => Show     (Checkpoint l)
deriving instance Eq       l => Eq       (Checkpoint l)
deriving instance NoThunks l => NoThunks (Checkpoint l)

instance GetTip l => Anchorable (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l) where
  asAnchor :: Checkpoint l -> Checkpoint l
asAnchor = Checkpoint l -> Checkpoint l
forall a. a -> a
id
  getAnchorMeasure :: Proxy (Checkpoint l) -> Checkpoint l -> WithOrigin SlotNo
getAnchorMeasure Proxy (Checkpoint l)
_ = l -> WithOrigin SlotNo
forall l. GetTip l => l -> WithOrigin SlotNo
getTipSlot (l -> WithOrigin SlotNo)
-> (Checkpoint l -> l) -> Checkpoint l -> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Checkpoint l -> l
forall l. Checkpoint l -> l
unCheckpoint

{-------------------------------------------------------------------------------
  LedgerDB Config
-------------------------------------------------------------------------------}

data LedgerDbCfg l = LedgerDbCfg {
      forall l. LedgerDbCfg l -> SecurityParam
ledgerDbCfgSecParam :: !SecurityParam
    , forall l. LedgerDbCfg l -> LedgerCfg l
ledgerDbCfg         :: !(LedgerCfg l)
    }
  deriving ((forall x. LedgerDbCfg l -> Rep (LedgerDbCfg l) x)
-> (forall x. Rep (LedgerDbCfg l) x -> LedgerDbCfg l)
-> Generic (LedgerDbCfg l)
forall x. Rep (LedgerDbCfg l) x -> LedgerDbCfg l
forall x. LedgerDbCfg l -> Rep (LedgerDbCfg l) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l x. Rep (LedgerDbCfg l) x -> LedgerDbCfg l
forall l x. LedgerDbCfg l -> Rep (LedgerDbCfg l) x
$cfrom :: forall l x. LedgerDbCfg l -> Rep (LedgerDbCfg l) x
from :: forall x. LedgerDbCfg l -> Rep (LedgerDbCfg l) x
$cto :: forall l x. Rep (LedgerDbCfg l) x -> LedgerDbCfg l
to :: forall x. Rep (LedgerDbCfg l) x -> LedgerDbCfg l
Generic)

deriving instance NoThunks (LedgerCfg l) => NoThunks (LedgerDbCfg l)

configLedgerDb ::
     ConsensusProtocol (BlockProtocol blk)
  => TopLevelConfig blk
  -> LedgerDbCfg (ExtLedgerState blk)
configLedgerDb :: forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> LedgerDbCfg (ExtLedgerState blk)
configLedgerDb TopLevelConfig blk
cfg = LedgerDbCfg {
      ledgerDbCfgSecParam :: SecurityParam
ledgerDbCfgSecParam = TopLevelConfig blk -> SecurityParam
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> SecurityParam
configSecurityParam TopLevelConfig blk
cfg
    , ledgerDbCfg :: LedgerCfg (ExtLedgerState blk)
ledgerDbCfg         = TopLevelConfig blk -> ExtLedgerCfg blk
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg TopLevelConfig blk
cfg
    }