Skip to content

Commit

Permalink
Try #2249:
Browse files Browse the repository at this point in the history
  • Loading branch information
iohk-bors[bot] authored Oct 17, 2020
2 parents 05e59a0 + 9147481 commit e57ccf7
Show file tree
Hide file tree
Showing 29 changed files with 8,417 additions and 260 deletions.
Original file line number Diff line number Diff line change
Expand Up @@ -881,24 +881,28 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
, name = "Genesis Pool A"
, description = Nothing
, homepage = "https://iohk.io"
, delisted = False
}
, StakePoolMetadata
{ ticker = (StakePoolTicker "GPB")
, name = "Genesis Pool B"
, description = Nothing
, homepage = "https://iohk.io"
, delisted = False
}
, StakePoolMetadata
{ ticker = (StakePoolTicker "GPC")
, name = "Genesis Pool C"
, description = Just "Lorem Ipsum Dolor Sit Amet."
, homepage = "https://iohk.io"
, delisted = False
}
, StakePoolMetadata
{ ticker = (StakePoolTicker "GPD")
, name = "Genesis Pool D"
, description = Just "Lorem Ipsum Dolor Sit Amet."
, homepage = "https://iohk.io"
, delisted = False
}
]

Expand Down
1 change: 1 addition & 0 deletions lib/core/cardano-wallet-core.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -90,6 +90,7 @@ library
, statistics
, stm
, streaming-commons
, string-interpolate
, string-qq
, template-haskell
, text
Expand Down
16 changes: 16 additions & 0 deletions lib/core/src/Cardano/Pool/DB.hs
Original file line number Diff line number Diff line change
Expand Up @@ -49,6 +49,8 @@ import Data.Map.Strict
( Map )
import Data.Quantity
( Quantity (..) )
import Data.Time.Clock.POSIX
( POSIXTime )
import Data.Word
( Word64 )
import System.Random
Expand Down Expand Up @@ -211,6 +213,11 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
-> stm ()
-- ^ Remove all entries of slot ids newer than the argument

, delistPools
:: [PoolId]
-> stm ()
-- ^ Mark pools as delisted
--
, removePools
:: [PoolId]
-> stm ()
Expand Down Expand Up @@ -249,6 +256,15 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
-> stm ()
-- ^ Modify the settings.

, readLastMetadataGC
:: stm POSIXTime
-- ^ Get the last metadata GC time.

, putLastMetadataGC
:: POSIXTime
-> stm ()
-- ^ Set the last metadata GC time.
--
, cleanDB
:: stm ()
-- ^ Clean a database
Expand Down
11 changes: 11 additions & 0 deletions lib/core/src/Cardano/Pool/DB/MVar.hs
Original file line number Diff line number Diff line change
Expand Up @@ -26,19 +26,22 @@ import Cardano.Pool.DB.Model
, emptyPoolDatabase
, mCleanDatabase
, mCleanPoolMetadata
, mDelistPools
, mListHeaders
, mListPoolLifeCycleData
, mListRegisteredPools
, mListRetiredPools
, mPutFetchAttempt
, mPutHeader
, mPutLastMetadataGC
, mPutPoolMetadata
, mPutPoolProduction
, mPutPoolRegistration
, mPutPoolRetirement
, mPutSettings
, mPutStakeDistribution
, mReadCursor
, mReadLastMetadataGC
, mReadPoolLifeCycleStatus
, mReadPoolMetadata
, mReadPoolProduction
Expand Down Expand Up @@ -146,6 +149,9 @@ newDBLayer timeInterpreter = do
rollbackTo =
void . alterPoolDB (const Nothing) db . mRollbackTo timeInterpreter

delistPools =
void . alterPoolDB (const Nothing) db . mDelistPools

removePools =
void . alterPoolDB (const Nothing) db . mRemovePools

Expand All @@ -165,6 +171,11 @@ newDBLayer timeInterpreter = do
putSettings =
void . alterPoolDB (const Nothing) db . mPutSettings

readLastMetadataGC = readPoolDB db mReadLastMetadataGC

putLastMetadataGC =
void . alterPoolDB (const Nothing) db . mPutLastMetadataGC

