content: {-# LANGUAGE RecordWildCards #-}
  
  -- | Logic of local data processing in Update System.
  
  module Pos.DB.Update.Logic.Global
         ( UpdateBlock
  
         , usApplyBlocks
         , usCanCreateBlock
         , usRollbackBlocks
         , usVerifyBlocks
         ) where
  
  import           Universum
  
  import           Control.Monad.Except (MonadError, runExceptT)
  import           Data.Default (Default (def))
  import           UnliftIO (MonadUnliftIO)
  
  import           Pos.Chain.Block (BlockHeader (..), ComponentBlock (..),
                       headerHashG, headerLeaderKeyL, headerSlotL)
  import           Pos.Chain.Genesis as Genesis (Config (..),
                       configBlkSecurityParam)
  import           Pos.Chain.Update (ApplicationName, BlockVersion,
                       BlockVersionData, BlockVersionState,
                       ConfirmedProposalState, ConsensusEra (..), MonadPoll,
                       NumSoftwareVersion, PollModifier (..), PollT,
                       PollVerFailure, ProposalState, SoftwareVersion (..),
                       USUndo, UpId, UpdateConfiguration, UpdatePayload,
                       blockVersionL, execPollT, execRollT, getAdoptedBV,
                       lastKnownBlockVersion, reportUnexpectedError, runPollT)
  import           Pos.Core (StakeholderId, addressHash, epochIndexL)
  import           Pos.Core.Chrono (NE, NewestFirst, OldestFirst (..))
  import           Pos.Core.Exception (reportFatalError)
  import           Pos.Core.Reporting (MonadReporting)
  import           Pos.Core.Slotting (EpochIndex (..), MonadSlotsData,
                       SlotId (..), SlottingData, slottingVar)
  import qualified Pos.DB.BatchOp as DB
  import qualified Pos.DB.BlockIndex as DB (getTipHeader)
  import qualified Pos.DB.Class as DB
  import           Pos.DB.Lrc (HasLrcContext)
  import           Pos.DB.Update.GState (UpdateOp (..), getConsensusEra)
  import           Pos.DB.Update.Poll.DBPoll (DBPoll, runDBPoll)
  import           Pos.DB.Update.Poll.Logic.Apply (verifyAndApplyUSPayload)
  import           Pos.DB.Update.Poll.Logic.Base (canCreateBlockBV)
  import           Pos.DB.Update.Poll.Logic.Rollback (rollbackUS)
  import           Pos.DB.Update.Poll.Logic.Softfork (processGenesisBlock,
                       recordBlockIssuance)
  import           Pos.Util.AssertMode (inAssertMode)
  import qualified Pos.Util.Modifier as MM
  import           Pos.Util.Util (HasLens', lensOf)
  import           Pos.Util.Wlog (WithLogger, logDebug, modifyLoggerName)
  
  
  ----------------------------------------------------------------------------
  -- UpdateBlock
  ----------------------------------------------------------------------------
  
  type UpdateBlock = ComponentBlock UpdatePayload
  
  ----------------------------------------------------------------------------
  -- Constraints
  ----------------------------------------------------------------------------
  
  type USGlobalVerifyMode ctx m =
      ( WithLogger m
      , MonadIO m
      , MonadReader ctx m
      , HasLrcContext ctx
      , HasLens' ctx UpdateConfiguration
      )
  
  type USGlobalApplyMode ctx m =
      ( USGlobalVerifyMode ctx m
      , DB.MonadDBRead m
      , MonadUnliftIO m
      , MonadSlotsData ctx m
      , MonadReporting m
      )
  
  ----------------------------------------------------------------------------
  -- Implementation
  ----------------------------------------------------------------------------
  
  withUSLogger :: WithLogger m => m a -> m a
  withUSLogger = modifyLoggerName (<> ".us")
  
  -- | Apply chain of /definitely/ valid blocks to US part of GState DB
  -- and to US local data. This function assumes that no other thread
  -- applies block in parallel. It also assumes that parent of oldest
  -- block is current tip.  If verification is done prior to
  -- application, one can pass 'PollModifier' obtained from verification
  -- to this function.
  --
  -- This function also updates in-memory state of slotting
  -- ('MonadSlotsData') whenever it should be updated. Note that at this
  -- point we can't be sure that blocks will be eventually applied to
  -- DB. So it can happen that we update in-memory data, but don't
  -- update DB. However, it's not a problem, because slotting data is
  -- stable, i. e. once we know it for some epoch, we can be sure it
  -- will never change. Also note that we store slotting data for all
  -- epochs in memory, so adding new one can't make anything worse.
  usApplyBlocks
      :: ( MonadThrow m
         , USGlobalApplyMode ctx m
         )
      => Genesis.Config
      -> OldestFirst NE UpdateBlock
      -> Maybe PollModifier
      -> m [DB.SomeBatchOp]
  usApplyBlocks genesisConfig blocks modifierMaybe =
      withUSLogger $
      processModifier =<<
      case modifierMaybe of
          Nothing -> do
              verdict <- usVerifyBlocks genesisConfig False blocks
              either onFailure (return . fst) verdict
          Just modifier -> do
              -- TODO: I suppose such sanity checks should be done at higher
              -- level.
              inAssertMode $ do
                  verdict <- usVerifyBlocks genesisConfig False blocks
                  whenLeft verdict $ \v -> onFailure v
              return modifier
    where
      onFailure failure = do
          let msg = "usVerifyBlocks failed in 'apply': " <> pretty failure
          reportFatalError msg
  
  -- | Revert application of given blocks to US part of GState DB and US local
  -- data. The caller must ensure that the tip stored in DB is 'headerHash' of
  -- head.
  usRollbackBlocks
      :: USGlobalApplyMode ctx m
      => NewestFirst NE (UpdateBlock, USUndo) -> m [DB.SomeBatchOp]
  usRollbackBlocks blunds = do
      uc <- view (lensOf @UpdateConfiguration)
      withUSLogger $
          processModifier =<<
          (runDBPoll uc . execPollT def $ mapM_ (rollbackUS . snd) blunds)
  
  -- This function takes a 'PollModifier' corresponding to a sequence of
  -- blocks, updates in-memory slotting data and converts this modifier
  -- to '[SomeBatchOp]'.
  processModifier :: MonadSlotsData ctx m => PollModifier -> m [DB.SomeBatchOp]
  processModifier pm@PollModifier {pmSlottingData = newSlottingData} =
      modifierToBatch pm <$ whenJust newSlottingData setNewSlottingData
    where
      setNewSlottingData newSD = do
          var <- view slottingVar
          atomically $ writeTVar var newSD
  
  -- | Verify whether sequence of blocks can be applied to US part of
  -- current GState DB.  This function doesn't make pure checks, they
  -- are assumed to be done earlier, most likely during objects
  -- construction.
  --
  -- If the first argument is 'True' it means that all data must be
  -- known. Currently it only means that 'UpdateProposal's must have
  -- only known attributes, but I can't guarantee this comment will
  -- always be up-to-date.
  --
  -- All blocks must be from the same epoch.
  usVerifyBlocks ::
         ( USGlobalVerifyMode ctx m
         , DB.MonadDBRead m
         , MonadUnliftIO m
         , MonadReporting m
         )
      => Genesis.Config
      -> Bool
      -> OldestFirst NE UpdateBlock
      -> m (Either PollVerFailure (PollModifier, OldestFirst NE USUndo))
  usVerifyBlocks genesisConfig verifyAllIsKnown blocks = do
      uc <- view (lensOf @UpdateConfiguration)
      withUSLogger $
          reportUnexpectedError $
          processRes <$> run uc (runExceptT action)
    where
      action = mapM (verifyBlock genesisConfig verifyAllIsKnown) blocks
      run :: UpdateConfiguration -> PollT (DBPoll n) a -> n (a, PollModifier)
      run uc = runDBPoll uc . runPollT def
      processRes ::
             (Either PollVerFailure (OldestFirst NE USUndo), PollModifier)
          -> Either PollVerFailure (PollModifier, OldestFirst NE USUndo)
      processRes (Left failure, _)       = Left failure
      processRes (Right undos, modifier) = Right (modifier, undos)
  
  verifyBlock ::
      ( USGlobalVerifyMode ctx m
      , DB.MonadDBRead m
      , MonadPoll m
      , MonadError PollVerFailure m
      )
      => Genesis.Config
      -> Bool
      -> UpdateBlock
      -> m USUndo
  verifyBlock genesisConfig _ (ComponentBlockGenesis genBlk) =
      execRollT $ processGenesisBlock genesisConfig (genBlk ^. epochIndexL)
  verifyBlock genesisConfig verifyAllIsKnown (ComponentBlockMain header payload) = do
      lastAdopted <- do
          -- During the `Original` era, `processGenesisBlock` is typically
          -- called from `verifyBlock` when provided with a
          -- `ComponentBlockGenesis` argument.
          --
          -- `processGenesisBlock` is responsible for some important
          -- operations which are to occur at the epoch boundary such as
          -- handling update adoption.
          --
          -- Since epoch boundary blocks aren't created during OBFT,
          -- we must ensure that we call `processGenesisBlock` on epoch
          -- boundaries (first slot of a new epoch) such that updates can still
          -- be adopted during OBFT.
          initialEra <- getConsensusEra
          initialBV  <- getAdoptedBV
          case initialEra of
              OBFT _ -> do
                  let slotId     = header ^. headerSlotL
                      epochIndex = siEpoch slotId
                  tipHeader <- DB.getTipHeader
                  whenEpochBoundaryObft epochIndex tipHeader $ \ei -> do
                      logDebug $ "usVerifyBlocks OBFT: We're on epoch boundary. Running processGenesisBlock"
                      processGenesisBlock genesisConfig ei
                  getAdoptedBV
  
              Original -> pure initialBV
  
      execRollT $ do
          verifyAndApplyUSPayload
              genesisConfig
              lastAdopted
              verifyAllIsKnown
              (Right header)
              payload
          -- Block issuance can't affect verification and application of US
          -- payload, so it's fine to separate it. Note, however, that it's
          -- important to do it after 'verifyAndApplyUSPayload', because there
          -- we assume that block version is confirmed.
          let leaderPk = header ^. headerLeaderKeyL
          recordBlockIssuance
              (configBlkSecurityParam genesisConfig)
              (addressHash leaderPk)
              (header ^. blockVersionL)
              (header ^. headerSlotL)
              (header ^. headerHashG)
    where
      whenEpochBoundaryObft ::
          ( Applicative m
          )
          => EpochIndex
          -> BlockHeader
          -> (EpochIndex -> m ())
          -> m ()
      whenEpochBoundaryObft currentEpoch tipHeader actn = do
          case tipHeader of
              BlockHeaderGenesis _ -> pass
              BlockHeaderMain mb ->
                  if mb ^. epochIndexL /= currentEpoch - 1
                      then pass
                      else actn currentEpoch
  
  -- | Checks whether our software can create block according to current
  -- global state.
  usCanCreateBlock ::
         ( WithLogger m
         , MonadUnliftIO m
         , DB.MonadDBRead m
         , MonadReader ctx m
         , HasLrcContext ctx
         , HasLens' ctx UpdateConfiguration
         )
      => m Bool
  usCanCreateBlock = do
      uc <- view (lensOf @UpdateConfiguration)
      withUSLogger $ runDBPoll uc $ do
          lastAdopted <- getAdoptedBV
          canCreateBlockBV lastAdopted (lastKnownBlockVersion uc)
  
  ----------------------------------------------------------------------------
  -- Conversion to batch
  ----------------------------------------------------------------------------
  
  modifierToBatch :: PollModifier -> [DB.SomeBatchOp]
  modifierToBatch PollModifier {..} =
      concat $
      [ bvsModifierToBatch (MM.insertions pmBVs) (MM.deletions pmBVs)
      , lastAdoptedModifierToBatch pmAdoptedBVFull
      , confirmedVerModifierToBatch
            (MM.insertions pmConfirmed)
            (MM.deletions pmConfirmed)
      , confirmedPropModifierToBatch
            (MM.insertions pmConfirmedProps)
            (MM.deletions pmConfirmedProps)
      , upModifierToBatch
            (MM.insertions pmActiveProps)
            (MM.deletions pmActiveProps)
      , sdModifierToBatch pmSlottingData
      , epModifierToBatch pmEpochProposers
      ]
  
  bvsModifierToBatch
      :: [(BlockVersion, BlockVersionState)]
      -> [BlockVersion]
      -> [DB.SomeBatchOp]
  bvsModifierToBatch added deleted = addOps ++ delOps
    where
      addOps = map (DB.SomeBatchOp . uncurry SetBVState) added
      delOps = map (DB.SomeBatchOp . DelBV) deleted
  
  lastAdoptedModifierToBatch :: Maybe (BlockVersion, BlockVersionData) -> [DB.SomeBatchOp]
  lastAdoptedModifierToBatch Nothing          = []
  lastAdoptedModifierToBatch (Just (bv, bvd)) = [DB.SomeBatchOp $ SetAdopted bv bvd]
  
  confirmedVerModifierToBatch
      :: [(ApplicationName, NumSoftwareVersion)]
      -> [ApplicationName]
      -> [DB.SomeBatchOp]
  confirmedVerModifierToBatch added deleted =
      addOps ++ delOps
    where
      addOps = map (DB.SomeBatchOp . ConfirmVersion . uncurry SoftwareVersion) added
      delOps = map (DB.SomeBatchOp . DelConfirmedVersion) deleted
  
  confirmedPropModifierToBatch
      :: [(SoftwareVersion, ConfirmedProposalState)]
      -> [SoftwareVersion]
      -> [DB.SomeBatchOp]
  confirmedPropModifierToBatch (map snd -> confAdded) confDeleted =
      confAddOps ++ confDelOps
    where
      confAddOps = map (DB.SomeBatchOp . AddConfirmedProposal) confAdded
      confDelOps = map (DB.SomeBatchOp . DelConfirmedProposal) confDeleted
  
  upModifierToBatch
      :: [(UpId, ProposalState)]
      -> [UpId]
      -> [DB.SomeBatchOp]
  upModifierToBatch (map snd -> added) deleted
        = addOps ++ delOps
    where
      addOps = map (DB.SomeBatchOp . PutProposal) added
      delOps = map (DB.SomeBatchOp . DeleteProposal) deleted
  
  sdModifierToBatch :: Maybe SlottingData -> [DB.SomeBatchOp]
  sdModifierToBatch Nothing   = []
  sdModifierToBatch (Just sd) = [DB.SomeBatchOp $ PutSlottingData sd]
  
  epModifierToBatch :: Maybe (HashSet StakeholderId) -> [DB.SomeBatchOp]
  epModifierToBatch Nothing   = []
  epModifierToBatch (Just ep) = [DB.SomeBatchOp $ PutEpochProposers ep]
  