Implement To/FromJSON instances for Value (Multi-Asset Value)

Add round-trip tests.

Improve the generators for Value and related types: sample the PolicyId
and AssetName from a smaller range of values so that for things like
Value we get more "interesting" values with duplicate policy ids or
asset names.

Add a canonicalise function for ValueNestedRep which should be the
equivalent of converting from ValueNestedRep to Value and back.

cardano-api/cardano-api.cabal

@@ -181,6 +181,7 @@ test-suite cardano-api-test
                         Test.Cardano.Api.Typed.MultiSig.Shelley
                         Test.Cardano.Api.Typed.Orphans
                         Test.Cardano.Api.Typed.RawBytes
+                        Test.Cardano.Api.Typed.Value
                         Test.Tasty.Hedgehog.Group
 
   default-language:     Haskell2010

cardano-api/src/Cardano/Api/Typed.hs

@@ -128,6 +128,12 @@ module Cardano.Api.Typed (
     selectLovelace,
     lovelaceToValue,
 
+    -- ** Alternative nested representation
+    ValueNestedRep(..),
+    ValueNestedBundle(..),
+    valueToNestedRep,
+    valueFromNestedRep,
+
     -- * Building transactions
     -- | Constructing and inspecting transactions
 

cardano-api/src/Cardano/Api/Value.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 -- | Currency values
@@ -26,6 +27,12 @@ module Cardano.Api.Value
   , selectLovelace
   , lovelaceToValue
 
+    -- ** Alternative nested representation
+  , ValueNestedRep(..)
+  , ValueNestedBundle(..)
+  , valueToNestedRep
+  , valueFromNestedRep
+
     -- * Internal conversion functions
   , toByronLovelace
   , toShelleyLovelace
@@ -36,11 +43,18 @@ module Cardano.Api.Value
 
 import           Prelude
 
+import           Data.Aeson hiding (Value)
+import qualified Data.Aeson as Aeson
+import           Data.Aeson.Types (Parser, toJSONKeyText)
 import           Data.ByteString (ByteString)
+import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Map.Merge.Strict as Map
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.String (IsString)
+import           Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
 
 import qualified Cardano.Chain.Common as Byron
 
@@ -51,6 +65,7 @@ import qualified Cardano.Ledger.Mary.Value as Mary
 import           Ouroboros.Consensus.Shelley.Protocol.Crypto (StandardCrypto)
 
 import           Cardano.Api.Script
+import           Cardano.Api.SerialiseRaw (deserialiseFromRawBytesHex, serialiseToRawBytesHex)
 
 
 -- ----------------------------------------------------------------------------
@@ -59,7 +74,7 @@ import           Cardano.Api.Script
 
 newtype Lovelace = Lovelace Integer
   deriving stock (Show)
-  deriving newtype (Eq, Ord, Enum, Num)
+  deriving newtype (Eq, Ord, Enum, Num, ToJSON, FromJSON)
 
 instance Semigroup Lovelace where
   Lovelace a <> Lovelace b = Lovelace (a + b)
@@ -87,7 +102,7 @@ fromShelleyLovelace (Shelley.Coin l) = Lovelace l
 --
 
 newtype Quantity = Quantity Integer
-  deriving newtype (Eq, Ord, Num, Show)
+  deriving newtype (Eq, Ord, Num, Show, ToJSON, FromJSON)
 
 instance Semigroup Quantity where
   Quantity a <> Quantity b = Quantity (a + b)
@@ -110,6 +125,19 @@ newtype AssetName = AssetName ByteString
   deriving stock (Show)
   deriving newtype (Eq, Ord, IsString)
 
+instance ToJSON AssetName where
+  toJSON (AssetName an) = Aeson.String $ Text.decodeUtf8 an
+
+instance FromJSON AssetName where
+  parseJSON = withText "AssetName" (return . AssetName . Text.encodeUtf8)
+
+instance ToJSONKey AssetName where
+  toJSONKey = toJSONKeyText (\(AssetName asset) -> Text.decodeUtf8 asset)
+
+instance FromJSONKey AssetName where
+  fromJSONKey = FromJSONKeyText (AssetName . Text.encodeUtf8)
+
+
 data AssetId = AdaAssetId
              | AssetId !PolicyId !AssetName
   deriving (Eq, Ord, Show)
@@ -145,6 +173,13 @@ mergeAssetMaps =
         Quantity 0 -> Nothing
         c          -> Just c
 
+instance ToJSON Value where
+  toJSON = toJSON . valueToNestedRep
+
+instance FromJSON Value where
+  parseJSON v = valueFromNestedRep <$> parseJSON v
+
+
 selectAsset :: Value -> (AssetId -> Quantity)
 selectAsset (Value m) a = Map.findWithDefault mempty a m
 
@@ -207,3 +242,70 @@ fromMaryValue (Mary.Value lovelace other) =
 
     fromMaryAssetName :: Mary.AssetName -> AssetName
     fromMaryAssetName (Mary.AssetName n) = AssetName n
+
+
+-- ----------------------------------------------------------------------------
+-- An alternative nested representation
+--
+
+-- | An alternative nested representation for 'Value' that groups assets that
+-- share a 'PolicyId'.
+--
+newtype ValueNestedRep = ValueNestedRep [ValueNestedBundle]
+  deriving (Eq, Ord, Show)
+
+-- | A bundle within a 'ValueNestedRep' for a single 'PolicyId', or for the
+-- special case of ada.
+--
+data ValueNestedBundle = ValueNestedBundleAda Quantity
+                       | ValueNestedBundle PolicyId (Map AssetName Quantity)
+  deriving (Eq, Ord, Show)
+
+
+valueToNestedRep :: Value -> ValueNestedRep
+valueToNestedRep v =
+    -- unflatten all the non-ada assets, and add ada separately
+    ValueNestedRep $
+        [ ValueNestedBundleAda q | let q = selectAsset v AdaAssetId, q /= 0 ]
+     ++ [ ValueNestedBundle pId qs | (pId, qs) <- Map.toList nonAdaAssets ]
+  where
+    nonAdaAssets :: Map PolicyId (Map AssetName Quantity)
+    nonAdaAssets =
+      Map.fromListWith (Map.unionWith (<>))
+        [ (pId, Map.singleton aName q)
+        | (AssetId pId aName, q) <- valueToList v ]
+
+valueFromNestedRep :: ValueNestedRep -> Value
+valueFromNestedRep (ValueNestedRep bundles) =
+    valueFromList
+      [ (aId, q)
+      | bundle   <- bundles
+      , (aId, q) <- case bundle of
+                      ValueNestedBundleAda  q  -> [ (AdaAssetId, q) ]
+                      ValueNestedBundle pId qs -> [ (AssetId pId aName, q)
+                                                  | (aName, q) <- Map.toList qs ]
+      ]
+
+instance ToJSON ValueNestedRep where
+  toJSON (ValueNestedRep bundles) = object $ map toPair bundles
+    where
+     toPair :: ValueNestedBundle -> (Text, Aeson.Value)
+     toPair (ValueNestedBundleAda q) = ("lovelace", toJSON q)
+     toPair (ValueNestedBundle pid assets) = (renderPolicyId pid, toJSON assets)
+
+     renderPolicyId :: PolicyId -> Text
+     renderPolicyId (PolicyId sh) = Text.decodeUtf8 (serialiseToRawBytesHex sh)
+
+instance FromJSON ValueNestedRep where
+  parseJSON =
+      withObject "ValueNestedRep" $ \obj ->
+        ValueNestedRep <$> sequenceA [ parsePid keyValTuple
+                                   | keyValTuple <- HashMap.toList obj ]
+    where
+      parsePid :: (Text, Aeson.Value) -> Parser ValueNestedBundle
+      parsePid ("lovelace", q) = ValueNestedBundleAda <$> parseJSON q
+      parsePid (pid, q) =
+        case deserialiseFromRawBytesHex AsScriptHash (Text.encodeUtf8 pid) of
+          Just sHash -> ValueNestedBundle (PolicyId sHash) <$> parseJSON q
+          Nothing -> fail $ "Failure when deserialising PolicyId: "
+                         <> Text.unpack pid

cardano-api/test/Test/Cardano/Api/Typed/Gen.hs

@@ -1,9 +1,12 @@
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Test.Cardano.Api.Typed.Gen
   ( genAddressByron
   , genAddressShelley
+  , genValueNestedRep
+  , genValueNestedBundle
   , genByronKeyWitness
   , genRequiredSig
   , genMofNRequiredSig
@@ -22,6 +25,7 @@ module Test.Cardano.Api.Typed.Gen
   , genStakeAddress
   , genTx
   , genTxBody
+  , genValue
   , genVerificationKey
   ) where
 
@@ -30,13 +34,14 @@ import           Cardano.Api.Typed
 import           Cardano.Prelude
 
 import           Control.Monad.Fail (fail)
-import qualified Data.Map as Map
+import qualified Data.Map.Strict as Map
+import           Data.String
 
 import qualified Cardano.Binary as CBOR
 import qualified Cardano.Crypto.Hash as Crypto
 import qualified Cardano.Crypto.Seed as Crypto
 
-import           Hedgehog (Gen, Range)
+import           Hedgehog (Gen)
 import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Range as Range
 
@@ -170,6 +175,55 @@ genMultiSigScriptsMary =
 
     ]
 
