<commit_before>{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types            #-}
{-# LANGUAGE TemplateHaskell       #-}

-- | Storage with node local state which should be persistent.

module Pos.State.Storage
       (
         Storage

       , Query
       , getBlock
       , getHeadBlock
       , getLeaders
       , getLocalTxs
       , getOurCommitment
       , getOurOpening
       , getOurShares
       , getParticipants
       , getThreshold
       , mayBlockBeUseful

       , ProcessBlockRes (..)

       , Update
       , createNewBlock
       , setSecret
       , processBlock
       , processNewSlot
       , processCommitment
       , processOpening
       , processShares
       , processTx
       , processVssCertificate

       , IdTimestamp (..)
       , addStatRecord
       , getStatRecords
       ) where

import           Control.Lens            (makeClassy, use, view, (.=), (^.))
import           Data.Acid               ()
import           Data.Default            (Default, def)
import qualified Data.HashMap.Strict     as HM
import           Data.List               (nub)
import           Data.List.NonEmpty      (NonEmpty ((:|)), span)
import           Data.SafeCopy           (base, deriveSafeCopySimple)
import           Formatting              (build, sformat, (%))
import           Serokell.AcidState      ()
import           Serokell.Util           (VerificationRes (..))
import           Universum

import           Pos.Constants           (k)
import           Pos.Crypto              (PublicKey, SecretKey, Share, Threshold,
                                          VssPublicKey, signedValue)
import           Pos.State.Storage.Block (BlockStorage, HasBlockStorage (blockStorage),
                                          blkCleanUp, blkCreateGenesisBlock,
                                          blkCreateNewBlock, blkProcessBlock, blkRollback,
                                          blkSetHead, getBlock, getHeadBlock, getLeaders,
                                          getSlotDepth, mayBlockBeUseful)
import           Pos.State.Storage.Mpc   (HasMpcStorage (mpcStorage), MpcStorage,
                                          calculateLeaders, getGlobalMpcDataByDepth,
                                          getLocalMpcData, getOurCommitment,
                                          getOurOpening, getOurShares, mpcApplyBlocks,
                                          mpcProcessCommitment, mpcProcessOpening,
                                          mpcProcessShares, mpcProcessVssCertificate,
                                          mpcRollback, mpcVerifyBlock, mpcVerifyBlocks,
                                          setSecret)
import           Pos.State.Storage.Stats (HasStatsData (statsData), IdTimestamp (..),
                                          StatsData, addStatRecord, getStatRecords)
import           Pos.State.Storage.Tx    (HasTxStorage (txStorage), TxStorage,
                                          getLocalTxs, getUtxoByDepth, processTx,
                                          txApplyBlocks, txRollback, txVerifyBlocks)
import           Pos.State.Storage.Types (AltChain, ProcessBlockRes (..), mkPBRabort)
import           Pos.Types               (Block, Commitment, CommitmentSignature,
                                          EpochIndex, MainBlock, Opening, SlotId (..),
                                          SlotLeaders, VssCertificate, blockTxs,
                                          epochIndexL, getAddress, headerHashG,
                                          mdVssCertificates, txOutAddress,
                                          unflattenSlotId, verifyTxAlone)
import           Pos.Util                (readerToState, _neHead)

type Query  a = forall m . MonadReader Storage m => m a
type Update a = forall m . MonadState Storage m => m a

data Storage = Storage
    { -- | State of MPC.
      __mpcStorage   :: !MpcStorage
    , -- | Transactions part of /static-state/.
      __txStorage    :: !TxStorage
    , -- | Blockchain part of /static-state/.
      __blockStorage :: !BlockStorage
    , -- | Id of last seen slot.
      _slotId        :: !SlotId
    , -- | Statistical data
      __statsData    :: !StatsData
    }

makeClassy ''Storage
deriveSafeCopySimple 0 'base ''Storage

instance HasMpcStorage Storage where
    mpcStorage = _mpcStorage
instance HasTxStorage Storage where
    txStorage = _txStorage
instance HasBlockStorage Storage where
    blockStorage = _blockStorage
instance HasStatsData Storage where
    statsData = _statsData

instance Default Storage where
    def =
        Storage
        { __mpcStorage = def
        , __txStorage = def
        , __blockStorage = def
        , _slotId = unflattenSlotId 0
        , __statsData = def
        }

getHeadEpoch :: Query EpochIndex
getHeadEpoch = view epochIndexL <$> getHeadBlock

-- | Create a new block on top of best chain.
createNewBlock :: SecretKey -> SlotId -> Update MainBlock
createNewBlock sk sId = do
    txs <- readerToState $ toList <$> getLocalTxs
    mpcData <- readerToState getLocalMpcData
    blk <- blkCreateNewBlock sk sId txs mpcData
    let blocks = Right blk :| []
    mpcApplyBlocks blocks
    blk <$ txApplyBlocks blocks

-- | Do all necessary changes when a block is received.
processBlock :: SlotId -> Block -> Update ProcessBlockRes
processBlock curSlotId blk = do
    mpcRes <- readerToState $ mpcVerifyBlock blk
    let txs =
            case blk of
                Left _        -> []
                Right mainBlk -> toList $ mainBlk ^. blockTxs
    let txRes = foldMap verifyTxAlone txs
    case mpcRes <> txRes of
        VerSuccess        -> processBlockDo curSlotId blk
        VerFailure errors -> return $ mkPBRabort errors

processBlockDo :: SlotId -> Block -> Update ProcessBlockRes
processBlockDo curSlotId blk = do
    r <- blkProcessBlock curSlotId blk
    case r of
        PBRgood (toRollback, chain) -> do
            mpcRes <- readerToState $ mpcVerifyBlocks toRollback chain
            txRes <- readerToState $ txVerifyBlocks toRollback chain
            case mpcRes <> txRes of
                VerSuccess        -> processBlockFinally toRollback chain
                VerFailure errors -> return $ mkPBRabort errors
        _ -> return r

-- At this point all checks have been passed and we know that we can
-- adopt this AltChain.
processBlockFinally :: Word -> AltChain -> Update ProcessBlockRes
processBlockFinally toRollback blocks = do
    -- we split block processing in two phases, cause processing genesis block (by `mpcApplyBlocks`)
    --    erases MPC data, which is needed for createGenesisBlock function
    let (prevEBlocks, newEBlocks) = span isRight blocks
    mpcRollback toRollback
    txRollback toRollback
    blkRollback toRollback
    case prevEBlocks of
      []       -> return ()
      (f:rest) -> processDo $ f :| rest
    case newEBlocks of
      [] -> return ()
      (genB:rest) -> do
          headEpoch <- readerToState getHeadEpoch
          createGenesisBlock $ headEpoch + 1
          processDo $ genB :| rest
    return $ PBRgood (toRollback, blocks)
  where
    processDo blocks' = do
        mpcApplyBlocks blocks'
        txApplyBlocks blocks'
        blkSetHead (blocks' ^. _neHead . headerHashG)
<commit_msg>Revert "[POS-31] Fix potential bug"<commit_after>{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types            #-}
{-# LANGUAGE TemplateHaskell       #-}

-- | Storage with node local state which should be persistent.

module Pos.State.Storage
       (
         Storage

       , Query
       , getBlock
       , getHeadBlock
       , getLeaders
       , getLocalTxs
       , getOurCommitment
       , getOurOpening
       , getOurShares
       , getParticipants
       , getThreshold
       , mayBlockBeUseful

       , ProcessBlockRes (..)

       , Update
       , createNewBlock
       , setSecret
       , processBlock
       , processNewSlot
       , processCommitment
       , processOpening
       , processShares
       , processTx
       , processVssCertificate

       , IdTimestamp (..)
       , addStatRecord
       , getStatRecords
       ) where

import           Control.Lens            (makeClassy, use, view, (.=), (^.))
import           Data.Acid               ()
import           Data.Default            (Default, def)
import qualified Data.HashMap.Strict     as HM
import           Data.List               (nub)
import           Data.List.NonEmpty      (NonEmpty ((:|)))
import           Data.SafeCopy           (base, deriveSafeCopySimple)
import           Formatting              (build, sformat, (%))
import           Serokell.AcidState      ()
import           Serokell.Util           (VerificationRes (..))
import           Universum

import           Pos.Constants           (k)
import           Pos.Crypto              (PublicKey, SecretKey, Share, Threshold,
                                          VssPublicKey, signedValue)
import           Pos.State.Storage.Block (BlockStorage, HasBlockStorage (blockStorage),
                                          blkCleanUp, blkCreateGenesisBlock,
                                          blkCreateNewBlock, blkProcessBlock, blkRollback,
                                          blkSetHead, getBlock, getHeadBlock, getLeaders,
                                          getSlotDepth, mayBlockBeUseful)
import           Pos.State.Storage.Mpc   (HasMpcStorage (mpcStorage), MpcStorage,
                                          calculateLeaders, getGlobalMpcDataByDepth,
                                          getLocalMpcData, getOurCommitment,
                                          getOurOpening, getOurShares, mpcApplyBlocks,
                                          mpcProcessCommitment, mpcProcessOpening,
                                          mpcProcessShares, mpcProcessVssCertificate,
                                          mpcRollback, mpcVerifyBlock, mpcVerifyBlocks,
                                          setSecret)
import           Pos.State.Storage.Stats (HasStatsData (statsData), IdTimestamp (..),
                                          StatsData, addStatRecord, getStatRecords)
import           Pos.State.Storage.Tx    (HasTxStorage (txStorage), TxStorage,
                                          getLocalTxs, getUtxoByDepth, processTx,
                                          txApplyBlocks, txRollback, txVerifyBlocks)
import           Pos.State.Storage.Types (AltChain, ProcessBlockRes (..), mkPBRabort)
import           Pos.Types               (Block, Commitment, CommitmentSignature,
                                          EpochIndex, MainBlock, Opening, SlotId (..),
                                          SlotLeaders, VssCertificate, blockTxs,
                                          epochIndexL, getAddress, headerHashG,
                                          mdVssCertificates, txOutAddress,
                                          unflattenSlotId, verifyTxAlone)
import           Pos.Util                (readerToState, _neHead)

type Query  a = forall m . MonadReader Storage m => m a
type Update a = forall m . MonadState Storage m => m a

data Storage = Storage
    { -- | State of MPC.
      __mpcStorage   :: !MpcStorage
    , -- | Transactions part of /static-state/.
      __txStorage    :: !TxStorage
    , -- | Blockchain part of /static-state/.
      __blockStorage :: !BlockStorage
    , -- | Id of last seen slot.
      _slotId        :: !SlotId
    , -- | Statistical data
      __statsData    :: !StatsData
    }

makeClassy ''Storage
deriveSafeCopySimple 0 'base ''Storage

instance HasMpcStorage Storage where
    mpcStorage = _mpcStorage
instance HasTxStorage Storage where
    txStorage = _txStorage
instance HasBlockStorage Storage where
    blockStorage = _blockStorage
instance HasStatsData Storage where
    statsData = _statsData

instance Default Storage where
    def =
        Storage
        { __mpcStorage = def
        , __txStorage = def
        , __blockStorage = def
        , _slotId = unflattenSlotId 0
        , __statsData = def
        }

getHeadEpoch :: Query EpochIndex
getHeadEpoch = view epochIndexL <$> getHeadBlock

-- | Create a new block on top of best chain.
createNewBlock :: SecretKey -> SlotId -> Update MainBlock
createNewBlock sk sId = do
    txs <- readerToState $ toList <$> getLocalTxs
    mpcData <- readerToState getLocalMpcData
    blk <- blkCreateNewBlock sk sId txs mpcData
    let blocks = Right blk :| []
    mpcApplyBlocks blocks
    blk <$ txApplyBlocks blocks

-- | Do all necessary changes when a block is received.
processBlock :: SlotId -> Block -> Update ProcessBlockRes
processBlock curSlotId blk = do
    mpcRes <- readerToState $ mpcVerifyBlock blk
    let txs =
            case blk of
                Left _        -> []
                Right mainBlk -> toList $ mainBlk ^. blockTxs
    let txRes = foldMap verifyTxAlone txs
    case mpcRes <> txRes of
        VerSuccess        -> processBlockDo curSlotId blk
        VerFailure errors -> return $ mkPBRabort errors

processBlockDo :: SlotId -> Block -> Update ProcessBlockRes
processBlockDo curSlotId blk = do
    r <- blkProcessBlock curSlotId blk
    case r of
        PBRgood (toRollback, chain) -> do
            mpcRes <- readerToState $ mpcVerifyBlocks toRollback chain
            txRes <- readerToState $ txVerifyBlocks toRollback chain
            case mpcRes <> txRes of
                VerSuccess        -> processBlockFinally toRollback chain
                VerFailure errors -> return $ mkPBRabort errors
        _ -> return r

-- At this point all checks have been passed and we know that we can
-- adopt this AltChain.
processBlockFinally :: Word -> AltChain -> Update ProcessBlockRes
processBlockFinally toRollback blocks = do
    mpcRollback toRollback
    mpcApplyBlocks blocks
    txRollback toRollback
    txApplyBlocks blocks
    blkRollback toRollback
    blkSetHead (blocks ^. _neHead . headerHashG)
    headEpoch <- readerToState getHeadEpoch
    knownEpoch <- use (slotId . epochIndexL)
    when (headEpoch + 1 == knownEpoch) $ createGenesisBlock knownEpoch
    return $ PBRgood (toRollback, blocks)

{'fraction_non_alphanumeric': 0.06627898829958663, 'fraction_numerical': 0.0007006235549639179, 'mean_word_length': 1.6876294483148182, 'pattern_counts': {'":': 0, '<': 30, '<?xml version=': 0, '>': 51, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 80, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6853922', 'n_tokens_mistral': 3647, 'n_tokens_neox': 3592, 'n_words': 999}