Validators module

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

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
+    }
+

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))

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)
+

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
+    }
+
+
+
+

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)
+

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)

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"