Merge #2047

2047:  Add pool DB operation `removeRetiredPools`.  r=jonathanknowles a=jonathanknowles

# Issue Number

#2018 

# Overview

Building on the work added in PRs #2024 and #2038, this PR:

- [x] Adds a `removeRetiredPools` operation to the pool DB layer:<br><br>
    ```hs
    removeRetiredPools  
        :: EpochNo
        -> stm [PoolRetirementCertificate]
        -- ^ Remove all pools with an active retirement epoch that is earlier 
        -- than or equal to the specified epoch.  
        --
        -- Returns the retirement certificates of the pools that were removed.
    ```
- [x] Writes a bracketed `MsgRemovingRetiredPools` message to the log whenever the `removeRetiredPools` operation is called:<br><br>
    ```
    Looking for pools that retired in or before epoch 1000.
    Removing the following retired pools:
        Pool 4355a46b with retirement epoch 999
        Pool 53c234e5 with retirement epoch 999
        Pool 121cfccd with retirement epoch 1000
        Pool 917df332 with retirement epoch 1000
    Finished removing retired pools.
    ```

# Further Work

Before garbage collection can actually happen, the wallet needs to call `removeRetiredPools` at appropriate intervals. This work is deferred to a future PR.

See issue #2019.

Co-authored-by: Jonathan Knowles <jonathan.knowles@iohk.io>

lib/core/cardano-wallet-core.cabal

@@ -114,6 +114,7 @@ library
       Cardano.DB.Sqlite
       Cardano.DB.Sqlite.Delete
       Cardano.Pool.DB
+      Cardano.Pool.DB.Log
       Cardano.Pool.DB.MVar
       Cardano.Pool.DB.Model
       Cardano.Pool.DB.Sqlite

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

@@ -380,7 +380,6 @@ data DBLog
     | MsgUnknownDBFile FilePath
     deriving (Generic, Show, Eq, ToJSON)
 
-
 {-------------------------------------------------------------------------------
                                     Logging
 -------------------------------------------------------------------------------}

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -16,13 +17,18 @@ module Cardano.Pool.DB
 
       -- * Utilities
     , determinePoolLifeCycleStatus
+    , removeRetiredPools
 
       -- * Errors
     , ErrPointAlreadyExists (..)
     ) where
 
 import Prelude
 
+import Cardano.Pool.DB.Log
+    ( PoolDbLog (..) )
+import Cardano.Wallet.Logging
+    ( bracketTracer )
 import Cardano.Wallet.Primitive.Types
     ( BlockHeader
     , CertificatePublicationTime (..)
@@ -39,9 +45,11 @@ import Cardano.Wallet.Primitive.Types
 import Control.Monad.Fail
     ( MonadFail )
 import Control.Monad.IO.Class
-    ( MonadIO )
+    ( MonadIO, liftIO )
 import Control.Monad.Trans.Except
     ( ExceptT )
+import Control.Tracer
+    ( Tracer, contramap, traceWith )
 import Data.Generics.Internal.VL.Lens
     ( view )
 import Data.Map.Strict
@@ -280,6 +288,33 @@ determinePoolLifeCycleStatus mReg mRet = case (mReg, mRet) of
             , show retTime
             ]
 
