Alter to/from json instances for RestServerOutput

input-output-hk · Jun 5, 2023 · 0ff1809 · 0ff1809
1 parent 5e13eac
commit 0ff1809
Show file tree

Hide file tree

Showing 4 changed files with 31 additions and 5 deletions.
diff --git a/hydra-cluster/hydra-cluster.cabal b/hydra-cluster/hydra-cluster.cabal
@@ -127,6 +127,7 @@ library
     , cardano-ledger-core
     , cardano-ledger-shelley
     , cardano-slotting
+    , cborg
     , containers
     , contra-tracer
     , data-default

diff --git a/hydra-cluster/src/Hydra/Cluster/Scenarios.hs b/hydra-cluster/src/Hydra/Cluster/Scenarios.hs
@@ -12,7 +12,8 @@ import Data.Aeson (Value, object, (.=))
 import Data.Aeson.Lens (key, _JSON)
 import Data.Aeson.Types (parseMaybe)
 import qualified Data.Set as Set
-import Hydra.API.Server (RestClientInput (..), RestServerOutput (DraftedCommitTx))
+import Hydra.API.ClientInput (RestClientInput (..))
+import Hydra.API.ServerOutput (RestServerOutput (DraftedCommitTx))
 import Hydra.Cardano.Api (
   Lovelace,
   TxId,

diff --git a/hydra-node/src/Hydra/API/Server.hs b/hydra-node/src/Hydra/API/Server.hs
@@ -21,6 +21,7 @@ import Hydra.API.Projection (Projection (..), mkProjection)
 import Hydra.API.ServerOutput (
   HeadStatus (Idle),
   OutputFormat (..),
+  RestServerOutput (DraftedCommitTx),
   ServerOutput (Greetings, InvalidInput),
   ServerOutputConfig (..),
   TimedServerOutput (..),
@@ -235,7 +236,7 @@ runAPIServer host port party tracer history chain callback headStatusP snapshotU
               case eCommitTx of
                 Left err -> responseLBS status400 [] (show err)
                 Right commitTx -> do
-                  let encodedRestOutput = Aeson.encode commitTx
+                  let encodedRestOutput = Aeson.encode $ DraftedCommitTx commitTx
                   responseLBS status200 [] encodedRestOutput
       _ -> do
         traceWith tracer $

diff --git a/hydra-node/src/Hydra/API/ServerOutput.hs b/hydra-node/src/Hydra/API/ServerOutput.hs
@@ -2,9 +2,10 @@
 
 module Hydra.API.ServerOutput where
 
-import Cardano.Binary (serialize')
+import Cardano.Binary (decodeFull', serialize')
 import Control.Lens ((.~))
 import Data.Aeson (Value (..), defaultOptions, encode, genericParseJSON, genericToJSON, omitNothingFields, withObject, (.:))
+import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.KeyMap as KeyMap
 import Data.Aeson.Lens (atKey, key)
 import qualified Data.ByteString.Base16 as Base16
@@ -155,8 +156,30 @@ newtype RestServerOutput tx = DraftedCommitTx
 
 deriving stock instance IsTx tx => Eq (RestServerOutput tx)
 deriving stock instance IsTx tx => Show (RestServerOutput tx)
-deriving newtype instance IsTx tx => ToJSON (RestServerOutput tx)
-deriving newtype instance IsTx tx => FromJSON (RestServerOutput tx)
+
+instance (IsTx tx, ToCBOR tx) => ToJSON (RestServerOutput tx) where
+  toJSON (DraftedCommitTx tx) =
+    Aeson.object
+      [ "tag" Aeson..= Aeson.String "RestServerOutput"
+      , "commitTx" Aeson..= (String . decodeUtf8 . Base16.encode $ serialize' tx)
+      ]
+
+instance
+  (IsTx tx, FromCBOR tx) =>
+  FromJSON (RestServerOutput tx)
+  where
+  parseJSON = withObject "RestServerOutput" $ \o -> do
+    tag <- o .: "tag"
+    case tag :: Text of
+      "RestServerOutput" -> do
+        encodedTx :: Text <- o .: "commitTx"
+        case Base16.decode $ encodeUtf8 encodedTx of
+          Left e -> fail e
+          Right commitTx ->
+            case decodeFull' commitTx of
+              Left err -> fail $ show err
+              Right v -> pure $ DraftedCommitTx v
+      _ -> fail "Expected tag to be PubKeyHash"
 
 instance IsTx tx => Arbitrary (RestServerOutput tx) where
   arbitrary = genericArbitrary