Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add createWallet and getWallet tests #82

Merged
merged 1 commit into from
Mar 19, 2019
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions cardano-wallet.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -129,6 +129,7 @@ test-suite unit
Cardano.Wallet.BinarySpec
Cardano.Wallet.MnemonicSpec
Cardano.Wallet.PrimitiveSpec
Cardano.WalletLayerSpec
Cardano.WalletSpec
if os(windows)
build-depends: Win32
Expand Down
4 changes: 3 additions & 1 deletion src/Cardano/DBLayer/MVar.hs
Original file line number Diff line number Diff line change
Expand Up @@ -18,6 +18,8 @@ import Cardano.DBLayer
( DBLayer (..) )
import Control.Concurrent.MVar
( modifyMVar_, newMVar, readMVar )
import Control.DeepSeq
( deepseq )

import qualified Data.Map.Strict as Map

Expand All @@ -29,7 +31,7 @@ newDBLayer = do
wallets <- newMVar mempty
return $ DBLayer
{ putCheckpoints = \key cps ->
modifyMVar_ wallets (return . Map.insert key cps)
cps `deepseq` (modifyMVar_ wallets (return . Map.insert key cps))
, readCheckpoints = \key ->
Map.lookup key <$> readMVar wallets
, readWallets =
Expand Down
19 changes: 14 additions & 5 deletions src/Cardano/WalletLayer.hs
Original file line number Diff line number Diff line change
Expand Up @@ -61,10 +61,9 @@ import Say

import qualified Data.Set as Set


-- | Types
data WalletLayer m s = WalletLayer
{ createWallet :: NewWallet -> m WalletId
{ createWallet :: NewWallet -> ExceptT CreateWalletError m WalletId
, getWallet :: WalletId -> ExceptT GetWalletError m (Wallet s)
, watchWallet :: WalletId -> m ()
}
Expand All @@ -85,7 +84,13 @@ data NewWallet = NewWallet
-- | Errors occuring when fetching a wallet
newtype GetWalletError
= ErrGetWalletNotFound WalletId
deriving Show
deriving (Eq, Show)

-- | Errors occuring when creating a wallet
newtype CreateWalletError
= ErrCreateWalletIdAlreadyExists WalletId
deriving (Eq, Show)


-- | Create a new instance of the wallet layer.
mkWalletLayer
Expand All @@ -108,8 +113,12 @@ mkWalletLayer db network = WalletLayer
let wallet =
initWallet $ SeqState (extPool, intPool)
let wid = WalletId $ getWalletName $ name w
putCheckpoints db (PrimaryKey wid) (wallet :| [])
return wid
lift (readCheckpoints db (PrimaryKey wid)) >>= \case
Nothing -> do
lift $ putCheckpoints db (PrimaryKey wid) (wallet :| [])
return wid
Just _ ->
throwE $ ErrCreateWalletIdAlreadyExists wid
, getWallet = \wid -> lift (readCheckpoints db (PrimaryKey wid)) >>= \case
Nothing ->
throwE $ ErrGetWalletNotFound wid
Expand Down
199 changes: 199 additions & 0 deletions test/unit/Cardano/WalletLayerSpec.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,199 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Cardano.WalletLayerSpec
( spec
) where


import Prelude

import Cardano.DBLayer
( DBLayer (..), PrimaryKey (..) )
import Cardano.DBLayer.MVar
( newDBLayer )
import Cardano.NetworkLayer.HttpBridge
( newNetworkLayer )
import Cardano.Wallet
( WalletId (..), WalletName (..) )
import Cardano.Wallet.AddressDerivation
( Passphrase (..) )
import Cardano.Wallet.AddressDiscovery
( AddressPoolGap, SeqState )
import Cardano.Wallet.Mnemonic
( Entropy
, EntropySize
, Mnemonic
, MnemonicException (..)
, MnemonicWords
, ambiguousNatVal
, entropyToMnemonic
, mkEntropy
)
import Cardano.WalletLayer
( NewWallet (..), WalletLayer (..), mkWalletLayer )
import Control.Monad.IO.Class
( liftIO )
import Control.Monad.Trans.Except
( runExceptT )
import Crypto.Encoding.BIP39
( ValidChecksumSize, ValidEntropySize, ValidMnemonicSentence )
import Data.Either
( isLeft, isRight )
import Data.Maybe
( isJust )
import Test.Hspec
( Spec, describe, it, shouldSatisfy )
import Test.QuickCheck
( Arbitrary (..)
, InfiniteList (..)
, Property
, arbitraryBoundedEnum
, checkCoverage
, choose
, vectorOf
)
import Test.QuickCheck.Monadic
( monadicIO )

import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
import qualified Data.List as L
import qualified Data.Text as T


spec :: Spec
spec = do
describe "WalletLayer works as expected" $ do
it "Wallet upon creation is written down in db"
(checkCoverage walletCreationProp)
Copy link
Contributor

@piotr-iohk piotr-iohk Mar 19, 2019

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Does it makes sense to use checkCoverage when there is no cover or coverTable used in the property?
(Just asking, as I simply don't know :)
cc @paweljakubas , @KtorZ

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@piotr-iohk Nope it doesn't :)

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Without any cover or coverTable, it's equivalent to doing just property.

it "Wallet cannot be created more than once"
(checkCoverage walletDoubleCreationProp)
it "Wallet after being created can be got using valid wallet Id"
(checkCoverage walletGetProp)
it "Wallet with wrong wallet Id cannot be got"
(checkCoverage walletGetWrongIdProp)


{-------------------------------------------------------------------------------
Properties
-------------------------------------------------------------------------------}

walletCreationProp
:: NewWallet
-> Property
walletCreationProp newWallet = monadicIO $ liftIO $ do
(WalletLayerFixture db _wl walletIds) <- setupFixture newWallet

resFromDb <- readCheckpoints db (PrimaryKey $ L.head walletIds)

resFromDb `shouldSatisfy` isJust


walletDoubleCreationProp
:: NewWallet
-> Property
walletDoubleCreationProp newWallet = monadicIO $ liftIO $ do
(WalletLayerFixture _db wl _walletIds) <- setupFixture newWallet

secondTrial <- runExceptT $ createWallet wl newWallet

secondTrial `shouldSatisfy` isLeft


walletGetProp
:: NewWallet
-> Property
walletGetProp newWallet = monadicIO $ liftIO $ do
(WalletLayerFixture _db wl walletIds) <- liftIO $ setupFixture newWallet

resFromGet <- runExceptT $ getWallet wl (L.head walletIds)

resFromGet `shouldSatisfy` isRight

walletGetWrongIdProp
:: NewWallet
-> Property
walletGetWrongIdProp newWallet = monadicIO $ liftIO $ do
(WalletLayerFixture _db wl walletIds) <- liftIO $ setupFixture newWallet

let (WalletId storedWalletId) = L.head walletIds
let corruptedWalletId = WalletId $ T.append "@ " storedWalletId
attempt <- runExceptT $ getWallet wl corruptedWalletId

attempt `shouldSatisfy` isLeft


{-------------------------------------------------------------------------------
Tests machinary, Arbitrary instances
-------------------------------------------------------------------------------}

data WalletLayerFixture = WalletLayerFixture {
_fixtureDBLayer :: DBLayer IO SeqState
, _fixtureWalletLayer :: WalletLayer IO SeqState
, _fixtureWallet :: [WalletId]
}

setupFixture
:: NewWallet
-> IO WalletLayerFixture
setupFixture newWallet = do
db <- newDBLayer
network <- newNetworkLayer "testnetwork" 8000
let wl = mkWalletLayer db network
res <- runExceptT $ createWallet wl newWallet
let wal = case res of
Left _ -> []
Right walletId -> [walletId]
pure $ WalletLayerFixture db wl wal

instance Arbitrary NewWallet where
-- No shrinking
arbitrary = NewWallet
<$> arbitrary
<*> arbitrary
<*> pure (WalletName "My Wallet")
<*> arbitrary
<*> arbitrary

instance
( ValidEntropySize n
, ValidChecksumSize n csz
) => Arbitrary (Entropy n) where
arbitrary =
let
size = fromIntegral $ ambiguousNatVal @n
entropy =
mkEntropy @n . B8.pack <$> vectorOf (size `quot` 8) arbitrary
in
either (error . show . UnexpectedEntropyError) id <$> entropy

-- | Same remark from 'Arbitrary Entropy' applies here.
instance
( n ~ EntropySize mw
, mw ~ MnemonicWords n
, ValidChecksumSize n csz
, ValidEntropySize n
, ValidMnemonicSentence mw
, Arbitrary (Entropy n)
) => Arbitrary (Mnemonic mw) where
arbitrary =
entropyToMnemonic <$> arbitrary @(Entropy n)

instance Arbitrary (Passphrase goal) where
shrink (Passphrase "") = []
shrink (Passphrase _ ) = [Passphrase ""]
arbitrary = do
n <- choose (0, 32)
InfiniteList bytes _ <- arbitrary
return $ Passphrase $ BA.convert $ BS.pack $ take n bytes

instance Arbitrary AddressPoolGap where
shrink _ = []
arbitrary = arbitraryBoundedEnum