{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- Dummy implementation of the database-layer, using 'MVar'. This may be good
-- for testing to compare with an implementation on a real data store, or to use
-- when compiling the wallet for targets which don't have SQLite.

module Cardano.Pool.DB.MVar
    ( newDBLayer
    ) where

import Prelude

import Cardano.Pool.DB
    ( DBLayer (..), ErrPointAlreadyExists (..) )
import Cardano.Pool.DB.Model
    ( ModelOp
    , PoolDatabase
    , PoolErr (..)
    , emptyPoolDatabase
    , mCleanDatabase
    , mCleanPoolMetadata
    , mListHeaders
    , mListPoolLifeCycleData
    , mListRegisteredPools
    , mListRetiredPools
    , mPutDelistedPools
    , mPutFetchAttempt
    , mPutHeader
    , mPutLastMetadataGC
    , mPutPoolMetadata
    , mPutPoolProduction
    , mPutPoolRegistration
    , mPutPoolRetirement
    , mPutSettings
    , mPutStakeDistribution
    , mReadCursor
    , mReadDelistedPools
    , mReadLastMetadataGC
    , mReadPoolLifeCycleStatus
    , mReadPoolMetadata
    , mReadPoolProduction
    , mReadPoolRegistration
    , mReadPoolRetirement
    , mReadSettings
    , mReadStakeDistribution
    , mReadSystemSeed
    , mReadTotalProduction
    , mRemovePools
    , mRemoveRetiredPools
    , mRollbackTo
    , mUnfetchedPoolMetadataRefs
    )
import Cardano.Wallet.Primitive.Slotting
    ( TimeInterpreter )
import Control.DeepSeq
    ( deepseq )
import Control.Monad
    ( void )
import Control.Monad.Trans.Except
    ( ExceptT (..) )
import Control.Monad.Trans.State.Strict
    ( runStateT )
import Data.Either
    ( fromRight )
import Data.Functor.Identity
    ( Identity )
import Data.Tuple
    ( swap )
import UnliftIO.Exception
    ( Exception, throwIO )
import UnliftIO.MVar
    ( MVar, modifyMVar, newMVar )

-- | Instantiate a new in-memory "database" layer that simply stores data in
-- a local MVar. Data vanishes if the software is shut down.
newDBLayer :: TimeInterpreter Identity -> IO (DBLayer IO)
newDBLayer :: TimeInterpreter Identity -> IO (DBLayer IO)
newDBLayer TimeInterpreter Identity
timeInterpreter = do
    MVar PoolDatabase
db <- PoolDatabase -> IO (MVar PoolDatabase)
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar PoolDatabase
emptyPoolDatabase
    DBLayer IO -> IO (DBLayer IO)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DBLayer IO -> IO (DBLayer IO)) -> DBLayer IO -> IO (DBLayer IO)
forall a b. (a -> b) -> a -> b
$ MVar PoolDatabase -> DBLayer IO
mkDBLayer MVar PoolDatabase
db
  where
    mkDBLayer :: MVar PoolDatabase -> DBLayer IO
mkDBLayer MVar PoolDatabase
db = DBLayer :: forall (m :: * -> *) (stm :: * -> *).
(MonadFail stm, MonadIO stm) =>
(BlockHeader -> PoolId -> ExceptT ErrPointAlreadyExists stm ())
-> (EpochNo -> stm (Map PoolId [BlockHeader]))
-> stm (Map PoolId (Quantity "block" Word64))
-> (EpochNo -> [(PoolId, Quantity "lovelace" Word64)] -> stm ())
-> (EpochNo -> stm [(PoolId, Quantity "lovelace" Word64)])
-> (Int -> stm [BlockHeader])
-> (PoolId -> stm PoolLifeCycleStatus)
-> (CertificatePublicationTime
    -> PoolRegistrationCertificate -> stm ())
-> (PoolId
    -> stm
         (Maybe (CertificatePublicationTime, PoolRegistrationCertificate)))
-> (CertificatePublicationTime
    -> PoolRetirementCertificate -> stm ())
-> (PoolId
    -> stm
         (Maybe (CertificatePublicationTime, PoolRetirementCertificate)))
-> (Int
    -> stm [(PoolId, StakePoolMetadataUrl, StakePoolMetadataHash)])
