[WIP] Plug wallet into Direct chain component

This is needed in order to provide a seed TxIn to the Init
transaction and of course to be able to sign transactions later on.

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

@@ -29,8 +29,9 @@ import Hydra.Chain (
   ChainComponent,
   PostChainTx (..),
  )
-import Hydra.Chain.Direct.Tx (OnChainHeadState (Closed), constructTx, runOnChainTxs)
+import Hydra.Chain.Direct.Tx (OnChainHeadState (..), abortTx, initTx, runOnChainTxs)
 import Hydra.Chain.Direct.Util (Block, Era, defaultCodecs, nullConnectTracers, versions)
+import Hydra.Chain.Direct.Wallet (SigningKey, TinyWallet (..), VerificationKey, withTinyWallet)
 import Hydra.Logging (Tracer)
 import Ouroboros.Consensus.Cardano.Block (GenTx (..), HardForkBlock (BlockAlonzo))
 import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr)
@@ -79,27 +80,31 @@ withDirectChain ::
   IOManager ->
   -- | Path to a domain socket used to connect to the server.
   FilePath ->
+  -- | Key pair for the wallet
+  (VerificationKey, SigningKey) ->
   ChainComponent tx IO ()
-withDirectChain _tracer magic iocp addr callback action = do
+withDirectChain _tracer magic iocp addr keyPair callback action = do
   queue <- newTQueueIO
   headState <- newTVarIO Closed
-  race_
-    (action $ Chain{postTx = atomically . writeTQueue queue})
-    ( connectTo
-        (localSnocket iocp addr)
-        nullConnectTracers
-        (versions magic (client queue headState callback))
-        addr
-    )
+  withTinyWallet magic keyPair iocp addr $ \wallet ->
+    race_
+      (action $ Chain{postTx = atomically . writeTQueue queue})
+      ( connectTo
+          (localSnocket iocp addr)
+          nullConnectTracers
+          (versions magic (client queue headState wallet callback))
+          addr
+      )
 
 client ::
   (MonadST m, MonadTimer m) =>
   TQueue m (PostChainTx tx) ->
   TVar m OnChainHeadState ->
+  TinyWallet m ->
   ChainCallback tx m ->
   NodeToClientVersion ->
   OuroborosApplication 'InitiatorMode LocalAddress LByteString m () Void
-client queue headState callback nodeToClientV =
+client queue headState wallet callback nodeToClientV =
   nodeToClientProtocols
     ( const $
         pure $
@@ -110,7 +115,7 @@ client queue headState callback nodeToClientV =
                    in MuxPeer nullTracer cChainSyncCodec peer
             , localTxSubmissionProtocol =
                 InitiatorProtocolOnly $
-                  let peer = localTxSubmissionClientPeer $ txSubmissionClient queue headState
+                  let peer = localTxSubmissionClientPeer $ txSubmissionClient queue headState wallet
                    in MuxPeer nullTracer cTxSubmissionCodec peer
             , localStateQueryProtocol =
                 InitiatorProtocolOnly $
@@ -178,15 +183,16 @@ txSubmissionClient ::
   MonadSTM m =>
   TQueue m (PostChainTx tx) ->
   TVar m OnChainHeadState ->
+  TinyWallet m ->
   LocalTxSubmissionClient (GenTx Block) (ApplyTxErr Block) m ()
-txSubmissionClient queue headState =
+txSubmissionClient queue headState TinyWallet{getUtxo} =
   LocalTxSubmissionClient clientStIdle
  where
   clientStIdle :: m (LocalTxClientStIdle (GenTx Block) (ApplyTxErr Block) m ())
   clientStIdle = do
     tx <- atomically $ readTQueue queue
-    st <- readTVarIO headState
-    pure $ SendMsgSubmitTx (fromPostChainTx st tx) (const clientStIdle)
+    validatedTx <- fromPostChainTx tx
+    pure $ SendMsgSubmitTx validatedTx (const clientStIdle)
 
   -- FIXME
   -- This is where we need signatures and client credentials. Ideally, we would
@@ -196,11 +202,18 @@ txSubmissionClient queue headState =
   --
   -- For now, it simply does not sign..
   --
-  -- TODO inline constructTx to be able to decide here which side effect to do
-  -- eg. we need to ask the wallet for a TxIn to produce the transaction
-  fromPostChainTx :: OnChainHeadState -> PostChainTx tx -> GenTx Block
-  fromPostChainTx st postChainTx =
-    GenTxAlonzo $ mkShelleyTx $ constructTx st postChainTx
+  fromPostChainTx :: PostChainTx tx -> m (GenTx Block)
+  fromPostChainTx = \case
+    InitTx p -> do
+      txIns <- keys <$> atomically getUtxo
+      case txIns of
+        (seedInput : _) -> pure $ GenTxAlonzo $ mkShelleyTx $ initTx p seedInput
+        [] -> error "cannot find a seed input to pass to Init transaction"
+    AbortTx _utxo -> do
+      readTVarIO headState >>= \case
+        Initial{initials} -> pure $ GenTxAlonzo $ mkShelleyTx $ uncurry abortTx initials
+        st -> error $ "cannot post Abort transaction in state " <> show st
+    _ -> error "not implemented"
 
 --
 -- Helpers

hydra-node/src/Hydra/Chain/Direct/Tx.hs

@@ -28,7 +28,7 @@ import Control.Monad.Class.MonadSTM (stateTVar)
 import qualified Data.Map as Map
 import qualified Data.Sequence.Strict as StrictSeq
 import qualified Data.Set as Set
-import Hydra.Chain (HeadParameters (..), OnChainTx (OnAbortTx, OnInitTx), PostChainTx (..))
+import Hydra.Chain (HeadParameters (..), OnChainTx (OnAbortTx, OnInitTx))
 import qualified Hydra.Contract.Head as Head
 import qualified Hydra.Contract.Initial as Initial
 import Hydra.Data.ContestationPeriod (contestationPeriodFromDiffTime, contestationPeriodToDiffTime)
@@ -67,17 +67,6 @@ data OnChainHeadState
       }
   deriving (Eq, Show, Generic)
 
