{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}

module Cardano.CLI.Shelley.Output
  ( PlutusScriptCostError
  , QueryKesPeriodInfoOutput (..)
  , QueryTipLocalState(..)
  , QueryTipLocalStateOutput(..)
  , ScriptCostOutput (..)
  , createOpCertIntervalInfo
  , renderScriptCosts
  ) where

import           Prelude

import           Cardano.Api
import           Cardano.Api.Shelley
import           Data.Aeson
import qualified Data.Aeson.Key as Aeson
import qualified Data.List as List
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Text (Text)
import qualified Data.Text as Text
import           Data.Time.Clock (UTCTime)
import           Data.Word

import           Cardano.CLI.Shelley.Orphans ()
import           Cardano.CLI.Types
import           Cardano.Ledger.Shelley.Scripts ()

data QueryKesPeriodInfoOutput =
  QueryKesPeriodInfoOutput
    { QueryKesPeriodInfoOutput -> OpCertIntervalInformation
qKesOpCertIntervalInformation :: OpCertIntervalInformation
      -- | Date of KES key expiry.
    , QueryKesPeriodInfoOutput -> Maybe UTCTime
qKesInfoKesKeyExpiry :: Maybe UTCTime
      -- | The latest operational certificate number in the node's state
      -- i.e how many times a new KES key has been generated.
    , QueryKesPeriodInfoOutput -> Maybe OpCertNodeStateCounter
qKesInfoNodeStateOperationalCertNo :: Maybe OpCertNodeStateCounter
      -- | The on disk operational certificate number.
    , QueryKesPeriodInfoOutput -> OpCertOnDiskCounter
qKesInfoOnDiskOperationalCertNo :: OpCertOnDiskCounter
      -- | The maximum number of KES key evolutions permitted per KES period.
    , QueryKesPeriodInfoOutput -> Word64
qKesInfoMaxKesKeyEvolutions :: Word64
    , QueryKesPeriodInfoOutput -> Word64
qKesInfoSlotsPerKesPeriod :: Word64
    } deriving (QueryKesPeriodInfoOutput -> QueryKesPeriodInfoOutput -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QueryKesPeriodInfoOutput -> QueryKesPeriodInfoOutput -> Bool
$c/= :: QueryKesPeriodInfoOutput -> QueryKesPeriodInfoOutput -> Bool
== :: QueryKesPeriodInfoOutput -> QueryKesPeriodInfoOutput -> Bool
$c== :: QueryKesPeriodInfoOutput -> QueryKesPeriodInfoOutput -> Bool
Eq, Int -> QueryKesPeriodInfoOutput -> ShowS
[QueryKesPeriodInfoOutput] -> ShowS
QueryKesPeriodInfoOutput -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QueryKesPeriodInfoOutput] -> ShowS
$cshowList :: [QueryKesPeriodInfoOutput] -> ShowS
show :: QueryKesPeriodInfoOutput -> String
$cshow :: QueryKesPeriodInfoOutput -> String
showsPrec :: Int -> QueryKesPeriodInfoOutput -> ShowS
$cshowsPrec :: Int -> QueryKesPeriodInfoOutput -> ShowS
Show)

instance ToJSON QueryKesPeriodInfoOutput where
  toJSON :: QueryKesPeriodInfoOutput -> Value
toJSON (QueryKesPeriodInfoOutput OpCertIntervalInformation
opCertIntervalInfo
                                   Maybe UTCTime
kesKeyExpiryTime
                                   Maybe OpCertNodeStateCounter
nodeStateOpCertNo
                                   (OpCertOnDiskCounter Word64
onDiskOpCertNo)
                                   Word64
maxKesKeyOps
                                   Word64
slotsPerKesPeriod) = do
    let (Word64
sKes, Word64
eKes, Word64
cKes, Maybe SlotsTillKesKeyExpiry
slotsTillExp) =
          case OpCertIntervalInformation
opCertIntervalInfo of
            OpCertWithinInterval OpCertStartingKesPeriod
startKes OpCertEndingKesPeriod
endKes CurrentKesPeriod
currKes SlotsTillKesKeyExpiry
sUntilExp ->
                     ( OpCertStartingKesPeriod -> Word64
unOpCertStartingKesPeriod OpCertStartingKesPeriod
startKes
                     , OpCertEndingKesPeriod -> Word64
unOpCertEndingKesPeriod OpCertEndingKesPeriod
endKes
                     , CurrentKesPeriod -> Word64
unCurrentKesPeriod CurrentKesPeriod
currKes
                     , forall a. a -> Maybe a
Just SlotsTillKesKeyExpiry
sUntilExp
                     )
            OpCertStartingKesPeriodIsInTheFuture OpCertStartingKesPeriod
