Merge pull request #29 from input-output-hk/KtorZ/JSON-for-interface

Use structured JSON for interfacing with 'ClientRequest' / 'ClientResponse'

hydra-node/hydra-node.cabal

@@ -101,9 +101,8 @@ library
     Hydra.Options
   other-modules:
     Paths_hydra_node
-  build-depends:
-      aeson
-    , base
+  build-depends: base
+    , aeson
     , cardano-binary
     , cardano-crypto-class
     , cardano-ledger-core
@@ -188,8 +187,8 @@ test-suite tests
     Test.Util
   main-is: Main.hs
   type: exitcode-stdio-1.0
-  build-depends:
-      base
+  build-depends: base
+    , aeson
     , cardano-binary
     , cardano-crypto-class
     , cborg

hydra-node/src/Hydra/API/Server.hs

@@ -11,30 +11,31 @@ import Hydra.Prelude
 import Control.Concurrent.STM (TChan, dupTChan, readTChan)
 import qualified Control.Concurrent.STM as STM
 import Control.Concurrent.STM.TChan (newBroadcastTChanIO, writeTChan)
+import qualified Data.Aeson as Aeson
 import Hydra.HeadLogic (
-  ClientRequest,
-  ClientResponse,
+  ClientInput,
+  ServerOutput,
  )
-import Hydra.Ledger (Tx)
+import Hydra.Ledger (Tx (..))
 import Hydra.Logging (Tracer, traceWith)
 import Hydra.Network (IP, PortNumber)
 import Network.WebSockets (acceptRequest, receiveData, runServer, sendTextData, withPingThread)
 
 data APIServerLog
   = APIServerStarted {listeningPort :: PortNumber}
   | NewAPIConnection
-  | APIResponseSent {sentResponse :: Text}
-  | APIRequestReceived {receivedRequest :: Text}
-  | APIInvalidRequest {receivedRequest :: Text}
+  | APIResponseSent {sentResponse :: LByteString}
+  | APIRequestReceived {receivedRequest :: LByteString}
+  | APIInvalidRequest {receivedRequest :: LByteString}
   deriving (Eq, Show)
 
 withAPIServer ::
   Tx tx =>
   IP ->
   PortNumber ->
   Tracer IO APIServerLog ->
-  (ClientRequest tx -> IO ()) ->
-  ((ClientResponse tx -> IO ()) -> IO ()) ->
+  (ClientInput tx -> IO ()) ->
+  ((ServerOutput tx -> IO ()) -> IO ()) ->
   IO ()
 withAPIServer host port tracer requests continuation = do
   responseChannel <- newBroadcastTChanIO
@@ -48,8 +49,8 @@ runAPIServer ::
   IP ->
   PortNumber ->
   Tracer IO APIServerLog ->
-  (ClientRequest tx -> IO ()) ->
-  TChan (ClientResponse tx) ->
+  (ClientInput tx -> IO ()) ->
+  TChan (ServerOutput tx) ->
   IO ()
 runAPIServer host port tracer requestHandler responseChannel = do
   traceWith tracer (APIServerStarted port)
@@ -62,13 +63,13 @@ runAPIServer host port tracer requestHandler responseChannel = do
  where
   sendResponses chan con = forever $ do
     response <- STM.atomically $ readTChan chan
-    let sentResponse = show response
+    let sentResponse = Aeson.encode response
     sendTextData con sentResponse
     traceWith tracer (APIResponseSent sentResponse)
 
   receiveRequests con = forever $ do
     msg <- receiveData con
-    case readEither (toString msg) of
+    case Aeson.eitherDecode msg of
       Right request -> do
         traceWith tracer (APIRequestReceived msg)
         requestHandler request

hydra-node/src/Hydra/Chain/ExternalPAB.hs

@@ -5,7 +5,7 @@ module Hydra.Chain.ExternalPAB where
 import Hydra.Prelude
 
 import Control.Monad.Class.MonadSay (say)
-import Data.Aeson (Result (Error, Success), ToJSON, eitherDecodeStrict)
+import Data.Aeson (Result (Error, Success), eitherDecodeStrict)
 import Data.Aeson.Types (fromJSON)
 import qualified Data.Map as Map
 import Hydra.Chain (Chain (Chain, postTx))

