<commit_before>{-# LANGUAGE TypeFamilies  #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS -fno-warn-unused-top-binds #-} -- for lenses

{- |

The initialization mode is used to build the node context (node resources).
We need a separate mode for this because our initialization procedures require
database access, slotting, logging, etc.

The tricky part specific to this mode is the use of futures. Some parts of the
'InitModeContext' become available *during* initialization, so we create thunks
out of thin air and fill them as we go. This way 'InitMode' has all instances
it needs at all stages of initialization, but some of those instances can be
unusable until the relevant parts of the context are set.

-}

module Pos.Launcher.Mode
       ( InitMode
       , runInitMode
       , InitModeContext(..)
       , newInitFuture
       ) where

import           Universum

import           Control.Lens          (makeLensesWith)
import qualified Control.Monad.Reader  as Mtl
import           Ether.Internal        (HasLens (..))
import           Mockable.Production   (Production)
import           System.IO.Unsafe      (unsafeInterleaveIO)

import           Pos.Block.Core        (Block, BlockHeader)
import           Pos.Block.Types       (Undo)
import           Pos.Core              (HasCoreConstants, IsHeader, Timestamp)
import           Pos.DB                (NodeDBs)
import           Pos.DB.Block          (dbGetBlockDefault, dbGetBlockSscDefault,
                                        dbGetHeaderDefault, dbGetHeaderSscDefault,
                                        dbGetUndoDefault, dbGetUndoSscDefault,
                                        dbPutBlundDefault)
import           Pos.DB.Class          (MonadBlockDBGeneric (..),
                                        MonadBlockDBGenericWrite (..), MonadDB (..),
                                        MonadDBRead (..))
import           Pos.DB.Rocks          (dbDeleteDefault, dbGetDefault,
                                        dbIterSourceDefault, dbPutDefault,
                                        dbWriteBatchDefault)
import           Pos.Genesis           (GenesisContext, GenesisUtxo, GenesisWStakeholders)
import           Pos.Lrc.Context       (LrcContext)
import           Pos.Slotting          (HasSlottingVar (..), SlottingData)
import           Pos.Slotting.Class    (MonadSlots (..))
import           Pos.Slotting.Impl.Sum (SlottingContextSum, currentTimeSlottingSum,
                                        getCurrentSlotBlockingSum,
                                        getCurrentSlotInaccurateSum, getCurrentSlotSum)
import           Pos.Slotting.MemState (MonadSlotsData)
import           Pos.Ssc.Class.Helpers (SscHelpersClass)
import           Pos.Ssc.Class.Types   (SscBlock)
import           Pos.Util              (Some (..))
import           Pos.Util.Util         (postfixLFields)




-- | 'newInitFuture' creates a thunk and a procedure to fill it. This can be
-- used to create a data structure and initialize it gradually while doing some
-- IO (e.g. accessing the database).
-- There are two contracts the caller must obey:
-- * the thunk isn't forced until the procedure to fill it was called.
--   Violation of this contract will lead to an error:
--     "thread blocked indefinitely in an MVar operation".
-- * the procedure to fill the thunk is called at most one time or multiple
--   times but with equivalent values.  Violation of this contract will lead
--   to non-deterministic choice of which value will be used.
newInitFuture :: (MonadIO m, MonadIO m') => m (a, a -> m' ())
newInitFuture = do
    v <- newEmptyMVar
    r <- liftIO $ unsafeInterleaveIO (readMVar v)
    pure (r, putMVar v)

-- The fields are lazy on purpose: this allows using them with
-- futures.
data InitModeContext ssc = InitModeContext
    { imcNodeDBs            :: NodeDBs
    , imcGenesisContext     :: GenesisContext<commit_msg>[CSL-1536] Replace putMVar with tryPutMVar in newInitFuture<commit_after>{-# LANGUAGE TypeFamilies  #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS -fno-warn-unused-top-binds #-} -- for lenses

{- |

The initialization mode is used to build the node context (node resources).
We need a separate mode for this because our initialization procedures require
database access, slotting, logging, etc.

The tricky part specific to this mode is the use of futures. Some parts of the
'InitModeContext' become available *during* initialization, so we create thunks
out of thin air and fill them as we go. This way 'InitMode' has all instances
it needs at all stages of initialization, but some of those instances can be
unusable until the relevant parts of the context are set.

-}

module Pos.Launcher.Mode
       ( InitMode
       , runInitMode
       , InitModeContext(..)
       , newInitFuture
       ) where

import           Universum

import           Control.Exception     (throwIO)
import           Control.Lens          (makeLensesWith)
import qualified Control.Monad.Reader  as Mtl
import           Ether.Internal        (HasLens (..))
import           Mockable.Production   (Production)
import           System.IO.Unsafe      (unsafeInterleaveIO)

import           Pos.Block.Core        (Block, BlockHeader)
import           Pos.Block.Types       (Undo)
import           Pos.Core              (HasCoreConstants, IsHeader, Timestamp)
import           Pos.DB                (NodeDBs)
import           Pos.DB.Block          (dbGetBlockDefault, dbGetBlockSscDefault,
                                        dbGetHeaderDefault, dbGetHeaderSscDefault,
                                        dbGetUndoDefault, dbGetUndoSscDefault,
                                        dbPutBlundDefault)
import           Pos.DB.Class          (MonadBlockDBGeneric (..),
                                        MonadBlockDBGenericWrite (..), MonadDB (..),
                                        MonadDBRead (..))
import           Pos.DB.Rocks          (dbDeleteDefault, dbGetDefault,
                                        dbIterSourceDefault, dbPutDefault,
                                        dbWriteBatchDefault)
import           Pos.Genesis           (GenesisContext, GenesisUtxo, GenesisWStakeholders)
import           Pos.Lrc.Context       (LrcContext)
import           Pos.Slotting          (HasSlottingVar (..), SlottingData)
import           Pos.Slotting.Class    (MonadSlots (..))
import           Pos.Slotting.Impl.Sum (SlottingContextSum, currentTimeSlottingSum,
                                        getCurrentSlotBlockingSum,
                                        getCurrentSlotInaccurateSum, getCurrentSlotSum)
import           Pos.Slotting.MemState (MonadSlotsData)
import           Pos.Ssc.Class.Helpers (SscHelpersClass)
import           Pos.Ssc.Class.Types   (SscBlock)
import           Pos.Util              (Some (..))
import           Pos.Util.Util         (postfixLFields)


data FutureError = FutureAlreadyFilled
    deriving Show

instance Exception FutureError

-- | 'newInitFuture' creates a thunk and a procedure to fill it. This can be
-- used to create a data structure and initialize it gradually while doing some
-- IO (e.g. accessing the database).
-- There are two contracts the caller must obey:
-- * the thunk isn't forced until the procedure to fill it was called.
--   Violation of this contract will either block the thread forever or
--   trigger the error "thread blocked indefinitely in an MVar operation".
-- * the procedure to fill the thunk is called at most once.
--   Violation of this contract will throw `FutureAlreadyFilled`.
newInitFuture :: (MonadIO m, MonadIO m') => m (a, a -> m' ())
newInitFuture = do
    mvar <- newEmptyMVar
    thunk <- liftIO $ unsafeInterleaveIO (readMVar mvar)
    let setter value = assertSingleAssignment =<< tryPutMVar mvar value
    pure (thunk, setter)
  where
    assertSingleAssignment :: MonadIO m => Bool -> m ()
    assertSingleAssignment = \case
        True -> pure ()
        False -> liftIO $ throwIO FutureAlreadyFilled

-- The fields are lazy on purpose: this allows using them with
-- futures.
data InitModeContext ssc = InitModeContext
    { imcNodeDBs            :: NodeDBs
    , imcGenesisContext     :: GenesisContext
{'fraction_non_alphanumeric': 0.07099440797471432, 'fraction_numerical': 0.0004862630683199611, 'mean_word_length': 2.00036469730124, 'pattern_counts': {'":': 0, '<': 9, '<?xml version=': 0, '>': 11, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 18, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6789062', 'n_tokens_mistral': 2124, 'n_tokens_neox': 2077, 'n_words': 717}