From 40ca2c2fafc3d8a84b061422fb6081831d240bbd Mon Sep 17 00:00:00 2001 From: KtorZ Date: Thu, 25 Apr 2019 12:24:47 +0200 Subject: [PATCH 1/2] store private key in DB & provide an accessor to read it back later --- src/Cardano/Wallet.hs | 5 ++++- src/Cardano/Wallet/DB.hs | 9 +++++++++ src/Cardano/Wallet/DB/MVar.hs | 26 ++++++++++++++++++-------- 3 files changed, 31 insertions(+), 9 deletions(-) diff --git a/src/Cardano/Wallet.hs b/src/Cardano/Wallet.hs index 2cadb1ad091..50d42fd8e7d 100644 --- a/src/Cardano/Wallet.hs +++ b/src/Cardano/Wallet.hs @@ -57,6 +57,7 @@ import Cardano.Wallet.Primitive.AddressDerivation , XPrv , deriveAccountPrivateKey , digest + , encryptPassphrase , generateKeyFromSeed , publicKey ) @@ -252,7 +253,9 @@ mkWalletLayer db network = WalletLayer , status = Restoring minBound , delegation = NotDelegating } - DB.createWallet db (PrimaryKey wid) checkpoint metadata $> wid + hpwd <- liftIO $ encryptPassphrase (passphrase w) + let creds = ( rootXPrv, hpwd ) + DB.createWallet db (PrimaryKey wid) checkpoint metadata creds $> wid , readWallet = _readWallet diff --git a/src/Cardano/Wallet/DB.hs b/src/Cardano/Wallet/DB.hs index 14a1a20e636..ffddf72363e 100644 --- a/src/Cardano/Wallet/DB.hs +++ b/src/Cardano/Wallet/DB.hs @@ -20,6 +20,8 @@ module Cardano.Wallet.DB import Prelude +import Cardano.Wallet.Primitive.AddressDerivation + ( Depth (..), Key, XPrv ) import Cardano.Wallet.Primitive.Model ( Wallet ) import Cardano.Wallet.Primitive.Types @@ -38,6 +40,7 @@ data DBLayer m s = DBLayer :: PrimaryKey WalletId -> Wallet s -> WalletMetadata + -> (Key 'RootK XPrv, Hash "encryption") -> ExceptT ErrWalletAlreadyExists m () -- ^ Initialize a database entry for a given wallet. 'putCheckpoint', -- 'putWalletMeta' or 'putTxHistory' will actually all fail if they are @@ -103,6 +106,12 @@ data DBLayer m s = DBLayer -- -- Returns an empty map if the wallet isn't found. + , readPrivateKey + :: PrimaryKey WalletId + -> m (Maybe (Key 'RootK XPrv, Hash "encryption")) + -- ^ Read a previously stored private key and its associated passphrase + -- hash. + , withLock :: forall e a. () => ExceptT e m a diff --git a/src/Cardano/Wallet/DB/MVar.hs b/src/Cardano/Wallet/DB/MVar.hs index 55ec0e0ba77..91bb1675b4e 100644 --- a/src/Cardano/Wallet/DB/MVar.hs +++ b/src/Cardano/Wallet/DB/MVar.hs @@ -22,6 +22,8 @@ import Cardano.Wallet.DB , ErrWalletAlreadyExists (..) , PrimaryKey (..) ) +import Cardano.Wallet.Primitive.AddressDerivation + ( Depth (..), Key, XPrv ) import Cardano.Wallet.Primitive.Model ( Wallet ) import Cardano.Wallet.Primitive.Types @@ -41,6 +43,7 @@ data Database s = Database { wallet :: Wallet s , metadata :: WalletMetadata , txHistory :: Map (Hash "Tx") (Tx, TxMeta) + , xprv :: (Key 'RootK XPrv, Hash "encryption") } -- | Instantiate a new in-memory "database" layer that simply stores data in @@ -55,10 +58,10 @@ newDBLayer = do Wallets -----------------------------------------------------------------------} - { createWallet = \key@(PrimaryKey wid) cp meta -> ExceptT $ do + { createWallet = \key@(PrimaryKey wid) cp meta k -> ExceptT $ do let alter = \case Nothing -> - Right $ Just $ Database cp meta mempty + Right $ Just $ Database cp meta mempty k Just _ -> Left (ErrWalletAlreadyExists wid) cp `deepseq` meta `deepseq` alterMVar db alter key @@ -82,8 +85,8 @@ newDBLayer = do let alter = \case Nothing -> Left (ErrNoSuchWallet wid) - Just (Database _ meta history) -> - Right $ Just $ Database cp meta history + Just (Database _ meta history k) -> + Right $ Just $ Database cp meta history k cp `deepseq` alterMVar db alter key , readCheckpoint = \key -> @@ -97,8 +100,8 @@ newDBLayer = do let alter = \case Nothing -> Left (ErrNoSuchWallet wid) - Just (Database cp _ history) -> - Right $ Just $ Database cp meta history + Just (Database cp _ history k) -> + Right $ Just $ Database cp meta history k meta `deepseq` alterMVar db alter key , readWalletMeta = \key -> do @@ -112,13 +115,20 @@ newDBLayer = do let alter = \case Nothing -> Left (ErrNoSuchWallet wid) - Just (Database cp meta txs) -> - Right $ Just $ Database cp meta (txs' <> txs) + Just (Database cp meta txs k) -> + Right $ Just $ Database cp meta (txs' <> txs) k txs' `deepseq` alterMVar db alter key , readTxHistory = \key -> maybe mempty txHistory . Map.lookup key <$> readMVar db + {----------------------------------------------------------------------- + Keystore + -----------------------------------------------------------------------} + + , readPrivateKey = \key -> + fmap xprv . Map.lookup key <$> readMVar db + {----------------------------------------------------------------------- Lock -----------------------------------------------------------------------} From 62a26d21812aa92a6acfeb4ec836c27315e847a8 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Thu, 25 Apr 2019 12:24:59 +0200 Subject: [PATCH 2/2] extended corresponding DB tests --- test/unit/Cardano/Wallet/DB/MVarSpec.hs | 136 ++++++++++++++++++------ 1 file changed, 104 insertions(+), 32 deletions(-) diff --git a/test/unit/Cardano/Wallet/DB/MVarSpec.hs b/test/unit/Cardano/Wallet/DB/MVarSpec.hs index 4166b8ee3b5..0826e2bb3d6 100644 --- a/test/unit/Cardano/Wallet/DB/MVarSpec.hs +++ b/test/unit/Cardano/Wallet/DB/MVarSpec.hs @@ -15,6 +15,8 @@ module Cardano.Wallet.DB.MVarSpec import Prelude +import Cardano.Crypto.Wallet + ( unXPrv ) import Cardano.Wallet ( unsafeRunExceptT ) import Cardano.Wallet.DB @@ -25,6 +27,8 @@ import Cardano.Wallet.DB ) import Cardano.Wallet.DB.MVar ( newDBLayer ) +import Cardano.Wallet.Primitive.AddressDerivation + ( Depth (..), Key, Passphrase (..), XPrv, generateKeyFromSeed ) import Cardano.Wallet.Primitive.Model ( Wallet, initWallet ) import Cardano.Wallet.Primitive.Types @@ -68,6 +72,8 @@ import Test.Hspec ( Spec, describe, it, shouldBe, shouldReturn ) import Test.QuickCheck ( Arbitrary (..) + , Gen + , InfiniteList (..) , Property , arbitraryBoundedEnum , checkCoverage @@ -84,6 +90,8 @@ import Test.QuickCheck.Instances import Test.QuickCheck.Monadic ( monadicIO, pick ) +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.Map.Strict as Map @@ -116,12 +124,24 @@ spec = do (property $ prop_putBeforeInit putTxHistory readTxHistoryF (pure mempty)) describe "put doesn't affect other resources" $ do - it "Checkpoint vs Wallet Metadata & Tx History" - (property $ prop_isolation putCheckpoint readWalletMeta readTxHistoryF) - it "Wallet Metadata vs Tx History & Checkpoint" - (property $ prop_isolation putWalletMeta readTxHistoryF readCheckpoint) - it "Tx History vs Checkpoint & Wallet Metadata" - (property $ prop_isolation putTxHistory readCheckpoint readWalletMeta) + it "Checkpoint vs Wallet Metadata & Tx History & Private Key" + (property $ prop_isolation putCheckpoint + readWalletMeta + readTxHistoryF + readPrivateKey + ) + it "Wallet Metadata vs Tx History & Checkpoint & Private Key" + (property $ prop_isolation putWalletMeta + readTxHistoryF + readCheckpoint + readPrivateKey + ) + it "Tx History vs Checkpoint & Wallet Metadata & Private Key" + (property $ prop_isolation putTxHistory + readCheckpoint + readWalletMeta + readPrivateKey + ) describe "can't read after delete" $ do it "Checkpoint" @@ -130,6 +150,8 @@ spec = do (property $ prop_readAfterDelete readWalletMeta Nothing) it "Tx History" (property $ prop_readAfterDelete readTxHistoryF (pure mempty)) + it "Private Key" + (property $ prop_readAfterDelete readPrivateKey Nothing) describe "sequential puts replace values in order" $ do it "Checkpoint" @@ -193,8 +215,8 @@ prop_readAfterPut putOp readOp (key, a) = where setup = do db <- liftIO newDBLayer - (cp, meta) <- pick arbitrary - liftIO $ unsafeRunExceptT $ createWallet db key cp meta + (cp, meta, xprv) <- pick arbitrary + liftIO $ unsafeRunExceptT $ createWallet db key cp meta xprv return db prop db = liftIO $ do unsafeRunExceptT $ putOp db key a @@ -246,8 +268,8 @@ prop_readAfterDelete readOp empty key = where setup = do db <- liftIO newDBLayer - (cp, meta) <- pick arbitrary - liftIO $ unsafeRunExceptT $ createWallet db key cp meta + (cp, meta, xprv) <- pick arbitrary + liftIO $ unsafeRunExceptT $ createWallet db key cp meta xprv return db prop db = liftIO $ do unsafeRunExceptT $ removeWallet db key @@ -255,7 +277,10 @@ prop_readAfterDelete readOp empty key = -- | Modifying one resource leaves the other untouched prop_isolation - :: (Show (f b), Eq (f b), Show (g c), Eq (g c), Applicative f, Applicative g) + :: ( Applicative f, Show (f b), Eq (f b) + , Applicative g, Show (g c), Eq (g c) + , Applicative h, Show (h d), Eq (h d) + ) => ( DBLayer IO DummyState -> PrimaryKey WalletId -> a @@ -269,24 +294,32 @@ prop_isolation -> PrimaryKey WalletId -> IO (g c) ) -- ^ Read Operation for another resource + -> ( DBLayer IO DummyState + -> PrimaryKey WalletId + -> IO (h d) + ) -- ^ Read Operation for another resource -> (PrimaryKey WalletId, a) -- ^ Properties arguments -> Property -prop_isolation putA readB readC (key, a) = +prop_isolation putA readB readC readD (key, a) = monadicIO (setup >>= prop) where setup = do db <- liftIO newDBLayer - (cp, meta, txs) <- pick arbitrary - liftIO $ unsafeRunExceptT $ createWallet db key cp meta + (cp, meta, txs, xprv) <- pick arbitrary + liftIO $ unsafeRunExceptT $ createWallet db key cp meta xprv liftIO $ unsafeRunExceptT $ putTxHistory db key txs - (b, c) <- liftIO $ (,) <$> readB db key <*> readC db key - return (db, (b,c)) + (b, c, d) <- liftIO $ (,,) + <$> readB db key + <*> readC db key + <*> readD db key + return (db, (b, c, d)) - prop (db, (b, c)) = liftIO $ do + prop (db, (b, c, d)) = liftIO $ do unsafeRunExceptT $ putA db key a readB db key `shouldReturn` b readC db key `shouldReturn` c + readD db key `shouldReturn` d -- | Check that the DB supports multiple sequential puts for a given resource prop_sequentialPut @@ -315,9 +348,9 @@ prop_sequentialPut putOp readOp resolve (KeyValPairs pairs) = ids = map fst pairs setup = do db <- liftIO newDBLayer - (cp, meta) <- pick arbitrary + (cp, meta, xprv) <- pick arbitrary liftIO $ unsafeRunExceptT $ once_ pairs $ \(k, _) -> - createWallet db k cp meta + createWallet db k cp meta xprv return db prop db = liftIO $ do unsafeRunExceptT $ forM_ pairs $ uncurry (putOp db) @@ -351,9 +384,9 @@ prop_parallelPut putOp readOp resolve (KeyValPairs pairs) = ids = map fst pairs setup = do db <- liftIO newDBLayer - (cp, meta) <- pick arbitrary + (cp, meta, xprv) <- pick arbitrary liftIO $ unsafeRunExceptT $ once_ pairs $ \(k, _) -> - createWallet db k cp meta + createWallet db k cp meta xprv return db prop db = liftIO $ do forConcurrently_ pairs $ unsafeRunExceptT . uncurry (putOp db) @@ -362,40 +395,50 @@ prop_parallelPut putOp readOp resolve (KeyValPairs pairs) = -- | Can list created wallets prop_createListWallet - :: KeyValPairs (PrimaryKey WalletId) (Wallet DummyState, WalletMetadata) + :: KeyValPairs + (PrimaryKey WalletId) + (Wallet DummyState, WalletMetadata, (Key 'RootK XPrv, Hash "encryption")) -> Property prop_createListWallet (KeyValPairs pairs) = monadicIO (setup >>= prop) where setup = liftIO newDBLayer prop db = liftIO $ do - res <- once pairs $ \(k, (cp, meta)) -> - unsafeRunExceptT $ createWallet db k cp meta + res <- once pairs $ \(k, (cp, meta, xprv)) -> + unsafeRunExceptT $ createWallet db k cp meta xprv (length <$> listWallets db) `shouldReturn` length res -- | Trying to create a same wallet twice should yield an error prop_createWalletTwice - :: (PrimaryKey WalletId, Wallet DummyState, WalletMetadata) + :: ( PrimaryKey WalletId + , Wallet DummyState + , WalletMetadata + , (Key 'RootK XPrv, Hash "encryption") + ) -> Property -prop_createWalletTwice (key@(PrimaryKey wid), cp, meta) = +prop_createWalletTwice (key@(PrimaryKey wid), cp, meta, xprv) = monadicIO (setup >>= prop) where setup = liftIO newDBLayer prop db = liftIO $ do let err = ErrWalletAlreadyExists wid - runExceptT (createWallet db key cp meta) `shouldReturn` Right () - runExceptT (createWallet db key cp meta) `shouldReturn` Left err + runExceptT (createWallet db key cp meta xprv) `shouldReturn` Right () + runExceptT (createWallet db key cp meta xprv) `shouldReturn` Left err --- | Trying to create a same wallet twice should yield an error +-- | Trying to remove a same wallet twice should yield an error prop_removeWalletTwice - :: (PrimaryKey WalletId, Wallet DummyState, WalletMetadata) + :: ( PrimaryKey WalletId + , Wallet DummyState + , WalletMetadata + , (Key 'RootK XPrv, Hash "encryption") + ) -> Property -prop_removeWalletTwice (key@(PrimaryKey wid), cp, meta) = +prop_removeWalletTwice (key@(PrimaryKey wid), cp, meta, xprv) = monadicIO (setup >>= prop) where setup = liftIO $ do db <- newDBLayer - unsafeRunExceptT $ createWallet db key cp meta + unsafeRunExceptT $ createWallet db key cp meta xprv return db prop db = liftIO $ do let err = ErrNoSuchWallet wid @@ -472,3 +515,32 @@ instance Arbitrary WalletMetadata where <*> (WalletPassphraseInfo <$> arbitrary) <*> oneof [pure Ready, Restoring . Quantity <$> arbitraryBoundedEnum] <*> pure NotDelegating + +instance Arbitrary (Key 'RootK XPrv) where + shrink _ = [] + arbitrary = do + (s, g, e) <- (,,) + <$> genPassphrase @"seed" (0, 32) + <*> genPassphrase @"generation" (0, 16) + <*> genPassphrase @"encryption" (0, 16) + return $ generateKeyFromSeed (s, g) e + where + genPassphrase :: (Int, Int) -> Gen (Passphrase purpose) + genPassphrase range = do + n <- choose range + InfiniteList bytes _ <- arbitrary + return $ Passphrase $ BA.convert $ BS.pack $ take n bytes + +instance Arbitrary (Hash "encryption") where + shrink _ = [] + arbitrary = do + InfiniteList bytes _ <- arbitrary + return $ Hash $ BS.pack $ take 32 bytes + +-- Necessary unsound Show instance for QuickCheck failure reporting +instance Show XPrv where + show = show . unXPrv + +-- Necessary unsound Eq instance for QuickCheck properties +instance Eq XPrv where + a == b = unXPrv a == unXPrv b