Validators module

hs-abci-sdk/src/Tendermint/SDK/Modules/Validators.hs

@@ -0,0 +1,26 @@
+module Tendermint.SDK.Modules.Validators (Validators, validatorsModule, 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,50 @@
+module Tendermint.SDK.Modules.Validators.EndBlock where
+
+import           Control.Monad                            (foldM)
+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 <- foldM (\cvks (key, newPower) ->
+      if newPower == 0 then do
+        -- delete from Validators map and key set
+        M.delete key validatorsMap
+        return (Set.delete key cvks)
+      else do
+        -- update power in Validators map and ensure key is in key set
+        M.insert key newPower validatorsMap
+        return (Set.insert key cvks)
+    ) curValKeySet (Map.assocs updatesMap)
+
+  -- 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,94 @@
+{-# 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           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
+  GetValidators :: ValidatorsKeeper m (Map.Map PubKey_ Word64)
+  GetValidatorsKeys :: ValidatorsKeeper m (Set.Set PubKey_)
+  GetPowerOf :: PubKey_ -> ValidatorsKeeper m Word64
+  GetQueuedUpdates :: ValidatorsKeeper m (Map.Map PubKey_ Word64)
+  GetQueuedUpdate :: PubKey_ -> ValidatorsKeeper m (Maybe Word64)
+  QueueUpdate :: PubKey_ -> Word64 -> ValidatorsKeeper m ()
+  QueueUpdates :: [(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
+  GetValidators -> getValidatorsF
+  GetValidatorsKeys -> getValidatorsKeysF
+  GetPowerOf key -> getPowerOfF key
+  GetQueuedUpdates -> getQueuedUpdatesF
+  GetQueuedUpdate key -> getQueuedUpdateF key
+  QueueUpdate key power -> queueUpdateF key power
+  QueueUpdates updates -> queueUpdatesF updates
+  )
+
+getValidatorsF
+  :: Members [ReadStore, Error AppError] r
+  => Sem r (Map.Map PubKey_ Word64)
+getValidatorsF = do
+  keyList <- fmap Set.toList getValidatorsKeysF
+  fmap Map.fromList $ mapM (\k -> fmap (\p -> (k, p)) (getPowerOfF k)) keyList
+
+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{..} ->
+  Map.alter (Just . fromMaybe power) key m) Map.empty updatesList
+
+getQueuedUpdateF
+  :: Members [ReadStore, Error AppError] r
+  => PubKey_
+  -> Sem r (Maybe Word64)
+getQueuedUpdateF key =
+  fmap (Map.lookup key) getQueuedUpdatesF
+
+queueUpdateF
+  :: Members [ReadStore, WriteStore, Error AppError] r
+  => PubKey_
+  -> Word64
+  -> Sem r ()
+queueUpdateF key power =
+  L.append (ValidatorUpdate key power) updatesList
+
+queueUpdatesF
+  :: Members [ReadStore, WriteStore, Error AppError] r
+  => [(PubKey_, Word64)]
+  -> Sem r ()
+queueUpdatesF = mapM_ $ uncurry queueUpdateF
+

hs-abci-sdk/src/Tendermint/SDK/Modules/Validators/Query.hs

@@ -0,0 +1,51 @@
+module Tendermint.SDK.Modules.Validators.Query where
+
+import qualified Data.Map.Strict                          as Map
+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
+  vs <- Keeper.getValidators
+  pure $ QueryResult
+    { queryResultData = vs
+    , queryResultIndex = 0
+    , queryResultKey = ""
+    , queryResultProof = Nothing
+    , queryResultHeight = 0
+    }
+
+
+
+

hs-abci-sdk/src/Tendermint/SDK/Modules/Validators/Store.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Tendermint.SDK.Modules.Validators.Store 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,55 @@
+module Tendermint.SDK.Modules.Validators.Types where
+
+import           Control.Lens                           (iso)
+import qualified Data.Aeson                             as A
+import           Data.ByteString                        (ByteString)
+import           Data.ByteString.Lazy                   (toStrict)
+import           Data.Maybe                             (fromJust)
+import           Data.Set                               (Set)
+import           Data.Word                              (Word64)
+import           GHC.Generics                           (Generic)
+import           Network.ABCI.Types.Messages.FieldTypes (PubKey)
+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"
+
+
+data ValidatorUpdate = ValidatorUpdate
+    { key   :: PubKey_
+    , power :: Word64
+    }
+    deriving Generic
+instance A.ToJSON ValidatorUpdate
+instance A.FromJSON ValidatorUpdate
+instance HasCodec ValidatorUpdate where
+  encode = toStrict . A.encode
+  decode s = maybe (Left "failure to decode ValidatorUpdate") Right (A.decodeStrict s)
+
+
+newtype PubKey_ = PubKey_ PubKey deriving (Eq, Ord, Generic)
+instance A.ToJSON PubKey_
+instance A.FromJSON PubKey_
+instance RawKey PubKey_ where
+  rawKey = iso (\(PubKey_ p) -> (toStrict . A.encode) p) (PubKey_ . fromJust . A.decodeStrict)
+
+
+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"