Split deterministic tests into separate modules (input-output-hk#2823)

This patch splits the deterministic tests into separate modules, so that
new tests can be added easily on them.

wallet-new/cardano-sl-wallet-new.cabal

@@ -248,6 +248,10 @@ executable cardano-integration-test
  Types
  Functions
  Error
+ Util
+ WalletSpecs
+ AddressSpecs
+ TransactionSpecs
 
  build-depends: base
  , aeson

wallet-new/integration/AddressSpecs.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
+
+module AddressSpecs (addressSpecs) where
+
+import Universum
+
+import Cardano.Wallet.Client.Http
+import Control.Lens hiding ((^..), (^?))
+import Test.Hspec
+
+import Util
+
+
+addressSpecs :: WalletRef -> WalletClient IO -> Spec
+addressSpecs wRef wc = do
+ describe "Addresses" $ do
+ it "Creating an address makes it available" $ do
+ -- create a wallet
+ Wallet{..} <- sampleWallet wRef wc
+
+ -- create an account
+ accResp <- postAccount wc walId (NewAccount Nothing "hello")
+ acc@Account{..} <- wrData <$> accResp `shouldPrism` _Right
+
+ -- accounts should exist
+ accResp' <- getAccounts wc walId
+ accs <- wrData <$> accResp' `shouldPrism` _Right
+ accs `shouldContain` [acc]
+
+ -- create an address
+ addResp <- postAddress wc (NewAddress Nothing accIndex walId)
+ addr <- wrData <$> addResp `shouldPrism` _Right
+
+ -- verify that address is in the API
+ idxResp <- getAddressIndex wc
+ addrs <- wrData <$> idxResp `shouldPrism` _Right
+
+ map addrId addrs `shouldContain` [addrId addr]
+
+ it "Index returns real data" $ do
+ addrsResp <- getAddressIndex wc
+ addrs <- wrData <$> addrsResp `shouldPrism` _Right
+
+ addrsResp' <- getAddressIndex wc
+ addrs' <- wrData <$> addrsResp' `shouldPrism` _Right
+
+ addrs `shouldBe` addrs'

wallet-new/integration/Main.hs

@@ -5,21 +5,19 @@ module Main where
 
 import Universum
 
-import Cardano.Wallet.API.V1.Errors (WalletError (WalletAlreadyExists), toServantError)
 import Cardano.Wallet.Client.Http
-import Control.Lens hiding ((^..), (^?))
 import Data.Map (fromList)
 import Data.Traversable (for)
-import qualified Pos.Core as Core
-import Servant (errBody)
 import System.IO (hSetEncoding, stdout, utf8)
-import System.IO.Unsafe (unsafePerformIO)
 import Test.Hspec
-import Test.QuickCheck (arbitrary, generate)
 
+import AddressSpecs (addressSpecs)
 import CLI
 import Functions
+import TransactionSpecs (transactionSpecs)
 import Types
+import Util (WalletRef, newWalletRef)
+import WalletSpecs (walletSpecs)
 
 -- | Here we want to run main when the (local) nodes
 -- have started.
@@ -59,7 +57,10 @@ main = do
  walletState
  actionDistribution
 
- hspec $ deterministicTests walletClient
+ -- Acquire the initial state for the deterministic tests
+ wRef <- newWalletRef
+
+ hspec $ deterministicTests wRef walletClient
  where
  actionDistribution :: ActionProbabilities
  actionDistribution = do
@@ -85,247 +86,8 @@ initialWalletState wc = do
  where
  fromResp = (either throwM (pure . wrData) =<<)
 
-deterministicTests :: WalletClient IO -> Spec
-deterministicTests wc = do
- describe "Addresses" $ do
- it "Creating an address makes it available" $ do
- -- create a wallet
- Wallet{..} <- sampleWallet
-
- -- create an account
- accResp <- postAccount wc walId (NewAccount Nothing "hello")
- acc@Account{..} <- wrData <$> accResp `shouldPrism` _Right
-
- -- accounts should exist
- accResp' <- getAccounts wc walId
- accs <- wrData <$> accResp' `shouldPrism` _Right
- accs `shouldContain` [acc]
-
- -- create an address
- addResp <- postAddress wc (NewAddress Nothing accIndex walId)
- addr <- wrData <$> addResp `shouldPrism` _Right
-
- -- verify that address is in the API
- idxResp <- getAddressIndex wc
- addrs <- wrData <$> idxResp `shouldPrism` _Right
-
- map addrId addrs `shouldContain` [addrId addr]
-
- it "Index returns real data" $ do
- addrsResp <- getAddressIndex wc
- addrs <- wrData <$> addrsResp `shouldPrism` _Right
-
- addrsResp' <- getAddressIndex wc
- addrs' <- wrData <$> addrsResp' `shouldPrism` _Right
-
- addrs `shouldBe` addrs'
-
- describe "Wallets" $ do
- it "Creating a wallet makes it available." $ do
- newWallet <- createRandomWallet
- Wallet{..} <- createWalletCheck newWallet
-
- eresp <- getWallet wc walId
- void $ eresp `shouldPrism` _Right
-
- it "Updating a wallet persists the update" $ do
- newWallet <- createRandomWallet
- wallet <- createWalletCheck newWallet
- let newName = "Foobar Bazquux"
- newAssurance = NormalAssurance
- eupdatedWallet <- updateWallet wc (walId wallet) WalletUpdate
- { uwalName = newName
- , uwalAssuranceLevel = newAssurance
- }
- Wallet{..} <- wrData <$> eupdatedWallet `shouldPrism` _Right
- walName `shouldBe` newName
- walAssuranceLevel `shouldBe` newAssurance
-
- it "CreateWallet with the same mnemonics rises WalletAlreadyExists error" $
- testWalletAlreadyExists CreateWallet
-
- it "RestoreWallet with the same mnemonics throws WalletAlreadyExists" $
- testWalletAlreadyExists RestoreWallet
-
- describe "Transactions" $ do
- it "posted transactions appear in the index" $ do
- genesis <- genesisWallet
- (fromAcct, _) <- firstAccountAndId genesis
-
- wallet <- sampleWallet
- (toAcct, toAddr) <- firstAccountAndId wallet
-
- let payment = Payment
- { pmtSource = PaymentSource
- { psWalletId = walId genesis
- , psAccountIndex = accIndex fromAcct
- }
- , pmtDestinations = pure PaymentDistribution
- { pdAddress = addrId toAddr
- , pdAmount = halfOf (accAmount fromAcct)
- }
- , pmtGroupingPolicy = Nothing
- , pmtSpendingPassword = Nothing
- }
- halfOf (V1 c) = V1 (Core.mkCoin (Core.getCoin c `div` 2))
-
- etxn <- postTransaction wc payment
-
- txn <- fmap wrData etxn `shouldPrism` _Right
-
- eresp <- getTransactionIndex wc
- (Just (walId wallet))
- (Just (accIndex toAcct))
- Nothing
- resp <- fmap wrData eresp `shouldPrism` _Right
-
- map txId resp `shouldContain` [txId txn]
-
- it "estimate fees of a well-formed transaction" $ do
- ws <- (,)
- <$> (createRandomWallet >>= createWalletCheck)
- <*> (createRandomWallet >>= createWalletCheck)
-
- ((fromAcct, _), (_toAcct, toAddr)) <- (,)
- <$> firstAccountAndId (fst ws)
- <*> firstAccountAndId (snd ws)
-
- let amount = V1 (Core.mkCoin 42)
-
- let payment = Payment
- { pmtSource = PaymentSource
- { psWalletId = walId (fst ws)
- , psAccountIndex = accIndex fromAcct
- }
- , pmtDestinations = pure PaymentDistribution
- { pdAddress = addrId toAddr
- , pdAmount = amount
- }
- , pmtGroupingPolicy = Nothing
- , pmtSpendingPassword = Nothing
- }
-
- efee <- getTransactionFee wc payment
- fee <- fmap (feeEstimatedAmount . wrData) efee `shouldPrism` _Right
- fee `shouldSatisfy` (> amount)
-
- it "fails if you spend too much money" $ do
- wallet <- sampleWallet
- (toAcct, toAddr) <- firstAccountAndId wallet
-
- let payment = Payment
- { pmtSource = PaymentSource
- { psWalletId = walId wallet
- , psAccountIndex = accIndex toAcct
- }
- , pmtDestinations = pure PaymentDistribution
- { pdAddress = addrId toAddr
- , pdAmount = tooMuchCash (accAmount toAcct)
- }
- , pmtGroupingPolicy = Nothing
- , pmtSpendingPassword = Nothing
- }
- tooMuchCash (V1 c) = V1 (Core.mkCoin (Core.getCoin c * 2))
- etxn <- postTransaction wc payment
-
- void $ etxn `shouldPrism` _Left
-
- where
- randomWallet action =
- generate $
- NewWallet
- <$> arbitrary
- <*> pure Nothing
- <*> arbitrary
- <*> pure "Wallet"
- <*> pure action
- createRandomWallet = randomWallet CreateWallet
-
- testWalletAlreadyExists action = do
- newWallet1 <- randomWallet action
- preWallet2 <- randomWallet action
- let newWallet2 =
- preWallet2
- { newwalBackupPhrase = newwalBackupPhrase newWallet1
- }
- -- First wallet creation/restoration should succeed
- result <- postWallet wc newWallet1
- void $ result `shouldPrism` _Right
- -- Second wallet creation/restoration should rise WalletAlreadyExists
- eresp <- postWallet wc newWallet2
- clientError <- eresp `shouldPrism` _Left
- let errorBody = errBody $ toServantError WalletAlreadyExists
- case clientError of
- ClientHttpError (FailureResponse response) ->
- responseBody response `shouldBe` errorBody
- _ ->
- expectationFailure $
- "expected (ClientHttpError FailureResponse) but got: "
- <> show clientError
-
- createWalletCheck newWallet = do
- result <- fmap wrData <$> postWallet wc newWallet
- result `shouldPrism` _Right
-
- firstAccountAndId wallet = do
- etoAccts <- getAccounts wc (walId wallet)
- toAccts <- fmap wrData etoAccts `shouldPrism` _Right
-
- toAccts `shouldSatisfy` (not . null)
- let (toAcct : _) = toAccts
-
- accAddresses toAcct `shouldSatisfy` (not . null)
- let (toAddr : _) = accAddresses toAcct
-
- pure (toAcct, toAddr)
-
- -- this is a "Safe' usage of `unsafePerformIO`. if it's too gross then
- -- I can delete it.
- walletRef :: MVar Wallet
- walletRef = unsafePerformIO newEmptyMVar
- {-# NOINLINE walletRef #-}
-
- sampleWallet :: IO Wallet
- sampleWallet = do
- mwallet <- tryTakeMVar walletRef
- case mwallet of
- Just wallet -> do
- putMVar walletRef wallet
- pure wallet
- Nothing -> do
- w <- createRandomWallet
- w' <- createWalletCheck w
- didWrite <- tryPutMVar walletRef w'
- if didWrite
- then pure w'
- else readMVar walletRef
-
- genesisWallet :: IO Wallet
- genesisWallet = do
- mwallet <- tryTakeMVar genesisRef
- case mwallet of
- Just wallet -> do
- putMVar genesisRef wallet
- pure wallet
- Nothing -> do
- Right allWallets <- fmap wrData <$> getWallets wc
- wallet <- maybe
- (fail "Genesis wallet is missing; did you import it prior to executing the test-suite?")
- return
- (find (("Genesis wallet" ==) . walName) allWallets)
- didWrite <- tryPutMVar genesisRef wallet
- if didWrite
- then pure wallet
- else readMVar genesisRef
-
- genesisRef :: MVar Wallet
- genesisRef = unsafePerformIO newEmptyMVar
- {-# NOINLINE genesisRef #-}
-
-shouldPrism :: Show s => s -> Prism' s a -> IO a
-shouldPrism a b = do
- a `shouldSatisfy` has b
- let Just x = a ^? b
- pure x
-
-infixr 8 `shouldPrism`
+deterministicTests :: WalletRef -> WalletClient IO -> Spec
+deterministicTests wref wc = do
+ addressSpecs wref wc
+ walletSpecs wref wc
+ transactionSpecs wref wc