content: {-# LANGUAGE Rank2Types      #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE TypeFamilies    #-}
  
  -- | Type classes for Poll abstraction.
  
  module Pos.Chain.Update.Poll.Class
         ( MonadPollRead (..)
         , MonadPoll (..)
  
         -- Roll Transformer
         , RollT
         , runRollT
         , execRollT
  
         -- Poll Transformer
         , PollT
         , runPollT
         , evalPollT
         , execPollT
         ) where
  
  import           Universum hiding (id)
  
  import           Control.Lens (uses, (%=), (.=))
  import           Control.Monad.Trans (MonadTrans)
  import           Data.Default (def)
  import qualified Data.HashMap.Strict as HM
  import qualified Data.HashSet as HS
  import qualified Data.List as List (find)
  import qualified Ether
  
  import           Pos.Chain.Update.ApplicationName (ApplicationName)
  import           Pos.Chain.Update.BlockVersion (BlockVersion)
  import           Pos.Chain.Update.BlockVersionData (BlockVersionData)
  import           Pos.Chain.Update.BlockVersionModifier (applyBVM)
  import           Pos.Chain.Update.Poll.Modifier (PollModifier (..),
                       pmActivePropsL, pmAdoptedBVFullL, pmBVsL, pmConfirmedL,
                       pmConfirmedPropsL, pmEpochProposersL, pmSlottingDataL)
  import           Pos.Chain.Update.Poll.Types (BlockVersionState,
                       BlockVersionState (..), ConfirmedProposalState,
                       DecidedProposalState (..), PrevValue, ProposalState (..),
                       USUndo (..), UndecidedProposalState (..), bvsIsConfirmed,
                       cpsSoftwareVersion, maybeToPrev, psProposal, unChangedBVL,
                       unChangedConfPropsL, unChangedPropsL, unChangedSVL,
                       unLastAdoptedBVL, unPrevProposersL, unSlottingDataL)
  import           Pos.Chain.Update.SoftwareVersion (NumSoftwareVersion,
                       SoftwareVersion (..))
  import           Pos.Chain.Update.Vote (UpId, UpdateProposal (..))
  import           Pos.Core (ChainDifficulty, Coin, EpochIndex, SlotId,
                       StakeholderId, addressHash)
  import           Pos.Core.Slotting (SlottingData)
  import           Pos.Crypto (hash)
  import qualified Pos.Util.Modifier as MM
  import           Pos.Util.Util (ether)
  import           Pos.Util.Wlog (WithLogger, logWarning)
  
  ----------------------------------------------------------------------------
  -- Read-only
  ----------------------------------------------------------------------------
  
  -- | Type class which provides function necessary for read-only
  -- verification of US data.
  class (Monad m, WithLogger m) => MonadPollRead m where
      getBVState :: BlockVersion -> m (Maybe BlockVersionState)
      -- ^ Retrieve state of given block version.
      getProposedBVs :: m [BlockVersion]
      -- ^ Retrieve all proposed block versions.
      getEpochProposers :: m (HashSet StakeholderId)
      -- ^ Retrieve all stakeholders who proposed proposals in the current epoch.
      getCompetingBVStates :: m [(BlockVersion, BlockVersionState)]
      -- ^ Get all competing 'BlockVersion's and their states.
      getAdoptedBVFull :: m (BlockVersion, BlockVersionData)
      -- ^ Retrieve last adopted block version and its state.
      getLastConfirmedSV :: ApplicationName -> m (Maybe NumSoftwareVersion)
      -- ^ Get numeric component of last confirmed version of application
      getProposal :: UpId -> m (Maybe ProposalState)
      -- ^ Get active proposal
      getProposalsByApp :: ApplicationName -> m [ProposalState]
      -- ^ Get active proposals for the specified application.
      getConfirmedProposals :: m [ConfirmedProposalState]
      -- ^ Get all known confirmed proposals.
      getEpochTotalStake :: BlockVersionData -> EpochIndex -> m (Maybe Coin)
      -- ^ Get total stake from distribution corresponding to given epoch
      getRichmanStake :: BlockVersionData -> EpochIndex -> StakeholderId -> m (Maybe Coin)
      -- ^ Get stake of ricmhan corresponding to given epoch (if she is
      -- really rich)
      getOldProposals :: SlotId -> m [UndecidedProposalState]
      -- ^ Get all proposals which are in undecided state and were
      -- included into block with slot less than or equal to given.
      getDeepProposals :: ChainDifficulty -> m [DecidedProposalState]
      -- ^ Get all proposals which are in decided state and become
      -- decided deeper than given 'ChainDifficulty'.
      getBlockIssuerStake :: EpochIndex -> StakeholderId -> m (Maybe Coin)
      -- ^ Get stake of issuer of one of the blocks created so far using
      -- stake distribution which is stable in given epoch.
      -- Only issuer of stable block can be passed to this function, otherwise
      -- 'Nothing' will be returned.
      getSlottingData :: m SlottingData
      -- ^ Get most recent 'SlottingData'.
  
      getAdoptedBV :: m BlockVersion
      getAdoptedBV = fst <$> getAdoptedBVFull
  
      getAdoptedBVData :: m BlockVersionData
      getAdoptedBVData = snd <$> getAdoptedBVFull
  
  instance {-# OVERLAPPABLE #-}
      (MonadPollRead m, MonadTrans t, Monad (t m), WithLogger (t m)) =>
          MonadPollRead (t m)
    where
      getBVState = lift . getBVState
      getProposedBVs = lift getProposedBVs
      getEpochProposers = lift getEpochProposers
      getCompetingBVStates = lift getCompetingBVStates
      getAdoptedBVFull = lift getAdoptedBVFull
      getLastConfirmedSV = lift . getLastConfirmedSV
      getProposal = lift . getProposal
      getProposalsByApp = lift . getProposalsByApp
      getConfirmedProposals = lift getConfirmedProposals
      getEpochTotalStake genesisBvd = lift . getEpochTotalStake genesisBvd
      getRichmanStake genesisBvd e = lift . getRichmanStake genesisBvd e
      getOldProposals = lift . getOldProposals
      getDeepProposals = lift . getDeepProposals
      getBlockIssuerStake e = lift . getBlockIssuerStake e
      getSlottingData = lift getSlottingData
  
  
  ----------------------------------------------------------------------------
  -- Writeable
  ----------------------------------------------------------------------------
  
  -- | Type class which provides function necessary for verification of
  -- US data with ability to modify state.
  class MonadPollRead m => MonadPoll m where
      putBVState :: BlockVersion -> BlockVersionState -> m ()
      -- ^ Put state of BlockVersion overriding if it exists.
      delBVState :: BlockVersion -> m ()
      -- ^ Delete BlockVersion and associated state.
      setAdoptedBV :: BlockVersion -> m ()
      -- ^ Set last adopted block version. State is taken from competing states.
      setLastConfirmedSV :: SoftwareVersion -> m ()
      -- ^ Set last confirmed version of application.
      delConfirmedSV :: ApplicationName -> m ()
      -- ^ Del last confirmed version of application.
      addConfirmedProposal :: ConfirmedProposalState -> m ()
      -- ^ Add new confirmed update proposal.
      delConfirmedProposal :: SoftwareVersion -> m ()
      -- ^ Del confirmed update proposal (for rollback only).
      insertActiveProposal :: ProposalState -> m ()
      -- ^ Add new active proposal with its state.
      deactivateProposal :: UpId -> m ()
      -- ^ Delete active proposal given its name and identifier.
      setSlottingData :: SlottingData -> m ()
      -- ^ Set most recent 'SlottingData'.
      setEpochProposers :: HashSet StakeholderId -> m ()
      -- ^ Set proposers.
  
  instance {-# OVERLAPPABLE #-}
      (MonadPoll m, MonadTrans t, Monad (t m), WithLogger (t m)) =>
          MonadPoll (t m)
    where
      putBVState pv = lift . putBVState pv
      delBVState = lift . delBVState
      setAdoptedBV = lift . setAdoptedBV
      setLastConfirmedSV = lift . setLastConfirmedSV
      delConfirmedSV = lift . delConfirmedSV
      addConfirmedProposal = lift . addConfirmedProposal
      delConfirmedProposal = lift . delConfirmedProposal
      insertActiveProposal = lift . insertActiveProposal
      deactivateProposal = lift . deactivateProposal
      setSlottingData = lift . setSlottingData
      setEpochProposers = lift . setEpochProposers
  
  ----------------------------------------------------------------------------
  -- Roll Transformer
  ----------------------------------------------------------------------------
  
  type RollT m = Ether.LazyStateT' USUndo m
  
  -- | Monad transformer which stores USUndo and implements writable
  -- MonadPoll. Its purpose is to collect data necessary for rollback.
  --
  -- [WARNING] This transformer uses StateT and is intended for
  -- single-threaded usage only.
  instance (MonadPoll m) => MonadPoll (RollT m) where
      putBVState bv sv = ether $ do
          insertIfNotExist bv unChangedBVL getBVState
          putBVState bv sv
  
      delBVState bv = ether $ do
          insertIfNotExist bv unChangedBVL getBVState
          delBVState bv
  
      setAdoptedBV = setValueWrapper unLastAdoptedBVL getAdoptedBV setAdoptedBV
  
      setLastConfirmedSV sv@SoftwareVersion{..} = ether $ do
          insertIfNotExist svAppName unChangedSVL getLastConfirmedSV
          setLastConfirmedSV sv
  
      -- can't be called during apply
      delConfirmedSV = lift . delConfirmedSV
  
      addConfirmedProposal cps = ether $ do
          confProps <- getConfirmedProposals
          insertIfNotExist (cpsSoftwareVersion cps) unChangedConfPropsL (getter confProps)
          addConfirmedProposal cps
        where
          getter confs sv = pure $ List.find (\x -> cpsSoftwareVersion x == sv) confs
  
      -- can't be called during apply
      delConfirmedProposal = lift . delConfirmedProposal
  
      insertActiveProposal ps = ether $ do
          whenNothingM_ (use unPrevProposersL) $ do
              prev <- getEpochProposers
              unPrevProposersL .= Just prev
          insertIfNotExist (hash $ psProposal $ ps) unChangedPropsL getProposal
          insertActiveProposal ps
  
      deactivateProposal id = ether $ do
          -- Proposer still can't propose new updates in the current epoch
          -- even if his update was deactivated in the same epoch
          insertIfNotExist id unChangedPropsL getProposal
          deactivateProposal id
  
      setSlottingData =
          setValueWrapper unSlottingDataL getSlottingData setSlottingData
      setEpochProposers =
          setValueWrapper unPrevProposersL getEpochProposers setEpochProposers
  
  -- This is a convenient wrapper for functions which should set some
  -- value and this change should be recorded in USUndo. If change of
  -- such kind is already recorded in 'USUndo', then we don't record it
  -- and just propagate the new value to the underlying 'MonadPoll'. If
  -- it is not recorded, we put old value into 'USUndo' before
  -- propagating the new value.
  setValueWrapper ::
         MonadPoll m
      => Lens' USUndo (Maybe a)
      -> m a
      -> (a -> m ())
      -> a
      -> RollT m ()
  setValueWrapper lens getAction setAction value = ether $ do
      whenNothingM_ (use lens) $ do
          prev <- lift getAction
          lens .= Just prev
      lift (setAction value)
  
  insertIfNotExist
      :: (Eq a, Hashable a, MonadState USUndo m)
      => a
      -> Lens' USUndo (HashMap a (PrevValue b))
      -> (a -> m (Maybe b))
      -> m ()
  insertIfNotExist id setter getter = do
      whenNothingM_ (HM.lookup id <$> use setter) $ do
          prev <- getter id
          setter %= HM.insert id (maybeToPrev prev)
  
  runRollT :: RollT m a -> m (a, USUndo)
  runRollT = flip Ether.runLazyStateT def
  
  execRollT :: Monad m => RollT m a -> m USUndo
  execRollT = flip Ether.execLazyStateT def
  
  ----------------------------------------------------------------------------
  -- PollT Transformer
  ----------------------------------------------------------------------------
  
  -- | Monad transformer which stores PollModifier and implements
  -- writable MonadPoll.
  --
  -- [WARNING] This transformer uses StateT and is intended for
  -- single-threaded usage only.
  type PollT = Ether.LazyStateT' PollModifier
  
  runPollT :: PollModifier -> PollT m a -> m (a, PollModifier)
  runPollT = flip Ether.runLazyStateT
  
  evalPollT :: Monad m => PollModifier -> PollT m a -> m a
  evalPollT = flip Ether.evalLazyStateT
  
  execPollT :: Monad m => PollModifier -> PollT m a -> m PollModifier
  execPollT = flip Ether.execLazyStateT
  
  instance (MonadPollRead m) =>
           MonadPollRead (PollT m) where
      getBVState pv = ether $
          MM.lookupM getBVState pv =<< use pmBVsL
      getProposedBVs = ether $
          MM.keysM getProposedBVs =<< use pmBVsL
      getEpochProposers = ether $ do
          new <- use pmEpochProposersL
          maybe getEpochProposers pure new
      getCompetingBVStates = ether $
          filter (bvsIsConfirmed . snd) <$>
          (MM.toListM getCompetingBVStates =<< use pmBVsL)
      getAdoptedBVFull = ether $
          maybe getAdoptedBVFull pure =<< use pmAdoptedBVFullL
      getLastConfirmedSV appName = ether $
          MM.lookupM getLastConfirmedSV appName =<< use pmConfirmedL
      getProposal upId = ether $
          MM.lookupM getProposal upId =<< use pmActivePropsL
      getProposalsByApp app = ether $ do
          let eqApp = (== app) . svAppName . upSoftwareVersion . psProposal . snd
          props <- uses pmActivePropsL (filter eqApp . MM.insertions)
          dbProps <- map (first (hash . psProposal) . join (,)) <$> getProposalsByApp app
          pure . toList . HM.fromList $ dbProps ++ props -- squash props with same upId
      getConfirmedProposals = ether $
          MM.valuesM
              (map (first cpsSoftwareVersion . join (,)) <$> getConfirmedProposals) =<<
          use pmConfirmedPropsL
      getEpochTotalStake genesisBvd = lift . getEpochTotalStake genesisBvd
      getRichmanStake genesisBvd e = lift . getRichmanStake genesisBvd e
      getOldProposals sl = ether $
          map snd <$>
          (MM.mapMaybeM getOldProposalPairs extractOld =<< use pmActivePropsL)
        where
          extractOld (PSUndecided ups)
              | upsSlot ups <= sl = Just ups
              | otherwise = Nothing
          extractOld (PSDecided _) = Nothing
          getOldProposalPairs =
              map (\ups -> (hash $ upsProposal ups, ups)) <$> getOldProposals sl
      getDeepProposals cd = ether $
          map snd <$>
          (MM.mapMaybeM getDeepProposalPairs extractDeep =<< use pmActivePropsL)
        where
          extractDeep (PSDecided dps)
              | Just propDifficulty <- dpsDifficulty dps
              , propDifficulty <= cd = Just dps
              | otherwise = Nothing
          extractDeep (PSUndecided _) = Nothing
          getDeepProposalPairs =
              map (\dps -> (hash $ upsProposal $ dpsUndecided dps, dps)) <$>
              getDeepProposals cd
      getBlockIssuerStake e = lift . getBlockIssuerStake e
      getSlottingData = ether $ do
          new <- gets pmSlottingData
          maybe getSlottingData pure new
  
  {-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}
  
  instance (MonadPollRead m) =>
           MonadPoll (PollT m) where
      putBVState bv st = ether $ pmBVsL %= MM.insert bv st
      delBVState bv = ether $ pmBVsL %= MM.delete bv
      setAdoptedBV bv = ether $ do
          bvs <- getBVState bv
          adoptedBVD <- getAdoptedBVData
          case bvs of
              Nothing ->
                  logWarning $ "setAdoptedBV: unknown version " <> pretty bv -- can't happen actually
              Just (bvsModifier -> bvm) ->
                  pmAdoptedBVFullL .= Just (bv, applyBVM bvm adoptedBVD)
      setLastConfirmedSV SoftwareVersion {..} = ether $
          pmConfirmedL %= MM.insert svAppName svNumber
      delConfirmedSV appName = ether $
          pmConfirmedL %= MM.delete appName
      addConfirmedProposal cps = ether $
          pmConfirmedPropsL %= MM.insert (cpsSoftwareVersion cps) cps
      delConfirmedProposal sv = ether $
          pmConfirmedPropsL %= MM.delete sv
      insertActiveProposal ps = do
          let up@UnsafeUpdateProposal{..} = psProposal ps
              upId = hash up
          whenNothingM_ (getProposal upId) $
              setEpochProposers =<< (HS.insert (addressHash upFrom) <$> getEpochProposers)
          ether $ pmActivePropsL %= MM.insert upId ps
      -- Deactivate proposal doesn't change epoch proposers.
      deactivateProposal id = do
          prop <- getProposal id
          whenJust prop $ \ps -> ether $ do
              let up = psProposal ps
                  upId = hash up
              pmActivePropsL %= MM.delete upId
      setSlottingData sd = ether $ pmSlottingDataL .= Just sd
      setEpochProposers ep = ether $ pmEpochProposersL .= Just ep
  