Merge pull request #46 from input-output-hk/ch1bo/modularize-headlogic

Move multiple types of out HeadLogic

hydra-node/exe/hydra-node/Main.hs

@@ -5,7 +5,6 @@ module Main where
 import Hydra.Prelude
 
 import Hydra.API.Server (withAPIServer)
-import Hydra.Chain.ZeroMQ (createMockChainClient)
 import Hydra.HeadLogic (
   Environment (party),
   Event (..),
@@ -29,6 +28,7 @@ import Hydra.Node (
   runHydraNode,
  )
 import Hydra.Options (Options (..), parseHydraOptions)
+import Hydra.Chain.ZeroMQ (withMockChain)
 
 main :: IO ()
 main = do
@@ -40,12 +40,10 @@ main = do
       -- XXX(SN): this is soo weird, [] and mempty are both `parties`
       let headState = createHeadState [] (HeadParameters 10 mempty)
       hh <- createHydraHead headState Ledger.simpleLedger
-      oc <- createMockChainClient mockChainPorts eq (contramap MockChain tracer)
-      withNetwork (contramap Network tracer) (party env) host port peers (putEvent eq . NetworkEvent) $
-        \hn ->
-          withAPIServer apiHost apiPort (contramap APIServer tracer) (putEvent eq . ClientEvent) $
-            \sendOutput ->
-              runHydraNode (contramap Node tracer) $ HydraNode{eq, hn, hh, oc, sendOutput, env}
+      withMockChain (contramap MockChain tracer) mockChainPorts (putEvent eq . OnChainEvent) $ \oc ->
+        withNetwork (contramap Network tracer) (party env) host port peers (putEvent eq . NetworkEvent) $ \hn ->
+          withAPIServer apiHost apiPort (contramap APIServer tracer) (putEvent eq . ClientEvent) $ \sendOutput ->
+            runHydraNode (contramap Node tracer) $ HydraNode{eq, hn, hh, oc, sendOutput, env}
  where
   withNetwork tracer party host port peers =
     let localhost = Host{hostName = show host, portNumber = port}

hydra-node/hydra-node.cabal

@@ -86,6 +86,7 @@ library
     Hydra.Chain
     Hydra.Chain.ExternalPAB
     Hydra.Chain.ZeroMQ
+    Hydra.ClientInput
     Hydra.HeadLogic
     Hydra.Ledger
     Hydra.Ledger.MaryTest
@@ -96,14 +97,17 @@ library
     Hydra.Network
     Hydra.Network.BroadcastToSelf
     Hydra.Network.Heartbeat
+    Hydra.Network.Message
     Hydra.Network.Ouroboros
-    Hydra.Network.Ouroboros.Type
     Hydra.Network.Ouroboros.Client
     Hydra.Network.Ouroboros.Server
+    Hydra.Network.Ouroboros.Type
     Hydra.Network.ZeroMQ
     Hydra.Node
     Hydra.Node.Version
     Hydra.Options
+    Hydra.ServerOutput
+    Hydra.Snapshot
   other-modules:
     Paths_hydra_node
   build-depends: base

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

@@ -14,13 +14,11 @@ import Control.Concurrent.STM.TChan (newBroadcastTChanIO, writeTChan)
 import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, readTVar)
 import qualified Data.Aeson as Aeson
 import Data.ByteString.Base16 (encodeBase16)
-import Hydra.HeadLogic (
-  ClientInput,
-  ServerOutput (..),
- )
+import Hydra.ClientInput (ClientInput)
 import Hydra.Ledger (Tx (..))
 import Hydra.Logging (Tracer, traceWith)
 import Hydra.Network (IP, PortNumber)
