{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Tools.DBAnalyser.Block.Byron (
    Args (..)
  , ByronBlockArgs
  , openGenesisByron
  ) where

import qualified Cardano.Chain.Block as Chain
import qualified Cardano.Chain.Genesis as Genesis
import qualified Cardano.Chain.Update as Update
import qualified Cardano.Chain.UTxO as Chain
import           Cardano.Crypto (RequiresNetworkMagic (..))
import qualified Cardano.Crypto as Crypto
import           Cardano.Crypto.Raw (Raw)
import           Cardano.Ledger.Binary (unAnnotated)
import           Cardano.Tools.DBAnalyser.HasAnalysis
import           Control.Monad.Except
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BL
import           Ouroboros.Consensus.Byron.Ledger (ByronBlock)
import qualified Ouroboros.Consensus.Byron.Ledger as Byron
import           Ouroboros.Consensus.Byron.Node (PBftSignatureThreshold (..),
                     ProtocolParamsByron (..), protocolInfoByron)
import           Ouroboros.Consensus.Node.ProtocolInfo
import           Text.Builder (decimal)

instance HasAnalysis ByronBlock where
    countTxOutputs :: ByronBlock -> Int
countTxOutputs = (ABoundaryBlock ByteString -> Int)
-> (ABlock ByteString -> Int) -> ByronBlock -> Int
forall a.
(ABoundaryBlock ByteString -> a)
-> (ABlock ByteString -> a) -> ByronBlock -> a
aBlockOrBoundary (Int -> ABoundaryBlock ByteString -> Int
forall a b. a -> b -> a
const Int
0) ABlock ByteString -> Int
countTxOutputsByron
    blockTxSizes :: ByronBlock -> [SizeInBytes]
blockTxSizes = (ABoundaryBlock ByteString -> [SizeInBytes])
-> (ABlock ByteString -> [SizeInBytes])
-> ByronBlock
-> [SizeInBytes]
forall a.
(ABoundaryBlock ByteString -> a)
-> (ABlock ByteString -> a) -> ByronBlock -> a
aBlockOrBoundary ([SizeInBytes] -> ABoundaryBlock ByteString -> [SizeInBytes]
forall a b. a -> b -> a
const []) ABlock ByteString -> [SizeInBytes]
blockTxSizesByron
    knownEBBs :: forall (proxy :: * -> *).
proxy ByronBlock
-> Map (HeaderHash ByronBlock) (ChainHash ByronBlock)
knownEBBs = Map ByronHash (ChainHash ByronBlock)
-> proxy ByronBlock -> Map ByronHash (ChainHash ByronBlock)
forall a b. a -> b -> a
const Map (HeaderHash ByronBlock) (ChainHash ByronBlock)
Map ByronHash (ChainHash ByronBlock)
Byron.knownEBBs
    emitTraces :: WithLedgerState ByronBlock -> [String]
emitTraces WithLedgerState ByronBlock
_ = []
    blockStats :: ByronBlock -> [Builder]
blockStats ByronBlock
blk = [ Int -> Builder
forall a. Integral a => a -> Builder
decimal (Int -> Builder) -> Int -> Builder
forall a b. (a -> b) -> a -> b
$ [SizeInBytes] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([SizeInBytes] -> Int) -> [SizeInBytes] -> Int
forall a b. (a -> b) -> a -> b
$ ByronBlock -> [SizeInBytes]
forall blk. HasAnalysis blk => blk -> [SizeInBytes]
blockTxSizes ByronBlock
blk
                     , SizeInBytes -> Builder
forall a. Integral a => a -> Builder
decimal (SizeInBytes -> Builder) -> SizeInBytes -> Builder
forall a b. (a -> b) -> a -> b
$ [SizeInBytes] -> SizeInBytes
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([SizeInBytes] -> SizeInBytes) -> [SizeInBytes] -> SizeInBytes
forall a b. (a -> b) -> a -> b
$ ByronBlock -> [SizeInBytes]
forall blk. HasAnalysis blk => blk -> [SizeInBytes]
blockTxSizes ByronBlock
blk
                     ]
    -- For the time being we do not support any block application
    -- metrics for the Byron era only.
    blockApplicationMetrics :: [(Builder, WithLedgerState ByronBlock -> IO Builder)]
blockApplicationMetrics = []

instance HasProtocolInfo ByronBlock where
    data Args ByronBlock =
      ByronBlockArgs {
          Args ByronBlock -> String
configFile           :: FilePath
        , Args ByronBlock -> RequiresNetworkMagic
requiresNetworkMagic :: RequiresNetworkMagic
        , Args ByronBlock -> Maybe (Hash Raw)
genesisHash          :: Maybe (Crypto.Hash Raw)
        , Args ByronBlock -> Maybe PBftSignatureThreshold
threshold            :: Maybe PBftSignatureThreshold
        }
    mkProtocolInfo :: Args ByronBlock -> IO (ProtocolInfo ByronBlock)
mkProtocolInfo Args ByronBlock
args = do
      Config
config <- String -> Maybe (Hash Raw) -> RequiresNetworkMagic -> IO Config
openGenesisByron (Args ByronBlock -> String
configFile Args ByronBlock
args) (Args ByronBlock -> Maybe (Hash Raw)
genesisHash Args ByronBlock
args) (Args ByronBlock -> RequiresNetworkMagic
requiresNetworkMagic Args ByronBlock
args)
      ProtocolInfo ByronBlock -> IO (ProtocolInfo ByronBlock)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProtocolInfo ByronBlock -> IO (ProtocolInfo ByronBlock))
