/
Node.hs
94 lines (82 loc) · 3.87 KB
/
Node.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
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Ouroboros.Consensus.Mock.Node (
CodecConfig (..)
, simpleBlockForging
) where
import Codec.Serialise (Serialise, serialise)
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.Map.Strict as Map
import Data.Typeable (Typeable)
import Data.Void (Void)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.SupportsProtocol
import Ouroboros.Consensus.Mock.Ledger
import Ouroboros.Consensus.Mock.Node.Abstract
import Ouroboros.Consensus.Mock.Node.Serialisation ()
import Ouroboros.Consensus.Node.NetworkProtocolVersion
import Ouroboros.Consensus.Node.Run
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.Util ((.....:))
import Ouroboros.Consensus.Util.RedundantConstraints
import Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo)
{-------------------------------------------------------------------------------
RunNode instance for the mock ledger
-------------------------------------------------------------------------------}
instance HasNetworkProtocolVersion (SimpleBlock SimpleMockCrypto ext) where
-- Use defaults
instance SupportedNetworkProtocolVersion (SimpleBlock SimpleMockCrypto ext) where
supportedNodeToNodeVersions _ = Map.singleton maxBound ()
supportedNodeToClientVersions _ = Map.singleton maxBound ()
instance ( LedgerSupportsProtocol (SimpleBlock SimpleMockCrypto ext)
-- The below constraint seems redundant but is not! When removed,
-- some of the tests loop, but only when compiled with @-O2@ ; with
-- @-O0@ it is perfectly fine. ghc bug?!
, BlockSupportsProtocol (SimpleBlock SimpleMockCrypto ext)
, Show (CannotForge (SimpleBlock SimpleMockCrypto ext))
, Show (ForgeStateInfo (SimpleBlock SimpleMockCrypto ext))
, Show (ForgeStateUpdateError (SimpleBlock SimpleMockCrypto ext))
, Typeable ext
, Serialise ext
, RunMockBlock SimpleMockCrypto ext
) => RunNode (SimpleBlock SimpleMockCrypto ext) where
nodeBlockFetchSize hdr =
7 {- CBOR-in-CBOR -} + 1 {- encodeListLen 2 -} + hdrSize + bodySize
where
hdrSize = fromIntegral (Lazy.length (serialise hdr))
bodySize = simpleBodySize (simpleHeaderStd hdr)
nodeImmDbChunkInfo = \cfg -> simpleChunkInfo $
EpochSize $ 10 * maxRollbacks (configSecurityParam cfg)
nodeCheckIntegrity = \_ _ -> True
{-------------------------------------------------------------------------------
BlockForging
-------------------------------------------------------------------------------}
-- | Can be used when 'CanBeLeader' is static
simpleBlockForging ::
forall c ext m.
( RunMockBlock c ext
, CannotForge (SimpleBlock c ext) ~ Void
, ForgeStateInfo (SimpleBlock c ext) ~ ()
, ForgeStateUpdateError (SimpleBlock c ext) ~ Void
, Monad m
)
=> CanBeLeader (BlockProtocol (SimpleBlock c ext))
-> ForgeExt c ext
-> BlockForging m (SimpleBlock c ext)
simpleBlockForging canBeLeader forgeExt = BlockForging {
canBeLeader = canBeLeader
, updateForgeState = \_ -> return $ ForgeStateUpdateInfo $ Unchanged ()
, checkCanForge = \_ _ _ _ _ -> return ()
, forgeBlock = return .....: forgeSimple forgeExt
}
where
_ = keepRedundantConstraint (Proxy @(ForgeStateUpdateError (SimpleBlock c ext) ~ Void))