Migration.hs

{-# LANGUAGE LambdaCase #-}

module Cardano.Wallet.Kernel.Migration
    ( migrateLegacyDataLayer
    , sanityCheckSpendingPassword
    ) where

import           Universum

import           Data.Acid.Advanced (update')
import           Data.Text (pack)
import           Data.Time (defaultTimeLocale, formatTime, getCurrentTime,
                     iso8601DateFormat)
import           Pos.Crypto.Signing (checkPassMatches)
import           System.Directory (doesDirectoryExist, makeAbsolute, renamePath)

import           Formatting ((%))
import qualified Formatting as F

import           Pos.Core.NetworkMagic (makeNetworkMagic)
import           Pos.Crypto (EncryptedSecretKey)
import           Pos.Util.Wlog (Severity (..))

import qualified Cardano.Wallet.Kernel as Kernel
import           Cardano.Wallet.Kernel.DB.AcidState (UpdateHdRootPassword (..))
import qualified Cardano.Wallet.Kernel.DB.HdWallet as HD
import           Cardano.Wallet.Kernel.DB.InDb (InDb (..))
import qualified Cardano.Wallet.Kernel.DB.Read as Kernel
import qualified Cardano.Wallet.Kernel.Internal as Kernel
import           Cardano.Wallet.Kernel.Keystore as Keystore
import qualified Cardano.Wallet.Kernel.Read as Kernel
import           Cardano.Wallet.Kernel.Restore (restoreWallet)
import           Cardano.Wallet.Kernel.Util.Core (getCurrentTimestamp)

{-------------------------------------------------------------------------------
  Pure helper functions for migration.
-------------------------------------------------------------------------------}

--- | Tries to check the existence of the DB at 'FilePath'. It first tries to
-- check for the input 'FilePath' as-it-is. If this fails, it tries to check
-- for absolute path.
-- This is sometimes necessary if the DB path is given with paths like
-- '../wallet-db'. Apparently `doesDirectoryExist` for such a relative path
-- was returning 'False', after making the path absolute.
resolveDbPath :: FilePath -> IO (Maybe FilePath)
resolveDbPath fp = do
    exists <- doesDirectoryExist fp
    case exists of
         True  -> return (Just fp)
         False -> do
             absPath  <- makeAbsolute fp
             absExist <- doesDirectoryExist absPath
             return $ if absExist then Just absPath else Nothing

--- | Move the legacy database into a backup directory.
moveLegacyDB :: FilePath -> IO FilePath
moveLegacyDB filepath = do
    now <- getCurrentTime
    let backupPath =  filepath
                   <> "-backup-"
                   <> formatTime defaultTimeLocale (iso8601DateFormat (Just "%H_%M_%S")) now
    renamePath filepath backupPath
    return backupPath

-- | Migrates all wallets present in the Keystore by restoring each wallet from
-- its encrypted secret key. Since the spending password is not available, we
-- cannot create a default address for new wallets. This has the effect that
-- the user won't be able to rely on transacting with a default address
-- while restoration is in progress.
--
-- When @forced@ is False we are lenient in logging any error and continuing
-- rather than crashing the node. The rationale is that if
-- we leave the node running, we would give the user a chance
-- to submit a bug report from the Daedalus interface.
--
-- However when @forced@ is True the migration is a all-or-nothing.
-- If anything fails the node crashes.
migrateLegacyDataLayer :: Kernel.PassiveWallet
                       -> FilePath
                       -> Bool
                       -> IO ()
migrateLegacyDataLayer pw unresolvedDbPath forced = do
    logMsg Info "Starting wallet(s) migration"

    resolved <- resolveDbPath unresolvedDbPath
    case resolved of
       Nothing -> -- We assume no migration is needed and we move along
            case forced of
                True -> do
                    logMsg Error $ "Migration failed! Legacy DB was not found at " <> pack unresolvedDbPath <> ", but migration is forced"
                    exitFailure
                False -> do
                    logMsg Info $ "No legacy DB at " <> pack unresolvedDbPath <> ", migration is not needed."
       Just legacyDbPath -> do
           wKeys <- Keystore.getKeys (pw ^. Kernel.walletKeystore)
           mapM_ (restore pw forced) wKeys

           -- asynchronous restoration still runs at this point.
           logMsg Info $ "Migration succeeded, restoration of migrated wallets in progress..."

           -- Now we can move the directory
           backupPath <- moveLegacyDB legacyDbPath

           -- asynchronous restoration still runs at this point.
           logMsg Info $ "acid state migration succeeded. Old db backup can be found at " <> pack backupPath
    where
        logMsg = pw ^. Kernel.walletLogMessage

restore :: Kernel.PassiveWallet
        -> Bool
        -> EncryptedSecretKey
        -> IO ()
restore pw forced esk = do
    let logMsg = pw ^. Kernel.walletLogMessage
        nm     = makeNetworkMagic (pw ^. Kernel.walletProtocolMagic)
        rootId = HD.eskToHdRootId nm esk

    let -- DEFAULTS for wallet restoration
        hasSpendingPassword   = isNothing $ checkPassMatches mempty esk
        defaultAddress        = Nothing
        defaultWalletName     = HD.WalletName "<Migrated Wallet>"
        defaultAssuranceLevel = HD.AssuranceLevelStrict

    res <- restoreWallet pw
                         hasSpendingPassword
                         defaultAddress
                         defaultWalletName
                         defaultAssuranceLevel
                         esk

    case res of
         Right (restoredRoot, balance) -> do
             let msg = "Migrating " % F.build
                        % " with balance " % F.build
             logMsg Info (F.sformat msg restoredRoot balance)
         Left err -> do
             let errMsg = "Couldn't migrate " % F.build
                        % " due to : " % F.build % "."
                 msg = F.sformat errMsg rootId err
             case forced of
                False -> logMsg Error msg
                True  -> do
                    logMsg Error ("Migration failed! " <> msg <> " You are advised to delete the newly created db and try again.")
                    exitFailure

-- | Verify that the spending password metadata are correctly set. We mistakenly
-- forgot to port a fix from RCD-47 done on 2.0.x onto 3.0.0 and, for a few
-- users, have migrated / restored their wallet with a wrong spending password
-- metadata (arbitrarily set to `False`), making their wallet completely
-- unusable.
--
-- This checks makes sure that the 'hasSpendingPassword' metadata correctly
-- reflects the wallet condition. To be run on each start-up, unfortunately.
sanityCheckSpendingPassword
    :: Kernel.PassiveWallet
    -> IO ()
sanityCheckSpendingPassword pw = do
    let nm = makeNetworkMagic (pw ^. Kernel.walletProtocolMagic)
    wKeys <- Keystore.getKeys (pw ^. Kernel.walletKeystore)
    db <- Kernel.getWalletSnapshot pw
    lastUpdateNow <- InDb <$> getCurrentTimestamp
    forM_ wKeys $ \esk -> do
        let hasSpendingPassword = case checkPassMatches mempty esk of
                Nothing -> HD.HasSpendingPassword lastUpdateNow
                Just _  -> HD.NoSpendingPassword
        let rootId = HD.eskToHdRootId nm esk
        whenDiscrepancy db rootId hasSpendingPassword restoreTruth >>= \case
            Left (HD.UnknownHdRoot _) ->
                logMsg Error "Failed to update spending password status, HDRoot is gone?"
            Right _ ->
                return ()
  where
    logMsg = pw ^. Kernel.walletLogMessage
    whenDiscrepancy db rootId hasSpendingPassword action = do
        case (hasSpendingPassword, Kernel.lookupHdRootId db rootId) of
            (_, Left e) ->
                return $ Left e
            (HD.HasSpendingPassword _, Right root) | root ^. HD.hdRootHasPassword == HD.NoSpendingPassword ->
                action rootId hasSpendingPassword
            _ -> -- Avoid making a DB update when there's no need
                return $ Right ()
    restoreTruth rootId hasSpendingPassword =
        void <$> update' (pw ^. Kernel.wallets) (UpdateHdRootPassword rootId hasSpendingPassword)