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
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
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
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
maxMajorPV :: Version
maxMajorPV = Version
forall a. Bounded a => a
minBound
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
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
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
,
ledgerIx :: TxIx
Ledger.ledgerIx = TxIx
forall a. Bounded a => a
minBound
,
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
}