{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

-- | Interface to the ledger layer
module Ouroboros.Consensus.Ledger.Abstract (
    -- * Type-level validation marker
    Validated
    -- * Apply block
  , ApplyBlock (..)
  , UpdateLedger
    -- * Derived
  , applyLedgerBlock
  , foldLedger
  , reapplyLedgerBlock
  , refoldLedger
  , tickThenApply
  , tickThenApplyLedgerResult
  , tickThenReapply
  , tickThenReapplyLedgerResult
    -- ** Short-hand
  , ledgerTipHash
  , ledgerTipPoint
  , ledgerTipSlot
    -- * Re-exports
  , module Ouroboros.Consensus.Ledger.Basics
  ) where

import           Control.Monad.Except
import           Data.Kind (Type)
import           Data.Proxy
import           GHC.Stack (HasCallStack)

import           Ouroboros.Consensus.Block.Abstract
import           Ouroboros.Consensus.Ledger.Basics
import           Ouroboros.Consensus.Ticked
import           Ouroboros.Consensus.Util (repeatedly, repeatedlyM, (..:))

-- | " Validated " transaction or block
--
-- The ledger defines how to validate transactions and blocks. It's possible the
-- type before and after validation may be distinct (eg Alonzo transactions),
-- which originally motivated this family.
--
-- We also gain the related benefit that certain interface functions, such as
-- those that /reapply/ blocks, can have a more precise type now. TODO
--
-- Similarly, the Node-to-Client mini protocols can explicitly indicate that the
-- client trusts the blocks from the local server, by having the server send
-- 'Validated' blocks to the client. TODO
--
-- Note that validation has different implications for a transaction than for a
-- block. In particular, a validated transaction can be " reapplied " to
-- different ledger states, whereas a validated block must only be " reapplied "
-- to the exact same ledger state (eg as part of rebuilding from an on-disk
-- ledger snapshot).
--
-- Since the ledger defines validation, see the ledger details for concrete
-- examples of what determines the validity (wrt to a 'LedgerState') of a
-- transaction and/or block. Example properties include: a transaction's claimed
-- inputs exist and are still unspent, a block carries a sufficient
-- cryptographic signature, etc.
data family Validated x :: Type

{-------------------------------------------------------------------------------
  Apply block to ledger state
-------------------------------------------------------------------------------}

class ( IsLedger l
      , HeaderHash l ~ HeaderHash blk
      , HasHeader blk
      , HasHeader (Header blk)
      ) => ApplyBlock l blk where

  -- | Apply a block to the ledger state.
  --
  -- This is passed the ledger state ticked with the slot of the given block, so
  -- 'applyChainTickLedgerResult' has already been called.
  applyBlockLedgerResult ::
       HasCallStack
    => LedgerCfg l
    -> blk
    -> Ticked l
    -> Except (LedgerErr l) (LedgerResult l l)

  -- | Re-apply a block to the very same ledger state it was applied in before.
  --
  -- Since a block can only be applied to a single, specific, ledger state,
  -- if we apply a previously applied block again it will be applied in the
  -- very same ledger state, and therefore can't possibly fail.
  --
  -- It is worth noting that since we already know that the block is valid in
  -- the provided ledger state, the ledger layer should not perform /any/
  -- validation checks.
  reapplyBlockLedgerResult ::
       HasCallStack
    => LedgerCfg l
    -> blk
    -> Ticked l
    -> LedgerResult l l

-- | Interaction with the ledger layer
class ApplyBlock (LedgerState blk) blk => UpdateLedger blk

{-------------------------------------------------------------------------------
  Derived functionality
-------------------------------------------------------------------------------}

-- | 'lrResult' after 'applyBlockLedgerResult'
applyLedgerBlock ::
     (ApplyBlock l blk, HasCallStack)
  => LedgerCfg l
  -> blk
  -> Ticked l
  -> Except (LedgerErr l) l
applyLedgerBlock :: LedgerCfg l -> blk -> Ticked l -> Except (LedgerErr l) l
applyLedgerBlock = (LedgerResult l l -> l)
-> ExceptT (LedgerErr l) Identity (LedgerResult l l)
-> Except (LedgerErr l) l
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LedgerResult l l -> l
forall l a. LedgerResult l a -> a
lrResult (ExceptT (LedgerErr l) Identity (LedgerResult l l)
 -> Except (LedgerErr l) l)
-> (LedgerCfg l
    -> blk
    -> Ticked l
    -> ExceptT (LedgerErr l) Identity (LedgerResult l l))
-> LedgerCfg l
-> blk
-> Ticked l
-> Except (LedgerErr l) l
forall y z x0 x1 x2.
(y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z
..: LedgerCfg l
-> blk
-> Ticked l
-> ExceptT (LedgerErr l) Identity (LedgerResult l l)
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
LedgerCfg l
-> blk -> Ticked l -> Except (LedgerErr l) (LedgerResult l l)
applyBlockLedgerResult

-- | 'lrResult' after 'reapplyBlockLedgerResult'
reapplyLedgerBlock ::
     (ApplyBlock l blk, HasCallStack)
  => LedgerCfg l
  -> blk
  -> Ticked l
  -> l
reapplyLedgerBlock :: LedgerCfg l -> blk -> Ticked l -> l
reapplyLedgerBlock = LedgerResult l l -> l
forall l a. LedgerResult l a -> a
lrResult (LedgerResult l l -> l)
-> (LedgerCfg l -> blk -> Ticked l -> LedgerResult l l)
-> LedgerCfg l
-> blk
-> Ticked l
-> l
forall y z x0 x1 x2.
(y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z
..: LedgerCfg l -> blk -> Ticked l -> LedgerResult l l
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
LedgerCfg l -> blk -> Ticked l -> LedgerResult l l
reapplyBlockLedgerResult

tickThenApplyLedgerResult ::
     ApplyBlock l blk
  => LedgerCfg l
  -> blk
  -> l
  -> Except (LedgerErr l) (LedgerResult l l)
tickThenApplyLedgerResult :: LedgerCfg l -> blk -> l -> Except (LedgerErr l) (LedgerResult l l)
tickThenApplyLedgerResult LedgerCfg l
cfg blk
blk l
l = do
  let lrTick :: LedgerResult l (Ticked l)
lrTick = LedgerCfg l -> SlotNo -> l -> LedgerResult l (Ticked l)
forall l.
IsLedger l =>
LedgerCfg l -> SlotNo -> l -> LedgerResult l (Ticked l)
applyChainTickLedgerResult LedgerCfg l
cfg (blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
blk) l
l
  LedgerResult l l
lrBlock <-   LedgerCfg l
-> blk -> Ticked l -> Except (LedgerErr l) (LedgerResult l l)
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
LedgerCfg l
-> blk -> Ticked l -> Except (LedgerErr l) (LedgerResult l l)
applyBlockLedgerResult     LedgerCfg l
cfg            blk
blk  (LedgerResult l (Ticked l) -> Ticked l
forall l a. LedgerResult l a -> a
lrResult LedgerResult l (Ticked l)
lrTick)
  LedgerResult l l -> Except (LedgerErr l) (LedgerResult l l)
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerResult :: forall l a. [AuxLedgerEvent l] -> a -> LedgerResult l a
LedgerResult {
      lrEvents :: [AuxLedgerEvent l]
lrEvents = LedgerResult l (Ticked l) -> [AuxLedgerEvent l]
forall l a. LedgerResult l a -> [AuxLedgerEvent l]
lrEvents LedgerResult l (Ticked l)
lrTick [AuxLedgerEvent l] -> [AuxLedgerEvent l] -> [AuxLedgerEvent l]
forall a. Semigroup a => a -> a -> a
<> LedgerResult l l -> [AuxLedgerEvent l]
forall l a. LedgerResult l a -> [AuxLedgerEvent l]
lrEvents LedgerResult l l
lrBlock
    , lrResult :: l
lrResult = LedgerResult l l -> l
forall l a. LedgerResult l a -> a
lrResult LedgerResult l l
lrBlock
    }

tickThenReapplyLedgerResult ::
     ApplyBlock l blk
  => LedgerCfg l
  -> blk
  -> l
  -> LedgerResult l l
tickThenReapplyLedgerResult :: LedgerCfg l -> blk -> l -> LedgerResult l l
tickThenReapplyLedgerResult LedgerCfg l
cfg blk
blk l
l =
  let lrTick :: LedgerResult l (Ticked l)
lrTick  = LedgerCfg l -> SlotNo -> l -> LedgerResult l (Ticked l)
forall l.
IsLedger l =>
LedgerCfg l -> SlotNo -> l -> LedgerResult l (Ticked l)
applyChainTickLedgerResult LedgerCfg l
cfg (blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
blk) l
l
      lrBlock :: LedgerResult l l
lrBlock = LedgerCfg l -> blk -> Ticked l -> LedgerResult l l
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
LedgerCfg l -> blk -> Ticked l -> LedgerResult l l
reapplyBlockLedgerResult   LedgerCfg l
cfg            blk
blk (LedgerResult l (Ticked l) -> Ticked l
forall l a. LedgerResult l a -> a
lrResult LedgerResult l (Ticked l)
lrTick)
  in LedgerResult :: forall l a. [AuxLedgerEvent l] -> a -> LedgerResult l a
LedgerResult {
      lrEvents :: [AuxLedgerEvent l]
lrEvents = LedgerResult l (Ticked l) -> [AuxLedgerEvent l]
forall l a. LedgerResult l a -> [AuxLedgerEvent l]
lrEvents LedgerResult l (Ticked l)
lrTick [AuxLedgerEvent l] -> [AuxLedgerEvent l] -> [AuxLedgerEvent l]
forall a. Semigroup a => a -> a -> a
<> LedgerResult l l -> [AuxLedgerEvent l]
forall l a. LedgerResult l a -> [AuxLedgerEvent l]
lrEvents LedgerResult l l
lrBlock
    , lrResult :: l
lrResult = LedgerResult l l -> l
forall l a. LedgerResult l a -> a
lrResult LedgerResult l l
lrBlock
    }

tickThenApply ::
     ApplyBlock l blk
  => LedgerCfg l
  -> blk
  -> l
  -> Except (LedgerErr l) l
tickThenApply :: LedgerCfg l -> blk -> l -> Except (LedgerErr l) l
tickThenApply = (LedgerResult l l -> l)
-> ExceptT (LedgerErr l) Identity (LedgerResult l l)
-> Except (LedgerErr l) l
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LedgerResult l l -> l
forall l a. LedgerResult l a -> a
lrResult (ExceptT (LedgerErr l) Identity (LedgerResult l l)
 -> Except (LedgerErr l) l)
-> (LedgerCfg l
    -> blk -> l -> ExceptT (LedgerErr l) Identity (LedgerResult l l))
-> LedgerCfg l
-> blk
-> l
-> Except (LedgerErr l) l
forall y z x0 x1 x2.
(y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z
..: LedgerCfg l
-> blk -> l -> ExceptT (LedgerErr l) Identity (LedgerResult l l)
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> Except (LedgerErr l) (LedgerResult l l)
tickThenApplyLedgerResult

tickThenReapply ::
     ApplyBlock l blk
  => LedgerCfg l
  -> blk
  -> l
  -> l
tickThenReapply :: LedgerCfg l -> blk -> l -> l
tickThenReapply = LedgerResult l l -> l
forall l a. LedgerResult l a -> a
lrResult (LedgerResult l l -> l)
-> (LedgerCfg l -> blk -> l -> LedgerResult l l)
-> LedgerCfg l
-> blk
-> l
-> l
forall y z x0 x1 x2.
(y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z
..: LedgerCfg l -> blk -> l -> LedgerResult l l
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> LedgerResult l l
tickThenReapplyLedgerResult

foldLedger ::
     ApplyBlock l blk
  => LedgerCfg l -> [blk] -> l -> Except (LedgerErr l) l
foldLedger :: LedgerCfg l -> [blk] -> l -> Except (LedgerErr l) l
foldLedger = (blk -> l -> Except (LedgerErr l) l)
-> [blk] -> l -> Except (LedgerErr l) l
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> m b) -> [a] -> b -> m b
repeatedlyM ((blk -> l -> Except (LedgerErr l) l)
 -> [blk] -> l -> Except (LedgerErr l) l)
-> (LedgerCfg l -> blk -> l -> Except (LedgerErr l) l)
-> LedgerCfg l
-> [blk]
-> l
-> Except (LedgerErr l) l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerCfg l -> blk -> l -> Except (LedgerErr l) l
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> Except (LedgerErr l) l
tickThenApply

refoldLedger ::
     ApplyBlock l blk
  => LedgerCfg l -> [blk] -> l -> l
refoldLedger :: LedgerCfg l -> [blk] -> l -> l
refoldLedger = (blk -> l -> l) -> [blk] -> l -> l
forall a b. (a -> b -> b) -> [a] -> b -> b
repeatedly ((blk -> l -> l) -> [blk] -> l -> l)
-> (LedgerCfg l -> blk -> l -> l) -> LedgerCfg l -> [blk] -> l -> l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerCfg l -> blk -> l -> l
forall l blk. ApplyBlock l blk => LedgerCfg l -> blk -> l -> l
tickThenReapply

{-------------------------------------------------------------------------------
  Short-hand
-------------------------------------------------------------------------------}

-- | Wrapper around 'ledgerTipPoint' that uses a proxy to fix @blk@
--
-- This is occassionally useful to guide type inference
ledgerTipPoint ::
     UpdateLedger blk
  => Proxy blk -> LedgerState blk -> Point blk
ledgerTipPoint :: Proxy blk -> LedgerState blk -> Point blk
ledgerTipPoint Proxy blk
_ = Point (LedgerState blk) -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (LedgerState blk) -> Point blk)
-> (LedgerState blk -> Point (LedgerState blk))
-> LedgerState blk
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState blk -> Point (LedgerState blk)
forall l. GetTip l => l -> Point l
getTip

ledgerTipHash ::
     forall blk. UpdateLedger blk
  => LedgerState blk -> ChainHash blk
ledgerTipHash :: LedgerState blk -> ChainHash blk
ledgerTipHash = Point blk -> ChainHash blk
forall block. Point block -> ChainHash block
pointHash (Point blk -> ChainHash blk)
-> (LedgerState blk -> Point blk)
-> LedgerState blk
-> ChainHash blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Proxy blk -> LedgerState blk -> Point blk
forall blk.
UpdateLedger blk =>
Proxy blk -> LedgerState blk -> Point blk
ledgerTipPoint (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk))

ledgerTipSlot ::
     forall blk. UpdateLedger blk
  => LedgerState blk -> WithOrigin SlotNo
ledgerTipSlot :: LedgerState blk -> WithOrigin SlotNo
ledgerTipSlot = Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot (Point blk -> WithOrigin SlotNo)
-> (LedgerState blk -> Point blk)
-> LedgerState blk
-> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Proxy blk -> LedgerState blk -> Point blk
forall blk.
UpdateLedger blk =>
Proxy blk -> LedgerState blk -> Point blk
ledgerTipPoint (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk))