Skip to content

Commit

Permalink
[23] add createWallet
Browse files Browse the repository at this point in the history
[23] Add mockup unit test

[23] Add create/get wallet tests

[23] fix last test

[23] enhance test suite

[23] Turn on FlexibleContexts

[23] make sure putCheckpoints is evaluated
  • Loading branch information
paweljakubas committed Mar 19, 2019
1 parent cf82c19 commit 1469c47
Show file tree
Hide file tree
Showing 4 changed files with 218 additions and 6 deletions.
2 changes: 2 additions & 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 All @@ -154,6 +155,7 @@ executable cardano-wallet-server
, docopt
, say
, text
, transformers
hs-source-dirs:
app
app/server
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)
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

0 comments on commit 1469c47

Please sign in to comment.