startKes OpCertEndingKesPeriod
endKes CurrentKesPeriod
currKes ->
                     ( OpCertStartingKesPeriod -> Word64
unOpCertStartingKesPeriod OpCertStartingKesPeriod
startKes
                     , OpCertEndingKesPeriod -> Word64
unOpCertEndingKesPeriod OpCertEndingKesPeriod
endKes
                     , CurrentKesPeriod -> Word64
unCurrentKesPeriod CurrentKesPeriod
currKes
                     , forall a. Maybe a
Nothing
                     )
            OpCertExpired OpCertStartingKesPeriod
startKes OpCertEndingKesPeriod
endKes CurrentKesPeriod
currKes ->
                     ( OpCertStartingKesPeriod -> Word64
unOpCertStartingKesPeriod OpCertStartingKesPeriod
startKes
                     , OpCertEndingKesPeriod -> Word64
unOpCertEndingKesPeriod OpCertEndingKesPeriod
endKes
                     , CurrentKesPeriod -> Word64
unCurrentKesPeriod CurrentKesPeriod
currKes
                     , forall a. Maybe a
Nothing
                     )
            OpCertSomeOtherError OpCertStartingKesPeriod
startKes OpCertEndingKesPeriod
endKes CurrentKesPeriod
currKes ->
                     ( OpCertStartingKesPeriod -> Word64
unOpCertStartingKesPeriod OpCertStartingKesPeriod
startKes
                     , OpCertEndingKesPeriod -> Word64
unOpCertEndingKesPeriod OpCertEndingKesPeriod
endKes
                     , CurrentKesPeriod -> Word64
unCurrentKesPeriod CurrentKesPeriod
currKes
                     , forall a. Maybe a
Nothing
                     )

    [Pair] -> Value
object [ Key
"qKesCurrentKesPeriod" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64
cKes
           , Key
"qKesStartKesInterval" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64
sKes
           , Key
"qKesEndKesInterval" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64
eKes
           , Key
"qKesRemainingSlotsInKesPeriod" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe SlotsTillKesKeyExpiry
slotsTillExp
           , Key
"qKesOnDiskOperationalCertificateNumber" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64
onDiskOpCertNo
           , Key
"qKesNodeStateOperationalCertificateNumber" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=  Maybe OpCertNodeStateCounter
nodeStateOpCertNo
           , Key
"qKesMaxKESEvolutions" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64
maxKesKeyOps
           , Key
"qKesSlotsPerKesPeriod" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64
slotsPerKesPeriod
           , Key
"qKesKesKeyExpiry" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe UTCTime
kesKeyExpiryTime
           ]

instance FromJSON QueryKesPeriodInfoOutput where
  parseJSON :: Value -> Parser QueryKesPeriodInfoOutput
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"QueryKesPeriodInfoOutput" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    CurrentKesPeriod
currentKesPeriod <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"qKesCurrentKesPeriod"
    OpCertStartingKesPeriod
startKesInterval <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"qKesStartKesInterval"
    OpCertEndingKesPeriod
endKesInterval <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"qKesEndKesInterval"
    Maybe SlotsTillKesKeyExpiry
remainingSlotsInKesPeriod <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"qKesRemainingSlotsInKesPeriod"
    OpCertOnDiskCounter
onDiskOperationalCertificateNumber <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"qKesOnDiskOperationalCertificateNumber"
    Maybe OpCertNodeStateCounter
nodeStateOperationalCertificateNumber <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"qKesNodeStateOperationalCertificateNumber"
    Word64
maxKESEvolutions <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"qKesMaxKESEvolutions"
    Word64
slotsPerKesPeriod <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"qKesSlotsPerKesPeriod"
    Maybe UTCTime
kesKeyExpiry <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"qKesKesKeyExpiry"
    let opCertIntervalInfo :: OpCertIntervalInformation
opCertIntervalInfo = CurrentKesPeriod
-> OpCertStartingKesPeriod
-> OpCertEndingKesPeriod
-> Maybe SlotsTillKesKeyExpiry
-> OpCertIntervalInformation
createOpCertIntervalInfo
                               CurrentKesPeriod