+genAssetName :: Gen AssetName
+genAssetName =
+  Gen.frequency
+    -- mostly from a small number of choices, so we get plenty of repetition
+    [ (9, Gen.element ["", "a", "b", "c"])
+    , (1, AssetName <$> Gen.utf8 (Range.singleton  32) Gen.alphaNum)
+    , (1, AssetName <$> Gen.utf8 (Range.constant 1 31) Gen.alphaNum)
+    ]
+
+genPolicyId :: Gen PolicyId
+genPolicyId =
+  Gen.frequency
+      -- mostly from a small number of choices, so we get plenty of repetition
+    [ (9, Gen.element [ fromString (x : replicate 55 '0') | x <- ['a'..'c'] ])
+
+       -- and some from the full range of the type
+    , (1, PolicyId <$> genScriptHash)
+    ]
+
+genAssetId :: Gen AssetId
+genAssetId = Gen.choice [ AssetId <$> genPolicyId <*> genAssetName
+                        , return AdaAssetId
+                        ]
+
+genQuantity :: Gen Quantity
+genQuantity = fromInteger <$> Gen.integral (Range.constantFrom 0 (-2) 2)
+
+genValue :: Gen Value
+genValue =
+  valueFromList <$>
+    Gen.list (Range.constant 0 10)
+             ((,) <$> genAssetId <*> genQuantity)
+
+
+-- Note that we expect to sometimes generate duplicate policy id keys since we
+-- pick 90% of policy ids from a set of just three.
+genValueNestedRep :: Gen ValueNestedRep
+genValueNestedRep =
+  ValueNestedRep <$> Gen.list (Range.constant 0 5) genValueNestedBundle
+
+genValueNestedBundle :: Gen ValueNestedBundle
+genValueNestedBundle =
+  Gen.choice
+    [ ValueNestedBundleAda <$> genQuantity
+    , ValueNestedBundle <$> genPolicyId
+                        <*> Gen.map (Range.constant 0 5)
+                                    ((,) <$> genAssetName <*> genQuantity)
+    ]
+
 genAllRequiredSig :: Gen (MultiSigScript ShelleyEra)
 genAllRequiredSig =
   RequireAllOf <$> Gen.list (Range.constant 1 10) (genRequiredSig SignaturesInShelleyEra)
