Discriminate at the file-system level between wallets of different ty…

…pes. We use the prefix "rnd" to denote database files of wallets where the address derivation style is random. We use the prefix "seq" to denote database files of wallets where the address derivation style is sequential.
cardano-foundation · Oct 14, 2019 · 042e52b · 042e52b
1 parent 3f250d9
commit 042e52b
Show file tree

Hide file tree

Showing 6 changed files with 37 additions and 22 deletions.
diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs
@@ -77,7 +77,7 @@ import Cardano.Wallet.DB.Sqlite.TH
 import Cardano.Wallet.DB.Sqlite.Types
     ( AddressPoolXPub (..), BlockId (..), TxId (..) )
 import Cardano.Wallet.Primitive.AddressDerivation
-    ( Depth (..), PersistKey (..) )
+    ( Depth (..), PersistKey (..), WalletKey (..) )
 import Cardano.Wallet.Primitive.AddressDiscovery
     ( IsOurs (..) )
 import Cardano.Wallet.Primitive.Types
@@ -112,6 +112,8 @@ import Data.Map.Strict
     ( Map )
 import Data.Maybe
     ( catMaybes )
+import Data.Proxy
+    ( Proxy (..) )
 import Data.Quantity
     ( Quantity (..) )
 import Data.Text
@@ -220,42 +222,49 @@ mkDBFactory cfg tr mDatabaseDir = case mDatabaseDir of
         }
     Just databaseDir -> DBFactory
         { withDatabase = \wid ->
-            withDBLayer cfg tracerDB (Just $ filepath wid)
+            withDBLayer cfg tracerDB (Just $ databaseFile wid)
         , removeDatabase = \wid -> do
             let files =
-                    [ filepath wid
-                    , filepath wid <> "-wal"
-                    , filepath wid <> "-shm"
+                    [ databaseFile wid
+                    , databaseFile wid <> "-wal"
+                    , databaseFile wid <> "-shm"
                     ]
             mapM_ removePathForcibly files
         }
       where
-        filepath wid = databaseDir </> T.unpack (toText wid) <> ".sqlite"
+        databaseFilePrefix = keyTypeDescriptor $ Proxy @k
+        databaseFile wid =
+            databaseDir </>
+            databaseFilePrefix <> "." <>
+            T.unpack (toText wid) <> ".sqlite"
   where
     tracerDB = appendName "database" tr
 
 -- | Lookup file-system for existing wallet databases
 findDatabases
-    :: Trace IO Text
+    :: forall k. PersistKey k
+    => Trace IO Text
     -> FilePath
     -> IO [W.WalletId]
 findDatabases tr dir = do
     files <- listDirectory dir
     fmap catMaybes $ forM files $ \file -> do
         isFile <- doesFileExist (dir </> file)
-        let (basename:rest) = T.splitOn "." $ T.pack file
-        case (isFile, fromText basename, rest) of
-            (True, Right wid, ["sqlite"]) -> do
-                logInfo tr $ "Found existing wallet: " <> basename
-                return (Just wid)
-            (True, Right _, _) -> do
-                return Nothing
-            _ -> do
-                logNotice tr $ mconcat
-                    [ "Found something else than a database file in the "
-                    , "database folder: ", T.pack file
-                    ]
-                return Nothing
+        case (isFile, T.splitOn "." $ T.pack file) of
+            (True, prefix : basename : ["sqlite"]) | prefix == expectedPrefix ->
+                case fromText basename of
+                    Right wid -> do
+                        logInfo tr $ "Found existing wallet: " <> basename
+                        return (Just wid)
+                    _ -> do
+                        logNotice tr $ mconcat
+                            [ "Found something other than a database file in "
+                            , "the database folder: ", T.pack file
+                            ]
+                        return Nothing
+            _ -> return Nothing
+  where
+    expectedPrefix = T.pack $ keyTypeDescriptor $ Proxy @k
 
 -- | Sets up a connection to the SQLite database.
 --

diff --git a/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs b/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs
@@ -395,6 +395,10 @@ class WalletKey (key :: Depth -> * -> *) where
         => key depth XPub
         -> Digest a
 
+    -- | Get a short, human-readable string descriptor that uniquely identifies
+    --   the specified key type.
+    keyTypeDescriptor :: Proxy key -> String
+
     -- | Unwrap the 'WalletKey' to use the 'XPrv' or 'XPub'.
     getRawKey
         :: key depth raw

diff --git a/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation/Random.hs b/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation/Random.hs
@@ -126,6 +126,7 @@ instance WalletKey RndKey where
     digest = hash . unXPub . getKey
     getRawKey = getKey
     dummyKey = dummyKeyRnd
+    keyTypeDescriptor _ = "rnd"
 
 {-------------------------------------------------------------------------------
                                  Key generation

diff --git a/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation/Sequential.hs b/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation/Sequential.hs
@@ -116,6 +116,7 @@ instance WalletKey SeqKey where
     digest = digestSeq
     getRawKey = getKey
     dummyKey = dummyKeySeq
+    keyTypeDescriptor _ = "seq"
 
 -- | Marker for the change chain. In practice, change of a transaction goes onto
 -- the addresses generated on the internal chain, whereas the external chain is

diff --git a/lib/http-bridge/src/Cardano/Wallet/HttpBridge.hs b/lib/http-bridge/src/Cardano/Wallet/HttpBridge.hs
@@ -158,7 +158,7 @@ serveWallet (cfg, sb, tr) databaseDir listen bridge mAction = do
     newApiLayer nl = do
         let g0 = staticBlockchainParameters nl
         let tl = HttpBridge.newTransactionLayer @n
-        wallets <- maybe (pure []) (Sqlite.findDatabases tr) databaseDir
+        wallets <- maybe (pure []) (Sqlite.findDatabases @k tr) databaseDir
         Server.newApiLayer tr g0 nl tl dbFactory wallets
 
     dbFactory

diff --git a/lib/jormungandr/src/Cardano/Wallet/Jormungandr.hs b/lib/jormungandr/src/Cardano/Wallet/Jormungandr.hs
@@ -170,7 +170,7 @@ serveWallet (cfg, sb, tr) databaseDir listen lj beforeMainLoop = do
     apiLayer tracer nl = do
         let (block0, bp) = staticBlockchainParameters nl
         let tl = newTransactionLayer @n (getGenesisBlockHash bp)
-        wallets <- maybe (pure []) (Sqlite.findDatabases tr) databaseDir
+        wallets <- maybe (pure []) (Sqlite.findDatabases @k tr) databaseDir
         Server.newApiLayer tracer (block0, bp) nl tl dbFactory wallets
 
     dbFactory