Merge pull request #82 from input-output-hk/paweljakubas/23/create-ge…

…t-wallet-impl

Add createWallet and getWallet tests

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

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 =

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

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