{-# LANGUAGE RecordWildCards #-}

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

module Pos.DB.Update.Logic.Local
       (
         -- * Proposals
         isProposalNeeded
       , getLocalProposalNVotes
       , processProposal

         -- * Votes
       , isVoteNeeded
       , getLocalVote
       , processVote

         -- * Normalization
       , usNormalize
       , processNewSlot
       , usPreparePayload

       , clearUSMemPool
       ) where

import           Universum hiding (id)

import           Control.Concurrent.STM (modifyTVar', writeTVar)
import           Control.Lens (views)
import           Control.Monad.Except (runExceptT, throwError)
import           Data.Default (Default (def))
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import           Formatting (sformat, (%))
import           UnliftIO (MonadUnliftIO)

import           Pos.Binary.Class (biSize)
import           Pos.Chain.Block (HeaderHash)
import           Pos.Chain.Genesis as Genesis (Config, configBlockVersionData)
import           Pos.Chain.Update (BlockVersionData (..),
                     MonadPoll (deactivateProposal),
                     MonadPollRead (getProposal), PollModifier,
                     PollVerFailure (..), UpId, UpdateConfiguration,
                     UpdatePayload (..), UpdateProposal, UpdateVote (..),
                     canCombineVotes, evalPollT, execPollT, getAdoptedBV,
                     modifyPollModifier, psVotes, reportUnexpectedError,
                     runPollT)
import           Pos.Core (SlotId (..), slotIdF)
import           Pos.Core.Reporting (MonadReporting)
import           Pos.Crypto (PublicKey, shortHashF)
import           Pos.DB.Class (MonadDBRead)
import qualified Pos.DB.GState.Common as DB
import           Pos.DB.GState.Lock (StateLock)
import           Pos.DB.Lrc (HasLrcContext)
import           Pos.DB.Update.Context (UpdateContext (..))
import qualified Pos.DB.Update.GState as DB
import           Pos.DB.Update.MemState (LocalVotes, MemPool (..),
                     MemState (..), MemVar (mvState), UpdateProposals,
                     addToMemPool, withUSLock)
import           Pos.DB.Update.Poll.DBPoll (runDBPoll)
import           Pos.DB.Update.Poll.Logic.Apply (verifyAndApplyUSPayload)
import           Pos.DB.Update.Poll.Logic.Normalize (filterProposalsByThd,
                     normalizePoll, refreshPoll)
import           Pos.Util.Util (HasLens (..), HasLens')
import           Pos.Util.Wlog (WithLogger, logWarning)

type USLocalLogicMode ctx m =
    ( MonadIO m
    , MonadDBRead m
    , MonadUnliftIO m
    , WithLogger m
    , MonadReader ctx m
    , HasLens UpdateContext ctx UpdateContext
    , HasLens UpdateConfiguration ctx UpdateConfiguration
    , HasLrcContext ctx
    )

type USLocalLogicModeWithLock ctx m =
    ( USLocalLogicMode ctx m
    , MonadMask m
    , HasLens' ctx StateLock
    )

getMemPool
    :: (MonadReader ctx m, HasLens UpdateContext ctx UpdateContext, MonadIO m)
    => m MemPool
getMemPool = msPool <$>
    (readTVarIO . mvState =<< views (lensOf @UpdateContext) ucMemState)

clearUSMemPool
    :: (MonadReader ctx m, HasLens UpdateContext ctx UpdateContext, MonadIO m)
    => m ()
clearUSMemPool =
    atomically . flip modifyTVar' resetData . mvState =<< views (lensOf @UpdateContext) ucMemState
  where
    resetData memState = memState {msPool = def, msModifier = def}

getPollModifier
    :: (MonadReader ctx m, HasLens UpdateContext ctx UpdateContext, MonadIO m)
    => m PollModifier
getPollModifier = msModifier <$>
    (readTVarIO . mvState =<< views (lensOf @UpdateContext) ucMemState)

getLocalProposals
    :: (MonadReader ctx m, HasLens UpdateContext ctx UpdateContext, MonadIO m)
    => m UpdateProposals
getLocalProposals = mpProposals <$> getMemPool

getLocalVotes
    :: (MonadReader ctx m, HasLens UpdateContext ctx UpdateContext, MonadIO m)
    => m LocalVotes
getLocalVotes = mpLocalVotes <$> getMemPool

-- Fetch memory state from 'TVar', modify it, write back. No
-- synchronization is done, it's caller's responsibility.
modifyMemState
    :: (MonadIO m, MonadReader ctx m, HasLens UpdateContext ctx UpdateContext)
    => (MemState -> m MemState) -> m ()
modifyMemState action = do
    stateVar <- mvState <$> views (lensOf @UpdateContext) ucMemState
    ms <- readTVarIO stateVar
    newMS <- action ms
    atomically $ writeTVar stateVar newMS

----------------------------------------------------------------------------
-- Data exchange in general
----------------------------------------------------------------------------

processSkeleton ::
       ( USLocalLogicModeWithLock ctx m
       , MonadReporting m
       )
    => Genesis.Config
    -> UpdatePayload
    -> m (Either PollVerFailure ())
processSkeleton genesisConfig payload =
    reportUnexpectedError $
    withUSLock $
    runExceptT $
    modifyMemState $ \ms@MemState {..} -> do
        dbTip <- lift DB.getTip
        -- We must check tip here, because we can't be sure that tip
        -- in DB is the same as the tip in memory. Normally it will be
        -- the case, but if normalization fails, it won't be true.
        --
        -- If this equality holds, we can be sure that all further
        -- reads will be done for the same GState, because here we own
        -- global lock and nobody can modify GState.
        unless (dbTip == msTip) $ do
            let err = PollTipMismatch msTip dbTip
            throwError err
        maxBlockSize <- bvdMaxBlockSize <$> lift DB.getAdoptedBVData
        msIntermediate <-
            -- TODO: This is a rather arbitrary limit, we should revisit it (see CSL-1664)
            if | maxBlockSize * 2 <= mpSize msPool ->
                   lift (refreshMemPool (configBlockVersionData genesisConfig) ms)
               | otherwise -> pure ms
        processSkeletonDo msIntermediate
  where
    processSkeletonDo ms@MemState {..} = do
        uc <- view (lensOf @UpdateConfiguration)
        modifierOrFailure <-
            lift . runDBPoll uc . runExceptT . evalPollT msModifier . execPollT def $ do
                lastAdopted <- getAdoptedBV
                verifyAndApplyUSPayload genesisConfig lastAdopted True (Left msSlot) payload
        case modifierOrFailure of
            Left failure -> throwError failure
            Right modifier -> do
                let newModifier = modifyPollModifier msModifier modifier
                let newPool = addToMemPool payload msPool
                pure $ ms {msModifier = newModifier, msPool = newPool}

-- Remove most useless data from mem pool to make it smaller.
refreshMemPool
    :: ( MonadDBRead m
       , MonadUnliftIO m
       , MonadReader ctx m
       , HasLrcContext ctx
       , WithLogger m
       , HasLens' ctx UpdateConfiguration
       )
    => BlockVersionData -> MemState -> m MemState
refreshMemPool genesisBvd ms@MemState {..} = do
    uc <- view (lensOf @UpdateConfiguration)
    let MemPool {..} = msPool
    ((newProposals, newVotes), newModifier) <- runDBPoll uc . runPollT def
        $ refreshPoll genesisBvd msSlot mpProposals mpLocalVotes
    let newPool =
            MemPool
            { mpProposals = newProposals
            , mpLocalVotes = newVotes
            , mpSize = biSize newProposals + biSize newVotes
            }
    return ms {msModifier = newModifier, msPool = newPool}

----------------------------------------------------------------------------
-- Proposals
----------------------------------------------------------------------------

-- | This function returns true if update proposal with given
-- identifier should be requested.
isProposalNeeded
    :: (MonadReader ctx m, HasLens UpdateContext ctx UpdateContext, MonadIO m)
    => UpId -> m Bool
isProposalNeeded id = not . HM.member id <$> getLocalProposals

-- | Get update proposal with given id if it is known.
getLocalProposalNVotes
    :: (MonadReader ctx m, HasLens UpdateContext ctx UpdateContext, MonadIO m)
    => UpId -> m (Maybe (UpdateProposal, [UpdateVote]))
getLocalProposalNVotes id = do
    prop <- HM.lookup id <$> getLocalProposals
    votes <- getLocalVotes
    pure $
        case prop of
            Nothing -> Nothing
            Just p  -> Just (p, toList $ HM.lookupDefault mempty id votes)

-- | Process proposal received from network, checking it against
-- current state (global + local) and adding to local state if it's
-- valid with respect to it.
-- If proposal is added to store, 'Right ()' is returned.
-- Otherwise 'Left err' is returned and 'err' lets caller decide whether
-- sender could be sure that error would happen.
processProposal
    :: (USLocalLogicModeWithLock ctx m, MonadReporting m)
    => Genesis.Config
    -> UpdateProposal
    -> m (Either PollVerFailure ())
processProposal genesisConfig proposal =
    processSkeleton genesisConfig $ UpdatePayload (Just proposal) []

----------------------------------------------------------------------------
-- Votes
----------------------------------------------------------------------------

lookupVote :: UpId -> PublicKey -> LocalVotes -> Maybe UpdateVote
lookupVote propId pk locVotes = HM.lookup propId locVotes >>= HM.lookup pk

-- | This function returns true if update vote proposal with given
-- identifier issued by stakeholder with given PublicKey and with
-- given decision should be requested.
isVoteNeeded
    :: USLocalLogicMode ctx m
    => UpId -> PublicKey -> Bool -> m Bool
isVoteNeeded propId pk decision = do
    uc <- view (lensOf @UpdateConfiguration)
    modifier <- getPollModifier
    runDBPoll uc . evalPollT modifier $ do
        proposal <- getProposal propId
        case proposal of
            Nothing -> pure False
            Just ps  -> pure .
                canCombineVotes decision .
                HM.lookup pk .
                psVotes $ ps

-- | Get update vote for proposal with given id from given issuer and
-- with given decision if it is known.
getLocalVote
    :: (MonadReader ctx m, HasLens UpdateContext ctx UpdateContext, MonadIO m)
    => UpId -> PublicKey -> Bool -> m (Maybe UpdateVote)
getLocalVote propId pk decision = do
    voteMaybe <- lookupVote propId pk <$> getLocalVotes
    pure $
        case voteMaybe of
            Nothing -> Nothing
            Just vote
                | uvDecision vote == decision -> Just vote
                | otherwise -> Nothing

-- | Process vote received from network, checking it against
-- current state (global + local) and adding to local state if it's
-- valid with respect to it.
-- If vote is added to store, 'Right ()' is returned.
-- Otherwise 'Left err' is returned and 'err' lets caller decide whether
-- sender could be sure that error would happen.
processVote
    :: (USLocalLogicModeWithLock ctx m, MonadReporting m)
    => Genesis.Config
    -> UpdateVote
    -> m (Either PollVerFailure ())
processVote genesisConfig vote =
    processSkeleton genesisConfig $ UpdatePayload Nothing [vote]

----------------------------------------------------------------------------
-- Normalization and related
----------------------------------------------------------------------------

-- | Remove local data from memory state to make it consistent with
-- current GState.  This function assumes that GState is locked. It
-- tries to leave as much data as possible. It assumes that
-- 'stateLock' is taken.
usNormalize :: USLocalLogicMode ctx m => BlockVersionData -> m ()
usNormalize genesisBvd = do
    tip <- DB.getTip
    stateVar <- mvState <$> views (lensOf @UpdateContext) ucMemState
    atomically . writeTVar stateVar =<< usNormalizeDo genesisBvd (Just tip) Nothing

-- Normalization under lock.  Note that here we don't care whether tip
-- in mempool is the same as the one is DB, because we take payload
-- from mempool and apply it to empty mempool, so it depends only on
-- GState.
usNormalizeDo
    :: USLocalLogicMode ctx m
    => BlockVersionData -> Maybe HeaderHash -> Maybe SlotId -> m MemState
usNormalizeDo genesisBvd tip slot = do
    uc <- view (lensOf @UpdateConfiguration)
    stateVar <- mvState <$> views (lensOf @UpdateContext) ucMemState
    ms@MemState {..} <- readTVarIO stateVar
    let MemPool {..} = msPool
    ((newProposals, newVotes), newModifier) <- runDBPoll uc . runPollT def
        $ normalizePoll genesisBvd msSlot mpProposals mpLocalVotes
    let newTip = fromMaybe msTip tip
    let newSlot = fromMaybe msSlot slot
    let newPool =
            MemPool
            { mpProposals = newProposals
            , mpLocalVotes = newVotes
            , mpSize = biSize newProposals + biSize newVotes
            }
    let newMS =
            ms
            { msModifier = newModifier
            , msPool = newPool
            , msTip = newTip
            , msSlot = newSlot
            }
    return newMS

-- | Update memory state to make it correct for given slot.
processNewSlot
    :: USLocalLogicModeWithLock ctx m => BlockVersionData -> SlotId -> m ()
processNewSlot genesisBvd slotId =
    withUSLock $ processNewSlotNoLock genesisBvd slotId

processNewSlotNoLock :: USLocalLogicMode ctx m => BlockVersionData -> SlotId -> m ()
processNewSlotNoLock genesisBvd slotId = modifyMemState $ \ms@MemState{..} -> do
    if | msSlot >= slotId -> pure ms
       -- Crucial changes happen only when epoch changes.
       | siEpoch msSlot == siEpoch slotId -> pure $ ms {msSlot = slotId}
       | otherwise -> usNormalizeDo genesisBvd Nothing (Just slotId)

-- | Prepare UpdatePayload for inclusion into new block with given
-- SlotId based on given tip.  This function assumes that
-- 'stateLock' is taken and nobody can apply/rollback blocks in
-- parallel or modify US mempool.  Sometimes payload can't be
-- created. It can happen if we are trying to create block for slot
-- which has already passed, for example. Or if we have different tip
-- in mempool because normalization failed earlier.
--
-- If we can't obtain payload for block creation, we use empty
-- payload, because it's important to create blocks for system
-- maintenance (empty blocks are better than no blocks).
usPreparePayload ::
       USLocalLogicMode ctx m
    => BlockVersionData
    -> HeaderHash
    -> SlotId
    -> m UpdatePayload
usPreparePayload genesisBvd neededTip slotId@SlotId{..} = do
    -- First of all, we make sure that mem state corresponds to given
    -- slot.  If mem state corresponds to newer slot already, it won't
    -- be updated, but we don't want to create block in this case
    -- anyway.  In normal cases 'processNewSlot' can't fail here
    -- because of tip mismatch, because we are under 'stateLock'.
    processNewSlotNoLock genesisBvd slotId
    -- After that we normalize payload to be sure it's valid. We try
    -- to keep it valid anyway, but we decided to have an extra
    -- precaution. We also do it because here we need to eliminate all
    -- proposals which don't have enough positive stake for inclusion
    -- into block. We check that payload corresponds to requested slot
    -- and return it if it does.
    preparePayloadDo
  where
    preparePayloadDo = do
        uc <- view (lensOf @UpdateConfiguration)
        -- Normalization is done just in case, as said before
        MemState {..} <- usNormalizeDo genesisBvd Nothing (Just slotId)
        -- If slot doesn't match, we can't provide payload for this slot.
        if | msSlot /= slotId -> def <$
               logWarning (sformat slotMismatchFmt msSlot slotId)
           | msTip /= neededTip -> def <$
               logWarning (sformat tipMismatchFmt msTip neededTip)
           | otherwise -> do
               -- Here we remove proposals which don't have enough
               -- positive stake for inclusion into payload.
               let MemPool {..} = msPool
               (filteredProposals, bad) <- runDBPoll uc . evalPollT msModifier $
                   filterProposalsByThd genesisBvd siEpoch mpProposals
               runDBPoll uc . evalPollT msModifier $
                   finishPrepare bad filteredProposals mpLocalVotes
    slotMismatchFmt = "US payload can't be created due to slot mismatch "%
                      "(our payload is for "%
                       slotIdF%", but requested one is "%slotIdF%")"
    tipMismatchFmt =  "US payload can't be created due to tip mismatch "
                     %"(our payload is for "
                     %shortHashF%", but we want to create payload based on tip "
                     %shortHashF%")"

-- Here we basically choose only one proposal for inclusion and remove
-- all votes for other proposals.
finishPrepare
    :: MonadPoll m
    => HashSet UpId -> UpdateProposals -> LocalVotes -> m UpdatePayload
finishPrepare badProposals proposals votes = do
    proposalPair <- foldM findProposal Nothing $ HM.toList proposals
    mapM_ (deactivate (fst <$> proposalPair)) $ HM.toList proposals
    let allVotes :: [UpdateVote]
        allVotes = concatMap toList $ toList votes
    goodVotes <- filterM isVoteValid allVotes
    return $
        UpdatePayload {upProposal = snd <$> proposalPair, upVotes = goodVotes}
  where
    findProposal (Just x) _ = pure (Just x)
    findProposal Nothing x@(upId, _) =
        bool Nothing (Just x) <$> (isJust <$> getProposal upId)
    deactivate chosenUpId (upId, _)
        | chosenUpId == Just upId = pass
        | otherwise =
            deactivateProposal upId
    isVoteValid vote = do
        let id = uvProposalId vote
        proposalIsPresent <- isJust <$> getProposal id
        pure $ not (HS.member id badProposals) && proposalIsPresent
