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

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
     TxBody(..),
@@ -403,7 +409,7 @@ module Cardano.Api.Typed (
     Shelley.emptyPParams,
     Shelley.truncateUnitInterval,
     emptyGenesisStaking,
-    secondsToNominalDiffTime
+    secondsToNominalDiffTime,
   ) where
 
 import           Prelude
@@ -463,7 +469,7 @@ import qualified Cardano.Chain.Slotting as Byron
 --
 -- Shelley imports
 --
-import           Ouroboros.Consensus.Shelley.Eras (StandardAllegra, StandardShelley, StandardMary)
+import           Ouroboros.Consensus.Shelley.Eras (StandardAllegra, StandardMary, StandardShelley)
 import           Ouroboros.Consensus.Shelley.Protocol.Crypto (StandardCrypto)
 
 import qualified Shelley.Spec.Ledger.Address as Shelley

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StandaloneDeriving #-}
 
 -- | Currency values
@@ -26,6 +27,12 @@ module Cardano.Api.Value
   , selectLovelace
   , lovelaceToValue
 
+    -- ** Alternative nested representation
+  , ValueNestedRep(..)
+  , ValueNestedBundle(..)
+  , valueToNestedRep
+  , valueFromNestedRep
+
     -- * Era-dependent use of multi-assert values
   , MintValue(..)
   , TxOutValue(..)
@@ -38,16 +45,24 @@ 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 Shelley.Spec.Ledger.Coin as Shelley
 
 import           Cardano.Api.Eras
 import           Cardano.Api.Script
+import           Cardano.Api.SerialiseRaw (deserialiseFromRawBytesHex, serialiseToRawBytesHex)
 
 
 -- ----------------------------------------------------------------------------
@@ -56,7 +71,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)
@@ -74,7 +89,7 @@ toShelleyLovelace (Lovelace l) = Shelley.Coin 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)
@@ -88,7 +103,6 @@ lovelaceToQuantity (Lovelace x) = Quantity x
 quantityToLovelace :: Quantity -> Lovelace
 quantityToLovelace (Quantity x) = Lovelace x
 
-
 newtype PolicyId = PolicyId ScriptHash
   deriving stock (Show)
   deriving newtype (Eq, Ord, IsString)
@@ -97,11 +111,23 @@ 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 = AssetId !PolicyId !AssetName
              | AdaAssetId
   deriving (Eq, Ord, Show)
 
-
 newtype Value = Value (Map AssetId Quantity)
   deriving Eq
 
@@ -115,7 +141,6 @@ instance Semigroup Value where
 instance Monoid Value where
   mempty = Value Map.empty
 
-
 {-# NOINLINE mergeAssetMaps #-} -- as per advice in Data.Map.Merge docs
 mergeAssetMaps :: Map AssetId Quantity
                -> Map AssetId Quantity
@@ -132,6 +157,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
 
@@ -158,6 +190,73 @@ lovelaceToValue :: Lovelace -> Value
 lovelaceToValue = Value . Map.singleton AdaAssetId . lovelaceToQuantity
 
 
+-- ----------------------------------------------------------------------------
+-- 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 = ValueNestedBundle PolicyId (Map AssetName Quantity)
+                       | ValueNestedBundleAda 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
+
+
 -- ----------------------------------------------------------------------------
 -- Era-dependent use of multi-assert values
 --

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

@@ -1,6 +1,8 @@
 module Test.Cardano.Api.Typed.Gen
   ( genAddressByron
   , genAddressShelley
+  , genValueNestedRep
+  , genValueNestedBundle
   , genByronKeyWitness
   , genRequiredSig
   , genMofNRequiredSig
@@ -19,6 +21,7 @@ module Test.Cardano.Api.Typed.Gen
   , genTxShelley
   , genTxBodyByron
   , genTxBodyShelley
+  , genValue
   , genVerificationKey
   ) where
 
@@ -149,6 +152,49 @@ genMultiSigScriptsMary =
 
     ]
 
