Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Updated to the most recent Alonzo specification #2095

Merged
merged 1 commit into from
Jan 18, 2021
Merged

Updated to the most recent Alonzo specification #2095

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
4 changes: 3 additions & 1 deletion alonzo/impl/cardano-ledger-alonzo.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -38,7 +38,8 @@ library
deepseq,
nothunks,
shelley-spec-ledger,
small-steps
small-steps,
text
hs-source-dirs:
src
ghc-options:
Expand Down Expand Up @@ -86,6 +87,7 @@ test-suite tests
Test.Cardano.Ledger.Alonzo.Serialisation.Tripping
build-depends:
base >=4.14 && <4.15,
base16-bytestring,
bytestring,
cardano-binary,
cardano-ledger-alonzo,
Expand Down
67 changes: 50 additions & 17 deletions alonzo/impl/src/Cardano/Ledger/Alonzo/Data.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,37 +1,82 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}

module Cardano.Ledger.Alonzo.Data
( Data (..),
( PlutusData (..),
-- Figure 2 (partial list)
Data (Data, ..),
EraIndependentData,
DataHash (..),
hashData,
)
where

import Cardano.Binary (FromCBOR (..), ToCBOR (..))
import Cardano.Binary (FromCBOR (..), ToCBOR (..), decodeInt, encodeInt)
import qualified Cardano.Crypto.Hash as Hash
import Cardano.Ledger.Crypto (HASH)
import qualified Cardano.Ledger.Crypto as CC
import Cardano.Ledger.Era (Crypto, Era)
import Control.DeepSeq (NFData)
import Data.Coders
import Data.MemoBytes (Mem, MemoBytes (..), memoBytes)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import Shelley.Spec.Ledger.Hashing (HashAnnotated (..))

-- | TODO this should be isomorphic to the plutus (alonzo version) type
data Data era = NotReallyData
deriving (Eq, Ord, Generic, Show)
-- =====================================================================
-- PlutusData is a placeholder for the type that Plutus expects as data.

data PlutusData = NotReallyData
deriving (Eq, Show, Ord, Generic)

instance NoThunks PlutusData

-- | TODO appropriate serialisation for the Real Plutus Data
instance ToCBOR (PlutusData) where
toCBOR _ = encodeInt 0

instance FromCBOR (PlutusData) where
fromCBOR = do
i <- decodeInt
case i of
0 -> pure NotReallyData
_ -> fail "oh no"

instance FromCBOR (Annotator PlutusData) where
fromCBOR = pure <$> fromCBOR

-- ============================================================================
-- the newtype Data is a wrapper around the type that Plutus expects as data.
-- The newtype will memoize the serialized bytes. The strategy is to replace
-- PlutusData with the correct type

newtype Data era = DataConstr (MemoBytes (PlutusData))
deriving (Eq, Ord, Generic, ToCBOR, Show)

deriving via
(Mem PlutusData)
instance
(Era era) =>
FromCBOR (Annotator (Data era))

instance NoThunks (Data era)

pattern Data :: PlutusData -> Data era
pattern Data p <-
DataConstr (Memo p _)
where
Data p = DataConstr (memoBytes (To p))

-- =============================================================================

data EraIndependentData

newtype DataHash crypto
Expand All @@ -53,15 +98,3 @@ hashData = DataHash . hashAnnotated
--------------------------------------------------------------------------------
-- Serialisation
--------------------------------------------------------------------------------

-- | TODO appropriate serialisation
instance Era era => ToCBOR (Data era) where
toCBOR = encode . encodeData
where
encodeData NotReallyData = Sum NotReallyData 0

instance Era era => FromCBOR (Data era) where
fromCBOR = decode $ Summands "Data" decodeData
where
decodeData 0 = SumD NotReallyData
decodeData n = Invalid n
101 changes: 69 additions & 32 deletions alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -3,10 +3,14 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
Expand All @@ -24,30 +28,41 @@ module Cardano.Ledger.Alonzo.PParams
PParamsUpdate,
emptyPParamsUpdate,
updatePParams,
hashLanguagePP,
)
where

import Cardano.Binary
( FromCBOR (..),
( Annotator,
Decoder,
FromCBOR (..),
ToCBOR (..),
decodeWord,
encodeListLen,
encodeMapLen,
encodeWord,
)
import qualified Cardano.Crypto.Hash as Hash
import Cardano.Ledger.Alonzo.Scripts (CostModel, ExUnits (..), Language, Prices (..))
import Cardano.Ledger.Alonzo.Scripts
( CostModel,
ExUnits (..),
Language,
Prices (..),
hashCostModel,
)
import Cardano.Ledger.Crypto (HASH)
import qualified Cardano.Ledger.Crypto as CC
import Cardano.Ledger.Era
import Control.DeepSeq (NFData)
import Control.Monad (unless)
import Data.Coders (Decode (..), decode, (<*!))
import Data.Foldable (fold)
import Data.Functor.Identity (Identity)
import Data.List (nub)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Proxy
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
import Numeric.Natural (Natural)
Expand All @@ -67,14 +82,15 @@ import Shelley.Spec.Ledger.Serialization
( FromCBORGroup (..),
ToCBORGroup (..),
decodeMapContents,
decodeRecordNamed,
decodeMapTraverse,
mapFromCBOR,
mapToCBOR,
ratioFromCBOR,
ratioToCBOR,
)
import Shelley.Spec.Ledger.Slot (EpochNo (..))

-- ================================================================
TimSheard marked this conversation as resolved.
Show resolved Hide resolved
-- TODO
-- make type families for PParams and PParamsUpdate
-- what is the encodeListLen ??
Expand Down Expand Up @@ -193,33 +209,42 @@ instance (Era era) => ToCBOR (PParams era) where
<> toCBOR maxTxExUnits'
<> toCBOR maxBlockExUnits'

instance (Era era) => FromCBOR (PParams era) where
fromCBOR = do
decodeRecordNamed "PParams" (const 22) $
PParams
<$> fromCBOR -- _minfeeA :: Integer
<*> fromCBOR -- _minfeeB :: Natural
<*> fromCBOR -- _maxBBSize :: Natural
<*> fromCBOR -- _maxTxSize :: Natural
<*> fromCBOR -- _maxBHSize :: Natural
<*> fromCBOR -- _keyDeposit :: Coin
<*> fromCBOR -- _poolDeposit :: Coin
<*> fromCBOR -- _eMax :: EpochNo
<*> fromCBOR -- _nOpt :: Natural
<*> ratioFromCBOR -- _a0 :: Rational
<*> fromCBOR -- _rho :: UnitInterval
<*> fromCBOR -- _tau :: UnitInterval
<*> fromCBOR -- _d :: UnitInterval
<*> fromCBOR -- _extraEntropy :: Nonce
<*> fromCBORGroup -- _protocolVersion :: ProtVer
<*> fromCBOR -- _minPoolCost :: Natural
instance
(Era era) =>
FromCBOR (Annotator (PParams era))
where
fromCBOR =
decode $
Ann (RecD PParams)
<*! Ann From -- _minfeeA :: Integer
<*! Ann From -- _minfeeB :: Natural
<*! Ann From -- _maxBBSize :: Natural
<*! Ann From -- _maxTxSize :: Natural
<*! Ann From -- _maxBHSize :: Natural
<*! Ann From -- _keyDeposit :: Coin
<*! Ann From -- _poolDeposit :: Coin
<*! Ann From -- _eMax :: EpochNo
<*! Ann From -- _nOpt :: Natural
<*! Ann (D ratioFromCBOR) -- _a0 :: Rational
<*! Ann From -- _rho :: UnitInterval
<*! Ann From -- _tau :: UnitInterval
<*! Ann From -- _d :: UnitInterval
<*! Ann From -- _extraEntropy :: Nonce
<*! Ann (D fromCBORGroup) -- _protocolVersion :: ProtVer
<*! Ann From -- _minPoolCost :: Natural
-- new/updated for alonzo
-- TODO what should all these really be?
<*> fromCBOR -- _adaPerUTxOByte ::
<*> fromCBOR -- _costmdls = costmdls',
<*> fromCBOR -- _prices = prices',
<*> fromCBOR -- _maxTxExUnits = maxTxExUnits',
<*> fromCBOR -- _maxBlockExUnits = maxBlockExUnits'
<*! Ann From -- _adaPerUTxOByte ::
<*! D (splitMapFromCBOR fromCBOR fromCBOR) -- _costmdls = costmdls',
<*! Ann From -- _prices = prices',
<*! Ann From -- _maxTxExUnits = maxTxExUnits',
<*! Ann From -- _maxBlockExUnits = maxBlockExUnits'

splitMapFromCBOR ::
Ord dom =>
Decoder s dom ->
Decoder s (Annotator rng) ->
Decoder s (Annotator (Map dom rng))
splitMapFromCBOR a b = decodeMapTraverse (pure <$> a) b

-- | Returns a basic "empty" `PParams` structure with all zero values.
emptyPParams :: PParams era
Expand Down Expand Up @@ -342,7 +367,8 @@ instance (Era era) => FromCBOR (PParamsUpdate era) where
15 -> fromCBOR >>= \x -> pure (15, \up -> up {_minPoolCost = SJust x})
-- new/updated for alonzo
16 -> fromCBOR >>= \x -> pure (15, \up -> up {_adaPerUTxOByte = SJust x})
17 -> fromCBOR >>= \x -> pure (15, \up -> up {_costmdls = SJust x})
-- THIS STUB WILL HAVE to be adjusted since CostModel only has FromCBOR(Annotator _) instance
-- 17 -> fromCBOR >>= \x -> pure (15, \up -> up {_costmdls = SJust x})
18 -> fromCBOR >>= \x -> pure (15, \up -> up {_prices = SJust x})
19 -> fromCBOR >>= \x -> pure (15, \up -> up {_maxTxExUnits = SJust x})
20 -> fromCBOR >>= \x -> pure (15, \up -> up {_maxBlockExUnits = SJust x})
Expand Down Expand Up @@ -401,15 +427,26 @@ updatePParams pp ppup =
fromMaybe' :: a -> StrictMaybe a -> a
fromMaybe' x = fromMaybe x . strictMaybeToMaybe

data EraIndependentPP
-- ===================================================
-- Figure 1: "Definitions Used in Protocol Parameters"
TimSheard marked this conversation as resolved.
Show resolved Hide resolved

-- Hash of a subset of Protocol Parameters relevant to Plutus script evaluation
newtype PPHash crypto
= PPHash
(Hash.Hash (HASH crypto) EraIndependentPP)
(Hash.Hash (HASH crypto) CostModel)
deriving (Show, Eq, Ord, Generic)
deriving newtype (NFData, NoThunks)

deriving newtype instance CC.Crypto crypto => FromCBOR (PPHash crypto)

deriving newtype instance CC.Crypto crypto => ToCBOR (PPHash crypto)

hashLanguagePP :: forall era. Era era => PParams era -> Language -> PPHash (Crypto era)
hashLanguagePP pp lang = PPHash (hashCostModel (Proxy @era) cm)
where
cm :: CostModel
cm = case Map.lookup lang (_costmdls pp) of
Just x -> x
Nothing -> error ("CostModel map does not have cost for language: " ++ show lang)

-- =============================================================
Loading