Skip to content

Commit

Permalink
wip
Browse files Browse the repository at this point in the history
  • Loading branch information
redxaxder committed Nov 24, 2020
1 parent d99dcda commit 69516f9
Show file tree
Hide file tree
Showing 15 changed files with 270 additions and 88 deletions.
9 changes: 6 additions & 3 deletions shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs
Original file line number Diff line number Diff line change
Expand Up @@ -16,11 +16,11 @@ shadowing warnings for the named field puns when used with a pattern synonym.
module Cardano.Ledger.Mary.Translation where

import Cardano.Ledger.Allegra (AllegraEra)
import Cardano.Ledger.Compactible
import Cardano.Ledger.Compactible (Compactible (..))
import Cardano.Ledger.Crypto (Crypto)
import Cardano.Ledger.Era hiding (Crypto)
import Cardano.Ledger.Mary (MaryEra)
import Cardano.Ledger.Mary.Value
import Cardano.Ledger.Mary.Value (Value (..))
import Cardano.Ledger.ShelleyMA.Metadata (Metadata (..), pattern Metadata)
import Cardano.Ledger.ShelleyMA.Scripts (Timelock)
import Cardano.Ledger.ShelleyMA.TxBody
Expand Down Expand Up @@ -362,4 +362,7 @@ translateValue :: Era era => Coin -> Value era
translateValue = Val.inject

translateCompactValue :: Era era => CompactForm Coin -> CompactForm (Value era)
translateCompactValue = toCompact . translateValue . fromCompact
translateCompactValue = assume . toCompact . translateValue . fromCompact
where
assume Nothing = error "impossible error: compact coin is out of range"
assume (Just x) = x
162 changes: 133 additions & 29 deletions shelley-ma/impl/src/Cardano/Ledger/Mary/Value.hs
Original file line number Diff line number Diff line change
Expand Up @@ -5,6 +5,8 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}

Expand All @@ -19,18 +21,18 @@ module Cardano.Ledger.Mary.Value
)
where

