Merge branch 'master' into abailly-iohk/introduce-adrs

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

@@ -35,7 +35,7 @@ main = do
     withMonitoring monitoringPort tracer' $ \tracer -> do
       let env = Environment nodeId
       eq <- createEventQueue
-      let headState = createHeadState [] (HeadParameters 3 []) SnapshotStrategy
+      let headState = createHeadState [] (HeadParameters 3 mempty) NoSnapshots
       hh <- createHydraHead headState Ledger.mockLedger
       oc <- createMockChainClient eq (contramap MockChain tracer)
       withOuroborosHydraNetwork (show host, port) peers (putEvent eq . NetworkEvent) $ \hn -> do

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

@@ -6,11 +6,11 @@ module Hydra.API.Server where
 import Cardano.Prelude hiding (Option, option)
 import Control.Concurrent.STM (TChan, dupTChan, readTChan)
 import qualified Data.Text as Text
-import Hydra.Ledger (UTxO)
-import Hydra.Logging (Tracer, traceWith)
 import Hydra.HeadLogic (
   ClientResponse,
  )
+import Hydra.Ledger (Tx)
+import Hydra.Logging (Tracer, traceWith)
 import Hydra.Network (IP, PortNumber)
 import Hydra.Node (
   HydraNode (..),
@@ -26,7 +26,15 @@ data APIServerLog
   | APIInvalidRequest {receivedRequest :: Text}
   deriving (Show)
 
-runAPIServer :: (Show tx, Read tx, Show (UTxO tx)) => IP -> PortNumber -> TChan (ClientResponse tx) -> HydraNode tx IO -> Tracer IO APIServerLog -> IO ()
+runAPIServer ::
+  Tx tx =>
+  Read tx =>
+  IP ->
+  PortNumber ->
+  TChan (ClientResponse tx) ->
+  HydraNode tx IO ->
+  Tracer IO APIServerLog ->
+  IO ()
 runAPIServer host port responseChannel node tracer = do
   traceWith tracer (APIServerStarted port)
   runServer (show host) (fromIntegral port) $ \pending -> do

hydra-node/src/Hydra/HeadLogic.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
 {-# OPTIONS_GHC -Wno-overlapping-patterns #-}
 
 module Hydra.HeadLogic where
@@ -17,9 +16,11 @@ import Hydra.Ledger (
   LedgerState,
   ParticipationToken (..),
   Party,
+  Tx,
   UTxO,
   ValidationError,
   ValidationResult (Invalid, Valid),
+  emptyUTxO,
   initLedgerState,
  )
 
@@ -41,8 +42,8 @@ data Effect tx
   | OnChainEffect OnChainTx
   | Delay DiffTime (Event tx)
 
-deriving instance Eq tx => Eq (UTxO tx) => Eq (Effect tx)
-deriving instance Show tx => Show (UTxO tx) => Show (Effect tx)
+deriving instance Tx tx => Eq (Effect tx)
+deriving instance Tx tx => Show (Effect tx)
 
 data ClientRequest tx
   = Init [Party]
@@ -52,18 +53,20 @@ data ClientRequest tx
   | Contest
   deriving (Eq, Read, Show)
 
+type SnapshotNumber = Natural
+
 data ClientResponse tx
   = NodeConnectedToNetwork
   | ReadyToCommit
   | HeadIsOpen (UTxO tx)
-  | HeadIsClosed DiffTime (UTxO tx)
+  | HeadIsClosed DiffTime (UTxO tx) SnapshotNumber [tx]
   | HeadIsFinalized (UTxO tx)
   | CommandFailed
   | TxConfirmed tx
   | TxInvalid tx
 
-deriving instance Eq tx => Eq (UTxO tx) => Eq (ClientResponse tx)
-deriving instance Show tx => Show (UTxO tx) => Show (ClientResponse tx)
+deriving instance Tx tx => Eq (ClientResponse tx)
+deriving instance Tx tx => Show (ClientResponse tx)
 
 data HydraMessage tx
   = ReqTx tx
@@ -75,7 +78,7 @@ data HydraMessage tx
   deriving (Eq, Show)
 
 data OnChainTx
-  = InitTx (Set.Set ParticipationToken)
+  = InitTx (Set ParticipationToken)
   | CommitTx ParticipationToken Natural
   | CollectComTx
   | CloseTx
@@ -88,8 +91,8 @@ data HeadState tx = HeadState
   , headStatus :: HeadStatus tx
   }
 
-deriving instance Eq (UTxO tx) => Eq (SimpleHeadState tx) => Eq (HeadState tx)
-deriving instance Show (UTxO tx) => Show (SimpleHeadState tx) => Show (HeadState tx)
+deriving instance Tx tx => Eq (HeadState tx)
+deriving instance Tx tx => Show (HeadState tx)
 
 data HeadStatus tx
   = InitState
@@ -98,29 +101,30 @@ data HeadStatus tx
   | ClosedState (UTxO tx)
   | FinalState
 
-deriving instance Eq (UTxO tx) => Eq (SimpleHeadState tx) => Eq (HeadStatus tx)
-deriving instance Show (UTxO tx) => Show (SimpleHeadState tx) => Show (HeadStatus tx)
+deriving instance Tx tx => Eq (HeadStatus tx)
+deriving instance Tx tx => Show (HeadStatus tx)
 
 data SimpleHeadState tx = SimpleHeadState
   { confirmedLedger :: LedgerState tx
   , -- TODO: tx should be an abstract 'TxId'
-    signatures :: Map tx (Set Party)
+    unconfirmedTxs :: Map tx (Set Party)
+  , confirmedTxs :: [tx]
   }
 
-deriving instance (Eq tx, Eq (UTxO tx)) => Eq (LedgerState tx) => Eq (SimpleHeadState tx)
-deriving instance (Show tx, Show (UTxO tx)) => Show (LedgerState tx) => Show (SimpleHeadState tx)
+deriving instance Tx tx => Eq (SimpleHeadState tx)
+deriving instance Tx tx => Show (SimpleHeadState tx)
 
 type PendingCommits = Set ParticipationToken
 
 -- | Contains at least the contestation period and other things.
 data HeadParameters = HeadParameters
   { contestationPeriod :: DiffTime
-  , parties :: [Party]
+  , parties :: Set Party
   }
   deriving (Eq, Show)
 
 -- | Decides when, how often and who is in charge of creating snapshots.
-data SnapshotStrategy = SnapshotStrategy
+data SnapshotStrategy = NoSnapshots | SnapshotAfter Natural
 
 -- | Assume: We know the party members and their verification keys. These need
 -- to be exchanged somehow, eventually.
@@ -155,9 +159,7 @@ data Environment = Environment
 -- network events, one for client events and one for main chain events, or by
 -- sub-'State'.
 update ::
-  Show (LedgerState tx) =>
-  Show (UTxO tx) =>
-  Show tx =>
+  Tx tx =>
   Ord tx =>
   Environment ->
   Ledger tx ->
@@ -166,9 +168,12 @@ update ::
   Outcome tx
 update Environment{party} ledger (HeadState p st) ev = case (st, ev) of
   (InitState, ClientEvent (Init parties)) ->
-    newState (p{parties}) InitState [OnChainEffect (InitTx $ makeAllTokens parties)]
+    newState p InitState [OnChainEffect (InitTx $ makeAllTokens parties)]
   (InitState, OnChainEvent (InitTx tokens)) ->
-    newState p (CollectingState tokens mempty) [ClientEffect ReadyToCommit]
+    -- NOTE(SN): Eventually we won't be able to construct 'HeadParameters' from
+    -- the 'InitTx'
+    let parties = Set.map thisToken tokens
+     in newState (p{parties}) (CollectingState tokens mempty) [ClientEffect ReadyToCommit]
   --
   (CollectingState remainingTokens _, ClientEvent (Commit amount)) ->
     case findToken remainingTokens party of
@@ -186,7 +191,7 @@ update Environment{party} ledger (HeadState p st) ev = case (st, ev) of
     let ls = initLedgerState ledger
      in newState
           p
-          (OpenState $ SimpleHeadState ls mempty)
+          (OpenState $ SimpleHeadState ls mempty mempty)
           [ClientEffect $ HeadIsOpen $ getUTxO ledger ls]
   --
   (OpenState _, OnChainEvent CommitTx{}) ->
@@ -202,39 +207,42 @@ update Environment{party} ledger (HeadState p st) ev = case (st, ev) of
     case canApply ledger (confirmedLedger headState) tx of
       Invalid _ -> panic "TODO: wait until it may be applied"
       Valid -> newState p st [NetworkEffect $ AckTx party tx]
-  (OpenState headState, NetworkEvent (MessageReceived (AckTx otherParty tx))) ->
-    case applyTransaction ledger (confirmedLedger headState) tx of
+  (OpenState headState@SimpleHeadState{confirmedLedger, confirmedTxs, unconfirmedTxs}, NetworkEvent (MessageReceived (AckTx otherParty tx))) ->
+    case applyTransaction ledger confirmedLedger tx of
       Left err -> panic $ "TODO: validation error: " <> show err
       Right newLedgerState -> do
         let sigs =
               Set.insert
                 otherParty
-                (fromMaybe Set.empty $ Map.lookup tx (signatures headState))
-        if sigs == Set.fromList (parties p)
+                (fromMaybe Set.empty $ Map.lookup tx unconfirmedTxs)
+        if sigs == parties p
           then
             newState
               p
               ( OpenState $
                   headState
                     { confirmedLedger = newLedgerState
-                    , signatures = Map.delete tx (signatures headState)
+                    , unconfirmedTxs = Map.delete tx unconfirmedTxs
+                    , confirmedTxs = tx : confirmedTxs
                     }
               )
               [ClientEffect $ TxConfirmed tx]
           else
             newState
               p
-              ( OpenState $
-                  headState
-                    { signatures = Map.insert tx sigs (signatures headState)
-                    }
+              ( OpenState headState{unconfirmedTxs = Map.insert tx sigs unconfirmedTxs}
               )
               []
 
   --
-  (OpenState SimpleHeadState{confirmedLedger}, OnChainEvent CloseTx) ->
+  (OpenState SimpleHeadState{confirmedLedger, confirmedTxs}, OnChainEvent CloseTx) ->
     let utxo = getUTxO ledger confirmedLedger
-     in newState p (ClosedState utxo) [ClientEffect $ HeadIsClosed (contestationPeriod p) utxo]
+        snapshotUtxo = emptyUTxO ledger
+        snapshotNumber = 0
+     in newState
+          p
+          (ClosedState utxo)
+          [ClientEffect $ HeadIsClosed (contestationPeriod p) snapshotUtxo snapshotNumber confirmedTxs]
   (ClosedState{}, ShouldPostFanout) ->
     newState p st [OnChainEffect FanoutTx]
   (ClosedState utxos, OnChainEvent FanoutTx) ->

hydra-node/src/Hydra/Ledger.hs

@@ -2,13 +2,6 @@ module Hydra.Ledger where
 
 import Cardano.Prelude hiding (undefined)
 
-import Cardano.Slotting.EpochInfo (fixedSizeEpochInfo)
-import Data.Default (Default (def))
-import Shelley.Spec.Ledger.API (Globals (..), Network (Testnet))
-import qualified Shelley.Spec.Ledger.API as Ledger
-import Shelley.Spec.Ledger.BaseTypes (UnitInterval, mkActiveSlotCoeff, mkUnitInterval)
-import Shelley.Spec.Ledger.Slot (EpochSize (EpochSize))
-
 -- NOTE(MB): We probably want to move these common types somewhere else. Putting
 -- here to avoid circular dependencies with Hydra.Logic
 
@@ -29,11 +22,18 @@ type Party = Natural
 
 -- * Ledger interface
 
--- TODO(SN): likely a type class could tie things together better
-
-type family UTxO tx
-
-type family LedgerState tx
+class
+  ( Eq tx
+  , Eq (UTxO tx)
+  , Eq (LedgerState tx)
+  , Show tx
+  , Show (UTxO tx)
+  , Show (LedgerState tx)
+  ) =>
+  Tx tx
+  where
+  type UTxO tx
+  type LedgerState tx
 
 data Ledger tx = Ledger
   { canApply :: LedgerState tx -> tx -> ValidationResult
@@ -50,72 +50,6 @@ data ValidationResult
 
 data ValidationError = ValidationError deriving (Eq, Show)
 
--- * Cardano ledger
-
-type instance UTxO (Ledger.Tx era) = Ledger.UTxO era
-
-type instance LedgerState (Ledger.Tx era) = Ledger.LedgerState era
-
-cardanoLedger ::
-  Ledger.ApplyTx era =>
-  Default (Ledger.LedgerState era) =>
-  Ledger.LedgersEnv era ->
-  Ledger (Ledger.Tx era)
-cardanoLedger env =
-  Ledger
-    { canApply = validateTx env
-    , applyTransaction = applyTx env
-    , initLedgerState = def
-    , getUTxO = Ledger._utxo . Ledger._utxoState
-    }
-
-applyTx ::
-  Ledger.ApplyTx era =>
-  Ledger.LedgersEnv era ->
-  Ledger.LedgerState era ->
-  Ledger.Tx era ->
-  Either ValidationError (Ledger.LedgerState era)
-applyTx env ls tx =
-  first toValidationError $ Ledger.applyTxsTransition globals env (pure tx) ls
- where
-  -- toValidationError :: ApplyTxError -> ValidationError
-  toValidationError = const ValidationError
-
-validateTx ::
-  Ledger.ApplyTx era =>
-  Ledger.LedgersEnv era ->
-  Ledger.LedgerState era ->
-  Ledger.Tx era ->
-  ValidationResult
-validateTx env ls tx =
-  either (Invalid . toValidationError) (const Valid) $
-    Ledger.applyTxsTransition globals env (pure tx) ls
- where
-  -- toValidationError :: ApplyTxError -> ValidationError
-  toValidationError = const ValidationError
-
---
--- From: shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Utils.hs
---
-
--- TODO(SN): not hard-code these obviously
-globals :: Globals
-globals =
-  Globals
-    { epochInfo = fixedSizeEpochInfo $ EpochSize 100
-    , slotsPerKESPeriod = 20
-    , stabilityWindow = 33
-    , randomnessStabilisationWindow = 33
-    , securityParameter = 10
-    , maxKESEvo = 10
-    , quorum = 5
-    , maxMajorPV = 1000
-    , maxLovelaceSupply = 45 * 1000 * 1000 * 1000 * 1000 * 1000
-    , activeSlotCoeff = mkActiveSlotCoeff . unsafeMkUnitInterval $ 0.9
-    , networkId = Testnet
-    }
-
--- | You vouch that argument is in [0; 1].
-unsafeMkUnitInterval :: Ratio Word64 -> UnitInterval
-unsafeMkUnitInterval r =
-  fromMaybe (panic "could not construct unit interval") $ mkUnitInterval r
+emptyUTxO :: Ledger tx -> UTxO tx
+emptyUTxO Ledger{initLedgerState, getUTxO} =
+  getUTxO initLedgerState