+-- | Removes all pools with an active retirement epoch that is earlier than
+--   or equal to the specified epoch.
+--
+-- Returns the retirement certificates of the pools that were removed.
+--
+-- See also:
+--
+--    - 'listRetiredPools'.
+--    - 'removePools'.
+--
+removeRetiredPools
+    :: DBLayer IO
+    -> Tracer IO PoolDbLog
+    -> EpochNo
+    -> IO [PoolRetirementCertificate]
+removeRetiredPools
+    DBLayer {atomically, listRetiredPools, removePools} trace epoch =
+        bracketTracer (contramap actionMessage trace) action
+  where
+    actionMessage = MsgRemovingRetiredPoolsForEpoch epoch
+
+    action = atomically $
+        listRetiredPools epoch >>= \retirementCerts -> do
+            liftIO $ traceWith trace $ MsgRemovingRetiredPools retirementCerts
+            removePools (view #poolId <$> retirementCerts)
+            pure retirementCerts
+
 -- | Forbidden operation was executed on an already existing slot
 newtype ErrPointAlreadyExists
     = ErrPointAlreadyExists BlockHeader -- Point already exists in db

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

@@ -0,0 +1,67 @@
+{-# LANGUAGE LambdaCase #-}
+
+-- |
+-- Copyright: © 2018-2020 IOHK
+-- License: Apache-2.0
+--
+-- Logging types specific to the pool database.
+--
+module Cardano.Pool.DB.Log
+    ( PoolDbLog (..)
+    ) where
+
+import Prelude
+
+import Cardano.BM.Data.Severity
+    ( Severity (..) )
+import Cardano.BM.Data.Tracer
+    ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
+import Cardano.DB.Sqlite
+    ( DBLog (..) )
+import Cardano.Wallet.Logging
+    ( BracketLog )
+import Cardano.Wallet.Primitive.Types
+    ( EpochNo, PoolId, PoolRetirementCertificate )
+import Data.Text.Class
+    ( ToText (..), toText )
+import Fmt
+    ( pretty )
+
+import qualified Data.Text as T
+
+data PoolDbLog
+    = MsgGeneric DBLog
+    | MsgRemovingPool PoolId
+    | MsgRemovingRetiredPools [PoolRetirementCertificate]
+    | MsgRemovingRetiredPoolsForEpoch EpochNo BracketLog
+    deriving (Eq, Show)
+
+instance HasPrivacyAnnotation PoolDbLog
+
+instance HasSeverityAnnotation PoolDbLog where
+    getSeverityAnnotation = \case
+        MsgGeneric e -> getSeverityAnnotation e
+        MsgRemovingPool {} -> Notice
+        MsgRemovingRetiredPools {} -> Debug
+        MsgRemovingRetiredPoolsForEpoch {} -> Debug
+
+instance ToText PoolDbLog where
+    toText = \case
+        MsgGeneric e -> toText e
+        MsgRemovingPool p -> mconcat
+            [ "Removing the following pool from the database: "
+            , toText p
+            , "."
+            ]
+        MsgRemovingRetiredPools [] ->
+            "There are no retired pools to remove."
+        MsgRemovingRetiredPools poolRetirementCerts -> T.unlines
+            [ "Removing the following retired pools:"
+            , T.unlines (pretty <$> poolRetirementCerts)
+            ]
+        MsgRemovingRetiredPoolsForEpoch epoch nestedMessage -> T.concat
+            [ "Removing pools that retired in or before epoch "
+            , toText epoch
+            , ": "
+            , toText nestedMessage
+            ]

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

@@ -249,7 +249,7 @@ mPutPoolRetirement cpt cert db =
     )
   where
     PoolDatabase {retirements} = db
-    PoolRetirementCertificate poolId _retiredIn = cert
+    PoolRetirementCertificate poolId _retirementEpoch = cert
 
 mReadPoolRetirement
     :: PoolId
@@ -282,7 +282,7 @@ mListRetiredPools epochNo db = (retiredPools, db)
 
     retiredPools :: [PoolRetirementCertificate]
     retiredPools = activeRetirementCertificates
-        & filter ((<= epochNo) . view #retiredIn)
+        & filter ((<= epochNo) . view #retirementEpoch)
 
     activeRetirementCertificates :: [PoolRetirementCertificate]
     activeRetirementCertificates =

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

@@ -27,15 +27,10 @@ module Cardano.Pool.DB.Sqlite
     , withDBLayer
     , defaultFilePath
     , DatabaseView (..)
-    , PoolDbLog (..)
     ) where
 
 import Prelude
 
-import Cardano.BM.Data.Severity
-    ( Severity (..) )
-import Cardano.BM.Data.Tracer
-    ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
 import Cardano.DB.Sqlite
     ( DBField (..)
     , DBLog (..)
@@ -50,6 +45,8 @@ import Cardano.DB.Sqlite
     )
 import Cardano.Pool.DB
     ( DBLayer (..), ErrPointAlreadyExists (..), determinePoolLifeCycleStatus )
+import Cardano.Pool.DB.Log
+    ( PoolDbLog (..) )
 import Cardano.Wallet.DB.Sqlite.Types
     ( BlockId (..) )
 import Cardano.Wallet.Primitive.Slotting
@@ -92,8 +89,6 @@ import Data.String.QQ
     ( s )
 import Data.Text
     ( Text )
-import Data.Text.Class
-    ( ToText (..), toText )
 import Data.Time.Clock
     ( UTCTime, addUTCTime, getCurrentTime )
 import Data.Word
@@ -261,10 +256,7 @@ newDBLayer trace fp timeInterpreter = do
         , putPoolRetirement = \cpt cert -> do
             let CertificatePublicationTime {slotNo, slotInternalIndex} = cpt
             let PoolRetirementCertificate
-                    { poolId
-                    , retiredIn
-                    } = cert
-            let EpochNo retirementEpoch = retiredIn
+                    poolId (EpochNo retirementEpoch) = cert
             repsert (PoolRetirementKey poolId slotNo slotInternalIndex) $
                 PoolRetirement
                     poolId
@@ -476,9 +468,9 @@ newDBLayer trace fp timeInterpreter = do
                         _poolId
                         slotNo
                         slotInternalIndex
-                        retirementEpoch = entityVal meta
-                let retiredIn = EpochNo (fromIntegral retirementEpoch)
-                let cert = PoolRetirementCertificate {poolId, retiredIn}
+                        retirementEpochNo = entityVal meta
+                let retirementEpoch = EpochNo (fromIntegral retirementEpochNo)
+                let cert = PoolRetirementCertificate {poolId, retirementEpoch}
                 let cpt = CertificatePublicationTime {slotNo, slotInternalIndex}
                 pure (cpt, cert)
 
@@ -670,28 +662,3 @@ fromPoolMeta meta = (poolMetadataHash meta,) $
         , description = poolMetadataDescription meta
         , homepage = poolMetadataHomepage meta
         }
-
-{-------------------------------------------------------------------------------
-                                   Logging
--------------------------------------------------------------------------------}
-
-data PoolDbLog
-    = MsgGeneric DBLog
-    | MsgRemovingPool PoolId
-    deriving (Eq, Show)
-
-instance HasPrivacyAnnotation PoolDbLog
-
-instance HasSeverityAnnotation PoolDbLog where
-    getSeverityAnnotation = \case
-        MsgGeneric e -> getSeverityAnnotation e
-        MsgRemovingPool {} -> Notice
-
-instance ToText PoolDbLog where
-    toText = \case
-        MsgGeneric e -> toText e
-        MsgRemovingPool p -> mconcat
-            [ "Removing the following pool from the database: "
-            , toText p
-            , "."
-            ]

lib/core/src/Cardano/Wallet.hs

@@ -1896,7 +1896,7 @@ joinStakePool ctx currentEpoch knownPools pid poolStatus wid argGenChange pwd =
             $ (,) <$> isStakeKeyRegistered (PrimaryKey wid)
                   <*> withNoSuchWallet wid (readWalletMeta (PrimaryKey wid))
 
-        let mRetirementEpoch = view #retiredIn <$>
+        let mRetirementEpoch = view #retirementEpoch <$>
                 W.getPoolRetirementCertificate poolStatus
         let retirementInfo =
                 PoolRetirementEpochInfo currentEpoch <$> mRetirementEpoch

lib/core/src/Cardano/Wallet/Primitive/Types.hs

@@ -1667,7 +1667,7 @@ data PoolRetirementCertificate = PoolRetirementCertificate
     { poolId :: !PoolId
 
     -- | The first epoch when the pool becomes inactive.
-    , retiredIn :: !EpochNo
+    , retirementEpoch :: !EpochNo
     } deriving (Generic, Show, Eq, Ord)
 
 instance NFData PoolRetirementCertificate
@@ -1676,7 +1676,7 @@ instance Buildable PoolRetirementCertificate where
     build (PoolRetirementCertificate p e) = mempty
         <> "Pool "
         <> build p
-        <> " retiring at "
+        <> " with retirement epoch "
         <> build e
 
 -- | Represents an abstract notion of a certificate publication time.

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

@@ -34,8 +34,10 @@ import Cardano.Pool.DB.Arbitrary
     , isValidSinglePoolCertificateSequence
     , serializeLists
     )