@@ -305,32 +359,6 @@ genTxId = TxId <$> genShelleyHash
 genTxIndex :: Gen TxIx
 genTxIndex = TxIx <$> Gen.word Range.constantBounded
 
-genQuantity :: Gen Quantity
-genQuantity = Quantity <$> Gen.integral (Range.linear 0 5000)
-
--- TODO: UTF8 bytes or random bytes?
-genAssetName :: Gen AssetName
-genAssetName = AssetName <$> Gen.bytes (Range.singleton 32)
-
-genPolicyId :: Gen PolicyId
-genPolicyId = PolicyId <$> genScriptHash
-
-genAssetId :: Gen AssetId
-genAssetId =
-  Gen.frequency
-    [ (1, pure AdaAssetId)
-    , (9, AssetId <$> genPolicyId <*> genAssetName)
-    ]
-
-genValue :: Gen Value
-genValue = valueFromList <$> Gen.list range genKeyValuePair
-  where
-    range :: Range Int
-    range = Range.constant 1 10
-
-    genKeyValuePair :: Gen (AssetId, Quantity)
-    genKeyValuePair = (,) <$> genAssetId <*> genQuantity
-
 genTxOutValue :: CardanoEra era -> Gen (TxOutValue era)
 genTxOutValue era =
   case era of

