{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# 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 Cardano.Binary
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.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
    (GenesisKeyHashes -> Set KeyHash)
-> (Config -> GenesisKeyHashes) -> Config -> Set KeyHash
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
    (State -> Map)
-> (ChainValidationState -> State) -> ChainValidationState -> Map
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
    (State -> ProtocolParameters)
-> (ChainValidationState -> State)
-> ChainValidationState
-> ProtocolParameters
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 =
  Natural -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    (Natural -> Word32)
-> (ChainValidationState -> Natural)
-> ChainValidationState
-> Word32
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
    (ProtocolParameters -> Natural)
-> (ChainValidationState -> ProtocolParameters)
-> ChainValidationState
-> Natural
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 = Annotated ProtocolMagicId ()
-> Annotated ProtocolMagicId ByteString
forall a b. ToCBOR a => Annotated a b -> Annotated a ByteString
reAnnotate (Annotated ProtocolMagicId ()
 -> Annotated ProtocolMagicId ByteString)
-> Annotated ProtocolMagicId ()
-> Annotated ProtocolMagicId ByteString
forall a b. (a -> b) -> a -> b
$ ProtocolMagicId -> () -> Annotated ProtocolMagicId ()
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) = Annotated ProtocolMagicId ByteString
-> RequiresNetworkMagic -> AProtocolMagic ByteString
forall a.
Annotated ProtocolMagicId a
-> RequiresNetworkMagic -> AProtocolMagic a
AProtocolMagic (Annotated ProtocolMagicId ()
-> Annotated ProtocolMagicId ByteString
forall a b. ToCBOR a => Annotated a b -> Annotated a ByteString
reAnnotate Annotated ProtocolMagicId ()
a) RequiresNetworkMagic
b

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

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

-- | Generalization of 'reAnnotate'
reAnnotateUsing ::
  forall f a.
  Functor f =>
  (f a -> Encoding) ->
  (forall s. Decoder s (f ByteSpan)) ->
  f a ->
  f ByteString
reAnnotateUsing :: (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 -> ByteString
-> Either DeserialiseFailure (ByteString, f ByteSpan)
-> f ByteString
forall err.
Show err =>
ByteString -> Either err (ByteString, f ByteSpan) -> f ByteString
splice ByteString
bs (Either DeserialiseFailure (ByteString, f ByteSpan)
 -> f ByteString)
-> Either DeserialiseFailure (ByteString, f ByteSpan)
-> f ByteString
forall a b. (a -> b) -> a -> b
$ (forall s. Decoder s (f ByteSpan))
-> ByteString -> Either DeserialiseFailure (ByteString, f ByteSpan)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes forall s. Decoder s (f ByteSpan)
decoder ByteString
bs)
    (ByteString -> f ByteString)
-> (f a -> ByteString) -> f a -> f ByteString
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
    (Encoding -> ByteString) -> (f a -> Encoding) -> f a -> ByteString
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 :: 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 (ByteString -> ByteString)
-> (ByteSpan -> ByteString) -> ByteSpan -> ByteString
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) (ByteSpan -> ByteString) -> f ByteSpan -> f ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f ByteSpan
fSpan
      | Bool
otherwise = Text -> f ByteString
forall x. Text -> x
roundtripFailure Text
"leftover bytes"
    splice ByteString
_ (Left err
err) = Text -> f ByteString
forall x. Text -> x
roundtripFailure (Text -> f ByteString) -> Text -> f ByteString
forall a b. (a -> b) -> a -> b
$ err -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show err
err

    roundtripFailure :: forall x. T.Text -> x
    roundtripFailure :: Text -> x
roundtripFailure Text
err =
      Text -> x
forall a. HasCallStack => Text -> a
panic (Text -> x) -> Text -> x
forall a b. (a -> b) -> a -> b
$
        Text -> [Text] -> Text
T.intercalate Text
": " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
          [ Text
"annotateBoundary",
            Text
"serialization roundtrip failure",
            Text -> Text
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' =
      Either ProofValidationError () -> Bool
forall a b. Either a b -> Bool
isRight (Either ProofValidationError () -> Bool)
-> Either ProofValidationError () -> Bool
forall a b. (a -> b) -> a -> b
$
        AHeader ByteString
-> ABody ByteString -> Either ProofValidationError ()
forall (m :: * -> *).
MonadError ProofValidationError m =>
AHeader ByteString -> ABody ByteString -> m ()
CC.validateHeaderMatchesBody AHeader ByteString
hdr' (ABlock ByteString -> ABody ByteString
forall a. ABlock a -> ABody a
CC.blockBody ABlock ByteString
blk')