Skip to content
Permalink
Browse files

Conclude reshuffling

  • Loading branch information...
paweljakubas committed May 16, 2019
1 parent 4e373b0 commit 09239940b190341f4c3b09adc5b79a38d14ef1a8
Showing with 101 additions and 125 deletions.
  1. +3 −112 lib/core/test/unit/Cardano/Wallet/DB/MVarSpec.hs
  2. +98 −13 lib/core/test/unit/Cardano/Wallet/DBSpec.hs
@@ -1,7 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

@@ -16,117 +15,9 @@ import Cardano.Wallet.DB
import Cardano.Wallet.DB.MVar
( newDBLayer )
import Cardano.Wallet.DBSpec
( DummyStateMVar (..)
, DummyTarget
, lrp
, prop_createListWallet
, prop_createWalletTwice
, prop_isolation
, prop_parallelPut
, prop_putBeforeInit
, prop_readAfterDelete
, prop_readAfterPut
, prop_removeWalletTwice
, prop_sequentialPut
, readTxHistoryF
, unions
)
import Cardano.Wallet.Primitive.Types
( Hash (..), Tx (..), TxMeta (..) )
import Data.Map.Strict
( Map )
( DummyStateMVar (..), DummyTarget, dbPropertyTests )
import Test.Hspec
( Spec, before, describe, it )
import Test.QuickCheck
( checkCoverage, property )
( Spec )

spec :: Spec
spec = do
before (newDBLayer :: IO (DBLayer IO DummyStateMVar DummyTarget)) $
describe "Extra Properties about DB initialization" $ do
it "createWallet . listWallets yields expected results"
(property . prop_createListWallet)
it "creating same wallet twice yields an error"
(property . prop_createWalletTwice)
it "removing the same wallet twice yields an error"
(property . prop_removeWalletTwice)

before (newDBLayer :: IO (DBLayer IO DummyStateMVar DummyTarget)) $
describe "put . read yields a result" $ do
it "Checkpoint"
(property . (prop_readAfterPut putCheckpoint readCheckpoint))
it "Wallet Metadata"
(property . (prop_readAfterPut putWalletMeta readWalletMeta))
it "Tx History"
(property . (prop_readAfterPut putTxHistory readTxHistoryF))
it "Private Key"
(property . (prop_readAfterPut putPrivateKey readPrivateKey))

before (newDBLayer :: IO (DBLayer IO DummyStateMVar DummyTarget)) $
describe "can't put before wallet exists" $ do
it "Checkpoint"
(property . (prop_putBeforeInit putCheckpoint readCheckpoint Nothing))
it "Wallet Metadata"
(property . (prop_putBeforeInit putWalletMeta readWalletMeta Nothing))
it "Tx History"
(property . (prop_putBeforeInit putTxHistory readTxHistoryF (pure mempty)))
it "Private Key"
(property . (prop_putBeforeInit putPrivateKey readPrivateKey Nothing))

before (newDBLayer :: IO (DBLayer IO DummyStateMVar DummyTarget)) $
describe "put doesn't affect other resources" $ do
it "Checkpoint vs Wallet Metadata & Tx History & Private Key"
(property . (prop_isolation putCheckpoint
readWalletMeta
readTxHistoryF
readPrivateKey)
)
it "Wallet Metadata vs Tx History & Checkpoint & Private Key"
(property . (prop_isolation putWalletMeta
readTxHistoryF
readCheckpoint
readPrivateKey)
)
it "Tx History vs Checkpoint & Wallet Metadata & Private Key"
(property . (prop_isolation putTxHistory
readCheckpoint
readWalletMeta
readPrivateKey)
)

before (newDBLayer :: IO (DBLayer IO DummyStateMVar DummyTarget)) $
describe "can't read after delete" $ do
it "Checkpoint"
(property . (prop_readAfterDelete readCheckpoint Nothing))
it "Wallet Metadata"
(property . (prop_readAfterDelete readWalletMeta Nothing))
it "Tx History"
(property . (prop_readAfterDelete readTxHistoryF (pure mempty)))
it "Private Key"
(property . (prop_readAfterDelete readPrivateKey Nothing))

before (newDBLayer :: IO (DBLayer IO DummyStateMVar DummyTarget)) $
describe "sequential puts replace values in order" $ do
it "Checkpoint"
(checkCoverage . (prop_sequentialPut putCheckpoint readCheckpoint lrp))
it "Wallet Metadata"
(checkCoverage . (prop_sequentialPut putWalletMeta readWalletMeta lrp))
it "Tx History"
(checkCoverage . (prop_sequentialPut putTxHistory readTxHistoryF unions))
it "Private Key"
(checkCoverage . (prop_sequentialPut putPrivateKey readPrivateKey lrp))