import Cardano.Binary
( FromCBOR,
ToCBOR,
encodeListLen,
fromCBOR,
toCBOR,
)
import Cardano.Binary (Decoder, Encoding, FromCBOR, ToCBOR, TokenType (..), decodeInt64, decodeWord64, fromCBOR, peekTokenType, toCBOR)
import qualified Cardano.Crypto.Hash.Class as Hash
import Cardano.Ledger.Compactible (Compactible (..))
import qualified Cardano.Ledger.Core as Core
import Cardano.Ledger.Era
import Cardano.Ledger.Torsor (Torsor (..))
import Cardano.Ledger.Val (Val (..))
import Cardano.Ledger.Val
( DecodeMint (..),
DecodeNonNegative (..),
EncodeMint (..),
Val (..),
)
import Control.DeepSeq (NFData (..))
import Control.Monad (guard)
import Data.Array (Array)
Expand All @@ -41,6 +43,14 @@ import Data.CannonicalMaps
cannonicalMapUnion,
pointWise,
)
import Data.Coders
( Decode (..),
Encode (..),
decode,
encode,
(!>),
(<!),
)
import Data.Group (Abelian, Group (..))
import Data.Map.Internal
( Map (..),
Expand All @@ -58,8 +68,8 @@ import Data.Word (Word64)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
import Shelley.Spec.Ledger.Coin (Coin (..), integerToWord64)
import Shelley.Spec.Ledger.Scripts (ScriptHash)
import Shelley.Spec.Ledger.Serialization (decodeRecordNamed)
import Shelley.Spec.Ledger.Scripts (ScriptHash (..))
import Shelley.Spec.Ledger.Serialization (decodeMap, encodeMap)
import Prelude hiding (lookup)

-- | Asset Name
Expand Down Expand Up @@ -147,24 +157,106 @@ instance Era era => Val (Value era) where
-- TODO Probably the actual serialization will be of the formal Coin OR Value type
-- Maybe better to make this distinction in the TxOut de/serialization

decodeInteger :: Decoder s Integer
decodeInteger = fromIntegral <$> decodeInt64

decodeValue ::
( Typeable (Core.Script era),
Era era
) =>
Decoder s (Value era)
decodeValue = do
tt <- peekTokenType
case tt of
TypeUInt -> inject . Coin <$> decodeInteger
TypeNInt -> inject . Coin <$> decodeInteger
TypeListLen -> decodeValuePair decodeInteger
TypeListLen64 -> decodeValuePair decodeInteger
TypeListLenIndef -> decodeValuePair decodeInteger
_ -> fail $ "Value: expected array or int"

decodeValuePair ::
( Typeable (Core.Script era),
Era era
) =>
(forall t. Decoder t Integer) ->
Decoder s (Value era)
decodeValuePair decodeAmount =
decode $
RecD Value
<! D decodeAmount
<! D (decodeMultiAssetMaps decodeAmount)

encodeMultiAssetMaps ::
( Typeable (Core.Script era),
Era era
) =>
Map (PolicyID era) (Map AssetName Integer) ->
Encoding
encodeMultiAssetMaps = encodeMap toCBOR (encodeMap toCBOR toCBOR)

decodeMultiAssetMaps ::
( Typeable (Core.Script era),
Era era
) =>
Decoder s Integer ->
Decoder s (Map (PolicyID era) (Map AssetName Integer))
decodeMultiAssetMaps decodeAmount =
prune <$> decodeMap fromCBOR (decodeMap fromCBOR decodeAmount)

decodeNonNegativeInteger :: Decoder s Integer
decodeNonNegativeInteger = fromIntegral <$> decodeWord64

decodeNonNegativeValue ::
( Typeable (Core.Script era),
Era era
) =>
Decoder s (Value era)
decodeNonNegativeValue = do
tt <- peekTokenType
case tt of
TypeUInt -> inject . Coin <$> decodeNonNegativeInteger
TypeListLen -> decodeValuePair decodeNonNegativeInteger
TypeListLen64 -> decodeValuePair decodeNonNegativeInteger
TypeListLenIndef -> decodeValuePair decodeNonNegativeInteger
_ -> fail $ "Value: expected array or int"

instance
(Era era, Typeable (Core.Script era)) =>
ToCBOR (Value era)
where
toCBOR (Value c v) =
encodeListLen 2
<> toCBOR c
<> toCBOR v
if Map.null v
then toCBOR c
else
encode $
Rec Value
!> To c
!> E encodeMultiAssetMaps v

instance
(Era era, Typeable (Core.Script era)) =>
FromCBOR (Value era)
where
fromCBOR = do
decodeRecordNamed "Value" (const 2) $ do
c <- fromCBOR
v <- fromCBOR
pure $ Value c v
fromCBOR = decodeValue

instance
(Era era, Typeable (Core.Script era)) =>
DecodeNonNegative (Value era)
where
decodeNonNegative = decodeNonNegativeValue

instance
(Era era, Typeable (Core.Script era)) =>
DecodeMint (Value era)
where
decodeMint = Value 0 <$> decodeMultiAssetMaps decodeInteger

instance
(Era era, Typeable (Core.Script era)) =>
EncodeMint (Value era)
where
encodeMint (Value _ multiasset) = encodeMultiAssetMaps multiasset

-- ========================================================================
-- Compactible
Expand All @@ -173,14 +265,20 @@ instance
instance Era era => Compactible (Value era) where
newtype CompactForm (Value era) = CompactValue (CV era)
deriving (ToCBOR, FromCBOR)
toCompact = CompactValue . toCV
toCompact x = CompactValue <$> toCV x
fromCompact (CompactValue x) = fromCV x

instance (Typeable (Core.Script era), Era era) => ToCBOR (CV era) where
toCBOR = toCBOR . fromCV

instance (Typeable (Core.Script era), Era era) => FromCBOR (CV era) where
fromCBOR = toCV <$> fromCBOR
fromCBOR = do
v <- decodeNonNegativeValue
case toCV v of
Nothing ->
fail
"impossible failure: decoded nonnegative value that cannot be compacted"
Just x -> pure x

data CV era
= CV
Expand All @@ -193,24 +291,23 @@ data CVPart era
{-# UNPACK #-} !AssetName
{-# UNPACK #-} !Word64

toCV :: Value era -> CV era
toCV v =
toCV :: Value era -> Maybe (CV era)
toCV v = do
let (c, triples) = gettriples v
policyIDs = Set.fromList $ (\(x, _, _) -> x) <$> triples
n = length triples - 1
arr = array (0, n) (zip [0 .. n] (toCVPart policyIDs <$> triples))
in CV (convert c) arr
cvParts <- traverse (toCVPart policyIDs) triples
let arr = array (0, n) (zip [0 .. n] cvParts)
c' <- integerToWord64 c
pure $ CV c' arr
where
deduplicate xs x = fromMaybe x $ do
r <- Set.lookupLE x xs
guard (x == r)
pure r
toCVPart policyIdSet (policyId, aname, amount) =
CVPart (deduplicate policyIdSet policyId) aname (convert amount)
convert x =
fromMaybe
(error $ "out of bounds : " ++ show x)
(integerToWord64 x)
CVPart (deduplicate policyIdSet policyId) aname
<$> integerToWord64 amount

fromCV :: Era era => CV era -> Value era
fromCV (CV w vs) = foldr f (inject . Coin . fromIntegral $ w) vs
Expand Down Expand Up @@ -287,6 +384,13 @@ insert combine pid aid new (Value cn m1) =

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

-- | Remove 0 assets from a map
prune ::
Map (PolicyID era) (Map AssetName Integer) ->
Map (PolicyID era) (Map AssetName Integer)
prune assets =
Map.filter (not . null) $ Map.filter (/= 0) <$> assets

-- | Display a Value as a String, one token per line
showValue :: Value era -> String
showValue v = show c ++ "\n" ++ unlines (map trans ts)
Expand Down
4 changes: 3 additions & 1 deletion shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxow.hs
Original file line number Diff line number Diff line change
Expand Up @@ -22,7 +22,7 @@ import Cardano.Ledger.ShelleyMA.Rules.Utxo ()
import Cardano.Ledger.ShelleyMA.Scripts ()
import Cardano.Ledger.ShelleyMA.TxBody ()
import Cardano.Ledger.Torsor (Torsor (..))
import Cardano.Ledger.Val (Val)
import Cardano.Ledger.Val (DecodeMint, DecodeNonNegative, Val)
import Control.State.Transition.Extended
import Data.Foldable (Foldable (toList))
import qualified Data.Map.Strict as Map
Expand Down Expand Up @@ -120,6 +120,8 @@ instance
Typeable ma,
STS (UTXO (ShelleyMAEra ma c)),
BaseM (UTXO (ShelleyMAEra ma c)) ~ ShelleyBase,
DecodeMint (Core.Value (ShelleyMAEra ma c)),
DecodeNonNegative (Core.Value (ShelleyMAEra ma c)),
Compactible (Core.Value (ShelleyMAEra ma c)),
Val (Core.Value (ShelleyMAEra ma c)),
GetPolicies (Core.Value (ShelleyMAEra ma c)) (ShelleyMAEra ma c),
Expand Down
17 changes: 14 additions & 3 deletions shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/TxBody.hs
Original file line number Diff line number Diff line change
Expand Up @@ -42,7 +42,12 @@ import qualified Cardano.Ledger.Core as Core
import Cardano.Ledger.Era (Era)
import Cardano.Ledger.ShelleyMA (MaryOrAllegra, ShelleyMAEra)
import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..))
import Cardano.Ledger.Val (Val (..))
import Cardano.Ledger.Val
( DecodeMint (..),
DecodeNonNegative,
EncodeMint (..),
Val (..),
)
import Control.DeepSeq (NFData (..))
import Data.Coders
( Decode (..),
Expand Down Expand Up @@ -88,6 +93,10 @@ type FamsFrom era =
Typeable era,
Typeable (Script era),
Typeable (Core.Metadata era),
Show (Value era),
Compactible (Value era),
DecodeNonNegative (Value era),
DecodeMint (Value era),
FromCBOR (CompactForm (Value era)), -- Arises because TxOut uses Compact form
FromCBOR (Value era),
FromCBOR (Annotator (Script era)) -- Arises becaause DCert memoizes its bytes
Expand All @@ -96,6 +105,8 @@ type FamsFrom era =
type FamsTo era =
( Era era,
ToCBOR (Value era),
Compactible (Value era),
EncodeMint (Value era),
ToCBOR (CompactForm (Value era)), -- Arises because TxOut uses Compact form
ToCBOR (Script era),
Typeable (Core.Metadata era)
Expand Down Expand Up @@ -173,7 +184,7 @@ txSparse (TxBodyRaw inp out cert wdrl fee (ValidityInterval bot top) up hash frg
!> encodeKeyedStrictMaybe 6 up
!> encodeKeyedStrictMaybe 7 hash
!> encodeKeyedStrictMaybe 8 bot
!> Omit isZero (Key 9 (To frge))
!> Omit isZero (Key 9 (E encodeMint frge))

bodyFields :: FamsFrom era => Word -> Field (TxBodyRaw era)
bodyFields 0 = field (\x tx -> tx {inputs = x}) (D (decodeSet fromCBOR))
Expand All @@ -185,7 +196,7 @@ bodyFields 5 = field (\x tx -> tx {wdrls = x}) From
bodyFields 6 = field (\x tx -> tx {update = x}) (D (SJust <$> fromCBOR))
bodyFields 7 = field (\x tx -> tx {mdHash = x}) (D (SJust <$> fromCBOR))
bodyFields 8 = field (\x tx -> tx {vldt = (vldt tx) {validFrom = x}}) (D (SJust <$> fromCBOR))
bodyFields 9 = field (\x tx -> tx {forge = x}) From
bodyFields 9 = field (\x tx -> tx {forge = x}) (D decodeMint)
bodyFields n = field (\_ t -> t) (Invalid n)

initial :: (Val (Value era)) => TxBodyRaw era
Expand Down
14 changes: 14 additions & 0 deletions shelley-ma/shelley-ma-test/cddl-files/shelley-ma.cddl
Original file line number Diff line number Diff line change
Expand Up @@ -260,3 +260,17 @@ genesishash = $hash28

vrf_keyhash = $hash32
metadata_hash = $hash32

; allegra differences
transaction_body_allegra =
{ 0 : set<transaction_input>
, 1 : [* transaction_output_allegra]
, 2 : coin ; fee
, ? 3 : uint ; ttl
, ? 4 : [* certificate]
, ? 5 : withdrawals
, ? 6 : update
, ? 7 : metadata_hash
, ? 8 : uint ; validity interval start
}
transaction_output_allegra = [address, amount : coin]
Original file line number Diff line number Diff line change
Expand Up @@ -25,9 +25,9 @@ cddlTests :: Int -> TestTree
cddlTests n = withResource combinedCDDL (const (pure ())) $ \cddl ->
testGroup "CDDL roundtrip tests" $
[ cddlTest @(Core.Value A) n "coin",
-- cddlTest @(Core.Value M) n "value",
-- cddlTest' @(Core.TxBody M) n "transaction_body",
-- cddlTest' @(Core.TxBody A) n "transaction_body",
cddlTest @(Core.Value M) n "value",
cddlTest' @(Core.TxBody M) n "transaction_body",
cddlTest' @(Core.TxBody A) n "transaction_body_allegra",
cddlTest' @(Core.Script M) n "native_script",
cddlTest' @(Core.Script A) n "native_script",
cddlTest' @(Core.Metadata M) n "transaction_metadata",
Expand Down
Loading

0 comments on commit 69516f9

Please sign in to comment.