--- | Construct the Head protocol transactions as Alonzo 'Tx'. Note that
--- 'ValidatedTx' this produces an unbalanced, unsigned transaction and this type
--- was used (in contrast to 'TxBody') to be able to express included datums,
--- onto which at least the 'initTx' relies on.
-constructTx :: OnChainHeadState -> PostChainTx tx -> ValidatedTx Era
-constructTx st tx =
-  case (st, tx) of
-    (Closed, InitTx p) -> initTx p (error "undefined")
-    (Initial{initials}, AbortTx _utxo) -> uncurry abortTx initials
-    _ -> error "not implemented"
-
 -- | Create the init transaction from some 'HeadParameters' and a single TxIn
 -- which will be used as unique parameter for minting NFTs.
 initTx :: HeadParameters -> TxIn StandardCrypto -> ValidatedTx Era

hydra-node/src/Hydra/Chain/Direct/Wallet.hs

@@ -37,7 +37,7 @@ import Hydra.Chain.Direct.Util (
   nullConnectTracers,
   versions,
  )
-import Hydra.Ledger.Cardano (mkVkAddress, signWith)
+import Hydra.Ledger.Cardano (genKeyPair, mkVkAddress, signWith)
 import Hydra.Prelude
 import Ouroboros.Consensus.Cardano.Block (BlockQuery (..), CardanoEras, pattern BlockAlonzo)
 import Ouroboros.Consensus.HardFork.Combinator (MismatchEraInfo)
@@ -77,6 +77,7 @@ import qualified Ouroboros.Network.Protocol.LocalStateQuery.Client as LSQ
 import qualified Shelley.Spec.Ledger.API as Ledger hiding (TxBody, TxOut)
 import Shelley.Spec.Ledger.BlockChain (HashHeader (..))
 import Shelley.Spec.Ledger.TxBody (TxId (..), pattern TxIn)
+import Test.QuickCheck (generate)
 
 type Address = Ledger.Addr StandardCrypto
 type TxBody = Ledger.TxBody Era
@@ -372,3 +373,12 @@ stateQueryClient tipVar utxoVar address =
     -- FIXME: log something before looping back?
     threadDelay 30
     reset
+
+--
+-- Keys
+--
+
+generateKeyPair :: IO (VerificationKey, SigningKey)
+generateKeyPair = do
+  Ledger.KeyPair (Ledger.VKey vk) sk <- generate genKeyPair
+  pure (vk, sk)

hydra-node/test/Hydra/Chain/Direct/TxSpec.hs

@@ -28,8 +28,8 @@ import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Map as Map
 import Data.Maybe (fromJust)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
-import Hydra.Chain (HeadParameters (..), PostChainTx (..), toOnChainTx)
-import Hydra.Chain.Direct.Tx (OnChainHeadState (..), abortTx, constructTx, initTx, observeInitTx, plutusScript, scriptAddr)
+import Hydra.Chain (HeadParameters (..), PostChainTx (..))
+import Hydra.Chain.Direct.Tx (OnChainHeadState (..), abortTx, initTx, plutusScript, scriptAddr)
 import Hydra.Chain.Direct.Util (Era)
 import qualified Hydra.Contract.Head as Head
 import qualified Hydra.Contract.Initial as Initial
