[CAD-2476] SMASH not returning active pools that were previously reti…

…red.

schema/migration-2-0007-20210114.sql

@@ -0,0 +1,19 @@
+-- Persistent generated migration.
+
+CREATE FUNCTION migrate() RETURNS void AS $$
+DECLARE
+  next_version int ;
+BEGIN
+  SELECT stage_two + 1 INTO next_version FROM schema_version ;
+  IF next_version = 7 THEN
+    ALTER TABLE "retired_pool" ADD COLUMN "block_no" uinteger NOT NULL;
+    -- Hand written SQL statements can be added here.
+    UPDATE schema_version SET stage_two = 7 ;
+    RAISE NOTICE 'DB has been migrated to stage_two version %', next_version ;
+  END IF ;
+END ;
+$$ LANGUAGE plpgsql ;
+
+SELECT migrate() ;
+
+DROP FUNCTION migrate() ;

smash-servant-types/src/Cardano/SMASH/API.hs

@@ -38,7 +38,8 @@ import           Servant.Swagger               (HasSwagger (..))
 import           Cardano.SMASH.DBSync.Db.Error (DBFail (..))
 import           Cardano.SMASH.Types           (ApiResult, HealthStatus,
                                                 PoolFetchError, PoolId (..),
-                                                PoolId, PoolMetadataHash,
+                                                PoolId, PoolIdBlockNumber (..),
+                                                PoolMetadataHash,
                                                 PoolMetadataRaw, TickerName,
                                                 TimeStringFormat, User)
 
@@ -120,7 +121,7 @@ type SmashAPI =  OfflineMetadataAPI
             :<|> AddPoolAPI
             :<|> AddTickerAPI
 
-type RetirePoolAPI = "api" :> APIVersion :> "retired" :> ReqBody '[JSON] PoolId :> ApiRes Patch PoolId
+type RetirePoolAPI = "api" :> APIVersion :> "retired" :> ReqBody '[JSON] PoolIdBlockNumber :> ApiRes Patch PoolId
 type AddPoolAPI = "api" :> APIVersion :> "metadata" :> Capture "id" PoolId :> Capture "hash" PoolMetadataHash :> ReqBody '[OctetStream] PoolMetadataRaw :> ApiRes Post PoolId
 type AddTickerAPI = "api" :> APIVersion :> "tickers" :> Capture "name" TickerName :> ReqBody '[JSON] PoolMetadataHash :> ApiRes Post TickerName
 

smash-servant-types/src/Cardano/SMASH/Types.hs

@@ -11,6 +11,7 @@ module Cardano.SMASH.Types
     , checkIfUserValid
     -- * Pool info
     , PoolId (..)
+    , PoolIdBlockNumber (..)
     , PoolUrl (..)
     , PoolMetadataHash (..)
     , bytestringToPoolMetaHash
@@ -302,6 +303,25 @@ data FetchError
   | FEConnectionFailure !PoolId !Text
   deriving (Eq, Generic)
 
+data PoolIdBlockNumber = PoolIdBlockNumber !PoolId !Word64
+    deriving (Eq, Show, Generic)
+
+instance ToJSON PoolIdBlockNumber where
+    toJSON (PoolIdBlockNumber poolId blockNumber) =
+        object
+            [ "poolId"      .= poolId
+            , "blockNumber" .= blockNumber
+            ]
+
+instance FromJSON PoolIdBlockNumber where
+    parseJSON = withObject "poolIdBlockNumber" $ \o -> do
+        poolId          <- o .: "poolId"
+        blockNumber     <- o .: "blockNumber"
+
+        return $ PoolIdBlockNumber poolId blockNumber
+
+instance ToSchema PoolIdBlockNumber
+
 -- |Fetch error for the specific @PoolId@ and the @PoolMetadataHash@.
 data PoolFetchError = PoolFetchError !Time.POSIXTime !PoolId !PoolMetadataHash !Text !Word
   deriving (Eq, Show, Generic)

smash/src/Cardano/SMASH/DB.hs

