From 42d387273fc564b6635909c8a5e597b928dcda77 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 20 Nov 2020 15:19:05 +0000 Subject: [PATCH] Review fixes --- cardano-api/src/Cardano/Api/Typed.hs | 2 + cardano-api/src/Cardano/Api/Value.hs | 201 ++++++++---------- .../test/Test/Cardano/Api/Typed/Gen.hs | 18 +- .../test/Test/Cardano/Api/Typed/Value.hs | 5 - 4 files changed, 103 insertions(+), 123 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Typed.hs b/cardano-api/src/Cardano/Api/Typed.hs index 2b91bde2284..e88771f530e 100644 --- a/cardano-api/src/Cardano/Api/Typed.hs +++ b/cardano-api/src/Cardano/Api/Typed.hs @@ -406,6 +406,8 @@ module Cardano.Api.Typed ( secondsToNominalDiffTime, -- Testing purposes + AssetsBundle(..), + AssetIdBundle(..), flatten, unflatten ) where diff --git a/cardano-api/src/Cardano/Api/Value.hs b/cardano-api/src/Cardano/Api/Value.hs index 7772d74ef13..b3b14ded8b0 100644 --- a/cardano-api/src/Cardano/Api/Value.hs +++ b/cardano-api/src/Cardano/Api/Value.hs @@ -36,6 +36,10 @@ module Cardano.Api.Value -- * Internal conversion functions , toShelleyLovelace + -- * Intermediate Value representation + , AssetsBundle(..) + , AssetIdBundle(..) + -- * Exported for testing purposes , flatten , unflatten @@ -45,9 +49,8 @@ import Prelude import Data.Aeson hiding (Value) import qualified Data.Aeson as Aeson -import Data.Aeson.Types (Parser) +import Data.Aeson.Types (Parser, toJSONKeyText) 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) @@ -103,10 +106,9 @@ lovelaceToQuantity (Lovelace x) = Quantity x quantityToLovelace :: Quantity -> Lovelace quantityToLovelace (Quantity x) = Lovelace x -data PolicyId = PolicyId ScriptHash - | AdaPolicyId +newtype PolicyId = PolicyId ScriptHash deriving stock (Show) - deriving (Eq, Ord) + deriving newtype (Eq, Ord, IsString) newtype AssetName = AssetName ByteString deriving stock (Show) @@ -129,123 +131,98 @@ instance Semigroup Value where instance Monoid Value where mempty = Value Map.empty +-- | Intermediate representation used in the JSON parsing/rendering of 'Value' +newtype AssetsBundle = AssetsBundle [AssetIdBundle] + deriving (Eq, Ord, Show) + +data AssetIdBundle = AssetIdBundle PolicyId (Map AssetName Quantity) + | AdaAsset Quantity + deriving (Eq, Ord, Show) + +instance ToJSON AssetsBundle where + toJSON (AssetsBundle bundles) = object $ map toPair bundles + where + toPair :: AssetIdBundle -> (Text, Aeson.Value) + toPair (AdaAsset q) = ("lovelace", toJSON q) + toPair (AssetIdBundle pid assets) = (renderPolicyId pid, toJSON assets) + + renderPolicyId :: PolicyId -> Text + renderPolicyId (PolicyId sh) = Text.decodeUtf8 (serialiseToRawBytesHex sh) + +instance ToJSON Quantity where + toJSON (Quantity q) = toJSON q + +instance FromJSON Quantity where + parseJSON = withScientific "MultiAssetQuantity" $ \sci -> + case Scientific.floatingOrInteger sci :: Either Double Integer of + Left d -> fail $ "Expected an integer but got: " <> show d + Right n -> return $ Quantity n + +instance ToJSON AssetName where + toJSON (AssetName an) = Aeson.String $ Text.decodeUtf8 an + +instance FromJSON AssetName where + parseJSON = withText "MultiAssetName" + $ \text -> return . AssetName $ Text.encodeUtf8 text + +instance ToJSONKey AssetName where + toJSONKey = toJSONKeyText + $ \(AssetName asset) -> Text.decodeUtf8 asset + +instance FromJSONKey AssetName where + fromJSONKey = FromJSONKeyText + $ \assetName -> AssetName $ Text.encodeUtf8 assetName + +instance FromJSON AssetsBundle where + parseJSON = withObject "AssetsBundle" $ \obj -> + AssetsBundle <$> HashMap.foldlWithKey' folder (return []) obj + where + folder + :: Parser [AssetIdBundle] + -> Text + -> Aeson.Value + -> Parser [AssetIdBundle] + folder acc pid asset = do + accum <- acc + assetIdBundle <- parsePid pid asset + return $ assetIdBundle : accum + + parsePid :: Text -> Aeson.Value -> Parser AssetIdBundle + parsePid pid q = + case pid of + "lovelace" -> + AdaAsset <$> parseJSON q + other -> + let pIdBS = Text.encodeUtf8 other + in case deserialiseFromRawBytesHex AsScriptHash pIdBS of + Just sHash -> AssetIdBundle (PolicyId sHash) <$> (parseJSON q) + Nothing -> fail $ "Failure when deserialising PolicyId: " + <> Text.unpack pid + instance ToJSON Value where - toJSON = render . unflatten + toJSON = toJSON . unflatten -unflatten :: Value-> Map PolicyId (Map AssetName Quantity) -unflatten (Value flatMap) = Map.foldlWithKey folder Map.empty flatMap +unflatten :: Value -> AssetsBundle +unflatten (Value flatMap) = AssetsBundle $ Map.foldlWithKey folder [] flatMap where folder - :: Map PolicyId (Map AssetName Quantity) + :: [AssetIdBundle] -> 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 + -> [AssetIdBundle] + folder acc (AssetId pid aName) q = AssetIdBundle pid (Map.singleton aName q) : acc + folder acc AdaAssetId q = AdaAsset q : acc 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 + parseJSON jv = flatten <$> parseJSON jv -flatten :: Map PolicyId (Map AssetName Quantity) -> Value -flatten = Map.foldlWithKey folder (Value Map.empty) +flatten :: AssetsBundle -> Value +flatten (AssetsBundle bundles) = foldl folder (Value Map.empty) bundles 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 + folder :: Value -> AssetIdBundle -> Value + folder acc (AssetIdBundle pid assetNameQuantityMap) = + acc <> Value (Map.mapKeysWith (<>) (\aname -> AssetId pid aname) assetNameQuantityMap) + folder acc (AdaAsset q) = acc <> Value (Map.singleton AdaAssetId q) {-# NOINLINE mergeAssetMaps #-} -- as per advice in Data.Map.Merge docs mergeAssetMaps :: Map AssetId Quantity diff --git a/cardano-api/test/Test/Cardano/Api/Typed/Gen.hs b/cardano-api/test/Test/Cardano/Api/Typed/Gen.hs index a278523bb77..7032abd1935 100644 --- a/cardano-api/test/Test/Cardano/Api/Typed/Gen.hs +++ b/cardano-api/test/Test/Cardano/Api/Typed/Gen.hs @@ -1,8 +1,9 @@ module Test.Cardano.Api.Typed.Gen ( genAddressByron , genAddressShelley + , genAssetsBundle + , genAssetIdBundleValue , genByronKeyWitness - , genIntermedValue , genRequiredSig , genMofNRequiredSig , genMultiSigScript @@ -170,11 +171,16 @@ 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) +genAssetsBundle :: Gen AssetsBundle +genAssetsBundle = AssetsBundle <$> Gen.list (Range.constant 1 10) genAssetIdBundleValue + +genAssetIdBundleValue :: Gen AssetIdBundle +genAssetIdBundleValue = + Gen.choice [ AssetIdBundle + <$> genPolicyId + <*> Gen.map (Range.singleton 1) ((,) <$> genAssetName <*> genQuantity) + , AdaAsset <$> genQuantity + ] genAllRequiredSig :: Gen (MultiSigScript ShelleyEra) genAllRequiredSig = diff --git a/cardano-api/test/Test/Cardano/Api/Typed/Value.hs b/cardano-api/test/Test/Cardano/Api/Typed/Value.hs index 281c41bd1aa..d0de6b4293f 100644 --- a/cardano-api/test/Test/Cardano/Api/Typed/Value.hs +++ b/cardano-api/test/Test/Cardano/Api/Typed/Value.hs @@ -26,11 +26,6 @@ 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