{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE Rank2Types          #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

-- | A set of type classes which provide access to database.
--
-- 'MonadDBRead' contains reading and iterating capabilities. The
-- advantage of it is that you don't need to do any 'IO' to use it
-- which makes it suitable for pure testing.
-- 'MonadDBRead' also provides access to the Block DB.
--
-- 'MonadDB' is a superclass of 'MonadDB' and allows to modify
-- DB. Again, its purpose is to make it possible to use DB w/o IO
-- context.
--
-- 'MonadGState' contains functions to retrieve some data from
-- GState DB without knowledge of where this data is located (where in
-- code and where in DB, i. e. by which key). For example, if X wants
-- to get data maintained by Y and doesn't know about Y, it can use
-- 'MonadGState' (which is at pretty low level).
--
-- Described two classes have RocksDB implementation "DB.Rocks" and
-- pure one for testing "DB.Pure".

module Pos.DB.Class
       (
         -- * Pure
         DBTag (..)
       , DBIteratorClass (..)
       , IterType
       , MonadDBRead (..)
       , Serialized (..)
       , SerializedBlock
       , SerializedUndo
       , MonadBlockDBRead
       , getDeserialized
       , getBlock
       , MonadDB (..)

         -- * GState
       , MonadGState (..)
       , gsMaxBlockSize
       , gsMaxHeaderSize
       , gsMaxTxSize
       , gsMaxProposalSize
       , gsUnlockStakeEpoch
       , gsIsBootstrapEra
       ) where

import           Universum

import           Control.Monad.Morph (hoist)
import           Control.Monad.Trans (MonadTrans (..))
import           Control.Monad.Trans.Control (MonadBaseControl)
import           Control.Monad.Trans.Resource (ResourceT)
import           Data.Conduit (Source)
import qualified Database.RocksDB as Rocks
import           Serokell.Data.Memory.Units (Byte)

import           Pos.Binary.Class (Bi, decodeFull)
import           Pos.Binary.Core ()
import           Pos.Core (Block, BlockVersionData (..), EpochIndex, HasConfiguration, HeaderHash,
                           isBootstrapEra)
import           Pos.Core.Block (BlockchainHelpers, MainBlockchain)
import           Pos.DB.Error (DBError (DBMalformed))
import           Pos.Util.Util (eitherToThrow)

----------------------------------------------------------------------------
-- Pure
----------------------------------------------------------------------------

-- | Tag which denotes one of DBs used by application.
data DBTag
    = BlockIndexDB
    | GStateDB
    | LrcDB
    | MiscDB
    deriving (Eq)

-- | Key-value type family encapsulating the iterator (something we
-- can iterate on) functionality.
class DBIteratorClass i where
    type IterKey   i :: *
    type IterValue i :: *
    iterKeyPrefix :: ByteString

type IterType i = (IterKey i, IterValue i)

newtype Serialized a = Serialized
    { unSerialized :: ByteString
    }

data SerBlock
data SerUndo

type SerializedBlock = Serialized SerBlock
type SerializedUndo = Serialized SerUndo

-- | Pure read-only interface to the database.
class (HasConfiguration, MonadBaseControl IO m, MonadThrow m) => MonadDBRead m where
    -- | This function takes tag and key and reads value associated
    -- with given key from DB corresponding to given tag.
    dbGet :: DBTag -> ByteString -> m (Maybe ByteString)

    -- | Source producing iteration over given 'i'.
    dbIterSource ::
        ( DBIteratorClass i
        , Bi (IterKey i)
        , Bi (IterValue i)
        ) => DBTag -> Proxy i -> Source (ResourceT m) (IterType i)

    -- | Get block by header hash
    dbGetSerBlock :: HeaderHash -> m (Maybe SerializedBlock)

    -- | Get undo by header hash
    dbGetSerUndo :: HeaderHash -> m (Maybe SerializedUndo)

instance {-# OVERLAPPABLE #-}
    (MonadDBRead m, MonadTrans t, MonadThrow (t m), MonadBaseControl IO (t m)) =>
        MonadDBRead (t m)
  where
    dbGet tag = lift . dbGet tag
    dbIterSource tag (p :: Proxy i) =
        hoist (hoist lift) (dbIterSource tag p)
    dbGetSerBlock = lift . dbGetSerBlock
    dbGetSerUndo = lift . dbGetSerUndo


type MonadBlockDBRead m = (MonadDBRead m, BlockchainHelpers MainBlockchain)

getDeserialized
    :: (MonadBlockDBRead m, Bi v)
    => (x -> m (Maybe (Serialized tag))) -> x -> m (Maybe v)
getDeserialized getter x = getter x >>= \case
    Nothing  -> pure Nothing
    Just ser -> eitherToThrow $ bimap DBMalformed Just $ decodeFull $ unSerialized ser

getBlock :: MonadBlockDBRead m => HeaderHash -> m (Maybe Block)
getBlock = getDeserialized dbGetSerBlock

-- | Pure interface to the database. Combines read-only interface and
-- ability to put raw bytes.
class MonadDBRead m => MonadDB m where
    -- | This function takes tag, key and value and puts given value
    -- associated with given key into DB corresponding to given tag.
    dbPut :: DBTag -> ByteString -> ByteString -> m ()

    -- | Write batch of operations into DB corresponding to given
    -- tag. This write is atomic.
    --
    -- There are multiple candidates for a type representing batch
    -- operation, for instance:
    -- • Rocks.BatchOp is a good candidate because it's exactly what we want
    -- for pure implementation and it can be used as is for RocksDB.
    -- • We could define our own type for this class, but it would be an
    -- overkill.
    -- • 'SomeBatchOp' could also be used, but it seems to be overcomplication
    -- for such simple interface.
    --
    -- So a list of 'Rocks.BatchOp' was chosen.
    dbWriteBatch :: DBTag -> [Rocks.BatchOp] -> m ()

    -- | This function takes tag and key and deletes value associated
    -- with given key from DB corresponding to given tag.
    dbDelete :: DBTag -> ByteString -> m ()

    -- | Put given blund into the Block DB.
    dbPutSerBlund :: (Block, SerializedUndo) -> m ()

instance {-# OVERLAPPABLE #-}
    (MonadDB m, MonadTrans t, MonadThrow (t m), MonadBaseControl IO (t m)) =>
        MonadDB (t m)
  where
    dbPut = lift ... dbPut
    dbWriteBatch = lift ... dbWriteBatch
    dbDelete = lift ... dbDelete
    dbPutSerBlund = lift ... dbPutSerBlund

----------------------------------------------------------------------------
-- GState abstraction
----------------------------------------------------------------------------

-- | This type class provides functions to get core data from GState.
-- The idea is that actual getters may be defined at high levels, but
-- may be needed at lower levels.
--
-- This class doesn't have a 'MonadRealDB' constraint, because
-- alternative DBs my be used to provide this data.
class Monad m => MonadGState m where
    gsAdoptedBVData :: m BlockVersionData

instance MonadGState ((->) BlockVersionData) where
    gsAdoptedBVData = identity

instance {-# OVERLAPPABLE #-}
    (MonadGState m, MonadTrans t,
     Monad (t m)) =>
        MonadGState (t m)
  where
    gsAdoptedBVData = lift gsAdoptedBVData

gsMaxBlockSize :: MonadGState m => m Byte
gsMaxBlockSize = bvdMaxBlockSize <$> gsAdoptedBVData

gsMaxHeaderSize :: MonadGState m => m Byte
gsMaxHeaderSize = bvdMaxHeaderSize <$> gsAdoptedBVData

gsMaxTxSize :: MonadGState m => m Byte
gsMaxTxSize = bvdMaxTxSize <$> gsAdoptedBVData

gsMaxProposalSize :: MonadGState m => m Byte
gsMaxProposalSize = bvdMaxProposalSize <$> gsAdoptedBVData

gsUnlockStakeEpoch :: MonadGState m => m EpochIndex
gsUnlockStakeEpoch = bvdUnlockStakeEpoch <$> gsAdoptedBVData

-- | Checks if provided epoch is in the bootstrap era.
gsIsBootstrapEra :: MonadGState m => EpochIndex -> m Bool
gsIsBootstrapEra epoch = do
    unlockStakeEpoch <- gsUnlockStakeEpoch
    pure $ isBootstrapEra unlockStakeEpoch epoch