@@ -21,7 +21,7 @@ module Cardano.SMASH.DB
 
 import           Cardano.Prelude
 
-import           Cardano.BM.Trace                          (Trace, logInfo)
+import           Cardano.BM.Trace                          (Trace)
 import           Control.Monad.Trans.Except.Extra          (left, newExceptT)
 
 import           Data.IORef                                (IORef, modifyIORef,
@@ -33,7 +33,8 @@ import           Data.Time.Clock.POSIX                     (utcTimeToPOSIXSecond
 import           Cardano.Slotting.Slot                     (SlotNo)
 
 import           Cardano.SMASH.DBSync.Db.Delete            (deleteAdminUser,
-                                                            deleteDelistedPool)
+                                                            deleteDelistedPool,
+                                                            deleteRetiredPool)
 import           Cardano.SMASH.DBSync.Db.Insert            (insertAdminUser,
                                                             insertBlock,
                                                             insertDelistedPool,
@@ -89,8 +90,10 @@ data DataLayer = DataLayer
     , dlAddDelistedPool         :: PoolId -> IO (Either DBFail PoolId)
     , dlRemoveDelistedPool      :: PoolId -> IO (Either DBFail PoolId)
 
-    , dlAddRetiredPool          :: PoolId -> IO (Either DBFail PoolId)
+    , dlAddRetiredPool          :: PoolId -> Word64 -> IO (Either DBFail PoolId)
+    , dlCheckRetiredPool        :: PoolId -> IO (Either DBFail (PoolId, Word64))
     , dlGetRetiredPools         :: IO (Either DBFail [PoolId])
+    , dlRemoveRetiredPool       :: PoolId -> IO (Either DBFail PoolId)
 
     , dlGetAdminUsers           :: IO (Either DBFail [AdminUser])
     , dlAddAdminUser            :: ApplicationUser -> IO (Either DBFail AdminUser)
@@ -150,10 +153,12 @@ stubbedDataLayer ioDataMap (DelistedPoolsIORef ioDelistedPool) (RetiredPoolsIORe
         _ <- modifyIORef ioDelistedPool (\pools -> filter (/= poolId) pools)
         return $ Right poolId
 
-    , dlAddRetiredPool      = \poolId -> do
+    , dlAddRetiredPool      = \poolId _ -> do
         _ <- modifyIORef ioRetiredPools (\pools -> [poolId] ++ pools)
         return . Right $ poolId
+    , dlCheckRetiredPool    = \_ -> panic "!"
     , dlGetRetiredPools     = Right <$> readIORef ioRetiredPools
+    , dlRemoveRetiredPool   = \_ -> panic "!"
 
     , dlGetAdminUsers       = return $ Right []
     , dlAddAdminUser        = \_ -> panic "!"
@@ -246,15 +251,25 @@ postgresqlDataLayer tracer = DataLayer
             then return $ Right poolId
             else return $ Left RecordDoesNotExist
 
-    , dlAddRetiredPool  = \poolId -> do
-        retiredPoolId <- runDbAction tracer $ insertRetiredPool $ RetiredPool poolId
+    , dlAddRetiredPool  = \poolId blockNo -> do
+        retiredPoolId <- runDbAction tracer $ insertRetiredPool $ RetiredPool poolId blockNo
 
         case retiredPoolId of
             Left err  -> return $ Left err
             Right _id -> return $ Right poolId
+    , dlCheckRetiredPool = \poolId -> do
+        retiredPool <- runDbAction tracer $ queryRetiredPool poolId
+        case retiredPool of
+            Left err -> return $ Left err
+            Right retiredPool' -> return $ Right (retiredPoolPoolId retiredPool', retiredPoolBlockNo retiredPool')
     , dlGetRetiredPools = do
         retiredPools <- runDbAction tracer $ queryAllRetiredPools
         return $ Right $ map retiredPoolPoolId retiredPools
+    , dlRemoveRetiredPool = \poolId -> do
+        isDeleted <- runDbAction tracer $ deleteRetiredPool poolId
+        if isDeleted
+            then return $ Right poolId
+            else return $ Left $ UnknownError "Retired pool not deleted!"
 
     , dlGetAdminUsers       = do
         adminUsers <- runDbAction tracer $ queryAdminUsers
@@ -285,9 +300,6 @@ postgresqlDataLayer tracer = DataLayer
             Left err   -> return $ Left err
             Right _val -> return $ Right poolId
     , dlAddPool             = \poolId -> do
-        case tracer of
-            Nothing -> pure ()
-            Just trcr -> logInfo trcr $ "Inserting pool, pool id -'" <> show poolId <> "'."
         poolId' <- runDbAction tracer $ insertPool (Pool poolId)
         case poolId' of
             Left err   -> return $ Left err

smash/src/Cardano/SMASH/DBSync/Db/Delete.hs

@@ -3,6 +3,7 @@
 
 module Cardano.SMASH.DBSync.Db.Delete
   ( deleteDelistedPool
+  , deleteRetiredPool
   , deleteAdminUser
   ) where
 
@@ -25,6 +26,14 @@ deleteDelistedPool poolId = do
   mapM_ deleteCascade keys
   pure $ not (null keys)
 
+-- | Delete a retired pool if it exists. Returns 'True' if it did exist and has been
+-- deleted and 'False' if it did not exist.
+deleteRetiredPool :: MonadIO m => Types.PoolId -> ReaderT SqlBackend m Bool
+deleteRetiredPool poolId = do
+  keys <- selectKeysList [ RetiredPoolPoolId ==. poolId ] []
+  mapM_ deleteCascade keys
+  pure $ not (null keys)
+
 deleteAdminUser :: MonadIO m => AdminUser -> ReaderT SqlBackend m Bool
 deleteAdminUser adminUser = do
   keys <- selectKeysList [ AdminUserUsername ==. adminUserUsername adminUser, AdminUserPassword ==. adminUserPassword adminUser ] []

smash/src/Cardano/SMASH/DBSync/Db/Query.hs

@@ -24,6 +24,7 @@ module Cardano.SMASH.DBSync.Db.Query
   , queryPoolMetadataFetchError
   , queryPoolMetadataFetchErrorByTime
   , queryAllRetiredPools
+  , queryRetiredPool
   ) where
 
 import           Cardano.Prelude                hiding (Meta, from, isJust,
@@ -114,6 +115,14 @@ queryAllRetiredPools = do
   res <- selectList [] []
   pure $ entityVal <$> res
 
+-- |Query retired pools.
+queryRetiredPool :: MonadIO m => Types.PoolId -> ReaderT SqlBackend m (Either DBFail RetiredPool)
+queryRetiredPool poolId = do
+  res <- select . from $ \retiredPools -> do
+            where_ (retiredPools ^. RetiredPoolPoolId ==. val poolId)
+            pure retiredPools
+  pure $ maybeToEither RecordDoesNotExist entityVal (listToMaybe res)
+
 -- | Count the number of blocks in the Block table.
 queryBlockCount :: MonadIO m => ReaderT SqlBackend m Word
 queryBlockCount = do

smash/src/Cardano/SMASH/DBSync/Db/Schema.hs

@@ -85,6 +85,7 @@ share
 
   RetiredPool
     poolId              Types.PoolId              sqltype=text
+    blockNo             Word64                    sqltype=uinteger -- When the pool was retired.
     UniqueRetiredPoolId poolId
 
   -- The pool metadata fetch error. We duplicate the poolId for easy access.

smash/src/Cardano/SMASH/DBSyncPlugin.hs

@@ -141,21 +141,22 @@ insertShelleyBlock blockName dataLayer tracer env blk _lStateSnap details = do
 
   runExceptT $ do
 
+    let blockNumber = Generic.blkBlockNo blk
+
     -- TODO(KS): Move to DataLayer.
     _blkId <- lift . DB.insertBlock $
                   DB.Block
                     { DB.blockHash = Shelley.blkHash blk
                     , DB.blockEpochNo = Just $ unEpochNo (sdEpochNo details)
                     , DB.blockSlotNo = Just $ unSlotNo (Generic.blkSlotNo blk)
-                    , DB.blockBlockNo = Just $ unBlockNo (Generic.blkBlockNo blk)
+                    , DB.blockBlockNo = Just $ unBlockNo blockNumber
                     }
 
-    zipWithM_ (insertTx dataLayer tracer env) [0 .. ] (Shelley.blkTxs blk)
+    zipWithM_ (insertTx dataLayer blockNumber tracer env) [0 .. ] (Shelley.blkTxs blk)
 
     liftIO $ do
       let epoch = unEpochNo (sdEpochNo details)
           slotWithinEpoch = unEpochSlot (sdEpochSlot details)
-          blockNumber = Generic.blkBlockNo blk
 
       when (slotWithinEpoch `mod` 1000 == 0) $
         logInfo tracer $ mconcat
@@ -170,27 +171,29 @@ insertShelleyBlock blockName dataLayer tracer env blk _lStateSnap details = do
 insertTx
     :: (MonadIO m)
     => DataLayer
+    -> BlockNo
     -> Trace IO Text
     -> DbSyncEnv
     -> Word64
     -> Generic.Tx
     -> ExceptT DbSyncNodeError m ()
-insertTx dataLayer tracer env _blockIndex tx =
-    mapM_ (insertCertificate dataLayer tracer env) $ Generic.txCertificates tx
+insertTx dataLayer blockNumber tracer env _blockIndex tx =
+    mapM_ (insertCertificate dataLayer blockNumber tracer env) $ Generic.txCertificates tx
 
 insertCertificate
     :: (MonadIO m)
     => DataLayer
+    -> BlockNo
     -> Trace IO Text
     -> DbSyncEnv
     -> Generic.TxCertificate
     -> ExceptT DbSyncNodeError m ()
-insertCertificate dataLayer tracer _env (Generic.TxCertificate _idx cert) =
+insertCertificate dataLayer blockNumber tracer _env (Generic.TxCertificate _idx cert) =
   case cert of
     Shelley.DCertDeleg _deleg ->
         liftIO $ logInfo tracer "insertCertificate: DCertDeleg"
     Shelley.DCertPool pool ->
-        insertPoolCert dataLayer tracer pool
+        insertPoolCert dataLayer blockNumber tracer pool
     Shelley.DCertMir _mir ->
         liftIO $ logInfo tracer "insertCertificate: DCertMir"
     Shelley.DCertGenesis _gen ->
@@ -199,10 +202,11 @@ insertCertificate dataLayer tracer _env (Generic.TxCertificate _idx cert) =
 insertPoolCert
     :: (MonadIO m)
     => DataLayer
+    -> BlockNo
     -> Trace IO Text
     -> Shelley.PoolCert StandardShelley
     -> ExceptT DbSyncNodeError m ()
-insertPoolCert dataLayer tracer pCert =
+insertPoolCert dataLayer blockNumber tracer pCert =
   case pCert of
     Shelley.RegPool pParams -> do
         let poolIdHash = B16.encode . Generic.unKeyHashRaw $ Shelley._poolId pParams
@@ -216,6 +220,28 @@ insertPoolCert dataLayer tracer pCert =
           Left _err -> liftIO . logInfo tracer $ "Pool already registered with pool id: " <> decodeUtf8 poolIdHash
           Right _pool -> liftIO . logInfo tracer $ "Inserting pool register with pool id: " <> decodeUtf8 poolIdHash
 
+        -- TODO(KS): Check whether the pool is retired, and if yes,
+        -- if the current block number is greater, remove that record.
+        let checkRetiredPool = dlCheckRetiredPool dataLayer
+        retiredPoolId <- liftIO $ checkRetiredPool poolId
+
+        -- This could be chained, revives the pool if it was re-submited when already being retired.
+        case retiredPoolId of
+            Left _err -> liftIO . logInfo tracer $ "Pool not retired: " <> decodeUtf8 poolIdHash
+            Right (poolId', retiredPoolBlockNo) ->
+                -- This is a superfluous check, like this word, but could be relevent in some cases.
+                if (retiredPoolBlockNo > unBlockNo blockNumber)
+                    then liftIO . logInfo tracer $ "Pool retired after this block, not reviving: " <> decodeUtf8 poolIdHash
+                    else do
+                        -- REVIVE retired pool
+                        let removeRetiredPool = dlRemoveRetiredPool dataLayer
+                        removedPoolId <- liftIO $ removeRetiredPool poolId'
+
+                        case removedPoolId of
+                            Left err -> liftIO . logInfo tracer $ "Pool retired, not revived. " <> show err
+                            Right removedPoolId' -> liftIO . logInfo tracer $ "Pool retired, revived: " <> show removedPoolId'
+
+        -- Finally, insert the metadata!
         insertPoolRegister dataLayer tracer pParams
 
     -- RetirePool (KeyHash 'StakePool era) _ = PoolId
@@ -227,7 +253,7 @@ insertPoolCert dataLayer tracer pCert =
 
         let addRetiredPool = dlAddRetiredPool dataLayer
 
-        eitherPoolId <- liftIO $ addRetiredPool poolId
+        eitherPoolId <- liftIO $ addRetiredPool poolId (unBlockNo blockNumber)
 
         case eitherPoolId of
             Left err -> liftIO . logError tracer $ "Error adding retiring pool: " <> show err

smash/src/Cardano/SMASH/Lib.hs

@@ -19,7 +19,8 @@ module Cardano.SMASH.Lib
     ) where
 
 #ifdef TESTING_MODE
-import           Cardano.SMASH.Types         (TickerName, pomTicker)
+import           Cardano.SMASH.Types         (PoolIdBlockNumber (..), TickerName,
+                                              pomTicker)
 import           Data.Aeson                  (eitherDecode')
 import qualified Data.ByteString.Lazy        as BL
 #endif
@@ -351,11 +352,11 @@ checkPool dataLayer poolId = convertIOToHandler $ do
 
 
 #ifdef TESTING_MODE
-retirePool :: DataLayer -> PoolId -> Handler (ApiResult DBFail PoolId)
-retirePool dataLayer poolId = convertIOToHandler $ do
+retirePool :: DataLayer -> PoolIdBlockNumber -> Handler (ApiResult DBFail PoolId)
+retirePool dataLayer (PoolIdBlockNumber poolId blockNo) = convertIOToHandler $ do
 
     let addRetiredPool = dlAddRetiredPool dataLayer
-    retiredPoolId <- addRetiredPool poolId
+    retiredPoolId <- addRetiredPool poolId blockNo
 
     return . ApiResult $ retiredPoolId
 

smash/test/MigrationSpec.hs

@@ -97,7 +97,7 @@ migrationTest = do
 
     -- TODO(KS): This version HAS to be changed manually so we don't mess up the
     -- migration.
-    let expected = SchemaVersion 1 6 0
+    let expected = SchemaVersion 1 7 0
     actual <- getDbSchemaVersion
     unless (expected == actual) $
         panic $ mconcat

smash/test/SmashSpec.hs

@@ -48,7 +48,7 @@ smashSpec = do
                 assert $ isDelisted
 
         describe "Fetch errors" $
-            prop "adding a fetch error adds it to the data layer" $ monadicIO $ do
+            prop "adding a fetch error adds it to the data layer" $ \(blockNo) -> monadicIO $ do
 
                 (pk, _) <- run $ createKeypair
 
@@ -58,7 +58,7 @@ smashSpec = do
                 dataLayer <- run createStubbedDataLayer
 
                 let addRetiredPool = dlAddRetiredPool dataLayer
-                retiredPoolId <- run $ addRetiredPool newPoolId
+                retiredPoolId <- run $ addRetiredPool newPoolId blockNo
 
                 let getRetiredPools = dlGetRetiredPools dataLayer
                 retiredPoolsId <- run $ getRetiredPools