hydra-node/src/Hydra/HeadLogic.hs

@@ -6,8 +6,9 @@ module Hydra.HeadLogic where
 
 import Hydra.Prelude
 
-import Cardano.Binary (FromCBOR (..), ToCBOR (..))
 import Cardano.Crypto.Util (SignableRepresentation (..))
+import Data.Aeson (object, withObject, (.:), (.=))
+import qualified Data.Aeson as Aeson
 import Data.List (elemIndex, (\\))
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
@@ -26,31 +27,78 @@ import Hydra.Ledger (
  )
 
 data Event tx
-  = ClientEvent (ClientRequest tx)
+  = ClientEvent (ClientInput tx)
   | NetworkEvent (HydraMessage tx)
   | OnChainEvent (OnChainTx tx)
   | ShouldPostFanout
   deriving (Eq, Show)
 
 data Effect tx
-  = ClientEffect (ClientResponse tx)
+  = ClientEffect (ServerOutput tx)
   | NetworkEffect (HydraMessage tx)
   | OnChainEffect (OnChainTx tx)
   | Delay DiffTime (Event tx)
 
 deriving instance Tx tx => Eq (Effect tx)
 deriving instance Tx tx => Show (Effect tx)
 
-data ClientRequest tx
+data ClientInput tx
   = Init
   | Commit (UTxO tx)
   | NewTx tx
   | Close
   | Contest
-
-deriving instance Tx tx => Eq (ClientRequest tx)
-deriving instance Tx tx => Show (ClientRequest tx)
-deriving instance Tx tx => Read (ClientRequest tx)
+  deriving (Generic)
+
+deriving instance Tx tx => Eq (ClientInput tx)
+deriving instance Tx tx => Show (ClientInput tx)
+deriving instance Tx tx => Read (ClientInput tx)
+
+instance (Arbitrary tx, Arbitrary (UTxO tx)) => Arbitrary (ClientInput tx) where
+  arbitrary = genericArbitrary
+
+  -- NOTE: Somehow, can't use 'genericShrink' here as GHC is complaining about
+  -- Overlapping instances with 'UTxO tx' even though for a fixed `tx`, there
+  -- should be only one 'UTxO tx'
+  shrink = \case
+    Init -> []
+    Commit xs -> Commit <$> shrink xs
+    NewTx tx -> NewTx <$> shrink tx
+    Close -> []
+    Contest -> []
+
+instance Tx tx => ToJSON (ClientInput tx) where
+  toJSON = \case
+    Init ->
+      object [tagFieldName .= s "init"]
+    Commit u ->
+      object [tagFieldName .= s "commit", "utxo" .= u]
+    NewTx tx ->
+      object [tagFieldName .= s "newTransaction", "transaction" .= tx]
+    Close ->
+      object [tagFieldName .= s "close"]
+    Contest ->
+      object [tagFieldName .= s "contest"]
+   where
+    s = Aeson.String
+    tagFieldName = "input"
+
+instance Tx tx => FromJSON (ClientInput tx) where
+  parseJSON = withObject "ClientInput" $ \obj -> do
+    tag <- obj .: "input"
+    case tag of
+      "init" ->
+        pure Init
+      "commit" ->
+        Commit <$> (obj .: "utxo")
+      "newTransaction" ->
+        NewTx <$> (obj .: "transaction")
+      "close" ->
+        pure Close
+      "contest" ->
+        pure Contest
+      _ ->
+        fail $ "unknown input type: " <> toString @Text tag
 
 type SnapshotNumber = Natural
 
@@ -60,15 +108,41 @@ data Snapshot tx = Snapshot
   , -- | The set of transactions that lead to 'utxo'
     confirmed :: [tx]
   }
+  deriving (Generic)
 
 deriving instance Tx tx => Eq (Snapshot tx)
 deriving instance Tx tx => Show (Snapshot tx)
 deriving instance Tx tx => Read (Snapshot tx)
 
