Merge pull request #197 from CardanoSolutions/asset-quantity-as-strings

Asset quantities as strings (adds feature #196)

Author: notunrandom

docs/api/nightly.yaml

@@ -1260,6 +1260,31 @@ components:
             1220099e5e430475c219518179efc7e6c8289db028904834025d5b086: 231
             289db028904834025d5b085d5b08661220099e5e430475c2195181796.08661220099e: 1
 
+    ValueAsString:
+      type: object
+      description: A (multi-asset) value of a transaction's output.
+      additionalProperties: false
+      required:
+        - coins
+      properties:
+        coins:
+          type: string
+          description: A quantity of Lovelace, encoded as string when 'asset-quantity=string' is specified as media-type parameter.
+          example: "42"
+        assets:
+          type: object
+          description: A _key:value_ map of asset identifier → quantity.
+          propertyNames:
+            type: string
+            pattern: ^[a-f0-9]{56}(.[a-f0-9]{2,64})?$
+          additionalProperties:
+            x-additionalPropertiesName: "{policy-id}.{asset-name}"
+            type: string
+            description: A quantity of some asset, encoded as string when 'asset-quantity=string' is specified as media-type parameter.
+          example:
+            1220099e5e430475c219518179efc7e6c8289db028904834025d5b086: "231"
+            289db028904834025d5b085d5b08661220099e5e430475c2195181796.08661220099e: "1"
+
     Wildcard:
       type: string
       title: Wildcard
@@ -1317,6 +1342,58 @@ components:
             - $ref: "#/components/schemas/SpentAt"
             - type: "null"
 
+    MatchQuantityAsString:
+      type: object
+      additionalProperties: false
+      required:
+        - transaction_index
+        - transaction_id
+        - output_index
+        - address
+        - value
+        - datum_hash
+        - script_hash
+        - created_at
+        - spent_at
+      properties:
+        transaction_index:
+          $ref: "#/components/schemas/TransactionIndex"
+        transaction_id:
+          $ref: "#/components/schemas/TransactionId"
+        output_index:
+          $ref: "#/components/schemas/OutputIndex"
+        address:
+          $ref: "#/components/schemas/Address"
+        value:
+          $ref: "#/components/schemas/ValueAsString"
+        datum_hash:
+          $ref: "#/components/schemas/DatumHash"
+        datum:
+          description: The resolved datum, if available. The field is only and always present (yet may be `null`) if `?resolve_hashes` was set.
+          oneOf:
+            - <<: *BinaryData
+              description: A serialized Plutus' Data.
+            - type: "null"
+              description: None or unknown datum.
+        datum_type:
+          $ref: "#/components/schemas/DatumType"
+        script_hash:
+          $ref: "#/components/schemas/ScriptHash"
+        script:
+          description: The resolved script, if available. The field is only and always present (yet may be `null`) if `?resolve_hashes` was set.
+          oneOf:
+            - $ref: "#/components/schemas/Script"
+            - type: "null"
+              description: None or unknown script.
+        created_at:
+          <<: *Point
+          description: Block reference at which this transaction was included in the ledger.
+        spent_at:
+          description: Block reference at which this transaction input was spent, if any.
+          oneOf:
+            - $ref: "#/components/schemas/SpentAt"
+            - type: "null"
+
     Health:
       type: object
       description: An overview of the server & connection status. Note that, when `most_recent_checkpoint` and `most_recent_node_tip` are equal, the index is fully synchronized.
@@ -1780,6 +1857,13 @@ paths:
         Optionally, use `?resolve_hashes` to automatically resolve and include `datum` and `script` associated with hash references, if available. Datums and scripts can otherwise be fetched using the [_Get Datum by Hash_](#tag/Datums/paths/~1datums~1{datum-hash}/get) and [_Get Script by Hash_](#tag/Scripts/paths/~1scripts~1{script-hash}/get) endpoints respectively.
 
         Note that it is generally a bad idea to fetch **ALL matches** for indexes built off permissive patterns (e.g. `*`), for the server will yield a large response.
+
+        > <sup><strong>TIP</strong></sup> <br/>
+        >
+        > You can customize coins and assets quantities encoding to always be strings instead of integers through the
+        > `Accept` header media-type as such:
+        >
+        > `Accept: application/json;asset-quantity=string`
       parameters:
         - $ref: "#/components/parameters/resolve-hashes"
         - $ref: "#/components/parameters/spent"
@@ -1803,6 +1887,11 @@ paths:
                 type: array
                 items:
                   $ref: "#/components/schemas/Match"
+            "application/json;charset=utf-8;asset-quantity=string":
+              schema:
+                type: array
+                items:
+                  $ref: "#/components/schemas/MatchQuantityAsString"
         304:
           $ref: "#/components/responses/304"
 
@@ -1814,6 +1903,13 @@ paths:
       description: |
         Retrieve matches from the database matching the given pattern, in descending `slot_no` order. Results are streamed to the client for more efficiency.
         See [Patterns](#section/Patterns) for more information about constructing patterns.
+
+        > <sup><strong>TIP</strong></sup> <br/>
+        >
+        > You can customize coins and assets quantities encoding to always be strings instead of integers through the
+        > `Accept` header media-type as such:
+        >
+        > `Accept: application/json;asset-quantity=string`
       parameters:
         - $ref: "#/components/parameters/pattern"
         - $ref: "#/components/parameters/resolve-hashes"
@@ -1837,7 +1933,12 @@ paths:
               schema:
                 type: array
                 items:
-                  $ref: "#/components/schemas/Match"
+
+            "application/json;charset=utf-8;asset-quantity=string":
+              schema:
+                type: array
+                items:
+                  $ref: "#/components/schemas/MatchQuantityAsString"
         304:
           $ref: "#/components/responses/304"
         400:

kupo.cabal

@@ -85,6 +85,7 @@ library:
     - filepath
     - generic-lens
     - http-client
+    - http-media
     - http-types
     - io-classes
     - lens

package.yaml

@@ -118,6 +118,9 @@ import Kupo.Data.Http.GetCheckpointMode
 import Kupo.Data.Http.OrderMatchesBy
     ( orderMatchesBy
     )
+import Kupo.Data.Http.QuantityEncoding
+    ( QuantityEncoding (..)
+    )
 import Kupo.Data.Http.ReferenceFlag
     ( referenceFlagFromQueryParams
     )
@@ -147,8 +150,16 @@ import Kupo.Data.Pattern
     , resultToJson
     , wildcard
     )
+import Network.HTTP.Media
+    ( mapAccept
+    )
+import Network.HTTP.Media.MediaType
+    ( (//)
+    , (/:)
+    )
 import Network.HTTP.Types
-    ( hAccept
+    ( Header
+    , hAccept
     , hContentType
     , status200
     , status202
@@ -181,6 +192,7 @@ import qualified Data.Set as Set
 import qualified GHC.Clock
 import qualified Kupo.Data.Http.Default as Default
 import qualified Kupo.Data.Http.Error as Errors
+import qualified Kupo.Data.Http.QuantityEncoding as QuantityEncoding
 import qualified Network.HTTP.Types.Header as Http
 import qualified Network.HTTP.Types.Status as Http
 import qualified Network.HTTP.Types.URI as Http
@@ -342,6 +354,7 @@ app networkParameters withDatabase forceRollback fetchBlock patternsVar readHeal
             withDatabase send ReadOnly $ \db -> do
                 send $ handleGetMatches
                             headers
+                            (requestHeaders req)
                             (pathParametersToText args)
                             (queryString req)
                             db
@@ -481,7 +494,7 @@ handleGetHealth
 handleGetHealth reqHeaders forcedStatus resolveNetworkParameters health = do
     networkParameters <- resolveNetworkParameters
     now <- getCurrentTime
-    case findContentType reqHeaders of
+    case findAcceptHeader reqHeaders of
         Just ct | cTextPlain `BS.isInfixOf` ct -> do
             let resHeaders = addCacheHeaders [(hContentType, cTextPlain <> ";charset=utf-8")] health
             return $ responseBuilder status resHeaders (mkPrometheusMetrics now networkParameters health)
@@ -520,14 +533,6 @@ handleGetHealth reqHeaders forcedStatus resolveNetworkParameters health = do
             <$> mostRecentNodeTip
             <*> (getPointSlotNo <$> mostRecentCheckpoint)
 
-    findContentType = \case
-        [] -> Nothing
-        (headerName, headerValue):rest ->
-            if headerName == hAccept then
-                Just headerValue
-            else
-                findContentType rest
-
     cTextPlain = "text/plain"
     cApplicationJson = "application/json"
     cAny = "*/*"
@@ -581,11 +586,12 @@ handleGetCheckpointBySlot headers mSlotNo query Database{..} =
 
 handleGetMatches
     :: [Http.Header]
+    -> [Http.Header]
     -> Maybe Text
     -> Http.Query
     -> Database IO
     -> Response
-handleGetMatches headers patternQuery queryParams Database{..} = handleRequest $ do
+handleGetMatches resHeaders reqHeaders patternQuery queryParams Database{..} = handleRequest $ do
     pattern_ <- (patternQuery >>= patternFromText)
         `orAbort` Errors.invalidPattern
 
@@ -604,7 +610,24 @@ handleGetMatches headers patternQuery queryParams Database{..} = handleRequest $
     sortDirection <- mkSortDirection <$> orderMatchesBy queryParams
         `orAbort` Errors.invalidSortDirection
 
-    pure $ responseStreamJson headers (resultToJson referenceFlag) $ \yield done -> do
+    let qualities =
+            [ ("application" // "json" /: QuantityEncoding.mediaTypeParam
+              , EncodeAsString
+              )
+            , ("application" // "json" /: QuantityEncoding.mediaTypeParam /: ("charset", "utf-8")
+              , EncodeAsString
+              )
+            , ("application" // "json" /: ("charset", "utf-8") /: QuantityEncoding.mediaTypeParam
+              , EncodeAsString
+              )
+            ]
+
+    let quantityEncoding = (findAcceptHeader reqHeaders >>= mapAccept qualities)
+            & fromMaybe EncodeAsInteger
+
+    let resHeaders' = (QuantityEncoding.adjustMediaType quantityEncoding resHeaders)
+
+    pure $ responseStreamJson resHeaders' (resultToJson referenceFlag quantityEncoding) $ \yield done -> do
         let assertPointExists :: Point -> DBTransaction IO ()
             assertPointExists requested = do
                 let nextSlot = next (getPointSlotNo requested)
@@ -943,6 +966,16 @@ requestBodyJson parser req = do
         Just (Json.Success a) -> return (Just a)
         _failureOrMalformed -> return Nothing
 
+findAcceptHeader :: [Header] -> Maybe ByteString
+findAcceptHeader = \case
+    [] -> Nothing
+    (headerName, headerValue):rest ->
+        if headerName == hAccept then
+            Just headerValue
+        else
+            findAcceptHeader rest
+
+
 --
 -- Tracer
 --

src/Kupo/App/Http.hs

@@ -12,6 +12,9 @@ import Kupo.Data.Cardano.PolicyId
     ( PolicyId
     , unsafePolicyIdFromBytes
     )
+import Kupo.Data.Http.QuantityEncoding
+    ( QuantityEncoding (..)
+    )
 
 import qualified Cardano.Ledger.Coin as Ledger
 import qualified Cardano.Ledger.Hashes as Ledger
@@ -54,13 +57,17 @@ unsafeValueFromList ada assets =
         | (pid, name, q) <- assets
         ]
 
-valueToJson :: Value -> Json.Encoding
-valueToJson (Ledger.MaryValue (Ledger.Coin coins) (Ledger.MultiAsset assets)) =
+valueToJson :: QuantityEncoding -> Value -> Json.Encoding
+valueToJson quantityEncoding (Ledger.MaryValue (Ledger.Coin coins) (Ledger.MultiAsset assets)) =
     Json.pairs $
-        Json.pair "coins"  (Json.integer coins)
+        Json.pair "coins"  (encodeQuantity coins)
       <>
         Json.pair "assets" (assetsToJson assets)
   where
+    encodeQuantity = case quantityEncoding of
+        EncodeAsInteger -> Json.integer
+        EncodeAsString -> Json.text . show
+
     shortBytesToKey =
         Builder.fromText . encodeBase16 . fromShort
 
@@ -82,7 +89,7 @@ valueToJson (Ledger.MaryValue (Ledger.Coin coins) (Ledger.MultiAsset assets)) =
                                         fieldName <> "." <> shortBytesToKey assetName
                                     ) & Json.fromText . toStrict . Builder.toLazyText
 
-                                v = Json.integer quantity
+                                v = encodeQuantity quantity
                              in
                                 Json.pair k v <> json
                         )

src/Kupo/Data/Cardano/Value.hs

@@ -0,0 +1,51 @@
+-- This Source Code Form is subject to the terms of the Mozilla Public
+-- License, v. 2.0. If a copy of the MPL was not distributed with this
+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.
+
+module Kupo.Data.Http.QuantityEncoding
+    ( QuantityEncoding(..)
+    , adjustMediaType
+    , mediaTypeParam
+    ) where
+
+import Kupo.Prelude
+
+import qualified Prelude as P
+    ( id
+    )
+
+import Network.HTTP.Media
+    ( MediaType
+    , mapContentMedia
+    , renderHeader
+    , (//)
+    , (/:)
+    )
+import Network.HTTP.Types
+    ( Header
+    , ResponseHeaders
+    , hContentType
+    )
+
+data QuantityEncoding = EncodeAsInteger | EncodeAsString
+    deriving Show
+
+adjustMediaType :: QuantityEncoding -> ResponseHeaders -> ResponseHeaders
+adjustMediaType EncodeAsInteger = P.id
+adjustMediaType EncodeAsString  = map insertParam
+
+mediaTypeParam :: (ByteString, ByteString)
+mediaTypeParam = ("asset-quantity", "string")
+
+insertParam :: Header -> Header
+insertParam (n,v)
+    | n == hContentType = (n, maybe v P.id (mapContentMedia mmap v))
+    | otherwise         = (n, v)
+
+mmap :: [(MediaType,ByteString)]
+mmap =
+    [("application"//"json"/:("charset","utf-8"),
+      renderHeader $ "application"//"json"/:("charset","utf-8")/:mediaTypeParam)
+    ,("application"//"json",
+      renderHeader $ "application"//"json"/:mediaTypeParam)
+    ]