-> ProtocolInfo ByronBlock -> IO (ProtocolInfo ByronBlock)
forall a b. (a -> b) -> a -> b
$ Config -> Maybe PBftSignatureThreshold -> ProtocolInfo ByronBlock
mkByronProtocolInfo Config
config (Args ByronBlock -> Maybe PBftSignatureThreshold
threshold Args ByronBlock
args)

type ByronBlockArgs = Args ByronBlock

-- | Equivalent of 'either' for 'ABlockOrBoundary'.
aBlockOrBoundary :: (Chain.ABoundaryBlock ByteString -> a)
                 -> (Chain.ABlock ByteString -> a)
                 -> ByronBlock -> a
aBlockOrBoundary :: forall a.
(ABoundaryBlock ByteString -> a)
-> (ABlock ByteString -> a) -> ByronBlock -> a
aBlockOrBoundary ABoundaryBlock ByteString -> a
fromBoundary ABlock ByteString -> a
fromRegular ByronBlock
blk = case ByronBlock
blk of
    Byron.ByronBlock (Chain.ABOBBoundary ABoundaryBlock ByteString
boundaryBlock) SlotNo
_ ByronHash
_
      -> ABoundaryBlock ByteString -> a
fromBoundary ABoundaryBlock ByteString
boundaryBlock
    Byron.ByronBlock (Chain.ABOBBlock ABlock ByteString
regularBlk) SlotNo
_ ByronHash
_
      -> ABlock ByteString -> a
fromRegular ABlock ByteString
regularBlk

countTxOutputsByron :: Chain.ABlock ByteString -> Int
countTxOutputsByron :: ABlock ByteString -> Int
countTxOutputsByron Chain.ABlock{ ABody ByteString
blockBody :: ABody ByteString
blockBody :: forall a. ABlock a -> ABody a
Chain.blockBody } = ATxPayload ByteString -> Int
forall a. ATxPayload a -> Int
countTxPayload ATxPayload ByteString
bodyTxPayload
  where
    Chain.ABody{ ATxPayload ByteString
bodyTxPayload :: ATxPayload ByteString
bodyTxPayload :: forall a. ABody a -> ATxPayload a
Chain.bodyTxPayload } = ABody ByteString
blockBody

    countTxPayload :: Chain.ATxPayload a -> Int
    countTxPayload :: forall a. ATxPayload a -> Int
