content: {-# LANGUAGE RecordWildCards #-}
  
  -- | Logic of application and verification of data in Poll.
  
  module Pos.DB.Update.Poll.Logic.Apply
         ( verifyAndApplyUSPayload
         , verifyAndApplyProposal
         , verifyAndApplyVoteDo
         ) where
  
  import           Universum hiding (id)
  
  import           Control.Monad.Except (MonadError, runExceptT, throwError)
  import qualified Data.HashSet as HS
  import           Data.List (partition)
  import qualified Data.List.NonEmpty as NE
  import           Formatting (build, builder, int, sformat, (%))
  
  import           Pos.Binary.Class (biSize)
  import           Pos.Chain.Block (HeaderHash, IsMainHeader (..), headerHashG,
                       headerSlotL)
  import           Pos.Chain.Genesis as Genesis (Config (..),
                       configBlkSecurityParam, configBlockVersionData,
                       configEpochSlots)
  import           Pos.Chain.Update (BlockVersion, BlockVersionData (..),
                       ConfirmedProposalState (..), DecidedProposalState (..),
                       DpsExtra (..), MonadPoll (..), MonadPollRead (..),
                       PollVerFailure (..), ProposalState (..),
                       SoftwareVersion (..), UndecidedProposalState (..), UpId,
                       UpdatePayload (..), UpdateProposal (..), UpdateVote (..),
                       UpsExtra (..), blockVersionL, bvdUpdateProposalThd,
                       checkUpdatePayload, psProposal)
  import           Pos.Core (BlockCount, ChainDifficulty (..), Coin, EpochIndex,
                       SlotCount, SlotId (..), addressHash, applyCoinPortionUp,
                       coinToInteger, difficultyL, epochIndexL, flattenSlotId,
                       sumCoins, unflattenSlotId, unsafeIntegerToCoin)
  import           Pos.Core.Attributes (areAttributesKnown)
  import           Pos.Crypto (hash, shortHashF)
  import           Pos.DB.Update.Poll.Logic.Base (canBeAdoptedBV,
                       canCreateBlockBV, confirmBlockVersion, isDecided,
                       mkTotNegative, mkTotPositive, mkTotSum, putNewProposal,
                       voteToUProposalState)
  import           Pos.DB.Update.Poll.Logic.Version (verifyAndApplyProposalBVS,
                       verifyBlockAndSoftwareVersions)
  import           Pos.Util.Some (Some (..))
  import           Pos.Util.Wlog (logDebug, logInfo, logNotice)
  
  type ApplyMode m =
      ( MonadError PollVerFailure m
      , MonadPoll m
      )
  
  -- | Verify UpdatePayload with respect to data provided by
  -- MonadPoll. If data is valid it is also applied.  Otherwise
  -- PollVerificationFailure is thrown using MonadError type class.
  --
  -- The first argument specifies whether we should perform unknown data
  -- checks. Currently it means that if it's 'True', then proposal (if
  -- it exists) must not have unknown attributes.
  --
  -- When the second argument is 'Left epoch', it means that temporary payload
  -- for given slot is applied. In this case threshold for inclusion of proposal
  -- into block is intentionally not checked.
  -- When it is 'Right header', it means that payload from block with
  -- given header is applied and in this case threshold for update proposal is
  -- checked.
  verifyAndApplyUSPayload
      :: ApplyMode m
      => Genesis.Config
      -> BlockVersion
      -> Bool
      -> Either SlotId (Some IsMainHeader)
      -> UpdatePayload
      -> m ()
  verifyAndApplyUSPayload genesisConfig lastAdopted verifyAllIsKnown slotOrHeader upp@UpdatePayload {..} = do
      -- First of all, we verify data.
      either (throwError . PollInvalidUpdatePayload) pure
          =<< runExceptT (checkUpdatePayload (configProtocolMagic genesisConfig) upp)
      whenRight slotOrHeader $ verifyHeader lastAdopted
  
      unless isEmptyPayload $ do
          -- Then we split all votes into groups. One group consists of
          -- votes for proposal from payload. Each other group consists of
          -- votes for other proposals.
          let upId = hash <$> upProposal
          let votePredicate vote = maybe False (uvProposalId vote ==) upId
          let (curPropVotes, otherVotes) = partition votePredicate upVotes
          let otherGroups = NE.groupWith uvProposalId otherVotes
          -- When there is proposal in payload, it's verified and applied.
          whenJust upProposal $ verifyAndApplyProposal
              genesisBvd
              verifyAllIsKnown
              slotOrHeader
              curPropVotes
          -- Then we also apply votes from other groups.
          -- ChainDifficulty is needed, because proposal may become approved
          -- and then we'll need to track whether it becomes confirmed.
          let cd = case slotOrHeader of
                  Left  _ -> Nothing
                  Right h -> Just (h ^. difficultyL, h ^. headerHashG)
          mapM_ (verifyAndApplyVotesGroup genesisBvd cd) otherGroups
      -- If we are applying payload from block, we also check implicit
      -- agreement rule and depth of decided proposals (they can become
      -- confirmed/discarded).
      case slotOrHeader of
          Left _           -> pass
          Right mainHeader -> do
              applyImplicitAgreement
                  (configEpochSlots genesisConfig)
                  (mainHeader ^. headerSlotL)
                  (mainHeader ^. difficultyL)
                  (mainHeader ^. headerHashG)
              applyDepthCheck
                  (configBlkSecurityParam genesisConfig)
                  (mainHeader ^. epochIndexL)
                  (mainHeader ^. headerHashG)
                  (mainHeader ^. difficultyL)
    where
      genesisBvd = configBlockVersionData genesisConfig
      isEmptyPayload = isNothing upProposal && null upVotes
  
  -- Here we verify all US-related data from header.
  verifyHeader
      :: (MonadError PollVerFailure m, MonadPoll m, IsMainHeader mainHeader)
      => BlockVersion -> mainHeader -> m ()
  verifyHeader lastAdopted header = do
      let versionInHeader = header ^. blockVersionL
      unlessM (canCreateBlockBV lastAdopted versionInHeader) $ do
          throwError
              $ PollWrongHeaderBlockVersion versionInHeader lastAdopted
  
  -- Get stake of stakeholder who issued given vote as per given epoch.
  -- If stakeholder wasn't richman at that point, PollNotRichman is thrown.
  resolveVoteStake
      :: (MonadError PollVerFailure m, MonadPollRead m)
      => BlockVersionData -> EpochIndex -> Coin -> UpdateVote -> m Coin
  resolveVoteStake genesisBvd epoch totalStake vote = do
      let !id = addressHash (uvKey vote)
      thresholdPortion <- bvdUpdateProposalThd <$> getAdoptedBVData
      let threshold = applyCoinPortionUp thresholdPortion totalStake
      let errNotRichman mbStake = PollNotRichman id threshold mbStake
      stake <- note (errNotRichman Nothing) =<< getRichmanStake genesisBvd epoch id
      when (stake < threshold) $
          throwError $ errNotRichman (Just stake)
      return stake
  
  -- Do all necessary checks of new proposal and votes for it.
  -- If it's valid, apply. Specifically, these checks are done:
  --
  -- 1. Check that no one stakeholder sent two update proposals within current epoch.
  -- 2. If 'verifyAllIsKnown' is 'True', check that proposal has
  --    no unknown attributes.
  -- 3. Proposal must not exceed maximal proposal size.
  -- 4. Check that there is no active proposal with the same id.
  -- 5. Verify consistenty with BlockVersionState for protocol version from proposal.
  -- 6. Verify that protocol version from proposal can follow last adopted protocol version.
  -- 7. Check that numeric software version of application is 1 more than
  --    of last confirmed proposal for this application.
  -- 8. If 'slotOrHeader' is 'Right', also check that sum of positive votes
  --    for this proposal is enough (at least 'updateProposalThd').
  --
  -- If all checks pass, proposal is added. It can be in undecided or decided
  -- state (if it has enough voted stake at once).
  verifyAndApplyProposal
      :: (MonadError PollVerFailure m, MonadPoll m)
      => BlockVersionData
      -> Bool
      -> Either SlotId (Some IsMainHeader)
      -> [UpdateVote]
      -> UpdateProposal
      -> m ()
  verifyAndApplyProposal genesisBvd verifyAllIsKnown slotOrHeader votes
                             up@UnsafeUpdateProposal {..} = do
      let !upId = hash up
      let !upFromId = addressHash upFrom
      whenM (HS.member upFromId <$> getEpochProposers) $
          throwError $ PollMoreThanOneProposalPerEpoch upFromId upId
      let epoch = slotOrHeader ^. epochIndexL
      let proposalSize = biSize up
      proposalSizeLimit <- bvdMaxProposalSize <$> getAdoptedBVData
      when (verifyAllIsKnown && not (areAttributesKnown upAttributes)) $
          throwError
              $ PollUnknownAttributesInProposal upId upAttributes
      when (proposalSize > proposalSizeLimit) $
          throwError
              $ PollTooLargeProposal upId proposalSize proposalSizeLimit
      whenJustM (getProposal upId) $
          const $ throwError $ PollProposalAlreadyActive upId
      -- Here we verify consistency with regards to data from 'BlockVersionState'
      -- and update relevant state if necessary.
      verifyAndApplyProposalBVS upId epoch up
      -- Then we verify the block and software versions from proposal are valid
      verifyBlockAndSoftwareVersions upId up
      -- After that we resolve stakes of all votes.
      totalStake <- note (PollUnknownStakes epoch)
          =<< getEpochTotalStake genesisBvd epoch
      votesAndStakes <- mapM
          (\v -> (v, ) <$> resolveVoteStake genesisBvd epoch totalStake v)
          votes
      -- When necessary, we also check that proposal itself has enough
      -- positive votes to be included into block.
      when (isRight slotOrHeader) $
          verifyProposalStake totalStake votesAndStakes upId
      -- Finally we put it into context of MonadPoll together with votes for it.
      putNewProposal slotOrHeader totalStake votesAndStakes up
  
  -- Here we check that proposal has at least 'bvdUpdateProposalThd' stake of
  -- total stake in all positive votes for it.
  verifyProposalStake
      :: (MonadPollRead m, MonadError PollVerFailure m)
      => Coin -> [(UpdateVote, Coin)] -> UpId -> m ()
  verifyProposalStake totalStake votesAndStakes upId = do
      thresholdPortion <- bvdUpdateProposalThd <$> getAdoptedBVData
      let threshold = applyCoinPortionUp thresholdPortion totalStake
      let thresholdInt = coinToInteger threshold
      let votesSum =
              sumCoins . map snd . filter (uvDecision . fst) $ votesAndStakes
      logDebug $
          sformat
              ("Verifying stake for proposal "%shortHashF%
               ", threshold is "%int%", voted stake is "%int)
              upId thresholdInt votesSum
      when (votesSum < thresholdInt) $
          throwError
              $ PollSmallProposalStake
                    threshold
                    (unsafeIntegerToCoin votesSum)
                    upId
  
  -- Here we verify votes for proposal which is already active. Each
  -- vote must have enough stake as per distribution from epoch where
  -- proposal was added.
  -- We also verify that what votes correspond to real proposal in
  -- undecided state.
  -- Votes are assumed to be for the same proposal.
  verifyAndApplyVotesGroup
      :: ApplyMode m
      => BlockVersionData
      -> Maybe (ChainDifficulty, HeaderHash)
      -> NonEmpty UpdateVote
      -> m ()
  verifyAndApplyVotesGroup genesisBvd cd votes = mapM_ verifyAndApplyVote votes
    where
      upId = uvProposalId $ NE.head votes
      verifyAndApplyVote vote = do
          let !stakeholderId = addressHash . uvKey $ NE.head votes
              unknownProposalErr = PollUnknownProposal stakeholderId upId
          ps <- note unknownProposalErr =<< getProposal upId
          case ps of
              PSDecided _     -> throwError
                                     $ PollProposalIsDecided upId stakeholderId
              PSUndecided ups -> verifyAndApplyVoteDo genesisBvd cd ups vote
  
  -- Here we actually apply vote to stored undecided proposal.
  verifyAndApplyVoteDo
      :: ApplyMode m
      => BlockVersionData
      -> Maybe (ChainDifficulty, HeaderHash)
      -> UndecidedProposalState
      -> UpdateVote
      -> m ()
  verifyAndApplyVoteDo genesisBvd cd ups vote = do
      let e = siEpoch $ upsSlot ups
      totalStake <- note (PollUnknownStakes e) =<< getEpochTotalStake genesisBvd e
      voteStake <- resolveVoteStake genesisBvd e totalStake vote
      newUPS@UndecidedProposalState {..} <-
          voteToUProposalState (uvKey vote) voteStake (uvDecision vote) ups
      let newPS
              | Just decision <-
                   isDecided
                       (mkTotPositive upsPositiveStake)
                       (mkTotNegative upsNegativeStake)
                       (mkTotSum totalStake) =
                  PSDecided
                      DecidedProposalState
                      { dpsUndecided = newUPS
                      , dpsDecision = decision
                      , dpsDifficulty = fst <$> cd
                      , dpsExtra = DpsExtra . snd <$> cd <*> Just False
                      }
              | otherwise = PSUndecided newUPS
      insertActiveProposal newPS
  
  -- According to implicit agreement rule all proposals which were put
  -- into blocks earlier than 'updateImplicit' slots before slot
  -- of current block become implicitly decided (approved or rejected).
  -- If proposal's total positive stake is bigger than negative, it's
  -- approved. Otherwise it's rejected.
  applyImplicitAgreement
      :: MonadPoll m
      => SlotCount-> SlotId -> ChainDifficulty -> HeaderHash-> m ()
  applyImplicitAgreement epochSlots (flattenSlotId epochSlots -> slotId) cd hh = do
      BlockVersionData {..} <- getAdoptedBVData
      let oldSlot = unflattenSlotId epochSlots $ slotId - bvdUpdateImplicit
      -- There is no one implicit agreed proposal
      -- when slot of block is less than @bvdUpdateImplicit@
      unless (slotId < bvdUpdateImplicit) $
          mapM_ applyImplicitAgreementDo =<< getOldProposals oldSlot
    where
      applyImplicitAgreementDo ups = do
          let decided = makeImplicitlyDecided ups
          insertActiveProposal $ PSDecided decided
          let upId = hash $ upsProposal ups
              status | dpsDecision decided = "approved"
                     | otherwise = "rejected"
          logInfo $ sformat ("Proposal "%build%" is implicitly "%builder)
              upId status
      makeImplicitlyDecided ups@UndecidedProposalState {..} =
          DecidedProposalState
          { dpsUndecided = ups
          , dpsDecision = upsPositiveStake > upsNegativeStake
          , dpsDifficulty = Just cd
          , dpsExtra = Just $ DpsExtra hh True
          }
  
  -- All decided proposals which became decided more than
  -- 'blkSecurityParam' blocks deeper than current block become
  -- confirmed or discarded (approved become confirmed, rejected become
  -- discarded).
  applyDepthCheck
      :: forall m . ApplyMode m
      => BlockCount -> EpochIndex -> HeaderHash -> ChainDifficulty -> m ()
  applyDepthCheck k epoch hh (ChainDifficulty cd)
      | cd <= k = pass
      | otherwise = do
          deepProposals <- getDeepProposals (ChainDifficulty (cd - k))
          -- 1. Group proposals by application name
          -- 2. Sort proposals in each group by tuple
          --     (decision, whether decision is implicit, positive stake, slot when it has been proposed)
          -- 3. We discard all proposals in each group except the head
          -- 4. Concatenate all groups and process all proposals
          let winners =
                  concatMap (toList . discardAllExceptHead . NE.sortBy proposalCmp) $
                  NE.groupWith groupCriterion deepProposals
          unless (null deepProposals) $ mapM_ applyDepthCheckDo winners
    where
      upsAppName = svAppName . upSoftwareVersion . upsProposal
      discardAllExceptHead (a:|xs) = a :| map (\x->x {dpsDecision = False}) xs
      groupCriterion = upsAppName . dpsUndecided
      mkTuple a extra =
          ( dpsDecision a
          , not $ deImplicit extra
          , upsPositiveStake $ dpsUndecided a
          , upsSlot $ dpsUndecided a
          )
  
      -- This comparator chooses the most appropriate proposal among
      -- proposals of one app and with same chain difficulty.
      proposalCmp a b
        | Just extraA <- dpsExtra a
        , Just extraB <- dpsExtra b =
            compare (mkTuple b extraB) (mkTuple a extraA)
        -- The following checks just in case,
        -- if there are proposals without dpsExtra
        | Just _ <- dpsExtra a = LT
        | Just _ <- dpsExtra b = GT
        | otherwise =
            compare  (upsSlot $ dpsUndecided b) (upsSlot $ dpsUndecided a)
  
      applyDepthCheckDo :: DecidedProposalState -> m ()
      applyDepthCheckDo DecidedProposalState {..} = do
          let UndecidedProposalState {..} = dpsUndecided
          let sv = upSoftwareVersion upsProposal
          let bv = upBlockVersion upsProposal
          let upId = hash upsProposal
          let status | dpsDecision = "confirmed"
                     | otherwise = "discarded"
          when dpsDecision $ do
              setLastConfirmedSV sv
              DpsExtra {..} <-
                  note (PollInternalError "DPS extra: expected Just, but got Nothing")
                        dpsExtra
              UpsExtra {..} <-
                  note (PollInternalError "UPS extra: expected Just, but got Nothing")
                        upsExtra
              let cps = ConfirmedProposalState
                      { cpsUpdateProposal = upsProposal
                      , cpsVotes = upsVotes
                      , cpsPositiveStake = upsPositiveStake
                      , cpsNegativeStake = upsNegativeStake
                      , cpsImplicit = deImplicit
                      , cpsProposed = ueProposedBlk
                      , cpsDecided = deDecidedBlk
                      , cpsConfirmed = hh
                      , cpsAdopted = Nothing
                      }
              addConfirmedProposal cps
              proposals <- getProposalsByApp $ upsAppName dpsUndecided
              mapM_ (deactivateProposal . hash . psProposal) proposals
          needConfirmBV <- (dpsDecision &&) <$> canBeAdoptedBV bv
          if | needConfirmBV -> do
                 confirmBlockVersion epoch bv
                 logInfo $ sformat (build%" is competing now") bv
             | otherwise -> do
                 delBVState bv
                 logInfo $ sformat ("State of "%build%" is deleted") bv
          deactivateProposal upId
          logNotice $ sformat ("Proposal "%shortHashF%" is "%builder) upId status
  