currentKesPeriod
                               OpCertStartingKesPeriod
startKesInterval
                               OpCertEndingKesPeriod
endKesInterval
                               Maybe SlotsTillKesKeyExpiry
remainingSlotsInKesPeriod
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ QueryKesPeriodInfoOutput
         { $sel:qKesOpCertIntervalInformation:QueryKesPeriodInfoOutput :: OpCertIntervalInformation
qKesOpCertIntervalInformation = OpCertIntervalInformation
opCertIntervalInfo
         , $sel:qKesInfoKesKeyExpiry:QueryKesPeriodInfoOutput :: Maybe UTCTime
qKesInfoKesKeyExpiry = Maybe UTCTime
kesKeyExpiry
         , $sel:qKesInfoNodeStateOperationalCertNo:QueryKesPeriodInfoOutput :: Maybe OpCertNodeStateCounter
qKesInfoNodeStateOperationalCertNo = Maybe OpCertNodeStateCounter
nodeStateOperationalCertificateNumber
         , $sel:qKesInfoOnDiskOperationalCertNo:QueryKesPeriodInfoOutput :: OpCertOnDiskCounter
qKesInfoOnDiskOperationalCertNo = OpCertOnDiskCounter
onDiskOperationalCertificateNumber
         , $sel:qKesInfoMaxKesKeyEvolutions:QueryKesPeriodInfoOutput :: Word64
qKesInfoMaxKesKeyEvolutions = Word64
maxKESEvolutions
         , $sel:qKesInfoSlotsPerKesPeriod:QueryKesPeriodInfoOutput :: Word64
qKesInfoSlotsPerKesPeriod = Word64
slotsPerKesPeriod
         }


createOpCertIntervalInfo
  :: CurrentKesPeriod
  -> OpCertStartingKesPeriod
  -> OpCertEndingKesPeriod
  -> Maybe SlotsTillKesKeyExpiry
  -> OpCertIntervalInformation
createOpCertIntervalInfo :: CurrentKesPeriod
-> OpCertStartingKesPeriod
-> OpCertEndingKesPeriod
-> Maybe SlotsTillKesKeyExpiry
-> OpCertIntervalInformation
createOpCertIntervalInfo c :: CurrentKesPeriod
c@(CurrentKesPeriod Word64
cKesPeriod)
                         s :: OpCertStartingKesPeriod
s@(OpCertStartingKesPeriod Word64
oCertStart)
                         e :: OpCertEndingKesPeriod
e@(OpCertEndingKesPeriod Word64
oCertEnd)
                         (Just SlotsTillKesKeyExpiry
tillExp)
  | Word64
oCertStart forall a. Ord a => a -> a -> Bool
<= Word64
cKesPeriod Bool -> Bool -> Bool
&& Word64
cKesPeriod forall a. Ord a => a -> a -> Bool
< Word64
oCertEnd =
      OpCertStartingKesPeriod
-> OpCertEndingKesPeriod
-> CurrentKesPeriod
-> SlotsTillKesKeyExpiry
-> OpCertIntervalInformation
OpCertWithinInterval OpCertStartingKesPeriod
s OpCertEndingKesPeriod
e CurrentKesPeriod
c SlotsTillKesKeyExpiry
tillExp
  | Word64
oCertStart forall a. Ord a => a -> a -> Bool
> Word64
cKesPeriod = OpCertStartingKesPeriod
-> OpCertEndingKesPeriod
-> CurrentKesPeriod
-> OpCertIntervalInformation
OpCertStartingKesPeriodIsInTheFuture OpCertStartingKesPeriod
s OpCertEndingKesPeriod
e CurrentKesPeriod
c
  | Word64
cKesPeriod forall a. Ord a => a -> a -> Bool
>= Word64
oCertEnd = OpCertStartingKesPeriod
-> OpCertEndingKesPeriod
-> CurrentKesPeriod
-> OpCertIntervalInformation
OpCertExpired OpCertStartingKesPeriod
s OpCertEndingKesPeriod
e CurrentKesPeriod
c
  | Bool
