diff --git a/cardano-wallet.cabal b/cardano-wallet.cabal index 975b64f380d..5a3e2326545 100644 --- a/cardano-wallet.cabal +++ b/cardano-wallet.cabal @@ -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 @@ -154,6 +155,7 @@ executable cardano-wallet-server , docopt , say , text + , transformers hs-source-dirs: app app/server diff --git a/src/Cardano/DBLayer/MVar.hs b/src/Cardano/DBLayer/MVar.hs index 1274c7a341d..e05a23d6a0b 100644 --- a/src/Cardano/DBLayer/MVar.hs +++ b/src/Cardano/DBLayer/MVar.hs @@ -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 @@ -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 = diff --git a/src/Cardano/WalletLayer.hs b/src/Cardano/WalletLayer.hs index 71749ae04ba..1b00b7dfcbd 100644 --- a/src/Cardano/WalletLayer.hs +++ b/src/Cardano/WalletLayer.hs @@ -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 () } @@ -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 @@ -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 diff --git a/test/unit/Cardano/WalletLayerSpec.hs b/test/unit/Cardano/WalletLayerSpec.hs new file mode 100644 index 00000000000..046043e8258 --- /dev/null +++ b/test/unit/Cardano/WalletLayerSpec.hs @@ -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