Merge pull request #52 from blockfrost/srk/ogmiosV5

Fix ogmios v5 txEvaluate response

blockfrost-api/CHANGELOG.md

@@ -1,4 +1,10 @@
-# Version [next](https://github.com/blockfrost/blockfrost-haskell/compare/api-0.9.0.0...master) (2024-mm-dd)
+# Version [0.10.0.0](https://github.com/blockfrost/blockfrost-haskell/compare/api-0.9.0.0...api-0.10.0.0) (2024-02-16)
+
+* Fixed
+  * Handling of Ogmios v5 `txEvaluate` response [#52](https://github.com/blockfrost/blockfrost-haskell/pull/52)
+    `TxEvalResult` is no more and instead we add `TxEvalValidator`
+    and `TxEvalFailure`. `TxEval` newtype now has a single `result` field
+    of type `Either TxEvalFailure (Map TxEvalValidator TxEvalBudget)`
 
 # Version [0.9.0.0](https://github.com/blockfrost/blockfrost-haskell/compare/api-0.8.1.0...api-0.9.0.0) (2023-12-18)
 

blockfrost-api/blockfrost-api.cabal

@@ -1,6 +1,6 @@
 cabal-version:       2.2
 name:                blockfrost-api
-version:             0.9.0.0
+version:             0.10.0.0
 synopsis:            API definitions for blockfrost.io
 description:         Core types and Servant API description
 homepage:            https://github.com/blockfrost/blockfrost-haskell

blockfrost-api/src/Blockfrost/Lens.hs

@@ -83,8 +83,8 @@ makeFields ''TransactionRedeemer
 
 makeFields ''DerivedAddress
 makeFields ''TxEval
+makeFields ''TxEvalValidator
 makeFields ''TxEvalBudget
-makeFields ''TxEvalResult
 makeFields ''TxEvalInput
 
 makeLensesWith blockfrostFieldRules ''IPFSAdd

blockfrost-api/src/Blockfrost/Types/Cardano/Utils.hs

@@ -4,29 +4,38 @@
 module Blockfrost.Types.Cardano.Utils
   ( DerivedAddress (..)
   , TxEval (..)
+  , TxEvalValidator (..)
   , TxEvalBudget (..)
-  , TxEvalResult (..)
   , evalSample
-  , resultSample
   , TxEvalInput (..)
   ) where
 
 import Data.Aeson
   ( FromJSON (..)
+  , FromJSONKey (..)
   , ToJSON (..)
+  , ToJSONKey (..)
   , Value (Array)
   , object
   , withObject
+  , withText
   , (.:)
   , (.:?)
   , (.=)
   )
+import Data.Aeson.Types (FromJSONKeyFunction(..), Parser)
 
 import Blockfrost.Types.Shared.CBOR (CBORString(..))
+import Blockfrost.Types.Shared.ValidationPurpose (ValidationPurpose(..))
 import Data.Text (Text)
+import Data.Map (Map)
 import Deriving.Aeson
 import Servant.Docs (ToSample (..), singleSample)
+import qualified Data.Aeson.Types
 import qualified Data.Char
+import qualified Data.Text
+import qualified Data.Map.Strict
+import qualified Text.Read
 
 -- | Derived Shelley address
 data DerivedAddress = DerivedAddress
@@ -48,68 +57,142 @@ instance ToSample DerivedAddress where
       , _derivedAddressAddress = "addr1q90sqnljxky88s0jsnps48jd872p7znzwym0jpzqnax6qs5nfrlkaatu28n0qzmqh7f2cpksxhpc9jefx3wrl0a2wu8q5amen7"
       }
 
+-- * TxEval
+
+data TxEvalValidator = TxEvalValidator
+  { _txEvalValidatorPurpose :: ValidationPurpose
+  , _txEvalValidatorIndex :: Int
+  }
+  deriving stock (Eq, Ord, Show, Generic)
+
+instance ToJSON TxEvalValidator where
+  toJSON = toJSON . mkOgmiosValidator
+
+instance ToJSONKey TxEvalValidator where
+  toJSONKey = Data.Aeson.Types.toJSONKeyText mkOgmiosValidator
+
+mkOgmiosValidator
+  :: TxEvalValidator
+  -> Text
+mkOgmiosValidator TxEvalValidator{..} =
+  (    toOgmiosPurpose _txEvalValidatorPurpose
+    <> ":"
+    <> Data.Text.pack (show _txEvalValidatorIndex)
+  )
+instance FromJSON TxEvalValidator where
+  parseJSON =
+    withText
+      "TxEvalValidator"
+      parseOgmiosValidator
+
+instance FromJSONKey TxEvalValidator where
+  fromJSONKey = FromJSONKeyTextParser parseOgmiosValidator
+
+parseOgmiosValidator
+  :: Text
+  -> Parser TxEvalValidator
+parseOgmiosValidator =
+      (\case
+         [purpose, index] ->
+            case fromOgmiosPurpose purpose of
+              Right p ->
+                case Text.Read.readMaybe (Data.Text.unpack index) of
+                  Nothing -> fail $ "Expecting numeric index, got " <> (Data.Text.unpack index)
+                  Just idx -> pure $ TxEvalValidator p idx
+              Left e ->
+                fail e
+         x -> fail $ "Expecting [purpose, index], got " <> show x
+      .  Data.Text.splitOn ":"
+      )
+
+toOgmiosPurpose
+  :: ValidationPurpose
+  -> Text
+toOgmiosPurpose Spend = "spend"
+toOgmiosPurpose Mint = "mint"
+toOgmiosPurpose Cert = "publish"
+toOgmiosPurpose Reward = "withdraw"
+
+fromOgmiosPurpose
+  :: Text
+  -> Either String ValidationPurpose
+fromOgmiosPurpose "spend" = Right Spend
+fromOgmiosPurpose "mint" = Right Mint
+fromOgmiosPurpose "publish" = Right Cert
+fromOgmiosPurpose "withdraw" = Right Reward
+fromOgmiosPurpose x =
+  Left
+    $ "Don't know how to handle Ogmios validation purpose: " 
+      <> Data.Text.unpack x
+
+validatorSample :: TxEvalValidator
+validatorSample =
+  TxEvalValidator
+    { _txEvalValidatorPurpose = Spend
+    , _txEvalValidatorIndex = 0
+    }
+
+instance ToSample TxEvalValidator where
+  toSamples = pure $ singleSample validatorSample
+
 data TxEvalBudget = TxEvalBudget
   { _txEvalBudgetMemory :: Integer -- ^ Memory budget
-  , _txEvalBudgetCPU    :: Integer -- ^ CPU budget
+  , _txEvalBudgetSteps  :: Integer -- ^ CPU budget
   }
   deriving stock (Show, Eq, Generic)
   deriving (FromJSON, ToJSON)
   via CustomJSON '[FieldLabelModifier '[StripPrefix "_txEvalBudget", CamelToSnake]] TxEvalBudget
 