otherwise = OpCertStartingKesPeriod
-> OpCertEndingKesPeriod
-> CurrentKesPeriod
-> OpCertIntervalInformation
OpCertSomeOtherError OpCertStartingKesPeriod
s OpCertEndingKesPeriod
e CurrentKesPeriod
c
createOpCertIntervalInfo c :: CurrentKesPeriod
c@(CurrentKesPeriod Word64
cKesPeriod)
                         s :: OpCertStartingKesPeriod
s@(OpCertStartingKesPeriod Word64
oCertStart)
                         e :: OpCertEndingKesPeriod
e@(OpCertEndingKesPeriod Word64
oCertEnd)
                         Maybe SlotsTillKesKeyExpiry
Nothing
  | Word64
oCertStart forall a. Ord a => a -> a -> Bool
> Word64
cKesPeriod = OpCertStartingKesPeriod
-> OpCertEndingKesPeriod
-> CurrentKesPeriod
-> OpCertIntervalInformation
OpCertStartingKesPeriodIsInTheFuture OpCertStartingKesPeriod
s OpCertEndingKesPeriod
e CurrentKesPeriod
c
  | Word64
cKesPeriod forall a. Ord a => a -> a -> Bool
>= Word64
oCertEnd = OpCertStartingKesPeriod
-> OpCertEndingKesPeriod
-> CurrentKesPeriod
-> OpCertIntervalInformation
OpCertExpired OpCertStartingKesPeriod
s OpCertEndingKesPeriod
e CurrentKesPeriod
c
  | Bool
otherwise = OpCertStartingKesPeriod
-> OpCertEndingKesPeriod
-> CurrentKesPeriod
-> OpCertIntervalInformation
OpCertSomeOtherError OpCertStartingKesPeriod
s OpCertEndingKesPeriod
e CurrentKesPeriod
c


data QueryTipLocalState mode = QueryTipLocalState
  { forall mode. QueryTipLocalState mode -> AnyCardanoEra
era :: AnyCardanoEra
  , forall mode. QueryTipLocalState mode -> EraHistory CardanoMode
eraHistory :: EraHistory CardanoMode
  , forall mode. QueryTipLocalState mode -> Maybe SystemStart
mSystemStart :: Maybe SystemStart
  , forall mode. QueryTipLocalState mode -> Maybe ChainTip
mChainTip :: Maybe ChainTip
  }

data QueryTipLocalStateOutput = QueryTipLocalStateOutput
  { QueryTipLocalStateOutput -> ChainTip
localStateChainTip :: ChainTip
  , QueryTipLocalStateOutput -> Maybe AnyCardanoEra
mEra :: Maybe AnyCardanoEra
  , QueryTipLocalStateOutput -> Maybe EpochNo
mEpoch :: Maybe EpochNo
  , QueryTipLocalStateOutput -> Maybe Word64
mSlotInEpoch :: Maybe Word64
  , QueryTipLocalStateOutput -> Maybe Word64
mSlotsToEpochEnd :: Maybe Word64
  , QueryTipLocalStateOutput -> Maybe Text
mSyncProgress :: Maybe Text
  } deriving Int -> QueryTipLocalStateOutput -> ShowS
[QueryTipLocalStateOutput] -> ShowS
QueryTipLocalStateOutput -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QueryTipLocalStateOutput] -> ShowS
$cshowList :: [QueryTipLocalStateOutput] -> ShowS
show :: QueryTipLocalStateOutput -> String
$cshow :: QueryTipLocalStateOutput -> String
showsPrec :: Int -> QueryTipLocalStateOutput -> ShowS
$cshowsPrec :: Int -> QueryTipLocalStateOutput -> ShowS
Show

-- | A key-value pair difference list for encoding a JSON object.
(..=) :: (KeyValue kv, ToJSON v) => Aeson.Key -> v -> [kv] -> [kv]
..= :: forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> [kv] -> [kv]
(..=) Key
n v
v = (Key
n forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= v
vforall a. a -> [a] -> [a]
:)

-- | A key-value pair difference list for encoding a JSON object where Nothing encodes absence of the key-value pair.
(..=?) :: (KeyValue kv, ToJSON v) => Aeson.Key -> Maybe v -> [kv] -> [kv]
..=? :: forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
(..=?) Key
n Maybe v
mv = case Maybe v
mv of
  Just v
v -> (Key
n forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= v
vforall a. a -> [a] -> [a]
:)
  Maybe v
Nothing -> forall a. a -> a
id

instance ToJSON QueryTipLocalStateOutput where
  toJSON :: QueryTipLocalStateOutput -> Value
