[69] adding db unit tests

src/Cardano/Wallet.hs

@@ -26,7 +26,7 @@
 module Cardano.Wallet
     (
     -- * Wallet
-      Wallet
+      Wallet(..)
     , initWallet
     , currentTip
     , applyBlock

test/unit/Cardano/DBLayer/MVarSpec.hs

@@ -1,14 +1,139 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Cardano.DBLayer.MVarSpec
     ( spec
     ) where
 
 import Prelude
 
+import Cardano.DBLayer
+    ( DBLayer (..), PrimaryKey (..) )
 import Cardano.DBLayer.MVar
-    ()
+    ( newDBLayer )
+import Cardano.Wallet
+    ( Wallet (..), WalletId (..), initWallet )
+import Cardano.Wallet.Primitive
+    ( IsOurs (..) )
+import Control.Concurrent.Async
+    ( mapConcurrently_ )
+import Control.DeepSeq
+    ( NFData )
+import Control.Monad.IO.Class
+    ( liftIO )
+import Data.List.NonEmpty
+    ( NonEmpty ((:|)) )
 import Test.Hspec
-    ( Spec )
+    ( Spec, describe, it, shouldBe )
+import Test.QuickCheck
+    ( Arbitrary (..), Property, checkCoverage, choose, vectorOf )
+import Test.QuickCheck.Monadic
+    ( monadicIO )
 
+import qualified Data.Set as Set
+import qualified Data.Text as T
 
 spec :: Spec
-spec = return ()
+spec = do
+    describe "DB works as expected" $ do
+        it "readCheckpoints works properly"
+            (checkCoverage dbReadCheckpointsProp)
+        it "replacement of values works properly"
+            (checkCoverage dbReplaceValsProp)
+        it "multiple sequential putCheckpoints work properly"
+            (checkCoverage dbMultiplePutsSeqProp)
+        it "multiple parallel putCheckpoints work properly"
+            (checkCoverage dbMultiplePutsParProp)
+
+
+{-------------------------------------------------------------------------------
+                                    Properties
+-------------------------------------------------------------------------------}
+
+
+dbReadCheckpointsProp
+    :: (PrimaryKey WalletId, Int)
+    -> Property
+dbReadCheckpointsProp (key, val)  = monadicIO $ liftIO $ do
+    db <- newDBLayer
+
+    putCheckpoints db key (toWalletState val)
+    resFromDb <- readCheckpoints db key
+
+    resFromDb `shouldBe` (Just $ toWalletState val)
+
+
+dbReplaceValsProp
+    :: (PrimaryKey WalletId, Int, Int)
+    -> Property
+dbReplaceValsProp (key, val1, val2)  = monadicIO $ liftIO $ do
+    db <- newDBLayer
+
+    putCheckpoints db key (toWalletState val1)
+    putCheckpoints db key (toWalletState val2)
+    resFromDb <- readCheckpoints db key
+
+    resFromDb `shouldBe` (Just $ toWalletState val2)
+
+dbMultiplePutsSeqProp
+    :: KeyValPairs
+    -> Property
+dbMultiplePutsSeqProp (KeyValPairs keyValPairs) = monadicIO $ liftIO $ do
+    db <- newDBLayer
+
+    mapM_ (\(key, val) -> putCheckpoints db key (toWalletState val)) keyValPairs
+    resFromDb <- Set.fromList <$> readWallets db
+
+    resFromDb `shouldBe` (Set.fromList (map fst keyValPairs))
+
+dbMultiplePutsParProp
+    :: KeyValPairs
+    -> Property
+dbMultiplePutsParProp (KeyValPairs keyValPairs) = monadicIO $ liftIO $ do
+    db <- newDBLayer
+
+    mapConcurrently_ (\(key, val) -> putCheckpoints db key (toWalletState val)) keyValPairs
+    resFromDb <- Set.fromList <$> readWallets db
+
+    resFromDb `shouldBe` (Set.fromList (map fst keyValPairs))
+
+
+{-------------------------------------------------------------------------------
+                      Tests machinery, Arbitrary instances
+-------------------------------------------------------------------------------}
+
+
+newtype KeyValPairs = KeyValPairs [(PrimaryKey WalletId, Int)]
+    deriving (Show, Eq)
+
+instance Arbitrary KeyValPairs where
+    -- No shrinking
+    arbitrary = do
+        pairs <- choose (10, 50) >>= flip vectorOf arbitrary
+        KeyValPairs <$> pure pairs
+
+toWalletState
+    :: (IsOurs s, Semigroup s, NFData s, Show s) => s
+    -> NonEmpty (Wallet s)
+toWalletState val = initWallet val :| []
+
+instance Eq (Wallet Int) where
+    Wallet _ _ _ s1 == Wallet _ _ _ s2
+        = s1 == s2
+
+instance Show (PrimaryKey WalletId) where
+    show (PrimaryKey wid) = show wid
+
+instance IsOurs Int where
+    isOurs _ num = (True, num)
+
+instance Semigroup Int where
+    num1 <> num2 = num1 + num2
+
+instance Arbitrary (PrimaryKey WalletId) where
+    -- No shrinking
+    arbitrary = do
+        fiftyInts <- vectorOf 50 $ choose (0 :: Int, 9)
+        let key = (T.pack . show) fiftyInts
+        fmap PrimaryKey $ WalletId <$> pure key

test/unit/Cardano/WalletLayerSpec.hs

@@ -121,7 +121,7 @@ walletGetWrongIdProp newWallet = monadicIO $ liftIO $ do
 
 
 {-------------------------------------------------------------------------------
-                      Tests machinary, Arbitrary instances
+                      Tests machinery, Arbitrary instances
 -------------------------------------------------------------------------------}
 
 data WalletLayerFixture = WalletLayerFixture {