cleanDB =
void $ alterPoolDB (const Nothing) db mCleanDatabase

Expand Down
42 changes: 36 additions & 6 deletions lib/core/src/Cardano/Pool/DB/Model.hs
Original file line number Diff line number Diff line change
Expand Up @@ -16,6 +16,11 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}

-- `const` isn't more readable than lambdas. Our language is based on
-- lambda calculus and we shouldn't feel ashamed to use them. They also
-- have different strictness properties.
{-# HLINT ignore "Use const" #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
Expand Down Expand Up @@ -60,9 +65,12 @@ module Cardano.Pool.DB.Model
, mRollbackTo
, mReadCursor
, mRemovePools
, mDelistPools
, mRemoveRetiredPools
, mReadSettings
, mPutSettings
, mPutLastMetadataGC
, mReadLastMetadataGC
) where

import Prelude
Expand All @@ -75,18 +83,22 @@ import Cardano.Wallet.Primitive.Types
( BlockHeader (..)
, CertificatePublicationTime
, EpochNo (..)
, InternalState (..)
, PoolId
, PoolLifeCycleStatus (..)
, PoolOwner (..)
, PoolRegistrationCertificate (..)
, PoolRetirementCertificate (..)
, Settings
, SlotNo (..)
, StakePoolMetadata
, StakePoolMetadata (..)
, StakePoolMetadataHash
, StakePoolMetadataUrl
, defaultInternalState
, defaultSettings
)
import Control.Monad
( forM_ )
import Control.Monad.Trans.Class
( lift )
import Control.Monad.Trans.State.Strict
Expand All @@ -109,6 +121,8 @@ import Data.Ord
( Down (..) )
import Data.Quantity
( Quantity (..) )
import Data.Time.Clock.POSIX
( POSIXTime )
import Data.Word
( Word64 )
import GHC.Generics
Expand Down Expand Up @@ -156,6 +170,10 @@ data PoolDatabase = PoolDatabase
-- ^ Store headers during syncing

, settings :: Settings

, internalState :: InternalState
-- ^ Various internal states that need to persist across
-- wallet restarts.
} deriving (Generic, Show, Eq)

data SystemSeed
Expand All @@ -173,7 +191,7 @@ instance Eq SystemSeed where
emptyPoolDatabase :: PoolDatabase
emptyPoolDatabase =
PoolDatabase mempty mempty mempty mempty mempty mempty mempty NotSeededYet
mempty defaultSettings
mempty defaultSettings defaultInternalState

{-------------------------------------------------------------------------------
Model Operation Types
Expand Down Expand Up @@ -414,6 +432,13 @@ mRollbackTo ti point = do
| point' <= getPoint point = Just v
| otherwise = Nothing

mDelistPools :: [PoolId] -> ModelOp ()
mDelistPools poolsToDelist =
forM_ poolsToDelist $ \pool -> do
mhash <- (>>= (fmap snd . poolMetadata . snd)) <$> mReadPoolRegistration pool
forM_ mhash $ \hash -> modify #metadata
$ Map.adjust (\m -> m { delisted = True }) hash

mRemovePools :: [PoolId] -> ModelOp ()
mRemovePools poolsToRemove = do
modify #distributions
Expand Down Expand Up @@ -448,15 +473,20 @@ mReadSettings
:: ModelOp Settings
mReadSettings = get #settings

-- `const` isn't more readable than lambdas. Our language is based on
-- lambda calculus and we shouldn't feel ashamed to use them. They also
-- have different strictness properties.
{- HLINT ignore mPutSettings "Use const" -}
mPutSettings
:: Settings
-> ModelOp ()
mPutSettings s = modify #settings (\_ -> s)

mReadLastMetadataGC
:: ModelOp POSIXTime
mReadLastMetadataGC = get (#internalState . #lastMetadataGC)

mPutLastMetadataGC
:: POSIXTime
-> ModelOp ()
mPutLastMetadataGC t = modify (#internalState . #lastMetadataGC) (\_ -> t)

--------------------------------------------------------------------------------
-- Utilities
--------------------------------------------------------------------------------
Expand Down
Loading

0 comments on commit e57ccf7

Please sign in to comment.