toJSON QueryTipLocalStateOutput
a = case QueryTipLocalStateOutput -> ChainTip
localStateChainTip QueryTipLocalStateOutput
a of
    ChainTip
ChainTipAtGenesis ->
      [Pair] -> Value
object forall a b. (a -> b) -> a -> b
$
        ( (Key
"era" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe AnyCardanoEra
mEra QueryTipLocalStateOutput
a)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"epoch" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe EpochNo
mEpoch QueryTipLocalStateOutput
a)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"slotInEpoch" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe Word64
mSlotInEpoch QueryTipLocalStateOutput
a)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"slotsToEpochEnd" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe Word64
mSlotsToEpochEnd QueryTipLocalStateOutput
a)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"syncProgress" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe Text
mSyncProgress QueryTipLocalStateOutput
a)
        ) []
    ChainTip SlotNo
slotNo Hash BlockHeader
blockHeader BlockNo
blockNo ->
      [Pair] -> Value
object forall a b. (a -> b) -> a -> b
$
        ( (Key
"slot" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> [kv] -> [kv]
..= SlotNo
slotNo)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"hash" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> [kv] -> [kv]
..= forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText Hash BlockHeader
blockHeader)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"block" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> [kv] -> [kv]
..= BlockNo
blockNo)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"era" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe AnyCardanoEra
mEra QueryTipLocalStateOutput
a)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"epoch" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe EpochNo
mEpoch QueryTipLocalStateOutput
a)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"slotInEpoch" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe Word64
mSlotInEpoch QueryTipLocalStateOutput
a)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"slotsToEpochEnd" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe Word64
mSlotsToEpochEnd QueryTipLocalStateOutput
a)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"syncProgress" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe Text
mSyncProgress QueryTipLocalStateOutput
a)
        ) []
  toEncoding :: QueryTipLocalStateOutput -> Encoding
toEncoding QueryTipLocalStateOutput
a = case QueryTipLocalStateOutput -> ChainTip
localStateChainTip QueryTipLocalStateOutput
a of
    ChainTip
ChainTipAtGenesis ->
      Series -> Encoding
pairs forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
        ( (Key
"era" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe AnyCardanoEra
mEra QueryTipLocalStateOutput
a)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"epoch" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe EpochNo
mEpoch QueryTipLocalStateOutput
a)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"slotInEpoch" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe Word64
mSlotInEpoch QueryTipLocalStateOutput
a)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"slotsToEpochEnd" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe Word64
mSlotsToEpochEnd QueryTipLocalStateOutput
a)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"syncProgress" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe Text
mSyncProgress QueryTipLocalStateOutput
a)
        ) []
    ChainTip SlotNo
slotNo Hash BlockHeader
blockHeader BlockNo
blockNo ->
      Series -> Encoding
pairs forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
        ( (Key
"slot" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> [kv] -> [kv]
..= SlotNo
slotNo)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"hash" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> [kv] -> [kv]
..= forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText Hash BlockHeader
blockHeader)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"block" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> [kv] -> [kv]
..= BlockNo
blockNo)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"era" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe AnyCardanoEra
mEra QueryTipLocalStateOutput
a)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"epoch" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe EpochNo
mEpoch QueryTipLocalStateOutput
a)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"slotInEpoch" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe Word64
mSlotInEpoch QueryTipLocalStateOutput
a)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"slotsToEpochEnd" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe Word64
mSlotsToEpochEnd QueryTipLocalStateOutput
a)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"syncProgress" forall kv v.
(KeyValue kv, ToJSON v) =>
Key -> Maybe v -> [kv] -> [kv]
..=? QueryTipLocalStateOutput -> Maybe Text
mSyncProgress QueryTipLocalStateOutput
a)
        ) []

instance FromJSON QueryTipLocalStateOutput where
  parseJSON :: Value -> Parser QueryTipLocalStateOutput
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"QueryTipLocalStateOutput" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Maybe AnyCardanoEra
mEra' <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"era"
    Maybe EpochNo
mEpoch' <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"epoch"
    Maybe Text
mSyncProgress' <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"syncProgress"

    Maybe SlotNo
mSlot <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"slot"
    Maybe (Hash BlockHeader)
mHash <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"hash"
    Maybe BlockNo
mBlock <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"block"
    Maybe Word64
