Don't attempt to execute nested pool DB queries.

Calls to `atomically` cannot be nested.

lib/core/src/Cardano/Pool/DB.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -15,7 +14,6 @@ module Cardano.Pool.DB
     ( -- * Interface
       DBLayer (..)
     , determinePoolRegistrationStatus
-    , readPoolRegistrationStatus
 
       -- * Errors
     , ErrPointAlreadyExists (..)
@@ -108,6 +106,10 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
         --
         -- This is useful for the @NetworkLayer@ to know how far we have synced.
 
+    , readPoolRegistrationStatus
+        :: PoolId
+        -> stm PoolRegistrationStatus
+
     , putPoolRegistration
         :: CertificatePublicationTime
         -> PoolRegistrationCertificate
@@ -254,20 +256,6 @@ determinePoolRegistrationStatus mReg mRet = case (mReg, mRet) of
             , show retTime
             ]
 
--- | Reads the current registration status of a pool.
---
--- See 'PoolRegistrationStatus' for more details.
---
-readPoolRegistrationStatus
-    :: DBLayer m
-    -> PoolId
-    -> m PoolRegistrationStatus
-readPoolRegistrationStatus
-    DBLayer {atomically, readPoolRegistration, readPoolRetirement} poolId =
-        atomically $ determinePoolRegistrationStatus
-            <$> readPoolRegistration poolId
-            <*> readPoolRetirement poolId
-
 -- | Forbidden operation was executed on an already existing slot
 newtype ErrPointAlreadyExists
     = ErrPointAlreadyExists BlockHeader -- Point already exists in db

lib/core/src/Cardano/Pool/DB/MVar.hs

@@ -17,7 +17,10 @@ module Cardano.Pool.DB.MVar
 import Prelude
 
 import Cardano.Pool.DB
