-
Notifications
You must be signed in to change notification settings - Fork 20
/
Server.hs
68 lines (62 loc) · 2.66 KB
/
Server.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
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Ouroboros.Consensus.MiniProtocol.LocalStateQuery.Server (localStateQueryServer) where
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.HeaderValidation (HasAnnTip (..))
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.Query
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Network.Protocol.LocalStateQuery.Server
import Ouroboros.Network.Protocol.LocalStateQuery.Type
(AcquireFailure (..), Target (..))
localStateQueryServer ::
forall m blk. (IOLike m, BlockSupportsLedgerQuery blk, ConfigSupportsNode blk, HasAnnTip blk)
=> ExtLedgerCfg blk
-> STM m (Point blk)
-- ^ Get tip point
-> (Point blk -> STM m (Maybe (ExtLedgerState blk)))
-- ^ Get a past ledger
-> STM m (Point blk)
-- ^ Get the immutable point
-> LocalStateQueryServer blk (Point blk) (Query blk) m ()
localStateQueryServer cfg getTipPoint getPastLedger getImmutablePoint =
LocalStateQueryServer $ return idle
where
idle :: ServerStIdle blk (Point blk) (Query blk) m ()
idle = ServerStIdle {
recvMsgAcquire = handleAcquire
, recvMsgDone = return ()
}
handleAcquire :: Target (Point blk)
-> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
handleAcquire tpt = do
(pt, mPastLedger, immutablePoint) <- atomically $ do
pt <- case tpt of
VolatileTip -> getTipPoint
SpecificPoint point -> pure point
ImmutableTip -> getImmutablePoint
(pt,,) <$> getPastLedger pt <*> getImmutablePoint
return $ case mPastLedger of
Just pastLedger
-> SendMsgAcquired $ acquired pastLedger
Nothing
| pointSlot pt < pointSlot immutablePoint
-> SendMsgFailure AcquireFailurePointTooOld idle
| otherwise
-> SendMsgFailure AcquireFailurePointNotOnChain idle
acquired :: ExtLedgerState blk
-> ServerStAcquired blk (Point blk) (Query blk) m ()
acquired ledgerState = ServerStAcquired {
recvMsgQuery = handleQuery ledgerState
, recvMsgReAcquire = handleAcquire
, recvMsgRelease = return idle
}
handleQuery ::
ExtLedgerState blk
-> Query blk result
-> m (ServerStQuerying blk (Point blk) (Query blk) m () result)
handleQuery ledgerState query = return $
SendMsgResult
(answerQuery cfg query ledgerState)
(acquired ledgerState)