Skip to content
This repository was archived by the owner on Aug 18, 2020. It is now read-only.

Commit 61d56cb

Browse files
ruhatchruhatch
committed
[CDEC-509] Add some tests for Pos.DB.Functions before refactoring
1 parent eef8d1e commit 61d56cb

File tree

6 files changed

+208
-2
lines changed

6 files changed

+208
-2
lines changed

‎db/cardano-sl-db.cabal

+5
Original file line numberDiff line numberDiff line change
@@ -197,15 +197,20 @@ test-suite test
197197
hs-source-dirs: test
198198
main-is: test.hs
199199
other-modules: Test.Pos.DB.Epoch.Index
200+
Test.Pos.DB.Functions
201+
Test.Pos.DB.Mode
200202
type: exitcode-stdio-1.0
201203
build-depends: base
204+
, cardano-sl-binary
202205
, cardano-sl-binary-test
203206
, cardano-sl-core
204207
, cardano-sl-core-test
205208
, cardano-sl-db
209+
, cardano-sl-util
206210
, cardano-sl-util-test
207211
, filepath
208212
, hedgehog
213+
, lens
209214
, temporary
210215
, universum
211216
default-language: Haskell2010

‎db/src/Pos/DB/Rocks/Functions.hs

+6-1
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ module Pos.DB.Rocks.Functions
1111
, closeRocksDB
1212
, openNodeDBs
1313
, closeNodeDBs
14+
, deleteNodeDBs
1415
, usingReadOptions
1516
, usingWriteOptions
1617

@@ -39,7 +40,7 @@ import Data.Conduit (ConduitT, bracketP, yield)
3940
import qualified Database.RocksDB as Rocks
4041
import System.Directory (createDirectoryIfMissing, doesDirectoryExist,
4142
removeDirectoryRecursive)
42-
import System.FilePath ((</>))
43+
import System.FilePath (takeDirectory, (</>))
4344

4445
import Pos.Binary.Class (Bi)
4546
import Pos.Core.Configuration (HasCoreConfiguration)
@@ -106,6 +107,10 @@ closeNodeDBs :: MonadIO m => NodeDBs -> m ()
106107
closeNodeDBs NodeDBs {..} =
107108
mapM_ closeRocksDB [_blockIndexDB, _gStateDB, _lrcDB, _miscDB]
108109

110+
deleteNodeDBs :: MonadIO m => NodeDBs -> m ()
111+
deleteNodeDBs =
112+
liftIO . removeDirectoryRecursive . takeDirectory . _epochDataDir
113+
109114
usingReadOptions
110115
:: MonadRealDB ctx m
111116
=> Rocks.ReadOptions

‎db/test/Test/Pos/DB/Functions.hs

