Implement To/FromJSON instance for 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

@@ -375,7 +375,11 @@ module Cardano.Api.Typed (
     Shelley.emptyPParams,
     Shelley.truncateUnitInterval,
     emptyGenesisStaking,
-    secondsToNominalDiffTime
+    secondsToNominalDiffTime,
+
+    -- Testing purposes
+    flatten,
+    unflatten
   ) where
 
 import           Prelude
@@ -435,7 +439,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
@@ -34,20 +35,34 @@ module Cardano.Api.Value
 
     -- * Internal conversion functions
   , toShelleyLovelace
+
+    -- * Exported for testing purposes
+  , flatten
+  , unflatten
   ) where
 
 import           Prelude
 
+import           Data.Aeson hiding (Value)
+import qualified Data.Aeson as Aeson
+import           Data.Aeson.Types (Parser)
 import           Data.ByteString (ByteString)
+import           Data.HashMap.Strict (HashMap)
+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 qualified Data.Scientific as Scientific
 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)
 
 
 -- ----------------------------------------------------------------------------
@@ -88,10 +103,10 @@ lovelaceToQuantity (Lovelace x) = Quantity x
 quantityToLovelace :: Quantity -> Lovelace
 quantityToLovelace (Quantity x) = Lovelace x
 
-
-newtype PolicyId = PolicyId ScriptHash
+data PolicyId = PolicyId ScriptHash
+              | AdaPolicyId
   deriving stock (Show)
-  deriving newtype (Eq, Ord, IsString)
+  deriving (Eq, Ord)
 
 newtype AssetName = AssetName ByteString
   deriving stock (Show)
@@ -101,7 +116,6 @@ data AssetId = AssetId !PolicyId !AssetName
              | AdaAssetId
   deriving (Eq, Ord, Show)
 
-
 newtype Value = Value (Map AssetId Quantity)
   deriving Eq
 
@@ -115,6 +129,123 @@ instance Semigroup Value where
 instance Monoid Value where
   mempty = Value Map.empty
 