+instance (Arbitrary tx, Arbitrary (UTxO tx)) => Arbitrary (Snapshot tx) where
+  arbitrary = genericArbitrary
+
+  -- NOTE: See note on 'Arbitrary (ClientInput tx)'
+  shrink s =
+    [ Snapshot (number s) utxo' confirmed'
+    | utxo' <- shrink (utxo s)
+    , confirmed' <- shrink (confirmed s)
+    ]
+
 instance Tx tx => SignableRepresentation (Snapshot tx) where
   getSignableRepresentation = encodeUtf8 . show @Text
 
-data ClientResponse tx
+instance Tx tx => ToJSON (Snapshot tx) where
+  toJSON s =
+    object
+      [ "snapshotNumber" .= number s
+      , "utxo" .= utxo s
+      , "confirmedTransactions" .= confirmed s
+      ]
+
+instance Tx tx => FromJSON (Snapshot tx) where
+  parseJSON = withObject "Snapshot" $ \obj ->
+    Snapshot
+      <$> (obj .: "snapshotNumber")
+      <*> (obj .: "utxo")
+      <*> (obj .: "confirmedTransactions")
+
+data ServerOutput tx
   = PeerConnected Party
   | PeerDisconnected Party
   | ReadyToCommit [Party]
@@ -79,10 +153,84 @@ data ClientResponse tx
   | TxSeen tx
   | TxInvalid tx
   | SnapshotConfirmed SnapshotNumber
-
-deriving instance Tx tx => Eq (ClientResponse tx)
-deriving instance Tx tx => Show (ClientResponse tx)
-deriving instance Tx tx => Read (ClientResponse tx)
+  deriving (Generic)
+
+deriving instance Tx tx => Eq (ServerOutput tx)
+deriving instance Tx tx => Show (ServerOutput tx)
+deriving instance Tx tx => Read (ServerOutput tx)
+
+instance (Arbitrary tx, Arbitrary (UTxO tx)) => Arbitrary (ServerOutput tx) where
+  arbitrary = genericArbitrary
+
+  -- NOTE: See note on 'Arbitrary (ClientInput tx)'
+  shrink = \case
+    PeerConnected p -> PeerConnected <$> shrink p
+    PeerDisconnected p -> PeerDisconnected <$> shrink p
+    ReadyToCommit xs -> ReadyToCommit <$> shrink xs
+    HeadIsOpen u -> HeadIsOpen <$> shrink u
+    HeadIsClosed t s -> HeadIsClosed t <$> shrink s
+    HeadIsFinalized u -> HeadIsFinalized <$> shrink u
+    CommandFailed -> []
+    TxSeen tx -> TxSeen <$> shrink tx
+    TxInvalid tx -> TxInvalid <$> shrink tx
+    SnapshotConfirmed{} -> []
+
+instance (ToJSON tx, ToJSON (Snapshot tx), ToJSON (UTxO tx)) => ToJSON (ServerOutput tx) where
+  toJSON = \case
+    PeerConnected peer ->
+      object [tagFieldName .= s "peerConnected", "peer" .= peer]
+    PeerDisconnected peer ->
+      object [tagFieldName .= s "peerDisconnected", "peer" .= peer]
+    ReadyToCommit parties ->
+      object [tagFieldName .= s "readyToCommit", "parties" .= parties]
+    HeadIsOpen utxo ->
+      object [tagFieldName .= s "headIsOpen", "utxo" .= utxo]
+    HeadIsClosed contestationPeriod latestSnapshot ->
+      object
+        [ tagFieldName .= s "headIsClosed"
+        , "contestationPeriod" .= contestationPeriod
+        , "latestSnapshot" .= latestSnapshot
+        ]
+    HeadIsFinalized utxo ->
+      object [tagFieldName .= s "headIsFinalized", "utxo" .= utxo]
+    CommandFailed ->
+      object [tagFieldName .= s "commandFailed"]
+    TxSeen tx ->
+      object [tagFieldName .= s "transactionSeen", "transaction" .= tx]
+    TxInvalid tx ->
+      object [tagFieldName .= s "transactionInvalid", "transaction" .= tx]
+    SnapshotConfirmed snapshotNumber ->
+      object [tagFieldName .= s "snapshotConfirmed", "snapshotNumber" .= snapshotNumber]
+   where
+    s = Aeson.String
+    tagFieldName = "output"
+
+instance (FromJSON tx, FromJSON (Snapshot tx), FromJSON (UTxO tx)) => FromJSON (ServerOutput tx) where
+  parseJSON = withObject "ServerOutput" $ \obj -> do
+    tag <- obj .: "output"
+    case tag of
+      "peerConnected" ->
+        PeerConnected <$> (obj .: "peer")
+      "peerDisconnected" ->
+        PeerDisconnected <$> (obj .: "peer")
+      "readyToCommit" ->
+        ReadyToCommit <$> (obj .: "parties")
+      "headIsOpen" ->
+        HeadIsOpen <$> (obj .: "utxo")
+      "headIsClosed" ->
+        HeadIsClosed <$> (obj .: "contestationPeriod") <*> (obj .: "latestSnapshot")
+      "headIsFinalized" ->
+        HeadIsFinalized <$> (obj .: "utxo")
+      "commandFailed" ->
+        pure CommandFailed
+      "transactionSeen" ->
+        TxSeen <$> (obj .: "transaction")
+      "transactionInvalid" ->
+        TxInvalid <$> (obj .: "transaction")
+      "snapshotConfirmed" ->
+        SnapshotConfirmed <$> (obj .: "snapshotNumber")
+      _ ->
+        fail $ "unknown output type: " <> toString @Text tag
 
 -- NOTE(SN): Every message comes from a 'Party', we might want to move it out of
 -- here into the 'NetworkEvent'