+genAssetName :: Gen AssetName
+genAssetName = AssetName <$> Gen.utf8 (Range.constant 1 15) Gen.alphaNum
+
+genPolicyId :: Gen PolicyId
+genPolicyId = PolicyId <$> genScriptHash
+
+genAssetId :: Gen AssetId
+genAssetId = Gen.choice [ AssetId <$> genPolicyId <*> genAssetName
+                        , return AdaAssetId
+                        ]
+genQuantity :: Gen Quantity
+genQuantity =
+  fromInteger <$> Gen.integral_ (Range.exponential 0 (toInteger (maxBound :: Int64)))
+
+genValue :: Gen Value
+genValue =
+  valueFromList <$> Gen.list (Range.constant 0 10) ((,)
+                <$> genAssetId <*> genQuantity)
+
+-- We do not generate duplicate keys as 'ValueNestedRep' is created via
+-- flattening a 'Map'
+genValueNestedRep :: Gen ValueNestedRep
+genValueNestedRep =
+  Gen.choice
+    [ ValueNestedRep <$> Gen.list (Range.singleton 1) genValueNestedBundle
+    , ValueNestedRep <$> sequenceA [genValueNestedBundle, genValueNestedBundleAda]
+    ]
+
+genValueNestedBundle :: Gen ValueNestedBundle
+genValueNestedBundle =
+  Gen.choice [ genValueNestedBundleAda
+             , genValueNestedBundleNonAda
+             ]
+
+genValueNestedBundleAda :: Gen ValueNestedBundle
+genValueNestedBundleAda = ValueNestedBundleAda <$> genQuantity
+
+genValueNestedBundleNonAda :: Gen ValueNestedBundle
+genValueNestedBundleNonAda =
+  ValueNestedBundle
+    <$> genPolicyId
+    <*> Gen.map (Range.singleton 1) ((,) <$> genAssetName <*> genQuantity)
+
 genAllRequiredSig :: Gen (MultiSigScript ShelleyEra)
 genAllRequiredSig =
   RequireAllOf <$> Gen.list (Range.constant 1 10) (genRequiredSig SignaturesInShelleyEra)
@@ -363,3 +409,4 @@ genShelleyScriptWitness = makeScriptWitness
 
 genSeed :: Int -> Gen Crypto.Seed
 genSeed n = Crypto.mkSeedFromBytes <$> Gen.bytes (Range.singleton n)
+

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

@@ -0,0 +1,48 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Test.Cardano.Api.Typed.Value
+  ( tests
+  ) where
+
+import           Cardano.Prelude
+import           Data.Aeson
+
+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
+
+-- Note when going from ValueNestedRep -> Value (via fromValueNestedRep)
+-- we merge maps, which combines all common keys. Therefore
+-- we must generate an ValueNestedRep with no duplicate values.
+-- Remember that Maps cannot have duplicate keys and therefore
+-- we will never go from Value -> ValueNestedRep (via toValueNestedRep) to a
+-- ValueNestedRep with duplicate values.
+prop_roundtrip_Value_unflatten_flatten :: Property
+prop_roundtrip_Value_unflatten_flatten =
+    property $ do
+      v <- forAll genValueNestedRep
+      let v' = valueToNestedRep (valueFromNestedRep v)
+      v `equiv` v'
+  where
+    equiv (ValueNestedRep a) (ValueNestedRep b) = sort a === sort b
+
+-- -----------------------------------------------------------------------------
+
+tests :: TestTree
+tests = fromGroup $$discover
+

cardano-api/test/cardano-api-test.hs

@@ -13,6 +13,7 @@ import qualified Test.Cardano.Api.Typed.Envelope
 import qualified Test.Cardano.Api.Typed.MultiSig.Allegra
 import qualified Test.Cardano.Api.Typed.MultiSig.Mary
 import qualified Test.Cardano.Api.Typed.RawBytes
+import qualified Test.Cardano.Api.Typed.Value
 
 main :: IO ()
 main = do
@@ -23,7 +24,8 @@ main = do
 tests :: TestTree
 tests =
   testGroup "Cardano.Api"
-    [ Test.Cardano.Api.Crypto.tests
+    [ Test.Cardano.Api.Typed.Value.tests
+    , Test.Cardano.Api.Crypto.tests
     , Test.Cardano.Api.Ledger.tests
     , Test.Cardano.Api.MetaData.tests
     , Test.Cardano.Api.Typed.Bech32.tests