cardano-api/test/Test/Cardano/Api/Typed/Value.hs

@@ -0,0 +1,79 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Test.Cardano.Api.Typed.Value
+  ( tests
+  ) where
+
+import           Prelude
+
+import           Data.List (sort, groupBy)
+import           Data.Aeson
+import qualified Data.Map.Strict as Map
+
+import           Cardano.Api.Typed
+
+import           Hedgehog (Property, discover, forAll, property, tripping, (===))
+import           Test.Cardano.Api.Typed.Gen
+
+import           Test.Tasty (TestTree)
+import           Test.Tasty.Hedgehog.Group (fromGroup)
+
+prop_roundtrip_Value_JSON :: Property
+prop_roundtrip_Value_JSON =
+  property $ do v <- forAll genValue
+                tripping v encode eitherDecode
+
+
+prop_roundtrip_Value_flatten_unflatten :: Property
+prop_roundtrip_Value_flatten_unflatten =
+  property $ do v <- forAll genValue
+                valueFromNestedRep (valueToNestedRep v) === v
+
+prop_roundtrip_Value_unflatten_flatten :: Property
+prop_roundtrip_Value_unflatten_flatten =
+    property $ do
+      v <- forAll genValueNestedRep
+      canonicalise v === valueToNestedRep (valueFromNestedRep v)
+
+canonicalise :: ValueNestedRep -> ValueNestedRep
+canonicalise =
+    ValueNestedRep
+  . filter (not . isZeroOrEmpty)
+  . map filterZeros
+  . map (foldl1 mergeBundle)
+  . groupBy samePolicyId
+  . sort
+  . (\(ValueNestedRep bundles) -> bundles)
+  where
+    samePolicyId ValueNestedBundleAda{}
+                 ValueNestedBundleAda{} = True
+    samePolicyId (ValueNestedBundle pid _)
+                 (ValueNestedBundle pid' _) = pid == pid'
+    samePolicyId _ _ = False
+
+    -- Merge together bundles that have already been grouped by same PolicyId:
+    mergeBundle (ValueNestedBundleAda q)
+                (ValueNestedBundleAda q') =
+      ValueNestedBundleAda (q <> q')
+
+    mergeBundle (ValueNestedBundle pid  as)
+                (ValueNestedBundle pid' as') | pid == pid' =
+      ValueNestedBundle pid (Map.unionWith (<>) as as')
+
+    mergeBundle _ _ = error "canonicalise.mergeBundle: impossible"
+
+    filterZeros b@ValueNestedBundleAda{} = b
+    filterZeros (ValueNestedBundle pid as) =
+      ValueNestedBundle pid (Map.filter (/=0) as)
+
+    isZeroOrEmpty (ValueNestedBundleAda q) = q == 0
+    isZeroOrEmpty (ValueNestedBundle _ as) = Map.null as
+
+{-# ANN canonicalise "HLint: ignore Use map once" #-}
+
+
+-- -----------------------------------------------------------------------------
+
+tests :: TestTree
+tests = fromGroup $$discover
+