diff --git a/db/cardano-sl-db.cabal b/db/cardano-sl-db.cabal index cdba1c233e5..63c9e99d33b 100644 --- a/db/cardano-sl-db.cabal +++ b/db/cardano-sl-db.cabal @@ -197,15 +197,20 @@ test-suite test hs-source-dirs: test main-is: test.hs other-modules: Test.Pos.DB.Epoch.Index + Test.Pos.DB.Functions + Test.Pos.DB.Mode type: exitcode-stdio-1.0 build-depends: base + , cardano-sl-binary , cardano-sl-binary-test , cardano-sl-core , cardano-sl-core-test , cardano-sl-db + , cardano-sl-util , cardano-sl-util-test , filepath , hedgehog + , lens , temporary , universum default-language: Haskell2010 diff --git a/db/src/Pos/DB/Rocks/Functions.hs b/db/src/Pos/DB/Rocks/Functions.hs index fab6d481d4c..c5eed5dca2f 100644 --- a/db/src/Pos/DB/Rocks/Functions.hs +++ b/db/src/Pos/DB/Rocks/Functions.hs @@ -11,6 +11,7 @@ module Pos.DB.Rocks.Functions , closeRocksDB , openNodeDBs , closeNodeDBs + , deleteNodeDBs , usingReadOptions , usingWriteOptions @@ -39,7 +40,7 @@ import Data.Conduit (ConduitT, bracketP, yield) import qualified Database.RocksDB as Rocks import System.Directory (createDirectoryIfMissing, doesDirectoryExist, removeDirectoryRecursive) -import System.FilePath (()) +import System.FilePath (takeDirectory, ()) import Pos.Binary.Class (Bi) import Pos.Core.Configuration (HasCoreConfiguration) @@ -106,6 +107,10 @@ closeNodeDBs :: MonadIO m => NodeDBs -> m () closeNodeDBs NodeDBs {..} = mapM_ closeRocksDB [_blockIndexDB, _gStateDB, _lrcDB, _miscDB] +deleteNodeDBs :: MonadIO m => NodeDBs -> m () +deleteNodeDBs = + liftIO . removeDirectoryRecursive . takeDirectory . _epochDataDir + usingReadOptions :: MonadRealDB ctx m => Rocks.ReadOptions diff --git a/db/test/Test/Pos/DB/Functions.hs b/db/test/Test/Pos/DB/Functions.hs new file mode 100644 index 00000000000..349ac37da00 --- /dev/null +++ b/db/test/Test/Pos/DB/Functions.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Test.Pos.DB.Functions + ( tests + ) where + +import Universum + +import Hedgehog + +import Pos.Binary.Class (Bi) +import Pos.Core (HasConfiguration, withCoreConfiguration) +import Pos.DB (DBTag (..), dbGetBi, dbGetBiNoVersion, dbPutBi, + dbPutBiNoVersion) + +import Test.Pos.Core.Dummy (dummyCoreConfiguration) +import Test.Pos.Core.ExampleHelpers (exampleBlockVersionData, + exampleSscPayload) +import Test.Pos.DB.Mode (runTestMode) + + +-------------------------------------------------------------------------------- +-- | Trying to read a missing key results in a @Nothing@ value +-- +prop_missingKey :: Property +prop_missingKey = withTests 1 $ dbProperty $ do + result :: Maybe Bool <- liftIO . runTestMode $ dbGetBi MiscDB "test/bool" + result === Nothing + + +-------------------------------------------------------------------------------- +-- | We can write values into the database and read them back +-- +prop_putGet :: Property +prop_putGet = withTests 1 $ dbProperty $ do + putGetProperty "test/bool" True + putGetProperty "test/int" (10000 :: Int) + putGetProperty "test/bytestring" ("testing" :: ByteString) + putGetProperty "test/blockversiondata" exampleBlockVersionData + putGetProperty "test/sscpayload" exampleSscPayload + + +-------------------------------------------------------------------------------- +-- | We can write values with an explicit version and read them back +-- +prop_putGetExplicitVersion :: Property +prop_putGetExplicitVersion = withTests 1 $ dbProperty $ do + putGetExplicitVersionProperty "test/bool" True + putGetExplicitVersionProperty "test/int" (10000 :: Int) + putGetExplicitVersionProperty "test/bytestring" ("testing" :: ByteString) + putGetExplicitVersionProperty + "test/blockversiondata" + exampleBlockVersionData + putGetExplicitVersionProperty "test/sscpayload" exampleSscPayload + + +-------------------------------------------------------------------------------- +-- | We can write values with no version and read them back +-- +prop_putGetNoVersion :: Property +prop_putGetNoVersion = withTests 1 $ dbProperty $ do + putGetNoVersionProperty "test/bool" True + putGetNoVersionProperty "test/int" (10000 :: Int) + putGetNoVersionProperty "test/bytestring" ("testing" :: ByteString) + putGetNoVersionProperty "test/blockversiondata" exampleBlockVersionData + putGetNoVersionProperty "test/sscpayload" exampleSscPayload + + +-------------------------------------------------------------------------------- +-- Hedgehog Helpers +-------------------------------------------------------------------------------- + +dbProperty :: (HasConfiguration => PropertyT IO ()) -> Property +dbProperty prop = property $ withCoreConfiguration dummyCoreConfiguration prop + +putGetProperty + :: (HasConfiguration, Bi a, Eq a, Show a) + => ByteString + -> a + -> PropertyT IO () +putGetProperty k v = do + result <- liftIO . runTestMode $ do + dbPutBi MiscDB k v + dbGetBi MiscDB k + result === Just v + +putGetExplicitVersionProperty + :: (HasConfiguration, Bi a, Eq a, Show a) + => ByteString + -> a + -> PropertyT IO () +putGetExplicitVersionProperty k v = do + result <- liftIO . runTestMode $ do + dbPutBiNoVersion MiscDB k (0 :: Word8, v) + dbGetBi MiscDB k + result === Just v + +putGetNoVersionProperty + :: (HasConfiguration, Bi a, Eq a, Show a) + => ByteString + -> a + -> PropertyT IO () +putGetNoVersionProperty k v = do + result <- liftIO . runTestMode $ do + dbPutBiNoVersion MiscDB k v + dbGetBiNoVersion MiscDB k + result === Just v + + +-------------------------------------------------------------------------------- +-- Main Testing Function +-------------------------------------------------------------------------------- + +tests :: IO Bool +tests = checkSequential $$(discover) diff --git a/db/test/Test/Pos/DB/Mode.hs b/db/test/Test/Pos/DB/Mode.hs new file mode 100644 index 00000000000..e81ddbc9c8f --- /dev/null +++ b/db/test/Test/Pos/DB/Mode.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module Test.Pos.DB.Mode + ( TestMode + , runTestMode + ) where + + +import Universum + +import Control.Lens (makeLenses) + +import Pos.Core (HasConfiguration) + +import Pos.DB (MonadDB (..), MonadDBRead (..), NodeDBs, closeNodeDBs, + dbDeleteDefault, dbGetDefault, dbIterSourceDefault, + dbPutDefault, dbWriteBatchDefault, deleteNodeDBs, + openNodeDBs) +import Pos.DB.Block (dbGetSerBlockRealDefault, + dbGetSerBlundRealDefault, dbGetSerUndoRealDefault, + dbPutSerBlundsRealDefault) +import Pos.Util.Util (HasLens (..)) + + +-------------------------------------------------------------------------------- +-- | We are forced to introduce a @TestMode@ and @TestContext@ because of the +-- @MonadRealDB ctx m@ based design. A neater alternative might be to have a +-- @DB.Handle@ containing the @NodeDBs@, which is passed explicitly. +-- +newtype TestMode a = TestMode + { unTestMode :: ReaderT TestContext IO a + } deriving ( Functor + , Applicative + , Monad + , MonadCatch + , MonadIO + , MonadThrow + , MonadReader TestContext + ) + +runTestMode :: TestMode a -> IO a +runTestMode testMode = + bracket acquire release $ runReaderT (unTestMode testMode) . TestContext + where + acquire = openNodeDBs True "test-db" + release nodeDBs = do + closeNodeDBs nodeDBs + deleteNodeDBs nodeDBs + +instance HasConfiguration => MonadDBRead TestMode where + dbGet = dbGetDefault + dbIterSource = dbIterSourceDefault + dbGetSerBlock = dbGetSerBlockRealDefault + dbGetSerUndo = dbGetSerUndoRealDefault + dbGetSerBlund = dbGetSerBlundRealDefault + +instance HasConfiguration => MonadDB TestMode where + dbPut = dbPutDefault + dbWriteBatch = dbWriteBatchDefault + dbDelete = dbDeleteDefault + dbPutSerBlunds = dbPutSerBlundsRealDefault + +data TestContext = TestContext + { _tcNodeDBs :: NodeDBs + } + +makeLenses ''TestContext + +instance HasLens NodeDBs TestContext NodeDBs where + lensOf = tcNodeDBs diff --git a/db/test/test.hs b/db/test/test.hs index 0c98569bcae..5e15c39af0a 100644 --- a/db/test/test.hs +++ b/db/test/test.hs @@ -1,7 +1,8 @@ import Universum import qualified Test.Pos.DB.Epoch.Index +import qualified Test.Pos.DB.Functions import Test.Pos.Util.Tripping (runTests) main :: IO () -main = runTests [Test.Pos.DB.Epoch.Index.tests] +main = runTests [Test.Pos.DB.Epoch.Index.tests, Test.Pos.DB.Functions.tests] diff --git a/pkgs/default.nix b/pkgs/default.nix index bbe1c865899..5d5fa7e18ef 100644 --- a/pkgs/default.nix +++ b/pkgs/default.nix @@ -16205,12 +16205,15 @@ cpphs ]; testHaskellDepends = [ base +cardano-sl-binary cardano-sl-binary-test cardano-sl-core cardano-sl-core-test +cardano-sl-util cardano-sl-util-test filepath hedgehog +lens temporary universum ];