-> ((StakePoolMetadataUrl, StakePoolMetadataHash) -> stm ())
-> stm [PoolId]
-> (EpochNo -> stm [PoolRetirementCertificate])
-> (EpochNo -> stm [PoolLifeCycleStatus])
-> (StakePoolMetadataHash -> StakePoolMetadata -> stm ())
-> stm ()
-> stm (Map StakePoolMetadataHash StakePoolMetadata)
-> stm StdGen
-> (SlotNo -> stm ())
-> ([PoolId] -> stm ())
-> stm [PoolId]
-> ([PoolId] -> stm ())
-> (EpochNo -> stm [PoolRetirementCertificate])
-> (BlockHeader -> stm ())
-> (Int -> stm [BlockHeader])
-> stm Settings
-> (Settings -> stm ())
-> stm (Maybe POSIXTime)
-> (POSIXTime -> stm ())
-> stm ()
-> (forall a. stm a -> m a)
-> DBLayer m
DBLayer {IO [PoolId]
IO (Maybe POSIXTime)
IO ()
IO (Map PoolId (Quantity "block" Word64))
IO (Map StakePoolMetadataHash StakePoolMetadata)
IO StdGen
IO Settings
Int -> IO [(PoolId, StakePoolMetadataUrl, StakePoolMetadataHash)]
Int -> IO [BlockHeader]
[PoolId] -> IO ()
(StakePoolMetadataUrl, StakePoolMetadataHash) -> IO ()
SlotNo -> IO ()
POSIXTime -> IO ()
Settings -> IO ()
CertificatePublicationTime -> PoolRetirementCertificate -> IO ()
CertificatePublicationTime -> PoolRegistrationCertificate -> IO ()
EpochNo -> IO [(PoolId, Quantity "lovelace" Word64)]
EpochNo -> IO [PoolLifeCycleStatus]
EpochNo -> IO [PoolRetirementCertificate]
EpochNo -> IO (Map PoolId [BlockHeader])
EpochNo -> [(PoolId, Quantity "lovelace" Word64)] -> IO ()
BlockHeader -> IO ()
BlockHeader -> PoolId -> ExceptT ErrPointAlreadyExists IO ()
PoolId
-> IO
     (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
PoolId
-> IO
     (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
PoolId -> IO PoolLifeCycleStatus
StakePoolMetadataHash -> StakePoolMetadata -> IO ()
forall a. a -> a
forall a. IO a -> IO a
atomically :: forall a. IO a -> IO a
cleanDB :: IO ()
putLastMetadataGC :: POSIXTime -> IO ()
readLastMetadataGC :: IO (Maybe POSIXTime)
putSettings :: Settings -> IO ()
readSettings :: IO Settings
listHeaders :: Int -> IO [BlockHeader]
putHeader :: BlockHeader -> IO ()
removeRetiredPools :: EpochNo -> IO [PoolRetirementCertificate]
removePools :: [PoolId] -> IO ()
readDelistedPools :: IO [PoolId]
putDelistedPools :: [PoolId] -> IO ()
rollbackTo :: SlotNo -> IO ()
readSystemSeed :: IO StdGen
readPoolMetadata :: IO (Map StakePoolMetadataHash StakePoolMetadata)
removePoolMetadata :: IO ()
putPoolMetadata :: StakePoolMetadataHash -> StakePoolMetadata -> IO ()
listPoolLifeCycleData :: EpochNo -> IO [PoolLifeCycleStatus]
listRetiredPools :: EpochNo -> IO [PoolRetirementCertificate]
listRegisteredPools :: IO [PoolId]
putFetchAttempt :: (StakePoolMetadataUrl, StakePoolMetadataHash) -> IO ()
unfetchedPoolMetadataRefs :: Int -> IO [(PoolId, StakePoolMetadataUrl, StakePoolMetadataHash)]
readPoolRetirement :: PoolId
-> IO
     (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
putPoolRetirement :: CertificatePublicationTime -> PoolRetirementCertificate -> IO ()
readPoolRegistration :: PoolId
-> IO
     (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
putPoolRegistration :: CertificatePublicationTime -> PoolRegistrationCertificate -> IO ()
readPoolLifeCycleStatus :: PoolId -> IO PoolLifeCycleStatus
readPoolProductionCursor :: Int -> IO [BlockHeader]
readStakeDistribution :: EpochNo -> IO [(PoolId, Quantity "lovelace" Word64)]
putStakeDistribution :: EpochNo -> [(PoolId, Quantity "lovelace" Word64)] -> IO ()
readTotalProduction :: IO (Map PoolId (Quantity "block" Word64))
readPoolProduction :: EpochNo -> IO (Map PoolId [BlockHeader])
putPoolProduction :: BlockHeader -> PoolId -> ExceptT ErrPointAlreadyExists IO ()
atomically :: forall a. a -> a
readPoolMetadata :: IO (Map StakePoolMetadataHash StakePoolMetadata)
cleanDB :: IO ()
putLastMetadataGC :: POSIXTime -> IO ()
readLastMetadataGC :: IO (Maybe POSIXTime)
putSettings :: Settings -> IO ()
readSettings :: IO Settings
listHeaders :: Int -> IO [BlockHeader]
putHeader :: BlockHeader -> IO ()
removeRetiredPools :: EpochNo -> IO [PoolRetirementCertificate]
removePools :: [PoolId] -> IO ()
readDelistedPools :: IO [PoolId]
putDelistedPools :: [PoolId] -> IO ()
rollbackTo :: SlotNo -> IO ()
readSystemSeed :: IO StdGen
removePoolMetadata :: IO ()
putPoolMetadata :: StakePoolMetadataHash -> StakePoolMetadata -> IO ()
listPoolLifeCycleData :: EpochNo -> IO [PoolLifeCycleStatus]
listRetiredPools :: EpochNo -> IO [PoolRetirementCertificate]
listRegisteredPools :: IO [PoolId]
putFetchAttempt :: (StakePoolMetadataUrl, StakePoolMetadataHash) -> IO ()
unfetchedPoolMetadataRefs :: Int -> IO [(PoolId, StakePoolMetadataUrl, StakePoolMetadataHash)]
putPoolRetirement :: CertificatePublicationTime -> PoolRetirementCertificate -> IO ()
readPoolLifeCycleStatus :: PoolId -> IO PoolLifeCycleStatus
putPoolRegistration :: CertificatePublicationTime -> PoolRegistrationCertificate -> IO ()
readPoolProductionCursor :: Int -> IO [BlockHeader]
readStakeDistribution :: EpochNo -> IO [(PoolId, Quantity "lovelace" Word64)]
putStakeDistribution :: EpochNo -> [(PoolId, Quantity "lovelace" Word64)] -> IO ()
readTotalProduction :: IO (Map PoolId (Quantity "block" Word64))
readPoolProduction :: EpochNo -> IO (Map PoolId [BlockHeader])
putPoolProduction :: BlockHeader -> PoolId -> ExceptT ErrPointAlreadyExists IO ()
readPoolRetirement :: PoolId
-> IO
     (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
readPoolRegistration :: PoolId
-> IO
     (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
..}
      where
        readPoolRegistration :: PoolId
-> IO
     (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
readPoolRegistration =
            MVar PoolDatabase
-> ModelOp
     (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
-> IO
     (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
forall a. MVar PoolDatabase -> ModelOp a -> IO a
readPoolDB MVar PoolDatabase
db (ModelOp
   (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
 -> IO
      (Maybe (CertificatePublicationTime, PoolRegistrationCertificate)))
-> (PoolId
    -> ModelOp
         (Maybe (CertificatePublicationTime, PoolRegistrationCertificate)))
-> PoolId
-> IO
     (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolId
-> ModelOp
     (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
mReadPoolRegistration

        readPoolRetirement :: PoolId
-> IO
     (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
readPoolRetirement =
            MVar PoolDatabase
-> ModelOp
     (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
-> IO
     (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
forall a. MVar PoolDatabase -> ModelOp a -> IO a
readPoolDB MVar PoolDatabase
db (ModelOp
   (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
 -> IO
      (Maybe (CertificatePublicationTime, PoolRetirementCertificate)))
-> (PoolId
    -> ModelOp
         (Maybe (CertificatePublicationTime, PoolRetirementCertificate)))
-> PoolId
-> IO
     (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolId
-> ModelOp
     (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
mReadPoolRetirement

        putPoolProduction :: BlockHeader -> PoolId -> ExceptT ErrPointAlreadyExists IO ()
putPoolProduction BlockHeader
sl PoolId
pool = IO (Either ErrPointAlreadyExists ())
-> ExceptT ErrPointAlreadyExists IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrPointAlreadyExists ())
 -> ExceptT ErrPointAlreadyExists IO ())
-> IO (Either ErrPointAlreadyExists ())
-> ExceptT ErrPointAlreadyExists IO ()
forall a b. (a -> b) -> a -> b
$
            PoolId
pool PoolId
-> IO (Either ErrPointAlreadyExists ())
-> IO (Either ErrPointAlreadyExists ())
forall a b. NFData a => a -> b -> b
`deepseq`
                (PoolErr -> Maybe ErrPointAlreadyExists)
-> MVar PoolDatabase
-> ModelOp ()
-> IO (Either ErrPointAlreadyExists ())
forall err a.
(PoolErr -> Maybe err)
-> MVar PoolDatabase -> ModelOp a -> IO (Either err a)
alterPoolDB PoolErr -> Maybe ErrPointAlreadyExists
errPointAlreadyExists MVar PoolDatabase
db (BlockHeader -> PoolId -> ModelOp ()
mPutPoolProduction BlockHeader
sl PoolId
pool)

        readPoolProduction :: EpochNo -> IO (Map PoolId [BlockHeader])
readPoolProduction =
            MVar PoolDatabase
-> ModelOp (Map PoolId [BlockHeader])
-> IO (Map PoolId [BlockHeader])
forall a. MVar PoolDatabase -> ModelOp a -> IO a
readPoolDB MVar PoolDatabase
db (ModelOp (Map PoolId [BlockHeader])
 -> IO (Map PoolId [BlockHeader]))
-> (EpochNo -> ModelOp (Map PoolId [BlockHeader]))
-> EpochNo
-> IO (Map PoolId [BlockHeader])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeInterpreter Identity
-> EpochNo -> ModelOp (Map PoolId [BlockHeader])
mReadPoolProduction TimeInterpreter Identity
timeInterpreter

        readTotalProduction :: IO (Map PoolId (Quantity "block" Word64))
readTotalProduction =
            MVar PoolDatabase
-> ModelOp (Map PoolId (Quantity "block" Word64))
-> IO (Map PoolId (Quantity "block" Word64))
forall a. MVar PoolDatabase -> ModelOp a -> IO a
readPoolDB MVar PoolDatabase
db ModelOp (Map PoolId (Quantity "block" Word64))
mReadTotalProduction

        putStakeDistribution :: EpochNo -> [(PoolId, Quantity "lovelace" Word64)] -> IO ()
putStakeDistribution EpochNo
a0 [(PoolId, Quantity "lovelace" Word64)]
a1 =
            IO (Either Any ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Any ()) -> IO ()) -> IO (Either Any ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (PoolErr -> Maybe Any)
-> MVar PoolDatabase -> ModelOp () -> IO (Either Any ())
forall err a.
(PoolErr -> Maybe err)
-> MVar PoolDatabase -> ModelOp a -> IO (Either err a)
alterPoolDB (Maybe Any -> PoolErr -> Maybe Any
forall a b. a -> b -> a
const Maybe Any
forall a. Maybe a
Nothing) MVar PoolDatabase
db (EpochNo -> [(PoolId, Quantity "lovelace" Word64)] -> ModelOp ()
mPutStakeDistribution EpochNo
a0 [(PoolId, Quantity "lovelace" Word64)]
a1)

        readStakeDistribution :: EpochNo -> IO [(PoolId, Quantity "lovelace" Word64)]
readStakeDistribution =
            MVar PoolDatabase
-> ModelOp [(PoolId, Quantity "lovelace" Word64)]
-> IO [(PoolId, Quantity "lovelace" Word64)]
forall a. MVar PoolDatabase -> ModelOp a -> IO a
readPoolDB MVar PoolDatabase
db (ModelOp [(PoolId, Quantity "lovelace" Word64)]
 -> IO [(PoolId, Quantity "lovelace" Word64)])
-> (EpochNo -> ModelOp [(PoolId, Quantity "lovelace" Word64)])
-> EpochNo
-> IO [(PoolId, Quantity "lovelace" Word64)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochNo -> ModelOp [(PoolId, Quantity "lovelace" Word64)]
mReadStakeDistribution

        readPoolProductionCursor :: Int -> IO [BlockHeader]
readPoolProductionCursor =
            MVar PoolDatabase -> ModelOp [BlockHeader] -> IO [BlockHeader]
forall a. MVar PoolDatabase -> ModelOp a -> IO a
readPoolDB MVar PoolDatabase
db (ModelOp [BlockHeader] -> IO [BlockHeader])
-> (Int -> ModelOp [BlockHeader]) -> Int -> IO [BlockHeader]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ModelOp [BlockHeader]
mReadCursor

        putPoolRegistration :: CertificatePublicationTime -> PoolRegistrationCertificate -> IO ()
putPoolRegistration CertificatePublicationTime
cpt PoolRegistrationCertificate
cert = IO (Either Any ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
              (IO (Either Any ()) -> IO ()) -> IO (Either Any ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (PoolErr -> Maybe Any)
-> MVar PoolDatabase -> ModelOp () -> IO (Either Any ())
forall err a.
(PoolErr -> Maybe err)
-> MVar PoolDatabase -> ModelOp a -> IO (Either err a)
alterPoolDB (Maybe Any -> PoolErr -> Maybe Any
forall a b. a -> b -> a
const Maybe Any
forall a. Maybe a
Nothing) MVar PoolDatabase
db
              (ModelOp () -> IO (Either Any ()))
-> ModelOp () -> IO (Either Any ())
forall a b. (a -> b) -> a -> b
$ CertificatePublicationTime
-> PoolRegistrationCertificate -> ModelOp ()
mPutPoolRegistration CertificatePublicationTime
cpt PoolRegistrationCertificate
cert

        readPoolLifeCycleStatus :: PoolId -> IO PoolLifeCycleStatus
readPoolLifeCycleStatus =
            MVar PoolDatabase
-> ModelOp PoolLifeCycleStatus -> IO PoolLifeCycleStatus
forall a. MVar PoolDatabase -> ModelOp a -> IO a
readPoolDB MVar PoolDatabase
db (ModelOp PoolLifeCycleStatus -> IO PoolLifeCycleStatus)
-> (PoolId -> ModelOp PoolLifeCycleStatus)
-> PoolId
-> IO PoolLifeCycleStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolId -> ModelOp PoolLifeCycleStatus
mReadPoolLifeCycleStatus

        putPoolRetirement :: CertificatePublicationTime -> PoolRetirementCertificate -> IO ()
putPoolRetirement CertificatePublicationTime
cpt PoolRetirementCertificate
cert = IO (Either Any ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
            (IO (Either Any ()) -> IO ()) -> IO (Either Any ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (PoolErr -> Maybe Any)
-> MVar PoolDatabase -> ModelOp () -> IO (Either Any ())
forall err a.
(PoolErr -> Maybe err)
-> MVar PoolDatabase -> ModelOp a -> IO (Either err a)
alterPoolDB (Maybe Any -> PoolErr -> Maybe Any
forall a b. a -> b -> a
const Maybe Any
forall a. Maybe a
Nothing) MVar PoolDatabase
db
            (ModelOp () -> IO (Either Any ()))
-> ModelOp () -> IO (Either Any ())
forall a b. (a -> b) -> a -> b
$ CertificatePublicationTime
-> PoolRetirementCertificate -> ModelOp ()
mPutPoolRetirement CertificatePublicationTime
cpt PoolRetirementCertificate
cert

        unfetchedPoolMetadataRefs :: Int -> IO [(PoolId, StakePoolMetadataUrl, StakePoolMetadataHash)]
unfetchedPoolMetadataRefs =
            MVar PoolDatabase
-> ModelOp [(PoolId, StakePoolMetadataUrl, StakePoolMetadataHash)]
-> IO [(PoolId, StakePoolMetadataUrl, StakePoolMetadataHash)]
forall a. MVar PoolDatabase -> ModelOp a -> IO a
readPoolDB MVar PoolDatabase
db (ModelOp [(PoolId, StakePoolMetadataUrl, StakePoolMetadataHash)]
 -> IO [(PoolId, StakePoolMetadataUrl, StakePoolMetadataHash)])
-> (Int
    -> ModelOp [(PoolId, StakePoolMetadataUrl, StakePoolMetadataHash)])
-> Int
-> IO [(PoolId, StakePoolMetadataUrl, StakePoolMetadataHash)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> ModelOp [(PoolId, StakePoolMetadataUrl, StakePoolMetadataHash)]
mUnfetchedPoolMetadataRefs

        putFetchAttempt :: (StakePoolMetadataUrl, StakePoolMetadataHash) -> IO ()
putFetchAttempt =
            IO (Either Any ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Any ()) -> IO ())
-> ((StakePoolMetadataUrl, StakePoolMetadataHash)
    -> IO (Either Any ()))
-> (StakePoolMetadataUrl, StakePoolMetadataHash)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolErr -> Maybe Any)
-> MVar PoolDatabase -> ModelOp () -> IO (Either Any ())
forall err a.
(PoolErr -> Maybe err)
-> MVar PoolDatabase -> ModelOp a -> IO (Either err a)
alterPoolDB (Maybe Any -> PoolErr -> Maybe Any
forall a b. a -> b -> a
const Maybe Any
forall a. Maybe a
Nothing) MVar PoolDatabase
db (ModelOp () -> IO (Either Any ()))
-> ((StakePoolMetadataUrl, StakePoolMetadataHash) -> ModelOp ())
-> (StakePoolMetadataUrl, StakePoolMetadataHash)
-> IO (Either Any ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StakePoolMetadataUrl, StakePoolMetadataHash) -> ModelOp ()
mPutFetchAttempt

        listRegisteredPools :: IO [PoolId]
listRegisteredPools =
            MVar PoolDatabase -> ModelOp [PoolId] -> IO [PoolId]
forall a. MVar PoolDatabase -> ModelOp a -> IO a
readPoolDB MVar PoolDatabase
db ModelOp [PoolId]
mListRegisteredPools

        listRetiredPools :: EpochNo -> IO [PoolRetirementCertificate]
listRetiredPools =
            MVar PoolDatabase
-> ModelOp [PoolRetirementCertificate]
-> IO [PoolRetirementCertificate]
forall a. MVar PoolDatabase -> ModelOp a -> IO a
readPoolDB MVar PoolDatabase
db (ModelOp [PoolRetirementCertificate]
 -> IO [PoolRetirementCertificate])
-> (EpochNo -> ModelOp [PoolRetirementCertificate])
-> EpochNo
-> IO [PoolRetirementCertificate]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochNo -> ModelOp [PoolRetirementCertificate]
mListRetiredPools

        listPoolLifeCycleData :: EpochNo -> IO [PoolLifeCycleStatus]
listPoolLifeCycleData =
            MVar PoolDatabase
-> ModelOp [PoolLifeCycleStatus] -> IO [PoolLifeCycleStatus]
forall a. MVar PoolDatabase -> ModelOp a -> IO a
readPoolDB MVar PoolDatabase
db (ModelOp [PoolLifeCycleStatus] -> IO [PoolLifeCycleStatus])
-> (EpochNo -> ModelOp [PoolLifeCycleStatus])
-> EpochNo
-> IO [PoolLifeCycleStatus]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochNo -> ModelOp [PoolLifeCycleStatus]
mListPoolLifeCycleData

        putPoolMetadata :: StakePoolMetadataHash -> StakePoolMetadata -> IO ()
putPoolMetadata StakePoolMetadataHash
a0 StakePoolMetadata
a1 =
            IO (Either Any ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Any ()) -> IO ()) -> IO (Either Any ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (PoolErr -> Maybe Any)
-> MVar PoolDatabase -> ModelOp () -> IO (Either Any ())
forall err a.
(PoolErr -> Maybe err)
-> MVar PoolDatabase -> ModelOp a -> IO (Either err a)
alterPoolDB (Maybe Any -> PoolErr -> Maybe Any
forall a b. a -> b -> a
const Maybe Any
forall a. Maybe a
Nothing) MVar PoolDatabase
db (StakePoolMetadataHash -> StakePoolMetadata -> ModelOp ()
mPutPoolMetadata StakePoolMetadataHash
a0 StakePoolMetadata
a1)

        removePoolMetadata :: IO ()
removePoolMetadata =
            IO (Either Any ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Any ()) -> IO ()) -> IO (Either Any ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (PoolErr -> Maybe Any)
-> MVar PoolDatabase -> ModelOp () -> IO (Either Any ())
forall err a.
(PoolErr -> Maybe err)
-> MVar PoolDatabase -> ModelOp a -> IO (Either err a)
alterPoolDB (Maybe Any -> PoolErr -> Maybe Any
forall a b. a -> b -> a
const Maybe Any
forall a. Maybe a
Nothing) MVar PoolDatabase
db ModelOp ()
mCleanPoolMetadata

        readSystemSeed :: IO StdGen
readSystemSeed =
            MVar PoolDatabase
-> (PoolDatabase -> IO (PoolDatabase, StdGen)) -> IO StdGen
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar PoolDatabase
db (((StdGen, PoolDatabase) -> (PoolDatabase, StdGen))
-> IO (StdGen, PoolDatabase) -> IO (PoolDatabase, StdGen)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (StdGen, PoolDatabase) -> (PoolDatabase, StdGen)
forall a b. (a, b) -> (b, a)
swap (IO (StdGen, PoolDatabase) -> IO (PoolDatabase, StdGen))
-> (PoolDatabase -> IO (StdGen, PoolDatabase))
-> PoolDatabase
-> IO (PoolDatabase, StdGen)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolDatabase -> IO (StdGen, PoolDatabase)
mReadSystemSeed)

        rollbackTo :: SlotNo -> IO ()
rollbackTo =
            IO (Either Any ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Any ()) -> IO ())
-> (SlotNo -> IO (Either Any ())) -> SlotNo -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolErr -> Maybe Any)
-> MVar PoolDatabase -> ModelOp () -> IO (Either Any ())
forall err a.
(PoolErr -> Maybe err)
-> MVar PoolDatabase -> ModelOp a -> IO (Either err a)
alterPoolDB (Maybe Any -> PoolErr -> Maybe Any
forall a b. a -> b -> a
const Maybe Any
forall a. Maybe a
Nothing) MVar PoolDatabase
db (ModelOp () -> IO (Either Any ()))
-> (SlotNo -> ModelOp ()) -> SlotNo -> IO (Either Any ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeInterpreter Identity -> SlotNo -> ModelOp ()
mRollbackTo TimeInterpreter Identity
timeInterpreter

        putDelistedPools :: [PoolId] -> IO ()
putDelistedPools =
            IO (Either Any ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Any ()) -> IO ())
-> ([PoolId] -> IO (Either Any ())) -> [PoolId] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolErr -> Maybe Any)
-> MVar PoolDatabase -> ModelOp () -> IO (Either Any ())
forall err a.
(PoolErr -> Maybe err)
-> MVar PoolDatabase -> ModelOp a -> IO (Either err a)
alterPoolDB (Maybe Any -> PoolErr -> Maybe Any
forall a b. a -> b -> a
const Maybe Any
forall a. Maybe a
Nothing) MVar PoolDatabase
db (ModelOp () -> IO (Either Any ()))
-> ([PoolId] -> ModelOp ()) -> [PoolId] -> IO (Either Any ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PoolId] -> ModelOp ()
mPutDelistedPools

        readDelistedPools :: IO [PoolId]
readDelistedPools =
            MVar PoolDatabase -> ModelOp [PoolId] -> IO [PoolId]
forall a. MVar PoolDatabase -> ModelOp a -> IO a
readPoolDB MVar PoolDatabase
db ModelOp [PoolId]
mReadDelistedPools

        removePools :: [PoolId] -> IO ()
removePools =
            IO (Either Any ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Any ()) -> IO ())
-> ([PoolId] -> IO (Either Any ())) -> [PoolId] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolErr -> Maybe Any)
-> MVar PoolDatabase -> ModelOp () -> IO (Either Any ())
forall err a.
(PoolErr -> Maybe err)
-> MVar PoolDatabase -> ModelOp a -> IO (Either err a)
alterPoolDB (Maybe Any -> PoolErr -> Maybe Any
forall a b. a -> b -> a
const Maybe Any
forall a. Maybe a
Nothing) MVar PoolDatabase
db (ModelOp () -> IO (Either Any ()))
-> ([PoolId] -> ModelOp ()) -> [PoolId] -> IO (Either Any ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PoolId] -> ModelOp ()
mRemovePools

        removeRetiredPools :: EpochNo -> IO [PoolRetirementCertificate]
removeRetiredPools =
            (Either Any [PoolRetirementCertificate]
 -> [PoolRetirementCertificate])
-> IO (Either Any [PoolRetirementCertificate])
-> IO [PoolRetirementCertificate]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([PoolRetirementCertificate]
-> Either Any [PoolRetirementCertificate]
-> [PoolRetirementCertificate]
forall b a. b -> Either a b -> b
fromRight [])
                (IO (Either Any [PoolRetirementCertificate])
 -> IO [PoolRetirementCertificate])
-> (EpochNo -> IO (Either Any [PoolRetirementCertificate]))
-> EpochNo
-> IO [PoolRetirementCertificate]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolErr -> Maybe Any)
-> MVar PoolDatabase
-> ModelOp [PoolRetirementCertificate]
-> IO (Either Any [PoolRetirementCertificate])
forall err a.
(PoolErr -> Maybe err)
-> MVar PoolDatabase -> ModelOp a -> IO (Either err a)
alterPoolDB (Maybe Any -> PoolErr -> Maybe Any
forall a b. a -> b -> a
const Maybe Any
forall a. Maybe a
Nothing) MVar PoolDatabase
db
                (ModelOp [PoolRetirementCertificate]
 -> IO (Either Any [PoolRetirementCertificate]))
-> (EpochNo -> ModelOp [PoolRetirementCertificate])
-> EpochNo
-> IO (Either Any [PoolRetirementCertificate])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochNo -> ModelOp [PoolRetirementCertificate]
mRemoveRetiredPools

        putHeader :: BlockHeader -> IO ()
putHeader =
            IO (Either Any ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Any ()) -> IO ())
-> (BlockHeader -> IO (Either Any ())) -> BlockHeader -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolErr -> Maybe Any)
-> MVar PoolDatabase -> ModelOp () -> IO (Either Any ())
forall err a.
(PoolErr -> Maybe err)
-> MVar PoolDatabase -> ModelOp a -> IO (Either err a)
alterPoolDB (Maybe Any -> PoolErr -> Maybe Any
forall a b. a -> b -> a
const Maybe Any
forall a. Maybe a
Nothing) MVar PoolDatabase
db (ModelOp () -> IO (Either Any ()))
-> (BlockHeader -> ModelOp ()) -> BlockHeader -> IO (Either Any ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> ModelOp ()
mPutHeader

        listHeaders :: Int -> IO [BlockHeader]
listHeaders =
            MVar PoolDatabase -> ModelOp [BlockHeader] -> IO [BlockHeader]
forall a. MVar PoolDatabase -> ModelOp a -> IO a
readPoolDB MVar PoolDatabase
db (ModelOp [BlockHeader] -> IO [BlockHeader])
-> (Int -> ModelOp [BlockHeader]) -> Int -> IO [BlockHeader]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ModelOp [BlockHeader]
mListHeaders

        readSettings :: IO Settings
readSettings = MVar PoolDatabase -> ModelOp Settings -> IO Settings
forall a. MVar PoolDatabase -> ModelOp a -> IO a
readPoolDB MVar PoolDatabase
db ModelOp Settings
mReadSettings

        putSettings :: Settings -> IO ()
putSettings =
            IO (Either Any ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Any ()) -> IO ())
-> (Settings -> IO (Either Any ())) -> Settings -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolErr -> Maybe Any)
-> MVar PoolDatabase -> ModelOp () -> IO (Either Any ())
forall err a.
(PoolErr -> Maybe err)
-> MVar PoolDatabase -> ModelOp a -> IO (Either err a)
alterPoolDB (Maybe Any -> PoolErr -> Maybe Any
forall a b. a -> b -> a
const Maybe Any
forall a. Maybe a
Nothing) MVar PoolDatabase
db (ModelOp () -> IO (Either Any ()))
-> (Settings -> ModelOp ()) -> Settings -> IO (Either Any ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> ModelOp ()
mPutSettings

        readLastMetadataGC :: IO (Maybe POSIXTime)
readLastMetadataGC = MVar PoolDatabase
-> ModelOp (Maybe POSIXTime) -> IO (Maybe POSIXTime)
forall a. MVar PoolDatabase -> ModelOp a -> IO a
readPoolDB MVar PoolDatabase
db ModelOp (Maybe POSIXTime)
mReadLastMetadataGC

        putLastMetadataGC :: POSIXTime -> IO ()
putLastMetadataGC =
            IO (Either Any ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Any ()) -> IO ())
-> (POSIXTime -> IO (Either Any ())) -> POSIXTime -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolErr -> Maybe Any)
-> MVar PoolDatabase -> ModelOp () -> IO (Either Any ())
forall err a.
(PoolErr -> Maybe err)
-> MVar PoolDatabase -> ModelOp a -> IO (Either err a)
alterPoolDB (Maybe Any -> PoolErr -> Maybe Any
forall a b. a -> b -> a
const Maybe Any
forall a. Maybe a
Nothing) MVar PoolDatabase
db (ModelOp () -> IO (Either Any ()))
-> (POSIXTime -> ModelOp ()) -> POSIXTime -> IO (Either Any ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> ModelOp ()
mPutLastMetadataGC

        cleanDB :: IO ()
cleanDB =
            IO (Either Any ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Any ()) -> IO ()) -> IO (Either Any ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (PoolErr -> Maybe Any)
-> MVar PoolDatabase -> ModelOp () -> IO (Either Any ())
forall err a.
(PoolErr -> Maybe err)
-> MVar PoolDatabase -> ModelOp a -> IO (Either err a)
alterPoolDB (Maybe Any -> PoolErr -> Maybe Any
forall a b. a -> b -> a
const Maybe Any
forall a. Maybe a
Nothing) MVar PoolDatabase
db ModelOp ()
mCleanDatabase

        readPoolMetadata :: IO (Map StakePoolMetadataHash StakePoolMetadata)
readPoolMetadata = MVar PoolDatabase
-> ModelOp (Map StakePoolMetadataHash StakePoolMetadata)
-> IO (Map StakePoolMetadataHash StakePoolMetadata)
forall a. MVar PoolDatabase -> ModelOp a -> IO a
readPoolDB MVar PoolDatabase
db ModelOp (Map StakePoolMetadataHash StakePoolMetadata)
mReadPoolMetadata

        atomically :: a -> a
atomically = a -> a
forall a. a -> a
id

alterPoolDB
    :: (PoolErr -> Maybe err)
    -- ^ Error type converter
    -> MVar PoolDatabase
    -- ^ The database variable
    -> ModelOp a
    -- ^ Operation to run on the database
    -> IO (Either err a)
alterPoolDB :: (PoolErr -> Maybe err)
-> MVar PoolDatabase -> ModelOp a -> IO (Either err a)
alterPoolDB PoolErr -> Maybe err
convertErr MVar PoolDatabase
dbVar ModelOp a
op =
    MVar PoolDatabase
-> (PoolDatabase -> IO (PoolDatabase, Either err a))
-> IO (Either err a)
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar PoolDatabase
dbVar ((PoolDatabase -> IO (PoolDatabase, Either err a))
 -> IO (Either err a))
-> (PoolDatabase -> IO (PoolDatabase, Either err a))
-> IO (Either err a)
forall a b. (a -> b) -> a -> b
$ \PoolDatabase
db ->
        case ModelOp a -> PoolDatabase -> Either PoolErr (a, PoolDatabase)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ModelOp a
op PoolDatabase
db of
            Left PoolErr
e -> case PoolErr -> Maybe err
convertErr PoolErr
e of
                Just err
e' -> (PoolDatabase, Either err a) -> IO (PoolDatabase, Either err a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PoolDatabase
db, err -> Either err a
forall a b. a -> Either a b
Left err
e')
                Maybe err
Nothing -> MVarPoolDBError -> IO (PoolDatabase, Either err a)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (MVarPoolDBError -> IO (PoolDatabase, Either err a))
-> MVarPoolDBError -> IO (PoolDatabase, Either err a)
forall a b. (a -> b) -> a -> b
$ PoolErr -> MVarPoolDBError
MVarPoolDBError PoolErr
e
            Right (a
result, PoolDatabase
dbUpdated) ->
                (PoolDatabase, Either err a) -> IO (PoolDatabase, Either err a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PoolDatabase
dbUpdated, a -> Either err a
forall a b. b -> Either a b
Right a
result)

readPoolDB
    :: MVar PoolDatabase
    -- ^ The database variable
    -> ModelOp a
    -- ^ Operation to run on the database
    -> IO a
readPoolDB :: MVar PoolDatabase -> ModelOp a -> IO a
readPoolDB MVar PoolDatabase
db ModelOp a
op =
    (PoolErr -> Maybe PoolErr)
-> MVar PoolDatabase -> ModelOp a -> IO (Either PoolErr a)
forall err a.
(PoolErr -> Maybe err)
-> MVar PoolDatabase -> ModelOp a -> IO (Either err a)
alterPoolDB PoolErr -> Maybe PoolErr
forall a. a -> Maybe a
Just MVar PoolDatabase
db ModelOp a
op IO (Either PoolErr a) -> (Either PoolErr a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (PoolErr -> IO a) -> (a -> IO a) -> Either PoolErr a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (MVarPoolDBError -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (MVarPoolDBError -> IO a)
-> (PoolErr -> MVarPoolDBError) -> PoolErr -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolErr -> MVarPoolDBError
MVarPoolDBError) a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

errPointAlreadyExists
    :: PoolErr
    -> Maybe ErrPointAlreadyExists
errPointAlreadyExists :: PoolErr -> Maybe ErrPointAlreadyExists
errPointAlreadyExists (PointAlreadyExists BlockHeader
slotid) =
    ErrPointAlreadyExists -> Maybe ErrPointAlreadyExists
forall a. a -> Maybe a
Just (BlockHeader -> ErrPointAlreadyExists
ErrPointAlreadyExists BlockHeader
slotid)

newtype MVarPoolDBError = MVarPoolDBError PoolErr
    deriving (Int -> MVarPoolDBError -> ShowS
[MVarPoolDBError] -> ShowS
MVarPoolDBError -> String
(Int -> MVarPoolDBError -> ShowS)
-> (MVarPoolDBError -> String)
-> ([MVarPoolDBError] -> ShowS)
-> Show MVarPoolDBError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MVarPoolDBError] -> ShowS
$cshowList :: [MVarPoolDBError] -> ShowS
show :: MVarPoolDBError -> String
$cshow :: MVarPoolDBError -> String
showsPrec :: Int -> MVarPoolDBError -> ShowS
$cshowsPrec :: Int -> MVarPoolDBError -> ShowS
Show)

instance Exception MVarPoolDBError