-
Notifications
You must be signed in to change notification settings - Fork 156
/
Query.hs
165 lines (143 loc) · 6.92 KB
/
Query.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
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Cardano.DbSync.Era.Shelley.Query
( queryPoolHashId
, queryStakeAddress
, queryStakePoolKeyHash
, queryStakeRefPtr
, queryStakeAddressRef
, queryResolveInput
, queryResolveInputCredentials
, queryStakeAddressIdPair
, queryPoolHashIdPair
, queryPoolUpdateByBlock
) where
import Cardano.Prelude hiding (Ptr, from, maybeToEither, on)
import Cardano.Db
import qualified Cardano.DbSync.Era.Shelley.Generic as Generic
import qualified Cardano.Ledger.Address as Ledger
import Cardano.Ledger.Credential (Ptr (..), StakeReference (..))
import qualified Cardano.Ledger.Keys as Ledger
import Cardano.DbSync.Util
import Cardano.Slotting.Slot (SlotNo (..))
import Database.Esqueleto.Legacy (InnerJoin (..), Value (..), desc, from, just, limit, on,
orderBy, select, val, where_, (==.), (^.))
import Database.Persist.Sql (SqlBackend)
import Ouroboros.Consensus.Cardano.Block (StandardCrypto)
{- HLINT ignore "Reduce duplication" -}
queryPoolHashId :: MonadIO m => ByteString -> ReaderT SqlBackend m (Maybe PoolHashId)
queryPoolHashId hash = do
res <- select . from $ \ phash -> do
where_ (phash ^. PoolHashHashRaw ==. val hash)
pure (phash ^. PoolHashId)
pure $ unValue <$> listToMaybe res
queryStakeAddress
:: MonadIO m
=> ByteString
-> ReaderT SqlBackend m (Either LookupFail StakeAddressId)
queryStakeAddress addr = do
res <- select . from $ \ saddr -> do
where_ (saddr ^. StakeAddressHashRaw ==. val addr)
pure (saddr ^. StakeAddressId)
pure $ maybeToEither (DbLookupMessage $ "StakeAddress " <> renderByteArray addr) unValue (listToMaybe res)
queryStakePoolKeyHash
:: forall era m. MonadIO m
=> Ledger.KeyHash 'Ledger.StakePool era
-> ReaderT SqlBackend m (Either LookupFail PoolHashId)
queryStakePoolKeyHash kh = do
res <- select . from $ \ (poolUpdate `InnerJoin` poolHash `InnerJoin` tx `InnerJoin` blk) -> do
on (blk ^. BlockId ==. tx ^. TxBlockId)
on (tx ^. TxId ==. poolUpdate ^. PoolUpdateRegisteredTxId)
on (poolUpdate ^. PoolUpdateHashId ==. poolHash ^. PoolHashId)
where_ (poolHash ^. PoolHashHashRaw ==. val (Generic.unKeyHashRaw kh))
orderBy [desc (blk ^. BlockSlotNo)]
limit 1
pure (poolHash ^. PoolHashId)
pure $ maybeToEither (DbLookupMessage "StakePoolKeyHash") unValue (listToMaybe res)
queryStakeAddressRef
:: MonadIO m
=> Ledger.Addr StandardCrypto
-> ReaderT SqlBackend m (Maybe StakeAddressId)
queryStakeAddressRef addr =
case addr of
Ledger.AddrBootstrap {} -> pure Nothing
Ledger.Addr nw _pcred sref ->
case sref of
StakeRefBase cred -> do
eres <- queryStakeAddress $ Ledger.serialiseRewardAcnt (Ledger.RewardAcnt nw cred)
pure $ either (const Nothing) Just eres
StakeRefPtr ptr -> queryStakeDelegation ptr
StakeRefNull -> pure Nothing
where
queryStakeDelegation
:: MonadIO m
=> Ptr
-> ReaderT SqlBackend m (Maybe StakeAddressId)
queryStakeDelegation (Ptr (SlotNo slot) txIx certIx) = do
res <- select . from $ \ (blk `InnerJoin` tx `InnerJoin` dlg) -> do
on (tx ^. TxId ==. dlg ^. DelegationTxId)
on (blk ^. BlockId ==. tx ^. TxBlockId)
where_ (blk ^. BlockSlotNo ==. just (val slot))
where_ (tx ^. TxBlockIndex ==. val (fromIntegral txIx))
where_ (dlg ^. DelegationCertIndex ==. val (fromIntegral certIx))
-- Need to order by BlockSlotNo descending for correct behavior when there are two
-- or more delegation certificates in a single epoch.
orderBy [desc (blk ^. BlockSlotNo)]
limit 1
pure (dlg ^. DelegationAddrId)
pure $ unValue <$> listToMaybe res
queryResolveInput :: MonadIO m => Generic.TxIn -> ReaderT SqlBackend m (Either LookupFail (TxId, DbLovelace))
queryResolveInput txIn =
queryTxOutValue (Generic.txInHash txIn, fromIntegral (Generic.txInIndex txIn))
queryResolveInputCredentials :: MonadIO m => Generic.TxIn -> ReaderT SqlBackend m (Either LookupFail (Maybe ByteString, Bool))
queryResolveInputCredentials txIn = do
queryTxOutCredentials (Generic.txInHash txIn, fromIntegral (Generic.txInIndex txIn))
queryStakeAddressIdPair :: MonadIO m => Generic.StakeCred -> ReaderT SqlBackend m (Maybe (Generic.StakeCred, StakeAddressId))
queryStakeAddressIdPair cred@(Generic.StakeCred bs) = do
res <- select . from $ \ saddr -> do
where_ (saddr ^. StakeAddressHashRaw ==. val bs)
pure $ saddr ^. StakeAddressId
pure $ convert <$> listToMaybe res
where
convert :: Value StakeAddressId -> (Generic.StakeCred, StakeAddressId)
convert (Value said) = (cred, said)
queryStakeRefPtr :: MonadIO m => Ptr -> ReaderT SqlBackend m (Maybe StakeAddressId)
queryStakeRefPtr (Ptr (SlotNo slot) txIx _certIx) = do
res <- select . from $ \ (blk `InnerJoin` tx `InnerJoin` sa) -> do
on (tx ^. TxId ==. sa ^. StakeAddressRegisteredTxId)
on (blk ^. BlockId ==. tx ^. TxBlockId)
where_ (blk ^. BlockSlotNo ==. just (val slot))
where_ (tx ^. TxBlockIndex ==. val (fromIntegral txIx))
-- where_ (sa ^. DelegationCertIndex ==. val (fromIntegral certIx))
-- Need to order by BlockSlotNo descending for correct behavior when there are two
-- or more delegation certificates in a single epoch.
orderBy [desc (blk ^. BlockSlotNo)]
limit 1
pure (sa ^. StakeAddressId)
pure $ unValue <$> listToMaybe res
queryPoolHashIdPair
:: MonadIO m
=> Generic.StakePoolKeyHash
-> ReaderT SqlBackend m (Maybe (Generic.StakePoolKeyHash, PoolHashId))
queryPoolHashIdPair pkh = do
res <- select . from $ \ pool -> do
where_ (pool ^. PoolHashHashRaw ==. val (Generic.unStakePoolKeyHash pkh))
pure $ pool ^. PoolHashId
pure $ convert <$> listToMaybe res
where
convert :: Value PoolHashId -> (Generic.StakePoolKeyHash, PoolHashId)
convert (Value phid) = (pkh, phid)
-- Check if there are other PoolUpdates in the same blocks for the same pool
queryPoolUpdateByBlock :: MonadIO m => BlockId -> PoolHashId -> ReaderT SqlBackend m Bool
queryPoolUpdateByBlock blkId poolHashId = do
res <- select . from $ \ (poolUpdate `InnerJoin` tx `InnerJoin` blk) -> do
on (blk ^. BlockId ==. tx ^. TxBlockId)
on (tx ^. TxId ==. poolUpdate ^. PoolUpdateRegisteredTxId)
where_ (poolUpdate ^. PoolUpdateHashId ==. val poolHashId)
where_ (blk ^. BlockId ==. val blkId)
limit 1
pure (blk ^. BlockEpochNo)
pure $ not (null res)