[23] add createWallet

[23] Add mockup unit test

[23] Add create/get wallet tests

[23] fix last test

app/server/Main.hs

@@ -23,6 +23,8 @@ import Cardano.WalletLayer
     ( NewWallet (..), WalletLayer (..), mkWalletLayer )
 import Control.Monad
     ( when )
+import Control.Monad.Trans.Except
+    ( runExceptT )
 import System.Console.Docopt
     ( Docopt
     , argument
@@ -70,11 +72,15 @@ main = do
     network <- HttpBridge.newNetworkLayer (T.pack . encode $ networkName) bridgePort
     db <- MVar.newDBLayer
     let wallet = mkWalletLayer db network
-    wid <- createWallet wallet NewWallet
-        { mnemonic = mnemonicSentence
-        , mnemonic2ndFactor = mempty
-        , name = WalletName "My Wallet"
-        , passphrase = mempty
-        , gap = minBound
-        }
-    watchWallet wallet wid
+    widE <- runExceptT $ createWallet wallet NewWallet
+           { mnemonic = mnemonicSentence
+           , mnemonic2ndFactor = mempty
+           , name = WalletName "My Wallet"
+           , passphrase = mempty
+           , gap = minBound
+           }
+    case widE of
+        Left e ->
+            print e
+        Right wid ->
+            watchWallet wallet wid

cardano-wallet.cabal

@@ -131,6 +131,7 @@ test-suite unit
       Cardano.Wallet.BinarySpec
       Cardano.Wallet.MnemonicSpec
       Cardano.Wallet.PrimitiveSpec
+      Cardano.WalletLayerSpec
       Cardano.WalletSpec
   if os(windows)
     build-depends: Win32
@@ -155,6 +156,7 @@ executable cardano-wallet-server
     , cardano-wallet
     , docopt
     , text
+    , transformers
   hs-source-dirs:
       app
       app/server

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/NetworkLayer/HttpBridgeSpec.hs

@@ -1,5 +1,7 @@
 module Cardano.NetworkLayer.HttpBridgeSpec
     ( spec
+    , mockNetworkLayer
+    , noLog
     ) where
 
 import Prelude

test/unit/Cardano/WalletLayerSpec.hs

@@ -0,0 +1,127 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# 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.HttpBridgeSpec
+    ( mockNetworkLayer, noLog )
+import Cardano.Wallet
+    ( WalletId (..), WalletName (..) )
+import Cardano.Wallet.AddressDerivationSpec
+    ()
+import Cardano.Wallet.AddressDiscovery
+    ( SeqState )
+import Cardano.Wallet.AddressDiscoverySpec
+    ()
+import Cardano.Wallet.MnemonicSpec
+    ()
+import Cardano.Wallet.Primitive
+    ( SlotId (..) )
+import Cardano.WalletLayer
+    ( NewWallet (..), WalletLayer (..), mkWalletLayer )
+import Control.Monad.IO.Class
+    ( liftIO )
+import Control.Monad.Trans.Except
+    ( runExceptT )
+import Data.Either
+    ( isLeft, isRight )
+import Data.Maybe
+    ( isJust )
+import Test.Hspec
+    ( Spec, describe, it, shouldSatisfy )
+import Test.QuickCheck
+    ( Arbitrary (..), Property, checkCoverage )
+import Test.QuickCheck.Monadic
+    ( monadicIO )
+
+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 and cannot be created more than once"
+            (checkCoverage walletCreationProp)
+        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)
+
+
+{-------------------------------------------------------------------------------
+                                    Test Logic
+-------------------------------------------------------------------------------}
+
+data WalletLayerFixture = WalletLayerFixture {
+      _fixtureDBLayer :: DBLayer IO SeqState
+    , _fixtureWalletLayer :: WalletLayer IO SeqState
+    }
+
+prepareWalletLayerFixture :: IO WalletLayerFixture
+prepareWalletLayerFixture = do
+    db <- newDBLayer
+    let network = mockNetworkLayer noLog 105 (SlotId 106 1492)
+    let walletLayer = mkWalletLayer db network
+    return $ WalletLayerFixture db walletLayer
+
+
+instance Arbitrary NewWallet where
+    -- No shrinking
+    arbitrary = NewWallet
+                <$> arbitrary
+                <*> arbitrary
+                <*> pure (WalletName "My Wallet")
+                <*> arbitrary
+                <*> arbitrary
+
+
+walletCreationProp
+    :: NewWallet
+    -> Property
+walletCreationProp newWallet = monadicIO $ liftIO $ do
+    (WalletLayerFixture db wl) <- liftIO prepareWalletLayerFixture
+    res <- runExceptT $ createWallet wl newWallet
+    case res of
+        Left e ->
+            fail $ show e
+        Right walletId -> do
+            resFromDb <- readCheckpoints db (PrimaryKey walletId)
+            resFromDb `shouldSatisfy` isJust
+            --the same wallet creation second time
+            secondTrial <- runExceptT $ createWallet wl newWallet
+            secondTrial `shouldSatisfy` isLeft
+
+walletGetProp
+    :: NewWallet
+    -> Property
+walletGetProp newWallet = monadicIO $ liftIO $ do
+    (WalletLayerFixture _db wl) <- liftIO prepareWalletLayerFixture
+    res <- runExceptT $ createWallet wl newWallet
+    case res of
+        Left e ->
+            fail $ show e
+        Right walletId -> do
+            resFromGet <- runExceptT $ getWallet wl walletId
+            resFromGet `shouldSatisfy` isRight
+
+walletGetWrongIdProp
+    :: NewWallet
+    -> Property
+walletGetWrongIdProp newWallet = monadicIO $ liftIO $ do
+    (WalletLayerFixture _db wl) <- liftIO prepareWalletLayerFixture
+    res <- runExceptT $ createWallet wl newWallet
+    case res of
+        Left e ->
+            fail $ show e
+        Right (WalletId walletId) -> do
+            let corruptedWalletId = WalletId $ T.append "@ " walletId
+            attempt <- runExceptT $ getWallet wl corruptedWalletId
+            attempt `shouldSatisfy` isLeft