From 46104c079eb2e00cc859ae37837832995d8b7d17 Mon Sep 17 00:00:00 2001 From: Luke Nadur Date: Wed, 1 Aug 2018 17:58:21 -0500 Subject: [PATCH 1/2] [CDEC-484] Reunite orphans from Pos.Chain.Ssc.Toss.Trans --- chain/cardano-sl-chain.cabal | 1 - chain/src/Pos/Chain/Ssc/Toss.hs | 3 - chain/src/Pos/Chain/Ssc/Toss/Trans.hs | 97 ----------------------- chain/src/Pos/Chain/Ssc/Toss/Types.hs | 107 ++++++++++++++++++++++---- 4 files changed, 94 insertions(+), 114 deletions(-) delete mode 100644 chain/src/Pos/Chain/Ssc/Toss/Trans.hs diff --git a/chain/cardano-sl-chain.cabal b/chain/cardano-sl-chain.cabal index 69268d59280..52a8f9a95a8 100644 --- a/chain/cardano-sl-chain.cabal +++ b/chain/cardano-sl-chain.cabal @@ -86,7 +86,6 @@ library Pos.Chain.Ssc.Toss.Pure Pos.Chain.Ssc.Toss.Base Pos.Chain.Ssc.Toss.Class - Pos.Chain.Ssc.Toss.Trans Pos.Chain.Ssc.Toss.Types Pos.Chain.Update.BlockVersion diff --git a/chain/src/Pos/Chain/Ssc/Toss.hs b/chain/src/Pos/Chain/Ssc/Toss.hs index ebe557ccf04..e06300c0195 100644 --- a/chain/src/Pos/Chain/Ssc/Toss.hs +++ b/chain/src/Pos/Chain/Ssc/Toss.hs @@ -4,7 +4,6 @@ module Pos.Chain.Ssc.Toss , module Pos.Chain.Ssc.Toss.Class , module Pos.Chain.Ssc.Toss.Logic , module Pos.Chain.Ssc.Toss.Pure - , module Pos.Chain.Ssc.Toss.Trans , module Pos.Chain.Ssc.Toss.Types ) where @@ -12,6 +11,4 @@ import Pos.Chain.Ssc.Toss.Base import Pos.Chain.Ssc.Toss.Class import Pos.Chain.Ssc.Toss.Logic import Pos.Chain.Ssc.Toss.Pure -import Pos.Chain.Ssc.Toss.Trans import Pos.Chain.Ssc.Toss.Types - diff --git a/chain/src/Pos/Chain/Ssc/Toss/Trans.hs b/chain/src/Pos/Chain/Ssc/Toss/Trans.hs deleted file mode 100644 index 1cbac820fe8..00000000000 --- a/chain/src/Pos/Chain/Ssc/Toss/Trans.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | TossT monad transformer. Single-threaded. - -module Pos.Chain.Ssc.Toss.Trans - ( TossT - , runTossT - , evalTossT - , execTossT - ) where - -import Universum hiding (id) - -import Control.Lens (at, (%=), (.=)) -import qualified Ether - -import Pos.Chain.Ssc.Base (deleteSignedCommitment, - insertSignedCommitment) -import Pos.Chain.Ssc.Toss.Class (MonadToss (..), MonadTossEnv (..), - MonadTossRead (..)) -import Pos.Chain.Ssc.Toss.Types (TossModifier (..), tmCertificates, - tmCommitments, tmOpenings, tmShares) -import Pos.Core.Ssc (insertVss) -import Pos.Util.Util (ether) - ----------------------------------------------------------------------------- --- Tranformer ----------------------------------------------------------------------------- - --- | Monad transformer which stores TossModifier and implements --- writable MonadToss. --- --- [WARNING] This transformer uses StateT and is intended for --- single-threaded usage only. -type TossT = Ether.StateT' TossModifier - ----------------------------------------------------------------------------- --- Runners ----------------------------------------------------------------------------- - -runTossT :: TossModifier -> TossT m a -> m (a, TossModifier) -runTossT = flip Ether.runStateT - -evalTossT :: Monad m => TossModifier -> TossT m a -> m a -evalTossT = flip Ether.evalStateT - -execTossT :: Monad m => TossModifier -> TossT m a -> m TossModifier -execTossT = flip Ether.execStateT - ----------------------------------------------------------------------------- --- MonadToss ----------------------------------------------------------------------------- - -instance MonadTossRead m => - MonadTossRead (TossT m) where - getCommitments = ether $ (<>) <$> use tmCommitments <*> getCommitments - getOpenings = ether $ (<>) <$> use tmOpenings <*> getOpenings - getShares = ether $ (<>) <$> use tmShares <*> getShares - getVssCertificates = ether $ (<>) <$> use tmCertificates <*> getVssCertificates - getStableCertificates = ether . getStableCertificates - -instance MonadTossEnv m => - MonadTossEnv (TossT m) where - getRichmen = ether . getRichmen - getAdoptedBVData = ether getAdoptedBVData - -instance MonadToss m => - MonadToss (TossT m) where - putCommitment signedComm = - ether $ tmCommitments %= insertSignedCommitment signedComm - putOpening id op = - ether $ tmOpenings . at id .= Just op - putShares id sh = - ether $ tmShares . at id .= Just sh - -- NB. 'insertVss' might delete some certs from the map, but it - -- shouldn't actually happen in practice because - -- 'checkCertificatesPayload' ensures that there are no clashes between - -- the certificates in blocks and certificates in the map - putCertificate cert = - ether $ tmCertificates %= fst . insertVss cert - delCommitment id = - ether $ tmCommitments %= deleteSignedCommitment id - delOpening id = - ether $ tmOpenings . at id .= Nothing - delShares id = - ether $ tmShares . at id .= Nothing - resetCO = ether $ do - tmCommitments .= mempty - tmOpenings .= mempty - tmCertificates .= mempty - resetCO - resetShares = ether $ do - tmShares .= mempty - resetShares - setEpochOrSlot = ether . setEpochOrSlot diff --git a/chain/src/Pos/Chain/Ssc/Toss/Types.hs b/chain/src/Pos/Chain/Ssc/Toss/Types.hs index 2a7931bf01d..4935c691e63 100644 --- a/chain/src/Pos/Chain/Ssc/Toss/Types.hs +++ b/chain/src/Pos/Chain/Ssc/Toss/Types.hs @@ -10,20 +10,30 @@ module Pos.Chain.Ssc.Toss.Types , tmOpenings , tmShares , tmCertificates + + , TossT + , runTossT + , evalTossT + , execTossT ) where -import Control.Lens (makeLenses) +import Universum hiding (id) + +import Control.Lens (at, makeLenses, (%=), (.=)) +import qualified Ether import qualified Formatting.Buildable as Buildable -import Universum import Pos.Binary.Class (Cons (..), Field (..), deriveSimpleBi, deriveSimpleBiCxt) -import Pos.Chain.Ssc.Base (isCommitmentId, isCommitmentIdx, +import Pos.Chain.Ssc.Base (deleteSignedCommitment, + insertSignedCommitment, isCommitmentId, isCommitmentIdx, isOpeningId, isOpeningIdx, isSharesId, isSharesIdx) +import Pos.Chain.Ssc.Toss.Class (MonadToss (..), MonadTossEnv (..), + MonadTossRead (..)) import Pos.Core (HasProtocolConstants, LocalSlotIndex, SlotId) import Pos.Core.Ssc (CommitmentsMap, OpeningsMap, SharesMap, - VssCertificatesMap) -import Pos.Util.Util (cborError) + VssCertificatesMap, insertVss) +import Pos.Util.Util (cborError, ether) -- | Tag corresponding to SSC data. data SscTag @@ -39,12 +49,6 @@ instance Buildable SscTag where build SharesMsg = "shares" build VssCertificateMsg = "VSS certificate" -deriveSimpleBi ''SscTag [ - Cons 'CommitmentMsg [], - Cons 'OpeningMsg [], - Cons 'SharesMsg [], - Cons 'VssCertificateMsg []] - isGoodSlotForTag :: HasProtocolConstants => SscTag -> LocalSlotIndex -> Bool isGoodSlotForTag CommitmentMsg = isCommitmentIdx isGoodSlotForTag OpeningMsg = isOpeningIdx @@ -64,8 +68,6 @@ data TossModifier = TossModifier , _tmCertificates :: !VssCertificatesMap } deriving (Generic, Show, Eq) -makeLenses ''TossModifier - instance Semigroup TossModifier where (TossModifier leftComms leftOpens leftShares leftCerts) <> (TossModifier rightComms rightOpens rightShares rightCerts) = @@ -80,6 +82,79 @@ instance Monoid TossModifier where mempty = TossModifier mempty mempty mempty mempty mappend = (<>) +---------------------------------------------------------------------------- +-- Tranformer +---------------------------------------------------------------------------- + +-- | Monad transformer which stores TossModifier and implements +-- writable MonadToss. +-- +-- [WARNING] This transformer uses StateT and is intended for +-- single-threaded usage only. +type TossT = Ether.StateT' TossModifier + +---------------------------------------------------------------------------- +-- Runners +---------------------------------------------------------------------------- + +runTossT :: TossModifier -> TossT m a -> m (a, TossModifier) +runTossT = flip Ether.runStateT + +evalTossT :: Monad m => TossModifier -> TossT m a -> m a +evalTossT = flip Ether.evalStateT + +execTossT :: Monad m => TossModifier -> TossT m a -> m TossModifier +execTossT = flip Ether.execStateT + +---------------------------------------------------------------------------- +-- MonadToss +---------------------------------------------------------------------------- + +makeLenses ''TossModifier + +instance MonadTossRead m => + MonadTossRead (TossT m) where + getCommitments = ether $ (<>) <$> use tmCommitments <*> getCommitments + getOpenings = ether $ (<>) <$> use tmOpenings <*> getOpenings + getShares = ether $ (<>) <$> use tmShares <*> getShares + getVssCertificates = ether $ (<>) <$> use tmCertificates <*> getVssCertificates + getStableCertificates = ether . getStableCertificates + +instance MonadTossEnv m => + MonadTossEnv (TossT m) where + getRichmen = ether . getRichmen + getAdoptedBVData = ether getAdoptedBVData + +instance MonadToss m => + MonadToss (TossT m) where + putCommitment signedComm = + ether $ tmCommitments %= insertSignedCommitment signedComm + putOpening id op = + ether $ tmOpenings . at id .= Just op + putShares id sh = + ether $ tmShares . at id .= Just sh + -- NB. 'insertVss' might delete some certs from the map, but it + -- shouldn't actually happen in practice because + -- 'checkCertificatesPayload' ensures that there are no clashes between + -- the certificates in blocks and certificates in the map + putCertificate cert = + ether $ tmCertificates %= fst . insertVss cert + delCommitment id = + ether $ tmCommitments %= deleteSignedCommitment id + delOpening id = + ether $ tmOpenings . at id .= Nothing + delShares id = + ether $ tmShares . at id .= Nothing + resetCO = ether $ do + tmCommitments .= mempty + tmOpenings .= mempty + tmCertificates .= mempty + resetCO + resetShares = ether $ do + tmShares .= mempty + resetShares + setEpochOrSlot = ether . setEpochOrSlot + deriveSimpleBiCxt [t|()|] ''TossModifier [ Cons 'TossModifier [ Field [| _tmCommitments :: CommitmentsMap |], @@ -87,3 +162,9 @@ deriveSimpleBiCxt [t|()|] ''TossModifier [ Field [| _tmShares :: SharesMap |], Field [| _tmCertificates :: VssCertificatesMap |] ]] + +deriveSimpleBi ''SscTag [ + Cons 'CommitmentMsg [], + Cons 'OpeningMsg [], + Cons 'SharesMsg [], + Cons 'VssCertificateMsg []] From a6036e099d84ef06994a70f46bbe69f68b7c38be Mon Sep 17 00:00:00 2001 From: Luke Nadur Date: Fri, 3 Aug 2018 13:05:41 -0500 Subject: [PATCH 2/2] [CDEC-484] Reunite orphans from Pos.Chain.Ssc.Error.Verify --- chain/src/Pos/Chain/Ssc/Error/Verify.hs | 8 ++------ core/src/Pos/Core/Ssc/VssCertificate.hs | 5 ++++- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/chain/src/Pos/Chain/Ssc/Error/Verify.hs b/chain/src/Pos/Chain/Ssc/Error/Verify.hs index 20d523e35a3..7f7d91aff4a 100644 --- a/chain/src/Pos/Chain/Ssc/Error/Verify.hs +++ b/chain/src/Pos/Chain/Ssc/Error/Verify.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -- | Possible failures during SSC verification. module Pos.Chain.Ssc.Error.Verify @@ -7,17 +5,15 @@ module Pos.Chain.Ssc.Error.Verify , sscIsCriticalVerifyError ) where +import Universum + import Formatting (bprint, build, ords, stext, (%)) import qualified Formatting.Buildable import Serokell.Util (listJson) -import Universum import Pos.Core (EpochIndex, SlotId, StakeholderId) import Pos.Core.Ssc (VssCertificate) -instance Buildable (StakeholderId, VssCertificate) where - build (a, b) = bprint ("(id: "%build%" , cert: "%build%")") a b - type NEStIds = NonEmpty StakeholderId -- | Type for verification error diff --git a/core/src/Pos/Core/Ssc/VssCertificate.hs b/core/src/Pos/Core/Ssc/VssCertificate.hs index 1ae61b2fd7c..1cbfc62b1cd 100644 --- a/core/src/Pos/Core/Ssc/VssCertificate.hs +++ b/core/src/Pos/Core/Ssc/VssCertificate.hs @@ -23,12 +23,12 @@ import Data.Hashable (Hashable (..)) import Data.SafeCopy (base, deriveSafeCopySimple) import Formatting (bprint, build, int, (%)) import qualified Formatting.Buildable as Buildable -import Pos.Core.Common (StakeholderId, addressHash) import Text.JSON.Canonical (FromJSON (..), Int54, JSValue (..), ReportSchemaErrors, ToJSON (..), fromJSField, mkObject) import Pos.Binary.Class (AsBinary, Bi (..), encodeListLen, enforceSize) +import Pos.Core.Common (StakeholderId, addressHash) import Pos.Core.Genesis.Canonical () import Pos.Core.Slotting (EpochIndex) import Pos.Crypto (ProtocolMagic, PublicKey, SecretKey, @@ -75,6 +75,9 @@ instance Buildable VssCertificate where build UnsafeVssCertificate {..} = bprint ("vssCert:"%build%":"%int) vcSigningKey vcExpiryEpoch +instance Buildable (StakeholderId, VssCertificate) where + build (a, b) = bprint ("(id: "%build%" , cert: "%build%")") a b + instance Hashable VssCertificate where hashWithSalt s UnsafeVssCertificate{..} = hashWithSalt s (vcExpiryEpoch, vcVssKey, vcSigningKey, vcSignature)