-    ( DBLayer (..), ErrPointAlreadyExists (..) )
+    ( DBLayer (..)
+    , ErrPointAlreadyExists (..)
+    , determinePoolRegistrationStatus
+    )
 import Cardano.Pool.DB.Model
     ( ModelPoolOp
     , PoolDatabase
@@ -60,6 +63,10 @@ import Data.Tuple
 newDBLayer :: IO (DBLayer IO)
 newDBLayer = do
     db <- newMVar emptyPoolDatabase
+    let readPoolRegistration_ =
+            readPoolDB db . mReadPoolRegistration
+    let readPoolRetirement_ =
+            readPoolDB db . mReadPoolRetirement
     return $ DBLayer
 
         { putPoolProduction = \sl pool -> ExceptT $ do
@@ -85,15 +92,18 @@ newDBLayer = do
               $ alterPoolDB (const Nothing) db
               $ mPutPoolRegistration cpt cert
 
-        , readPoolRegistration =
-            readPoolDB db . mReadPoolRegistration
+        , readPoolRegistrationStatus = \poolId ->
+            determinePoolRegistrationStatus
+                <$> readPoolRegistration_ poolId
+                <*> readPoolRetirement_ poolId
+
+        , readPoolRegistration = readPoolRegistration_
 
         , putPoolRetirement = \cpt cert -> void
             $ alterPoolDB (const Nothing) db
             $ mPutPoolRetirement cpt cert
 
-        , readPoolRetirement =
-            readPoolDB db . mReadPoolRetirement
+        , readPoolRetirement = readPoolRetirement_
 
         , unfetchedPoolMetadataRefs =
             readPoolDB db . mUnfetchedPoolMetadataRefs

lib/core/src/Cardano/Pool/DB/Sqlite.hs

@@ -42,7 +42,10 @@ import Cardano.DB.Sqlite
     , tableName
     )
 import Cardano.Pool.DB
-    ( DBLayer (..), ErrPointAlreadyExists (..) )
+    ( DBLayer (..)
+    , ErrPointAlreadyExists (..)
+    , determinePoolRegistrationStatus
+    )
 import Cardano.Wallet.DB.Sqlite.Types
     ( BlockId (..) )
 import Cardano.Wallet.Primitive.Types
@@ -203,6 +206,11 @@ newDBLayer trace fp = do
                 [ StakeDistributionEpoch ==. fromIntegral epoch ]
                 []
 
+        , readPoolRegistrationStatus = \poolId ->
+            determinePoolRegistrationStatus
+                <$> readPoolRegistration_ poolId
+                <*> readPoolRetirement_ poolId
+
         , putPoolRegistration = \cpt cert -> do
             let CertificatePublicationTime {slotId, slotInternalIndex} = cpt
             let poolId = view #poolId cert
@@ -232,48 +240,7 @@ newDBLayer trace fp = do
                     (poolOwners cert)
                     [0..]
 
-        , readPoolRegistration = \poolId -> do
-            result <- selectFirst
-                [ PoolRegistrationPoolId ==. poolId ]
-                [ Desc PoolRegistrationSlot
-                , Desc PoolRegistrationSlotInternalIndex
-                ]
-            forM result $ \meta -> do
-                let PoolRegistration
-                        _poolId
-                        slotId
-                        slotInternalIndex
-                        marginNum
-                        marginDen
-                        poolCost_
-                        poolPledge_
-                        poolMetadataUrl
-                        poolMetadataHash = entityVal meta
-                let poolMargin = unsafeMkPercentage $
-                        toRational $ marginNum % marginDen
-                let poolCost = Quantity poolCost_
-                let poolPledge = Quantity poolPledge_
-                let poolMetadata = (,) <$> poolMetadataUrl <*> poolMetadataHash
-                poolOwners <- fmap (poolOwnerOwner . entityVal) <$>
-                    selectList
-                        [ PoolOwnerPoolId
-                            ==. poolId
-                        , PoolOwnerSlot
-                            ==. slotId
-                        , PoolOwnerSlotInternalIndex
-                            ==. slotInternalIndex
-                        ]
-                        [ Asc PoolOwnerIndex ]
-                let cert = PoolRegistrationCertificate
-                        { poolId
-                        , poolOwners
-                        , poolMargin
-                        , poolCost
-                        , poolPledge
-                        , poolMetadata
-                        }
-                let cpt = CertificatePublicationTime {slotId, slotInternalIndex}
-                pure (cpt, cert)
+        , readPoolRegistration = readPoolRegistration_
 
         , putPoolRetirement = \cpt cert -> do
             let CertificatePublicationTime {slotId, slotInternalIndex} = cpt
@@ -289,22 +256,7 @@ newDBLayer trace fp = do
                     slotInternalIndex
                     (fromIntegral retirementEpoch)
 
-        , readPoolRetirement = \poolId -> do
-            result <- selectFirst
-                [ PoolRetirementPoolId ==. poolId ]
-                [ Desc PoolRetirementSlot
-                , Desc PoolRetirementSlotInternalIndex
-                ]
-            forM result $ \meta -> do
-                let PoolRetirement
-                        _poolId
-                        slotId
-                        slotInternalIndex
-                        retirementEpoch = entityVal meta
-                let retiredIn = EpochNo (fromIntegral retirementEpoch)
-                let cert = PoolRetirementCertificate {poolId, retiredIn}
-                let cpt = CertificatePublicationTime {slotId, slotInternalIndex}
-                pure (cpt, cert)
+        , readPoolRetirement = readPoolRetirement_
 
         , unfetchedPoolMetadataRefs = \limit -> do
             let nLimit = T.pack (show limit)
@@ -413,6 +365,66 @@ newDBLayer trace fp = do
 
         , atomically = runQuery
         })
