module Hydra.Ledger.Cardano.Configuration (
  module Hydra.Ledger.Cardano.Configuration,
  Ledger.Globals,
  Ledger.LedgerEnv,
) where

import Hydra.Cardano.Api
import Hydra.Prelude

import Cardano.Ledger.Api (PParams)
import Cardano.Ledger.BaseTypes (Globals (..), boundRational, mkActiveSlotCoeff)
import Cardano.Ledger.BaseTypes qualified as Ledger
import Cardano.Ledger.Shelley.API (computeRandomnessStabilisationWindow, computeStabilityWindow)
import Cardano.Ledger.Shelley.API.Types qualified as Ledger
import Cardano.Slotting.EpochInfo (fixedEpochInfo)
import Cardano.Slotting.Time (mkSlotLength)
import Data.Aeson qualified as Json
import Data.Aeson.Types qualified as Json

-- * Helpers

readJsonFileThrow :: (Json.Value -> Json.Parser a) -> FilePath -> IO a
readJsonFileThrow :: forall a. (Value -> Parser a) -> FilePath -> IO a
readJsonFileThrow Value -> Parser a
parser FilePath
filepath = do
  Value
value <- FilePath -> IO (Either FilePath Value)
forall a. FromJSON a => FilePath -> IO (Either FilePath a)
Json.eitherDecodeFileStrict FilePath
filepath IO (Either FilePath Value)
-> (Either FilePath Value -> IO Value) -> IO Value
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> IO Value)
-> (Value -> IO Value) -> Either FilePath Value -> IO Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> IO Value
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail Value -> IO Value
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  case (Value -> Parser a) -> Value -> Either FilePath a
forall a b. (a -> Parser b) -> a -> Either FilePath b
Json.parseEither Value -> Parser a
parser Value
value of
    Left FilePath
e -> FilePath -> IO a
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
e
    Right a
a -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

-- * Globals

data GlobalsTranslationException = GlobalsTranslationException
  deriving stock (GlobalsTranslationException -> GlobalsTranslationException -> Bool
(GlobalsTranslationException
 -> GlobalsTranslationException -> Bool)
-> (GlobalsTranslationException
    -> GlobalsTranslationException -> Bool)
-> Eq GlobalsTranslationException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GlobalsTranslationException -> GlobalsTranslationException -> Bool
== :: GlobalsTranslationException -> GlobalsTranslationException -> Bool
$c/= :: GlobalsTranslationException -> GlobalsTranslationException -> Bool
/= :: GlobalsTranslationException -> GlobalsTranslationException -> Bool
Eq, Int -> GlobalsTranslationException -> ShowS
[GlobalsTranslationException] -> ShowS
GlobalsTranslationException -> FilePath
(Int -> GlobalsTranslationException -> ShowS)
-> (GlobalsTranslationException -> FilePath)
-> ([GlobalsTranslationException] -> ShowS)
-> Show GlobalsTranslationException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GlobalsTranslationException -> ShowS
showsPrec :: Int -> GlobalsTranslationException -> ShowS
$cshow :: GlobalsTranslationException -> FilePath
show :: GlobalsTranslationException -> FilePath
$cshowList :: [GlobalsTranslationException] -> ShowS
showList :: [GlobalsTranslationException] -> ShowS
Show)

instance Exception GlobalsTranslationException

-- | Create new L2 ledger 'Globals' from 'GenesisParameters'.
--
-- Throws at least 'GlobalsTranslationException'
newGlobals :: MonadThrow m => GenesisParameters ShelleyEra -> m Globals
newGlobals :: forall (m :: * -> *).
MonadThrow m =>
GenesisParameters ShelleyEra -> m Globals
newGlobals GenesisParameters ShelleyEra
genesisParameters = do
  case PositiveUnitInterval -> ActiveSlotCoeff
mkActiveSlotCoeff (PositiveUnitInterval -> ActiveSlotCoeff)
-> Maybe PositiveUnitInterval -> Maybe ActiveSlotCoeff
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Maybe PositiveUnitInterval
forall r. BoundedRational r => Rational -> Maybe r
boundRational Rational
protocolParamActiveSlotsCoefficient of
    Maybe ActiveSlotCoeff
Nothing -> GlobalsTranslationException -> m Globals
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO GlobalsTranslationException
GlobalsTranslationException
    Just ActiveSlotCoeff
slotCoeff -> do
      let k :: Word64
k = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
protocolParamSecurity
      Globals -> m Globals
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Globals -> m Globals) -> Globals -> m Globals
forall a b. (a -> b) -> a -> b
$
        Globals
          { activeSlotCoeff :: ActiveSlotCoeff
activeSlotCoeff = ActiveSlotCoeff
slotCoeff
          , EpochInfo (Either Text)
epochInfo :: EpochInfo (Either Text)
epochInfo :: EpochInfo (Either Text)
epochInfo
          , maxKESEvo :: Word64
maxKESEvo = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
protocolParamMaxKESEvolutions
          , maxLovelaceSupply :: Word64
maxLovelaceSupply = Coin -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Coin
protocolParamMaxLovelaceSupply
          , Version
maxMajorPV :: Version
maxMajorPV :: Version
maxMajorPV
          , networkId :: Network
networkId = NetworkId -> Network
toShelleyNetwork NetworkId
protocolParamNetworkId
          , quorum :: Word64
quorum = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
protocolParamUpdateQuorum
          , randomnessStabilisationWindow :: Word64
randomnessStabilisationWindow = Word64 -> ActiveSlotCoeff -> Word64
computeRandomnessStabilisationWindow Word64
k ActiveSlotCoeff
slotCoeff
          , securityParameter :: Word64
securityParameter = Word64
k
          , slotsPerKESPeriod :: Word64
slotsPerKESPeriod = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
protocolParamSlotsPerKESPeriod
          , stabilityWindow :: Word64
stabilityWindow = Word64 -> ActiveSlotCoeff -> Word64
computeStabilityWindow Word64
k ActiveSlotCoeff
slotCoeff
          , systemStart :: SystemStart
systemStart = UTCTime -> SystemStart
SystemStart UTCTime
protocolParamSystemStart
          }
 where
  GenesisParameters
    { Int
protocolParamSlotsPerKESPeriod :: Int
protocolParamSlotsPerKESPeriod :: forall era. GenesisParameters era -> Int
protocolParamSlotsPerKESPeriod
    , Int
protocolParamUpdateQuorum :: Int
protocolParamUpdateQuorum :: forall era. GenesisParameters era -> Int
protocolParamUpdateQuorum
    , Coin
protocolParamMaxLovelaceSupply :: Coin
protocolParamMaxLovelaceSupply :: forall era. GenesisParameters era -> Coin
protocolParamMaxLovelaceSupply
    , Int
protocolParamSecurity :: Int
protocolParamSecurity :: forall era. GenesisParameters era -> Int
protocolParamSecurity
    , Rational
protocolParamActiveSlotsCoefficient :: Rational
protocolParamActiveSlotsCoefficient :: forall era. GenesisParameters era -> Rational
protocolParamActiveSlotsCoefficient
    , UTCTime
protocolParamSystemStart :: UTCTime
protocolParamSystemStart :: forall era. GenesisParameters era -> UTCTime
protocolParamSystemStart
    , NetworkId
protocolParamNetworkId :: NetworkId
protocolParamNetworkId :: forall era. GenesisParameters era -> NetworkId
protocolParamNetworkId
    , Int
protocolParamMaxKESEvolutions :: Int
protocolParamMaxKESEvolutions :: forall era. GenesisParameters era -> Int
protocolParamMaxKESEvolutions
    , EpochSize
protocolParamEpochLength :: EpochSize
protocolParamEpochLength :: forall era. GenesisParameters era -> EpochSize
protocolParamEpochLength
    , NominalDiffTime
protocolParamSlotLength :: NominalDiffTime
protocolParamSlotLength :: forall era. GenesisParameters era -> NominalDiffTime
protocolParamSlotLength
    } = GenesisParameters ShelleyEra
genesisParameters
  -- NOTE: This is used by the ledger to discard blocks that have a version
  -- beyond a known limit. Or said differently, unused and irrelevant for Hydra.
  maxMajorPV :: Version
maxMajorPV = Version
forall a. Bounded a => a
minBound
  -- NOTE: uses fixed epoch info for our L2 ledger
  epochInfo :: EpochInfo (Either Text)
epochInfo = EpochSize -> SlotLength -> EpochInfo (Either Text)
forall (m :: * -> *).
Monad m =>
EpochSize -> SlotLength -> EpochInfo m
fixedEpochInfo EpochSize
protocolParamEpochLength SlotLength
slotLength
  slotLength :: SlotLength
slotLength = NominalDiffTime -> SlotLength
mkSlotLength NominalDiffTime
protocolParamSlotLength

-- * LedgerEnv

-- | Decode protocol parameters using the 'ProtocolParameters' instance as this
-- is used by cardano-cli and matches the schema. TODO: define the schema
pparamsFromJson :: Json.Value -> Json.Parser (PParams LedgerEra)
pparamsFromJson :: Value -> Parser (PParams LedgerEra)
pparamsFromJson = Value -> Parser (PParams LedgerEra)
Value -> Parser (PParams StandardBabbage)
forall a. FromJSON a => Value -> Parser a
parseJSON

-- | Create a new ledger env from given protocol parameters.
newLedgerEnv :: PParams LedgerEra -> Ledger.LedgerEnv LedgerEra
newLedgerEnv :: PParams LedgerEra -> LedgerEnv LedgerEra
newLedgerEnv PParams LedgerEra
protocolParams =
  Ledger.LedgerEnv
    { ledgerSlotNo :: SlotNo
Ledger.ledgerSlotNo = Word64 -> SlotNo
SlotNo Word64
0
    , -- NOTE: This can probably stay at 0 forever. This is used internally by the
      -- node's mempool to keep track of transaction seen from peers. Transactions
      -- in Hydra do not go through the node's mempool and follow a different
      -- consensus path so this will remain unused.
      ledgerIx :: TxIx
Ledger.ledgerIx = TxIx
forall a. Bounded a => a
minBound
    , -- NOTE: This keeps track of the ledger's treasury and reserve which are
      -- both unused in Hydra. There might be room for interesting features in the
      -- future with these two but for now, we'll consider them empty.
      ledgerAccount :: AccountState
Ledger.ledgerAccount = Coin -> Coin -> AccountState
Ledger.AccountState Coin
forall a. Monoid a => a
mempty Coin
forall a. Monoid a => a
mempty
    , ledgerPp :: PParams StandardBabbage
Ledger.ledgerPp = PParams LedgerEra
PParams StandardBabbage
protocolParams
    }