-
Notifications
You must be signed in to change notification settings - Fork 86
/
Shelley.hs
229 lines (192 loc) · 8.24 KB
/
Shelley.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
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Block.Shelley (
Args (..)
, ShelleyBlockArgs
) where
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Short as Short
import Data.Foldable (asum, toList)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, mapMaybe)
import Data.Maybe.Strict
import Data.Sequence.Strict (StrictSeq)
import qualified Data.Set as Set
import GHC.Records (HasField, getField)
import Options.Applicative
import Cardano.Binary (serialize')
import qualified Cardano.Ledger.Core as Core
import qualified Cardano.Ledger.TxIn as Core
import qualified Cardano.Ledger.Era as CL
import Cardano.Ledger.SafeHash (extractHash, originalBytes)
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Cardano.Ledger.Shelley.RewardUpdate as SL
import Cardano.Ledger.Allegra (AllegraEra)
import Cardano.Ledger.Alonzo (AlonzoEra)
import qualified Cardano.Ledger.Alonzo.Tx as Alonzo
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Mary (MaryEra)
import Ouroboros.Consensus.Block (IsEBB (..))
import qualified Ouroboros.Consensus.Mempool.TxLimits as TxLimits
import Ouroboros.Consensus.Node.ProtocolInfo
import Ouroboros.Consensus.Shelley.Eras (ShelleyBasedEra,
StandardShelley)
import Ouroboros.Consensus.Shelley.Ledger (shelleyLedgerState)
import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyBlock)
import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Shelley
import Ouroboros.Consensus.Shelley.Node (Nonce (..),
ProtocolParamsShelley (..),
ProtocolParamsShelleyBased (..), ShelleyGenesis,
protocolInfoShelley)
import HasAnalysis
{-------------------------------------------------------------------------------
ActualTxOutputIdDelta
-------------------------------------------------------------------------------}
-- | As of Alonzo, a transaction's effect on the UTxO depends on more than just
-- the @"inputs"@ and @"outputs"@ field
class ActualTxOutputIdDelta era where
-- | Which UTxO this transaction consumed
consumedTxIn :: Core.Tx era -> Set.Set (SL.TxIn (CL.Crypto era))
-- | How many UTxO this transaction created
createdTxOutputIds :: Core.Tx era -> [Int]
preAlonzo_consumedTxIn ::
( ShelleyBasedEra era
, HasField "inputs" (Core.TxBody era) (Set.Set (SL.TxIn (CL.Crypto era)))
) => Core.Tx era -> Set.Set (SL.TxIn (CL.Crypto era))
preAlonzo_consumedTxIn = getField @"inputs" . getField @"body"
preAlonzo_createdTxOutputIds ::
ShelleyBasedEra era
=> Core.Tx era -> [Int]
preAlonzo_createdTxOutputIds =
map getSize . toList . getField @"outputs" . getField @"body"
where
getSize = BS.length . serialize'
instance SL.PraosCrypto c => ActualTxOutputIdDelta (ShelleyEra c) where
consumedTxIn = preAlonzo_consumedTxIn
createdTxOutputIds = preAlonzo_createdTxOutputIds
instance SL.PraosCrypto c => ActualTxOutputIdDelta (AllegraEra c) where
consumedTxIn = preAlonzo_consumedTxIn
createdTxOutputIds = preAlonzo_createdTxOutputIds
instance SL.PraosCrypto c => ActualTxOutputIdDelta (MaryEra c) where
consumedTxIn = preAlonzo_consumedTxIn
createdTxOutputIds = preAlonzo_createdTxOutputIds
isValidTx :: Core.Tx (AlonzoEra c) -> Bool
isValidTx vtx = Alonzo.IsValid True == getField @"isValid" vtx
instance SL.PraosCrypto c => ActualTxOutputIdDelta (AlonzoEra c) where
consumedTxIn vtx =
if isValidTx vtx
then preAlonzo_consumedTxIn vtx
else getField @"collateral" (getField @"body" vtx)
createdTxOutputIds vtx =
if not (isValidTx vtx) then [] else preAlonzo_createdTxOutputIds vtx
{-------------------------------------------------------------------------------
HasAnalysis instance
-------------------------------------------------------------------------------}
-- | Usable for each Shelley-based era
instance ( ShelleyBasedEra era
, ActualTxOutputIdDelta era
, HasField "inputs" (Core.TxBody era) (Set.Set (SL.TxIn (CL.Crypto era)))
, HasField "outputs" (Core.TxBody era) (StrictSeq (Core.TxOut era))
) => HasAnalysis (ShelleyBlock era) where
countTxOutputs blk = case Shelley.shelleyBlockRaw blk of
SL.Block _ body -> sum $ fmap countOutputs (CL.fromTxSeq @era body)
where
countOutputs :: Core.Tx era -> Int
countOutputs = length . getField @"outputs" . getField @"body"
extractTxOutputIdDelta blk =
( IsNotEBB
, length txs
, foldMap inputs txs
, mapMaybe outputs (toList txs)
)
where
SL.Block _ body = Shelley.shelleyBlockRaw blk
txs = CL.fromTxSeq @era body
asShort = Short.toShort . originalBytes . extractHash . Core._unTxId
cnv :: SL.TxIn (CL.Crypto era) -> TxIn
cnv (Core.TxIn txid nat) = TxIn (asShort txid) (fromInteger $ toInteger nat)
inputs :: Core.Tx era -> [TxIn]
inputs = map cnv . Set.toList . consumedTxIn
outputs :: Core.Tx era -> Maybe TxOutputIds
outputs tx =
mkTxOutputIds (asShort txid) (createdTxOutputIds tx)
where
txid = Core.txid $ getField @"body" tx
-- TODO this is dead-code for a Cardano chain, but inaccurate for a pure
-- Shelley chain
genesisTxOutputIds _ = (0, [])
blockTxSizes blk = case Shelley.shelleyBlockRaw blk of
SL.Block _ body ->
toList
$ fmap (fromIntegral . (getField @"txsize")) (CL.fromTxSeq @era body)
knownEBBs = const Map.empty
emitTraces (WithLedgerState _blk lsb lsa) = catMaybes
[
let be = SL.nesEL . shelleyLedgerState $ lsb
ae = SL.nesEL . shelleyLedgerState $ lsa
in if be /= ae
then
Just $ "EPOCH_START_" <> show ae
else Nothing
, let brp = SL.nesRu . shelleyLedgerState $ lsb
arp = SL.nesRu . shelleyLedgerState $ lsa
in case (brp, arp) of
(SNothing, SJust _) -> Just "RWDPULSER_START"
(SJust (SL.Pulsing _ _), SJust (SL.Complete _)) -> Just "RWDPULSER_COMPLETE"
(SJust _, SNothing) -> Just "RWDPULSER_RESET"
(_, _) -> Nothing
]
{-------------------------------------------------------------------------------
HasProtocolInfo instance
-------------------------------------------------------------------------------}
-- | Shelley-era specific
instance HasProtocolInfo (ShelleyBlock StandardShelley) where
data Args (ShelleyBlock StandardShelley) = ShelleyBlockArgs {
configFileShelley :: FilePath
, initialNonce :: Nonce
}
deriving (Show)
argsParser _ = parseShelleyArgs
mkProtocolInfo ShelleyBlockArgs {..} = do
config <- either (error . show) return =<<
Aeson.eitherDecodeFileStrict' configFileShelley
return $ mkShelleyProtocolInfo config initialNonce
type ShelleyBlockArgs = Args (ShelleyBlock StandardShelley)
mkShelleyProtocolInfo ::
ShelleyGenesis StandardShelley
-> Nonce
-> ProtocolInfo IO (ShelleyBlock StandardShelley)
mkShelleyProtocolInfo genesis initialNonce =
protocolInfoShelley
ProtocolParamsShelleyBased {
shelleyBasedGenesis = genesis
, shelleyBasedInitialNonce = initialNonce
, shelleyBasedLeaderCredentials = []
}
ProtocolParamsShelley {
shelleyProtVer = SL.ProtVer 2 0
, shelleyMaxTxCapacityOverrides = TxLimits.mkOverrides TxLimits.noOverridesMeasure
}
parseShelleyArgs :: Parser ShelleyBlockArgs
parseShelleyArgs = ShelleyBlockArgs
<$> strOption (mconcat [
long "configShelley"
, help "Path to config file"
, metavar "PATH"
])
<*> asum [ Nonce <$> parseNonce
, pure NeutralNonce]
where
parseNonce = strOption (mconcat [
long "nonce"
, help "Initial nonce, i.e., hash of the genesis config file"
, metavar "NONCE"
])