@@ -92,9 +240,7 @@ data HydraMessage tx
   | AckSn Party (Signed (Snapshot tx)) SnapshotNumber
   | Connected Party
   | Disconnected Party
-  deriving (Eq, Show)
-
-deriving stock instance Generic (HydraMessage tx)
+  deriving (Generic, Eq, Show)
 
 instance (ToCBOR tx, ToCBOR (UTxO tx)) => ToCBOR (HydraMessage tx) where
   toCBOR = \case

hydra-node/src/Hydra/Ledger.hs

@@ -1,19 +1,20 @@
+{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-deprecations #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Hydra.Ledger where
 
-import Cardano.Binary (FromCBOR (fromCBOR), ToCBOR (toCBOR))
+import Hydra.Prelude
+
 import Cardano.Crypto.DSIGN (DSIGNAlgorithm (..), MockDSIGN, SignKeyDSIGN, VerKeyDSIGN (VerKeyMockDSIGN), signDSIGN)
 import Cardano.Crypto.Util (SignableRepresentation)
-import Hydra.Prelude hiding (show)
 
 -- NOTE(MB): We probably want to move these common types somewhere else. Putting
 -- here to avoid circular dependencies with Hydra.Logic
 
 -- | Identifies a party in a Hydra head.
 newtype Party = UnsafeParty (VerKeyDSIGN MockDSIGN)
-  deriving (Eq)
+  deriving stock (Eq, Generic)
   deriving newtype (Show, Read, Num)
 
 deriving instance Read (VerKeyDSIGN MockDSIGN)
@@ -22,6 +23,15 @@ instance Ord Party where
   (UnsafeParty a) <= (UnsafeParty b) =
     rawSerialiseVerKeyDSIGN a <= rawSerialiseVerKeyDSIGN b
 
+instance Arbitrary Party where
+  arbitrary = deriveParty . generateKey <$> arbitrary
+
+instance ToJSON Party where
+  toJSON (UnsafeParty (VerKeyMockDSIGN i)) = toJSON i
+
+instance FromJSON Party where
+  parseJSON = fmap fromInteger . parseJSON
+
 instance FromCBOR Party where
   fromCBOR = UnsafeParty <$> fromCBOR
 
@@ -68,6 +78,10 @@ class
   , Read (UTxO tx)
   , Monoid (UTxO tx)
   , Typeable tx
+  , FromJSON tx
+  , FromJSON (UTxO tx)
+  , ToJSON tx
+  , ToJSON (UTxO tx)
   ) =>
   Tx tx
   where