{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- Old-style manual migrations of the SQLlite database.
-- These migrations are soon to be removed in favor of
-- a file format with version number.

module Cardano.Wallet.DB.Sqlite.Migration
    ( DefaultFieldValues (..)
    , migrateManually
    , SchemaVersion (..)
    , currentSchemaVersion
    , InvalidDatabaseSchemaVersion (..)
    )
    where

import Prelude

import Cardano.DB.Sqlite
    ( DBField (..)
    , DBLog (..)
    , ManualMigration (..)
    , fieldName
    , fieldType
    , tableName
    )
import Cardano.Wallet.DB.Sqlite.Schema
    ( EntityField (..) )
import Cardano.Wallet.Primitive.AddressDerivation.Icarus
    ( IcarusKey )
import Cardano.Wallet.Primitive.AddressDerivation.Shelley
    ( ShelleyKey (..) )
import Cardano.Wallet.Primitive.Passphrase.Types
    ( PassphraseScheme (..) )
import Control.Monad
    ( forM_, void, when )
import Control.Tracer
    ( Tracer, traceWith )
import Data.Functor
    ( (<&>) )
import Data.Maybe
    ( mapMaybe )
import Data.Proxy
    ( Proxy (..) )
import Data.Text
    ( Text )
import Data.Text.Class
    ( ToText (..), fromText )
import Data.Word
    ( Word16 )
import Database.Persist.Class
    ( toPersistValue )
import Database.Persist.Types
    ( PersistValue (..), fromPersistValueText )
import Numeric.Natural
    ( Natural )
import UnliftIO.Exception
    ( Exception, throwIO, throwString )

import qualified Cardano.Wallet.Primitive.AddressDerivation as W
import qualified Cardano.Wallet.Primitive.AddressDiscovery.Sequential as Seq
import qualified Cardano.Wallet.Primitive.Types as W
import qualified Cardano.Wallet.Primitive.Types.Address as W
import qualified Cardano.Wallet.Primitive.Types.Coin as W
import qualified Data.Text as T
import qualified Database.Sqlite as Sqlite

{-------------------------------------------------------------------------------
    Database Migrations
-------------------------------------------------------------------------------}

-- | A set of default field values that can be consulted when performing a
-- database migration.
data DefaultFieldValues = DefaultFieldValues
    { DefaultFieldValues -> ActiveSlotCoefficient
defaultActiveSlotCoefficient :: W.ActiveSlotCoefficient
    , DefaultFieldValues -> Word16
defaultDesiredNumberOfPool :: Word16
    , DefaultFieldValues -> Coin
defaultMinimumUTxOValue :: W.Coin
    , DefaultFieldValues -> Maybe EpochNo
defaultHardforkEpoch :: Maybe W.EpochNo
    , DefaultFieldValues -> Coin
defaultKeyDeposit :: W.Coin
    }

-- | A data-type for capturing column status. Used to be represented as a
-- 'Maybe Bool' which is somewhat confusing to interpret.
data SqlColumnStatus
    = TableMissing
    | ColumnMissing
    | ColumnPresent
    deriving SqlColumnStatus -> SqlColumnStatus -> Bool
(SqlColumnStatus -> SqlColumnStatus -> Bool)
-> (SqlColumnStatus -> SqlColumnStatus -> Bool)
-> Eq SqlColumnStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SqlColumnStatus -> SqlColumnStatus -> Bool
$c/= :: SqlColumnStatus -> SqlColumnStatus -> Bool
== :: SqlColumnStatus -> SqlColumnStatus -> Bool
$c== :: SqlColumnStatus -> SqlColumnStatus -> Bool
Eq

data TableCreationResult
    = TableCreated
    | TableExisted

newtype SchemaVersion = SchemaVersion Natural
  deriving newtype (SchemaVersion -> SchemaVersion -> Bool
(SchemaVersion -> SchemaVersion -> Bool)
-> (SchemaVersion -> SchemaVersion -> Bool) -> Eq SchemaVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SchemaVersion -> SchemaVersion -> Bool
$c/= :: SchemaVersion -> SchemaVersion -> Bool
== :: SchemaVersion -> SchemaVersion -> Bool
$c== :: SchemaVersion -> SchemaVersion -> Bool
Eq, Eq SchemaVersion
Eq SchemaVersion
-> (SchemaVersion -> SchemaVersion -> Ordering)
-> (SchemaVersion -> SchemaVersion -> Bool)
-> (SchemaVersion -> SchemaVersion -> Bool)
-> (SchemaVersion -> SchemaVersion -> Bool)
-> (SchemaVersion -> SchemaVersion -> Bool)
-> (SchemaVersion -> SchemaVersion -> SchemaVersion)
-> (SchemaVersion -> SchemaVersion -> SchemaVersion)
-> Ord SchemaVersion
SchemaVersion -> SchemaVersion -> Bool
SchemaVersion -> SchemaVersion -> Ordering
SchemaVersion -> SchemaVersion -> SchemaVersion
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SchemaVersion -> SchemaVersion -> SchemaVersion
$cmin :: SchemaVersion -> SchemaVersion -> SchemaVersion
max :: SchemaVersion -> SchemaVersion -> SchemaVersion
$cmax :: SchemaVersion -> SchemaVersion -> SchemaVersion
>= :: SchemaVersion -> SchemaVersion -> Bool
$c>= :: SchemaVersion -> SchemaVersion -> Bool
> :: SchemaVersion -> SchemaVersion -> Bool
$c> :: SchemaVersion -> SchemaVersion -> Bool
<= :: SchemaVersion -> SchemaVersion -> Bool
$c<= :: SchemaVersion -> SchemaVersion -> Bool
< :: SchemaVersion -> SchemaVersion -> Bool
$c< :: SchemaVersion -> SchemaVersion -> Bool
compare :: SchemaVersion -> SchemaVersion -> Ordering
$ccompare :: SchemaVersion -> SchemaVersion -> Ordering
$cp1Ord :: Eq SchemaVersion
Ord, ReadPrec [SchemaVersion]
ReadPrec SchemaVersion
Int -> ReadS SchemaVersion
ReadS [SchemaVersion]
(Int -> ReadS SchemaVersion)
-> ReadS [SchemaVersion]
-> ReadPrec SchemaVersion
-> ReadPrec [SchemaVersion]
-> Read SchemaVersion
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SchemaVersion]
$creadListPrec :: ReadPrec [SchemaVersion]
readPrec :: ReadPrec SchemaVersion
$creadPrec :: ReadPrec SchemaVersion
readList :: ReadS [SchemaVersion]
$creadList :: ReadS [SchemaVersion]
readsPrec :: Int -> ReadS SchemaVersion
$creadsPrec :: Int -> ReadS SchemaVersion
Read, Int -> SchemaVersion -> ShowS
[SchemaVersion] -> ShowS
SchemaVersion -> String
(Int -> SchemaVersion -> ShowS)
-> (SchemaVersion -> String)
-> ([SchemaVersion] -> ShowS)
-> Show SchemaVersion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SchemaVersion] -> ShowS
$cshowList :: [SchemaVersion] -> ShowS
show :: SchemaVersion -> String
$cshow :: SchemaVersion -> String
showsPrec :: Int -> SchemaVersion -> ShowS
$cshowsPrec :: Int -> SchemaVersion -> ShowS
Show )

data InvalidDatabaseSchemaVersion
    = InvalidDatabaseSchemaVersion
    { InvalidDatabaseSchemaVersion -> SchemaVersion
expectedVersion :: SchemaVersion
    , InvalidDatabaseSchemaVersion -> SchemaVersion
actualVersion :: SchemaVersion
    }
    deriving (Int -> InvalidDatabaseSchemaVersion -> ShowS
[InvalidDatabaseSchemaVersion] -> ShowS
InvalidDatabaseSchemaVersion -> String
(Int -> InvalidDatabaseSchemaVersion -> ShowS)
-> (InvalidDatabaseSchemaVersion -> String)
-> ([InvalidDatabaseSchemaVersion] -> ShowS)
-> Show InvalidDatabaseSchemaVersion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InvalidDatabaseSchemaVersion] -> ShowS
$cshowList :: [InvalidDatabaseSchemaVersion] -> ShowS
show :: InvalidDatabaseSchemaVersion -> String
$cshow :: InvalidDatabaseSchemaVersion -> String
showsPrec :: Int -> InvalidDatabaseSchemaVersion -> ShowS
$cshowsPrec :: Int -> InvalidDatabaseSchemaVersion -> ShowS
Show, InvalidDatabaseSchemaVersion
-> InvalidDatabaseSchemaVersion -> Bool
(InvalidDatabaseSchemaVersion
 -> InvalidDatabaseSchemaVersion -> Bool)
-> (InvalidDatabaseSchemaVersion
    -> InvalidDatabaseSchemaVersion -> Bool)
-> Eq InvalidDatabaseSchemaVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InvalidDatabaseSchemaVersion
-> InvalidDatabaseSchemaVersion -> Bool
$c/= :: InvalidDatabaseSchemaVersion
-> InvalidDatabaseSchemaVersion -> Bool
== :: InvalidDatabaseSchemaVersion
-> InvalidDatabaseSchemaVersion -> Bool
$c== :: InvalidDatabaseSchemaVersion
-> InvalidDatabaseSchemaVersion -> Bool
Eq, Show InvalidDatabaseSchemaVersion
Typeable InvalidDatabaseSchemaVersion
Typeable InvalidDatabaseSchemaVersion
-> Show InvalidDatabaseSchemaVersion
-> (InvalidDatabaseSchemaVersion -> SomeException)
-> (SomeException -> Maybe InvalidDatabaseSchemaVersion)
-> (InvalidDatabaseSchemaVersion -> String)
-> Exception InvalidDatabaseSchemaVersion
SomeException -> Maybe InvalidDatabaseSchemaVersion
InvalidDatabaseSchemaVersion -> String
InvalidDatabaseSchemaVersion -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: InvalidDatabaseSchemaVersion -> String
$cdisplayException :: InvalidDatabaseSchemaVersion -> String
fromException :: SomeException -> Maybe InvalidDatabaseSchemaVersion
$cfromException :: SomeException -> Maybe InvalidDatabaseSchemaVersion
toException :: InvalidDatabaseSchemaVersion -> SomeException
$ctoException :: InvalidDatabaseSchemaVersion -> SomeException
$cp2Exception :: Show InvalidDatabaseSchemaVersion
$cp1Exception :: Typeable InvalidDatabaseSchemaVersion
Exception)

currentSchemaVersion :: SchemaVersion
currentSchemaVersion :: SchemaVersion
currentSchemaVersion = Natural -> SchemaVersion
SchemaVersion Natural
1

-- | Executes any manual database migration steps that may be required on
-- startup.
migrateManually
    :: W.WalletKey k
    => Tracer IO DBLog
    -> Proxy k
    -> DefaultFieldValues
    -> [ManualMigration]
migrateManually :: Tracer IO DBLog
-> Proxy k -> DefaultFieldValues -> [ManualMigration]
migrateManually Tracer IO DBLog
tr Proxy k
proxy DefaultFieldValues
defaultFieldValues =
    (Connection -> IO ()) -> ManualMigration
ManualMigration ((Connection -> IO ()) -> ManualMigration)
-> [Connection -> IO ()] -> [ManualMigration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    [ Connection -> IO ()
initializeSchemaVersionTable
    , Connection -> IO ()
cleanupCheckpointTable
    , Connection -> IO ()
assignDefaultPassphraseScheme
    , Connection -> IO ()
addDesiredPoolNumberIfMissing
    , Connection -> IO ()
addMinimumUTxOValueIfMissing
    , Connection -> IO ()
addHardforkEpochIfMissing

      -- FIXME
      -- Temporary migration to fix Daedalus flight wallets. This should
      -- really be removed as soon as we have a fix for the cardano-sl:wallet
      -- currently in production.
    , Connection -> IO ()
removeSoftRndAddresses

    , Connection -> IO ()
removeOldTxParametersTable
    , Connection -> IO ()
addAddressStateIfMissing
    , Connection -> IO ()
addSeqStateDerivationPrefixIfMissing
    , Connection -> IO ()
renameRoleColumn
    , Connection -> IO ()
renameRoleFields
    , Connection -> IO ()
updateFeeValueAndAddKeyDeposit
    , Connection -> IO ()
addFeeToTransaction
    , Connection -> IO ()
moveRndUnusedAddresses
    , Connection -> IO ()
cleanupSeqStateTable
    , Connection -> IO ()
addPolicyXPubIfMissing
    ]
  where
    initializeSchemaVersionTable :: Sqlite.Connection -> IO ()
    initializeSchemaVersionTable :: Connection -> IO ()
initializeSchemaVersionTable Connection
conn =
        Connection -> IO TableCreationResult
createSchemaVersionTableIfMissing Connection
conn IO TableCreationResult -> (TableCreationResult -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            TableCreationResult
TableCreated -> Connection -> SchemaVersion -> IO ()
putSchemaVersion Connection
conn SchemaVersion
currentSchemaVersion
            TableCreationResult
TableExisted -> do
                SchemaVersion
schemaVersion <- Connection -> IO SchemaVersion
getSchemaVersion Connection
conn
                case SchemaVersion -> SchemaVersion -> Ordering
forall a. Ord a => a -> a -> Ordering
compare SchemaVersion
schemaVersion SchemaVersion
currentSchemaVersion of
                    Ordering
GT -> InvalidDatabaseSchemaVersion -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO InvalidDatabaseSchemaVersion :: SchemaVersion -> SchemaVersion -> InvalidDatabaseSchemaVersion
InvalidDatabaseSchemaVersion
                        { expectedVersion :: SchemaVersion
expectedVersion = SchemaVersion
currentSchemaVersion
                        , actualVersion :: SchemaVersion
actualVersion = SchemaVersion
schemaVersion
                        }
                    Ordering
LT -> Connection -> SchemaVersion -> IO ()
putSchemaVersion Connection
conn SchemaVersion
currentSchemaVersion
                    Ordering
EQ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    createSchemaVersionTableIfMissing ::
        Sqlite.Connection -> IO TableCreationResult
    createSchemaVersionTableIfMissing :: Connection -> IO TableCreationResult
createSchemaVersionTableIfMissing Connection
conn = do
        [[PersistValue]]
res <- Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn
            Text
"SELECT name FROM sqlite_master \
            \WHERE type='table' AND name='database_schema_version'"
        case [[PersistValue]]
res of
           [] -> TableCreationResult
TableCreated TableCreationResult
-> IO [[PersistValue]] -> IO TableCreationResult
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn
            Text
"CREATE TABLE database_schema_version\
            \( name TEXT PRIMARY KEY \
            \, version INTEGER NOT NULL \
            \)"
           [[PersistValue]]
_ -> TableCreationResult -> IO TableCreationResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure TableCreationResult
TableExisted

    putSchemaVersion :: Sqlite.Connection -> SchemaVersion -> IO ()
    putSchemaVersion :: Connection -> SchemaVersion -> IO ()
putSchemaVersion Connection
conn SchemaVersion
schemaVersion = IO [[PersistValue]] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [[PersistValue]] -> IO ()) -> IO [[PersistValue]] -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn (Text -> IO [[PersistValue]]) -> Text -> IO [[PersistValue]]
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
        [ Text
"INSERT INTO database_schema_version (name, version)"
        , Text
"VALUES ('schema',"
        , Text
version
        , Text
") ON CONFLICT (name) DO UPDATE SET version ="
        , Text
version
        ]
      where
        version :: Text
version = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SchemaVersion -> String
forall a. Show a => a -> String
show SchemaVersion
schemaVersion

    getSchemaVersion :: Sqlite.Connection -> IO SchemaVersion
    getSchemaVersion :: Connection -> IO SchemaVersion
getSchemaVersion Connection
conn =
        Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn Text
"SELECT version FROM database_schema_version" IO [[PersistValue]]
-> ([[PersistValue]] -> IO SchemaVersion) -> IO SchemaVersion
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            [[PersistInt64 Int64
i]] | Int64
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
0 -> SchemaVersion -> IO SchemaVersion
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SchemaVersion -> IO SchemaVersion)
-> SchemaVersion -> IO SchemaVersion
forall a b. (a -> b) -> a -> b
$ Natural -> SchemaVersion
SchemaVersion (Natural -> SchemaVersion) -> Natural -> SchemaVersion
forall a b. (a -> b) -> a -> b
$ Int64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
            [[PersistValue]]
_ -> String -> IO SchemaVersion
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"Database metadata table is corrupt"

    -- NOTE
    -- We originally stored script pool gap inside sequential state in the 'SeqState' table,
    -- represented by 'seqStateScriptGap' field. We introduce separate shared wallet state
    -- and want to get rid of this. Also we had two supporting tables which we will drop,
    -- 'SeqStateKeyHash' and 'SeqStateScriptHash'.
    cleanupSeqStateTable :: Sqlite.Connection -> IO ()
    cleanupSeqStateTable :: Connection -> IO ()
cleanupSeqStateTable Connection
conn = do
        let orig :: Text
orig = Text
"seq_state"

        -- 1. Drop column from the 'seq_state' table
        Connection -> Text -> Text -> IO SqlColumnStatus
isFieldPresentByName Connection
conn Text
"seq_state" Text
"script_gap" IO SqlColumnStatus -> (SqlColumnStatus -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            SqlColumnStatus
ColumnPresent -> do
                let tmp :: Text
tmp = Text
orig Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_tmp"

                [[PersistValue]]
info <- Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn (Text -> IO [[PersistValue]]) -> Text -> IO [[PersistValue]]
forall a b. (a -> b) -> a -> b
$ Text -> Text
getTableInfo Text
orig
                let excluding :: [Text]
excluding = [Text
"script_gap"]
                let filtered :: [[PersistValue]]
filtered = ([PersistValue] -> Maybe [PersistValue])
-> [[PersistValue]] -> [[PersistValue]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Text] -> [PersistValue] -> Maybe [PersistValue]
filterColumn [Text]
excluding) [[PersistValue]]
info
                Connection -> Text -> Text -> [[PersistValue]] -> IO ()
