Implement getTxMetadata and isTxConfirmed for Blockfrost, add basic test

src/Internal/Contract/QueryHandle.purs

@@ -46,6 +46,10 @@ import Ctl.Internal.QueryM.Ogmios (SubmitTxR(SubmitTxSuccess), TxEvaluationR)
 import Ctl.Internal.Serialization (convertTransaction, toBytes) as Serialization
 import Ctl.Internal.Serialization.Address (Address)
 import Ctl.Internal.Serialization.Hash (ScriptHash)
+import Ctl.Internal.Service.Blockfrost
+  ( getTxMetadata
+  , isTxConfirmed
+  ) as Blockfrost
 import Ctl.Internal.Types.Chain as Chain
 import Ctl.Internal.Types.Datum (DataHash, Datum)
 import Ctl.Internal.Types.Transaction (TransactionHash, TransactionInput)
@@ -115,5 +119,20 @@ queryHandleForCtlBackend contractEnv backend =
 
 queryHandleForBlockfrostBackend
   :: ContractEnv -> BlockfrostBackend -> QueryHandle
-queryHandleForBlockfrostBackend = undefined
-
+queryHandleForBlockfrostBackend _ backend =
+  { getDatumByHash: undefined
+  , getScriptByHash: undefined
+  , getUtxoByOref: undefined
+  , isTxConfirmed: runBlockfrost backend Nothing <<< Blockfrost.isTxConfirmed -- TODO Just
+  , getTxMetadata: runBlockfrost backend Nothing <<< Blockfrost.getTxMetadata -- TODO Just
+  , utxosAt: undefined
+  , getChainTip: undefined
+  , getCurrentEpoch: undefined
+  , submitTx: undefined
+  , evaluateTx: undefined
+  , getEraSummaries: undefined
+  }
+  where
+  runBlockfrost :: forall (a :: Type). _ -> _ -> (_ -> _ -> Aff a) -> Aff a
+  runBlockfrost { blockfrostConfig } mbApiKey action = action blockfrostConfig
+    mbApiKey

src/Internal/Deserialization/FromBytes.purs

@@ -33,6 +33,7 @@ import Ctl.Internal.Serialization.Types
   , Transaction
   , TransactionBody
   , TransactionHash
+  , TransactionMetadatum
   , TransactionOutput
   , TransactionUnspentOutput
   , TransactionWitnessSet
@@ -72,6 +73,9 @@ instance FromBytes Ed25519Signature where
 instance FromBytes GeneralTransactionMetadata where
   fromBytes' = fromBytesImpl "GeneralTransactionMetadata"
 
+instance FromBytes TransactionMetadatum where
+  fromBytes' = fromBytesImpl "TransactionMetadatum"
+
 instance FromBytes GenesisDelegateHash where
   fromBytes' = fromBytesImpl "GenesisDelegateHash"
 

src/Internal/QueryM.purs

@@ -385,7 +385,7 @@ mempoolSnapshotHasTxAff ogmiosWs logger ms =
 
 data ClientError
   = ClientHttpError Affjax.Error
-  | ClientHttpResponseError String
+  | ClientHttpResponseError Affjax.StatusCode.StatusCode String
   | ClientDecodeJsonError String JsonDecodeError
   | ClientEncodingError String
   | ClientOtherError String
@@ -396,8 +396,10 @@ instance Show ClientError where
     "(ClientHttpError "
       <> Affjax.printError err
       <> ")"
-  show (ClientHttpResponseError err) =
+  show (ClientHttpResponseError statusCode err) =
     "(ClientHttpResponseError "
+      <> show statusCode
+      <> " "
       <> show err
       <> ")"
   show (ClientDecodeJsonError jsonStr err) =
@@ -428,7 +430,8 @@ handleAffjaxResponse (Left affjaxError) =
 handleAffjaxResponse
   (Right { status: Affjax.StatusCode.StatusCode statusCode, body })
   | statusCode < 200 || statusCode > 299 =
-      Left (ClientHttpResponseError body)
+      Left
+        (ClientHttpResponseError (Affjax.StatusCode.StatusCode statusCode) body)
   | otherwise =
       body # lmap (ClientDecodeJsonError body)
         <<< (decodeAeson <=< parseJsonStringToAeson)

src/Internal/QueryM/Kupo.purs

