diff --git a/lib/core/src/Cardano/Wallet/DB/MVar.hs b/lib/core/src/Cardano/Wallet/DB/MVar.hs index 863a1102d79..204d2fb012a 100644 --- a/lib/core/src/Cardano/Wallet/DB/MVar.hs +++ b/lib/core/src/Cardano/Wallet/DB/MVar.hs @@ -35,6 +35,7 @@ import Cardano.Wallet.DB.Model , emptyDatabase , mCheckWallet , mInitializeWallet + , mIsStakeKeyRegistered , mListCheckpoints , mListWallets , mPutCheckpoint @@ -118,7 +119,8 @@ newDBLayer = do cert `deepseq` sl `deepseq` alterDB errNoSuchWallet db (mPutDelegationCertificate pk cert sl) - , readIsStakeKeyRegistered = error "todo" + , isStakeKeyRegistered = + ExceptT . alterDB errNoSuchWallet db . mIsStakeKeyRegistered {----------------------------------------------------------------------- Tx History diff --git a/lib/core/src/Cardano/Wallet/DB/Model.hs b/lib/core/src/Cardano/Wallet/DB/Model.hs index 593283d9c8f..dfd4f877654 100644 --- a/lib/core/src/Cardano/Wallet/DB/Model.hs +++ b/lib/core/src/Cardano/Wallet/DB/Model.hs @@ -50,6 +50,7 @@ module Cardano.Wallet.DB.Model , mPutWalletMeta , mReadWalletMeta , mPutDelegationCertificate + , mIsStakeKeyRegistered , mPutTxHistory , mReadTxHistory , mRemovePendingTx @@ -78,6 +79,7 @@ import Cardano.Wallet.Primitive.Types , Range (..) , SlotId (..) , SortOrder (..) + , StakeKeyCertificate (..) , TransactionInfo (..) , Tx (..) , TxMeta (..) @@ -139,6 +141,7 @@ deriving instance (Eq wid, Eq xprv, Eq s) => Eq (Database wid s xprv) data WalletDatabase s xprv = WalletDatabase { checkpoints :: !(Map SlotId (Wallet s)) , certificates :: !(Map SlotId (Maybe PoolId)) + , stakeKeys :: !(Map SlotId StakeKeyCertificate) , metadata :: !WalletMetadata , txHistory :: !(Map (Hash "Tx") TxMeta) , xprv :: !(Maybe xprv) @@ -202,6 +205,7 @@ mInitializeWallet wid cp meta txs0 pp db@Database{wallets,txs} let wal = WalletDatabase { checkpoints = Map.singleton (tip cp) cp + , stakeKeys = mempty , certificates = mempty , metadata = meta , txHistory = history @@ -353,11 +357,25 @@ mPutDelegationCertificate -> DelegationCertificate -> SlotId -> ModelOp wid s xprv () -mPutDelegationCertificate wid cert slot = alterModel wid $ \wal -> - ( () +mPutDelegationCertificate wid cert slot = alterModel wid + $ \wal@WalletDatabase{certificates,stakeKeys} -> + ( () + , wal + { certificates = Map.insert slot (dlgCertPoolId cert) certificates + , stakeKeys = case cert of + CertDelegateNone{} -> Map.insert slot StakeKeyDeregistration stakeKeys + CertDelegateFull{} -> stakeKeys + CertRegisterKey{} -> Map.insert slot StakeKeyRegistration stakeKeys + } + ) + +mIsStakeKeyRegistered + :: Ord wid + => wid + -> ModelOp wid s xprv Bool +mIsStakeKeyRegistered wid = alterModel wid $ \wal@WalletDatabase{stakeKeys} -> + ( maybe False ((== StakeKeyRegistration) . snd) (Map.lookupMax stakeKeys) , wal - { certificates = Map.insert slot (dlgCertPoolId cert) (certificates wal) - } ) mPutTxHistory diff --git a/lib/core/test/unit/Cardano/Wallet/DB/StateMachine.hs b/lib/core/test/unit/Cardano/Wallet/DB/StateMachine.hs index 247a7ed97af..9beb16d564d 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/StateMachine.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/StateMachine.hs @@ -71,6 +71,7 @@ import Cardano.Wallet.DB.Model , emptyDatabase , mCleanDB , mInitializeWallet + , mIsStakeKeyRegistered , mListCheckpoints , mListWallets , mPutCheckpoint @@ -124,6 +125,7 @@ import Cardano.Wallet.Primitive.Types , SlotId (..) , SlotNo (..) , SortOrder (..) + , StakeKeyCertificate , TransactionInfo (..) , Tx (..) , TxIn (..) @@ -298,6 +300,7 @@ data Cmd s wid | RollbackTo wid SlotId | RemovePendingTx wid (Hash "Tx") | PutDelegationCertificate wid DelegationCertificate SlotId + | IsStakeKeyRegistered wid | PutDelegationRewardBalance wid (Quantity "lovelace" Word64) | ReadDelegationRewardBalance wid deriving (Show, Functor, Foldable, Traversable) @@ -314,6 +317,7 @@ data Success s wid | BlockHeaders [BlockHeader] | Point SlotId | DelegationRewardBalance (Quantity "lovelace" Word64) + | StakeKeyStatus Bool deriving (Show, Eq, Functor, Foldable, Traversable) newtype Resp s wid @@ -357,6 +361,8 @@ runMock = \case first (Resp . fmap Metadata) . mReadWalletMeta wid PutDelegationCertificate wid cert sl -> first (Resp . fmap Unit) . mPutDelegationCertificate wid cert sl + IsStakeKeyRegistered wid -> + first (Resp . fmap StakeKeyStatus) . mIsStakeKeyRegistered wid PutTxHistory wid txs -> first (Resp . fmap Unit) . mPutTxHistory wid txs ReadTxHistory wid order range status -> @@ -419,6 +425,8 @@ runIO db@DBLayer{..} = fmap Resp . go atomically (readWalletMeta $ PrimaryKey wid) PutDelegationCertificate wid pool sl -> catchNoSuchWallet Unit $ mapExceptT atomically $ putDelegationCertificate (PrimaryKey wid) pool sl + IsStakeKeyRegistered wid -> catchNoSuchWallet StakeKeyStatus $ + mapExceptT atomically $ isStakeKeyRegistered (PrimaryKey wid) PutTxHistory wid txs -> catchNoSuchWallet Unit $ mapExceptT atomically $ putTxHistory (PrimaryKey wid) txs ReadTxHistory wid order range status -> Right . TxHistory <$> @@ -572,6 +580,7 @@ generator (Model _ wids) = Just $ frequency $ fmap (fmap At) <$> concat , (5, PutWalletMeta <$> genId' <*> arbitrary) , (5, ReadWalletMeta <$> genId') , (5, PutDelegationCertificate <$> genId' <*> arbitrary <*> arbitrary) + , (1, IsStakeKeyRegistered <$> genId') , (5, PutTxHistory <$> genId' <*> fmap unGenTxHistory arbitrary) , (5, ReadTxHistory <$> genId' <*> genSortOrder <*> genRange <*> arbitrary) , (4, RemovePendingTx <$> genId' <*> arbitrary) @@ -701,6 +710,7 @@ instance CommandNames (At (Cmd s)) where cmdName (At PutWalletMeta{}) = "PutWalletMeta" cmdName (At ReadWalletMeta{}) = "ReadWalletMeta" cmdName (At PutDelegationCertificate{}) = "PutDelegationCertificate" + cmdName (At IsStakeKeyRegistered{}) = "IsStakeKeyRegistered" cmdName (At PutTxHistory{}) = "PutTxHistory" cmdName (At ReadTxHistory{}) = "ReadTxHistory" cmdName (At PutPrivateKey{}) = "PutPrivateKey" @@ -715,7 +725,8 @@ instance CommandNames (At (Cmd s)) where [ "CleanDB" , "CreateWallet", "RemoveWallet", "ListWallets" , "PutCheckpoint", "ReadCheckpoint", "ListCheckpoints", "RollbackTo" - , "PutWalletMeta", "ReadWalletMeta", "PutDelegationCertificate" + , "PutWalletMeta", "ReadWalletMeta" + , "PutDelegationCertificate", "IsStakeKeyRegistered" , "PutTxHistory", "ReadTxHistory", "RemovePendingTx" , "PutPrivateKey", "ReadPrivateKey" , "PutProtocolParameters", "ReadProtocolParameters" @@ -843,6 +854,9 @@ instance ToExpr Direction where instance ToExpr MWid where toExpr = defaultExprViaShow +instance ToExpr StakeKeyCertificate where + toExpr = genericToExpr + {------------------------------------------------------------------------------- Tagging -------------------------------------------------------------------------------}