implement database abstract model for state-machine testing.

cardano-foundation · Jul 3, 2020 · 8a33b1e · 8a33b1e
1 parent eecc482
commit 8a33b1e
Show file tree

Hide file tree

Showing 3 changed files with 40 additions and 6 deletions.
diff --git 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
@@ -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
@@ -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
 -------------------------------------------------------------------------------}