-
Notifications
You must be signed in to change notification settings - Fork 86
/
HeadLogic.hs
259 lines (227 loc) · 8.62 KB
/
HeadLogic.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
module Hydra.HeadLogic where
import Cardano.Prelude
import Control.Monad.Class.MonadTime (DiffTime)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Hydra.Ledger (
Amount,
Committed,
Ledger (applyTransaction, canApply, getUTxO),
LedgerState,
ParticipationToken (..),
Party,
UTxO,
ValidationError,
ValidationResult (Invalid, Valid),
initLedgerState,
)
data Event tx
= ClientEvent (ClientRequest tx)
| NetworkEvent (NetworkEvent tx)
| OnChainEvent OnChainTx
| ShouldPostFanout
deriving (Eq, Show)
data NetworkEvent tx
= MessageReceived (HydraMessage tx)
| NetworkConnected
deriving (Eq, Show)
data Effect tx
= ClientEffect (ClientResponse tx)
| NetworkEffect (HydraMessage 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)
data ClientRequest tx
= Init [Party]
| Commit Amount
| NewTx tx
| Close
| Contest
deriving (Eq, Read, Show)
data ClientResponse tx
= NodeConnectedToNetwork
| ReadyToCommit
| HeadIsOpen (UTxO tx)
| HeadIsClosed DiffTime (UTxO 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)
data HydraMessage tx
= ReqTx tx
| AckTx Party tx
| ConfTx
| ReqSn
| AckSn
| ConfSn
deriving (Eq, Show)
data OnChainTx
= InitTx (Set.Set ParticipationToken)
| CommitTx ParticipationToken Natural
| CollectComTx
| CloseTx
| ContestTx
| FanoutTx
deriving (Eq, Show, Read)
data HeadState tx = HeadState
{ headParameters :: HeadParameters
, 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)
data HeadStatus tx
= InitState
| CollectingState PendingCommits Committed
| OpenState (SimpleHeadState 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)
data SimpleHeadState tx = SimpleHeadState
{ confirmedLedger :: LedgerState tx
, -- TODO: tx should be an abstract 'TxId'
signatures :: Map tx (Set Party)
}
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)
type PendingCommits = Set ParticipationToken
-- | Contains at least the contestation period and other things.
data HeadParameters = HeadParameters
{ contestationPeriod :: DiffTime
, parties :: [Party]
}
deriving (Eq, Show)
-- | Decides when, how often and who is in charge of creating snapshots.
data SnapshotStrategy = SnapshotStrategy
-- | Assume: We know the party members and their verification keys. These need
-- to be exchanged somehow, eventually.
createHeadState :: [Party] -> HeadParameters -> SnapshotStrategy -> HeadState tx
createHeadState _ parameters _ = HeadState parameters InitState
-- | Preliminary type for collecting errors occurring during 'update'. Might
-- make sense to merge this (back) into 'Outcome'.
data LogicError tx
= InvalidEvent (Event tx) (HeadState tx)
| InvalidState (HeadState tx)
| LedgerError ValidationError
deriving instance (Eq (HeadState tx), Eq (Event tx)) => Eq (LogicError tx)
deriving instance (Show (HeadState tx), Show (Event tx)) => Show (LogicError tx)
data Outcome tx
= NewState (HeadState tx) [Effect tx]
| Wait
| Error (LogicError tx)
newState :: HeadParameters -> HeadStatus tx -> [Effect tx] -> Outcome tx
newState p s = NewState (HeadState p s)
data Environment = Environment
{ -- | This is the p_i from the paper
party :: Party
}
-- | The heart of the Hydra head logic, a handler of all kinds of 'Event' in the
-- Hydra head. This may also be split into multiple handlers, i.e. one for hydra
-- 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 =>
Ord tx =>
Environment ->
Ledger tx ->
HeadState tx ->
Event tx ->
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)]
(InitState, OnChainEvent (InitTx tokens)) ->
newState p (CollectingState tokens mempty) [ClientEffect ReadyToCommit]
--
(CollectingState remainingTokens _, ClientEvent (Commit amount)) ->
case findToken remainingTokens party of
Nothing ->
panic $ "you're not allowed to commit (anymore): remainingTokens : " <> show remainingTokens <> ", partiyIndex: " <> show party
Just pt -> newState p st [OnChainEffect (CommitTx pt amount)]
(CollectingState remainingTokens committed, OnChainEvent (CommitTx pt amount)) ->
let remainingTokens' = Set.delete pt remainingTokens
newCommitted = Map.insert pt amount committed
newHeadState = CollectingState remainingTokens' newCommitted
in if canCollectCom party pt remainingTokens'
then newState p newHeadState [OnChainEffect CollectComTx]
else newState p newHeadState []
(CollectingState{}, OnChainEvent CollectComTx) ->
let ls = initLedgerState ledger
in newState
p
(OpenState $ SimpleHeadState ls mempty)
[ClientEffect $ HeadIsOpen $ getUTxO ledger ls]
--
(OpenState _, OnChainEvent CommitTx{}) ->
Error (InvalidEvent ev (HeadState p st)) -- HACK(SN): is a general case later
(OpenState{}, ClientEvent Close) ->
newState p st [OnChainEffect CloseTx, Delay (contestationPeriod p) ShouldPostFanout]
--
(OpenState SimpleHeadState{confirmedLedger}, ClientEvent (NewTx tx)) ->
case canApply ledger confirmedLedger tx of
Invalid _ -> newState p st [ClientEffect $ TxInvalid tx]
Valid -> newState p st [NetworkEffect $ ReqTx tx]
(OpenState headState, NetworkEvent (MessageReceived (ReqTx tx))) ->
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
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)
then
newState
p
( OpenState $
headState
{ confirmedLedger = newLedgerState
, signatures = Map.delete tx (signatures headState)
}
)
[ClientEffect $ TxConfirmed tx]
else
newState
p
( OpenState $
headState
{ signatures = Map.insert tx sigs (signatures headState)
}
)
[]
--
(OpenState SimpleHeadState{confirmedLedger}, OnChainEvent CloseTx) ->
let utxo = getUTxO ledger confirmedLedger
in newState p (ClosedState utxo) [ClientEffect $ HeadIsClosed (contestationPeriod p) utxo]
(ClosedState{}, ShouldPostFanout) ->
newState p st [OnChainEffect FanoutTx]
(ClosedState utxos, OnChainEvent FanoutTx) ->
newState p FinalState [ClientEffect $ HeadIsFinalized utxos]
--
(_, NetworkEvent NetworkConnected) ->
newState p st [ClientEffect NodeConnectedToNetwork]
(_, ClientEvent{}) ->
newState p st [ClientEffect CommandFailed]
_ -> panic $ "UNHANDLED EVENT: on " <> show party <> " of event " <> show ev <> " in state " <> show st
canCollectCom :: Party -> ParticipationToken -> Set ParticipationToken -> Bool
canCollectCom party pt remainingTokens = null remainingTokens && thisToken pt == party
makeAllTokens :: [Party] -> Set ParticipationToken
makeAllTokens parties = Set.fromList $ map (ParticipationToken total) parties
where
total = fromIntegral $ length parties
findToken :: Set ParticipationToken -> Party -> Maybe ParticipationToken
findToken allTokens party =
find (\t -> thisToken t == party) allTokens