<commit_before>{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE Rank2Types          #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Logic of local data processing in Update System.

module Pos.Update.Logic.Global
       ( usApplyBlocks
       , usCanCreateBlock
       , usRollbackBlocks
       , usVerifyBlocks
       ) where

import           Control.Monad.Except (MonadError, runExceptT)
import           Data.Default         (Default (def))
import qualified Data.HashMap.Strict  as HM
import           System.Wlog          (WithLogger, logError)
import           Universum

import           Pos.Constants        (lastKnownBlockVersion)
import           Pos.Context          (WithNodeContext)
import qualified Pos.DB               as DB
import           Pos.DB.GState        (UpdateOp (..))
import           Pos.Ssc.Class        (Ssc)
import           Pos.Types            (ApplicationName, Block, BlockVersion,
                                       NumSoftwareVersion, SoftwareVersion (..),
                                       difficultyL, epochIndexL, gbBody, gbHeader,
                                       gbhExtra, mbUpdatePayload, mehBlockVersion)
import           Pos.Update.Core      (UpId)
import           Pos.Update.Error     (USError (USInternalError))
import           Pos.Update.Poll      (BlockVersionState, ConfirmedProposalState, DBPoll,
                                       MonadPoll, PollModifier (..), PollT,
                                       PollVerFailure, ProposalState, USUndo,
                                       canCreateBlockBV, execPollT, execRollT,
                                       processGenesisBlock, recordBlockIssuance,
                                       rollbackUSPayload, runDBPoll, runPollT,
                                       verifyAndApplyUSPayload)
import           Pos.Util             (Color (Red), NE, NewestFirst, OldestFirst,
                                       colorize, inAssertMode)

type USGlobalApplyMode ssc m = (WithLogger m
                               , DB.MonadDB ssc m
                               , Ssc ssc
                               , WithNodeContext ssc m)
type USGlobalVerifyMode ssc m = (DB.MonadDB ssc m
                                , MonadError PollVerFailure m
                                , Ssc ssc
                                , WithNodeContext ssc m)

-- | Apply chain of /definitely/ valid blocks to US part of GState DB
-- and to US local data. This function assumes that no other thread
-- applies block in parallel. It also assumes that parent of oldest
-- block is current tip.  If verification is done prior to
-- application, one can pass 'PollModifier' obtained from verification
-- to this function.
usApplyBlocks
    :: (MonadThrow m, USGlobalApplyMode ssc m)
    => OldestFirst NE (Block ssc)
    -> Maybe PollModifier
    -> m [DB.SomeBatchOp]
usApplyBlocks blocks modifierMaybe =
    case modifierMaybe of
        Nothing -> do
            verdict <- runExceptT $ usVerifyBlocks blocks
            either onFailure (return . modifierToBatch . fst) verdict
        Just modifier -> do
            -- TODO: I suppose such sanity checks should be done at higher
            -- level.
            inAssertMode $ do
                verdict <- runExceptT $ usVerifyBlocks blocks
                either onFailure (const pass) verdict
            return $ modifierToBatch modifier
  where
    onFailure failure = do
        let msg = "usVerifyBlocks failed in 'apply': " <> pretty failure
        logError $ colorize Red msg
        throwM $ USInternalError msg

-- | Revert application of given blocks to US part of GState DB and US local
-- data. The caller must ensure that the tip stored in DB is 'headerHash' of
-- head.
usRollbackBlocks
    :: forall ssc m.
       USGlobalApplyMode ssc m
    => NewestFirst NE (Block ssc, USUndo) -> m [DB.SomeBatchOp]
usRollbackBlocks blunds =
    modifierToBatch <$> (runDBPoll . execPollT def $ mapM_ rollbackDo blunds)
  where
    rollbackDo :: (Block ssc, USUndo) -> PollT (DBPoll m) ()
    rollbackDo (Left _, _) = pass
    rollbackDo (Right blk, undo) =
        rollbackUSPayload
            (blk ^. difficultyL)
            (blk ^. gbBody . mbUpdatePayload)
            undo

-- | Verify whether sequence of blocks can be applied to US part of
-- current GState DB.  This function doesn't make pure checks, they
-- are assumed to be done earlier, most likely during objects
-- construction.
usVerifyBlocks
    :: (USGlobalVerifyMode ssc m)
    => OldestFirst NE (Block ssc) -> m (PollModifier, OldestFirst NE USUndo)
usVerifyBlocks blocks = swap <$> run (mapM verifyBlock blocks)
  where
    run = runDBPoll . runPollT def

verifyBlock
    :: (USGlobalVerifyMode ssc m, MonadPoll m)<commit_msg>[CSL-638] Add comment about currently broken rollback of genesis block<commit_after>{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE Rank2Types          #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Logic of local data processing in Update System.

module Pos.Update.Logic.Global
       ( usApplyBlocks
       , usCanCreateBlock
       , usRollbackBlocks
       , usVerifyBlocks
       ) where

import           Control.Monad.Except (MonadError, runExceptT)
import           Data.Default         (Default (def))
import qualified Data.HashMap.Strict  as HM
import           System.Wlog          (WithLogger, logError)
import           Universum

import           Pos.Constants        (lastKnownBlockVersion)
import           Pos.Context          (WithNodeContext)
import qualified Pos.DB               as DB
import           Pos.DB.GState        (UpdateOp (..))
import           Pos.Ssc.Class        (Ssc)
import           Pos.Types            (ApplicationName, Block, BlockVersion,
                                       NumSoftwareVersion, SoftwareVersion (..),
                                       difficultyL, epochIndexL, gbBody, gbHeader,
                                       gbhExtra, mbUpdatePayload, mehBlockVersion)
import           Pos.Update.Core      (UpId)
import           Pos.Update.Error     (USError (USInternalError))
import           Pos.Update.Poll      (BlockVersionState, ConfirmedProposalState, DBPoll,
                                       MonadPoll, PollModifier (..), PollT,
                                       PollVerFailure, ProposalState, USUndo,
                                       canCreateBlockBV, execPollT, execRollT,
                                       processGenesisBlock, recordBlockIssuance,
                                       rollbackUSPayload, runDBPoll, runPollT,
                                       verifyAndApplyUSPayload)
import           Pos.Util             (Color (Red), NE, NewestFirst, OldestFirst,
                                       colorize, inAssertMode)

type USGlobalApplyMode ssc m = (WithLogger m
                               , DB.MonadDB ssc m
                               , Ssc ssc
                               , WithNodeContext ssc m)
type USGlobalVerifyMode ssc m = (DB.MonadDB ssc m
                                , MonadError PollVerFailure m
                                , Ssc ssc
                                , WithNodeContext ssc m)

-- | Apply chain of /definitely/ valid blocks to US part of GState DB
-- and to US local data. This function assumes that no other thread
-- applies block in parallel. It also assumes that parent of oldest
-- block is current tip.  If verification is done prior to
-- application, one can pass 'PollModifier' obtained from verification
-- to this function.
usApplyBlocks
    :: (MonadThrow m, USGlobalApplyMode ssc m)
    => OldestFirst NE (Block ssc)
    -> Maybe PollModifier
    -> m [DB.SomeBatchOp]
usApplyBlocks blocks modifierMaybe =
    case modifierMaybe of
        Nothing -> do
            verdict <- runExceptT $ usVerifyBlocks blocks
            either onFailure (return . modifierToBatch . fst) verdict
        Just modifier -> do
            -- TODO: I suppose such sanity checks should be done at higher
            -- level.
            inAssertMode $ do
                verdict <- runExceptT $ usVerifyBlocks blocks
                either onFailure (const pass) verdict
            return $ modifierToBatch modifier
  where
    onFailure failure = do
        let msg = "usVerifyBlocks failed in 'apply': " <> pretty failure
        logError $ colorize Red msg
        throwM $ USInternalError msg

-- | Revert application of given blocks to US part of GState DB and US local
-- data. The caller must ensure that the tip stored in DB is 'headerHash' of
-- head.
usRollbackBlocks
    :: forall ssc m.
       USGlobalApplyMode ssc m
    => NewestFirst NE (Block ssc, USUndo) -> m [DB.SomeBatchOp]
usRollbackBlocks blunds =
    modifierToBatch <$> (runDBPoll . execPollT def $ mapM_ rollbackDo blunds)
  where
    rollbackDo :: (Block ssc, USUndo) -> PollT (DBPoll m) ()
    -- FIXME: rollback of genesis block can be non-trivial too!
    rollbackDo (Left _, _) = pass
    rollbackDo (Right blk, undo) =
        rollbackUSPayload
            (blk ^. difficultyL)
            (blk ^. gbBody . mbUpdatePayload)
            undo

-- | Verify whether sequence of blocks can be applied to US part of
-- current GState DB.  This function doesn't make pure checks, they
-- are assumed to be done earlier, most likely during objects
-- construction.
usVerifyBlocks
    :: (USGlobalVerifyMode ssc m)
    => OldestFirst NE (Block ssc) -> m (PollModifier, OldestFirst NE USUndo)
usVerifyBlocks blocks = swap <$> run (mapM verifyBlock blocks)
  where
    run = runDBPoll . runPollT def

verifyBlock
    :: (USGlobalVerifyMode ssc m, MonadPoll m)
{'fraction_non_alphanumeric': 0.0669360688011605, 'fraction_numerical': 0.0005180810278727593, 'mean_word_length': 1.7672018348623852, 'pattern_counts': {'":': 0, '<': 13, '<?xml version=': 0, '>': 29, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 32, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '946785', 'n_tokens_mistral': 2566, 'n_tokens_neox': 2511, 'n_words': 839}