dropColumnOp Connection
conn Text
orig Text
tmp [[PersistValue]]
filtered

            SqlColumnStatus
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        -- 2. Drop supplementrary tables
        [[PersistValue]]
_ <- Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn (Text -> IO [[PersistValue]]) -> Text -> IO [[PersistValue]]
forall a b. (a -> b) -> a -> b
$ Text -> Text
dropTable Text
"seq_state_key_hash"
        [[PersistValue]]
_ <- Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn (Text -> IO [[PersistValue]]) -> Text -> IO [[PersistValue]]
forall a b. (a -> b) -> a -> b
$ Text -> Text
dropTable Text
"seq_state_script_hash"

        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    dropTable :: Text -> Text
    dropTable :: Text -> Text
dropTable Text
table = Text
"DROP TABLE IF EXISTS " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";"

    getTableInfo :: Text -> Text
    getTableInfo :: Text -> Text
getTableInfo Text
table = Text
"PRAGMA table_info(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
");"

    filterColumn :: [Text] -> [PersistValue] -> Maybe [PersistValue]
    filterColumn :: [Text] -> [PersistValue] -> Maybe [PersistValue]
filterColumn [Text]
excluding = \case
        [ PersistValue
_, PersistText Text
colName, PersistText Text
colType, PersistValue
colNull, PersistValue
_, PersistValue
_] ->
            if Text
colName Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
excluding then
                Maybe [PersistValue]
forall a. Maybe a
Nothing
            else
                [PersistValue] -> Maybe [PersistValue]
forall a. a -> Maybe a
Just [Text -> PersistValue
PersistText Text
colName, Text -> PersistValue
PersistText Text
colType, PersistValue
colNull]
        [PersistValue]
_ ->
            Maybe [PersistValue]
forall a. Maybe a
Nothing

    dropColumnOp
        :: Sqlite.Connection
        -> Text
        -> Text
        -> [[PersistValue]]
        -> IO ()
    dropColumnOp :: Connection -> Text -> Text -> [[PersistValue]] -> IO ()
dropColumnOp Connection
conn Text
orig Text
tmp [[PersistValue]]
filtered = do
        [[PersistValue]]
_ <- Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn (Text -> IO [[PersistValue]]) -> Text -> IO [[PersistValue]]
forall a b. (a -> b) -> a -> b
$ Text -> Text
dropTable Text
tmp
        [[PersistValue]]
_ <- Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn (Text -> IO [[PersistValue]]) -> Text -> IO [[PersistValue]]
forall a b. (a -> b) -> a -> b
$ Text -> [[PersistValue]] -> Text
createTable Text
tmp [[PersistValue]]
filtered
        [[PersistValue]]
_ <- Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn (Text -> IO [[PersistValue]]) -> Text -> IO [[PersistValue]]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [[PersistValue]] -> Text
copyTable Text
orig Text
tmp [[PersistValue]]
filtered
        [[PersistValue]]
_ <- Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn (Text -> IO [[PersistValue]]) -> Text -> IO [[PersistValue]]
forall a b. (a -> b) -> a -> b
$ Text -> Text
dropTable Text
orig
        [[PersistValue]]
_ <- Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn (Text -> IO [[PersistValue]]) -> Text -> IO [[PersistValue]]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
forall a. (Monoid a, IsString a) => a -> a -> a
renameTable Text
tmp Text
orig

        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      where
        createTable :: Text -> [[PersistValue]] -> Text
createTable Text
table [[PersistValue]]
cols = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"CREATE TABLE ", Text
table, Text
" ("
            , Text -> [Text] -> Text
T.intercalate Text
", " (([PersistValue] -> Maybe Text) -> [[PersistValue]] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [PersistValue] -> Maybe Text
createColumn [[PersistValue]]
cols)
            , Text
");"
            ]
        copyTable :: Text -> Text -> [[PersistValue]] -> Text
copyTable Text
source Text
destination [[PersistValue]]
cols = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"INSERT INTO ", Text
destination, Text
" SELECT "
            , Text -> [Text] -> Text
T.intercalate Text
", " (([PersistValue] -> Maybe Text) -> [[PersistValue]] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [PersistValue] -> Maybe Text
selectColumn [[PersistValue]]
cols)
            , Text
" FROM ", Text
source
            , Text
";"
            ]
        renameTable :: a -> a -> a
renameTable a
from a
to = [a] -> a
forall a. Monoid a => [a] -> a
mconcat
            [ a
"ALTER TABLE ", a
from, a
" RENAME TO ", a
to, a
";" ]

        selectColumn :: [PersistValue] -> Maybe Text
        selectColumn :: [PersistValue] -> Maybe Text
selectColumn = \case
            [ PersistText Text
colName, PersistValue
_ , PersistValue
_ ] ->
                Text -> Maybe Text
forall a. a -> Maybe a
Just Text
colName
            [PersistValue]
_ ->
                Maybe Text
forall a. Maybe a
Nothing

        createColumn :: [PersistValue] -> Maybe Text
        createColumn :: [PersistValue] -> Maybe Text
createColumn = \case
            [ PersistText Text
colName, PersistText Text
colType, PersistInt64 Int64
1 ] ->
                Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords [ Text
colName, Text
colType, Text
"NOT NULL" ]
            [ PersistText Text
colName, PersistText Text
colType, PersistValue
_ ] ->
                Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords [ Text
colName, Text
colType ]
            [PersistValue]
_ ->
                Maybe Text
forall a. Maybe a
Nothing

    -- NOTE
    -- We originally stored protocol parameters in the 'Checkpoint' table, and
    -- later moved them to a new dedicatd table. However, removing a column is
    -- not something straightforward in SQLite, so we initially simply marked
    -- most parameters as _unused. Later, we did rework how genesis and protocol
    -- parameters were stored and shared between wallets and completely removed
    -- them from the database. At the same time, we also introduced
    -- 'genesis_hash' and 'genesis_start' in the 'Wallet' table which we use is
    -- as a discriminator for the migration.
    cleanupCheckpointTable :: Sqlite.Connection -> IO ()
    cleanupCheckpointTable :: Connection -> IO ()
cleanupCheckpointTable Connection
conn = do
        let orig :: Text
orig = Text
"checkpoint"

        -- 1. Add genesis_hash and genesis_start to the 'wallet' table.
        let field :: DBField
field = EntityField Wallet BlockId -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField Wallet BlockId
forall typ. (typ ~ BlockId) => EntityField Wallet typ
WalGenesisHash
        Connection -> DBField -> IO SqlColumnStatus
isFieldPresent Connection
conn DBField
field IO SqlColumnStatus -> (SqlColumnStatus -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            SqlColumnStatus
TableMissing ->
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> DBLog
MsgManualMigrationNotNeeded DBField
field

            SqlColumnStatus
ColumnPresent -> do
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> DBLog
MsgManualMigrationNotNeeded DBField
field

            SqlColumnStatus
ColumnMissing -> do
                [[PersistValue]
defaults] <- Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn (Text -> IO [[PersistValue]]) -> Text -> IO [[PersistValue]]
forall a b. (a -> b) -> a -> b
$ [Text] -> Text -> Text
select [Text
"genesis_hash", Text
"genesis_start"] Text
orig
                let [PersistText Text
genesisHash, PersistText Text
genesisStart] = [PersistValue]
defaults
                Connection -> Bool -> DBField -> Text -> IO ()
addColumn_ Connection
conn Bool
True (EntityField Wallet BlockId -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField Wallet BlockId
forall typ. (typ ~ BlockId) => EntityField Wallet typ
WalGenesisHash) (Text -> Text
quotes Text
genesisHash)
                Connection -> Bool -> DBField -> Text -> IO ()
addColumn_ Connection
conn Bool
True (EntityField Wallet UTCTime -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField Wallet UTCTime
forall typ. (typ ~ UTCTime) => EntityField Wallet typ
WalGenesisStart) (Text -> Text
quotes Text
genesisStart)

        -- 2. Drop columns from the 'checkpoint' table
        Connection -> Text -> Text -> IO SqlColumnStatus
isFieldPresentByName Connection
conn Text
"checkpoint" Text
"genesis_hash" IO SqlColumnStatus -> (SqlColumnStatus -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            SqlColumnStatus
ColumnPresent -> do
                let tmp :: Text
tmp = Text
orig Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_tmp"

                [[PersistValue]]
info <- Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn (Text -> IO [[PersistValue]]) -> Text -> IO [[PersistValue]]
forall a b. (a -> b) -> a -> b
$ Text -> Text
getTableInfo Text
orig
                let filtered :: [[PersistValue]]
filtered = ([PersistValue] -> Maybe [PersistValue])
-> [[PersistValue]] -> [[PersistValue]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Text] -> [PersistValue] -> Maybe [PersistValue]
filterColumn [Text]
excluding) [[PersistValue]]
info
                      where
                        excluding :: [Text]
excluding =
                            [ Text
"genesis_hash", Text
"genesis_start", Text
"fee_policy"
                            , Text
"slot_length", Text
"epoch_length", Text
"tx_max_size"
                            , Text
"epoch_stability", Text
"active_slot_coeff"
                            ]
                Connection -> Text -> Text -> [[PersistValue]] -> IO ()
dropColumnOp Connection
conn Text
orig Text
tmp [[PersistValue]]
filtered
            SqlColumnStatus
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      where
        select :: [Text] -> Text -> Text
select [Text]
fields Text
table = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"SELECT ", Text -> [Text] -> Text
T.intercalate Text
", " [Text]
fields
            , Text
" FROM ", Text
table
            , Text
" ORDER BY slot ASC LIMIT 1;"
            ]

    -- NOTE
    -- Wallets created before the 'PassphraseScheme' was introduced have no
    -- passphrase scheme set in the database. Yet, their passphrase is known
    -- to use the default / new scheme (i.e. PBKDF2) and, it is impossible
    -- to have a wallet with a scheme but no last update. Either they should
    -- have both, or they should have none.
    --
    --     Creation Method               | Scheme | Last Update
    --     ---                           | ---    | ---
    --     Byron, from mnemonic          | ✓      | ✓
    --     Byron, from xprv              | ✓      | ✓
    --     Shelley, from mnemonic        | ✓      | ✓
    --     Shelley, from account pub key | ø      | ø
    assignDefaultPassphraseScheme :: Sqlite.Connection -> IO ()
    assignDefaultPassphraseScheme :: Connection -> IO ()
