Extend DB Layer & Wallet to support wallet metadata

src/Cardano/Wallet.hs

@@ -19,8 +19,8 @@ module Cardano.Wallet
     -- * Types
       WalletLayer (..)
     , NewWallet(..)
-    , ReadWalletError(..)
-    , CreateWalletError(..)
+    , ErrNoSuchWallet(..)
+    , ErrWalletAlreadyExists(..)
 
     -- * Construction
     , mkWalletLayer
@@ -32,7 +32,11 @@ module Cardano.Wallet
 import Prelude
 
 import Cardano.Wallet.DB
-    ( DBLayer (..), PrimaryKey (..) )
+    ( DBLayer
+    , ErrNoSuchWallet (..)
+    , ErrWalletAlreadyExists (..)
+    , PrimaryKey (..)
+    )
 import Cardano.Wallet.Network
     ( NetworkLayer (..), listen )
 import Cardano.Wallet.Primitive.AddressDerivation
@@ -48,7 +52,14 @@ import Cardano.Wallet.Primitive.AddressDiscovery
 import Cardano.Wallet.Primitive.Model
     ( Wallet, applyBlocks, initWallet )
 import Cardano.Wallet.Primitive.Types
-    ( Block (..), WalletId (..), WalletMetadata (..), WalletName (..) )
+    ( Block (..)
+    , WalletDelegation (..)
+    , WalletId (..)
+    , WalletMetadata (..)
+    , WalletName (..)
+    , WalletPassphraseInfo (..)
+    , WalletState (..)
+    )
 import Control.Exception
     ( Exception )
 import Control.Monad
@@ -58,10 +69,17 @@ import Control.Monad.Fail
 import Control.Monad.IO.Class
     ( liftIO )
 import Control.Monad.Trans.Except
-    ( ExceptT, runExceptT, throwE )
+    ( ExceptT, runExceptT )
+import Control.Monad.Trans.Maybe
+    ( MaybeT (..), maybeToExceptT )
+import Data.Functor
+    ( ($>) )
+import Data.Time.Clock
+    ( getCurrentTime )
 import GHC.Generics
     ( Generic )
 
+import qualified Cardano.Wallet.DB as DB
 
 {-------------------------------------------------------------------------------
                                  Types
@@ -70,10 +88,10 @@ import GHC.Generics
 data WalletLayer s = WalletLayer
     { createWallet
         :: NewWallet
-        -> ExceptT CreateWalletError IO WalletId
+        -> ExceptT (ErrWalletAlreadyExists "createWallet") IO WalletId
     , readWallet
         :: WalletId
-        -> ExceptT ReadWalletError IO (Wallet s, WalletMetadata)
+        -> ExceptT (ErrNoSuchWallet "readWallet") IO (Wallet s, WalletMetadata)
     , watchWallet
         :: WalletId
         -> IO ()
@@ -92,16 +110,6 @@ data NewWallet = NewWallet
         :: !AddressPoolGap
     } deriving (Show, Generic)
 
--- | Errors occuring when fetching a wallet
-newtype ReadWalletError
-    = ErrReadWalletNotFound WalletId
-    deriving (Eq, Show)
-
--- | Errors occuring when creating a wallet
-newtype CreateWalletError
-    = ErrCreateWalletIdAlreadyExists WalletId
-    deriving (Eq, Show)
-
 {-------------------------------------------------------------------------------
                                  Construction
 -------------------------------------------------------------------------------}
@@ -122,36 +130,52 @@ mkWalletLayer db network = WalletLayer
                 mkAddressPool (publicKey accXPrv) (gap w) ExternalChain []
         let intPool =
                 mkAddressPool (publicKey accXPrv) minBound InternalChain []
-        let wallet = initWallet $ SeqState
+        let wid =
+                WalletId (digest $ publicKey rootXPrv)
+        let checkpoint = initWallet $ SeqState
                 { externalPool = extPool
                 , internalPool = intPool
                 }
-        let wid = WalletId (digest $ publicKey rootXPrv)
-        liftIO (readCheckpoint db (PrimaryKey wid)) >>= \case
-            Nothing -> do
-                liftIO $ putCheckpoint db (PrimaryKey wid) wallet
-                return wid
-            Just _ ->
-                throwE $ ErrCreateWalletIdAlreadyExists wid
-    , readWallet = \wid -> liftIO (readCheckpoint db (PrimaryKey wid)) >>= \case
-        Nothing ->
-            throwE $ ErrReadWalletNotFound wid
-        Just w ->
-            return (w, error "FIXME: store and retrieve wallet metadata")
-
-    , watchWallet = liftIO . listen network . onNextblocks
+        now <- liftIO getCurrentTime
+        let metadata = WalletMetadata
+                { name = Cardano.Wallet.name w
+                , passphraseInfo = WalletPassphraseInfo now
+                , status = Restoring minBound
+                , delegation = NotDelegating
+                }
+        DB.createWallet db (PrimaryKey wid) checkpoint metadata $> wid
+
+    , readWallet = \wid -> maybeToExceptT (ErrNoSuchWallet wid) $ do
+        cp <- MaybeT $ DB.readCheckpoint db (PrimaryKey wid)
+        meta <- MaybeT $ DB.readWalletMeta db (PrimaryKey wid)
+        return (cp, meta)
+
+    , watchWallet =
+        liftIO . listen network . onNextblocks
     }
   where
     onNextblocks :: WalletId -> [Block] -> IO ()
     onNextblocks wid blocks = do
