<commit_before>-- | Main Toss logic.

{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Pos.Ssc.GodTossing.Toss.Logic
       ( verifyAndApplyGtPayload
       , applyGenesisBlock
       , rollbackGT
       , normalizeToss
       ) where

import           Control.Monad.Except            (MonadError (throwError), runExceptT)
import qualified Data.HashMap.Strict             as HM
import           Formatting                      (sformat, (%))
import           Serokell.Util.Text              (listJson)
import           System.Wlog                     (logDebug, logError)
import           Universum

import           Pos.Constants                   (slotSecurityParam)
import           Pos.Ssc.GodTossing.Core         (CommitmentsMap (..), GtPayload (..),
                                                  getCommitmentsMap,
                                                  mkCommitmentsMapUnsafe, _gpCertificates)
import           Pos.Ssc.GodTossing.Functions    (verifyGtPayload)
import           Pos.Ssc.GodTossing.Toss.Base    (checkPayload)
import           Pos.Ssc.GodTossing.Toss.Class   (MonadToss (..), MonadTossRead (..))
import           Pos.Ssc.GodTossing.Toss.Failure (TossVerFailure (..))
import           Pos.Ssc.GodTossing.Toss.Types   (TossModifier (..))
import           Pos.Ssc.GodTossing.Type         ()
import           Pos.Types                       (EpochIndex, EpochOrSlot (..),
                                                  LocalSlotIndex (getSlotIndex),
                                                  MainBlockHeader, SlotId (siSlot),
                                                  epochIndexL, epochOrSlot,
                                                  getEpochOrSlot)
import           Pos.Util                        (NewestFirst (..))

-- | Verify 'GtPayload' with respect to data provided by
-- MonadToss. If data is valid it is also applied.  Otherwise
-- TossVerFailure is thrown using 'MonadError' type class.
verifyAndApplyGtPayload
    :: (MonadToss m, MonadError TossVerFailure m)
    => Either EpochIndex (MainBlockHeader ssc) -> GtPayload -> m ()
verifyAndApplyGtPayload eoh payload = do
    verifyGtPayload eoh payload  -- not necessary for blocks, but just in case
    let blockCerts = _gpCertificates payload
    let curEpoch = either identity (^. epochIndexL) eoh
    stableCerts <- getStableCertificates curEpoch
    richmenSet <- maybe (throwError $ NoRichmen curEpoch) pure =<< getRichmen curEpoch
    logDebug $ sformat (" Stable certificates: "%listJson
                        %", richmen: "%listJson)
                stableCerts richmenSet
    checkPayload curEpoch payload

    -- Apply
    case eoh of
        Left _       -> pass
        Right header -> do
            let eos = getEpochOrSlot header
            setEpochOrSlot eos
            let slot = epochOrSlot (const 0) (getSlotIndex . siSlot) eos
            when (slot >= slotSecurityParam && slot < 2 * slotSecurityParam) resetShares
    mapM_ putCertificate blockCerts
    case payload of
        CommitmentsPayload  comms  _ ->
            mapM_ putCommitment $ toList $ getCommitmentsMap comms
        OpeningsPayload     opens  _ ->
            mapM_ (uncurry putOpening) $ HM.toList opens
        SharesPayload       shares _ ->
            mapM_ (uncurry putShares) $ HM.toList shares
        CertificatesPayload        _ ->
            pass

-- | Apply genesis block for given epoch to 'Toss' state.
applyGenesisBlock :: MonadToss m => EpochIndex -> m ()
applyGenesisBlock epoch = do
    setEpochOrSlot $ getEpochOrSlot epoch
    resetCO

-- | Rollback application of 'GtPayload's in 'Toss'. First argument is
-- 'EpochOrSlot' of oldest block which is subject to rollback.
rollbackGT :: MonadToss m => EpochOrSlot -> NewestFirst [] GtPayload -> m ()
rollbackGT oldestEOS (NewestFirst payloads)
    | oldestEOS == toEnum 0 = do
        logError "rollbackGT: most genesis block is passed to rollback"
        setEpochOrSlot oldestEOS
        resetCO
        resetShares
    | otherwise = do
        setEpochOrSlot (pred oldestEOS)<commit_msg>[CSL-704] Added some clarifying comments<commit_after>-- | Main Toss logic.

{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Pos.Ssc.GodTossing.Toss.Logic
       ( verifyAndApplyGtPayload
       , applyGenesisBlock
       , rollbackGT
       , normalizeToss
       ) where

import           Control.Monad.Except            (MonadError (throwError), runExceptT)
import qualified Data.HashMap.Strict             as HM
import           Formatting                      (sformat, (%))
import           Serokell.Util.Text              (listJson)
import           System.Wlog                     (logDebug, logError)
import           Universum

import           Pos.Constants                   (slotSecurityParam)
import           Pos.Ssc.GodTossing.Core         (CommitmentsMap (..), GtPayload (..),
                                                  getCommitmentsMap, isSharesIdx,
                                                  mkCommitmentsMapUnsafe, _gpCertificates)
import           Pos.Ssc.GodTossing.Functions    (verifyGtPayload)
import           Pos.Ssc.GodTossing.Toss.Base    (checkPayload)
import           Pos.Ssc.GodTossing.Toss.Class   (MonadToss (..), MonadTossRead (..))
import           Pos.Ssc.GodTossing.Toss.Failure (TossVerFailure (..))
import           Pos.Ssc.GodTossing.Toss.Types   (TossModifier (..))
import           Pos.Ssc.GodTossing.Type         ()
import           Pos.Types                       (EpochIndex, EpochOrSlot (..),
                                                  LocalSlotIndex (getSlotIndex),
                                                  MainBlockHeader, SlotId (siSlot),
                                                  epochIndexL, epochOrSlot,
                                                  getEpochOrSlot)
import           Pos.Util                        (NewestFirst (..))

-- | Verify 'GtPayload' with respect to data provided by
-- MonadToss. If data is valid it is also applied.  Otherwise
-- TossVerFailure is thrown using 'MonadError' type class.
verifyAndApplyGtPayload
    :: (MonadToss m, MonadError TossVerFailure m)
    => Either EpochIndex (MainBlockHeader ssc) -> GtPayload -> m ()
verifyAndApplyGtPayload eoh payload = do
    verifyGtPayload eoh payload  -- not necessary for blocks, but just in case
    let blockCerts = _gpCertificates payload
    let curEpoch = either identity (^. epochIndexL) eoh
    stableCerts <- getStableCertificates curEpoch
    richmenSet <- maybe (throwError $ NoRichmen curEpoch) pure =<< getRichmen curEpoch
    logDebug $ sformat (" Stable certificates: "%listJson
                        %", richmen: "%listJson)
                stableCerts richmenSet
    checkPayload curEpoch payload

    -- Apply
    case eoh of
        Left _       -> pass
        Right header -> do
            let eos = getEpochOrSlot header
            setEpochOrSlot eos
            let slot = epochOrSlot (const 0) (getSlotIndex . siSlot) eos
            -- We can freely clear shares after 'slotSecurityParam'
            -- because it's guaranteed that rollback on more than 'slotSecurityParam'
            -- can't happen
            when (slot >= slotSecurityParam && (not $ isSharesIdx slot)) resetShares
    mapM_ putCertificate blockCerts
    case payload of
        CommitmentsPayload  comms  _ ->
            mapM_ putCommitment $ toList $ getCommitmentsMap comms
        OpeningsPayload     opens  _ ->
            mapM_ (uncurry putOpening) $ HM.toList opens
        SharesPayload       shares _ ->
            mapM_ (uncurry putShares) $ HM.toList shares
        CertificatesPayload        _ ->
            pass

-- | Apply genesis block for given epoch to 'Toss' state.
applyGenesisBlock :: MonadToss m => EpochIndex -> m ()
applyGenesisBlock epoch = do
    setEpochOrSlot $ getEpochOrSlot epoch
    -- We don't clear shares on genesis block because
    -- there aren't 'slotSecurityParam' slots after shares phase,
    -- so we won't have shares after rollback
    -- We store shares until 'slotSecurityParam' slots of next epoch passed
    -- and clear their after that
    resetCO

-- | Rollback application of 'GtPayload's in 'Toss'. First argument is
-- 'EpochOrSlot' of oldest block which is subject to rollback.
rollbackGT :: MonadToss m => EpochOrSlot -> NewestFirst [] GtPayload -> m ()
rollbackGT oldestEOS (NewestFirst payloads)
    | oldestEOS == toEnum 0 = do
        logError "rollbackGT: most genesis block is passed to rollback"
        setEpochOrSlot oldestEOS
        resetCO
        resetShares
    | otherwise = do
        setEpochOrSlot (pred oldestEOS)
{'fraction_non_alphanumeric': 0.07336394948335247, 'fraction_numerical': 0.0009184845005740528, 'mean_word_length': 1.827328789354106, 'pattern_counts': {'":': 0, '<': 12, '<?xml version=': 0, '>': 33, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 24, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4994935', 'n_tokens_mistral': 2372, 'n_tokens_neox': 2340, 'n_words': 651}