before (newDBLayer :: IO (DBLayer IO DummyStateMVar DummyTarget)) $
describe "parallel puts replace values in _any_ order" $ do
it "Checkpoint"
(checkCoverage . (prop_parallelPut putCheckpoint readCheckpoint
(length . lrp @Maybe)))
it "Wallet Metadata"
(checkCoverage . (prop_parallelPut putWalletMeta readWalletMeta
(length . lrp @Maybe)))
it "Tx History"
(checkCoverage . (prop_parallelPut putTxHistory readTxHistoryF
(length . unions @(Map (Hash "Tx") (Tx, TxMeta)))))
it "Private Key"
(checkCoverage . (prop_parallelPut putPrivateKey readPrivateKey
(length . lrp @Maybe)))
spec = dbPropertyTests (newDBLayer :: IO (DBLayer IO DummyStateMVar DummyTarget))
@@ -15,19 +15,8 @@ module Cardano.Wallet.DBSpec
( spec
, DummyTarget
, DummyStateMVar (..)
, lrp
, unions
, readTxHistoryF
, prop_createListWallet
, prop_readAfterDelete
, prop_createWalletTwice
, prop_removeWalletTwice
, prop_readAfterPut
, dbPropertyTests
, prop_readAfterPutBoundary
, prop_putBeforeInit
, prop_sequentialPut
, prop_isolation
, prop_parallelPut
) where

import Prelude
@@ -93,19 +82,21 @@ import GHC.Generics
import System.IO.Unsafe
( unsafePerformIO )
import Test.Hspec
( Spec, shouldBe, shouldReturn )
( Spec, before, describe, it, shouldBe, shouldReturn )
import Test.QuickCheck
( Arbitrary (..)
, Gen
, InfiniteList (..)
, Property
, arbitraryBoundedEnum
, checkCoverage
, choose
, cover
, elements
, generate
, genericShrink
, oneof
, property
, scale
, suchThat
, vectorOf
@@ -598,3 +589,97 @@ prop_parallelPut putOp readOp resolve dbLayer (KeyValPairs pairs) =
forConcurrently_ pairs $ unsafeRunExceptT . uncurry (putOp db)
res <- once pairs (readOp db . fst)
length res `shouldBe` resolve pairs

dbPropertyTests
:: (Arbitrary (Wallet s DummyTarget), Show s, Eq s, IsOurs s, NFData s)
=> IO (DBLayer IO s DummyTarget)
-> Spec
dbPropertyTests dbLayer = do
before dbLayer $
describe "Extra Properties about DB initialization" $ do
it "createWallet . listWallets yields expected results"
(property . prop_createListWallet)
it "creating same wallet twice yields an error"
(property . prop_createWalletTwice)
it "removing the same wallet twice yields an error"
(property . prop_removeWalletTwice)

before dbLayer $
describe "put . read yields a result" $ do
it "Checkpoint"
(property . (prop_readAfterPut putCheckpoint readCheckpoint))
it "Wallet Metadata"
(property . (prop_readAfterPut putWalletMeta readWalletMeta))
it "Tx History"
(property . (prop_readAfterPut putTxHistory readTxHistoryF))
it "Private Key"
(property . (prop_readAfterPut putPrivateKey readPrivateKey))

before dbLayer $
describe "can't put before wallet exists" $ do
it "Checkpoint"
(property . (prop_putBeforeInit putCheckpoint readCheckpoint Nothing))
it "Wallet Metadata"
(property . (prop_putBeforeInit putWalletMeta readWalletMeta Nothing))
it "Tx History"
(property . (prop_putBeforeInit putTxHistory readTxHistoryF (pure mempty)))
it "Private Key"
(property . (prop_putBeforeInit putPrivateKey readPrivateKey Nothing))

before dbLayer $
describe "put doesn't affect other resources" $ do
it "Checkpoint vs Wallet Metadata & Tx History & Private Key"
(property . (prop_isolation putCheckpoint
readWalletMeta
readTxHistoryF
readPrivateKey)
)
it "Wallet Metadata vs Tx History & Checkpoint & Private Key"
(property . (prop_isolation putWalletMeta
readTxHistoryF
readCheckpoint
readPrivateKey)
)
it "Tx History vs Checkpoint & Wallet Metadata & Private Key"
(property . (prop_isolation putTxHistory
readCheckpoint
readWalletMeta
readPrivateKey)
)

before dbLayer $
describe "can't read after delete" $ do
it "Checkpoint"
(property . (prop_readAfterDelete readCheckpoint Nothing))
it "Wallet Metadata"
(property . (prop_readAfterDelete readWalletMeta Nothing))
it "Tx History"
(property . (prop_readAfterDelete readTxHistoryF (pure mempty)))
it "Private Key"
(property . (prop_readAfterDelete readPrivateKey Nothing))

before dbLayer $
describe "sequential puts replace values in order" $ do
it "Checkpoint"
(checkCoverage . (prop_sequentialPut putCheckpoint readCheckpoint lrp))
it "Wallet Metadata"
(checkCoverage . (prop_sequentialPut putWalletMeta readWalletMeta lrp))
it "Tx History"
(checkCoverage . (prop_sequentialPut putTxHistory readTxHistoryF unions))
it "Private Key"
(checkCoverage . (prop_sequentialPut putPrivateKey readPrivateKey lrp))

before dbLayer $
describe "parallel puts replace values in _any_ order" $ do
it "Checkpoint"
(checkCoverage . (prop_parallelPut putCheckpoint readCheckpoint
(length . lrp @Maybe)))
it "Wallet Metadata"
(checkCoverage . (prop_parallelPut putWalletMeta readWalletMeta
(length . lrp @Maybe)))
it "Tx History"
(checkCoverage . (prop_parallelPut putTxHistory readTxHistoryF
(length . unions @(Map (Hash "Tx") (Tx, TxMeta)))))
it "Private Key"
(checkCoverage . (prop_parallelPut putPrivateKey readPrivateKey
(length . lrp @Maybe)))

0 comments on commit 0923994

Please sign in to comment.
You can’t perform that action at this time.