-        (txs, cp') <- readCheckpoint db (PrimaryKey wid) >>= \case
+        (txs, cp') <- DB.readCheckpoint db (PrimaryKey wid) >>= \case
             Nothing ->
                 fail $ "couldn't find worker wallet: " <> show wid
             Just cp -> do
                 let nonEmpty = not . null . transactions
                 return $ applyBlocks (filter nonEmpty blocks) cp
-        putCheckpoint db (PrimaryKey wid) cp'
-        unsafeRunExceptT $ putTxHistory db (PrimaryKey wid) txs -- Safe after ^
+        -- FIXME
+        -- Note that, the two calls below are _safe_ under the assumption that
+        -- the wallet existed _right before_. In theory, in a multi-threaded
+        -- context, it may happen that another actor deletes the wallet between
+        -- the calls. Here
+        -- In practice, it isn't really _bad_ if the wallet is gone, we could
+        -- simply log an error or warning and move on. This would have to be
+        -- done as soon as we introduce logging.
+        -- Note also that there's no transaction surrounding both calls because
+        -- there's only one thread per wallet that will apply blocks. And
+        -- therefore, only one thread making changes on checkpoints and/or tx
+        -- history
+        unsafeRunExceptT $ DB.putCheckpoint db (PrimaryKey wid) cp'
+        unsafeRunExceptT $ DB.putTxHistory db (PrimaryKey wid) txs
 
 {-------------------------------------------------------------------------------
                                  Helpers

src/Cardano/Wallet/Api/Server.hs

@@ -16,9 +16,9 @@ module Cardano.Wallet.Api.Server
 import Prelude
 
 import Cardano.Wallet
-    ( CreateWalletError (..)
+    ( ErrNoSuchWallet (..)
+    , ErrWalletAlreadyExists (..)
     , NewWallet (..)
-    , ReadWalletError (..)
     , WalletLayer (..)
     )
 import Cardano.Wallet.Api
@@ -88,7 +88,7 @@ getWallet w (ApiT wid) = do
     (wallet, meta) <- liftHandler $ readWallet w wid
     return ApiWallet
         { id =
-            ApiT $ meta ^. #walletId
+            ApiT wid
         , addressPoolGap =
             ApiT $ getState wallet ^. #externalPool . #gap
         , balance = ApiT $ WalletBalance
@@ -180,10 +180,10 @@ class LiftHandler e where
 -- In practice, we want to create nice error messages giving as much details as
 -- we can.
 
-instance LiftHandler ReadWalletError where
+instance LiftHandler (ErrNoSuchWallet operation) where
     handler = \case
-        ErrReadWalletNotFound _ -> err404
+        ErrNoSuchWallet _ -> err404
 
-instance LiftHandler CreateWalletError where
+instance LiftHandler (ErrWalletAlreadyExists operation) where
     handler = \case
-        ErrCreateWalletIdAlreadyExists _ -> err409
+        ErrWalletAlreadyExists _ -> err409

src/Cardano/Wallet/DB.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
 
 -- |
 -- Copyright: © 2018-2019 IOHK
@@ -10,47 +11,78 @@
 module Cardano.Wallet.DB
     ( DBLayer(..)
     , PrimaryKey(..)
-    , ErrPutTxHistory(..)
+    , ErrNoSuchWallet(..)
+    , ErrWalletAlreadyExists(..)
     ) where
 
 import Prelude
 
 import Cardano.Wallet.Primitive.Model
     ( Wallet )
 import Cardano.Wallet.Primitive.Types
-    ( Hash, Tx, TxMeta, WalletId )
+    ( Hash, Tx, TxMeta, WalletId, WalletMetadata )
 import Control.Monad.Trans.Except
     ( ExceptT )
 import Data.Map.Strict
     ( Map )
+import GHC.TypeLits
+    ( Symbol )
 
 
 -- | A Database interface for storing various things in a DB. In practice,
 -- we'll need some extra contraints on the wallet state that allows us to
 -- serialize and unserialize it (e.g. @forall s. (Serialize s) => ...@)
 data DBLayer m s = DBLayer
-    { putCheckpoint
+    { createWallet
         :: PrimaryKey WalletId
         -> Wallet s
-        -> m ()
+        -> WalletMetadata
+        -> ExceptT (ErrWalletAlreadyExists "createWallet") m ()
+        -- ^ Initialize a database entry for a given wallet. 'putCheckpoint',
+        -- 'putWalletMeta' or 'putTxHistory' will actually all fail if they are
+        -- called _first_ on a wallet.
+        --
+
+    , listWallets
+        :: m [PrimaryKey WalletId]
+        -- ^ Get the list of all known wallets in the DB, possibly empty.
+
+    , putCheckpoint
+        :: PrimaryKey WalletId
+        -> Wallet s
+        -> ExceptT (ErrNoSuchWallet "putCheckpoint") m ()
         -- ^ Replace the current checkpoint for a given wallet. We do not handle
         -- rollbacks yet, and therefore only stores the latest available
         -- checkpoint.
+        --
+        -- If the wallet doesn't exist, this operation returns an error.
 
     , readCheckpoint
         :: PrimaryKey WalletId
         -> m (Maybe (Wallet s))
-        -- ^ Fetch the most recent checkpoint of a given wallet. Return 'Nothing'
-        -- if there's no such wallet.
+        -- ^ Fetch the most recent checkpoint of a given wallet.
+        --
+        -- Return 'Nothing' if there's no such wallet.
 
-    , readWallets
-        :: m [PrimaryKey WalletId]
-        -- ^ Get the list of all known wallets in the DB, possibly empty.
+    , putWalletMeta
+        :: PrimaryKey WalletId
+        -> WalletMetadata
+        -> ExceptT (ErrNoSuchWallet "putWalletMeta") m ()
+        -- ^ Replace an existing wallet metadata with the given one.
+        --
+        -- If the wallet doesn't exist, this operation returns an error
+
+    , readWalletMeta
+        :: PrimaryKey WalletId
+        -> m (Maybe WalletMetadata)
+        -- ^ Fetch a wallet metadata, if they exist.
+        --
+        -- Return 'Nothing' if there's no such wallet.
 
     , putTxHistory
         :: PrimaryKey WalletId
         -> Map (Hash "Tx") (Tx, TxMeta)
-        -> ExceptT ErrPutTxHistory m ()
+        -> ExceptT (ErrNoSuchWallet "putTxHistory") m ()
         -- ^ Augments the transaction history for a known wallet.
         --
         -- If an entry for a particular transaction already exists it is not
@@ -61,14 +93,20 @@ data DBLayer m s = DBLayer
     , readTxHistory
         :: PrimaryKey WalletId
         -> m (Map (Hash "Tx") (Tx, TxMeta))
-        -- ^ Fetch the current transaction history of a known wallet. Returns an
-        -- empty map if the wallet isn't found.
+        -- ^ Fetch the current transaction history of a known wallet.
+        --
+        -- Returns an empty map if the wallet isn't found.
     }
 
--- | Error while trying to insert transaction history in the DB.
-newtype ErrPutTxHistory
-    = ErrNoSuchWallet WalletId
-    deriving (Show, Eq)
+-- | Can't perform given operation because there's no wallet
+newtype ErrNoSuchWallet (operation :: Symbol)
+    = ErrNoSuchWallet WalletId -- Wallet is gone or doesn't exist yet
+    deriving (Eq, Show)
+
+-- | Forbidden operation was executed on an already existing wallet
+newtype ErrWalletAlreadyExists (operation :: Symbol)
+    = ErrWalletAlreadyExists WalletId -- Wallet already exists in db
+    deriving (Eq, Show)
 
 -- | A primary key which can take many forms depending on the value. This may
 -- become a type family as we move forward, but for now, it illustrate that