+import Hydra.ServerOutput (ServerOutput (InvalidInput))
 import Network.WebSockets (
   acceptRequest,
   receiveData,

hydra-node/src/Hydra/Chain.hs

@@ -4,7 +4,30 @@ module Hydra.Chain where
 
 import Cardano.Prelude
 import Control.Monad.Class.MonadThrow (MonadThrow)
-import Hydra.HeadLogic (OnChainTx)
+import Data.Aeson (FromJSON, ToJSON)
+import Hydra.Ledger (Party, Tx, UTxO)
+import Hydra.Snapshot (Snapshot)
+
+-- NOTE(SN): Might not be symmetric in a real chain client, i.e. posting
+-- transactions could be parameterized using such data types, but they are not
+-- fully recoverable from transactions observed on chain
+-- REVIEW(SN): There is a similarly named type in plutus-ledger, so we might
+-- want to rename this
+data OnChainTx tx
+  = InitTx [Party] -- NOTE(SN): The order of this list is important for leader selection.
+  | CommitTx Party (UTxO tx)
+  | AbortTx (UTxO tx)
+  | CollectComTx (UTxO tx)
+  | CloseTx (Snapshot tx)
+  | ContestTx (Snapshot tx)
+  | FanoutTx (UTxO tx)
+  deriving stock (Generic)
+
+deriving instance Tx tx => Eq (OnChainTx tx)
+deriving instance Tx tx => Show (OnChainTx tx)
+deriving instance Tx tx => Read (OnChainTx tx)
+deriving instance Tx tx => ToJSON (OnChainTx tx)
+deriving instance Tx tx => FromJSON (OnChainTx tx)
 
 data ChainError = ChainError
   deriving (Exception, Show)
@@ -16,3 +39,9 @@ newtype Chain tx m = Chain
     -- Does at least throw 'ChainError'.
     postTx :: MonadThrow m => OnChainTx tx -> m ()
   }
+
+-- | Handle to interface observed transactions.
+type ChainCallback tx m = OnChainTx tx -> m ()
+
+-- | A type tying both posting and observing transactions into a single /Component/.
+type ChainComponent tx m a = ChainCallback tx m -> (Chain tx m -> m a) -> m a

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

@@ -8,13 +8,13 @@ import Control.Monad.Class.MonadSay (say)
 import Data.Aeson (Result (Error, Success), eitherDecodeStrict)
 import Data.Aeson.Types (fromJSON)
 import qualified Data.Map as Map
-import Hydra.Chain (Chain (Chain, postTx))
-import Hydra.HeadLogic (OnChainTx (InitTx))
+import Hydra.Chain (Chain (Chain, postTx), OnChainTx (InitTx), ChainComponent)
+import Hydra.Contract.PAB (PABContract (GetUtxos, Setup, WatchInit))
 import Hydra.Ledger (Party, Tx)
 import Hydra.Logging (Tracer)
-import Ledger (TxOut (txOutValue), pubKeyHash, txOutTxOut, PubKeyHash)
+import Ledger (PubKeyHash, TxOut (txOutValue), pubKeyHash, txOutTxOut)
 import Ledger.AddressMap (UtxoMap)
