{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

module Cardano.Chain.Byron.API.Common (
  -- * Extract info from genesis config
  allowedDelegators,

  -- * Extract info from chain state
  getDelegationMap,
  getProtocolParams,
  getMaxBlockSize,

  -- * Annotations
  reAnnotateBlock,
  reAnnotateBoundary,
  reAnnotateMagic,
  reAnnotateMagicId,
  reAnnotateUsing,

  -- * Headers
  abobMatchesBody,
)
where

import qualified Cardano.Chain.Block as CC
import qualified Cardano.Chain.Common as CC
import qualified Cardano.Chain.Delegation as Delegation
import qualified Cardano.Chain.Delegation.Validation.Interface as D.Iface
import qualified Cardano.Chain.Genesis as Gen
import qualified Cardano.Chain.Slotting as CC
import qualified Cardano.Chain.Update as Update
import qualified Cardano.Chain.Update.Validation.Interface as U.Iface
import Cardano.Crypto.ProtocolMagic
import Cardano.Ledger.Binary
import Cardano.Prelude
import qualified Codec.CBOR.Read as CBOR
import qualified Codec.CBOR.Write as CBOR
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.Text as T

{-------------------------------------------------------------------------------
  Extract info from genesis config
-------------------------------------------------------------------------------}

allowedDelegators :: Gen.Config -> Set CC.KeyHash
allowedDelegators :: Config -> Set KeyHash
allowedDelegators =
  GenesisKeyHashes -> Set KeyHash
Gen.unGenesisKeyHashes
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Config -> GenesisKeyHashes
Gen.configGenesisKeyHashes

{-------------------------------------------------------------------------------
  Extract info from chain state
-------------------------------------------------------------------------------}

getDelegationMap :: CC.ChainValidationState -> Delegation.Map
getDelegationMap :: ChainValidationState -> Map
getDelegationMap =
  State -> Map
D.Iface.delegationMap
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ChainValidationState -> State
CC.cvsDelegationState

getProtocolParams :: CC.ChainValidationState -> Update.ProtocolParameters
getProtocolParams :: ChainValidationState -> ProtocolParameters
getProtocolParams =
  State -> ProtocolParameters
U.Iface.adoptedProtocolParameters
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ChainValidationState -> State
CC.cvsUpdateState

getMaxBlockSize :: CC.ChainValidationState -> Word32
getMaxBlockSize :: ChainValidationState -> Word32
getMaxBlockSize =
  forall a b. (Integral a, Num b) => a -> b
fromIntegral
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ProtocolParameters -> Natural
Update.ppMaxBlockSize
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ChainValidationState -> ProtocolParameters
getProtocolParams

{-------------------------------------------------------------------------------
  Annotations
-------------------------------------------------------------------------------}

reAnnotateMagicId :: ProtocolMagicId -> Annotated ProtocolMagicId ByteString
reAnnotateMagicId :: ProtocolMagicId -> Annotated ProtocolMagicId ByteString
reAnnotateMagicId ProtocolMagicId
pmi = forall a b.
EncCBOR a =>
Version -> Annotated a b -> Annotated a ByteString
reAnnotate Version
byronProtVer forall a b. (a -> b) -> a -> b
$ forall b a. b -> a -> Annotated b a
Annotated ProtocolMagicId
pmi ()

reAnnotateMagic :: ProtocolMagic -> AProtocolMagic ByteString
reAnnotateMagic :: ProtocolMagic -> AProtocolMagic ByteString
reAnnotateMagic (AProtocolMagic Annotated ProtocolMagicId ()
a RequiresNetworkMagic
b) = forall a.
Annotated ProtocolMagicId a
-> RequiresNetworkMagic -> AProtocolMagic a
AProtocolMagic (forall a b.
EncCBOR a =>
Version -> Annotated a b -> Annotated a ByteString
reAnnotate Version
byronProtVer Annotated ProtocolMagicId ()
a) RequiresNetworkMagic
b

reAnnotateBlock :: CC.EpochSlots -> CC.ABlock () -> CC.ABlock ByteString
reAnnotateBlock :: EpochSlots -> ABlock () -> ABlock ByteString
reAnnotateBlock EpochSlots
epochSlots =
  forall (f :: * -> *) a.
Functor f =>
(f a -> Encoding)
-> (forall s. Decoder s (f ByteSpan)) -> f a -> f ByteString
reAnnotateUsing
    (EpochSlots -> ABlock () -> Encoding
CC.encCBORBlock EpochSlots
epochSlots)
    (forall s. EpochSlots -> Decoder s (ABlock ByteSpan)
CC.decCBORABlock EpochSlots
epochSlots)

reAnnotateBoundary ::
  ProtocolMagicId ->
  CC.ABoundaryBlock () ->
  CC.ABoundaryBlock ByteString
reAnnotateBoundary :: ProtocolMagicId -> ABoundaryBlock () -> ABoundaryBlock ByteString
reAnnotateBoundary ProtocolMagicId
pm =
  forall (f :: * -> *) a.
Functor f =>
(f a -> Encoding)
-> (forall s. Decoder s (f ByteSpan)) -> f a -> f ByteString
reAnnotateUsing
    (forall a. ProtocolMagicId -> ABoundaryBlock a -> Encoding
CC.encCBORABoundaryBlock ProtocolMagicId
pm)
    forall s. Decoder s (ABoundaryBlock ByteSpan)
CC.decCBORABoundaryBlock

-- | Generalization of 'reAnnotate'
reAnnotateUsing ::
  forall f a.
  Functor f =>
  (f a -> Encoding) ->
  (forall s. Decoder s (f ByteSpan)) ->
  f a ->
  f ByteString
reAnnotateUsing :: forall (f :: * -> *) a.
Functor f =>
(f a -> Encoding)
-> (forall s. Decoder s (f ByteSpan)) -> f a -> f ByteString
reAnnotateUsing f a -> Encoding
encoder forall s. Decoder s (f ByteSpan)
decoder =
  (\ByteString
bs -> forall err.
Show err =>
ByteString -> Either err (ByteString, f ByteSpan) -> f ByteString
splice ByteString
bs forall a b. (a -> b) -> a -> b
$ forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes (forall s a.
Maybe ByteString -> Version -> Decoder s a -> Decoder s a
toPlainDecoder (forall a. a -> Maybe a
Just ByteString
bs) Version
byronProtVer forall s. Decoder s (f ByteSpan)
decoder) ByteString
bs)
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Encoding -> ByteString
CBOR.toLazyByteString
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Version -> Encoding -> Encoding
toPlainEncoding Version
byronProtVer
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. f a -> Encoding
encoder
  where
    splice ::
      Show err =>
      Lazy.ByteString ->
      Either err (Lazy.ByteString, f ByteSpan) ->
      f ByteString
    splice :: forall err.
Show err =>
ByteString -> Either err (ByteString, f ByteSpan) -> f ByteString
splice ByteString
bs (Right (ByteString
left, f ByteSpan
fSpan))
      | ByteString -> Bool
Lazy.null ByteString
left = ByteString -> ByteString
Lazy.toStrict forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteSpan -> ByteString
slice ByteString
bs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f ByteSpan
fSpan
      | Bool
otherwise = forall x. Text -> x
roundtripFailure Text
"leftover bytes"
    splice ByteString
_ (Left err
err) = forall x. Text -> x
roundtripFailure forall a b. (a -> b) -> a -> b
$ forall a b. (Show a, ConvertText String b) => a -> b
show err
err

    roundtripFailure :: forall x. T.Text -> x
    roundtripFailure :: forall x. Text -> x
roundtripFailure Text
err =
      forall a. HasCallStack => Text -> a
panic
        forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate
          Text
": "
          [ Text
"annotateBoundary"
          , Text
"serialization roundtrip failure"
          , forall a b. (Show a, ConvertText String b) => a -> b
show Text
err
          ]

{-------------------------------------------------------------------------------
  Header of a regular block or EBB

  The ledger layer defines 'ABlockOrBoundary', but no equivalent for headers.
-------------------------------------------------------------------------------}

-- | Check if a block matches its header
--
-- For EBBs, we're currently being more permissive here and not performing any
-- header-body validation but only checking whether an EBB header and EBB block
-- were provided. This seems to be fine as it won't cause any loss of consensus
-- with the old `cardano-sl` nodes.
abobMatchesBody ::
  CC.ABlockOrBoundaryHdr ByteString ->
  CC.ABlockOrBoundary ByteString ->
  Bool
abobMatchesBody :: ABlockOrBoundaryHdr ByteString
-> ABlockOrBoundary ByteString -> Bool
abobMatchesBody ABlockOrBoundaryHdr ByteString
hdr ABlockOrBoundary ByteString
blk =
  case (ABlockOrBoundaryHdr ByteString
hdr, ABlockOrBoundary ByteString
blk) of
    (CC.ABOBBlockHdr AHeader ByteString
hdr', CC.ABOBBlock ABlock ByteString
blk') -> AHeader ByteString -> ABlock ByteString -> Bool
matchesBody AHeader ByteString
hdr' ABlock ByteString
blk'
    (CC.ABOBBoundaryHdr ABoundaryHeader ByteString
_, CC.ABOBBoundary ABoundaryBlock ByteString
_) -> Bool
True
    (CC.ABOBBlockHdr AHeader ByteString
_, CC.ABOBBoundary ABoundaryBlock ByteString
_) -> Bool
False
    (CC.ABOBBoundaryHdr ABoundaryHeader ByteString
_, CC.ABOBBlock ABlock ByteString
_) -> Bool
False
  where
    matchesBody :: CC.AHeader ByteString -> CC.ABlock ByteString -> Bool
    matchesBody :: AHeader ByteString -> ABlock ByteString -> Bool
matchesBody AHeader ByteString
hdr' ABlock ByteString
blk' =
      forall a b. Either a b -> Bool
isRight
        forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadError ProofValidationError m =>
AHeader ByteString -> ABody ByteString -> m ()
CC.validateHeaderMatchesBody AHeader ByteString
hdr' (forall a. ABlock a -> ABody a
CC.blockBody ABlock ByteString
blk')