countTxPayload = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
                   ([Int] -> Int) -> (ATxPayload a -> [Int]) -> ATxPayload a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ATxAux a -> Int) -> [ATxAux a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Tx -> Int
countTx (Tx -> Int) -> (ATxAux a -> Tx) -> ATxAux a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotated Tx a -> Tx
forall b a. Annotated b a -> b
unAnnotated (Annotated Tx a -> Tx)
-> (ATxAux a -> Annotated Tx a) -> ATxAux a -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ATxAux a -> Annotated Tx a
forall a. ATxAux a -> Annotated Tx a
Chain.aTaTx)
                   ([ATxAux a] -> [Int])
-> (ATxPayload a -> [ATxAux a]) -> ATxPayload a -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ATxPayload a -> [ATxAux a]
forall a. ATxPayload a -> [ATxAux a]
Chain.aUnTxPayload

    countTx :: Chain.Tx -> Int
    countTx :: Tx -> Int
countTx = NonEmpty TxOut -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (NonEmpty TxOut -> Int) -> (Tx -> NonEmpty TxOut) -> Tx -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> NonEmpty TxOut
Chain.txOutputs

blockTxSizesByron :: Chain.ABlock ByteString -> [SizeInBytes]
blockTxSizesByron :: ABlock ByteString -> [SizeInBytes]
blockTxSizesByron ABlock ByteString
block =
    (ATxAux ByteString -> SizeInBytes)
-> [ATxAux ByteString] -> [SizeInBytes]
forall a b. (a -> b) -> [a] -> [b]
map (Int64 -> SizeInBytes
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> SizeInBytes)
-> (ATxAux ByteString -> Int64) -> ATxAux ByteString -> SizeInBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length (ByteString -> Int64)
-> (ATxAux ByteString -> ByteString) -> ATxAux ByteString -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString)
-> (ATxAux ByteString -> ByteString)
-> ATxAux ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ATxAux ByteString -> ByteString
forall a. ATxAux a -> a
Chain.aTaAnnotation) [ATxAux ByteString]
blockTxAuxs
  where
    Chain.ABlock{ ABody ByteString
blockBody :: forall a. ABlock a -> ABody a
blockBody :: ABody ByteString
Chain.blockBody } = ABlock ByteString
block
    Chain.ABody{ ATxPayload ByteString
bodyTxPayload :: forall a. ABody a -> ATxPayload a
bodyTxPayload :: ATxPayload ByteString
Chain.bodyTxPayload } = ABody ByteString
blockBody
    Chain.ATxPayload{ aUnTxPayload :: forall a. ATxPayload a -> [ATxAux a]
Chain.aUnTxPayload = [ATxAux ByteString]
blockTxAuxs } = ATxPayload ByteString
bodyTxPayload

openGenesisByron ::
     FilePath
  -> Maybe (Crypto.Hash Raw)
  -> RequiresNetworkMagic
  -> IO Genesis.Config
openGenesisByron :: String -> Maybe (Hash Raw) -> RequiresNetworkMagic -> IO Config
openGenesisByron String
configFile Maybe (Hash Raw)
mHash RequiresNetworkMagic
requiresNetworkMagic = do
    Hash Raw
genesisHash <- case Maybe (Hash Raw)
mHash of
      Maybe (Hash Raw)
