{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- TODO where to put this?
module Ouroboros.Consensus.Shelley.Ledger.TPraos () where

import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map

import           Cardano.Crypto.VRF (certifiedOutput)

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Protocol.Signed

import qualified Shelley.Spec.Ledger.API as SL

import           Ouroboros.Consensus.Shelley.Eras (EraCrypto)
import           Ouroboros.Consensus.Shelley.Ledger.Block
import           Ouroboros.Consensus.Shelley.Ledger.Config
import           Ouroboros.Consensus.Shelley.Protocol

{-------------------------------------------------------------------------------
  Support for Transitional Praos consensus algorithm
-------------------------------------------------------------------------------}

type instance BlockProtocol (ShelleyBlock era) = TPraos (EraCrypto era)

instance ShelleyBasedEra era => BlockSupportsProtocol (ShelleyBlock era) where
  validateView :: BlockConfig (ShelleyBlock era)
-> Header (ShelleyBlock era)
-> ValidateView (BlockProtocol (ShelleyBlock era))
validateView BlockConfig (ShelleyBlock era)
_cfg (ShelleyHeader hdr _) = ValidateView (BlockProtocol (ShelleyBlock era))
BHeader (EraCrypto era)
hdr

  selectView :: BlockConfig (ShelleyBlock era)
-> Header (ShelleyBlock era)
-> SelectView (BlockProtocol (ShelleyBlock era))
selectView BlockConfig (ShelleyBlock era)
cfg hdr :: Header (ShelleyBlock era)
hdr@(ShelleyHeader shdr _) = TPraosChainSelectView :: forall c.
BlockNo
-> SlotNo
-> SelfIssued
-> VKey 'BlockIssuer c
-> Word64
-> OutputVRF (VRF c)
-> TPraosChainSelectView c
TPraosChainSelectView {
        csvChainLength :: BlockNo
csvChainLength = Header (ShelleyBlock era) -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header (ShelleyBlock era)
hdr
      , csvSlotNo :: SlotNo
csvSlotNo      = Header (ShelleyBlock era) -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header (ShelleyBlock era)
hdr
      , csvSelfIssued :: SelfIssued
csvSelfIssued  = SelfIssued
selfIssued
      , csvIssuer :: VKey 'BlockIssuer (EraCrypto era)
csvIssuer      = BHBody (EraCrypto era) -> VKey 'BlockIssuer (EraCrypto era)
forall crypto. BHBody crypto -> VKey 'BlockIssuer crypto
SL.bheaderVk BHBody (EraCrypto era)
hdrBody
      , csvIssueNo :: Word64
csvIssueNo     = OCert (EraCrypto era) -> Word64
forall crypto. OCert crypto -> Word64
SL.ocertN (OCert (EraCrypto era) -> Word64)
-> (BHBody (EraCrypto era) -> OCert (EraCrypto era))
-> BHBody (EraCrypto era)
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHBody (EraCrypto era) -> OCert (EraCrypto era)
forall crypto. BHBody crypto -> OCert crypto
SL.bheaderOCert (BHBody (EraCrypto era) -> Word64)
-> BHBody (EraCrypto era) -> Word64
forall a b. (a -> b) -> a -> b
$ BHBody (EraCrypto era)
hdrBody
      , csvLeaderVRF :: OutputVRF (VRF (EraCrypto era))
csvLeaderVRF   = CertifiedVRF (VRF (EraCrypto era)) Natural
-> OutputVRF (VRF (EraCrypto era))
forall v a. CertifiedVRF v a -> OutputVRF v
certifiedOutput (CertifiedVRF (VRF (EraCrypto era)) Natural
 -> OutputVRF (VRF (EraCrypto era)))
-> (BHBody (EraCrypto era)
    -> CertifiedVRF (VRF (EraCrypto era)) Natural)
-> BHBody (EraCrypto era)
-> OutputVRF (VRF (EraCrypto era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHBody (EraCrypto era)
-> CertifiedVRF (VRF (EraCrypto era)) Natural
forall crypto. BHBody crypto -> CertifiedVRF crypto Natural
SL.bheaderL (BHBody (EraCrypto era) -> OutputVRF (VRF (EraCrypto era)))
-> BHBody (EraCrypto era) -> OutputVRF (VRF (EraCrypto era))
forall a b. (a -> b) -> a -> b
$ BHBody (EraCrypto era)
hdrBody
      }
    where
      hdrBody :: SL.BHBody (EraCrypto era)
      hdrBody :: BHBody (EraCrypto era)
hdrBody = BHeader (EraCrypto era) -> BHBody (EraCrypto era)
forall crypto. Crypto crypto => BHeader crypto -> BHBody crypto
SL.bhbody BHeader (EraCrypto era)
shdr

      issuerVKeys :: Map (SL.KeyHash 'SL.BlockIssuer (EraCrypto era))
                         (SL.VKey 'SL.BlockIssuer (EraCrypto era))
      issuerVKeys :: Map
  (KeyHash 'BlockIssuer (EraCrypto era))
  (VKey 'BlockIssuer (EraCrypto era))
issuerVKeys = BlockConfig (ShelleyBlock era)
-> Map
     (KeyHash 'BlockIssuer (EraCrypto era))
     (VKey 'BlockIssuer (EraCrypto era))
forall era.
BlockConfig (ShelleyBlock era)
-> Map
     (KeyHash 'BlockIssuer (EraCrypto era))
     (VKey 'BlockIssuer (EraCrypto era))
shelleyBlockIssuerVKeys BlockConfig (ShelleyBlock era)
cfg

      -- | Premature optimisation: we assume everywhere that 'selectView' is
      -- cheap, so micro-optimise checking whether the issuer vkey is one of our
      -- own vkeys.
      --
      -- * Equality of vkeys takes roughly 40ns
      -- * Hashing a vkey takes roughly 850ns
      -- * Equality of hashes takes roughly 10ns
      --
      -- We want to avoid the hashing of a vkey as it is more expensive than
      -- simply doing a linear search, comparing vkeys for equality. Only when
      -- we have to do a linear search across a large number of vkeys does it
      -- become more efficient to first hash the vkey and look up its hash in
      -- the map.
      --
      -- We could try to be clever and estimate the number of keys after which
      -- we switch from a linear search to hashing + a O(log n) map lookup, but
      -- we keep it (relatively) simple and optimise for the common case: 0 or 1
      -- key.
      selfIssued :: SelfIssued
      selfIssued :: SelfIssued
selfIssued = case Map
  (KeyHash 'BlockIssuer (EraCrypto era))
  (VKey 'BlockIssuer (EraCrypto era))
-> Int
forall k a. Map k a -> Int
Map.size Map
  (KeyHash 'BlockIssuer (EraCrypto era))
  (VKey 'BlockIssuer (EraCrypto era))
issuerVKeys of
          -- The most common case: a non-block producing node
          Int
0 -> SelfIssued
NotSelfIssued
          -- A block producing node with a single set of credentials: just do an
          -- equality check of the single VKey, skipping the more expensive
          -- computation of the hash.
          Int
1 | BHBody (EraCrypto era) -> VKey 'BlockIssuer (EraCrypto era)
forall crypto. BHBody crypto -> VKey 'BlockIssuer crypto
SL.bheaderVk BHBody (EraCrypto era)
hdrBody VKey 'BlockIssuer (EraCrypto era)
-> Map
     (KeyHash 'BlockIssuer (EraCrypto era))
     (VKey 'BlockIssuer (EraCrypto era))
-> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Map
  (KeyHash 'BlockIssuer (EraCrypto era))
  (VKey 'BlockIssuer (EraCrypto era))
issuerVKeys
            -> SelfIssued
SelfIssued
            | Bool
otherwise
            -> SelfIssued
NotSelfIssued
          -- When we are running with multiple sets of credentials, which should
          -- only happen when benchmarking, do a hash lookup, as the number of
          -- keys can grow to 100-250.
          Int
_ | VKey 'BlockIssuer (EraCrypto era)
-> KeyHash 'BlockIssuer (EraCrypto era)
forall crypto (kd :: KeyRole).
Crypto crypto =>
VKey kd crypto -> KeyHash kd crypto
SL.hashKey (BHBody (EraCrypto era) -> VKey 'BlockIssuer (EraCrypto era)
forall crypto. BHBody crypto -> VKey 'BlockIssuer crypto
SL.bheaderVk BHBody (EraCrypto era)
hdrBody)
                KeyHash 'BlockIssuer (EraCrypto era)
-> Map
     (KeyHash 'BlockIssuer (EraCrypto era))
     (VKey 'BlockIssuer (EraCrypto era))
-> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` BlockConfig (ShelleyBlock era)
-> Map
     (KeyHash 'BlockIssuer (EraCrypto era))
     (VKey 'BlockIssuer (EraCrypto era))
forall era.
BlockConfig (ShelleyBlock era)
-> Map
     (KeyHash 'BlockIssuer (EraCrypto era))
     (VKey 'BlockIssuer (EraCrypto era))
shelleyBlockIssuerVKeys BlockConfig (ShelleyBlock era)
cfg
            -> SelfIssued
SelfIssued
            | Bool
otherwise
            -> SelfIssued
NotSelfIssued

-- TODO correct place for these two?
type instance Signed (Header (ShelleyBlock era)) = SL.BHBody (EraCrypto era)

instance ShelleyBasedEra era => SignedHeader (Header (ShelleyBlock era)) where
  headerSigned :: Header (ShelleyBlock era) -> Signed (Header (ShelleyBlock era))
headerSigned = BHeader (Crypto era) -> BHBody (Crypto era)
forall crypto. Crypto crypto => BHeader crypto -> BHBody crypto
SL.bhbody (BHeader (Crypto era) -> BHBody (Crypto era))
-> (Header (ShelleyBlock era) -> BHeader (Crypto era))
-> Header (ShelleyBlock era)
-> BHBody (Crypto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header (ShelleyBlock era) -> BHeader (Crypto era)
forall era. Header (ShelleyBlock era) -> BHeader (EraCrypto era)
shelleyHeaderRaw