assignDefaultPassphraseScheme Connection
conn = do
        Connection -> DBField -> IO SqlColumnStatus
isFieldPresent Connection
conn DBField
passphraseScheme IO SqlColumnStatus -> (SqlColumnStatus -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            SqlColumnStatus
TableMissing -> do
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> DBLog
MsgManualMigrationNotNeeded DBField
passphraseScheme
            SqlColumnStatus
ColumnMissing -> do
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> DBLog
MsgManualMigrationNotNeeded DBField
passphraseScheme
                Statement
query <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
conn (Text -> IO Statement) -> Text -> IO Statement
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
                    [ Text
"ALTER TABLE", DBField -> Text
tableName DBField
passphraseScheme
                    , Text
"ADD COLUMN", DBField -> Text
fieldName DBField
passphraseScheme
                    , DBField -> Text
fieldType DBField
passphraseScheme, Text
" NULL"
                    , Text
";"
                    ]
                Statement -> IO StepResult
Sqlite.step Statement
query IO StepResult -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Statement -> IO ()
Sqlite.finalize Statement
query
                Connection -> IO ()
assignDefaultPassphraseScheme Connection
conn -- loop to apply case below
            SqlColumnStatus
ColumnPresent  -> do
                Text
value <- (Text -> IO Text)
-> (Text -> IO Text) -> Either Text Text -> IO Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO Text) -> (Text -> String) -> Text -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. Show a => a -> String
show) (\Text
x -> Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"") (Either Text Text -> IO Text) -> Either Text Text -> IO Text
forall a b. (a -> b) -> a -> b
$
                    PersistValue -> Either Text Text