Nothing -> (GenesisDataError -> IO (Hash Raw))
-> (Hash Raw -> IO (Hash Raw))
-> Either GenesisDataError (Hash Raw)
-> IO (Hash Raw)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO (Hash Raw)
forall a. HasCallStack => String -> a
error (String -> IO (Hash Raw))
-> (GenesisDataError -> String)
-> GenesisDataError
-> IO (Hash Raw)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenesisDataError -> String
forall a. Show a => a -> String
show) Hash Raw -> IO (Hash Raw)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either GenesisDataError (Hash Raw) -> IO (Hash Raw))
-> IO (Either GenesisDataError (Hash Raw)) -> IO (Hash Raw)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT GenesisDataError IO (Hash Raw)
-> IO (Either GenesisDataError (Hash Raw))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
        (GenesisHash -> Hash Raw
Genesis.unGenesisHash (GenesisHash -> Hash Raw)
-> ((GenesisData, GenesisHash) -> GenesisHash)
-> (GenesisData, GenesisHash)
-> Hash Raw
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenesisData, GenesisHash) -> GenesisHash
forall a b. (a, b) -> b
snd ((GenesisData, GenesisHash) -> Hash Raw)
-> ExceptT GenesisDataError IO (GenesisData, GenesisHash)
-> ExceptT GenesisDataError IO (Hash Raw)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ExceptT GenesisDataError IO (GenesisData, GenesisHash)
forall (m :: * -> *).
(MonadError GenesisDataError m, MonadIO m) =>
String -> m (GenesisData, GenesisHash)
Genesis.readGenesisData String
configFile)
      Just Hash Raw
hash -> Hash Raw -> IO (Hash Raw)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Hash Raw
hash
    Config
genesisConfig <- (ConfigurationError -> IO Config)
-> (Config -> IO Config)
-> Either ConfigurationError Config
-> IO Config
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO Config
forall a. HasCallStack => String -> a
error (String -> IO Config)
-> (ConfigurationError -> String)
-> ConfigurationError
-> IO Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigurationError -> String
forall a. Show a => a -> String
show) Config -> IO Config
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ConfigurationError Config -> IO Config)
-> IO (Either ConfigurationError Config) -> IO Config
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT ConfigurationError IO Config
-> IO (Either ConfigurationError Config)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
      (RequiresNetworkMagic
-> String -> Hash Raw -> ExceptT ConfigurationError IO Config
forall (m :: * -> *).
(MonadError ConfigurationError m, MonadIO m) =>
RequiresNetworkMagic -> String -> Hash Raw -> m Config
Genesis.mkConfigFromFile
        RequiresNetworkMagic
requiresNetworkMagic
        String
configFile
        Hash Raw
genesisHash)
    Config -> IO Config
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Config
genesisConfig

mkByronProtocolInfo :: Genesis.Config
                    -> Maybe PBftSignatureThreshold
                    -> ProtocolInfo ByronBlock
mkByronProtocolInfo :: Config -> Maybe PBftSignatureThreshold -> ProtocolInfo ByronBlock
mkByronProtocolInfo Config
genesisConfig Maybe PBftSignatureThreshold
signatureThreshold =
    ProtocolParamsByron -> ProtocolInfo ByronBlock
protocolInfoByron (ProtocolParamsByron -> ProtocolInfo ByronBlock)
-> ProtocolParamsByron -> ProtocolInfo ByronBlock
forall a b. (a -> b) -> a -> b
$ ProtocolParamsByron {
        $sel:byronGenesis:ProtocolParamsByron :: Config
byronGenesis                = Config
genesisConfig
      , $sel:byronPbftSignatureThreshold:ProtocolParamsByron :: Maybe PBftSignatureThreshold
byronPbftSignatureThreshold = Maybe PBftSignatureThreshold
signatureThreshold
      , $sel:byronProtocolVersion:ProtocolParamsByron :: ProtocolVersion
byronProtocolVersion        = Word16 -> Word16 -> Word8 -> ProtocolVersion
Update.ProtocolVersion Word16
1 Word16
0 Word8
0
      , $sel:byronSoftwareVersion:ProtocolParamsByron :: SoftwareVersion
byronSoftwareVersion        = ApplicationName -> NumSoftwareVersion -> SoftwareVersion
Update.SoftwareVersion (Text -> ApplicationName
Update.ApplicationName Text
"db-analyser") NumSoftwareVersion
2
      , $sel:byronLeaderCredentials:ProtocolParamsByron :: Maybe ByronLeaderCredentials
byronLeaderCredentials      = Maybe ByronLeaderCredentials
forall a. Maybe a
Nothing
      }