+instance ToJSON Value where
+  toJSON = render . unflatten
+
+unflatten :: Value-> Map PolicyId (Map AssetName Quantity)
+unflatten (Value flatMap) = Map.foldlWithKey folder Map.empty flatMap
+ where
+  folder
+    :: Map PolicyId (Map AssetName Quantity)
+    -> AssetId
+    -> Quantity
+    -> Map PolicyId (Map AssetName Quantity)
+  folder acc (AssetId pid aName) q =
+    Map.insertWith (<>) pid (Map.singleton aName q) acc
+  folder acc AdaAssetId q =
+    Map.insertWith (<>) AdaPolicyId (Map.singleton "lovelace" q) acc
+
+render :: Map PolicyId (Map AssetName Quantity) -> Aeson.Value
+render flatMap = Aeson.Object $ Map.foldlWithKey folder HashMap.empty flatMap
+ where
+  folder
+    :: HashMap Text Aeson.Value
+    -> PolicyId
+    -> Map AssetName Quantity
+    -> HashMap Text Aeson.Value
+  folder acc (PolicyId sh) nestedMap =
+    HashMap.insertWith
+      objectCombine
+      (Text.decodeUtf8 (serialiseToRawBytesHex sh))
+      (mapToValue nestedMap)
+      acc
+
+  folder acc AdaPolicyId nestedMap =
+    case Map.lookup "lovelace" nestedMap of
+      Just (Quantity n) ->
+        HashMap.insertWith numberCombine "lovelace" (Aeson.Number $ fromInteger n) acc
+      Nothing -> error $ "Expected \"lovelace\" key in: " <> show nestedMap
+
+  mapToValue :: Map AssetName Quantity -> Aeson.Value
+  mapToValue m =
+    Aeson.Object $
+      Map.foldlWithKey
+      (\acc (AssetName n) (Quantity a) ->
+        HashMap.insertWith numberCombine (Text.decodeUtf8 n) (Aeson.Number $ fromInteger a) acc)
+      HashMap.empty
+      m
+
+  objectCombine :: Aeson.Value -> Aeson.Value -> Aeson.Value
+  objectCombine (Aeson.Object hm1) (Aeson.Object hm2) =
+    Aeson.Object (HashMap.unionWith numberCombine hm1 hm2)
+  objectCombine v1 v2 = error $ "Expected two aeson objects but got: "
+                              <> show v1 <>" and " <> show v2
+
+  numberCombine :: Aeson.Value -> Aeson.Value -> Aeson.Value
+  numberCombine (Aeson.Number sci1) (Aeson.Number sci2) = Aeson.Number (sci1 + sci2)
+  numberCombine v1 v2 = error $ "Expected two aeson numbers but got: "
+                              <> show v1 <>" and " <> show v2
+
+instance FromJSON Value where
+  parseJSON jv = flatten <$> parseMA jv
+
+parseMA :: Aeson.Value -> Parser (Map PolicyId (Map AssetName Quantity))
+parseMA =
+  withObject "MultiAssetValue"
+    $ \obj -> HashMap.foldlWithKey' folder (return Map.empty) obj
+ where
+  folder
+    :: Parser (Map PolicyId (Map AssetName Quantity))
+    -> Text
+    -> Aeson.Value
+    -> Parser (Map PolicyId (Map AssetName Quantity))
+  folder acc pidText assetNameandQ = do
+    accum <- acc
+    pid <- parsePid pidText
+    aNameQuanMap <- toAssetQuantityMap assetNameandQ
+    return $ Map.insertWith (<>) pid aNameQuanMap accum
+
+  parsePid :: Text -> Parser PolicyId
+  parsePid pid =
+    case pid of
+      "lovelace" -> return AdaPolicyId
+      other -> let pIdBS = Text.encodeUtf8 other
+               in case deserialiseFromRawBytesHex AsScriptHash pIdBS of
+                    Just sHash -> return $ PolicyId sHash
+                    Nothing -> fail $ "Failure when deserialising PolicyId: " <> Text.unpack pid
+
+  toAssetQuantityMap :: Aeson.Value -> Parser (Map AssetName Quantity)
+  toAssetQuantityMap (Aeson.Object hm') =
+    HashMap.foldlWithKey' assetQuantityFolder (return Map.empty) hm'
+  toAssetQuantityMap ll@(Aeson.Number _) =
+    sequenceA $ Map.singleton (AssetName "lovelace") (convNumber ll)
+  toAssetQuantityMap v = fail $ "Expected Aeson Object but got: " <> show v
+
+  assetQuantityFolder
+    :: Parser (Map AssetName Quantity)
+    -> Text -> Aeson.Value -> Parser (Map AssetName Quantity)
+  assetQuantityFolder acc assetName quantity = do
+    accum <- acc
+    q <- convNumber quantity
+    return $ Map.insertWith (<>) (AssetName $ Text.encodeUtf8 assetName) q accum
+
+  convNumber :: Aeson.Value -> Parser Quantity
+  convNumber = withScientific "MultiAssetValue" $ \sci ->
+    case Scientific.floatingOrInteger sci :: Either Double Integer of
+      Left  d -> fail $ "Expected an integer but got: " <> show d
+      Right n -> return $ Quantity n
+
+flatten :: Map PolicyId (Map AssetName Quantity) -> Value
+flatten = Map.foldlWithKey folder (Value Map.empty)
+ where
+  folder :: Value -> PolicyId -> Map AssetName Quantity -> Value
+  folder acc pid aQmap = acc <> Value (Map.mapKeys (createAssetId pid) aQmap)
+
+  createAssetId :: PolicyId -> AssetName -> AssetId
+  createAssetId pid an@(AssetName bs) =
+    case Text.decodeUtf8 bs of
+      "lovelace" -> AdaAssetId
+      _ -> AssetId pid an
 
 {-# NOINLINE mergeAssetMaps #-} -- as per advice in Data.Map.Merge docs
 mergeAssetMaps :: Map AssetId Quantity

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

@@ -2,6 +2,7 @@ module Test.Cardano.Api.Typed.Gen
   ( genAddressByron
   , genAddressShelley
   , genByronKeyWitness
+  , genIntermedValue
   , genRequiredSig
   , genMofNRequiredSig
   , genMultiSigScript
@@ -19,6 +20,7 @@ module Test.Cardano.Api.Typed.Gen
   , genTxShelley
   , genTxBodyByron
   , genTxBodyShelley
+  , genValue
   , genVerificationKey
   ) where
 
@@ -155,6 +157,31 @@ 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)
+
+genIntermedValue :: Gen (Map PolicyId (Map AssetName Quantity))
+genIntermedValue = Gen.map (Range.constant 0 10) ((,) <$> genPolicyId <*> genAssetNameQuantity)
+ where
+  genAssetNameQuantity :: Gen (Map AssetName Quantity)
+  genAssetNameQuantity = Gen.map (Range.constant 1 10) ((,) <$> genAssetName <*> genQuantity)
+
 genAllRequiredSig :: Gen (MultiSigScript Shelley)
 genAllRequiredSig =
   RequireAllOf <$> Gen.list (Range.constant 1 10) (genRequiredSig SignaturesInShelleyEra)
@@ -367,3 +394,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,38 @@
+{-# 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_unflatten_flatten :: Property
+prop_roundtrip_Value_unflatten_flatten =
+  property $ do v <- forAll genValue
+                flatten (unflatten v) === v
+
+prop_roundtrip_Value_flatten_unflatten :: Property
+prop_roundtrip_Value_flatten_unflatten =
+  property $ do v <- forAll genIntermedValue
+                unflatten (flatten v) === v
+
+-- -----------------------------------------------------------------------------
+
+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