implement database abstract model for state-machine testing.

cardano-foundation · Jul 3, 2020 · 68fbe3b · 68fbe3b
1 parent eecc482
commit 68fbe3b
Show file tree

Hide file tree

Showing 3 changed files with 29 additions and 5 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
@@ -124,6 +124,7 @@ import Cardano.Wallet.Primitive.Types
     , SlotId (..)
     , SlotNo (..)
     , SortOrder (..)
+    , StakeKeyCertificate
     , TransactionInfo (..)
     , Tx (..)
     , TxIn (..)
@@ -843,6 +844,9 @@ instance ToExpr Direction where
 instance ToExpr MWid where
     toExpr = defaultExprViaShow
 
+instance ToExpr StakeKeyCertificate where
+    toExpr = genericToExpr
+
 {-------------------------------------------------------------------------------
   Tagging
 -------------------------------------------------------------------------------}