-
Notifications
You must be signed in to change notification settings - Fork 44
/
Chain.hs
47 lines (43 loc) · 1.76 KB
/
Chain.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
{-# LANGUAGE RankNTypes #-}
module Language.Marlowe.Runtime.Transaction.Chain
where
import Control.Concurrent (threadDelay)
import Control.Concurrent.Component
import Control.Concurrent.STM (STM, atomically, newTVar, readTVar, writeTVar)
import Control.Exception (finally)
import Data.Functor (($>))
import Data.Void (absurd)
import Language.Marlowe.Runtime.ChainSync.Api (Move(..), RuntimeChainSeekClient)
import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain
import Network.Protocol.ChainSeek.Client
import Network.Protocol.Connection (SomeClientConnector)
import Network.Protocol.Driver (runSomeConnector)
newtype TransactionChainClientDependencies = TransactionChainClientDependencies
{ chainSyncConnector :: SomeClientConnector RuntimeChainSeekClient IO
}
transactionChainClient :: Component IO TransactionChainClientDependencies (STM Bool, STM Chain.ChainPoint)
transactionChainClient = component \TransactionChainClientDependencies{..} -> do
tipVar <- newTVar Chain.Genesis
connectedVar <- newTVar False
pure
( flip finally (atomically $ writeTVar connectedVar False)
$ runSomeConnector chainSyncConnector
$ client connectedVar tipVar
, (readTVar connectedVar, readTVar tipVar)
)
where
client connectedVar tipVar = ChainSeekClient do
atomically $ writeTVar connectedVar True
pure clientIdle
where
clientIdle = SendMsgQueryNext AdvanceToTip clientNext
clientNext = ClientStNext
{ recvMsgRollForward = \_ _ tip -> atomically do
writeTVar tipVar tip
pure clientIdle
, recvMsgRollBackward = \_ tip -> atomically do
writeTVar tipVar tip
pure clientIdle
, recvMsgQueryRejected = absurd
, recvMsgWait = threadDelay 1_000_000 $> SendMsgPoll clientNext
}