{-# LANGUAGE AllowAmbiguousTypes #-}

-- | Workers responsible for Leaders and Richmen computation.
-- This module also contains high-level logic of LRC for historical
-- reasons.
-- And actually nowadays there are no workers here.

module Pos.DB.Block.Lrc
       ( LrcModeFull
       , lrcSingleShot
       ) where

import           Universum hiding (id)

import           Control.Exception.Safe (bracketOnError)
import           Control.Lens (views)
import           Control.Monad.STM (retry)
import           Data.Coerce (coerce)
import           Data.Conduit (ConduitT, runConduitRes, (.|))
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import           Formatting (build, sformat, (%))
import qualified System.Metrics.Counter as Metrics
import           UnliftIO (MonadUnliftIO)

import           Pos.Chain.Genesis as Genesis (Config (..),
                     configBlkSecurityParam, configBlockVersionData,
                     configEpochSlots, configK)
import           Pos.Chain.Lrc (LrcError (..), RichmenStakes,
                     findDelegationStakes, findRichmenStakes,
                     followTheSatoshiM)
import           Pos.Chain.Ssc (MonadSscMem, noReportNoSecretsForEpoch1)
import           Pos.Chain.Update (BlockVersionState (..), ConsensusEra (..))
import           Pos.Core (Coin, EpochIndex (..), EpochOrSlot (..), SharedSeed,
                     SlotCount, StakeholderId, crucialSlot, epochIndexL,
                     getEpochOrSlot)
import           Pos.Core.Chrono (NE, NewestFirst (..), toOldestFirst)
import           Pos.Core.Conc (forConcurrently)
import           Pos.Core.Reporting (HasMisbehaviorMetrics (..),
                     MisbehaviorMetrics (..))
import           Pos.Core.Slotting (MonadSlots)
import           Pos.Core.Util.TimeLimit (logWarningWaitLinear)
import qualified Pos.DB.Block.GState.SanityCheck as DB (sanityCheckDB)
import qualified Pos.DB.Block.Load as DB
import           Pos.DB.Block.Logic.Internal (BypassSecurityCheck (..),
                     MonadBlockApply, applyBlocksUnsafe, rollbackBlocksUnsafe)
import           Pos.DB.Block.Slog.Logic (ShouldCallBListener (..))
import           Pos.DB.Class (MonadDBRead, MonadGState)
import           Pos.DB.Delegation (getDelegators, isIssuerByAddressHash)
import qualified Pos.DB.GState.Stakes as GS (getRealStake, getRealTotalStake)
import           Pos.DB.Lrc (IssuersStakes, LrcConsumer (..), LrcContext (..),
                     LrcMode, LrcSyncData (..), allLrcConsumers, getSeed,
                     putEpoch, putIssuersStakes, putSeed)
import qualified Pos.DB.Lrc as LrcDB (hasLeaders, putLeadersForEpoch)
import           Pos.DB.Ssc (sscCalculateSeed)
import qualified Pos.DB.Txp.Stakes as GS
import           Pos.DB.Update (getCompetingBVStates, getConsensusEra)
import           Pos.Util (maybeThrow)
import           Pos.Util.Util (HasLens (..), intords)
import           Pos.Util.Wlog (logDebug, logInfo, logWarning)


----------------------------------------------------------------------------
-- Single shot
----------------------------------------------------------------------------

-- | 'LrcModeFull' contains all constraints necessary to launch LRC.
type LrcModeFull ctx m =
    ( LrcMode ctx m
    , MonadSscMem ctx m
    , MonadSlots ctx m
    , MonadBlockApply ctx m
    , MonadReader ctx m
    )

-- | Run leaders and richmen computation for given epoch. If stable
-- block for this epoch is not known, LrcError will be thrown.
-- It assumes that 'StateLock' is taken already.
lrcSingleShot
    :: forall ctx m
     . (LrcModeFull ctx m, HasMisbehaviorMetrics ctx)
    => Genesis.Config
    -> EpochIndex
    -> m ()
lrcSingleShot genesisConfig epoch = do
    lock <- views (lensOf @LrcContext) lcLrcSync
    logDebug $ sformat
        ("lrcSingleShot is trying to acquire LRC lock, the epoch is "
         %build) epoch
    tryAcquireExclusiveLock epoch lock onAcquiredLock
  where
    consumers = allLrcConsumers @ctx @m (configBlockVersionData genesisConfig)
    for_thEpochMsg = sformat (" for "%intords%" epoch") (getEpochIndex epoch)
    onAcquiredLock = do
        logDebug "lrcSingleShot has acquired LRC lock"
        (need, filteredConsumers) <-
            logWarningWaitLinear 5 "determining whether LRC is needed" $ do
                expectedRichmenComp <-
                    filterM (flip lcIfNeedCompute epoch) consumers
                needComputeLeaders <- not <$> LrcDB.hasLeaders epoch
                let needComputeRichmen = not . null $ expectedRichmenComp
                when needComputeLeaders $ logInfo
                    ("Need to compute leaders" <> for_thEpochMsg)
                when needComputeRichmen $ logInfo
                    ("Need to compute richmen" <> for_thEpochMsg)
                return $
                    ( needComputeLeaders || needComputeRichmen
                    , expectedRichmenComp)
        when need $ do
            logInfo "LRC is starting actual computation"
            lrcDo genesisConfig epoch filteredConsumers
            logInfo "LRC has finished actual computation"
        putEpoch epoch
        logInfo ("LRC has updated LRC DB" <> for_thEpochMsg)

tryAcquireExclusiveLock
    :: (MonadMask m, MonadIO m)
    => EpochIndex -> TVar LrcSyncData -> m () -> m ()
tryAcquireExclusiveLock epoch lock action =
    bracketOnError acquireLock (flip whenJust releaseLock) doAction
  where
    acquireLock = atomically $ do
        sync <- readTVar lock
        if | not (lrcNotRunning sync) {- i.e. lrc is running -} -> retry
           | lastEpochWithLrc sync >= epoch -> pure Nothing
           | lastEpochWithLrc sync == epoch - 1 -> do
                 writeTVar lock (LrcSyncData False (lastEpochWithLrc sync))
                 pure (Just (lastEpochWithLrc sync))
           | otherwise -> throwM UnknownBlocksForLrc
    releaseLock e = atomically $ writeTVar lock (LrcSyncData True e)
    doAction Nothing = pass
    doAction _       = action >> releaseLock epoch

lrcDo
    :: forall ctx m
     . ( LrcModeFull ctx m
       , HasMisbehaviorMetrics ctx
       )
    => Genesis.Config
    -> EpochIndex
    -> [LrcConsumer m]
    -> m ()
lrcDo genesisConfig epoch consumers = do
    era <- getConsensusEra
    blundsUpToGenesis <- DB.loadBlundsFromTipWhile genesisHash upToGenesis
    -- If there are blocks from 'epoch' it means that we somehow accepted them
    -- before running LRC for 'epoch'. It's very bad.
    unless (null blundsUpToGenesis) $ throwM LrcAfterGenesis
    -- We don't calculate the seed inside 'withBlocksRolledBack' because
    -- there are shares in those ~2k blocks that 'withBlocksRolledBack'
    -- rolls back.
    --
    -- However, it's important to check that there are blocks to
    -- rollback before computing ssc seed (because if there are no
    -- blocks, it doesn't make sense to do it).
    blundsToRollback <- DB.loadBlundsFromTipWhile genesisHash whileAfterCrucial
    blundsToRollbackNE <-
        maybeThrow UnknownBlocksForLrc (atLeastKNewestFirst blundsToRollback)
    case era of
        Original -> do
            seed <- sscCalculateSeed (configBlockVersionData genesisConfig) epoch >>= \case
                Right s -> do
                    logInfo $ sformat
                        ("Calculated seed for epoch "%build%" successfully") epoch
                    return s
                Left _ -> do
                    -- Critical error means that the system is in dangerous state.
                    -- For now let's consider all errors critical, maybe we'll revise it later.
                    unless (noReportNoSecretsForEpoch1 && epoch == 1) $ do
                        whenJustM (view misbehaviorMetrics) $ liftIO .
                            Metrics.inc . _mmSscFailures
                    getSeed (epoch - 1) >>=
                        maybeThrow (CanNotReuseSeedForLrc (epoch - 1))
            putSeed epoch seed
            -- Roll back to the crucial slot and calculate richmen, etc.
            withBlocksRolledBack blundsToRollbackNE $ do
                issuersAndRichmenComputationDo
                DB.sanityCheckDB $ configGenesisData genesisConfig
                leadersComputationDo (configEpochSlots genesisConfig) epoch seed

        OBFT _ -> do
            -- During OBFT, we don't need to perform any SSC operations such as
            -- calculating the seed for FTS. Also, we don't need to perform any
            -- leader schedule computations via `leadersComputationDo` since we
            -- follow a strict round-robin schedule for OBFT.
            --
            -- However, we do need to perform the issuers and richmen
            -- computations since update adoption depends on this data being
            -- available in the database.
            --
            -- There is a possibility for the richmen (calculated and stored
            -- in the db via `richmenComputationDo`) and the genesis
            -- stakeholders (which are utilized for the OBFT schedule) to
            -- diverge.
            withBlocksRolledBack blundsToRollbackNE $ do
                issuersAndRichmenComputationDo
                DB.sanityCheckDB $ configGenesisData genesisConfig
  where
    genesisHash = configGenesisHash genesisConfig
    atLeastKNewestFirst :: forall a. NewestFirst [] a -> Maybe (NewestFirst NE a)
    atLeastKNewestFirst l =
        if length l >= configK genesisConfig
        then coerce (nonEmpty @a) l
        else Nothing

    applyBack blunds = applyBlocksUnsafe genesisConfig scb blunds Nothing
    upToGenesis b = b ^. epochIndexL >= epoch
    whileAfterCrucial b = getEpochOrSlot b > crucial
    crucial = EpochOrSlot $ Right $ crucialSlot
        (configBlkSecurityParam genesisConfig)
        epoch
    bsc =
        -- LRC rollbacks temporarily to examine the state of the DB at the
        -- time of the crucial slot. The crucial slot may be further than 'blkSecurityParam'
        -- slots from the current one, so the security check must be disabled.
        BypassSecurityCheck True
    scb =
        -- We don't want to trigger BListener callback because
        -- LRC computation via rollback is an artificial solution
        -- and outer viewers mustn't know about it.
        ShouldCallBListener False
    issuersAndRichmenComputationDo = do
        issuersComputationDo epoch
        richmenComputationDo epoch consumers
    withBlocksRolledBack blunds =
        bracket_ (rollbackBlocksUnsafe genesisConfig bsc scb blunds)
                 (applyBack (toOldestFirst blunds))

issuersComputationDo :: forall ctx m . LrcMode ctx m => EpochIndex -> m ()
issuersComputationDo epochId = do
    issuers <- unionHSs .
               map (bvsIssuersStable . snd) <$>
               getCompetingBVStates
    issuersStakes <- foldM putIsStake mempty issuers
    putIssuersStakes epochId issuersStakes
  where
    unionHSs = foldl' (flip HS.union) mempty
    putIsStake :: IssuersStakes -> StakeholderId -> m IssuersStakes
    putIsStake hm id = GS.getRealStake id >>= \case
        Nothing ->
           hm <$ (logWarning $ sformat ("Stake for issuer "%build% " not found") id)
        Just stake -> pure $ HM.insert id stake hm

leadersComputationDo :: LrcMode ctx m
    => SlotCount
    -> EpochIndex
    -> SharedSeed
    -> m ()
leadersComputationDo epochSlots epochId seed =
    unlessM (LrcDB.hasLeaders epochId) $ do
        totalStake <- GS.getRealTotalStake
        leaders <-
            runConduitRes $ GS.stakeSource .| followTheSatoshiM epochSlots seed totalStake
        LrcDB.putLeadersForEpoch epochSlots epochId leaders

--------------------------------------------------------------------------------
-- Richmen
--------------------------------------------------------------------------------

richmenComputationDo
    :: forall ctx m.
       LrcMode ctx m
    => EpochIndex -> [LrcConsumer m] -> m ()
richmenComputationDo epochIdx consumers = unless (null consumers) $ do
    total <- GS.getRealTotalStake
    logDebug $ "Effective total stake: " <> pretty total
    consumersAndThds <-
        zip consumers <$> mapM (flip lcThreshold total) consumers
    let minThreshold :: Maybe Coin
        minThreshold = safeThreshold consumersAndThds (not . lcConsiderDelegated)
        minThresholdD :: Maybe Coin
        minThresholdD = safeThreshold consumersAndThds lcConsiderDelegated
    (richmen, richmenD) <- runConduitRes $
        GS.stakeSource .| findAllRichmenMaybe minThreshold minThresholdD
    logDebug $ "Size of richmen: " <> show (HM.size richmen)
    logDebug $ "Size of richmenD: " <> show (HM.size richmenD)
    let callCallback (cons, thd) =
            if lcConsiderDelegated cons
            then lcComputedCallback cons epochIdx total
                   (HM.filter (>= thd) richmenD)
            else lcComputedCallback cons epochIdx total
                   (HM.filter (>= thd) richmen)
    void $ forConcurrently consumersAndThds callCallback
  where
    safeThreshold consumersAndThds f =
        safeMinimum $ map snd $ filter (f . fst) consumersAndThds
    safeMinimum a
        | null a = Nothing
        | otherwise = Just $ minimum a

type MonadDBReadFull m = (MonadDBRead m, MonadGState m, MonadUnliftIO m)

-- Can it be improved using conduits?
-- | Find delegated richmen using precomputed usual richmen.
-- Do it using one pass by delegation DB.
findDelRichUsingPrecomp
    :: forall m.
       (MonadDBReadFull m)
    => RichmenStakes -> Coin -> m RichmenStakes
findDelRichUsingPrecomp precomputed thr = do
    (old, new) <-
        runConduitRes $
        getDelegators .|
        findDelegationStakes isIssuerByAddressHash GS.getRealStake thr
    -- attention: order of new and precomputed is important
    -- we want to use new stakes (computed from delegated) of precomputed richmen
    pure (new `HM.union` (precomputed `HM.difference` (HS.toMap old)))

-- | Find delegated richmen.
findDelegatedRichmen
    :: (MonadDBReadFull m)
    => Coin -> ConduitT (StakeholderId, Coin) Void m RichmenStakes
findDelegatedRichmen thr = do
    st <- findRichmenStakes thr
    lift $ findDelRichUsingPrecomp st thr

-- | Function considers all variants of computation
-- and compute using one pass by stake DB and one pass by delegation DB.
findAllRichmenMaybe
    :: forall m.
       (MonadDBReadFull m)
    => Maybe Coin -- ^ Eligibility threshold (optional)
    -> Maybe Coin -- ^ Delegation threshold (optional)
    -> ConduitT (StakeholderId, Coin) Void m (RichmenStakes, RichmenStakes)
findAllRichmenMaybe maybeT maybeTD
    | Just t <- maybeT
    , Just tD <- maybeTD = do
        let mn = min t tD
        richmenMin <- findRichmenStakes mn
        let richmen = HM.filter (>= t) richmenMin
        let precomputedD = HM.filter (>= tD) richmenMin
        richmenD <- lift $ findDelRichUsingPrecomp precomputedD tD
        pure (richmen, richmenD)
    | Just t <- maybeT = (,mempty) <$> findRichmenStakes t
    | Just tD <- maybeTD = (mempty,) <$> findDelegatedRichmen tD
    | otherwise = pure (mempty, mempty)

----------------------------------------------------------------------------
-- Worker
----------------------------------------------------------------------------

-- TODO CSL-359
--
-- This worker no longer exists. It was added as the first step
-- towards CSL-359. The idea is that we can start LRC before the end
-- of an epoch. We just need to check that rollback deeper than
-- 'crucialSlot' didn't happen. It's only an optimization which can be
-- quite crucial when there are many stakeholders.
--
-- It was deleted because of possible deadlock. This worker may start
-- doing LRC and try to acquire 'StateLock' while another thread may
-- hold 'StateLock' for block processing and try to start LRC.  So if
-- you are going to bring it back at some point, please take it into
-- account.  One way to avoid locking here is to do CSL-360, i. e. use
-- snapshot instead of locking.
--
-- You can find it in git history if you want to.