-instance ToSample TxEvalBudget where
-  toSamples = pure $ singleSample
-    TxEvalBudget
-      { _txEvalBudgetMemory = 1700
-      , _txEvalBudgetCPU    = 476468
+budgetSample :: TxEvalBudget
+budgetSample =
+  TxEvalBudget
+      { _txEvalBudgetMemory = 1765011
+      , _txEvalBudgetSteps  = 503871230
       }
 
--- | Transaction evaluation result
-data TxEvalResult = TxEvalResult
-  { _txEvalResultValidator :: Text         -- ^ Redeemer pointer
-  , _txEvalResultBudget    :: TxEvalBudget -- ^ Budget
-  }
+instance ToSample TxEvalBudget where
+  toSamples = pure $ singleSample budgetSample
+
+data TxEvalFailure = TxEvalFailure Value
   deriving stock (Show, Eq, Generic)
   deriving (FromJSON, ToJSON)
-  via CustomJSON '[FieldLabelModifier '[StripPrefix "_txEvalResult", CamelToSnake]] TxEvalResult
-
-resultSample :: TxEvalResult
-resultSample =
-  TxEvalResult
-    { _txEvalResultValidator = "spend:0"
-    , _txEvalResultBudget =
-        TxEvalBudget
-          { _txEvalBudgetMemory = 1700
-          , _txEvalBudgetCPU    = 476468
-          }
-    }
-
-instance ToSample TxEvalResult where
-  toSamples = pure $ singleSample resultSample
 
 -- | Transaction evaluation result wrapper
-newtype TxEval = TxEval { _txEvalResult :: [TxEvalResult] }
+newtype TxEval = TxEval
+  { _txEvalResult ::
+      Either
+        TxEvalFailure
+        (Map
+          TxEvalValidator
+          TxEvalBudget)
+  }
   deriving stock (Show, Eq, Generic)
 
 instance ToJSON TxEval where
   toJSON TxEval{..} =
     object
-      [ "jsonrpc" .= ("2.0" :: Text)
-      , "method" .= ("evaluateTransaction" :: Text)
+      [ "type" .= ("jsonwsp/response" :: Text)
+      , "version" .= ("1.0" :: Text)
+      , "servicename" .= ("ogmios" :: Text)
+      , "methodname" .= ("EvaluateTx" :: Text)
       , "result" .= toJSON _txEvalResult
       ]
 
 instance FromJSON TxEval where
   parseJSON = withObject "txEval" $ \o -> do
-    (mErr :: Maybe Value) <- o .:? "error"
-    case mErr of
-      Just err -> fail $ show err
-      Nothing -> pure ()
-
     r <- o .: "result"
-    TxEval <$> parseJSON r
+    mEvalResult <- r .:? "EvaluationResult"
+    case mEvalResult of
+      Nothing -> TxEval . Left . TxEvalFailure <$> r .: "EvaluationFailure"
+      Just evalRes -> TxEval . Right <$> parseJSON evalRes
 
 evalSample :: TxEval
-evalSample = TxEval (pure resultSample)
+evalSample =
+  TxEval
+    $ Right
+        (Data.Map.Strict.fromList
+          [(validatorSample, budgetSample)]
+        )
 
 instance ToSample TxEval where
   toSamples = pure $ singleSample evalSample

blockfrost-api/src/Blockfrost/Types/Shared/ValidationPurpose.hs

@@ -10,7 +10,7 @@ import Blockfrost.Types.Shared.Opts
 
 -- | Validation purpose
 data ValidationPurpose = Spend | Mint | Cert | Reward
-  deriving stock (Show, Eq, Generic)
+  deriving stock (Eq, Ord, Show, Generic)
   deriving (FromJSON, ToJSON)
   via CustomJSON '[ConstructorTagModifier '[ToLower]] ValidationPurpose