diff --git a/hs-abci-sdk/package.yaml b/hs-abci-sdk/package.yaml index e20ec44a..1017256c 100644 --- a/hs-abci-sdk/package.yaml +++ b/hs-abci-sdk/package.yaml @@ -135,6 +135,7 @@ library: - Tendermint.SDK.Crypto - Tendermint.SDK.Modules.Auth - Tendermint.SDK.Modules.Bank + - Tendermint.SDK.Modules.Validators - Tendermint.SDK.Types.Address - Tendermint.SDK.Types.Effects - Tendermint.SDK.Types.Message diff --git a/hs-abci-sdk/src/Tendermint/SDK/Modules/Validators.hs b/hs-abci-sdk/src/Tendermint/SDK/Modules/Validators.hs new file mode 100644 index 00000000..92cc7692 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Modules/Validators.hs @@ -0,0 +1,35 @@ +module Tendermint.SDK.Modules.Validators + ( + Validators + , validatorsModule + + , module Tendermint.SDK.Modules.Validators.Keeper + , module Tendermint.SDK.Modules.Validators.Types + + , endBlock + ) where + + +import Polysemy (Members) +import Tendermint.SDK.Application (Module (..), + ModuleEffs) +import Tendermint.SDK.BaseApp (EmptyTxServer (..)) +import Tendermint.SDK.Modules.Validators.EndBlock +import Tendermint.SDK.Modules.Validators.Keeper +import Tendermint.SDK.Modules.Validators.Query +import Tendermint.SDK.Modules.Validators.Types + + +type Validators = Module ValidatorsName EmptyTxServer EmptyTxServer QueryApi ValidatorsEffs '[] + +validatorsModule :: + Members (ModuleEffs Validators) r => + Validators r +validatorsModule = + Module + { moduleTxDeliverer = EmptyTxServer, + moduleTxChecker = EmptyTxServer, + moduleQuerier = querier, + moduleEval = eval + } + diff --git a/hs-abci-sdk/src/Tendermint/SDK/Modules/Validators/EndBlock.hs b/hs-abci-sdk/src/Tendermint/SDK/Modules/Validators/EndBlock.hs new file mode 100644 index 00000000..83830d90 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Modules/Validators/EndBlock.hs @@ -0,0 +1,52 @@ +module Tendermint.SDK.Modules.Validators.EndBlock where + +import Control.Monad.State (MonadTrans (lift), + execStateT, forM_, + modify) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Network.ABCI.Types.Messages.FieldTypes as ABCI +import qualified Network.ABCI.Types.Messages.Request as Request +import Polysemy (Members, Sem) +import Tendermint.SDK.BaseApp (BlockEffs, + EndBlockResult (..)) +import qualified Tendermint.SDK.BaseApp.Store.List as L +import qualified Tendermint.SDK.BaseApp.Store.Map as M +import qualified Tendermint.SDK.BaseApp.Store.Var as V +import Tendermint.SDK.Modules.Validators.Keeper +import Tendermint.SDK.Modules.Validators.Store +import Tendermint.SDK.Modules.Validators.Types + + +endBlock + :: Members BlockEffs r + => Members ValidatorsEffs r + => Request.EndBlock + -> Sem r EndBlockResult +endBlock _ = do + updatesMap <- getQueuedUpdates + curValKeySet <- getValidatorsKeys + + -- update the Validators map and key set + newValKeySet <- flip execStateT curValKeySet $ + forM_ (Map.toList updatesMap) $ \(key, newPower) -> + if newPower == 0 then do + -- delete from Validators map and key set + lift $ M.delete key validatorsMap + modify $ Set.delete key + else do + -- update power in Validators map and ensure key is in key set + lift $ M.insert key newPower validatorsMap + modify $ Set.insert key + + -- store new set of validator keys + V.putVar (KeySet newValKeySet) validatorsKeySet + + -- reset the updatesList to empty + L.deleteWhen (const True) updatesList + + -- return EndBlockResult with validator updates for Tendermint + pure $ EndBlockResult (map convertToValUp (Map.assocs updatesMap)) Nothing + where + convertToValUp (PubKey_ key, power) = + ABCI.ValidatorUpdate (Just key) (ABCI.WrappedVal (fromIntegral power)) diff --git a/hs-abci-sdk/src/Tendermint/SDK/Modules/Validators/Keeper.hs b/hs-abci-sdk/src/Tendermint/SDK/Modules/Validators/Keeper.hs new file mode 100644 index 00000000..d64e26bf --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Modules/Validators/Keeper.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Tendermint.SDK.Modules.Validators.Keeper where + +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import qualified Data.Set as Set +import Data.Word (Word64) +import Network.ABCI.Types.Messages.FieldTypes +import Polysemy (Members, Sem, + interpret, makeSem) +import Polysemy.Error (Error) +import Tendermint.SDK.BaseApp (AppError, ReadStore, + WriteStore) +import qualified Tendermint.SDK.BaseApp.Store.List as L +import qualified Tendermint.SDK.BaseApp.Store.Map as M +import qualified Tendermint.SDK.BaseApp.Store.Var as V +import Tendermint.SDK.Modules.Validators.Store +import Tendermint.SDK.Modules.Validators.Types + + +data ValidatorsKeeper m a where + GetValidatorsKeys :: ValidatorsKeeper m (Set.Set PubKey_) + GetPowerOf :: PubKey_ -> ValidatorsKeeper m Word64 + GetQueuedUpdates :: ValidatorsKeeper m (Map.Map PubKey_ Word64) + QueueUpdate :: PubKey_ -> Word64 -> ValidatorsKeeper m () + +makeSem ''ValidatorsKeeper + +type ValidatorsEffs = '[ValidatorsKeeper] + +eval + :: Members [ReadStore, WriteStore, Error AppError] r + => Sem (ValidatorsKeeper : r) a + -> Sem r a +eval = interpret (\case + GetValidatorsKeys -> getValidatorsKeysF + GetPowerOf key -> getPowerOfF key + GetQueuedUpdates -> getQueuedUpdatesF + QueueUpdate key power -> queueUpdateF key power + ) + +getValidatorsKeysF + :: Members [ReadStore, Error AppError] r + => Sem r (Set.Set PubKey_) +getValidatorsKeysF = + fmap (maybe Set.empty (\(KeySet x) -> x)) $ V.takeVar validatorsKeySet + +getPowerOfF + :: Members [ReadStore, Error AppError] r + => PubKey_ + -> Sem r Word64 +getPowerOfF key = + fmap (fromMaybe 0) $ M.lookup key validatorsMap + +getQueuedUpdatesF + :: Members [ReadStore, Error AppError] r + => Sem r (Map.Map PubKey_ Word64) +getQueuedUpdatesF = L.foldl (\m (ValidatorUpdate_ ValidatorUpdate{..}) -> + Map.alter (Just . fromMaybe (toWord validatorUpdatePower)) (toPK_ validatorUpdatePubKey) m) Map.empty updatesList + where + toWord (WrappedVal x) = fromIntegral x + toPK_ = PubKey_ . fromMaybe (error "Bad ValidatorUpdate with Nothing PubKey found in queued updates") + +queueUpdateF + :: Members [ReadStore, WriteStore, Error AppError] r + => PubKey_ + -> Word64 + -> Sem r () +queueUpdateF (PubKey_ key) power = + L.append (ValidatorUpdate_(ValidatorUpdate (Just key) (wrapInt power))) updatesList + where + wrapInt p = WrappedVal (fromIntegral p) + diff --git a/hs-abci-sdk/src/Tendermint/SDK/Modules/Validators/Query.hs b/hs-abci-sdk/src/Tendermint/SDK/Modules/Validators/Query.hs new file mode 100644 index 00000000..0ba31457 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Modules/Validators/Query.hs @@ -0,0 +1,57 @@ +module Tendermint.SDK.Modules.Validators.Query + ( + querier + , QueryApi + )where + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.Word (Word64) +import Polysemy (Members, Sem) +import Servant.API +import Tendermint.SDK.BaseApp +import qualified Tendermint.SDK.BaseApp.Store.Map as M +import qualified Tendermint.SDK.BaseApp.Store.Var as V +import qualified Tendermint.SDK.Modules.Validators.Keeper as Keeper +import Tendermint.SDK.Modules.Validators.Store +import Tendermint.SDK.Modules.Validators.Types + +type QueryApi = GetPowerOf :<|> GetValidatorsKeys :<|> GetValidators + +querier + :: Members QueryEffs r + => Members Keeper.ValidatorsEffs r + => RouteQ QueryApi r +querier = + getPowerOfQuery :<|> getValidatorsKeys :<|> getValidators + +type GetPowerOf = "powerOf" :> StoreLeaf (M.Map PubKey_ Word64) +getPowerOfQuery + :: Members QueryEffs r + => RouteQ GetPowerOf r +getPowerOfQuery = storeQueryHandler validatorsMap + +type GetValidatorsKeys = "validatorsKeys" :> StoreLeaf (V.Var KeySet) +getValidatorsKeys + :: Members QueryEffs r + => RouteQ GetValidatorsKeys r +getValidatorsKeys = storeQueryHandler validatorsKeySet + +type GetValidators = "validators" :> Leaf (Map.Map PubKey_ Word64) +getValidators + :: Members Keeper.ValidatorsEffs r + => Sem r (QueryResult (Map.Map PubKey_ Word64)) +getValidators = do + keyList <- fmap Set.toList Keeper.getValidatorsKeys + vs <- fmap Map.fromList $ mapM (\k -> fmap (\p -> (k, p)) (Keeper.getPowerOf k)) keyList + pure $ QueryResult + { queryResultData = vs + , queryResultIndex = 0 + , queryResultKey = "" + , queryResultProof = Nothing + , queryResultHeight = 0 + } + + + + diff --git a/hs-abci-sdk/src/Tendermint/SDK/Modules/Validators/Store.hs b/hs-abci-sdk/src/Tendermint/SDK/Modules/Validators/Store.hs new file mode 100644 index 00000000..3936dc62 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Modules/Validators/Store.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Tendermint.SDK.Modules.Validators.Store + ( + updatesList + , validatorsMap + , validatorsKeySet + ) where + +import Data.Word (Word64) +import Tendermint.SDK.BaseApp (KeyRoot (..), Store, + makeStore) +import qualified Tendermint.SDK.BaseApp.Store.List as L +import qualified Tendermint.SDK.BaseApp.Store.Map as M +import Tendermint.SDK.BaseApp.Store.TH (makeSubStore) +import qualified Tendermint.SDK.BaseApp.Store.Var as V +import Tendermint.SDK.Modules.Validators.Types + + +store :: Store ValidatorsNameSpace +store = makeStore $ KeyRoot "validators" + +$(makeSubStore 'store "updatesList" [t|L.List ValidatorUpdate_|] updatesListKey) + +$(makeSubStore 'store "validatorsMap" [t|M.Map PubKey_ Word64|] validatorsMapKey) + +$(makeSubStore 'store "validatorsKeySet" [t|V.Var KeySet|] validatorsKeySetKey) + diff --git a/hs-abci-sdk/src/Tendermint/SDK/Modules/Validators/Types.hs b/hs-abci-sdk/src/Tendermint/SDK/Modules/Validators/Types.hs new file mode 100644 index 00000000..f77fdea8 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Modules/Validators/Types.hs @@ -0,0 +1,59 @@ +module Tendermint.SDK.Modules.Validators.Types where + +import Control.Lens (Wrapped (_Wrapped'), + iso, (^.), _Unwrapped') +import qualified Data.Aeson as A +import Data.Bifunctor (Bifunctor (bimap, second)) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy (toStrict) +import Data.Either (fromRight) +import Data.ProtoLens (decodeMessage, + encodeMessage) +import Data.Set (Set) +import Data.String.Conversions (cs) +import GHC.Generics (Generic) +import Network.ABCI.Types.Messages.FieldTypes (PubKey (PubKey), + ValidatorUpdate) +import Tendermint.SDK.BaseApp (RawKey (..)) +import Tendermint.SDK.Codec (HasCodec (..)) + + +data ValidatorsNameSpace + +type ValidatorsName = "validators" + + +updatesListKey :: ByteString +updatesListKey = "updatesList" + +validatorsMapKey :: ByteString +validatorsMapKey = "validatorsMap" + +validatorsKeySetKey :: ByteString +validatorsKeySetKey = "validatorsKeySet" + + +newtype ValidatorUpdate_ = ValidatorUpdate_ ValidatorUpdate deriving (Eq, Generic) + +instance HasCodec ValidatorUpdate_ where + encode (ValidatorUpdate_ vu) = encodeMessage $ (vu ^. _Wrapped') + decode bs = bimap cs (ValidatorUpdate_ . (^. _Unwrapped')) $ decodeMessage bs + +newtype PubKey_ = PubKey_ PubKey deriving (Eq, Ord, Generic) + +instance RawKey PubKey_ where + rawKey = iso t f + where + t (PubKey_ p) = encodeMessage $ (p ^. _Wrapped') + f = PubKey_ . fromRight (PubKey "" "") . second (^. _Unwrapped') . decodeMessage + + +instance A.ToJSON PubKey_ +instance A.FromJSON PubKey_ + +newtype KeySet = KeySet (Set PubKey_) deriving Generic +instance A.ToJSON KeySet +instance A.FromJSON KeySet +instance HasCodec KeySet where + encode = toStrict . A.encode + decode s = maybe (Left "failure to decode KeySet") Right (A.decodeStrict s) diff --git a/hs-abci-types/src/Network/ABCI/Types/Messages/FieldTypes.hs b/hs-abci-types/src/Network/ABCI/Types/Messages/FieldTypes.hs index 8f1d9637..021f3c68 100644 --- a/hs-abci-types/src/Network/ABCI/Types/Messages/FieldTypes.hs +++ b/hs-abci-types/src/Network/ABCI/Types/Messages/FieldTypes.hs @@ -245,7 +245,7 @@ data PubKey = PubKey -- ^ Type of the public key. , pubKeyData :: Base64String -- ^ Public key data. - } deriving (Eq, Show, Generic) + } deriving (Eq, Ord, Show, Generic) instance ToJSON PubKey where toJSON = genericToJSON $ defaultABCIOptions "pubKey"