@@ -41,7 +41,7 @@ import Plutus.V1.Ledger.Api (PubKeyHash (PubKeyHash), toBuiltin, toBuiltinData,
 import Shelley.Spec.Ledger.API (Coin (Coin), StrictMaybe (SJust), UTxO (UTxO))
 import Test.Cardano.Ledger.Alonzo.PlutusScripts (defaultCostModel)
 import Test.Cardano.Ledger.Alonzo.Serialisation.Generators ()
-import Test.QuickCheck (Gen, counterexample, oneof, (===), (==>))
+import Test.QuickCheck (Gen, counterexample, oneof, (===))
 import Test.QuickCheck.Instances ()
 
 -- TODO(SN): use real max tx size
@@ -51,19 +51,6 @@ maxTxSize = 16000
 spec :: Spec
 spec =
   parallel $ do
-    prop "observeTx . constructTx roundtrip" $ \postTx txIn time ->
-      isImplemented postTx txIn -- TODO(SN): test all constructors
-        ==> fst (observeInitTx (constructTx txIn postTx) Closed) === Just (toOnChainTx @SimpleTx time postTx)
-
-    prop "transaction size below limit" $ \postTx txIn ->
-      isImplemented postTx txIn -- TODO(SN): test all constructors
-        ==> let tx = constructTx @SimpleTx txIn postTx
-                cbor = serialize tx
-                len = LBS.length cbor
-             in counterexample ("Tx: " <> show tx) $
-                  counterexample ("Tx serialized size: " <> show len) $
-                    len < maxTxSize
-
     describe "initTx" $ do
       -- NOTE(SN): We are relying in the inclusion of the datum in the "posting
       -- tx" in order to 'observeTx'. This test is here to make this a bit more

hydra-node/test/Hydra/Chain/DirectSpec.hs

@@ -17,6 +17,7 @@ import Hydra.Chain (
  )
 import Hydra.Chain.Direct (withDirectChain)
 import Hydra.Chain.Direct.MockServer (withMockServer)
+import Hydra.Chain.Direct.Wallet (generateKeyPair)
 import Hydra.Ledger.Simple (SimpleTx)
 import Hydra.Logging (nullTracer)
 import Hydra.Party (Party, deriveParty, generateKey)
@@ -26,9 +27,12 @@ spec = parallel $ do
   it "publishes init tx and observes it also" $ do
     calledBackAlice <- newEmptyMVar
     calledBackBob <- newEmptyMVar
+    aliceKeys <- generateKeyPair
+    bobKeys <- generateKeyPair
+
     withMockServer $ \networkMagic iocp socket _ -> do
-      withDirectChain nullTracer networkMagic iocp socket (putMVar calledBackAlice) $ \Chain{postTx} -> do
-        withDirectChain nullTracer networkMagic iocp socket (putMVar calledBackBob) $ \_ -> do
+      withDirectChain nullTracer networkMagic iocp socket aliceKeys (putMVar calledBackAlice) $ \Chain{postTx} -> do
+        withDirectChain nullTracer networkMagic iocp socket bobKeys (putMVar calledBackBob) $ \_ -> do
           let parameters = HeadParameters 100 [alice, bob, carol]
           postTx $ InitTx @SimpleTx parameters
           failAfter 5 $
@@ -39,9 +43,11 @@ spec = parallel $ do
   it "can init and abort a head given nothing has been committed" $ do
     calledBackAlice <- newEmptyMVar
     calledBackBob <- newEmptyMVar
+    aliceKeys <- generateKeyPair
+    bobKeys <- generateKeyPair
     withMockServer $ \networkMagic iocp socket _ -> do
-      withDirectChain nullTracer networkMagic iocp socket (putMVar calledBackAlice) $ \Chain{postTx} -> do
-        withDirectChain nullTracer networkMagic iocp socket (putMVar calledBackBob) $ \_ -> do
+      withDirectChain nullTracer networkMagic iocp socket aliceKeys (putMVar calledBackAlice) $ \Chain{postTx} -> do
+        withDirectChain nullTracer networkMagic iocp socket bobKeys (putMVar calledBackBob) $ \_ -> do
           let parameters = HeadParameters 100 [alice, bob, carol]
           postTx $ InitTx @SimpleTx parameters
           failAfter 5 $