-import Ledger.Value as Value
+import Ledger.Value (flattenValue)
 import Network.HTTP.Req (
   HttpException (VanillaHttpException),
   POST (..),
@@ -34,7 +34,6 @@ import Network.WebSockets.Client (runClient)
 import Plutus.PAB.Webserver.Types (InstanceStatusToClient (NewObservableState))
 import Wallet.Emulator.Types (Wallet (..), walletPubKey)
 import Wallet.Types (ContractInstanceId, unContractInstanceId)
-import Hydra.Contract.PAB (PABContract (Setup, GetUtxos, WatchInit))
 
 data ExternalPABLog = ExternalPABLog
   deriving stock (Eq, Show, Generic)
@@ -46,9 +45,7 @@ withExternalPAB ::
   Tx tx =>
   WalletId ->
   Tracer IO ExternalPABLog ->
-  (OnChainTx tx -> IO ()) ->
-  (Chain tx IO -> IO a) ->
-  IO a
+  ChainComponent tx IO ()
 withExternalPAB walletId _tracer callback action = do
   withAsync (initTxSubscriber wallet callback) $ \_ ->
     withAsync (utxoSubscriber wallet) $ \_ -> do

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

@@ -9,15 +9,12 @@ module Hydra.Chain.ZeroMQ where
 
 import Hydra.Prelude
 
-import Control.Monad.Class.MonadAsync (async, link)
 import Control.Monad.Class.MonadSTM (modifyTVar', newTBQueue, newTVarIO, readTBQueue, readTVarIO, writeTBQueue)
 import qualified Data.Text.Encoding as Enc
-import Hydra.Chain (Chain (..))
-import Hydra.HeadLogic (Event (OnChainEvent), OnChainTx)
+import Hydra.Chain (Chain (..), ChainComponent, OnChainTx)
 import Hydra.Ledger (Tx)
 import Hydra.Logging (ToObject, Tracer, traceWith)
 import Hydra.Network (MockChainPorts (..))
-import Hydra.Node (EventQueue (..))
 import System.ZMQ4.Monadic (
   Pub (..),
   Rep (..),
@@ -156,16 +153,14 @@ catchUpTransactions catchUpAddress handler tracer = runZMQ $ do
       forM_ txs handler
     Nothing -> error $ "cannot decode catch-up transactions  " <> show message
 
-createMockChainClient ::
+withMockChain ::
   Tx tx =>
-  MockChainPorts ->
-  EventQueue IO (Event tx) ->
   Tracer IO (MockChainLog tx) ->
-  IO (Chain tx IO)
-createMockChainClient (MockChainPorts (syncPort, catchUpPort, postPort)) EventQueue{putEvent} tracer = do
-  -- TODO: Structure mock chain client as a component
-  catchUpTransactions ("tcp://127.0.0.1:" <> show catchUpPort) onTx tracer
-  link =<< async (runChainSync ("tcp://127.0.0.1:" <> show syncPort) onTx tracer)
-  pure Chain{postTx = mockChainClient ("tcp://127.0.0.1:" <> show postPort) tracer}
+  MockChainPorts ->
+  ChainComponent tx IO ()
+withMockChain tracer (MockChainPorts (syncPort, catchUpPort, postPort)) callback action = do
+  catchUpTransactions ("tcp://127.0.0.1:" <> show catchUpPort) callback tracer
+  runChainSync ("tcp://127.0.0.1:" <> show syncPort) callback tracer
+    `race_` action chain
  where
-  onTx tx = putEvent $ OnChainEvent tx
+  chain = Chain{postTx = mockChainClient ("tcp://127.0.0.1:" <> show postPort) tracer}

hydra-node/src/Hydra/ClientInput.hs

@@ -0,0 +1,79 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Hydra.ClientInput where
+
+import Data.Aeson (object, withObject, (.:), (.=))
+import qualified Data.Aeson as Aeson
+import Hydra.Ledger (Tx, UTxO)
+import Hydra.Prelude
+
+data ClientInput tx
+  = Init
+  | Abort
+  | Commit (UTxO tx)
+  | NewTx tx
+  | GetUtxo
+  | Close
+  | Contest
+  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 -> []
+    Abort -> []
+    Commit xs -> Commit <$> shrink xs
+    NewTx tx -> NewTx <$> shrink tx
+    GetUtxo -> []
+    Close -> []
+    Contest -> []
+
+instance Tx tx => ToJSON (ClientInput tx) where
+  toJSON = \case
+    Init ->
+      object [tagFieldName .= s "init"]
+    Abort ->
+      object [tagFieldName .= s "abort"]
+    Commit u ->
+      object [tagFieldName .= s "commit", "utxo" .= u]
+    NewTx tx ->
+      object [tagFieldName .= s "newTransaction", "transaction" .= tx]
+    GetUtxo ->
+      object [tagFieldName .= s "getUtxo"]
+    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
+      "abort" ->
+        pure Abort
+      "commit" ->
+        Commit <$> (obj .: "utxo")
+      "newTransaction" ->
+        NewTx <$> (obj .: "transaction")
+      "getUtxo" ->
+        pure GetUtxo
+      "close" ->
+        pure Close
+      "contest" ->
+        pure Contest
+      _ ->
+        fail $ "unknown input type: " <> toString @Text tag