+    where
+        readPoolRegistration_ poolId = do
+            result <- selectFirst
+                [ PoolRegistrationPoolId ==. poolId ]
+                [ Desc PoolRegistrationSlot
+                , Desc PoolRegistrationSlotInternalIndex
+                ]
+            forM result $ \meta -> do
+                let PoolRegistration
+                        _poolId
+                        slotId
+                        slotInternalIndex
+                        marginNum
+                        marginDen
+                        poolCost_
+                        poolPledge_
+                        poolMetadataUrl
+                        poolMetadataHash = entityVal meta
+                let poolMargin = unsafeMkPercentage $
+                        toRational $ marginNum % marginDen
+                let poolCost = Quantity poolCost_
+                let poolPledge = Quantity poolPledge_
+                let poolMetadata = (,) <$> poolMetadataUrl <*> poolMetadataHash
+                poolOwners <- fmap (poolOwnerOwner . entityVal) <$>
+                    selectList
+                        [ PoolOwnerPoolId
+                            ==. poolId
+                        , PoolOwnerSlot
+                            ==. slotId
+                        , PoolOwnerSlotInternalIndex
+                            ==. slotInternalIndex
+                        ]
+                        [ Asc PoolOwnerIndex ]
+                let cert = PoolRegistrationCertificate
+                        { poolId
+                        , poolOwners
+                        , poolMargin
+                        , poolCost
+                        , poolPledge
+                        , poolMetadata
+                        }
+                let cpt = CertificatePublicationTime {slotId, slotInternalIndex}
+                pure (cpt, cert)
+
+        readPoolRetirement_ poolId = do
+            result <- selectFirst
+                [ PoolRetirementPoolId ==. poolId ]
+                [ Desc PoolRetirementSlot
+                , Desc PoolRetirementSlotInternalIndex
+                ]
+            forM result $ \meta -> do
+                let PoolRetirement
+                        _poolId
+                        slotId
+                        slotInternalIndex
+                        retirementEpoch = entityVal meta
+                let retiredIn = EpochNo (fromIntegral retirementEpoch)
+                let cert = PoolRetirementCertificate {poolId, retiredIn}
+                let cpt = CertificatePublicationTime {slotId, slotInternalIndex}
+                pure (cpt, cert)
 
 -- | 'Temporary', catches migration error from previous versions and if any,
 -- _removes_ the database file completely before retrying to start the database.

lib/core/test/unit/Cardano/Pool/DB/Properties.hs

@@ -599,7 +599,7 @@ prop_readPoolRegistrationStatus
     -> [PoolCertificate]
     -> Property
 prop_readPoolRegistrationStatus
-    db@DBLayer {..} sharedPoolId certificatesManyPoolIds =
+    DBLayer {..} sharedPoolId certificatesManyPoolIds =
         monadicIO (setup >> prop)
   where
     setup = run $ atomically cleanDB
@@ -609,9 +609,10 @@ prop_readPoolRegistrationStatus
         mFinalRetirement
 
     prop = do
-        run $ atomically $
-            mapM_ (uncurry putCertificate) certificatePublications
-        actualStatus <- run $ readPoolRegistrationStatus db sharedPoolId
+        actualStatus <-
+            run $ atomically $ do
+                mapM_ (uncurry putCertificate) certificatePublications
+                readPoolRegistrationStatus sharedPoolId
         monitor $ counterexample $ unlines
             [ "\nFinal registration: "
             , show mFinalRegistration

lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs

@@ -307,9 +307,9 @@ combineChainData =
 readDBPoolData
     :: DBLayer IO
     -> IO (Map PoolId PoolDbData)
-readDBPoolData db@DBLayer{..} = atomically $ do
+readDBPoolData DBLayer {..} = atomically $ do
     pools <- listRegisteredPools
-    registrationStatuses <- mapM (liftIO . readPoolRegistrationStatus db) pools
+    registrationStatuses <- mapM readPoolRegistrationStatus pools
     let certMap = Map.fromList
             [ (poolId, certs)
             | (poolId, Just certs) <- zip pools