/
StoresSpec.hs
278 lines (254 loc) · 8.82 KB
/
StoresSpec.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
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Cardano.Wallet.DB.Sqlite.StoresSpec
( spec
) where
import Prelude
import Cardano.Address.Derivation
( XPrv )
import Cardano.DB.Sqlite
( ForeignKeysSetting (..), SqliteContext (runQuery) )
import Cardano.Wallet.Address.Book
( AddressBookIso (..), Prologue, getPrologue )
import Cardano.Wallet.Address.Derivation
( Depth (RootK) )
import Cardano.Wallet.Address.Derivation.Shared
( SharedKey )
import Cardano.Wallet.Address.Derivation.Shelley
( ShelleyKey )
import Cardano.Wallet.Address.Discovery.Random
( RndState )
import Cardano.Wallet.Address.Discovery.Sequential
( SeqState )
import Cardano.Wallet.Address.Discovery.Shared
( Readiness (Pending), SharedState (..) )
import Cardano.Wallet.Checkpoints
( DeltaCheckpoints (..) )
import Cardano.Wallet.DB.Arbitrary
( GenState, InitialCheckpoint (..) )
import Cardano.Wallet.DB.Fixtures
( initializeWallet, withDBInMemory )
import Cardano.Wallet.DB.Sqlite.Stores
( PersistAddressBook (..), mkStoreWallet )
import Cardano.Wallet.DB.Store.Info.Store
( WalletInfo (WalletInfo) )
import Cardano.Wallet.DB.WalletState
( DeltaWalletState
, DeltaWalletState1 (..)
, fromGenesis
, fromWallet
, getLatest
, getSlot
)
import Cardano.Wallet.DummyTarget.Primitive.Types
( dummyGenesisParameters )
import Cardano.Wallet.Flavor
( KeyOf, WalletFlavorS (ShelleyWallet) )
import Cardano.Wallet.Primitive.Types
( SlotNo (..), WalletId (..), WithOrigin (..) )
import Cardano.Wallet.Read.NetworkId
( NetworkDiscriminant (..) )
import Control.Monad
( forM_ )
import Data.Bifunctor
( second )
import Data.Delta
( Base, Delta (..) )
import Data.Generics.Internal.VL.Lens
( over, (^.) )
import Data.Maybe
( fromJust )
import Data.Store
( Store (..) )
import Fmt
( Buildable (..), listF, pretty )
import Test.Hspec
( Spec, around, describe, it )
import Test.QuickCheck
( Arbitrary (..)
, Blind (..)
, Gen
, Property
, choose
, counterexample
, frequency
, property
, sized
, vectorOf
)
import Test.QuickCheck.Monadic
( PropertyM, assert, monadicIO, monitor, pick, run )
import UnliftIO.Exception
( impureThrow )
import qualified Data.Map.Strict as Map
spec :: Spec
spec = do
around (withDBInMemory ForeignKeysEnabled) $ do
describe "Writing and loading" $ do
it "loadPrologue . insertPrologue = id for SeqState" $
property . prop_prologue_load_write @(SeqState 'Mainnet ShelleyKey) id
it "loadPrologue . insertPrologue = id for RndState" $
property . prop_prologue_load_write @(RndState 'Mainnet) id
it "loadPrologue . insertPrologue = id for SharedState" $
property . prop_prologue_load_write @(SharedState 'Mainnet SharedKey)
(\s -> s { ready = Pending })
around (withDBInMemory ForeignKeysEnabled) $ do
describe "Update" $ do
it "mkStoreWallet" $
property . prop_StoreWallet (ShelleyWallet @'Mainnet)
{-------------------------------------------------------------------------------
Properties
-------------------------------------------------------------------------------}
-- | Check that writing and loading the 'Prologue' works.
prop_prologue_load_write
:: forall s.
( PersistAddressBook s
, Buildable (Prologue s)
)
=> (s -> s) -> SqliteContext -> (WalletId, s) -> Property
prop_prologue_load_write preprocess db (wid, s) =
monadicIO $ run (toIO setup) >> prop
where
toIO = runQuery db
setup = initializeWallet wid
prop = prop_loadAfterWrite toIO (insertPrologue wid) (loadPrologue wid) pro
pro = getPrologue $ preprocess s
-- FIXME during ADP-1043: See note at 'multisigPoolAbsent'
-- | Checks that loading a value after writing it to a database table
-- is successful.
prop_loadAfterWrite
:: ( Monad m, Buildable (f a) , Eq (f a), Applicative f )
=> (forall b. m b -> IO b)
-- ^ Function to embed the monad in 'IO'
-> (a -> m ())
-- ^ Write operation
-> (m (f a))
-- ^ Load operation
-> a
-- ^ Property arguments
-> PropertyM IO ()
prop_loadAfterWrite toIO writeOp loadOp a = do
res <- run . toIO $ writeOp a >> loadOp
let fa = pure a
monitor $ counterexample $ "\nInserted\n" <> pretty fa
monitor $ counterexample $ "\nRead\n" <> pretty res
assertWith "Inserted == Read" (res == fa)
{-------------------------------------------------------------------------------
Update
-------------------------------------------------------------------------------}
prop_StoreWallet
:: forall s
. ( PersistAddressBook s
, GenState s
, Eq (KeyOf s 'RootK XPrv)
)
=> WalletFlavorS s
-> SqliteContext
-> (WalletId, InitialCheckpoint s)
-> Property
prop_StoreWallet wF db (wid, InitialCheckpoint cp0) =
monadicIO (setup >> prop)
where
toIO = runQuery db
setup = run . toIO $ initializeWallet wid
genState = do
wi <-
WalletInfo wid
<$> arbitrary
<*> pure dummyGenesisParameters
pure $ fromJust . fromGenesis cp0 $ wi
prop = do
prop_StoreUpdates
toIO
(mkStoreWallet wF wid)
genState
genDeltaWalletState
genDeltaWalletState
:: GenState s
=> GenDelta (DeltaWalletState s)
genDeltaWalletState wallet = frequency . map (second updateCheckpoints) $
[ (8, genPutCheckpoint)
, (1, pure $ RollbackTo Origin)
, (1, RollbackTo . At . SlotNo <$> choose (0, slotLatest))
, (1, RollbackTo . At . SlotNo <$> choose (slotLatest+1, slotLatest+10))
, (2, RestrictTo <$> genFilteredSlots)
, (1, pure $ RestrictTo [])
]
where
updateCheckpoints gen = (\x -> [UpdateCheckpoints [x]]) <$> gen
slotLatest = case getSlot . snd . fromWallet $ getLatest wallet of
Origin -> 0
At (SlotNo s) -> s
genSlotNo = SlotNo . (slotLatest +) <$> choose (1,10)
genPutCheckpoint = do
slot <- genSlotNo
cp <- over (#currentTip . #slotNo) (const slot) <$> arbitrary
pure $ PutCheckpoint (At slot) (snd $ fromWallet cp)
genFilteredSlots = do
let slots = Map.keys $ wallet ^. (#checkpoints . #checkpoints)
keeps <- vectorOf (length slots) arbitrary
pure . map fst . filter snd $ zip slots keeps
-- | Given a value, generate a random delta starting from this value.
type GenDelta da = Base da -> Gen da
-- | A sequence of updates and values after updating.
-- The update that is applied *last* appears in the list *first*.
newtype Updates da = Updates [(Base da, da)]
instance Show da => Show (Updates da) where
show (Updates xs) = show . map snd $ xs
-- | Randomly generate a sequence of updates
genUpdates :: Delta da => Gen (Base da) -> GenDelta da -> Gen (Updates da)
genUpdates gen0 more = sized $ \n -> go n [] =<< gen0
where
go 0 das _ = pure $ Updates das
go n das a0 = do
da <- more a0
let a1 = apply da a0
go (n-1) ((a1,da):das) a1
-- | Test whether 'updateS' and 'loadS' behave as expected.
--
-- TODO: Shrinking of the update sequence.
prop_StoreUpdates
:: ( Monad m, Delta da, Eq (Base da), Buildable da )
=> (forall b. m b -> IO b)
-- ^ Function to embed the monad in 'IO'
-> Store m qa da
-- ^ Store that is to be tested.
-> Gen (Base da)
-- ^ Generator for the initial value.
-> GenDelta da
-- ^ Generator for deltas.
-> PropertyM IO ()
prop_StoreUpdates toIO store gen0 more = do
let runs = run . toIO
-- randomly generate a sequence of updates
Blind a0 <- pick $ Blind <$> gen0
Blind (Updates adas) <- pick $ Blind <$> genUpdates (pure a0) more
let as = map fst adas ++ [a0]
das = map snd adas
monitor $ counterexample $
"\nUpdates applied:\n" <> pretty (listF das)
-- apply those updates
ea <- runs $ do
writeS store a0
-- first update is applied last!
let updates = reverse $ zip das (drop 1 as)
forM_ updates $ \(da,a) -> updateS store (Just a) da
loadS store
-- check whether the last value is correct
case ea of
Left err -> impureThrow err
Right a -> do
assert $ a == head as
{-------------------------------------------------------------------------------
QuickCheck utilities
-------------------------------------------------------------------------------}
-- | Like 'assert', but allow giving a label / title before running a assertion
assertWith :: String -> Bool -> PropertyM IO ()
assertWith lbl condition = do
let flag = if condition then "✓" else "✗"
monitor (counterexample $ lbl <> " " <> flag)
assert condition