{-# LANGUAGE Rank2Types      #-}
{-# LANGUAGE RecordWildCards #-}

-- | Base operations in Poll.

module Pos.DB.Update.Poll.Logic.Base
       ( TotalPositive (..)
       , TotalNegative (..)
       , TotalSum (..)
       , mkTotPositive
       , mkTotNegative
       , mkTotSum

       , BVChange (..)
       , adoptBlockVersion
       , canBeAdoptedBV
       , canBeProposedBV
       , canCreateBlockBV
       , isCompetingBV
       , confirmBlockVersion
       , updateSlottingData
       , verifyNextBVMod
       , CurEpoch
       , ConfirmedEpoch
       , calcSoftforkThreshold

       , isDecided
       , voteToUProposalState
       , putNewProposal
       ) where

import           Universum

import           Control.Lens (at)
import           Control.Monad.Except (MonadError (throwError))
import qualified Data.HashMap.Strict as HM
import qualified Data.Set as S
import           Data.Tagged (Tagged, untag)
import           Data.Time.Units (convertUnit)
import           Formatting (build, int, sformat, (%))

import           Pos.Chain.Block (HeaderHash, IsMainHeader (..), headerHashG)
import           Pos.Chain.Update (BlockVersion (..), BlockVersionData (..),
                     BlockVersionModifier (..), BlockVersionState (..),
                     ConfirmedProposalState (..), DecidedProposalState (..),
                     DpsExtra (..), MonadPoll (..), MonadPollRead (..),
                     PollVerFailure (..), ProposalState (..),
                     SoftforkRule (..), UndecidedProposalState (..), UpId,
                     UpdateProposal (..), UpdateVote (..), UpsExtra (..),
                     bvsIsConfirmed, combineVotes, cpsBlockVersion,
                     isPositiveVote, newVoteState)
import           Pos.Core (Coin, CoinPortion (..), EpochIndex, SlotCount,
                     SlotId, TimeDiff (..), addressHash, applyCoinPortionUp,
                     coinPortionDenominator, coinToInteger, difficultyL,
                     getCoinPortion, sumCoins, unsafeAddCoin,
                     unsafeIntegerToCoin, unsafeSubCoin)
import           Pos.Core.Slotting (EpochSlottingData (..), SlottingData,
                     addEpochSlottingData, getCurrentEpochIndex,
                     getNextEpochSlottingData)
import           Pos.Crypto (PublicKey, hash, shortHashF)
import           Pos.Util.Wlog (WithLogger, logDebug, logNotice)



----------------------------------------------------------------------------
-- BlockVersion-related simple functions/operations
----------------------------------------------------------------------------

-- | Check whether BlockVersion is competing.
isCompetingBV :: MonadPollRead m => BlockVersion -> m Bool
isCompetingBV = fmap (maybe False bvsIsConfirmed) . getBVState

-- | Mark given 'BlockVersion' as confirmed if it is known. This
-- function also takes epoch when proposal was confirmed.
confirmBlockVersion :: MonadPoll m => EpochIndex -> BlockVersion -> m ()
confirmBlockVersion confirmedEpoch bv =
    getBVState bv >>= \case
        Nothing  -> pass
        Just bvs -> putBVState bv bvs {bvsConfirmedEpoch = Just confirmedEpoch}

-- | Check whether block with given 'BlockVersion' can be created
-- according to current Poll.
--
-- Specifically, one of the following conditions must be true.
-- • Given block version is equal to last adopted block version.
-- • Given block version is competing
canCreateBlockBV :: MonadPollRead m => BlockVersion -> BlockVersion -> m Bool
canCreateBlockBV lastAdopted bv = do
    isCompeting <- isCompetingBV bv
    pure (bv == lastAdopted || isCompeting)


-- | @BVChange@ encodes the validity of a BlockVersion update
data BVChange = BVIncrement
              | BVNoChange
              | BVInvalid

-- | Check whether given 'BlockVersion' can be proposed according to
-- current Poll.
--
-- Specifically, the following rules regarding major and minor versions
-- take place:
-- 1. If major version is less than last adopted one, it can't be proposed.
-- 2. If major version is more than '1' greater than last adopted one,
-- it can't be proposed as well.
-- 3. If major version is greater than last adopted one by '1', then minor
-- version must be '0'.
-- 4. If major version is equal to the last adopted one, then minor version
-- can be either same as the last adopted one or greater by '1'.
-- Rules regarding alternative version are as follows (assuming
-- checks above pass):
-- 1. If '(Major, Minor)' of given version is equal to '(Major, Minor)' of
-- last adopted version, then alternative version must be equal to
-- alternative version of last adopted version.
-- 2. Otherwise '(Major, Minor)' of given version is lexicographically greater
-- than '(Major, Minor)' of last adopted version and in this case
-- other proposed block versions with same '(Major, Minor)' are considered
-- (let's call this set 'X').
-- If 'X' is empty, given alternative version must be 0.
-- Otherwise it must be in 'X' or greater than maximum from 'X' by one.
canBeProposedBV :: MonadPollRead m => BlockVersion -> m BVChange
canBeProposedBV bv =
    canBeProposedPure bv <$> getAdoptedBV <*>
    (S.fromList <$> getProposedBVs)

canBeProposedPure :: BlockVersion -> BlockVersion -> Set BlockVersion -> BVChange
canBeProposedPure BlockVersion { bvMajor = givenMajor
                               , bvMinor = givenMinor
                               , bvAlt = givenAlt
                               } BlockVersion { bvMajor = adoptedMajor
                                              , bvMinor = adoptedMinor
                                              , bvAlt = adoptedAlt
                                              } proposed
    | givenMajor < adoptedMajor = BVInvalid
    | givenMajor > adoptedMajor + 1 = BVInvalid
    | givenMajor == adoptedMajor + 1 && givenMinor /= 0 = BVInvalid
    | givenMajor == adoptedMajor &&
          givenMinor /= adoptedMinor && givenMinor /= adoptedMinor + 1 = BVInvalid
    | (givenMajor, givenMinor) == (adoptedMajor, adoptedMinor) =
        if givenAlt == adoptedAlt
           then BVNoChange
           else BVInvalid
    -- At this point we know that
    -- '(givenMajor, givenMinor) > (adoptedMajor, adoptedMinor)'
    | null relevantProposed =
        if givenAlt == 0
           then BVIncrement
           else BVInvalid
    | otherwise =
        if (givenAlt == (S.findMax relevantProposed + 1) ||
            givenAlt `S.member` relevantProposed)
           then BVIncrement
           else BVInvalid
  where
    -- Here we can use mapMonotonic, even though 'bvAlt' itself is not
    -- necessary monotonic.
    -- That's because after filtering all versions have same major and minor
    -- components.
    relevantProposed = S.mapMonotonic bvAlt $ S.filter predicate proposed
    predicate BlockVersion {..} = bvMajor == givenMajor && bvMinor == givenMinor

-- | Check whether given 'BlockVersion' can be adopted according to
-- current Poll.
--
-- Specifically, the following rules regarding major and minor versions
-- take place:
-- 1. If major version is less than last adopted one, it can't be adopted.
-- 2. If major version is more than '1' greater than last adopted one,
-- it can't be adopted as well.
-- 3. If major version is greater than last adopted one by '1', then minor
-- version must be '0'.
-- 4. If major version is equal to the last adopted one, then minor version
-- can be greather than minor component of last adopted version by 1.
canBeAdoptedBV :: MonadPollRead m => BlockVersion -> m Bool
canBeAdoptedBV bv = canBeAdoptedPure bv <$> getAdoptedBV

canBeAdoptedPure :: BlockVersion -> BlockVersion -> Bool
canBeAdoptedPure BlockVersion { bvMajor = givenMajor
                              , bvMinor = givenMinor
                              }
                 BlockVersion { bvMajor = adoptedMajor
                              , bvMinor = adoptedMinor
                              }
    | givenMajor < adoptedMajor = False
    | givenMajor > adoptedMajor + 1 = False
    | givenMajor == adoptedMajor + 1 = givenMinor == 0
    | otherwise = givenMinor == adoptedMinor + 1

-- | Adopt given block version. When it happens, last adopted block
-- version is changed.
--
-- Apart from that, 'ConfirmedProposalState' of proposals with this
-- block version are updated.
adoptBlockVersion
    :: MonadPoll m
    => HeaderHash -> BlockVersion -> m ()
adoptBlockVersion winningBlk bv = do
    setAdoptedBV bv
    logNotice $ sformat logFmt bv winningBlk
    mapM_ processConfirmed =<< getConfirmedProposals
  where
    processConfirmed cps
        | cpsBlockVersion cps /= bv = pass
        | otherwise = addConfirmedProposal cps {cpsAdopted = Just winningBlk}
    logFmt = "BlockVersion is adopted: "%build%"; winning block was "%shortHashF

-- | Update slotting data stored in poll. First argument is epoch for
-- which currently adopted 'BlockVersion' can be applied. Here we update the
-- @SlottingData@ from the update. We can recieve updated epoch @SlottingData@
-- and from it, changed epoch/slot times, which is important to keep track of.
updateSlottingData
    :: (MonadError PollVerFailure m, MonadPoll m)
    => SlotCount
    -> EpochIndex
    -> m ()
updateSlottingData epochSlots epochIndex = do
    let errFmt =
            ("can't update slotting data, stored current epoch is "%int%
             ", while given epoch is "%int%
             ")")

    slottingData         <- getSlottingData

    let currentEpochIndex = getCurrentEpochIndex slottingData
    let nextEpochSD       = getNextEpochSlottingData slottingData

    if | currentEpochIndex + 1 == epochIndex ->
          -- We don't need an epochIndex since it's always being added at the end.
          updateSlottingDataDo slottingData nextEpochSD
       -- This can happen if there was rollback of genesis block.
       | currentEpochIndex == epochIndex -> pass
       | otherwise ->
           throwError $ PollInternalError $ sformat errFmt currentEpochIndex epochIndex
  where
    -- | Here we calculate the new @EpochSlottingData@ and add it in the
    -- @MonadPoll@ memory @SlottingData@.
    updateSlottingDataDo :: MonadPoll m => SlottingData -> EpochSlottingData -> m ()
    updateSlottingDataDo slottingData esd = do
        latestSlotDuration <- bvdSlotDuration <$> getAdoptedBVData

        let epochDuration = fromIntegral epochSlots * convertUnit (esdSlotDuration esd)
        let newLastStartDiff = esdStartDiff esd + TimeDiff epochDuration
        let newESD = EpochSlottingData {
              esdSlotDuration = latestSlotDuration
            , esdStartDiff    = newLastStartDiff
            }

        let newSlottingData = addEpochSlottingData slottingData newESD

        setSlottingData newSlottingData

-- | Verify that 'BlockVersionModifier' passed as last argument can follow
-- 'BlockVersionData' passed as second argument. First argument
-- ('UpId') is used to create error only.
verifyNextBVMod
    :: MonadError PollVerFailure m
    => UpId
    -> EpochIndex -- block epoch index
    -> BlockVersionData
    -> BlockVersionModifier
    -> m ()
verifyNextBVMod upId _epoch
  BlockVersionData { bvdScriptVersion = oldSV
                   , bvdMaxBlockSize = oldMBS
                   }
  BlockVersionModifier { bvmScriptVersion = newSVM
                       , bvmMaxBlockSize = newMBSM
                       }
    | Just newSV <- newSVM,
      newSV /= oldSV + 1 && newSV /= oldSV =
        throwError
            $ PollWrongScriptVersion oldSV newSV upId
    | Just newMBS <- newMBSM,
      newMBS > oldMBS * 2 =
        throwError
           $ PollLargeMaxBlockSize (oldMBS * 2) newMBS upId
    | otherwise = pass

-- | Dummy type for tagging used by 'calcSoftforkThreshold'.
data CurEpoch

-- | Dummy type for tagging used by 'calcSoftforkThreshold'.
data ConfirmedEpoch

-- | Calculate how much stake issuers of blocks with some block
-- version should have to make this version adopted.
calcSoftforkThreshold ::
       SoftforkRule
    -> Coin
    -> Tagged CurEpoch EpochIndex
    -> Tagged ConfirmedEpoch EpochIndex
    -> Coin
calcSoftforkThreshold SoftforkRule {..} totalStake (untag -> curEpoch) (untag -> confirmedEpoch)
    | curEpoch < confirmedEpoch =
        error
            "calcSoftforkThreshold: logical error, curEpoch < confirmedEpoch, can't happen"
    | otherwise = applyCoinPortionUp portion totalStake
  where
    minuend :: Word64
    minuend = getCoinPortion srInitThd
    -- ↓ Can't overflow, because we explicitly check it above (↑). ↓
    epochDiff :: Word64
    epochDiff = fromIntegral $ curEpoch - confirmedEpoch
    -- ↓ Maximal epoch difference such that decrement can be
    -- calculated w/o overflow. ↓
    maxEpochDiff = coinPortionDenominator `div` getCoinPortion srThdDecrement
    -- ↓ Is evaluated only if 'epochDiff ≤ maxEpochDiff', in which
    -- case overflow is impossible, moreover, 'subtrahend' should
    -- represent a valid 'CoinPortion'. ↓
    subtrahend :: Word64
    subtrahend = getCoinPortion srThdDecrement * epochDiff
    portion
        -- ↓This condition↓ means that too many epochs passed so that
        -- decrement doesn't even fit into 'CoinPortion'.
        | epochDiff > maxEpochDiff = srMinThd
        -- 'subtrahend + getCoinPortion srMinThd' can not overflow as
        -- long as 2 'coinPortionDenominator's fit into 'Word64'
        -- (which is true).
        --
        -- ↓Here↓ 'CoinPortion' is safe because:
        -- • 'minued - subtrahend' can't underflow because it's ensured by
        --   the guard;
        -- • the value can't be negative, because the type is unsigned;
        -- • the value can't be greater than max possible one, because
        --   minuend represents a valid coin portion.
        | minuend > subtrahend + getCoinPortion srMinThd =
            CoinPortion (minuend - subtrahend)
        | otherwise = srMinThd

----------------------------------------------------------------------------
-- Wrappers for type-safety
----------------------------------------------------------------------------

newtype TotalPositive = TotalPositive Integer
newtype TotalNegative = TotalNegative Integer
newtype TotalSum = TotalSum Integer

mkTotPositive :: Coin -> TotalPositive
mkTotPositive = TotalPositive . coinToInteger

mkTotNegative :: Coin -> TotalNegative
mkTotNegative = TotalNegative . coinToInteger

mkTotSum :: Coin -> TotalSum
mkTotSum = TotalSum . coinToInteger

----------------------------------------------------------------------------
-- Basic operations
----------------------------------------------------------------------------

-- Proposal is approved (which corresponds to 'Just True') if total
-- stake of votes for it is more than half of total stake.
-- Proposal is rejected (which corresponds to 'Just False') if total
-- stake of votes against it is more than half of total stake.
-- Otherwise proposal is undecided ('Nothing').
isDecided :: TotalPositive -> TotalNegative -> TotalSum -> Maybe Bool
isDecided (TotalPositive totalPositive) (TotalNegative totalNegative) (TotalSum totalSum)
    | totalPositive * 2 > totalSum = Just True
    | totalNegative * 2 > totalSum = Just False
    | otherwise = Nothing

-- | Apply vote to UndecidedProposalState, thus modifing mutable data,
-- i. e. votes and stakes.
voteToUProposalState
    :: (MonadError PollVerFailure m, WithLogger m)
    => PublicKey
    -> Coin
    -> Bool
    -> UndecidedProposalState
    -> m UndecidedProposalState
voteToUProposalState voter stake decision ups@UndecidedProposalState {..} = do
    let upId = hash upsProposal
    -- We need to find out new state of vote (it can be a fresh vote or revote).
    let oldVote = upsVotes ^. at voter
    let oldPositive = maybe False isPositiveVote oldVote
    let oldNegative = maybe False (not . isPositiveVote) oldVote
    let combinedMaybe = decision `combineVotes` oldVote
    logDebug $ sformat (
        "New vote: upId = "%build%",\
        \voter = "%build%",\
        \vote = "%build%",\
        \voter stake = "%build)
        upId voter combinedMaybe stake
    combined <-
        note
            (PollExtraRevote upId (addressHash voter) decision)
            combinedMaybe
    -- We recalculate new stake taking into account that old vote
    -- could be deactivate.
    let posStakeAfterRemove
            | oldPositive = upsPositiveStake `unsafeSubCoin` stake
            | otherwise = upsPositiveStake
        negStakeAfterRemove
            | oldNegative = upsNegativeStake `unsafeSubCoin` stake
            | otherwise = upsNegativeStake
    -- Then we recalculate stake adding stake of new vote.
        posStakeFinal
            | decision = posStakeAfterRemove `unsafeAddCoin` stake
            | otherwise = posStakeAfterRemove
        negStakeFinal
            | decision = negStakeAfterRemove
            | otherwise = negStakeAfterRemove `unsafeAddCoin` stake
    -- We add a new vote with update state to set of votes.
    let newVotes = HM.insert voter combined upsVotes
    logDebug $
        sformat ("Stakes of proposal "%build%" after vote: \
                 \positive "%build%",\
                 \negative: "%build)
                upId posStakeFinal negStakeFinal
    return
        ups
        { upsVotes = newVotes
        , upsPositiveStake = posStakeFinal
        , upsNegativeStake = negStakeFinal
        }

-- Put a new proposal into context of MonadPoll. First argument
-- determines whether proposal is part of existing block or is taken
-- from mempool. State of proposal is calculated from votes for it and
-- their stakes.
putNewProposal
    :: (MonadPoll m, IsMainHeader mainHeader)
    => Either SlotId mainHeader
    -> Coin
    -> [(UpdateVote, Coin)]
    -> UpdateProposal
    -> m ()
putNewProposal slotOrHeader totalStake votesAndStakes up = insertActiveProposal ps
  where
    slotId = either identity (view headerSlotL) slotOrHeader
    cd = either (const Nothing) (Just . view difficultyL) slotOrHeader
    totalPositive = sumCoins . map snd . filter (uvDecision . fst) $ votesAndStakes
    totalNegative = sumCoins . map snd . filter (not . uvDecision . fst) $ votesAndStakes
    blkHeaderHash = either (const Nothing) (Just . view headerHashG) slotOrHeader
    votes = HM.fromList . map convertVote $ votesAndStakes
    -- New proposal always has a fresh vote (not revote).
    convertVote (vote, _) = (uvKey vote, newVoteState (uvDecision vote))
    ups =
        UndecidedProposalState
        { upsVotes = votes
        , upsProposal = up
        , upsSlot = slotId
        , upsPositiveStake = unsafeIntegerToCoin totalPositive
        , upsNegativeStake = unsafeIntegerToCoin totalNegative
        , upsExtra = UpsExtra <$> blkHeaderHash
        }
    -- New proposal can be in decided state immediately if it has a
    -- lot of positive votes.
    ps
        | Just decision <-
             isDecided
                 (TotalPositive totalPositive)
                 (TotalNegative totalNegative)
                 (mkTotSum totalStake) =
            PSDecided
                DecidedProposalState
                { dpsDecision = decision
                , dpsUndecided = ups
                , dpsDifficulty = cd
                , dpsExtra = DpsExtra <$> blkHeaderHash <*> Just False
                }
    -- Or it can be in undecided state (more common case).
        | otherwise = PSUndecided ups