mSlotInEpoch' <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"slotInEpoch"
    Maybe Word64
mSlotsToEpochEnd' <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"slotsToEpochEnd"
    case (Maybe SlotNo
mSlot, Maybe (Hash BlockHeader)
mHash, Maybe BlockNo
mBlock) of
      (Maybe SlotNo
Nothing, Maybe (Hash BlockHeader)
Nothing, Maybe BlockNo
Nothing) ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ChainTip
-> Maybe AnyCardanoEra
-> Maybe EpochNo
-> Maybe Word64
-> Maybe Word64
-> Maybe Text
-> QueryTipLocalStateOutput
QueryTipLocalStateOutput
                 ChainTip
ChainTipAtGenesis
                 Maybe AnyCardanoEra
mEra'
                 Maybe EpochNo
mEpoch'
                 Maybe Word64
mSlotInEpoch'
                 Maybe Word64
mSlotsToEpochEnd'
                 Maybe Text
mSyncProgress'
      (Just SlotNo
slot, Just Hash BlockHeader
hash, Just BlockNo
block) ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ChainTip
-> Maybe AnyCardanoEra
-> Maybe EpochNo
-> Maybe Word64
-> Maybe Word64
-> Maybe Text
-> QueryTipLocalStateOutput
QueryTipLocalStateOutput
                 (SlotNo -> Hash BlockHeader -> BlockNo -> ChainTip
ChainTip SlotNo
slot Hash BlockHeader
hash BlockNo
block)
                 Maybe AnyCardanoEra
mEra'
                 Maybe EpochNo
mEpoch'
                 Maybe Word64
mSlotInEpoch'
                 Maybe Word64
mSlotsToEpochEnd'
                 Maybe Text
mSyncProgress'
      (Maybe SlotNo
_,Maybe (Hash BlockHeader)
_,Maybe BlockNo
_) ->
        forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
          [ String
"QueryTipLocalStateOutput was incorrectly JSON encoded."
          , String
" Expected slot, header hash and block number (ChainTip)"
          , String
" or none (ChainTipAtGenesis)"
          ]

data ScriptCostOutput =
  ScriptCostOutput
    { ScriptCostOutput -> ScriptHash
scScriptHash :: ScriptHash
    , ScriptCostOutput -> ExecutionUnits
scExecutionUnits :: ExecutionUnits
    , ScriptCostOutput -> Lovelace
scAda :: Lovelace
    }

instance ToJSON ScriptCostOutput where
  toJSON :: ScriptCostOutput -> Value
toJSON (ScriptCostOutput ScriptHash
sHash ExecutionUnits
execUnits Lovelace
llCost) =
    [Pair] -> Value
object [ Key
"scriptHash" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ScriptHash
sHash
           , Key
"executionUnits" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ExecutionUnits
execUnits
           , Key
"lovelaceCost" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Lovelace
llCost
           ]

data PlutusScriptCostError
  = PlutusScriptCostErrPlutusScriptNotFound ScriptWitnessIndex
  | PlutusScriptCostErrExecError ScriptWitnessIndex (Maybe ScriptHash) ScriptExecutionError
  | PlutusScriptCostErrRationalExceedsBound ExecutionUnitPrices  ExecutionUnits
  | PlutusScriptCostErrRefInputNoScript TxIn
  | PlutusScriptCostErrRefInputNotInUTxO TxIn
  deriving Int -> PlutusScriptCostError -> ShowS
[PlutusScriptCostError] -> ShowS
PlutusScriptCostError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PlutusScriptCostError] -> ShowS
$cshowList :: [PlutusScriptCostError] -> ShowS
show :: PlutusScriptCostError -> String
$cshow :: PlutusScriptCostError -> String
showsPrec :: Int -> PlutusScriptCostError -> ShowS
$cshowsPrec :: Int -> PlutusScriptCostError -> ShowS
Show


instance Error PlutusScriptCostError where
  displayError :: PlutusScriptCostError -> String
displayError (PlutusScriptCostErrPlutusScriptNotFound ScriptWitnessIndex
sWitIndex) =
    String
"No Plutus script was found at: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ScriptWitnessIndex
sWitIndex
  displayError (PlutusScriptCostErrExecError ScriptWitnessIndex
sWitIndex Maybe ScriptHash
sHash ScriptExecutionError
sExecErro) =
    String