+import Cardano.Pool.DB.Log
+    ( PoolDbLog )
 import Cardano.Pool.DB.Sqlite
-    ( PoolDbLog, newDBLayer )
+    ( newDBLayer )
 import Cardano.Wallet.DummyTarget.Primitive.Types
     ( dummyTimeInterpreter )
 import Cardano.Wallet.Primitive.Slotting
@@ -1008,10 +1010,10 @@ prop_listRetiredPools_multiplePools_multipleCerts
         let epochsToTest =
                 EpochNo minBound :
                 EpochNo maxBound :
-                L.nub (view #retiredIn <$> poolsMarkedToRetire)
+                L.nub (view #retirementEpoch <$> poolsMarkedToRetire)
         forM_ epochsToTest $ \currentEpoch -> do
             let retiredPoolsExpected = filter
-                    ((<= currentEpoch) . view #retiredIn)
+                    ((<= currentEpoch) . view #retirementEpoch)
                     (poolsMarkedToRetire)
             retiredPoolsActual <-
                 run $ atomically $ listRetiredPools currentEpoch

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

@@ -15,10 +15,12 @@ import Prelude
 
 import Cardano.DB.Sqlite
     ( DBLog (..) )
+import Cardano.Pool.DB.Log
+    ( PoolDbLog (..) )
 import Cardano.Pool.DB.Properties
     ( newMemoryDBLayer, properties, withDB )
 import Cardano.Pool.DB.Sqlite
-    ( PoolDbLog (..), withDBLayer )
+    ( withDBLayer )
 import Cardano.Wallet.DummyTarget.Primitive.Types
     ( dummyTimeInterpreter )
 import System.Directory

lib/jormungandr/src/Cardano/Wallet/Jormungandr.hs

@@ -61,7 +61,7 @@ import Cardano.DB.Sqlite
     ( DBLog )
 import Cardano.Launcher
     ( ProcessHasExited (..) )
-import Cardano.Pool.DB.Sqlite
+import Cardano.Pool.DB.Log
     ( PoolDbLog )
 import Cardano.Pool.Jormungandr.Metadata
     ( ApiStakePool )

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

@@ -55,7 +55,7 @@ import Cardano.BM.Trace
     ( Trace, appendName )
 import Cardano.DB.Sqlite
     ( DBLog )
-import Cardano.Pool.DB.Sqlite
+import Cardano.Pool.DB.Log
     ( PoolDbLog )
 import Cardano.Pool.Metadata
     ( defaultManagerSettings

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

@@ -325,8 +325,8 @@ combineDbAndLsqData ti nOpt lsqData =
         -> PoolDbData
         -> m Api.ApiStakePool
     mkApiPool pid (PoolLsqData prew pstk psat) dbData = do
-        let mRetiredIn = retiredIn <$> retirementCert dbData
-        retirementEpochInfo <- traverse toApiEpochInfo mRetiredIn
+        let mRetirementEpoch = retirementEpoch <$> retirementCert dbData
+        retirementEpochInfo <- traverse toApiEpochInfo mRetirementEpoch
         pure $ Api.ApiStakePool
             { Api.id = (ApiT pid)
             , Api.metrics = Api.ApiStakePoolMetrics