{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Storage.LedgerDB.Query (
    ledgerDbAnchor
  , ledgerDbCurrent
  , ledgerDbIsSaturated
  , ledgerDbMaxRollback
  , ledgerDbPast
  , ledgerDbSnapshots
  , ledgerDbTip
  ) where

import           Data.Foldable (find)
import           Data.Word
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Storage.LedgerDB.LedgerDB
import qualified Ouroboros.Network.AnchoredSeq as AS

-- | The ledger state at the tip of the chain
ledgerDbCurrent :: GetTip l => LedgerDB l -> l
ledgerDbCurrent :: forall l. GetTip l => LedgerDB l -> l
ledgerDbCurrent = (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

-- | Information about the state of the ledger at the anchor
ledgerDbAnchor :: LedgerDB l -> l
ledgerDbAnchor :: forall l. LedgerDB l -> l
ledgerDbAnchor = Checkpoint l -> l
forall l. Checkpoint l -> l
unCheckpoint (Checkpoint l -> l)
-> (LedgerDB l -> Checkpoint l) -> LedgerDB l -> l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
-> Checkpoint l
forall v a b. AnchoredSeq v a b -> a
AS.anchor (AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
 -> Checkpoint l)
-> (LedgerDB l
    -> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l))
-> LedgerDB 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

-- | All snapshots currently stored by the ledger DB (new to old)
--
-- This also includes the snapshot at the anchor. For each snapshot we also
-- return the distance from the tip.
ledgerDbSnapshots :: LedgerDB l -> [(Word64, l)]
ledgerDbSnapshots :: forall l. LedgerDB l -> [(Word64, l)]
ledgerDbSnapshots LedgerDB{AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints :: forall l.
LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints :: AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
..} =
    [Word64] -> [l] -> [(Word64, l)]
forall a b. [a] -> [b] -> [(a, b)]
zip
      [Word64
0..]
      ((Checkpoint l -> l) -> [Checkpoint l] -> [l]
forall a b. (a -> b) -> [a] -> [b]
map Checkpoint l -> l
forall l. Checkpoint l -> l
unCheckpoint (AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
-> [Checkpoint l]
forall v a b. AnchoredSeq v a b -> [b]
AS.toNewestFirst AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints)
        [l] -> [l] -> [l]
forall a. Semigroup a => a -> a -> a
<> [Checkpoint l -> l
forall l. Checkpoint l -> l
unCheckpoint (AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
-> Checkpoint l
forall v a b. AnchoredSeq v a b -> a
AS.anchor AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints)])

-- | How many blocks can we currently roll back?
ledgerDbMaxRollback :: GetTip l => LedgerDB l -> Word64
ledgerDbMaxRollback :: forall l. GetTip l => LedgerDB l -> Word64
ledgerDbMaxRollback LedgerDB{AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints :: forall l.
LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints :: AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
..} = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
-> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AS.length AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints)

-- | Reference to the block at the tip of the chain
ledgerDbTip :: GetTip l => LedgerDB l -> Point l
ledgerDbTip :: forall l. GetTip l => LedgerDB l -> Point l
ledgerDbTip = Point l -> Point l
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point l -> Point l)
-> (LedgerDB l -> Point l) -> LedgerDB l -> Point 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
. LedgerDB l -> l
forall l. GetTip l => LedgerDB l -> l
ledgerDbCurrent

-- | Have we seen at least @k@ blocks?
ledgerDbIsSaturated :: GetTip l => SecurityParam -> LedgerDB l -> Bool
ledgerDbIsSaturated :: forall l. GetTip l => SecurityParam -> LedgerDB l -> Bool
ledgerDbIsSaturated (SecurityParam Word64
k) LedgerDB l
db =
    LedgerDB l -> Word64
forall l. GetTip l => LedgerDB l -> Word64
ledgerDbMaxRollback LedgerDB l
db Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
k

-- | Get a past ledger state
--
--  \( O(\log(\min(i,n-i)) \)
--
-- When no ledger state (or anchor) has the given 'Point', 'Nothing' is
-- returned.
ledgerDbPast ::
     (HasHeader blk, IsLedger l, HeaderHash l ~ HeaderHash blk)
  => Point blk
  -> LedgerDB l
  -> Maybe l
ledgerDbPast :: forall blk l.
(HasHeader blk, IsLedger l, HeaderHash l ~ HeaderHash blk) =>
Point blk -> LedgerDB l -> Maybe l
ledgerDbPast Point blk
pt LedgerDB l
db
    | Point blk
pt Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point l -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (l -> Point l
forall l. GetTip l => l -> Point l
getTip (LedgerDB l -> l
forall l. LedgerDB l -> l
ledgerDbAnchor LedgerDB l
db))
    = l -> Maybe l
forall a. a -> Maybe a
Just (l -> Maybe l) -> l -> Maybe l
forall a b. (a -> b) -> a -> b
$ LedgerDB l -> l
forall l. LedgerDB l -> l
ledgerDbAnchor LedgerDB l
db
    | Bool
otherwise
    = (Checkpoint l -> l) -> Maybe (Checkpoint l) -> Maybe l
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Checkpoint l -> l
forall l. Checkpoint l -> l
unCheckpoint (Maybe (Checkpoint l) -> Maybe l)
-> Maybe (Checkpoint l) -> Maybe l
forall a b. (a -> b) -> a -> b
$
        (Checkpoint l -> Bool) -> [Checkpoint l] -> Maybe (Checkpoint l)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk
pt) (Point blk -> Bool)
-> (Checkpoint l -> Point blk) -> Checkpoint l -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point l -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point l -> Point blk)
-> (Checkpoint l -> Point l) -> Checkpoint l -> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l -> Point l
forall l. GetTip l => l -> Point l
getTip (l -> Point l) -> (Checkpoint l -> l) -> Checkpoint l -> Point l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Checkpoint l -> l
forall l. Checkpoint l -> l
unCheckpoint) ([Checkpoint l] -> Maybe (Checkpoint l))
-> [Checkpoint l] -> Maybe (Checkpoint l)
forall a b. (a -> b) -> a -> b
$
          WithOrigin SlotNo
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
-> [Checkpoint l]
forall v a b. Anchorable v a b => v -> AnchoredSeq v a b -> [b]
AS.lookupByMeasure (Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point blk
pt) (LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
forall l.
LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints LedgerDB l
db)