@@ -66,7 +66,7 @@ import Ctl.Internal.Serialization.Address
 import Ctl.Internal.Serialization.Hash (ScriptHash, scriptHashToBytes)
 import Ctl.Internal.Types.BigNum (toString) as BigNum
 import Ctl.Internal.Types.ByteArray (ByteArray, byteArrayToHex, hexToByteArray)
-import Ctl.Internal.Types.CborBytes (hexToCborBytes)
+import Ctl.Internal.Types.CborBytes (CborBytes, hexToCborBytes)
 import Ctl.Internal.Types.Datum (DataHash(DataHash), Datum)
 import Ctl.Internal.Types.OutputDatum
   ( OutputDatum(NoOutputDatum, OutputDatumHash, OutputDatum)
@@ -434,9 +434,7 @@ instance Show KupoMetadata where
 
 instance DecodeAeson KupoMetadata where
   decodeAeson = decodeAeson >=> case _ of
-    [ { raw } :: { raw :: String } ] -> do
-      cbor <- flip note (hexToCborBytes raw) $
-        TypeMismatch "Hexadecimal String"
+    [ { raw: cbor } :: { raw :: CborBytes } ] -> do
       metadata <- flip note (fromBytes cbor) $
         TypeMismatch "Hexadecimal encoded Metadata"
       pure $ KupoMetadata $ Just $ convertGeneralTransactionMetadata metadata

src/Internal/Service/Blockfrost.purs

@@ -0,0 +1,119 @@
+module Ctl.Internal.Service.Blockfrost
+  ( isTxConfirmed
+  , getTxMetadata
+  ) where
+
+import Prelude
+
+import Aeson
+  ( class DecodeAeson
+  , Aeson
+  , JsonDecodeError(TypeMismatch)
+  , decodeAeson
+  )
+import Affjax (Error, Response, URL, defaultRequest, request) as Affjax
+import Affjax.RequestHeader (RequestHeader(RequestHeader)) as Affjax
+import Affjax.ResponseFormat as Affjax.ResponseFormat
+import Affjax.StatusCode (StatusCode(StatusCode)) as Affjax
+import Ctl.Internal.Deserialization.FromBytes (fromBytes)
+import Ctl.Internal.Deserialization.Transaction
+  ( convertGeneralTransactionMetadata
+  )
+import Ctl.Internal.QueryM
+  ( ClientError(ClientHttpResponseError)
+  , handleAffjaxResponse
+  )
+import Ctl.Internal.QueryM.ServerConfig (ServerConfig, mkHttpUrl)
+import Ctl.Internal.Types.ByteArray (byteArrayToHex)
+import Ctl.Internal.Types.CborBytes (CborBytes)
+import Ctl.Internal.Types.Transaction (TransactionHash)
+import Ctl.Internal.Types.TransactionMetadata
+  ( GeneralTransactionMetadata(GeneralTransactionMetadata)
+  )
+import Data.Either (Either(Left, Right), note)
+import Data.Foldable (foldMap)
+import Data.Generic.Rep (class Generic)
+import Data.HTTP.Method (Method(GET))
+import Data.Map as Map
+import Data.Maybe (Maybe(Just, Nothing))
+import Data.Newtype (unwrap)
+import Data.Show.Generic (genericShow)
+import Data.Traversable (for)
+import Effect.Aff (Aff)
+
+isTxConfirmed
+  :: TransactionHash
+  -> ServerConfig
+  -> Maybe String
+  -> Aff (Either ClientError Boolean)
+isTxConfirmed txHash config mbApiKey = do
+  response :: Either ClientError Aeson <- handleAffjaxResponse <$> request
+  pure case response of
+    Right _ -> Right true
+    Left (ClientHttpResponseError (Affjax.StatusCode 404) _) -> Right false
+    Left e -> Left e
+  where
+  request :: Aff (Either Affjax.Error (Affjax.Response String))
+  request = Affjax.request $ Affjax.defaultRequest
+    { method = Left GET
+    , url = mkHttpUrl config <> endpoint
+    , responseFormat = Affjax.ResponseFormat.string
+    , headers =
+        flip foldMap mbApiKey \apiKey ->
+          [ Affjax.RequestHeader "project_id" apiKey ]
+    }
+
+  endpoint :: Affjax.URL
+  endpoint = "/txs/" <> byteArrayToHex (unwrap txHash)
+
+getTxMetadata
+  :: TransactionHash
+  -> ServerConfig
+  -> Maybe String
+  -> Aff (Either ClientError (Maybe GeneralTransactionMetadata))
+getTxMetadata txHash config mbApiKey = do
+  response :: Either ClientError _ <- handleAffjaxResponse <$> request
+  pure case response of
+    Right metadata -> Right $ Just $ unwrapBlockfrostMetadata metadata
+    Left (ClientHttpResponseError (Affjax.StatusCode 404) _) -> Right Nothing
+    Left e -> Left e
+  where
+  request :: Aff (Either Affjax.Error (Affjax.Response String))
+  request = Affjax.request $ Affjax.defaultRequest
+    { method = Left GET
+    , url = mkHttpUrl config <> endpoint
+    , responseFormat = Affjax.ResponseFormat.string
+    , headers =
+        flip foldMap mbApiKey \apiKey ->
+          [ Affjax.RequestHeader "project_id" apiKey ]
+    }
+
+  endpoint :: Affjax.URL
+  endpoint = "/txs/" <> byteArrayToHex (unwrap txHash) <> "/metadata/cbor"
+
+--------------------------------------------------------------------------------
+-- `getTxMetadata` reponse parsing
+--------------------------------------------------------------------------------
+
+newtype BlockfrostMetadata = BlockfrostMetadata
+  GeneralTransactionMetadata
+
+derive instance Generic BlockfrostMetadata _
+derive instance Eq BlockfrostMetadata
+
+instance Show BlockfrostMetadata where
+  show = genericShow
+
+instance DecodeAeson BlockfrostMetadata where
+  decodeAeson = decodeAeson >=>
+    \(metadatas :: Array { metadata :: CborBytes }) -> do
+      metadatas' <- for metadatas \{ metadata } -> do
+        map (unwrap <<< convertGeneralTransactionMetadata) <$> flip note
+          (fromBytes metadata) $
+          TypeMismatch "Hexadecimal encoded Metadata"
+
+      pure $ BlockfrostMetadata $ GeneralTransactionMetadata $ Map.unions
+        metadatas'
+
+unwrapBlockfrostMetadata :: BlockfrostMetadata -> GeneralTransactionMetadata
+unwrapBlockfrostMetadata (BlockfrostMetadata metadata) = metadata

test/Blockfrost.purs

@@ -0,0 +1,124 @@
+module Test.Ctl.Blockfrost where
+
+import Prelude
+
+import Contract.Metadata
+  ( GeneralTransactionMetadata(GeneralTransactionMetadata)
+  , TransactionMetadatum(Text)
+  , TransactionMetadatumLabel(TransactionMetadatumLabel)
+  )
+import Contract.Prim.ByteArray (hexToByteArrayUnsafe)
+import Contract.Test.Mote (TestPlanM, interpretWithConfig)
+import Contract.Test.Utils (exitCode, interruptOnSignal)
+import Contract.Transaction (TransactionHash(TransactionHash))
+import Ctl.Internal.Service.Blockfrost (getTxMetadata, isTxConfirmed)
+import Data.BigInt as BigInt
+import Data.Either (Either(Right), hush)
+import Data.Map as Map
+import Data.Maybe (Maybe(Just, Nothing), fromJust)
+import Data.Posix.Signal (Signal(SIGINT))
+import Data.Time.Duration (Milliseconds(Milliseconds))
+import Data.Tuple.Nested ((/\))
+import Data.UInt as UInt
+import Effect (Effect)
+import Effect.Aff (Aff, cancelWith, effectCanceler, launchAff)
+import Effect.Class.Console (log)
+import Mote (group, test)
+import Partial.Unsafe (unsafePartial)
+import Test.Spec.Assertions (shouldEqual)
+import Test.Spec.Runner (defaultConfig)
+
+-- Run with `spago test --main Test.Ctl.Blockfrost`
+main :: Effect Unit
+main = interruptOnSignal SIGINT =<< launchAff do
+  flip cancelWith (effectCanceler (exitCode 1)) do
+    interpretWithConfig
+      defaultConfig { timeout = Just $ Milliseconds 450_000.0, exit = true }
+      testPlan
+
+fixture1 :: { hash :: TransactionHash, metadata :: GeneralTransactionMetadata }
+fixture1 =
+  { hash: TransactionHash $ hexToByteArrayUnsafe
+      "7a2aff2b7f92f6f8ec3fb2135301c7bfc36fea1489a3ca37fd6066f3155c46ff"
+  , metadata:
+      GeneralTransactionMetadata $ Map.fromFoldable $
+        ( \(label /\ text) ->
+            TransactionMetadatumLabel
+              (unsafePartial $ fromJust $ BigInt.fromString label) /\ Text text
+        )
+          <$>
+            [ "30" /\ "5"
+            , "50" /\
+                "d8799f581c11185d006a64f24e9cf6da987589cd0b166718d3680e63985db370"
+            , "51" /\
+                "3d9fd8799fd8799fd8799f581c70e60f3b5ea7153e0acc7a803e4401d44b8ed1"
+            , "52" /\
+                "bae1c7baaad1a62a72ffd8799fd8799fd8799f581c1e78aae7c90cc36d624f7b"
+            , "53" /\
+                "3bb6d86b52696dc84e490f343eba89005fffffffffa140d8799f00a1401a000f"
+            , "54" /\
+                "32a0ffffd8799fd8799fd8799f581c11185d006a64f24e9cf6da987589cd0b16"
+            , "55" /\
+                "6718d3680e63985db3703dffd8799fd8799fd8799f581cac7d463e54c43d994b"
+            , "56" /\
+                "66d1512d5fb315c7563ae43c37610cd07977c7ffffffffa1581c4e5205e5df36"
+            , "57" /\
+                "8030e9f814c2258c01f50c62375c55b07fbcc076c181d8799f01a0ffffffff,d"
+            , "58" /\
+                "8799f581c11185d006a64f24e9cf6da987589cd0b166718d3680e63985db3703"
+            , "59" /\
+                "d9fd8799fd8799fd8799f581c70e60f3b5ea7153e0acc7a803e4401d44b8ed1b"
+            , "60" /\
+                "ae1c7baaad1a62a72ffd8799fd8799fd8799f581c1e78aae7c90cc36d624f7b3"
+            , "61" /\
+                "bb6d86b52696dc84e490f343eba89005fffffffffa140d8799f00a1401a000f3"
+            , "62" /\
+                "2a0ffffd8799fd8799fd8799f581c11185d006a64f24e9cf6da987589cd0b166"
+            , "63" /\
+                "718d3680e63985db3703dffd8799fd8799fd8799f581cac7d463e54c43d994b6"
+            , "64" /\
+                "6d1512d5fb315c7563ae43c37610cd07977c7ffffffffa1581c4e5205e5df368"
+            , "65" /\
+                "030e9f814c2258c01f50c62375c55b07fbcc076c181d8799f01a0ffffffff,d8"
+            , "66" /\
+                "799f581c11185d006a64f24e9cf6da987589cd0b166718d3680e63985db3703d"
+            , "67" /\
+                "9fd8799fd8799fd8799f581c70e60f3b5ea7153e0acc7a803e4401d44b8ed1ba"
+            , "68" /\
+                "e1c7baaad1a62a72ffd8799fd8799fd8799f581c1e78aae7c90cc36d624f7b3b"
+            , "69" /\
+                "b6d86b52696dc84e490f343eba89005fffffffffa140d8799f00a1401a000f32"
+            , "70" /\
+                "a0ffffd8799fd8799fd8799f581c11185d006a64f24e9cf6da987589cd0b1667"
+            , "71" /\
+                "18d3680e63985db3703dffd8799fd8799fd8799f581cac7d463e54c43d994b66"
+            , "72" /\
+                "d1512d5fb315c7563ae43c37610cd07977c7ffffffffa1581c4e5205e5df3680"
+            , "73" /\
+                "30e9f814c2258c01f50c62375c55b07fbcc076c181d8799f01a0ffffffff,"
+            , "75" /\
+                "4e5205e5df368030e9f814c2258c01f50c62375c55b07fbcc076c181::00"
+            , "76" /\
+                "4e5205e5df368030e9f814c2258c01f50c62375c55b07fbcc076c181::01"
+            , "77" /\
+                "4e5205e5df368030e9f814c2258c01f50c62375c55b07fbcc076c181::02"
+            ]
+  }
+
+config =
+  { host: "cardano-preview.blockfrost.io"
+  , port: UInt.fromInt 443
+  , secure: true
+  , path: Just "/api/v0"
+  }
+
+apiKey = Just ?help
+
+testPlan :: TestPlanM (Aff Unit) Unit
+testPlan = group "Blockfrost" do
+  test "getTxMetadata success" do
+    metadata <- getTxMetadata fixture1.hash config apiKey
+    (hush metadata) `shouldEqual` (Just (Just fixture1.metadata))
+  test "isTxConfirmed success" do
+    confirmed <- isTxConfirmed fixture1.hash config apiKey
+    (hush confirmed) `shouldEqual` (Just true)