fromPersistValueText (PassphraseScheme -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue PassphraseScheme
EncryptWithPBKDF2)
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> (DBLog -> DBLog) -> DBLog -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBLog -> DBLog
MsgExpectedMigration
                    (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> Text -> DBLog
MsgManualMigrationNeeded DBField
passphraseScheme Text
value
                Statement
query <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
conn (Text -> IO Statement) -> Text -> IO Statement
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
                    [ Text
"UPDATE", DBField -> Text
tableName DBField
passphraseScheme
                    , Text
"SET", DBField -> Text
fieldName DBField
passphraseScheme, Text
"=", Text
value
                    , Text
"WHERE", DBField -> Text
fieldName DBField
passphraseScheme, Text
"IS NULL"
                    , Text
"AND", DBField -> Text
fieldName DBField
passphraseLastUpdatedAt, Text
"IS NOT NULL"
                    , Text
";"
                    ]
                Statement -> IO StepResult
Sqlite.step Statement
query IO StepResult -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Statement -> IO ()
Sqlite.finalize Statement
query
      where
        passphraseScheme :: DBField
passphraseScheme = EntityField Wallet (Maybe PassphraseScheme) -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField Wallet (Maybe PassphraseScheme)
forall typ.
(typ ~ Maybe PassphraseScheme) =>
EntityField Wallet typ
WalPassphraseScheme
        passphraseLastUpdatedAt :: DBField
passphraseLastUpdatedAt = EntityField Wallet (Maybe UTCTime) -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField Wallet (Maybe UTCTime)
forall typ. (typ ~ Maybe UTCTime) => EntityField Wallet typ
WalPassphraseLastUpdatedAt

    -- | Remove any addresses that were wrongly generated in previous releases.
    -- See comment below in 'selectState' from 'RndState'.
    --
    -- Important: this _may_ remove USED addresses from the discovered set which
    -- is _okay-ish_ for two reasons:
    --
    --     1. Address will still be discovered in UTxOs and this won't affect
    --     users' balance. But the address won't show up when in the listing.
    --     This is a wanted behavior.
    --
    --     2. The discovered list of address is really used internally to avoid
    --     index clash when generating new change addresses. Since we'll
    --     generate addresses from a completely different part of the HD tree
    --     ANYWAY, there's no risk of clash.
    removeSoftRndAddresses :: Sqlite.Connection -> IO ()
    removeSoftRndAddresses :: Connection -> IO ()
removeSoftRndAddresses Connection
conn = do
        Connection -> DBField -> IO SqlColumnStatus
isFieldPresent Connection
conn DBField
rndAccountIx IO SqlColumnStatus -> (SqlColumnStatus -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            SqlColumnStatus
TableMissing -> do
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> DBLog
MsgManualMigrationNotNeeded DBField
rndAccountIx
            SqlColumnStatus
ColumnMissing -> do
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> DBLog
MsgManualMigrationNotNeeded DBField
rndAccountIx
            SqlColumnStatus
ColumnPresent -> do
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> (DBLog -> DBLog) -> DBLog -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBLog -> DBLog
MsgExpectedMigration
                    (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> Text -> DBLog
MsgManualMigrationNeeded DBField
rndAccountIx Text
hardLowerBound
                Statement
stmt <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
conn (Text -> IO Statement) -> Text -> IO Statement
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
                    [ Text
"DELETE FROM", DBField -> Text
tableName DBField
rndAccountIx
                    , Text
"WHERE", DBField -> Text
fieldName DBField
rndAccountIx, Text
"<", Text
hardLowerBound
                    , Text
";"
                    ]
                StepResult
_ <- Statement -> IO StepResult
Sqlite.step Statement
stmt
                Statement -> IO ()
Sqlite.finalize Statement
stmt
      where
        hardLowerBound :: Text
hardLowerBound = Int -> Text
forall a. ToText a => a -> Text
toText (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Index 'Hardened Any -> Int
forall a. Enum a => a -> Int
fromEnum (Index 'Hardened Any -> Int) -> Index 'Hardened Any -> Int
forall a b. (a -> b) -> a -> b
$ Bounded (Index 'Hardened Any) => Index 'Hardened Any
forall a. Bounded a => a
minBound @(W.Index 'W.Hardened _)
        rndAccountIx :: DBField
rndAccountIx   = EntityField RndStateAddress Word32 -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField RndStateAddress Word32
forall typ. (typ ~ Word32) => EntityField RndStateAddress typ
RndStateAddressAccountIndex

    -- | When we implemented the 'importAddress' and 'createAddress' features,
    -- we mistakenly added all imported addresses in the discovered section and
    -- table of the RndState. This makes them affected by rollbacks, which is
    -- very much an issue. While fixing this, we can also take the opportunity
    -- to move all existing 'unused' addresses from the 'RndStateAddress' to the
    -- 'RndStatePendingAddress' table.
    --
    -- Arguably, the 'status' column is redundant on the 'RndStateAddress' table
    -- because any address in that table must be 'Used', by construction.
    moveRndUnusedAddresses :: Sqlite.Connection -> IO ()
    moveRndUnusedAddresses :: Connection -> IO ()
moveRndUnusedAddresses Connection
conn = do
        Connection -> DBField -> IO SqlColumnStatus
isFieldPresent Connection
conn DBField
rndStateAddressStatus IO SqlColumnStatus -> (SqlColumnStatus -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            SqlColumnStatus
TableMissing -> do
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> DBLog
MsgManualMigrationNotNeeded DBField
rndStateAddressStatus
            SqlColumnStatus
ColumnMissing -> do
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> DBLog
MsgManualMigrationNotNeeded DBField
rndStateAddressStatus
            SqlColumnStatus
ColumnPresent -> do
                let unused :: Text
unused = Text -> Text
quotes (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ AddressState -> Text
forall a. ToText a => a -> Text
toText AddressState
W.Unused

                [[PersistInt64 Int64
n]] <- Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn (Text -> IO [[PersistValue]]) -> Text -> IO [[PersistValue]]
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
                    [ Text
"SELECT COUNT(*)"
                    , Text
"FROM", DBField -> Text
tableName DBField
rndStateAddressStatus
                    , Text
"WHERE", DBField -> Text
fieldName DBField
rndStateAddressStatus, Text
"=", Text
unused
                    , Text
";"
                    ]

                if Int64
n Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0 then do
                    Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> Text -> DBLog
MsgManualMigrationNeeded DBField
rndStateAddressStatus Text
"-"

                    IO [[PersistValue]] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [[PersistValue]] -> IO ()) -> IO [[PersistValue]] -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn (Text -> IO [[PersistValue]]) -> Text -> IO [[PersistValue]]
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
                        [ Text
"INSERT INTO", Text
rndStatePendingTable
                        , Text
"(wallet_id, account_ix, address_ix, address)"
                        , Text
"SELECT wallet_id, account_ix, address_ix, address"
                        , Text
"FROM", Text
rndStateDiscoveredTable
                        , Text
"WHERE", DBField -> Text
fieldName DBField
rndStateAddressStatus, Text
"=", Text
unused
                        , Text
";"
                        ]

                    IO [[PersistValue]] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [[PersistValue]] -> IO ()) -> IO [[PersistValue]] -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn (Text -> IO [[PersistValue]]) -> Text -> IO [[PersistValue]]
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
                        [ Text
"DELETE FROM", Text
rndStateDiscoveredTable
                        , Text
"WHERE", DBField -> Text
fieldName DBField
rndStateAddressStatus, Text
"=", Text
unused
                        , Text
";"
                        ]
                else do
                    Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> DBLog
MsgManualMigrationNotNeeded DBField
rndStateAddressStatus
      where
        rndStateAddressStatus :: DBField
rndStateAddressStatus = EntityField RndStateAddress AddressState -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField RndStateAddress AddressState
forall typ. (typ ~ AddressState) => EntityField RndStateAddress typ
RndStateAddressStatus
        rndStateDiscoveredTable :: Text
rndStateDiscoveredTable = DBField -> Text
tableName (DBField -> Text) -> DBField -> Text
forall a b. (a -> b) -> a -> b
$ EntityField RndStateAddress WalletId -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField RndStateAddress WalletId
forall typ. (typ ~ WalletId) => EntityField RndStateAddress typ
RndStateAddressWalletId
        rndStatePendingTable :: Text
rndStatePendingTable  = DBField -> Text
tableName (DBField -> Text) -> DBField -> Text
forall a b. (a -> b) -> a -> b
$ EntityField RndStatePendingAddress WalletId -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField RndStatePendingAddress WalletId
forall typ.
(typ ~ WalletId) =>
EntityField RndStatePendingAddress typ
RndStatePendingAddressWalletId

    -- | Adds an 'desired_pool_number' column to the 'protocol_parameters'
    -- table if it is missing.
    --
    addDesiredPoolNumberIfMissing :: Sqlite.Connection -> IO ()
    addDesiredPoolNumberIfMissing :: Connection -> IO ()
addDesiredPoolNumberIfMissing Connection
conn = do
        Connection -> Bool -> DBField -> Text -> IO ()
addColumn_ Connection
conn Bool
True (EntityField ProtocolParameters Word16 -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField ProtocolParameters Word16
forall typ. (typ ~ Word16) => EntityField ProtocolParameters typ
ProtocolParametersDesiredNumberOfPools) Text
value
      where
        value :: Text
value = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word16 -> String
forall a. Show a => a -> String
show (Word16 -> String) -> Word16 -> String
forall a b. (a -> b) -> a -> b
$ DefaultFieldValues -> Word16
defaultDesiredNumberOfPool DefaultFieldValues
defaultFieldValues

    -- | Adds an 'minimum_utxo_value' column to the 'protocol_parameters'
    -- table if it is missing.
    --
    addMinimumUTxOValueIfMissing :: Sqlite.Connection -> IO ()
    addMinimumUTxOValueIfMissing :: Connection -> IO ()
addMinimumUTxOValueIfMissing Connection
conn = do
        Connection -> Bool -> DBField -> Text -> IO ()
addColumn_ Connection
conn Bool
True (EntityField ProtocolParameters Coin -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField ProtocolParameters Coin
forall typ. (typ ~ Coin) => EntityField ProtocolParameters typ
ProtocolParametersMinimumUtxoValue) Text
value
      where
        value :: Text
value = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Natural -> String
forall a. Show a => a -> String
show (Natural -> String) -> Natural -> String
forall a b. (a -> b) -> a -> b
$ Coin -> Natural
W.unCoin (Coin -> Natural) -> Coin -> Natural
forall a b. (a -> b) -> a -> b
$ DefaultFieldValues -> Coin
defaultMinimumUTxOValue DefaultFieldValues
defaultFieldValues

    -- | Adds an 'hardfork_epoch' column to the 'protocol_parameters'
    -- table if it is missing.
    --
    addHardforkEpochIfMissing :: Sqlite.Connection -> IO ()
    addHardforkEpochIfMissing :: Connection -> IO ()
addHardforkEpochIfMissing Connection
conn = do
        Connection -> Bool -> DBField -> Text -> IO ()
addColumn_ Connection
conn Bool
False (EntityField ProtocolParameters (Maybe EpochNo) -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField ProtocolParameters (Maybe EpochNo)
forall typ.
(typ ~ Maybe EpochNo) =>
EntityField ProtocolParameters typ
ProtocolParametersHardforkEpoch) Text
value
      where
        value :: Text
value = case DefaultFieldValues -> Maybe EpochNo
defaultHardforkEpoch DefaultFieldValues
defaultFieldValues of
            Maybe EpochNo
Nothing -> Text
"NULL"
            Just EpochNo
v -> String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word31 -> String
forall a. Show a => a -> String
show (Word31 -> String) -> Word31 -> String
forall a b. (a -> b) -> a -> b
$ EpochNo -> Word31
W.unEpochNo EpochNo
v

    -- | Adds a 'key_deposit column to the 'protocol_parameters' table if it is
    -- missing.
    --
    addKeyDepositIfMissing :: Sqlite.Connection -> Text -> IO ()
    addKeyDepositIfMissing :: Connection -> Text -> IO ()
addKeyDepositIfMissing Connection
conn =
        Connection -> Bool -> DBField -> Text -> IO ()
addColumn_ Connection
conn Bool
True (EntityField ProtocolParameters Coin -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField ProtocolParameters Coin
forall typ. (typ ~ Coin) => EntityField ProtocolParameters typ
ProtocolParametersKeyDeposit)

    -- | This table became @protocol_parameters@.
    removeOldTxParametersTable :: Sqlite.Connection -> IO ()
    removeOldTxParametersTable :: Connection -> IO ()
removeOldTxParametersTable Connection
conn = do
        Statement
dropTable' <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
conn Text
"DROP TABLE IF EXISTS tx_parameters;"
        IO StepResult -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO StepResult -> IO ()) -> IO StepResult -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Statement -> IO StepResult
Sqlite.stepConn Connection
conn Statement
dropTable'
        Statement -> IO ()
Sqlite.finalize Statement
dropTable'

    -- | In order to make listing addresses bearable for large wallet, we
    -- altered the discovery process to mark addresses as used as they are
    -- discovered. Existing databases don't have that pre-computed field.
    addAddressStateIfMissing :: Sqlite.Connection -> IO ()
    addAddressStateIfMissing :: Connection -> IO ()
addAddressStateIfMissing Connection
conn = do
        SqlColumnStatus
_  <- Connection -> Bool -> DBField -> Text -> IO SqlColumnStatus
addColumn Connection
conn Bool
False (EntityField SeqStateAddress AddressState -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField SeqStateAddress AddressState
forall typ. (typ ~ AddressState) => EntityField SeqStateAddress typ
SeqStateAddressStatus) (AddressState -> Text
forall a. ToText a => a -> Text
toText AddressState
W.Unused)
        SqlColumnStatus
st <- Connection -> Bool -> DBField -> Text -> IO SqlColumnStatus
addColumn Connection
conn Bool
False (EntityField RndStateAddress AddressState -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField RndStateAddress AddressState
forall typ. (typ ~ AddressState) => EntityField RndStateAddress typ
RndStateAddressStatus) (AddressState -> Text
forall a. ToText a => a -> Text
toText AddressState
W.Unused)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SqlColumnStatus
st SqlColumnStatus -> SqlColumnStatus -> Bool
forall a. Eq a => a -> a -> Bool
== SqlColumnStatus
ColumnMissing) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            DBField -> IO ()
markAddressesAsUsed (EntityField SeqStateAddress AddressState -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField SeqStateAddress AddressState
forall typ. (typ ~ AddressState) => EntityField SeqStateAddress typ
SeqStateAddressStatus)
            DBField -> IO ()
markAddressesAsUsed (EntityField RndStateAddress AddressState -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField RndStateAddress AddressState
forall typ. (typ ~ AddressState) => EntityField RndStateAddress typ
RndStateAddressStatus)
      where
        markAddressesAsUsed :: DBField -> IO ()
markAddressesAsUsed DBField
field = do
            Statement
query <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
conn (Text -> IO Statement) -> Text -> IO Statement
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
                [ Text
"UPDATE", DBField -> Text
tableName DBField
field
                , Text
"SET status = '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AddressState -> Text
forall a. ToText a => a -> Text
toText AddressState
W.Used Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
                , Text
"WHERE", DBField -> Text
tableName DBField
field Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".address", Text
"IN"
                , Text
"(SELECT DISTINCT(address) FROM tx_out)"
                ]
            StepResult
_ <- Statement -> IO StepResult
Sqlite.step Statement
query
            Statement -> IO ()
Sqlite.finalize Statement
query

    addSeqStateDerivationPrefixIfMissing :: Sqlite.Connection -> IO ()
    addSeqStateDerivationPrefixIfMissing :: Connection -> IO ()
addSeqStateDerivationPrefixIfMissing Connection
conn
        | Bool
isIcarusDatabase = do
            Connection -> Bool -> DBField -> Text -> IO ()
addColumn_ Connection
conn Bool
True (EntityField SeqState DerivationPrefix -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField SeqState DerivationPrefix
forall typ. (typ ~ DerivationPrefix) => EntityField SeqState typ
SeqStateDerivationPrefix) Text
icarusPrefix

        | Bool
isShelleyDatabase = do
            Connection -> Bool -> DBField -> Text -> IO ()
addColumn_ Connection
conn Bool
True (EntityField SeqState DerivationPrefix -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField SeqState DerivationPrefix
forall typ. (typ ~ DerivationPrefix) => EntityField SeqState typ
SeqStateDerivationPrefix) Text
shelleyPrefix

        | Bool
otherwise =
            () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      where
        isIcarusDatabase :: Bool
isIcarusDatabase =
            Proxy k -> String
forall (key :: Depth -> * -> *).
WalletKey key =>
Proxy key -> String
W.keyTypeDescriptor Proxy k
proxy String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy IcarusKey -> String
forall (key :: Depth -> * -> *).
WalletKey key =>
Proxy key -> String
W.keyTypeDescriptor (Proxy IcarusKey
forall k (t :: k). Proxy t
Proxy @IcarusKey)
        icarusPrefix :: Text
icarusPrefix = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. Show a => a -> String
show (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ DerivationPrefix -> Text
forall a. ToText a => a -> Text
toText
            (DerivationPrefix -> Text) -> DerivationPrefix -> Text
forall a b. (a -> b) -> a -> b
$ (Index 'Hardened 'PurposeK, Index 'Hardened 'CoinTypeK,
 Index 'Hardened 'AccountK)
-> DerivationPrefix
Seq.DerivationPrefix (Index 'Hardened 'PurposeK
Seq.purposeBIP44, Index 'Hardened 'CoinTypeK
Seq.coinTypeAda, Index 'Hardened 'AccountK
forall a. Bounded a => a
minBound)

        isShelleyDatabase :: Bool
isShelleyDatabase =
            Proxy k -> String
forall (key :: Depth -> * -> *).
WalletKey key =>
Proxy key -> String
W.keyTypeDescriptor Proxy k
proxy String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy ShelleyKey -> String
forall (key :: Depth -> * -> *).
WalletKey key =>
Proxy key -> String
W.keyTypeDescriptor (Proxy ShelleyKey
forall k (t :: k). Proxy t
Proxy @ShelleyKey)
        shelleyPrefix :: Text
shelleyPrefix = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. Show a => a -> String
show (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ DerivationPrefix -> Text
forall a. ToText a => a -> Text
toText
            (DerivationPrefix -> Text) -> DerivationPrefix -> Text
forall a b. (a -> b) -> a -> b
$ (Index 'Hardened 'PurposeK, Index 'Hardened 'CoinTypeK,
 Index 'Hardened 'AccountK)
-> DerivationPrefix
Seq.DerivationPrefix (Index 'Hardened 'PurposeK
Seq.purposeCIP1852, Index 'Hardened 'CoinTypeK
Seq.coinTypeAda, Index 'Hardened 'AccountK
forall a. Bounded a => a
minBound)

    --
    --   - UTxOInternal
    --   - UTxOExternal
    --
    -- (notice the mixed case here) and were serialized to text as:
    --
    --   - u_tx_o_internal
    --   - u_tx_o_external
    --
    -- which is pretty lame. This was changed later on, but already
    -- serialized data may subsist on for quite a while. Hence this little
    -- pirouette here.
    renameRoleFields :: Sqlite.Connection -> IO ()
    renameRoleFields :: Connection -> IO ()
renameRoleFields Connection
conn = do
        Connection -> DBField -> Text -> Text -> IO ()
renameColumnField Connection
conn (EntityField SeqStateAddress Role -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField SeqStateAddress Role
forall typ. (typ ~ Role) => EntityField SeqStateAddress typ
SeqStateAddressRole)
            Text
"u_tx_o_internal" Text
"utxo_internal"
        Connection -> DBField -> Text -> Text -> IO ()
renameColumnField Connection
conn (EntityField SeqStateAddress Role -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField SeqStateAddress Role
forall typ. (typ ~ Role) => EntityField SeqStateAddress typ
SeqStateAddressRole)
            Text
"u_tx_o_external" Text
"utxo_external"

    -- | Rename column table of SeqStateAddress from 'accounting_style' to `role`
    -- if needed.
    renameRoleColumn :: Sqlite.Connection -> IO ()
    renameRoleColumn :: Connection -> IO ()
renameRoleColumn Connection
conn =
        Connection -> DBField -> IO SqlColumnStatus
isFieldPresent Connection
conn DBField
roleField IO SqlColumnStatus -> (SqlColumnStatus -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            SqlColumnStatus
TableMissing ->
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> DBLog
MsgManualMigrationNotNeeded DBField
roleField
            SqlColumnStatus
ColumnMissing -> do
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> Text -> DBLog
MsgManualMigrationNeeded DBField
roleField Text
"accounting_style"
                Statement
query <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
conn (Text -> IO Statement) -> Text -> IO Statement
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
                    [ Text
"ALTER TABLE", DBField -> Text
tableName DBField
roleField
                    , Text
"RENAME COLUMN accounting_style TO"
                    , DBField -> Text
fieldName DBField
roleField
                    , Text
";"
                    ]
                Statement -> IO StepResult
Sqlite.step Statement
query IO StepResult -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Statement -> IO ()
Sqlite.finalize Statement
query
            SqlColumnStatus
ColumnPresent ->
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> DBLog
MsgManualMigrationNotNeeded DBField
roleField
      where
        roleField :: DBField
roleField = EntityField SeqStateAddress Role -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField SeqStateAddress Role
forall typ. (typ ~ Role) => EntityField SeqStateAddress typ
SeqStateAddressRole

    -- This migration is rather delicate. Indeed, we need to introduce an
    -- explicit 'fee' on known transactions, so only do we need to add the new
    -- column (easy), but we also need to find the right value for that new
    -- column (delicate).
    --
    -- Note that it is not possible to recover explicit fees on incoming
    -- transactions without having access to the entire ledger (we do not know
    -- the _amount_ from inputs of incoming transactions). Therefore, by
    -- convention it has been decided that incoming transactions will have fee
    -- equals to 0.
    --
    -- For outgoing transaction, it is possible to recalculate fees by
    -- calculating the delta between the total input value minus the total
    -- output value. The delta (inputs - output) is necessarily positive
    -- (by definition of 'outgoing' transactions) and comprised of:
    --
    -- - Fees
    -- - Total deposits if any
    --
    -- To subtract deposit values from fees, we consider that any transaction
    -- that has one or less output and fees greater than the key deposit (or min
    -- utxo value) is a key registration transaction and the key deposit value
    -- can be subtracted from the delta to deduce the fees.
    --
    -- Note that ideally, we would do this in a single `UPDATE ... FROM` query
    -- but the `FROM` syntax is only supported in SQLite >= 3.33 which is only
    -- supported in the latest version of persistent-sqlite (2.11.0.0). So
    -- instead, we query all transactions which require an update in memory,
    -- and update them one by one. This may be quite long on some database but
    -- it is in the end a one-time cost paid on start-up.
    addFeeToTransaction :: Sqlite.Connection -> IO ()
    addFeeToTransaction :: Connection -> IO ()
addFeeToTransaction Connection
conn = do
        Connection -> DBField -> IO SqlColumnStatus
isFieldPresent Connection
conn DBField
fieldFee IO SqlColumnStatus -> (SqlColumnStatus -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            SqlColumnStatus
TableMissing  ->
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> DBLog
MsgManualMigrationNotNeeded DBField
fieldFee
            SqlColumnStatus
ColumnPresent ->
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> DBLog
MsgManualMigrationNotNeeded DBField
fieldFee
            SqlColumnStatus
ColumnMissing -> do
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> Text -> DBLog
MsgManualMigrationNeeded DBField
fieldFee Text
"NULL"

                [(Text, Int64, Int64)]
rows <- ([[PersistValue]] -> [(Text, Int64, Int64)])
-> IO [[PersistValue]] -> IO [(Text, Int64, Int64)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[PersistValue]] -> [(Text, Int64, Int64)]
unwrapRows (IO Text
mkQuery IO Text -> (Text -> IO [[PersistValue]]) -> IO [[PersistValue]]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn)

                [[PersistValue]]
_ <- Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn (Text -> IO [[PersistValue]]) -> Text -> IO [[PersistValue]]
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
                    [ Text
"ALTER TABLE", DBField -> Text
tableName DBField
fieldFee
                    , Text
"ADD COLUMN", DBField -> Text
fieldName DBField
fieldFee
                    , DBField -> Text
fieldType DBField
fieldFee
                    , Text
";"
                    ]

                [(Text, Int64, Int64)]
-> ((Text, Int64, Int64) -> IO [[PersistValue]]) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, Int64, Int64)]
rows (((Text, Int64, Int64) -> IO [[PersistValue]]) -> IO ())
-> ((Text, Int64, Int64) -> IO [[PersistValue]]) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Text
txid, Int64
nOuts, Int64
delta) -> do
                    let fee :: Text
fee = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int64 -> String
forall a. Show a => a -> String
show (Int64 -> String) -> Int64 -> String
forall a b. (a -> b) -> a -> b
$
                            if Int64 -> Int64 -> Bool
forall a. (Num a, Ord a) => a -> Int64 -> Bool
isKeyRegistration Int64
nOuts Int64
delta
                            then Int64
delta Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
keyDepositValue
                            else Int64
delta

                    Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn (Text -> IO [[PersistValue]]) -> Text -> IO [[PersistValue]]
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
                        [ Text
"UPDATE", DBField -> Text
tableName DBField
fieldFee
                        , Text
"SET", DBField -> Text
fieldName DBField
fieldFee, Text
"=", Text -> Text
quotes Text
fee
                        , Text
"WHERE", DBField -> Text
fieldName DBField
fieldTxId, Text
"=", Text -> Text
quotes Text
txid
                        , Text
";"
                        ]
      where
        fieldFee :: DBField
fieldFee  = EntityField TxMeta (Maybe Word64) -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField TxMeta (Maybe Word64)
forall typ. (typ ~ Maybe Word64) => EntityField TxMeta typ
TxMetaFee
        fieldTxId :: DBField
fieldTxId = EntityField TxMeta TxId -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField TxMeta TxId
forall typ. (typ ~ TxId) => EntityField TxMeta typ
TxMetaTxId

        unwrapRows :: [[PersistValue]] -> [(Text, Int64, Int64)]
unwrapRows = ([PersistValue] -> (Text, Int64, Int64))
-> [[PersistValue]] -> [(Text, Int64, Int64)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([PersistValue] -> (Text, Int64, Int64))
 -> [[PersistValue]] -> [(Text, Int64, Int64)])
-> ([PersistValue] -> (Text, Int64, Int64))
-> [[PersistValue]]
-> [(Text, Int64, Int64)]
forall a b. (a -> b) -> a -> b
$ \[PersistText Text
txid, PersistInt64 Int64
nOuts, PersistInt64 Int64
delta] ->
            (Text
txid, Int64
nOuts, Int64
delta)

        isKeyRegistration :: a -> Int64 -> Bool
isKeyRegistration a
nOuts Int64
delta =
            a
nOuts a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
1 Bool -> Bool -> Bool
&& Int64
delta Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
max Int64
keyDepositValue Int64
minUtxoValue

        minUtxoValue :: Int64
minUtxoValue
            = Natural -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
            (Natural -> Int64) -> Natural -> Int64
forall a b. (a -> b) -> a -> b
$ Coin -> Natural
W.unCoin
            (Coin -> Natural) -> Coin -> Natural
forall a b. (a -> b) -> a -> b
$ DefaultFieldValues -> Coin
defaultMinimumUTxOValue DefaultFieldValues
defaultFieldValues

        keyDepositValue :: Int64
keyDepositValue
            = Natural -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
            (Natural -> Int64) -> Natural -> Int64
forall a b. (a -> b) -> a -> b
$ Coin -> Natural
W.unCoin
            (Coin -> Natural) -> Coin -> Natural
forall a b. (a -> b) -> a -> b
$ DefaultFieldValues -> Coin
defaultKeyDeposit DefaultFieldValues
defaultFieldValues

        mkQuery :: IO Text
mkQuery = Connection -> DBField -> IO SqlColumnStatus
isFieldPresent Connection
conn (EntityField TxWithdrawal TxId -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField TxWithdrawal TxId
forall typ. (typ ~ TxId) => EntityField TxWithdrawal typ
TxWithdrawalTxId) IO SqlColumnStatus -> (SqlColumnStatus -> Text) -> IO Text
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
            -- On rather old databases, the tx_withdrawal table doesn't even exists.
            SqlColumnStatus
TableMissing -> [Text] -> Text
T.unwords
                [ Text
"SELECT tx_id, num_out, total_in - total_out FROM tx_meta"
                , Text
"JOIN (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
resolvedInputsQuery Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") USING (tx_id)"
                , Text
"JOIN (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
outputsQuery Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") USING (tx_id)"
                , Text
"WHERE direction = 0"
                , Text
";"
                ]

            SqlColumnStatus
_ -> [Text] -> Text
T.unwords
                [ Text
"SELECT tx_id, num_out, total_in + IFNULL(total_wdrl, 0) - total_out FROM tx_meta"
                , Text
"JOIN (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
resolvedInputsQuery Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") USING (tx_id)"
                , Text
"LEFT JOIN (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
withdrawalsQuery Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") USING (tx_id)"
                , Text
"JOIN (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
outputsQuery Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") USING (tx_id)"
                , Text
"WHERE direction = 0"
                , Text
";"
                ]

        resolvedInputsQuery :: Text
resolvedInputsQuery = [Text] -> Text
T.unwords
            [ Text
"SELECT tx_in.tx_id, SUM(tx_out.amount) AS total_in FROM tx_in"
            , Text
"JOIN tx_out ON tx_out.tx_id = tx_in.source_tx_id AND tx_out.'index' = tx_in.source_index"
            , Text
"GROUP BY tx_in.tx_id"
            ]

        withdrawalsQuery :: Text
withdrawalsQuery = [Text] -> Text
T.unwords
            [ Text
"SELECT tx_id, SUM(amount) AS total_wdrl FROM tx_withdrawal"
            , Text
"GROUP BY tx_id"
            ]

        outputsQuery :: Text
outputsQuery = [Text] -> Text
T.unwords
            [ Text
"SELECT tx_id, SUM(amount) AS total_out, COUNT(*) AS num_out FROM tx_out"
            , Text
"GROUP BY tx_id"
            ]

    -- | Since key deposit and fee value are intertwined, we migrate them both
    -- here.
    updateFeeValueAndAddKeyDeposit :: Sqlite.Connection -> IO ()
    updateFeeValueAndAddKeyDeposit :: Connection -> IO ()
updateFeeValueAndAddKeyDeposit Connection
conn = do
        Connection -> DBField -> IO SqlColumnStatus
isFieldPresent Connection
conn DBField
fieldKeyDeposit IO SqlColumnStatus -> (SqlColumnStatus -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            SqlColumnStatus
ColumnMissing -> do
                -- If the key deposit is missing, we need to add it, but also
                -- and first, we also need to update the fee policy and drop
                -- the third component of the fee policy which is now captured
                -- by the stake key deposit.
                Statement
feePolicyInfo <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
conn (Text -> IO Statement) -> Text -> IO Statement
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
                    [ Text
"SELECT", DBField -> Text
fieldName DBField
fieldFeePolicy
                    , Text
"FROM", DBField -> Text
tableName DBField
fieldFeePolicy
                    , Text
";"
                    ]
                [PersistValue]
row <- Statement -> IO StepResult
Sqlite.step Statement
feePolicyInfo IO StepResult -> IO [PersistValue] -> IO [PersistValue]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Statement -> IO [PersistValue]
Sqlite.columns Statement
feePolicyInfo
                Statement -> IO ()
Sqlite.finalize Statement
feePolicyInfo

                case (PersistValue -> Bool) -> [PersistValue] -> [PersistValue]
forall a. (a -> Bool) -> [a] -> [a]
filter (PersistValue -> PersistValue -> Bool
forall a. Eq a => a -> a -> Bool
/= PersistValue
PersistNull) [PersistValue]
row of
                    [PersistText Text
t] -> case Text -> Text -> [Text]
T.splitOn Text
" + " Text
t of
                        [Text
a,Text
b,Text
c] -> do
                            Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> Text -> DBLog
MsgManualMigrationNeeded DBField
fieldFeePolicy Text
t
                            -- update fee policy
                            let newVal :: Text
newVal = Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" + " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b
                            Statement
query <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
conn (Text -> IO Statement) -> Text -> IO Statement
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
                                [ Text
"UPDATE", DBField -> Text
tableName DBField
fieldFeePolicy
                                , Text
"SET", DBField -> Text
fieldName DBField
fieldFeePolicy, Text
"= '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
newVal Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
                                , Text
";"
                                ]
                            Statement -> IO StepResult
Sqlite.step Statement
query IO StepResult -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Statement -> IO ()
Sqlite.finalize Statement
query
                            let (Right Coin
stakeKeyVal) = Natural -> Coin
W.Coin (Natural -> Coin) -> (Double -> Natural) -> Double -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Natural
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Coin)
-> Either TextDecodingError Double -> Either TextDecodingError Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either TextDecodingError Double
forall a. FromText a => Text -> Either TextDecodingError a
fromText @Double (Int -> Text -> Text
T.dropEnd Int
1 Text
c)
                            Connection -> Text -> IO ()
addKeyDepositIfMissing Connection
conn (Coin -> Text
forall a. ToText a => a -> Text
toText Coin
stakeKeyVal)
                        [Text]
_ ->
                            String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unexpected row result when querying fee value: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t)
                    [PersistValue]
_ ->
                        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

            -- If the protocol_parameters table is missing, or if if the key
            -- deposit exists, there's nothing to do in this migration.
            SqlColumnStatus
_ -> do
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> DBLog
MsgManualMigrationNotNeeded DBField
fieldFeePolicy
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> DBLog
MsgManualMigrationNotNeeded DBField
fieldKeyDeposit
      where
        fieldFeePolicy :: DBField
fieldFeePolicy  = EntityField ProtocolParameters FeePolicy -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField ProtocolParameters FeePolicy
forall typ. (typ ~ FeePolicy) => EntityField ProtocolParameters typ
ProtocolParametersFeePolicy
        fieldKeyDeposit :: DBField
fieldKeyDeposit = EntityField ProtocolParameters Coin -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField ProtocolParameters Coin
forall typ. (typ ~ Coin) => EntityField ProtocolParameters typ
ProtocolParametersKeyDeposit

    -- | Adds an 'policy_xpub' column to the 'seq_state'
    -- table if it is missing.
    --
    addPolicyXPubIfMissing :: Sqlite.Connection -> IO ()
    addPolicyXPubIfMissing :: Connection -> IO ()
addPolicyXPubIfMissing Connection
conn = do
        Connection -> Bool -> DBField -> Text -> IO ()
addColumn_ Connection
conn Bool
False (EntityField SeqState (Maybe ByteString) -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField SeqState (Maybe ByteString)
forall typ. (typ ~ Maybe ByteString) => EntityField SeqState typ
SeqStatePolicyXPub) Text
value
      where
        value :: Text
value = Text
"NULL"

    -- | Determines whether a field is present in its parent table.
    isFieldPresent :: Sqlite.Connection -> DBField -> IO SqlColumnStatus
    isFieldPresent :: Connection -> DBField -> IO SqlColumnStatus
isFieldPresent Connection
conn DBField
field =
        Connection -> Text -> Text -> IO SqlColumnStatus
isFieldPresentByName Connection
conn (DBField -> Text
tableName DBField
field) (DBField -> Text
fieldName DBField
field)

    isFieldPresentByName :: Sqlite.Connection -> Text -> Text -> IO SqlColumnStatus
    isFieldPresentByName :: Connection -> Text -> Text -> IO SqlColumnStatus
isFieldPresentByName Connection
conn Text
table Text
field = do
        Statement
getTableInfo' <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
conn (Text -> IO Statement) -> Text -> IO Statement
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"SELECT sql FROM sqlite_master "
            , Text
"WHERE type = 'table' "
            , Text
"AND name = '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"';"
            ]
        [PersistValue]
row <- Statement -> IO StepResult
Sqlite.step Statement
getTableInfo'
            IO StepResult -> IO [PersistValue] -> IO [PersistValue]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Statement -> IO [PersistValue]
Sqlite.columns Statement
getTableInfo'
        Statement -> IO ()
Sqlite.finalize Statement
getTableInfo'
        SqlColumnStatus -> IO SqlColumnStatus
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SqlColumnStatus -> IO SqlColumnStatus)
-> SqlColumnStatus -> IO SqlColumnStatus
forall a b. (a -> b) -> a -> b
$ case [PersistValue]
row of
            [PersistText Text
t]
                | Text
field Text -> Text -> Bool
`T.isInfixOf` Text
t -> SqlColumnStatus
ColumnPresent
                | Bool
otherwise             -> SqlColumnStatus
ColumnMissing
            [PersistValue]
_ -> SqlColumnStatus
TableMissing

    addColumn_
        :: Sqlite.Connection
        -> Bool
        -> DBField
        -> Text
        -> IO ()
    addColumn_ :: Connection -> Bool -> DBField -> Text -> IO ()
addColumn_ Connection
a Bool
b DBField
c =
        IO SqlColumnStatus -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SqlColumnStatus -> IO ())
-> (Text -> IO SqlColumnStatus) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> Bool -> DBField -> Text -> IO SqlColumnStatus
addColumn Connection
a Bool
b DBField
c

    -- | A migration for adding a non-existing column to a table. Factor out as
    -- it's a common use-case.
    addColumn
        :: Sqlite.Connection
        -> Bool
        -> DBField
        -> Text
        -> IO SqlColumnStatus
    addColumn :: Connection -> Bool -> DBField -> Text -> IO SqlColumnStatus
addColumn Connection
conn Bool
notNull DBField
field Text
value = do
        Connection -> DBField -> IO SqlColumnStatus
isFieldPresent Connection
conn DBField
field IO SqlColumnStatus
-> (SqlColumnStatus -> IO SqlColumnStatus) -> IO SqlColumnStatus
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \SqlColumnStatus
st -> SqlColumnStatus
st SqlColumnStatus -> IO () -> IO SqlColumnStatus
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ case SqlColumnStatus
st of
            SqlColumnStatus
TableMissing ->
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> DBLog
MsgManualMigrationNotNeeded DBField
field
            SqlColumnStatus
ColumnMissing -> do
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> Text -> DBLog
MsgManualMigrationNeeded DBField
field Text
value
                Statement
query <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
conn (Text -> IO Statement) -> Text -> IO Statement
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
                    [ Text
"ALTER TABLE", DBField -> Text
tableName DBField
field
                    , Text
"ADD COLUMN", DBField -> Text
fieldName DBField
field
                    , DBField -> Text
fieldType DBField
field, if Bool
notNull then Text
"NOT NULL" else Text
""
                    , Text
"DEFAULT", Text
value
                    , Text
";"
                    ]
                StepResult
_ <- Statement -> IO StepResult
Sqlite.step Statement
query
                Statement -> IO ()
Sqlite.finalize Statement
query
            SqlColumnStatus
ColumnPresent ->
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> DBLog
MsgManualMigrationNotNeeded DBField
field

    renameColumnField
        :: Sqlite.Connection
        -> DBField
        -> Text -- Old Value
        -> Text -- New Value
        -> IO ()
    renameColumnField :: Connection -> DBField -> Text -> Text -> IO ()
renameColumnField Connection
conn DBField
field Text
old Text
new = do
        Connection -> DBField -> IO SqlColumnStatus
isFieldPresent Connection
conn DBField
field IO SqlColumnStatus -> (SqlColumnStatus -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            SqlColumnStatus
TableMissing ->
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> DBLog
MsgManualMigrationNotNeeded DBField
field
            SqlColumnStatus
ColumnMissing -> do
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBField -> DBLog
MsgManualMigrationNotNeeded DBField
field
            SqlColumnStatus
ColumnPresent -> do
                Statement
query <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
conn (Text -> IO Statement) -> Text -> IO Statement
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
                    [ Text
"UPDATE", DBField -> Text
tableName DBField
field
                    , Text
"SET", DBField -> Text
fieldName DBField
field, Text
"=", Text -> Text
quotes Text
new
                    , Text
"WHERE", DBField -> Text
fieldName DBField
field, Text
"=", Text -> Text
quotes Text
old
                    ]
                StepResult
_ <- Statement -> IO StepResult
Sqlite.step Statement
query
                Int64
changes <- Connection -> IO Int64
Sqlite.changes Connection
conn
                Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ if Int64
changes Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0
                    then DBField -> Text -> DBLog
MsgManualMigrationNeeded DBField
field Text
old
                    else DBField -> DBLog
MsgManualMigrationNotNeeded DBField
field
                Statement -> IO ()
Sqlite.finalize Statement
query

    quotes :: Text -> Text
    quotes :: Text -> Text
quotes Text
x = Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""

-- | Unsafe, execute a raw SQLite query. Used only in migration when really
-- needed.
runSql :: Sqlite.Connection -> Text -> IO [[PersistValue]]
runSql :: Connection -> Text -> IO [[PersistValue]]
runSql Connection
conn Text
raw = do
    Statement
query <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
conn Text
raw
    [[PersistValue]]
result <- Statement -> [[PersistValue]] -> IO [[PersistValue]]
collect Statement
query []
    Statement -> IO ()
Sqlite.finalize Statement
query
    [[PersistValue]] -> IO [[PersistValue]]
forall (m :: * -> *) a. Monad m => a -> m a
return [[PersistValue]]
result
  where
    collect :: Statement -> [[PersistValue]] -> IO [[PersistValue]]
collect Statement
query [[PersistValue]]
acc = do
        StepResult
step <- Statement -> IO StepResult
Sqlite.step Statement
query
        case StepResult
step of
            StepResult
Sqlite.Row -> do
                [PersistValue]
result <- Statement -> IO [PersistValue]
Sqlite.columns Statement
query
                Statement -> [[PersistValue]] -> IO [[PersistValue]]
collect Statement
query ([PersistValue]
result [PersistValue] -> [[PersistValue]] -> [[PersistValue]]
forall a. a -> [a] -> [a]
: [[PersistValue]]
acc)
            StepResult
Sqlite.Done -> do
                [[PersistValue]] -> IO [[PersistValue]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[PersistValue]] -> [[PersistValue]]
forall a. [a] -> [a]
reverse [[PersistValue]]
acc)