Add DB-Layer Unit Tests

.travis.yml

@@ -98,8 +98,9 @@ jobs:
     name: "Haddock"
     script:
     - tar xzf $STACK_WORK_CACHE
+    - cp -Rv specifications/api api
     - mkdir -p haddock && mv $(stack path --local-doc-root)/* haddock
-    - git add haddock && git commit -m $TRAVIS_COMMIT
+    - git add api haddock && git commit -m $TRAVIS_COMMIT
     - git checkout gh-pages && git cherry-pick -X theirs -n - && git commit --allow-empty --no-edit
     - git push -f -q https://WilliamKingNoel-Bot:[email protected]/input-output-hk/cardano-wallet gh-pages &>/dev/null
 

README.md

@@ -1,17 +1,54 @@
 <p align="center">
-  <big><strong>Cardano-Wallet</strong></big>
+  <big><strong>Cardano Wallet</strong></big>
 </p>
 
 <p align="center">
   <img width="200" src=".github/images/cardano-logo.png"/>
 </p>
 
 <p align="center">
-  <!-- We will need to decide on that soon enough <img src="https://img.shields.io/badge/version-x.x.x-ff69b4.svg?style=for-the-badge" /> -->
+  <a href="https://github.com/input-output-hk/cardano-wallet/releases"><img src="https://img.shields.io/github/release/input-output-hk/cardano-wallet.svg?style=for-the-badge" /></a>
   <a href="https://travis-ci.org/input-output-hk/cardano-wallet"><img src="https://img.shields.io/travis/input-output-hk/cardano-wallet.svg?style=for-the-badge" /></a>
   <a href="https://coveralls.io/github/input-output-hk/cardano-wallet"><img src="https://img.shields.io/coveralls/github/input-output-hk/cardano-wallet.svg?style=for-the-badge" /></a>
 </p>
 
+<hr/>
+
+Cardano Wallet helps you manage your Ada. You can use it to send and
+receive payments on the [Cardano](https://www.cardano.org) blockchain.
+
+This project provides an HTTP Application Programming Interface (API)
+and command-line interface (CLI) for working with your wallet.
+
+It can be used as a component of a frontend such as
+[Daedalus](https://daedaluswallet.io), which provides a friendly user
+interface for wallets. Most users who would like to use Cardano should
+start with Daedalus.
+
+## Development
+
+This source code repository contains the next major version of Cardano
+Wallet, which has been completely rewritten for the
+[Shelley](https://cardanoroadmap.com/) phase.
+
+The Byron version of Cardano Wallet is in the
+[cardano-sl](https://github.com/input-output-hk/cardano-sl)
+repository.
+
+## How to build
+
+Use [Haskell Stack](https://haskellstack.org/) to build this project:
+
+    stack build --test
+
+
+## Documentation
+
+ * Users of the Cardano Wallet API can refer to the [API Documentation](https://input-output-hk.github.io/cardano-wallet/api/).
+ * Development-related information can be found in the [Wiki](https://github.com/input-output-hk/cardano-wallet/wiki).
+ * To help understand the source code, refer to the [Haddock Documentation](https://input-output-hk.github.io/cardano-wallet/haddock/).
+
+
 <hr/>
 
 <p align="center">

src/Cardano/Wallet.hs

@@ -122,6 +122,7 @@ data Wallet s where
         -> Wallet s
 
 deriving instance Show (Wallet s)
+deriving instance Eq s => Eq (Wallet s)
 
 instance NFData (Wallet s) where
     rnf (Wallet utxo pending sl s) =

src/Cardano/Wallet/Binary/Packfile.hs

@@ -45,8 +45,7 @@ decodePackfile pf = case runGetOrFail getHeader pf of
         Left e -> Left e
         Right () -> case runGetOrFail getBlobs rest of
             Left (_, _, msg) -> Left (BlobDecodeError msg)
-            Right ("", _, res) -> Right res
-            Right (_, _, _) -> Left (BlobDecodeError "Unconsumed data")
+            Right (_, _, res) -> Right res
 
 data Header = Header !BS.ByteString !Int
 

test/unit/Cardano/DBLayer/MVarSpec.hs

@@ -1,14 +1,139 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Cardano.DBLayer.MVarSpec
     ( spec
     ) where
 
 import Prelude
 
+import Cardano.DBLayer
+    ( DBLayer (..), PrimaryKey (..) )
 import Cardano.DBLayer.MVar
-    ()
+    ( newDBLayer )
+import Cardano.Wallet
+    ( Wallet, WalletId (..), initWallet )
+import Cardano.Wallet.Primitive
+    ( IsOurs (..) )
+import Control.Concurrent.Async
+    ( mapConcurrently_ )
+import Control.DeepSeq
+    ( NFData )
+import Control.Monad.IO.Class
+    ( liftIO )
+import Data.List.NonEmpty
+    ( NonEmpty ((:|)) )
 import Test.Hspec
-    ( Spec )
+    ( Spec, before, describe, it, shouldBe )
+import Test.QuickCheck
+    ( Arbitrary (..), Property, choose, property, vectorOf )
+import Test.QuickCheck.Monadic
+    ( monadicIO )
 
+import qualified Data.Set as Set
+import qualified Data.Text as T
 
 spec :: Spec
-spec = return ()
+spec = do
+    describe "DB works as expected" $ before newDBLayer $ do
+        it "readCheckpoints . putCheckpoints yields inserted checkpoints" $
+            \db -> (property $ dbReadCheckpointsProp db)
+        it "replacement of values returns last value that was put" $
+            \db -> (property $ dbReplaceValsProp db)
+        it "multiple sequential putCheckpoints work properly" $
+            \db -> (property $ dbMultiplePutsSeqProp db)
+        it "multiple parallel putCheckpoints work properly" $
+            \db -> (property $ dbMultiplePutsParProp db)
+
+{-------------------------------------------------------------------------------
+                                    Properties
+-------------------------------------------------------------------------------}
+
+
+dbReadCheckpointsProp
+    :: DBLayer IO DummyState
+    -> (PrimaryKey WalletId, DummyState)
+    -> Property
+dbReadCheckpointsProp db (key, val)  = monadicIO $ liftIO $ do
+    putCheckpoints db key (toWalletState val)
+    resFromDb <- readCheckpoints db key
+
+    resFromDb `shouldBe` (Just $ toWalletState val)
+
+dbReplaceValsProp
+    :: DBLayer IO DummyState
+    -> (PrimaryKey WalletId, DummyState, DummyState)
+    -> Property
+dbReplaceValsProp db (key, val1, val2)  = monadicIO $ liftIO $ do
+    putCheckpoints db key (toWalletState val1)
+    putCheckpoints db key (toWalletState val2)
+    resFromDb <- readCheckpoints db key
+
+    resFromDb `shouldBe` (Just $ toWalletState val2)
+
+dbMultiplePutsSeqProp
+    :: DBLayer IO DummyState
+    -> KeyValPairs
+    -> Property
+dbMultiplePutsSeqProp db (KeyValPairs keyValPairs) = monadicIO $ liftIO $ do
+    mapM_ (\(key, val) -> putCheckpoints db key (toWalletState val)) keyValPairs
+    resFromDb <- Set.fromList <$> readWallets db
+
+    resFromDb `shouldBe` (Set.fromList (map fst keyValPairs))
+
+dbMultiplePutsParProp
+    :: DBLayer IO DummyState
+    -> KeyValPairs
+    -> Property
+dbMultiplePutsParProp db (KeyValPairs keyValPairs) = monadicIO $ liftIO $ do
+    mapConcurrently_ (\(key, val) -> putCheckpoints db key (toWalletState val)) keyValPairs
+    resFromDb <- Set.fromList <$> readWallets db
+
+    resFromDb `shouldBe` (Set.fromList (map fst keyValPairs))
+
+{-------------------------------------------------------------------------------
+                      Tests machinery, Arbitrary instances
+-------------------------------------------------------------------------------}
+
+
+newtype KeyValPairs = KeyValPairs [(PrimaryKey WalletId, DummyState)]
+    deriving (Show, Eq)
+
+instance Arbitrary KeyValPairs where
+    -- No shrinking
+    arbitrary = do
+        pairs <- choose (10, 50) >>= flip vectorOf arbitrary
+        KeyValPairs <$> pure pairs
+
+newtype DummyState = DummyState Int
+    deriving (Show, Eq)
+
+instance Arbitrary DummyState where
+    -- No shrinking
+    arbitrary = DummyState <$> arbitrary
+
+deriving instance NFData DummyState
+
+instance IsOurs DummyState where
+    isOurs _ num = (True, num)
+
+instance Semigroup DummyState where
+    (DummyState num1) <> (DummyState num2)
+        = DummyState (num1 + num2)
+
+deriving instance Show (PrimaryKey WalletId)
+
+instance Arbitrary (PrimaryKey WalletId) where
+    -- No shrinking
+    arbitrary = do
+        nums <- vectorOf 10 $ choose (0 :: Int, 9)
+        let key = (T.pack . show) nums
+        fmap PrimaryKey $ WalletId <$> pure key
+
+toWalletState
+    :: (IsOurs s, Semigroup s, NFData s, Show s) => s
+    -> NonEmpty (Wallet s)
+toWalletState val = initWallet val :| []

test/unit/Cardano/Wallet/Binary/PackfileSpec.hs

@@ -47,10 +47,14 @@ spec = do
             let decoded = decodePackfile "\254CARDANOYOLO\NUL\NUL\NUL\SOH"
             decoded `shouldBe` Left WrongFileTypeError
 
-        it "should ensure pack file version" $ do
+        it "should ensure pack file version is lesser" $ do
             let decoded = decodePackfile "\254CARDANOPACK\NUL\NUL\NUL\2"
             decoded `shouldBe` Left VersionTooNewError
 
+        it "should ensure pack file version is greater" $ do
+            let decoded = decodePackfile "\254CARDANOPACK\NUL\NUL\NUL\0"
+            decoded `shouldBe` Left VersionTooOldError
+
         it "should decode an empty pack file" $ do
             decodePackfile packFileHeader `shouldBe` Right []
 

test/unit/Cardano/WalletLayerSpec.hs

@@ -54,8 +54,8 @@ import Test.QuickCheck
     , InfiniteList (..)
     , Property
     , arbitraryBoundedEnum
-    , checkCoverage
     , choose
+    , property
     , vectorOf
     )
 import Test.QuickCheck.Monadic
@@ -72,13 +72,13 @@ spec :: Spec
 spec = do
     describe "WalletLayer works as expected" $ do
         it "Wallet upon creation is written down in db"
-            (checkCoverage walletCreationProp)
+            (property walletCreationProp)
         it "Wallet cannot be created more than once"
-            (checkCoverage walletDoubleCreationProp)
+            (property walletDoubleCreationProp)
         it "Wallet after being created can be got using valid wallet Id"
-            (checkCoverage walletGetProp)
+            (property walletGetProp)
         it "Wallet with wrong wallet Id cannot be got"
-            (checkCoverage walletGetWrongIdProp)
+            (property walletGetWrongIdProp)
 
 
 {-------------------------------------------------------------------------------
@@ -121,7 +121,7 @@ walletGetWrongIdProp newWallet = monadicIO $ liftIO $ do
 
 
 {-------------------------------------------------------------------------------
-                      Tests machinary, Arbitrary instances
+                      Tests machinery, Arbitrary instances
 -------------------------------------------------------------------------------}
 
 data WalletLayerFixture = WalletLayerFixture {