-
Notifications
You must be signed in to change notification settings - Fork 86
/
Common.hs
174 lines (151 loc) · 6.39 KB
/
Common.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
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
module Ouroboros.Consensus.Storage.Common (
-- * Indexing
tipIsGenesis
-- * PrefixLen
, PrefixLen (..)
, addPrefixLen
, takePrefix
-- * BinaryBlockInfo
, BinaryBlockInfo (..)
, extractHeader
-- * Iterator bounds
, StreamFrom (..)
, StreamTo (..)
, validBounds
-- * BlockComponent
, BlockComponent (..)
-- * Re-exports
, SizeInBytes
) where
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BL
import Data.ByteString.Short (ShortByteString)
import qualified Data.ByteString.Short as Short
import Data.Word
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import Ouroboros.Network.DeltaQ (SizeInBytes)
import Ouroboros.Consensus.Block
{-------------------------------------------------------------------------------
Indexing
-------------------------------------------------------------------------------}
tipIsGenesis :: WithOrigin r -> Bool
tipIsGenesis Origin = True
tipIsGenesis (NotOrigin _) = False
{-------------------------------------------------------------------------------
PrefixLen
-------------------------------------------------------------------------------}
-- | Number of bytes from the start of a block needed to reconstruct the
-- nested context.
--
-- See 'reconstructPrefixLen'.
newtype PrefixLen = PrefixLen {
getPrefixLen :: Word8
}
deriving stock (Eq, Ord, Show, Generic)
deriving newtype (NoThunks)
addPrefixLen :: Word8 -> PrefixLen -> PrefixLen
addPrefixLen m (PrefixLen n) = PrefixLen (m + n)
takePrefix :: PrefixLen -> BL.ByteString -> ShortByteString
takePrefix (PrefixLen n) =
Short.toShort . BL.toStrict . BL.take (fromIntegral n)
{-------------------------------------------------------------------------------
BinaryBlockInfo
-------------------------------------------------------------------------------}
-- | Information about the serialised block.
data BinaryBlockInfo = BinaryBlockInfo
{ headerOffset :: !Word16
-- ^ The offset within the serialised block at which the header starts.
, headerSize :: !Word16
-- ^ How many bytes the header is long. Extracting the 'headerSize' bytes
-- from serialised block starting from 'headerOffset' should yield the
-- header. Before passing the extracted bytes to the decoder for headers,
-- an envelope can be around using 'nodeAddHeaderEnvelope'.
-- In the future, i.e. Shelley, we might want to extend this to include a
-- field to tell where the transaction body ends and where the transaction
-- witnesses begin so we can only extract the transaction body.
} deriving (Eq, Show, Generic)
-- | Extract the header from the given 'ByteString' using the
-- 'BinaryBlockInfo'.
extractHeader :: BinaryBlockInfo -> ByteString -> ByteString
extractHeader BinaryBlockInfo { headerOffset, headerSize } =
BL.take (fromIntegral headerSize)
. BL.drop (fromIntegral headerOffset)
{-------------------------------------------------------------------------------
Iterator bounds
-------------------------------------------------------------------------------}
-- | The lower bound for an iterator
--
-- Hint: use @'StreamFromExclusive' 'genesisPoint'@ to start streaming from
-- Genesis.
data StreamFrom blk =
StreamFromInclusive !(RealPoint blk)
| StreamFromExclusive !(Point blk)
deriving stock (Show, Eq, Generic)
deriving anyclass (NoThunks)
newtype StreamTo blk =
StreamToInclusive (RealPoint blk)
deriving stock (Show, Eq, Generic)
deriving anyclass (NoThunks)
-- | Check whether the bounds make sense
--
-- An example of bounds that don't make sense:
--
-- > StreamFromExclusive (BlockPoint 3 ..)
-- > StreamToInclusive (RealPoint 3 ..)
--
-- This function does not check whether the bounds correspond to existing
-- blocks.
validBounds :: StandardHash blk => StreamFrom blk -> StreamTo blk -> Bool
validBounds from (StreamToInclusive (RealPoint sto hto)) =
case from of
StreamFromExclusive GenesisPoint -> True
-- EBBs spoil the fun again: when 'StreamFromExclusive' refers to an EBB
-- in slot X and 'StreamToInclusive' to the regular block in the same slot
-- X, the bound is still valid. Without EBBs, we would have @sfrom < sto@.
--
-- We /can/ rule out streaming exclusively from the block to the same
-- block.
StreamFromExclusive (BlockPoint sfrom hfrom) -> hfrom /= hto && sfrom <= sto
StreamFromInclusive (RealPoint sfrom _) -> sfrom <= sto
{-------------------------------------------------------------------------------
BlockComponent
-------------------------------------------------------------------------------}
-- | Which component of the block to read from a database: the whole block,
-- its header, its hash, the block size, ..., or combinations thereof.
--
-- NOTE: when requesting multiple components, we will not optimise/cache them.
data BlockComponent blk a where
-- | Verify the integrity of the block by checking its signature and/or
-- hashes. The interpreter should throw an exception when the block does not
-- pass the check.
GetVerifiedBlock :: BlockComponent blk blk
GetBlock :: BlockComponent blk blk
GetRawBlock :: BlockComponent blk ByteString
GetHeader :: BlockComponent blk (Header blk)
GetRawHeader :: BlockComponent blk ByteString
GetHash :: BlockComponent blk (HeaderHash blk)
GetSlot :: BlockComponent blk SlotNo
GetIsEBB :: BlockComponent blk IsEBB
GetBlockSize :: BlockComponent blk Word32
GetHeaderSize :: BlockComponent blk Word16
GetNestedCtxt :: BlockComponent blk (SomeSecond (NestedCtxt Header) blk)
GetPure :: a
-> BlockComponent blk a
GetApply :: BlockComponent blk (a -> b)
-> BlockComponent blk a
-> BlockComponent blk b
instance Functor (BlockComponent blk) where
fmap f = (GetPure f <*>)
instance Applicative (BlockComponent blk) where
pure = GetPure
(<*>) = GetApply