"Plutus script at: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ScriptWitnessIndex
sWitIndex forall a. Semigroup a => a -> a -> a
<> String
" with hash: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Maybe ScriptHash
sHash forall a. Semigroup a => a -> a -> a
<>
    String
" errored with: " forall a. Semigroup a => a -> a -> a
<> forall e. Error e => e -> String
displayError ScriptExecutionError
sExecErro
  displayError (PlutusScriptCostErrRationalExceedsBound ExecutionUnitPrices
eUnitPrices ExecutionUnits
eUnits) =
    String
"Either the execution unit prices: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ExecutionUnitPrices
eUnitPrices forall a. Semigroup a => a -> a -> a
<> String
" or the execution units: " forall a. Semigroup a => a -> a -> a
<>
    forall a. Show a => a -> String
show ExecutionUnits
eUnits forall a. Semigroup a => a -> a -> a
<> String
" or both are either too precise or not within bounds"
  displayError (PlutusScriptCostErrRefInputNoScript TxIn
txin) =
    String
"No reference script found at input: " forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (TxIn -> Text
renderTxIn TxIn
txin)
  displayError (PlutusScriptCostErrRefInputNotInUTxO TxIn
txin) =
    String
"Reference input was not found in utxo: " forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (TxIn -> Text
renderTxIn TxIn
txin)

renderScriptCosts
  :: UTxO era
  -> ExecutionUnitPrices
  -> [(ScriptWitnessIndex, AnyScriptWitness era)]
  -- ^ Initial mapping of script witness index to actual script.
  -- We need this in order to know which script corresponds to the
  -- calculated execution units.
  -> Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
  -- ^ Post execution cost calculation mapping of script witness
  -- index to execution units.
  -> Either PlutusScriptCostError [ScriptCostOutput]
renderScriptCosts :: forall era.
UTxO era
-> ExecutionUnitPrices
-> [(ScriptWitnessIndex, AnyScriptWitness era)]
-> Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
-> Either PlutusScriptCostError [ScriptCostOutput]
renderScriptCosts (UTxO Map TxIn (TxOut CtxUTxO era)
utxo) ExecutionUnitPrices
eUnitPrices [(ScriptWitnessIndex, AnyScriptWitness era)]
scriptMapping Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
executionCostMapping =
  forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA forall a b. (a -> b) -> a -> b
$ forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey
    (\[Either PlutusScriptCostError ScriptCostOutput]
accum ScriptWitnessIndex
sWitInd Either ScriptExecutionError ExecutionUnits
eExecUnits -> do
      case forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup ScriptWitnessIndex
sWitInd [(ScriptWitnessIndex, AnyScriptWitness era)]
scriptMapping of
        Just (AnyScriptWitness SimpleScriptWitness{}) -> [Either PlutusScriptCostError ScriptCostOutput]
accum

        Just (AnyScriptWitness (PlutusScriptWitness ScriptLanguageInEra lang era
_ PlutusScriptVersion lang
pVer (PScript PlutusScript lang
pScript) ScriptDatum witctx
_ ScriptRedeemer
_ ExecutionUnits
_)) -> do
          let scriptHash :: ScriptHash
scriptHash = forall lang. Script lang -> ScriptHash
hashScript forall a b. (a -> b) -> a -> b
$ forall lang.
PlutusScriptVersion lang -> PlutusScript lang -> Script lang
PlutusScript PlutusScriptVersion lang
pVer PlutusScript lang
pScript
          case Either ScriptExecutionError ExecutionUnits
eExecUnits of
            Right ExecutionUnits
execUnits ->
              case ExecutionUnitPrices -> ExecutionUnits -> Maybe Lovelace
calculateExecutionUnitsLovelace ExecutionUnitPrices
eUnitPrices ExecutionUnits
execUnits of
                Just Lovelace
llCost ->
                  forall a b. b -> Either a b
Right (ScriptHash -> ExecutionUnits -> Lovelace -> ScriptCostOutput
ScriptCostOutput ScriptHash
scriptHash ExecutionUnits
execUnits Lovelace
llCost)
                    forall a. a -> [a] -> [a]
: [Either PlutusScriptCostError ScriptCostOutput]
accum
                Maybe Lovelace
Nothing ->
                  forall a b. a -> Either a b
Left (ExecutionUnitPrices -> ExecutionUnits -> PlutusScriptCostError
PlutusScriptCostErrRationalExceedsBound ExecutionUnitPrices
eUnitPrices ExecutionUnits
execUnits)
                    forall a. a -> [a] -> [a]
: [Either PlutusScriptCostError ScriptCostOutput]
accum
            Left ScriptExecutionError
err -> forall a b. a -> Either a b
Left (ScriptWitnessIndex
-> Maybe ScriptHash
-> ScriptExecutionError
-> PlutusScriptCostError
PlutusScriptCostErrExecError ScriptWitnessIndex
sWitInd (forall a. a -> Maybe a
Just ScriptHash
scriptHash) ScriptExecutionError
err) forall a. a -> [a] -> [a]
: [Either PlutusScriptCostError ScriptCostOutput]
accum
        -- TODO: Create a new sum type to encapsulate the fact that we can also
        -- have a txin and render the txin in the case of reference scripts.
        Just (AnyScriptWitness (PlutusScriptWitness ScriptLanguageInEra lang era
_ PlutusScriptVersion lang
_ (PReferenceScript TxIn
refTxIn Maybe ScriptHash
_) ScriptDatum witctx
_ ScriptRedeemer
_ ExecutionUnits
_)) ->
          case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
refTxIn Map TxIn (TxOut CtxUTxO era)
utxo of
            Maybe (TxOut CtxUTxO era)
Nothing -> forall a b. a -> Either a b
Left (TxIn -> PlutusScriptCostError
PlutusScriptCostErrRefInputNotInUTxO TxIn
refTxIn) forall a. a -> [a] -> [a]
: [Either PlutusScriptCostError ScriptCostOutput]
accum
            Just (TxOut AddressInEra era
_ TxOutValue era
_ TxOutDatum CtxUTxO era
_ ReferenceScript era
refScript) ->
              case ReferenceScript era
refScript of
                ReferenceScript era
ReferenceScriptNone -> forall a b. a -> Either a b
Left (TxIn -> PlutusScriptCostError
PlutusScriptCostErrRefInputNoScript TxIn
refTxIn) forall a. a -> [a] -> [a]
: [Either PlutusScriptCostError ScriptCostOutput]
accum
                ReferenceScript ReferenceTxInsScriptsInlineDatumsSupportedInEra era
_ (ScriptInAnyLang ScriptLanguage lang
_ Script lang
script) ->
                  case Either ScriptExecutionError ExecutionUnits
eExecUnits of
                    Right ExecutionUnits
execUnits ->
                      case ExecutionUnitPrices -> ExecutionUnits -> Maybe Lovelace
calculateExecutionUnitsLovelace ExecutionUnitPrices
eUnitPrices ExecutionUnits
execUnits of
                        Just Lovelace
llCost ->
                          forall a b. b -> Either a b
Right (ScriptHash -> ExecutionUnits -> Lovelace -> ScriptCostOutput
ScriptCostOutput (forall lang. Script lang -> ScriptHash
hashScript Script lang
script) ExecutionUnits
execUnits Lovelace
llCost)
                            forall a. a -> [a] -> [a]
: [Either PlutusScriptCostError ScriptCostOutput]
accum
                        Maybe Lovelace
Nothing ->
                          forall a b. a -> Either a b
Left (ExecutionUnitPrices -> ExecutionUnits -> PlutusScriptCostError
PlutusScriptCostErrRationalExceedsBound ExecutionUnitPrices
eUnitPrices ExecutionUnits
execUnits)
                            forall a. a -> [a] -> [a]
: [Either PlutusScriptCostError ScriptCostOutput]
accum
                    Left ScriptExecutionError
err -> forall a b. a -> Either a b
Left (ScriptWitnessIndex
-> Maybe ScriptHash
-> ScriptExecutionError
-> PlutusScriptCostError
PlutusScriptCostErrExecError ScriptWitnessIndex
sWitInd forall a. Maybe a
Nothing ScriptExecutionError
err) forall a. a -> [a] -> [a]
: [Either PlutusScriptCostError ScriptCostOutput]
accum


        Maybe (AnyScriptWitness era)
Nothing -> forall a b. a -> Either a b
Left (ScriptWitnessIndex -> PlutusScriptCostError
PlutusScriptCostErrPlutusScriptNotFound ScriptWitnessIndex
sWitInd) forall a. a -> [a] -> [a]
: [Either PlutusScriptCostError ScriptCostOutput]
accum

    ) [] Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
executionCostMapping