+118
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,118 @@
1+
{-# LANGUAGE FlexibleContexts #-}
2+
{-# LANGUAGE Rank2Types #-}
3+
{-# LANGUAGE ScopedTypeVariables #-}
4+
{-# LANGUAGE TemplateHaskell #-}
5+
6+
module Test.Pos.DB.Functions
7+
( tests
8+
) where
9+
10+
import Universum
11+
12+
import Hedgehog
13+
14+
import Pos.Binary.Class (Bi)
15+
import Pos.Core (HasConfiguration, withCoreConfiguration)
16+
import Pos.DB (DBTag (..), dbGetBi, dbGetBiNoVersion, dbPutBi,
17+
dbPutBiNoVersion)
18+
19+
import Test.Pos.Core.Dummy (dummyCoreConfiguration)
20+
import Test.Pos.Core.ExampleHelpers (exampleBlockVersionData,
21+
exampleSscPayload)
22+
import Test.Pos.DB.Mode (runTestMode)
23+
24+
25+
--------------------------------------------------------------------------------
26+
-- | Trying to read a missing key results in a @Nothing@ value
27+
--
28+
prop_missingKey :: Property
29+
prop_missingKey = withTests 1 $ dbProperty $ do
30+
result :: Maybe Bool <- liftIO . runTestMode $ dbGetBi MiscDB "test/bool"
31+
result === Nothing
32+
33+
34+
--------------------------------------------------------------------------------
35+
-- | We can write values into the database and read them back
36+
--
37+
prop_putGet :: Property
38+
prop_putGet = withTests 1 $ dbProperty $ do
39+
putGetProperty "test/bool" True
40+
putGetProperty "test/int" (10000 :: Int)
41+
putGetProperty "test/bytestring" ("testing" :: ByteString)
42+
putGetProperty "test/blockversiondata" exampleBlockVersionData
43+
putGetProperty "test/sscpayload" exampleSscPayload
44+
45+
46+
--------------------------------------------------------------------------------
47+
-- | We can write values with an explicit version and read them back
48+
--
49+
prop_putGetExplicitVersion :: Property
50+
prop_putGetExplicitVersion = withTests 1 $ dbProperty $ do
51+
putGetExplicitVersionProperty "test/bool" True
52+
putGetExplicitVersionProperty "test/int" (10000 :: Int)
53+
putGetExplicitVersionProperty "test/bytestring" ("testing" :: ByteString)
54+
putGetExplicitVersionProperty
55+
"test/blockversiondata"
56+
exampleBlockVersionData
57+
putGetExplicitVersionProperty "test/sscpayload" exampleSscPayload
58+
59+
60+
--------------------------------------------------------------------------------
61+
-- | We can write values with no version and read them back
62+
--
63+
prop_putGetNoVersion :: Property
64+
prop_putGetNoVersion = withTests 1 $ dbProperty $ do
65+
putGetNoVersionProperty "test/bool" True
66+
putGetNoVersionProperty "test/int" (10000 :: Int)
67+
putGetNoVersionProperty "test/bytestring" ("testing" :: ByteString)
68+
putGetNoVersionProperty "test/blockversiondata" exampleBlockVersionData
69+
putGetNoVersionProperty "test/sscpayload" exampleSscPayload
70+
71+
72+
--------------------------------------------------------------------------------
73+
-- Hedgehog Helpers
74+
--------------------------------------------------------------------------------
75+
76+
dbProperty :: (HasConfiguration => PropertyT IO ()) -> Property
77+
dbProperty prop = property $ withCoreConfiguration dummyCoreConfiguration prop
78+
79+
putGetProperty
80+
:: (HasConfiguration, Bi a, Eq a, Show a)
81+
=> ByteString
82+
-> a
83+
-> PropertyT IO ()
84+
putGetProperty k v = do
85+
result <- liftIO . runTestMode $ do
86+
dbPutBi MiscDB k v
87+
dbGetBi MiscDB k
88+
result === Just v
89+
90+
putGetExplicitVersionProperty
91+
:: (HasConfiguration, Bi a, Eq a, Show a)
92+
=> ByteString
93+
-> a
94+
-> PropertyT IO ()
95+
putGetExplicitVersionProperty k v = do
96+
result <- liftIO . runTestMode $ do
97+
dbPutBiNoVersion MiscDB k (0 :: Word8, v)
98+
dbGetBi MiscDB k
99+
result === Just v
100+
101+
putGetNoVersionProperty
102+
:: (HasConfiguration, Bi a, Eq a, Show a)
103+
=> ByteString
104+
-> a
105+
-> PropertyT IO ()
106+
putGetNoVersionProperty k v = do
107+
result <- liftIO . runTestMode $ do
108+
dbPutBiNoVersion MiscDB k v
109+
dbGetBiNoVersion MiscDB k
110+
result === Just v
111+
112+
113+
--------------------------------------------------------------------------------
114+
-- Main Testing Function
115+
--------------------------------------------------------------------------------
116+
117+
tests :: IO Bool
118+
tests = checkSequential $$(discover)

‎db/test/Test/Pos/DB/Mode.hs

+74
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,74 @@
1+
{-# LANGUAGE FlexibleContexts #-}
2+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+
{-# LANGUAGE MultiParamTypeClasses #-}
4+
{-# LANGUAGE TemplateHaskell #-}
5+
{-# LANGUAGE UndecidableInstances #-}
6+
7+
module Test.Pos.DB.Mode
8+
( TestMode
9+
, runTestMode
10+
) where
11+
12+
13+
import Universum
14+
15+
import Control.Lens (makeLenses)
16+
17+
import Pos.Core (HasConfiguration)
18+
19+
import Pos.DB (MonadDB (..), MonadDBRead (..), NodeDBs, closeNodeDBs,
20+
dbDeleteDefault, dbGetDefault, dbIterSourceDefault,
21+
dbPutDefault, dbWriteBatchDefault, deleteNodeDBs,
22+
openNodeDBs)
23+
import Pos.DB.Block (dbGetSerBlockRealDefault,
24+
dbGetSerBlundRealDefault, dbGetSerUndoRealDefault,
25+
dbPutSerBlundsRealDefault)
26+
import Pos.Util.Util (HasLens (..))
27+
28+
29+
--------------------------------------------------------------------------------
30+
-- | We are forced to introduce a @TestMode@ and @TestContext@ because of the
31+
-- @MonadRealDB ctx m@ based design. A neater alternative might be to have a
32+
-- @DB.Handle@ containing the @NodeDBs@, which is passed explicitly.
33+
--
34+
newtype TestMode a = TestMode
35+
{ unTestMode :: ReaderT TestContext IO a
36+
} deriving ( Functor
37+
, Applicative
38+
, Monad
39+
, MonadCatch
40+
, MonadIO
41+
, MonadThrow
42+
, MonadReader TestContext
43+
)
44+
45+
runTestMode :: TestMode a -> IO a
46+
runTestMode testMode =
47+
bracket acquire release $ runReaderT (unTestMode testMode) . TestContext
48+
where
49+
acquire = openNodeDBs True "test-db"
50+
release nodeDBs = do
51+
closeNodeDBs nodeDBs
52+
deleteNodeDBs nodeDBs
53+
54+
instance HasConfiguration => MonadDBRead TestMode where
55+
dbGet = dbGetDefault
56+
dbIterSource = dbIterSourceDefault
57+
dbGetSerBlock = dbGetSerBlockRealDefault
58+
dbGetSerUndo = dbGetSerUndoRealDefault
59+
dbGetSerBlund = dbGetSerBlundRealDefault
60+
61+
instance HasConfiguration => MonadDB TestMode where
62+
dbPut = dbPutDefault
63+
dbWriteBatch = dbWriteBatchDefault
64+
dbDelete = dbDeleteDefault
65+
dbPutSerBlunds = dbPutSerBlundsRealDefault
66+
67+
data TestContext = TestContext
68+
{ _tcNodeDBs :: NodeDBs
69+
}
70+
71+
makeLenses ''TestContext
72+
73+
instance HasLens NodeDBs TestContext NodeDBs where
74+
lensOf = tcNodeDBs

‎db/test/test.hs

+2-1
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,8 @@
11
import Universum
22

33
import qualified Test.Pos.DB.Epoch.Index
4+
import qualified Test.Pos.DB.Functions
45
import Test.Pos.Util.Tripping (runTests)
56

67
main :: IO ()
7-
main = runTests [Test.Pos.DB.Epoch.Index.tests]
8+
main = runTests [Test.Pos.DB.Epoch.Index.tests, Test.Pos.DB.Functions.tests]

‎pkgs/default.nix

+3
Original file line numberDiff line numberDiff line change
@@ -16205,12 +16205,15 @@ cpphs
1620516205
];
1620616206
testHaskellDepends = [
1620716207
base
16208+
cardano-sl-binary
1620816209
cardano-sl-binary-test
1620916210
cardano-sl-core
1621016211
cardano-sl-core-test
16212+
cardano-sl-util
1621116213
cardano-sl-util-test
1621216214
filepath
1621316215
hedgehog
16216+
lens
1621416217
temporary
1621516218
universum
1621616219
];

0 commit comments

Comments
 (0)