[CDEC-509] Add some tests for Pos.DB.Functions before refactoring

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

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

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)

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

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]

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
 ];