{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{- HLINT ignore "Redundant flip" -}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- An implementation of the DBLayer which uses Persistent and SQLite.

module Cardano.Pool.DB.Sqlite
    ( newDBLayer
    , withDBLayer
    , withDecoratedDBLayer
    , DBDecorator (..)
    , undecoratedDB
    , defaultFilePath
    , DatabaseView (..)
    , createViews
    ) where

import Prelude

import Cardano.DB.Sqlite
    ( DBField (..)
    , DBLog (..)
    , ForeignKeysSetting (ForeignKeysEnabled)
    , ManualMigration (..)
    , MigrationError
    , SqliteContext (..)
    , fieldName
    , handleConstraint
    , newInMemorySqliteContext
    , newSqliteContext
    , tableName
    , withConnectionPool
    )
import Cardano.Pool.DB
    ( DBLayer (..), ErrPointAlreadyExists (..), determinePoolLifeCycleStatus )
import Cardano.Pool.DB.Log
    ( ParseFailure (..), PoolDbLog (..) )
import Cardano.Pool.DB.Sqlite.TH hiding
    ( BlockHeader, blockHeight )
import Cardano.Wallet.DB.Sqlite.Types
    ( BlockId (..), fromMaybeHash, toMaybeHash )
import Cardano.Wallet.Logging
    ( bracketTracer )
import Cardano.Wallet.Primitive.Slotting
    ( TimeInterpreter, epochOf, firstSlotInEpoch, interpretQuery )
import Cardano.Wallet.Primitive.Types
    ( BlockHeader (..)
    , CertificatePublicationTime (..)
    , EpochNo (..)
    , PoolId (..)
    , PoolLifeCycleStatus (..)
    , PoolRegistrationCertificate (..)
    , PoolRetirementCertificate (..)
    , StakePoolMetadata (..)
    , StakePoolMetadataHash
    , defaultSettings
    )
import Cardano.Wallet.Unsafe
    ( unsafeMkPercentage )
import Control.Monad
    ( forM, forM_ )
import Control.Monad.IO.Class
    ( liftIO )
import Control.Monad.Trans.Except
    ( ExceptT (..) )
import Control.Tracer
    ( Tracer (..), contramap, natTracer, traceWith )
import Data.Either
    ( partitionEithers, rights )
import Data.Function
    ( (&) )
import Data.Functor
    ( (<&>) )
import Data.Generics.Internal.VL.Lens
    ( view )
import Data.List
    ( foldl' )
import Data.Map.Strict
    ( Map )
import Data.Quantity
    ( Percentage (..), Quantity (..) )
import Data.Ratio
    ( denominator, numerator, (%) )
import Data.String.Interpolate
    ( i )
import Data.Text
    ( Text )
import Data.Time.Clock
    ( UTCTime, addUTCTime, getCurrentTime )
import Data.Word
    ( Word64, Word8 )
import Database.Persist.Sql
    ( Entity (..)
    , Filter
    , PersistValue
    , RawSql
    , SelectOpt (..)
    , Single (..)
    , deleteWhere
    , fromPersistValue
    , insertMany_
    , insert_
    , rawSql
    , repsert
    , selectFirst
    , selectList
    , toPersistValue
    , update
    , (<.)
    , (=.)
    , (==.)
    , (>.)
    , (>=.)
    )
import Database.Persist.Sqlite
    ( SqlPersistT )
import System.Directory
    ( removeFile )
import System.FilePath
    ( (</>) )
import System.Random
    ( newStdGen )
import UnliftIO.Exception
    ( bracket, catch, throwIO )

import qualified Cardano.Pool.DB.Sqlite.TH as TH
import qualified Cardano.Wallet.Primitive.Types as W
import qualified Cardano.Wallet.Primitive.Types.Coin as Coin
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Database.Sqlite as Sqlite

-- | Return the preferred @FilePath@ for the stake pool .sqlite file, given a
-- parent directory.
defaultFilePath
    :: FilePath
    -- ^ The directory in which the .sqlite file will be located.
    -> FilePath
defaultFilePath :: FilePath -> FilePath
defaultFilePath = (FilePath -> FilePath -> FilePath
</> FilePath
"stake-pools.sqlite")

-- | Runs an action with a connection to the SQLite database.
--
-- Database migrations are run to create tables if necessary.
--
-- If the given file path does not exist, it will be created by the sqlite
-- library.
withDBLayer
    :: Tracer IO PoolDbLog
    -- ^ Logging object.
    -> Maybe FilePath
    -- ^ Database file location, or 'Nothing' for in-memory database.
    -> TimeInterpreter IO
    -- ^ The time interpreter object.
    -> (DBLayer IO -> IO a)
    -- ^ Action to run.
    -> IO a
withDBLayer :: Tracer IO PoolDbLog
-> Maybe FilePath
-> TimeInterpreter IO
-> (DBLayer IO -> IO a)
-> IO a
withDBLayer = DBDecorator IO
-> Tracer IO PoolDbLog
-> Maybe FilePath
-> TimeInterpreter IO
-> (DBLayer IO -> IO a)
-> IO a
forall a.
DBDecorator IO
-> Tracer IO PoolDbLog
-> Maybe FilePath
-> TimeInterpreter IO
-> (DBLayer IO -> IO a)
-> IO a
withDecoratedDBLayer DBDecorator IO
forall (a :: * -> *). DBDecorator a
undecoratedDB

-- | A decorator for the database layer, useful for instrumenting or monitoring
--   calls to database operations.
newtype DBDecorator a =
    DBDecorator { DBDecorator a -> DBLayer a -> DBLayer a
decorateDBLayer :: DBLayer a -> DBLayer a }

-- | The identity decorator.
--
-- Equivalent to an undecorated database.
--
undecoratedDB :: DBDecorator a
undecoratedDB :: DBDecorator a
undecoratedDB = (DBLayer a -> DBLayer a) -> DBDecorator a
forall (a :: * -> *). (DBLayer a -> DBLayer a) -> DBDecorator a
DBDecorator DBLayer a -> DBLayer a
forall a. a -> a
id

-- | Runs an action with a connection to the SQLite database.
--
-- This function has the same behaviour as 'withDBLayer', but provides a way
-- to decorate the created 'DBLayer' object with a 'DBDecorator', useful for
-- instrumenting or monitoring calls to database operations.
--
withDecoratedDBLayer
    :: DBDecorator IO
       -- ^ The database decorator.
    -> Tracer IO PoolDbLog
       -- ^ Logging object
    -> Maybe FilePath
       -- ^ Database file location, or Nothing for in-memory database
    -> TimeInterpreter IO
       -- ^ The time interpreter object.
    -> (DBLayer IO -> IO a)
       -- ^ Action to run.
    -> IO a
withDecoratedDBLayer :: DBDecorator IO
-> Tracer IO PoolDbLog
-> Maybe FilePath
-> TimeInterpreter IO
-> (DBLayer IO -> IO a)
-> IO a
withDecoratedDBLayer DBDecorator IO
dbDecorator Tracer IO PoolDbLog
tr Maybe FilePath
mDatabaseDir TimeInterpreter IO
ti DBLayer IO -> IO a
action = do
    case Maybe FilePath
mDatabaseDir of
        Maybe FilePath
Nothing -> IO (IO (), SqliteContext)
-> ((IO (), SqliteContext) -> IO ())
-> ((IO (), SqliteContext) -> IO a)
-> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
            (Tracer IO DBLog
-> [ManualMigration]
-> Migration
-> ForeignKeysSetting
-> IO (IO (), SqliteContext)
newInMemorySqliteContext Tracer IO DBLog
tr'
                [ManualMigration]
createViews Migration
migrateAll ForeignKeysSetting
ForeignKeysEnabled)
            (IO (), SqliteContext) -> IO ()
forall a b. (a, b) -> a
fst
            (DBLayer IO -> IO a
action (DBLayer IO -> IO a)
-> ((IO (), SqliteContext) -> DBLayer IO)
-> (IO (), SqliteContext)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBDecorator IO -> DBLayer IO -> DBLayer IO
forall (a :: * -> *). DBDecorator a -> DBLayer a -> DBLayer a
decorateDBLayer DBDecorator IO
dbDecorator (DBLayer IO -> DBLayer IO)
-> ((IO (), SqliteContext) -> DBLayer IO)
-> (IO (), SqliteContext)
-> DBLayer IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tracer IO PoolDbLog
-> TimeInterpreter IO -> SqliteContext -> DBLayer IO
newDBLayer Tracer IO PoolDbLog
tr TimeInterpreter IO
ti (SqliteContext -> DBLayer IO)
-> ((IO (), SqliteContext) -> SqliteContext)
-> (IO (), SqliteContext)
-> DBLayer IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO (), SqliteContext) -> SqliteContext
forall a b. (a, b) -> b
snd)

        Just FilePath
fp -> Tracer IO PoolDbLog -> FilePath -> IO a -> IO a
forall a. Tracer IO PoolDbLog -> FilePath -> IO a -> IO a
handlingPersistError Tracer IO PoolDbLog
tr FilePath
fp (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
            Tracer IO DBLog -> FilePath -> (ConnectionPool -> IO a) -> IO a
forall a.
Tracer IO DBLog -> FilePath -> (ConnectionPool -> IO a) -> IO a
withConnectionPool Tracer IO DBLog
tr' FilePath
fp ((ConnectionPool -> IO a) -> IO a)
-> (ConnectionPool -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ConnectionPool
pool -> do
                Either MigrationError SqliteContext
ctx <- Tracer IO DBLog
-> ConnectionPool
-> [ManualMigration]
-> Migration
-> IO (Either MigrationError SqliteContext)
newSqliteContext Tracer IO DBLog
tr' ConnectionPool
pool [ManualMigration]
createViews Migration
migrateAll
                Either MigrationError SqliteContext
ctx Either MigrationError SqliteContext
-> (Either MigrationError SqliteContext -> IO a) -> IO a
forall a b. a -> (a -> b) -> b
& (MigrationError -> IO a)
-> (SqliteContext -> IO a)
-> Either MigrationError SqliteContext
-> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
                    MigrationError -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO
                    (DBLayer IO -> IO a
action (DBLayer IO -> IO a)
-> (SqliteContext -> DBLayer IO) -> SqliteContext -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBDecorator IO -> DBLayer IO -> DBLayer IO
forall (a :: * -> *). DBDecorator a -> DBLayer a -> DBLayer a
decorateDBLayer DBDecorator IO
dbDecorator (DBLayer IO -> DBLayer IO)
-> (SqliteContext -> DBLayer IO) -> SqliteContext -> DBLayer IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tracer IO PoolDbLog
-> TimeInterpreter IO -> SqliteContext -> DBLayer IO
newDBLayer Tracer IO PoolDbLog
tr TimeInterpreter IO
ti)
  where
    tr' :: Tracer IO DBLog
tr' = (DBLog -> PoolDbLog) -> Tracer IO PoolDbLog -> Tracer IO DBLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap DBLog -> PoolDbLog
MsgGeneric Tracer IO PoolDbLog
tr

-- | Sets up a connection to the SQLite database.
--
-- Database migrations are run to create tables if necessary.
--
-- If the given file path does not exist, it will be created by the sqlite
-- library.
--
-- 'getDBLayer' will provide the actual 'DBLayer' implementation. The database
-- should be closed with 'destroyDBLayer'. If you use 'withDBLayer' then both of
-- these things will be handled for you.
newDBLayer
    :: Tracer IO PoolDbLog
       -- ^ Logging object
    -> TimeInterpreter IO
       -- ^ Time interpreter for slot to time conversions
    -> SqliteContext
        -- ^ A (thread-) safe wrapper for running db queries.
    -> DBLayer IO
newDBLayer :: Tracer IO PoolDbLog
-> TimeInterpreter IO -> SqliteContext -> DBLayer IO
newDBLayer Tracer IO PoolDbLog
tr TimeInterpreter IO
ti SqliteContext{forall a. SqlPersistT IO a -> IO a
$sel:runQuery:SqliteContext :: SqliteContext -> forall a. SqlPersistT IO a -> IO a
runQuery :: forall a. SqlPersistT IO a -> IO a
runQuery} =
    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 {ReaderT SqlBackend IO [PoolId]
ReaderT SqlBackend IO (Maybe POSIXTime)
ReaderT SqlBackend IO ()
ReaderT SqlBackend IO (Map PoolId (Quantity "block" Word64))
ReaderT SqlBackend IO (Map StakePoolMetadataHash StakePoolMetadata)
ReaderT SqlBackend IO StdGen
ReaderT SqlBackend IO Settings
Int
-> ReaderT
     SqlBackend
     IO
     [(PoolId, StakePoolMetadataUrl, StakePoolMetadataHash)]
Int -> ReaderT SqlBackend IO [BlockHeader]
[PoolId] -> ReaderT SqlBackend IO ()
(StakePoolMetadataUrl, StakePoolMetadataHash)
-> ReaderT SqlBackend IO ()
SlotNo -> ReaderT SqlBackend IO ()
POSIXTime -> ReaderT SqlBackend IO ()
Settings -> ReaderT SqlBackend IO ()
CertificatePublicationTime
-> PoolRetirementCertificate -> ReaderT SqlBackend IO ()
CertificatePublicationTime
-> PoolRegistrationCertificate -> ReaderT SqlBackend IO ()
EpochNo
-> ReaderT SqlBackend IO [(PoolId, Quantity "lovelace" Word64)]
EpochNo -> SqlPersistT IO [PoolLifeCycleStatus]
EpochNo -> ReaderT SqlBackend IO [PoolRetirementCertificate]
EpochNo -> ReaderT SqlBackend IO (Map PoolId [BlockHeader])
EpochNo
-> [(PoolId, Quantity "lovelace" Word64)]
-> ReaderT SqlBackend IO ()
BlockHeader -> ReaderT SqlBackend IO ()
BlockHeader
-> PoolId
-> ExceptT ErrPointAlreadyExists (ReaderT SqlBackend IO) ()
PoolId
-> ReaderT
     SqlBackend
     IO
     (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
PoolId
-> ReaderT
     SqlBackend
     IO
     (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
PoolId -> ReaderT SqlBackend IO PoolLifeCycleStatus
StakePoolMetadataHash
-> StakePoolMetadata -> ReaderT SqlBackend IO ()
forall a. SqlPersistT IO a -> IO a
forall backend (m :: * -> *).
(PersistQueryRead backend, MonadIO m,
 BaseBackend backend ~ SqlBackend) =>
Int -> ReaderT backend m [BlockHeader]
forall backend (m :: * -> *).
(PersistQueryRead backend, MonadIO m,
 BaseBackend backend ~ SqlBackend) =>
EpochNo -> ReaderT backend m [(PoolId, Quantity "lovelace" Word64)]
forall backend (m :: * -> *).
(PersistQueryRead backend, MonadIO m, PersistStoreWrite backend,
 BaseBackend backend ~ SqlBackend) =>
(StakePoolMetadataUrl, StakePoolMetadataHash)
-> ReaderT backend m ()
forall a (m :: * -> *) a a a backend.
(Show a, PersistField a, PersistField a, PersistField a, MonadIO m,
 BackendCompatible SqlBackend backend) =>
a -> ReaderT backend m [(a, a, a)]
forall (m :: * -> *) backend.
(MonadIO m, PersistQueryRead backend,
 BaseBackend backend ~ SqlBackend) =>
PoolId
-> ReaderT
     backend
     m
     (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
forall (m :: * -> *) backend.
(MonadIO m, PersistQueryRead backend,
 BaseBackend backend ~ SqlBackend) =>
PoolId
-> ReaderT
     backend
     m
     (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
forall (m :: * -> *) backend.
(MonadIO m, PersistQueryRead backend,
 BaseBackend backend ~ SqlBackend) =>
PoolId -> ReaderT backend m PoolLifeCycleStatus
forall (m :: * -> *) backend.
(MonadIO m, PersistQueryRead backend, PersistStoreWrite backend,
 BaseBackend backend ~ SqlBackend) =>
POSIXTime -> ReaderT backend m ()
forall (m :: * -> *) backend.
(MonadIO m, PersistQueryWrite backend,
 BaseBackend backend ~ SqlBackend) =>
[PoolId] -> ReaderT backend m ()
forall (m :: * -> *) backend.
(MonadIO m, PersistQueryWrite backend,
 BaseBackend backend ~ SqlBackend) =>
CertificatePublicationTime
-> PoolRegistrationCertificate -> ReaderT backend m ()
forall (m :: * -> *) backend.
(MonadIO m, PersistQueryWrite backend,
 BaseBackend backend ~ SqlBackend) =>
EpochNo
-> [(PoolId, Quantity "lovelace" Word64)] -> ReaderT backend m ()
forall (m :: * -> *) backend.
(MonadIO m, PersistQueryWrite backend,
 BaseBackend backend ~ SqlBackend) =>
StakePoolMetadataHash -> StakePoolMetadata -> ReaderT backend m ()
forall (m :: * -> *) backend.
(MonadIO m, PersistStoreWrite backend,
 BaseBackend backend ~ SqlBackend) =>
CertificatePublicationTime
-> PoolRetirementCertificate -> ReaderT backend m ()
forall (m :: * -> *) backend.
(MonadIO m, PersistStoreWrite backend,
 BaseBackend backend ~ SqlBackend) =>
BlockHeader -> ReaderT backend m ()
forall (m :: * -> *) backend.
(PersistStoreWrite backend, MonadUnliftIO m,
 BaseBackend backend ~ SqlBackend) =>
BlockHeader
-> PoolId -> ExceptT ErrPointAlreadyExists (ReaderT backend m) ()
atomically :: forall a. SqlPersistT IO a -> IO a
cleanDB :: ReaderT SqlBackend IO ()
putLastMetadataGC :: POSIXTime -> ReaderT SqlBackend IO ()
readLastMetadataGC :: ReaderT SqlBackend IO (Maybe POSIXTime)
putSettings :: Settings -> ReaderT SqlBackend IO ()
readSettings :: ReaderT SqlBackend IO Settings
listHeaders :: Int -> ReaderT SqlBackend IO [BlockHeader]
putHeader :: BlockHeader -> ReaderT SqlBackend IO ()
removeRetiredPools :: EpochNo -> ReaderT SqlBackend IO [PoolRetirementCertificate]
removePools :: [PoolId] -> ReaderT SqlBackend IO ()
readDelistedPools :: ReaderT SqlBackend IO [PoolId]
putDelistedPools :: [PoolId] -> ReaderT SqlBackend IO ()
rollbackTo :: SlotNo -> ReaderT SqlBackend IO ()
readSystemSeed :: ReaderT SqlBackend IO StdGen
readPoolMetadata :: ReaderT SqlBackend IO (Map StakePoolMetadataHash StakePoolMetadata)
removePoolMetadata :: ReaderT SqlBackend IO ()
putPoolMetadata :: StakePoolMetadataHash
-> StakePoolMetadata -> ReaderT SqlBackend IO ()
listPoolLifeCycleData :: EpochNo -> SqlPersistT IO [PoolLifeCycleStatus]
listRetiredPools :: EpochNo -> ReaderT SqlBackend IO [PoolRetirementCertificate]
listRegisteredPools :: ReaderT SqlBackend IO [PoolId]
putFetchAttempt :: (StakePoolMetadataUrl, StakePoolMetadataHash)
-> ReaderT SqlBackend IO ()
unfetchedPoolMetadataRefs :: Int
-> ReaderT
     SqlBackend
     IO
     [(PoolId, StakePoolMetadataUrl, StakePoolMetadataHash)]
readPoolRetirement :: PoolId
-> ReaderT
     SqlBackend
     IO
     (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
putPoolRetirement :: CertificatePublicationTime
-> PoolRetirementCertificate -> ReaderT SqlBackend IO ()
readPoolRegistration :: PoolId
-> ReaderT
     SqlBackend
     IO
     (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
putPoolRegistration :: CertificatePublicationTime
-> PoolRegistrationCertificate -> ReaderT SqlBackend IO ()
readPoolLifeCycleStatus :: PoolId -> ReaderT SqlBackend IO PoolLifeCycleStatus
readPoolProductionCursor :: Int -> ReaderT SqlBackend IO [BlockHeader]
readStakeDistribution :: EpochNo
-> ReaderT SqlBackend IO [(PoolId, Quantity "lovelace" Word64)]
putStakeDistribution :: EpochNo
-> [(PoolId, Quantity "lovelace" Word64)]
-> ReaderT SqlBackend IO ()
readTotalProduction :: ReaderT SqlBackend IO (Map PoolId (Quantity "block" Word64))
readPoolProduction :: EpochNo -> ReaderT SqlBackend IO (Map PoolId [BlockHeader])
putPoolProduction :: BlockHeader
-> PoolId
-> ExceptT ErrPointAlreadyExists (ReaderT SqlBackend IO) ()
listHeaders :: forall backend (m :: * -> *).
(PersistQueryRead backend, MonadIO m,
 BaseBackend backend ~ SqlBackend) =>
Int -> ReaderT backend m [BlockHeader]
putHeader :: forall (m :: * -> *) backend.
(MonadIO m, PersistStoreWrite backend,
 BaseBackend backend ~ SqlBackend) =>
BlockHeader -> ReaderT backend m ()
readPoolRetirement :: forall (m :: * -> *) backend.
(MonadIO m, PersistQueryRead backend,
 BaseBackend backend ~ SqlBackend) =>
PoolId
-> ReaderT
     backend
     m
     (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
readPoolRegistration :: forall (m :: * -> *) backend.
(MonadIO m, PersistQueryRead backend,
 BaseBackend backend ~ SqlBackend) =>
PoolId
-> ReaderT
     backend
     m
     (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
atomically :: forall a. SqlPersistT IO a -> IO a
cleanDB :: ReaderT SqlBackend IO ()
putLastMetadataGC :: forall (m :: * -> *) backend.
(MonadIO m, PersistQueryRead backend, PersistStoreWrite backend,
 BaseBackend backend ~ SqlBackend) =>
POSIXTime -> ReaderT backend m ()
readLastMetadataGC :: ReaderT SqlBackend IO (Maybe POSIXTime)
putSettings :: Settings -> ReaderT SqlBackend IO ()
readSettings :: ReaderT SqlBackend IO Settings
readSystemSeed :: ReaderT SqlBackend IO StdGen
readPoolProductionCursor :: forall backend (m :: * -> *).
(PersistQueryRead backend, MonadIO m,
 BaseBackend backend ~ SqlBackend) =>
Int -> ReaderT backend m [BlockHeader]
removeRetiredPools :: EpochNo -> ReaderT SqlBackend IO [PoolRetirementCertificate]
removePools :: [PoolId] -> ReaderT SqlBackend IO ()
readDelistedPools :: ReaderT SqlBackend IO [PoolId]
putDelistedPools :: forall (m :: * -> *) backend.
(MonadIO m, PersistQueryWrite backend,
 BaseBackend backend ~ SqlBackend) =>
[PoolId] -> ReaderT backend m ()
rollbackTo :: SlotNo -> ReaderT SqlBackend IO ()
listPoolLifeCycleData :: EpochNo -> SqlPersistT IO [PoolLifeCycleStatus]
listRetiredPools :: EpochNo -> ReaderT SqlBackend IO [PoolRetirementCertificate]
listRegisteredPools :: ReaderT SqlBackend IO [PoolId]
readPoolMetadata :: ReaderT SqlBackend IO (Map StakePoolMetadataHash StakePoolMetadata)
removePoolMetadata :: ReaderT SqlBackend IO ()
putPoolMetadata :: forall (m :: * -> *) backend.
(MonadIO m, PersistQueryWrite backend,
 BaseBackend backend ~ SqlBackend) =>
StakePoolMetadataHash -> StakePoolMetadata -> ReaderT backend m ()
putFetchAttempt :: forall backend (m :: * -> *).
(PersistQueryRead backend, MonadIO m, PersistStoreWrite backend,
 BaseBackend backend ~ SqlBackend) =>
(StakePoolMetadataUrl, StakePoolMetadataHash)
-> ReaderT backend m ()
unfetchedPoolMetadataRefs :: forall a (m :: * -> *) a a a backend.
(Show a, PersistField a, PersistField a, PersistField a, MonadIO m,
 BackendCompatible SqlBackend backend) =>
a -> ReaderT backend m [(a, a, a)]
putPoolRetirement :: forall (m :: * -> *) backend.
(MonadIO m, PersistStoreWrite backend,
 BaseBackend backend ~ SqlBackend) =>
CertificatePublicationTime
-> PoolRetirementCertificate -> ReaderT backend m ()
putPoolRegistration :: forall (m :: * -> *) backend.
(MonadIO m, PersistQueryWrite backend,
 BaseBackend backend ~ SqlBackend) =>
CertificatePublicationTime
-> PoolRegistrationCertificate -> ReaderT backend m ()
readPoolLifeCycleStatus :: forall (m :: * -> *) backend.
(MonadIO m, PersistQueryRead backend,
 BaseBackend backend ~ SqlBackend) =>
PoolId -> ReaderT backend m PoolLifeCycleStatus
readStakeDistribution :: forall backend (m :: * -> *).
(PersistQueryRead backend, MonadIO m,
 BaseBackend backend ~ SqlBackend) =>
EpochNo -> ReaderT backend m [(PoolId, Quantity "lovelace" Word64)]
putStakeDistribution :: forall (m :: * -> *) backend.
(MonadIO m, PersistQueryWrite backend,
 BaseBackend backend ~ SqlBackend) =>
EpochNo
-> [(PoolId, Quantity "lovelace" Word64)] -> ReaderT backend m ()
readTotalProduction :: ReaderT SqlBackend IO (Map PoolId (Quantity "block" Word64))
readPoolProduction :: EpochNo -> ReaderT SqlBackend IO (Map PoolId [BlockHeader])
putPoolProduction :: forall (m :: * -> *) backend.
(PersistStoreWrite backend, MonadUnliftIO m,
 BaseBackend backend ~ SqlBackend) =>
BlockHeader
-> PoolId -> ExceptT ErrPointAlreadyExists (ReaderT backend m) ()
..}
      where
        putPoolProduction :: BlockHeader
-> PoolId -> ExceptT ErrPointAlreadyExists (ReaderT backend m) ()
putPoolProduction BlockHeader
point PoolId
pool = ReaderT backend m (Either ErrPointAlreadyExists ())
-> ExceptT ErrPointAlreadyExists (ReaderT backend m) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT backend m (Either ErrPointAlreadyExists ())
 -> ExceptT ErrPointAlreadyExists (ReaderT backend m) ())
-> ReaderT backend m (Either ErrPointAlreadyExists ())
-> ExceptT ErrPointAlreadyExists (ReaderT backend m) ()
forall a b. (a -> b) -> a -> b
$
            ErrPointAlreadyExists
-> ReaderT backend m ()
-> ReaderT backend m (Either ErrPointAlreadyExists ())
forall (m :: * -> *) e a.
MonadUnliftIO m =>
e -> m a -> m (Either e a)
handleConstraint (BlockHeader -> ErrPointAlreadyExists
ErrPointAlreadyExists BlockHeader
point) (ReaderT backend m ()
 -> ReaderT backend m (Either ErrPointAlreadyExists ()))
-> ReaderT backend m ()
-> ReaderT backend m (Either ErrPointAlreadyExists ())
forall a b. (a -> b) -> a -> b
$
                PoolProduction -> ReaderT backend m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
record -> ReaderT backend m ()
insert_ (PoolId -> BlockHeader -> PoolProduction
mkPoolProduction PoolId
pool BlockHeader
point)

        readPoolProduction :: EpochNo -> ReaderT SqlBackend IO (Map PoolId [BlockHeader])
readPoolProduction EpochNo
epoch = do
            [(PoolId, BlockHeader)]
production <- (PoolProduction -> (PoolId, BlockHeader))
-> [PoolProduction] -> [(PoolId, BlockHeader)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PoolProduction -> (PoolId, BlockHeader)
fromPoolProduction
                ([PoolProduction] -> [(PoolId, BlockHeader)])
-> ReaderT SqlBackend IO [PoolProduction]
-> ReaderT SqlBackend IO [(PoolId, BlockHeader)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TimeInterpreter IO
-> EpochNo -> ReaderT SqlBackend IO [PoolProduction]
selectPoolProduction TimeInterpreter IO
ti EpochNo
epoch

            let toMap :: Ord a => Map a [b] -> (a,b) -> Map a [b]
                toMap :: Map a [b] -> (a, b) -> Map a [b]
toMap Map a [b]
m (a
k, b
v) = (Maybe [b] -> Maybe [b]) -> a -> Map a [b] -> Map a [b]
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (b -> Maybe [b] -> Maybe [b]
forall a. a -> Maybe [a] -> Maybe [a]
alter b
v) a
k Map a [b]
m
                  where
                    alter :: a -> Maybe [a] -> Maybe [a]
alter a
x = \case
                      Maybe [a]
Nothing -> [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a
x]
                      Just [a]
xs -> [a] -> Maybe [a]
forall a. a -> Maybe a
Just (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)

            Map PoolId [BlockHeader]
-> ReaderT SqlBackend IO (Map PoolId [BlockHeader])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Map PoolId [BlockHeader]
 -> (PoolId, BlockHeader) -> Map PoolId [BlockHeader])
-> Map PoolId [BlockHeader]
-> [(PoolId, BlockHeader)]
-> Map PoolId [BlockHeader]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map PoolId [BlockHeader]
-> (PoolId, BlockHeader) -> Map PoolId [BlockHeader]
forall a b. Ord a => Map a [b] -> (a, b) -> Map a [b]
toMap Map PoolId [BlockHeader]
forall k a. Map k a
Map.empty [(PoolId, BlockHeader)]
production)

        readTotalProduction :: ReaderT SqlBackend IO (Map PoolId (Quantity "block" Word64))
readTotalProduction = [(PoolId, Quantity "block" Word64)]
-> Map PoolId (Quantity "block" Word64)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PoolId, Quantity "block" Word64)]
 -> Map PoolId (Quantity "block" Word64))
-> ReaderT SqlBackend IO [(PoolId, Quantity "block" Word64)]
-> ReaderT SqlBackend IO (Map PoolId (Quantity "block" Word64))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tracer IO PoolDbLog
-> RawQuery
     (Single PersistValue, Single PersistValue)
     (PoolId, Quantity "block" Word64)
-> ReaderT SqlBackend IO [(PoolId, Quantity "block" Word64)]
forall a b.
RawSql a =>
Tracer IO PoolDbLog -> RawQuery a b -> SqlPersistT IO [b]
runRawQuery Tracer IO PoolDbLog
tr
            (Text
-> Text
-> [PersistValue]
-> ((Single PersistValue, Single PersistValue)
    -> Either Text (PoolId, Quantity "block" Word64))
-> RawQuery
     (Single PersistValue, Single PersistValue)
     (PoolId, Quantity "block" Word64)
forall a b.
Text
-> Text -> [PersistValue] -> (a -> Either Text b) -> RawQuery a b
RawQuery Text
"readTotalProduction" Text
query [] (Single PersistValue, Single PersistValue)
-> Either Text (PoolId, Quantity "block" Word64)
forall a a (unit :: Symbol).
(PersistField a, PersistField a) =>
(Single PersistValue, Single PersistValue)
-> Either Text (a, Quantity unit a)
parseRow)
          where
            query :: Text
query = [Text] -> Text
T.unwords
                [ Text
"SELECT pool_id, count(pool_id) as block_count"
                , Text
"FROM pool_production"
                , Text
"GROUP BY pool_id;"
                ]
            parseRow :: (Single PersistValue, Single PersistValue)
-> Either Text (a, Quantity unit a)
parseRow
                ( Single PersistValue
fieldPoolId
                , Single PersistValue
fieldBlockCount
                ) = (,)
                    (a -> Quantity unit a -> (a, Quantity unit a))
-> Either Text a
-> Either Text (Quantity unit a -> (a, Quantity unit a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistValue -> Either Text a
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
fieldPoolId
                    Either Text (Quantity unit a -> (a, Quantity unit a))
-> Either Text (Quantity unit a)
-> Either Text (a, Quantity unit a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (a -> Quantity unit a
forall (unit :: Symbol) a. a -> Quantity unit a
Quantity (a -> Quantity unit a)
-> Either Text a -> Either Text (Quantity unit a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistValue -> Either Text a
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
fieldBlockCount)

        putStakeDistribution :: EpochNo
-> [(PoolId, Quantity "lovelace" Word64)] -> ReaderT backend m ()
putStakeDistribution epoch :: EpochNo
epoch@(EpochNo Word31
ep) [(PoolId, Quantity "lovelace" Word64)]
distribution = do
            [Filter StakeDistribution] -> ReaderT backend m ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [EntityField StakeDistribution Word64
forall typ. (typ ~ Word64) => EntityField StakeDistribution typ
StakeDistributionEpoch EntityField StakeDistribution Word64
-> Word64 -> Filter StakeDistribution
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Word31 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word31
ep]
            [StakeDistribution] -> ReaderT backend m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[record] -> ReaderT backend m ()
insertMany_ (EpochNo
-> [(PoolId, Quantity "lovelace" Word64)] -> [StakeDistribution]
mkStakeDistribution EpochNo
epoch [(PoolId, Quantity "lovelace" Word64)]
distribution)

        readStakeDistribution :: EpochNo -> ReaderT backend m [(PoolId, Quantity "lovelace" Word64)]
readStakeDistribution (EpochNo Word31
epoch) = do
            (Entity StakeDistribution -> (PoolId, Quantity "lovelace" Word64))
-> [Entity StakeDistribution]
-> [(PoolId, Quantity "lovelace" Word64)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (StakeDistribution -> (PoolId, Quantity "lovelace" Word64)
fromStakeDistribution (StakeDistribution -> (PoolId, Quantity "lovelace" Word64))
-> (Entity StakeDistribution -> StakeDistribution)
-> Entity StakeDistribution
-> (PoolId, Quantity "lovelace" Word64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity StakeDistribution -> StakeDistribution
forall record. Entity record -> record
entityVal) ([Entity StakeDistribution]
 -> [(PoolId, Quantity "lovelace" Word64)])
-> ReaderT backend m [Entity StakeDistribution]
-> ReaderT backend m [(PoolId, Quantity "lovelace" Word64)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Filter StakeDistribution]
-> [SelectOpt StakeDistribution]
-> ReaderT backend m [Entity StakeDistribution]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList
                [ EntityField StakeDistribution Word64
forall typ. (typ ~ Word64) => EntityField StakeDistribution typ
StakeDistributionEpoch EntityField StakeDistribution Word64
-> Word64 -> Filter StakeDistribution
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Word31 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word31
epoch ]
                []

        readPoolLifeCycleStatus :: PoolId -> ReaderT backend m PoolLifeCycleStatus
readPoolLifeCycleStatus PoolId
poolId =
            Maybe (CertificatePublicationTime, PoolRegistrationCertificate)
-> Maybe (CertificatePublicationTime, PoolRetirementCertificate)
-> PoolLifeCycleStatus
forall publicationTime.
(Ord publicationTime, Show publicationTime) =>
Maybe (publicationTime, PoolRegistrationCertificate)
-> Maybe (publicationTime, PoolRetirementCertificate)
-> PoolLifeCycleStatus
determinePoolLifeCycleStatus
                (Maybe (CertificatePublicationTime, PoolRegistrationCertificate)
 -> Maybe (CertificatePublicationTime, PoolRetirementCertificate)
 -> PoolLifeCycleStatus)
-> ReaderT
     backend
     m
     (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
-> ReaderT
     backend
     m
     (Maybe (CertificatePublicationTime, PoolRetirementCertificate)
      -> PoolLifeCycleStatus)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PoolId
-> ReaderT
     backend
     m
     (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
forall (m :: * -> *) backend.
(MonadIO m, PersistQueryRead backend,
 BaseBackend backend ~ SqlBackend) =>
PoolId
-> ReaderT
     backend
     m
     (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
readPoolRegistration PoolId
poolId
                ReaderT
  backend
  m
  (Maybe (CertificatePublicationTime, PoolRetirementCertificate)
   -> PoolLifeCycleStatus)
-> ReaderT
     backend
     m
     (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
-> ReaderT backend m PoolLifeCycleStatus
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PoolId
-> ReaderT
     backend
     m
     (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
forall (m :: * -> *) backend.
(MonadIO m, PersistQueryRead backend,
 BaseBackend backend ~ SqlBackend) =>
PoolId
-> ReaderT
     backend
     m
     (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
readPoolRetirement PoolId
poolId

        putPoolRegistration :: CertificatePublicationTime
-> PoolRegistrationCertificate -> ReaderT backend m ()
putPoolRegistration CertificatePublicationTime
cpt PoolRegistrationCertificate
cert = do
            let CertificatePublicationTime {SlotNo
$sel:slotNo:CertificatePublicationTime :: CertificatePublicationTime -> SlotNo
slotNo :: SlotNo
slotNo, Word64
$sel:slotInternalIndex:CertificatePublicationTime :: CertificatePublicationTime -> Word64
slotInternalIndex :: Word64
slotInternalIndex} = CertificatePublicationTime
cpt
            let poolId :: PoolId
poolId = ((PoolId -> Const PoolId PoolId)
 -> PoolRegistrationCertificate
 -> Const PoolId PoolRegistrationCertificate)
-> PoolRegistrationCertificate -> PoolId
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "poolId"
  ((PoolId -> Const PoolId PoolId)
   -> PoolRegistrationCertificate
   -> Const PoolId PoolRegistrationCertificate)
(PoolId -> Const PoolId PoolId)
-> PoolRegistrationCertificate
-> Const PoolId PoolRegistrationCertificate
#poolId PoolRegistrationCertificate
cert
            [Filter PoolOwner] -> ReaderT backend m ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere
                [ EntityField PoolOwner PoolId
forall typ. (typ ~ PoolId) => EntityField PoolOwner typ
PoolOwnerPoolId EntityField PoolOwner PoolId -> PoolId -> Filter PoolOwner
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. PoolId
poolId
                , EntityField PoolOwner SlotNo
forall typ. (typ ~ SlotNo) => EntityField PoolOwner typ
PoolOwnerSlot EntityField PoolOwner SlotNo -> SlotNo -> Filter PoolOwner
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. SlotNo
slotNo
                , EntityField PoolOwner Word64
forall typ. (typ ~ Word64) => EntityField PoolOwner typ
PoolOwnerSlotInternalIndex EntityField PoolOwner Word64 -> Word64 -> Filter PoolOwner
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Word64
slotInternalIndex
                ]
            let poolRegistrationKey :: Key PoolRegistration
poolRegistrationKey = PoolId -> SlotNo -> Word64 -> Key PoolRegistration
PoolRegistrationKey
                    PoolId
poolId SlotNo
slotNo Word64
slotInternalIndex
            let poolRegistrationRow :: PoolRegistration
poolRegistrationRow = PoolId
-> SlotNo
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Maybe StakePoolMetadataUrl
-> Maybe StakePoolMetadataHash
-> PoolRegistration
PoolRegistration
                    (PoolId
poolId)
                    (SlotNo
slotNo)
                    (Word64
slotInternalIndex)
                    (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word64) -> Integer -> Word64
forall a b. (a -> b) -> a -> b
$ Ratio Integer -> Integer
forall a. Ratio a -> a
numerator
                        (Ratio Integer -> Integer) -> Ratio Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Percentage -> Ratio Integer
getPercentage (Percentage -> Ratio Integer) -> Percentage -> Ratio Integer
forall a b. (a -> b) -> a -> b
$ PoolRegistrationCertificate -> Percentage
poolMargin PoolRegistrationCertificate
cert)
                    (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word64) -> Integer -> Word64
forall a b. (a -> b) -> a -> b
$ Ratio Integer -> Integer
forall a. Ratio a -> a
denominator
                        (Ratio Integer -> Integer) -> Ratio Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Percentage -> Ratio Integer
getPercentage (Percentage -> Ratio Integer) -> Percentage -> Ratio Integer
forall a b. (a -> b) -> a -> b
$ PoolRegistrationCertificate -> Percentage
poolMargin PoolRegistrationCertificate
cert)
                    (HasCallStack => Coin -> Word64
Coin -> Word64
Coin.unsafeToWord64 (Coin -> Word64) -> Coin -> Word64
forall a b. (a -> b) -> a -> b
$ PoolRegistrationCertificate -> Coin
poolCost PoolRegistrationCertificate
cert)
                    (HasCallStack => Coin -> Word64
Coin -> Word64
Coin.unsafeToWord64 (Coin -> Word64) -> Coin -> Word64
forall a b. (a -> b) -> a -> b
$ PoolRegistrationCertificate -> Coin
poolPledge PoolRegistrationCertificate
cert)
                    ((StakePoolMetadataUrl, StakePoolMetadataHash)
-> StakePoolMetadataUrl
forall a b. (a, b) -> a
fst ((StakePoolMetadataUrl, StakePoolMetadataHash)
 -> StakePoolMetadataUrl)
-> Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
-> Maybe StakePoolMetadataUrl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PoolRegistrationCertificate
-> Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
poolMetadata PoolRegistrationCertificate
cert)
                    ((StakePoolMetadataUrl, StakePoolMetadataHash)
-> StakePoolMetadataHash
forall a b. (a, b) -> b
snd ((StakePoolMetadataUrl, StakePoolMetadataHash)
 -> StakePoolMetadataHash)
-> Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
-> Maybe StakePoolMetadataHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PoolRegistrationCertificate
-> Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
poolMetadata PoolRegistrationCertificate
cert)
            ()
_ <- Key PoolRegistration -> PoolRegistration -> ReaderT backend m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
repsert Key PoolRegistration
poolRegistrationKey PoolRegistration
poolRegistrationRow
            [PoolOwner] -> ReaderT backend m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[record] -> ReaderT backend m ()
insertMany_ ([PoolOwner] -> ReaderT backend m ())
-> [PoolOwner] -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$
                (PoolOwner -> Word8 -> PoolOwner)
-> [PoolOwner] -> [Word8] -> [PoolOwner]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                    (PoolId -> SlotNo -> Word64 -> PoolOwner -> Word8 -> PoolOwner
PoolOwner PoolId
poolId SlotNo
slotNo Word64
slotInternalIndex)
                    (PoolRegistrationCertificate -> [PoolOwner]
poolOwners PoolRegistrationCertificate
cert)
                    [Word8
0..]

        putPoolRetirement :: CertificatePublicationTime
-> PoolRetirementCertificate -> ReaderT backend m ()
putPoolRetirement CertificatePublicationTime
cpt PoolRetirementCertificate
cert = do
            let CertificatePublicationTime {SlotNo
slotNo :: SlotNo
$sel:slotNo:CertificatePublicationTime :: CertificatePublicationTime -> SlotNo
slotNo, Word64
slotInternalIndex :: Word64
$sel:slotInternalIndex:CertificatePublicationTime :: CertificatePublicationTime -> Word64
slotInternalIndex} = CertificatePublicationTime
cpt
            let PoolRetirementCertificate
                    PoolId
poolId (EpochNo Word31
retirementEpoch) = PoolRetirementCertificate
cert
            Key PoolRetirement -> PoolRetirement -> ReaderT backend m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
repsert (PoolId -> SlotNo -> Word64 -> Key PoolRetirement
PoolRetirementKey PoolId
poolId SlotNo
slotNo Word64
slotInternalIndex) (PoolRetirement -> ReaderT backend m ())
-> PoolRetirement -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$
                PoolId -> SlotNo -> Word64 -> Word64 -> PoolRetirement
PoolRetirement
                    PoolId
poolId
                    SlotNo
slotNo
                    Word64
slotInternalIndex
                    (Word31 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word31
retirementEpoch)

        unfetchedPoolMetadataRefs :: a -> ReaderT backend m [(a, a, a)]
unfetchedPoolMetadataRefs a
limit = do
            let nLimit :: Text
nLimit = FilePath -> Text
T.pack (a -> FilePath
forall a. Show a => a -> FilePath
show a
limit)
            let poolId :: Text
poolId        = DBField -> Text
fieldName (EntityField PoolRegistration PoolId -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField PoolRegistration PoolId
forall typ. (typ ~ PoolId) => EntityField PoolRegistration typ
PoolRegistrationPoolId)
            let metadataHash :: Text
metadataHash  = DBField -> Text
fieldName (EntityField PoolRegistration (Maybe StakePoolMetadataHash)
-> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField PoolRegistration (Maybe StakePoolMetadataHash)
forall typ.
(typ ~ Maybe StakePoolMetadataHash) =>
EntityField PoolRegistration typ
PoolRegistrationMetadataHash)
            let metadataUrl :: Text
metadataUrl   = DBField -> Text
fieldName (EntityField PoolRegistration (Maybe StakePoolMetadataUrl)
-> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField PoolRegistration (Maybe StakePoolMetadataUrl)
forall typ.
(typ ~ Maybe StakePoolMetadataUrl) =>
EntityField PoolRegistration typ
PoolRegistrationMetadataUrl)
            let retryAfter :: Text
retryAfter    = DBField -> Text
fieldName (EntityField PoolMetadataFetchAttempts UTCTime -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField PoolMetadataFetchAttempts UTCTime
forall typ.
(typ ~ UTCTime) =>
EntityField PoolMetadataFetchAttempts typ
PoolFetchAttemptsRetryAfter)
            let registrations :: Text
registrations = DBField -> Text
tableName (EntityField PoolRegistration (Maybe StakePoolMetadataHash)
-> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField PoolRegistration (Maybe StakePoolMetadataHash)
forall typ.
(typ ~ Maybe StakePoolMetadataHash) =>
EntityField PoolRegistration typ
PoolRegistrationMetadataHash)
            let fetchAttempts :: Text
fetchAttempts = DBField -> Text
tableName (EntityField PoolMetadataFetchAttempts StakePoolMetadataHash
-> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField PoolMetadataFetchAttempts StakePoolMetadataHash
forall typ.
(typ ~ StakePoolMetadataHash) =>
EntityField PoolMetadataFetchAttempts typ
PoolFetchAttemptsMetadataHash)
            let metadata :: Text
metadata      = DBField -> Text
tableName (EntityField PoolMetadata StakePoolMetadataHash -> DBField
forall record typ.
PersistEntity record =>
EntityField record typ -> DBField
DBField EntityField PoolMetadata StakePoolMetadataHash
forall typ.
(typ ~ StakePoolMetadataHash) =>
EntityField PoolMetadata typ
PoolMetadataHash)
            let query :: Text
query = [Text] -> Text
T.unwords
                    [ Text
"SELECT"
                        , Text
"a." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
poolId, Text
","
                        , Text
"a." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
metadataUrl, Text
","
                        , Text
"a." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
metadataHash
                    , Text
"FROM", Text
registrations, Text
"AS a"
                    , Text
"LEFT JOIN", Text
fetchAttempts, Text
"AS b"
                    , Text
"ON"
                        , Text
"a." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
metadataUrl,  Text
"=", Text
"b." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
metadataUrl, Text
"AND"
                        , Text
"a." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
metadataHash, Text
"=", Text
"b." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
metadataHash
                    , Text
"WHERE"
                        -- Successfully fetched metadata
                        , Text
"a." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
metadataHash, Text
"NOT", Text
"IN"
                        , Text
"("
                        , Text
"SELECT", Text
metadataHash
                        , Text
"FROM", Text
metadata
                        , Text
")"
                    , Text
"AND"
                        -- Discard recent failed attempts
                        , Text
"("
                        , Text
retryAfter, Text
"<", Text
"datetime('now')"
                        , Text
"OR"
                        , Text
retryAfter, Text
"IS NULL"
                        , Text
")"
                    -- Important, since we have a limit, we order all results by
                    -- earliest "retry_after", so that we are sure that all
                    -- metadata gets _eventually_ processed.
                    --
                    -- Note that `NULL` is smaller than everything.
                    , Text
"ORDER BY", Text
retryAfter, Text
"ASC"
                    , Text
"LIMIT", Text
nLimit
                    , Text
";"
                    ]

            let safeCast :: (Single PersistValue, Single PersistValue, Single PersistValue)
-> Either Text (a, a, a)
safeCast (Single PersistValue
a, Single PersistValue
b, Single PersistValue
c) = (,,)
                    (a -> a -> a -> (a, a, a))
-> Either Text a -> Either Text (a -> a -> (a, a, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistValue -> Either Text a
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
a
                    Either Text (a -> a -> (a, a, a))
-> Either Text a -> Either Text (a -> (a, a, a))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PersistValue -> Either Text a
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
b
                    Either Text (a -> (a, a, a))
-> Either Text a -> Either Text (a, a, a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PersistValue -> Either Text a
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
c

            [Either Text (a, a, a)] -> [(a, a, a)]
forall a b. [Either a b] -> [b]
rights ([Either Text (a, a, a)] -> [(a, a, a)])
-> ([(Single PersistValue, Single PersistValue,
      Single PersistValue)]
    -> [Either Text (a, a, a)])
-> [(Single PersistValue, Single PersistValue,
     Single PersistValue)]
-> [(a, a, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Single PersistValue, Single PersistValue, Single PersistValue)
 -> Either Text (a, a, a))
-> [(Single PersistValue, Single PersistValue,
     Single PersistValue)]
-> [Either Text (a, a, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Single PersistValue, Single PersistValue, Single PersistValue)
-> Either Text (a, a, a)
forall a a a.
(PersistField a, PersistField a, PersistField a) =>
(Single PersistValue, Single PersistValue, Single PersistValue)
-> Either Text (a, a, a)
safeCast ([(Single PersistValue, Single PersistValue, Single PersistValue)]
 -> [(a, a, a)])
-> ReaderT
     backend
     m
     [(Single PersistValue, Single PersistValue, Single PersistValue)]
-> ReaderT backend m [(a, a, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> [PersistValue]
-> ReaderT
     backend
     m
     [(Single PersistValue, Single PersistValue, Single PersistValue)]
forall a (m :: * -> *) backend.
(RawSql a, MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m [a]
rawSql Text
query []

        putFetchAttempt :: (StakePoolMetadataUrl, StakePoolMetadataHash)
-> ReaderT backend m ()
putFetchAttempt (StakePoolMetadataUrl
url, StakePoolMetadataHash
hash) = do
            -- NOTE
            -- assuming SQLite has the same notion of "now" that the host system.
            UTCTime
now <- IO UTCTime -> ReaderT backend m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
            Word8
retryCount <- Word8
-> (Entity PoolMetadataFetchAttempts -> Word8)
-> Maybe (Entity PoolMetadataFetchAttempts)
-> Word8
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word8
0 (PoolMetadataFetchAttempts -> Word8
poolFetchAttemptsRetryCount (PoolMetadataFetchAttempts -> Word8)
-> (Entity PoolMetadataFetchAttempts -> PoolMetadataFetchAttempts)
-> Entity PoolMetadataFetchAttempts
-> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity PoolMetadataFetchAttempts -> PoolMetadataFetchAttempts
forall record. Entity record -> record
entityVal) (Maybe (Entity PoolMetadataFetchAttempts) -> Word8)
-> ReaderT backend m (Maybe (Entity PoolMetadataFetchAttempts))
-> ReaderT backend m Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Filter PoolMetadataFetchAttempts]
-> [SelectOpt PoolMetadataFetchAttempts]
-> ReaderT backend m (Maybe (Entity PoolMetadataFetchAttempts))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst
                [ EntityField PoolMetadataFetchAttempts StakePoolMetadataHash
forall typ.
(typ ~ StakePoolMetadataHash) =>
EntityField PoolMetadataFetchAttempts typ
PoolFetchAttemptsMetadataHash EntityField PoolMetadataFetchAttempts StakePoolMetadataHash
-> StakePoolMetadataHash -> Filter PoolMetadataFetchAttempts
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. StakePoolMetadataHash
hash
                , EntityField PoolMetadataFetchAttempts StakePoolMetadataUrl
forall typ.
(typ ~ StakePoolMetadataUrl) =>
EntityField PoolMetadataFetchAttempts typ
PoolFetchAttemptsMetadataUrl  EntityField PoolMetadataFetchAttempts StakePoolMetadataUrl
-> StakePoolMetadataUrl -> Filter PoolMetadataFetchAttempts
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. StakePoolMetadataUrl
url
                ] []
            let retryAfter :: UTCTime
retryAfter = UTCTime -> Word8 -> UTCTime
backoff UTCTime
now Word8
retryCount
            Key PoolMetadataFetchAttempts
-> PoolMetadataFetchAttempts -> ReaderT backend m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
repsert
                (StakePoolMetadataHash
-> StakePoolMetadataUrl -> Key PoolMetadataFetchAttempts
PoolMetadataFetchAttemptsKey StakePoolMetadataHash
hash StakePoolMetadataUrl
url)
                (StakePoolMetadataHash
-> StakePoolMetadataUrl
-> UTCTime
-> Word8
-> PoolMetadataFetchAttempts
PoolMetadataFetchAttempts StakePoolMetadataHash
hash StakePoolMetadataUrl
url UTCTime
retryAfter (Word8
retryCount Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
1))

        putPoolMetadata :: StakePoolMetadataHash -> StakePoolMetadata -> ReaderT backend m ()
putPoolMetadata StakePoolMetadataHash
hash StakePoolMetadata
metadata = do
            let StakePoolMetadata
                    {StakePoolTicker
$sel:ticker:StakePoolMetadata :: StakePoolMetadata -> StakePoolTicker
ticker :: StakePoolTicker
ticker, Text
$sel:name:StakePoolMetadata :: StakePoolMetadata -> Text
name :: Text
name, Maybe Text
$sel:description:StakePoolMetadata :: StakePoolMetadata -> Maybe Text
description :: Maybe Text
description, Text
$sel:homepage:StakePoolMetadata :: StakePoolMetadata -> Text
homepage :: Text
homepage} = StakePoolMetadata
metadata
            Key PoolMetadata -> PoolMetadata -> ReaderT backend m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
repsert
                (StakePoolMetadataHash -> Key PoolMetadata
PoolMetadataKey StakePoolMetadataHash
hash)
                (StakePoolMetadataHash
-> Text -> StakePoolTicker -> Maybe Text -> Text -> PoolMetadata
PoolMetadata StakePoolMetadataHash
hash Text
name StakePoolTicker
ticker Maybe Text
description Text
homepage)
            [Filter PoolMetadataFetchAttempts] -> ReaderT backend m ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [ EntityField PoolMetadataFetchAttempts StakePoolMetadataHash
forall typ.
(typ ~ StakePoolMetadataHash) =>
EntityField PoolMetadataFetchAttempts typ
PoolFetchAttemptsMetadataHash EntityField PoolMetadataFetchAttempts StakePoolMetadataHash
-> StakePoolMetadataHash -> Filter PoolMetadataFetchAttempts
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. StakePoolMetadataHash
hash ]

        removePoolMetadata :: ReaderT SqlBackend IO ()
removePoolMetadata = do
            [Filter PoolMetadata] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ([] :: [Filter PoolMetadata])
            [Filter PoolMetadataFetchAttempts] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ([] :: [Filter PoolMetadataFetchAttempts])
            [Filter PoolDelistment] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ([] :: [Filter PoolDelistment])

        readPoolMetadata :: ReaderT SqlBackend IO (Map StakePoolMetadataHash StakePoolMetadata)
readPoolMetadata = do
            [(StakePoolMetadataHash, StakePoolMetadata)]
-> Map StakePoolMetadataHash StakePoolMetadata
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(StakePoolMetadataHash, StakePoolMetadata)]
 -> Map StakePoolMetadataHash StakePoolMetadata)
-> ([Entity PoolMetadata]
    -> [(StakePoolMetadataHash, StakePoolMetadata)])
-> [Entity PoolMetadata]
-> Map StakePoolMetadataHash StakePoolMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entity PoolMetadata -> (StakePoolMetadataHash, StakePoolMetadata))
-> [Entity PoolMetadata]
-> [(StakePoolMetadataHash, StakePoolMetadata)]
forall a b. (a -> b) -> [a] -> [b]
map (PoolMetadata -> (StakePoolMetadataHash, StakePoolMetadata)
fromPoolMeta (PoolMetadata -> (StakePoolMetadataHash, StakePoolMetadata))
-> (Entity PoolMetadata -> PoolMetadata)
-> Entity PoolMetadata
-> (StakePoolMetadataHash, StakePoolMetadata)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity PoolMetadata -> PoolMetadata
forall record. Entity record -> record
entityVal)
                ([Entity PoolMetadata]
 -> Map StakePoolMetadataHash StakePoolMetadata)
-> ReaderT SqlBackend IO [Entity PoolMetadata]
-> ReaderT
     SqlBackend IO (Map StakePoolMetadataHash StakePoolMetadata)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Filter PoolMetadata]
-> [SelectOpt PoolMetadata]
-> ReaderT SqlBackend IO [Entity PoolMetadata]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [] []

        listRegisteredPools :: ReaderT SqlBackend IO [PoolId]
listRegisteredPools = do
            (Entity PoolRegistration -> PoolId)
-> [Entity PoolRegistration] -> [PoolId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PoolRegistration -> PoolId
poolRegistrationPoolId (PoolRegistration -> PoolId)
-> (Entity PoolRegistration -> PoolRegistration)
-> Entity PoolRegistration
-> PoolId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity PoolRegistration -> PoolRegistration
forall record. Entity record -> record
entityVal) ([Entity PoolRegistration] -> [PoolId])
-> ReaderT SqlBackend IO [Entity PoolRegistration]
-> ReaderT SqlBackend IO [PoolId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Filter PoolRegistration]
-> [SelectOpt PoolRegistration]
-> ReaderT SqlBackend IO [Entity PoolRegistration]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [ ]
                [ EntityField PoolRegistration SlotNo -> SelectOpt PoolRegistration
forall record typ. EntityField record typ -> SelectOpt record
Desc EntityField PoolRegistration SlotNo
forall typ. (typ ~ SlotNo) => EntityField PoolRegistration typ
PoolRegistrationSlot
                , EntityField PoolRegistration Word64 -> SelectOpt PoolRegistration
forall record typ. EntityField record typ -> SelectOpt record
Desc EntityField PoolRegistration Word64
forall typ. (typ ~ Word64) => EntityField PoolRegistration typ
PoolRegistrationSlotInternalIndex
                ]

        listRetiredPools :: EpochNo -> ReaderT SqlBackend IO [PoolRetirementCertificate]
listRetiredPools EpochNo
epochNo = Tracer IO PoolDbLog
-> RawQuery
     (Single PersistValue, Single PersistValue)
     PoolRetirementCertificate
-> ReaderT SqlBackend IO [PoolRetirementCertificate]
forall a b.
RawSql a =>
Tracer IO PoolDbLog -> RawQuery a b -> SqlPersistT IO [b]
runRawQuery Tracer IO PoolDbLog
tr (RawQuery
   (Single PersistValue, Single PersistValue)
   PoolRetirementCertificate
 -> ReaderT SqlBackend IO [PoolRetirementCertificate])
-> RawQuery
     (Single PersistValue, Single PersistValue)
     PoolRetirementCertificate
-> ReaderT SqlBackend IO [PoolRetirementCertificate]
forall a b. (a -> b) -> a -> b
$
            Text
-> Text
-> [PersistValue]
-> ((Single PersistValue, Single PersistValue)
    -> Either Text PoolRetirementCertificate)
-> RawQuery
     (Single PersistValue, Single PersistValue)
     PoolRetirementCertificate
forall a b.
Text
-> Text -> [PersistValue] -> (a -> Either Text b) -> RawQuery a b
RawQuery Text
"listRetiredPools" Text
query [PersistValue]
parameters (Single PersistValue, Single PersistValue)
-> Either Text PoolRetirementCertificate
parseRow
          where
            query :: Text
query = [Text] -> Text
T.unwords
                [ Text
"SELECT *"
                , Text
"FROM active_pool_retirements"
                , Text
"WHERE retirement_epoch <= ?;"
                ]
            parameters :: [PersistValue]
parameters = [ EpochNo -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue EpochNo
epochNo ]
            parseRow :: (Single PersistValue, Single PersistValue)
-> Either Text PoolRetirementCertificate
parseRow (Single PersistValue
poolId, Single PersistValue
retirementEpoch) =
                PoolId -> EpochNo -> PoolRetirementCertificate
PoolRetirementCertificate
                    (PoolId -> EpochNo -> PoolRetirementCertificate)
-> Either Text PoolId
-> Either Text (EpochNo -> PoolRetirementCertificate)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistValue -> Either Text PoolId
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
poolId
                    Either Text (EpochNo -> PoolRetirementCertificate)
-> Either Text EpochNo -> Either Text PoolRetirementCertificate
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PersistValue -> Either Text EpochNo
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
retirementEpoch

        listPoolLifeCycleData :: EpochNo -> SqlPersistT IO [PoolLifeCycleStatus]
listPoolLifeCycleData EpochNo
epochNo = Tracer IO PoolDbLog
-> RawQuery
     (Single PersistValue, Single PersistValue, Single PersistValue,
      Single PersistValue, Single PersistValue, Single PersistValue,
      Single PersistValue, Single PersistValue, Single PersistValue)
     PoolLifeCycleStatus
-> SqlPersistT IO [PoolLifeCycleStatus]
forall a b.
RawSql a =>
Tracer IO PoolDbLog -> RawQuery a b -> SqlPersistT IO [b]
runRawQuery Tracer IO PoolDbLog
tr (RawQuery
   (Single PersistValue, Single PersistValue, Single PersistValue,
    Single PersistValue, Single PersistValue, Single PersistValue,
    Single PersistValue, Single PersistValue, Single PersistValue)
   PoolLifeCycleStatus
 -> SqlPersistT IO [PoolLifeCycleStatus])
-> RawQuery
     (Single PersistValue, Single PersistValue, Single PersistValue,
      Single PersistValue, Single PersistValue, Single PersistValue,
      Single PersistValue, Single PersistValue, Single PersistValue)
     PoolLifeCycleStatus
-> SqlPersistT IO [PoolLifeCycleStatus]
forall a b. (a -> b) -> a -> b
$ Text
-> Text
-> [PersistValue]
-> ((Single PersistValue, Single PersistValue, Single PersistValue,
     Single PersistValue, Single PersistValue, Single PersistValue,
     Single PersistValue, Single PersistValue, Single PersistValue)
    -> Either Text PoolLifeCycleStatus)
-> RawQuery
     (Single PersistValue, Single PersistValue, Single PersistValue,
      Single PersistValue, Single PersistValue, Single PersistValue,
      Single PersistValue, Single PersistValue, Single PersistValue)
     PoolLifeCycleStatus
forall a b.
Text
-> Text -> [PersistValue] -> (a -> Either Text b) -> RawQuery a b
RawQuery
            Text
"listPoolLifeCycleData" Text
query [PersistValue]
parameters (Single PersistValue, Single PersistValue, Single PersistValue,
 Single PersistValue, Single PersistValue, Single PersistValue,
 Single PersistValue, Single PersistValue, Single PersistValue)
-> Either Text PoolLifeCycleStatus
parseRow
          where
            query :: Text
query = [Text] -> Text
T.unwords
                [ Text
"SELECT *"
                , Text
"FROM active_pool_lifecycle_data"
                , Text
"WHERE retirement_epoch IS NULL OR retirement_epoch > ?;"
                ]
            parameters :: [PersistValue]
parameters = [ EpochNo -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue EpochNo
epochNo ]
            parseRow :: (Single PersistValue, Single PersistValue, Single PersistValue,
 Single PersistValue, Single PersistValue, Single PersistValue,
 Single PersistValue, Single PersistValue, Single PersistValue)
-> Either Text PoolLifeCycleStatus
parseRow
                ( Single PersistValue
fieldPoolId
                , Single PersistValue
fieldRetirementEpoch
                , Single PersistValue
fieldOwners
                , Single PersistValue
fieldCost
                , Single PersistValue
fieldPledge
                , Single PersistValue
fieldMarginNumerator
                , Single PersistValue
fieldMarginDenominator
                , Single PersistValue
fieldMetadataHash
                , Single PersistValue
fieldMetadataUrl
                ) = do
                PoolRegistrationCertificate
regCert <- Either Text PoolRegistrationCertificate
parseRegistrationCertificate
                Either Text (Maybe PoolRetirementCertificate)
parseRetirementCertificate Either Text (Maybe PoolRetirementCertificate)
-> (Maybe PoolRetirementCertificate -> PoolLifeCycleStatus)
-> Either Text PoolLifeCycleStatus
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> PoolLifeCycleStatus
-> (PoolRetirementCertificate -> PoolLifeCycleStatus)
-> Maybe PoolRetirementCertificate
-> PoolLifeCycleStatus
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                    (PoolRegistrationCertificate -> PoolLifeCycleStatus
PoolRegistered PoolRegistrationCertificate
regCert)
                    (PoolRegistrationCertificate
-> PoolRetirementCertificate -> PoolLifeCycleStatus
PoolRegisteredAndRetired PoolRegistrationCertificate
regCert)
              where
                parseRegistrationCertificate :: Either Text PoolRegistrationCertificate
parseRegistrationCertificate = PoolId
-> [PoolOwner]
-> Percentage
-> Coin
-> Coin
-> Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
-> PoolRegistrationCertificate
PoolRegistrationCertificate
                    (PoolId
 -> [PoolOwner]
 -> Percentage
 -> Coin
 -> Coin
 -> Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
 -> PoolRegistrationCertificate)
-> Either Text PoolId
-> Either
     Text
     ([PoolOwner]
      -> Percentage
      -> Coin
      -> Coin
      -> Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
      -> PoolRegistrationCertificate)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistValue -> Either Text PoolId
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
fieldPoolId
                    Either
  Text
  ([PoolOwner]
   -> Percentage
   -> Coin
   -> Coin
   -> Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
   -> PoolRegistrationCertificate)
-> Either Text [PoolOwner]
-> Either
     Text
     (Percentage
      -> Coin
      -> Coin
      -> Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
      -> PoolRegistrationCertificate)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PersistValue -> Either Text [PoolOwner]
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
fieldOwners
                    Either
  Text
  (Percentage
   -> Coin
   -> Coin
   -> Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
   -> PoolRegistrationCertificate)
-> Either Text Percentage
-> Either
     Text
     (Coin
      -> Coin
      -> Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
      -> PoolRegistrationCertificate)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either Text Percentage
parseMargin
                    Either
  Text
  (Coin
   -> Coin
   -> Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
   -> PoolRegistrationCertificate)
-> Either Text Coin
-> Either
     Text
     (Coin
      -> Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
      -> PoolRegistrationCertificate)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Word64 -> Coin
Coin.fromWord64 (Word64 -> Coin) -> Either Text Word64 -> Either Text Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistValue -> Either Text Word64
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
fieldCost)
                    Either
  Text
  (Coin
   -> Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
   -> PoolRegistrationCertificate)
-> Either Text Coin
-> Either
     Text
     (Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
      -> PoolRegistrationCertificate)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Word64 -> Coin
Coin.fromWord64 (Word64 -> Coin) -> Either Text Word64 -> Either Text Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistValue -> Either Text Word64
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
fieldPledge)
                    Either
  Text
  (Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
   -> PoolRegistrationCertificate)
-> Either
     Text (Maybe (StakePoolMetadataUrl, StakePoolMetadataHash))
-> Either Text PoolRegistrationCertificate
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either Text (Maybe (StakePoolMetadataUrl, StakePoolMetadataHash))
parseMetadata

                parseRetirementCertificate :: Either Text (Maybe PoolRetirementCertificate)
parseRetirementCertificate = do
                    PoolId
poolId <- PersistValue -> Either Text PoolId
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
fieldPoolId
                    Maybe EpochNo
mRetirementEpoch <- PersistValue -> Either Text (Maybe EpochNo)
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
fieldRetirementEpoch
                    Maybe PoolRetirementCertificate
-> Either Text (Maybe PoolRetirementCertificate)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PoolRetirementCertificate
 -> Either Text (Maybe PoolRetirementCertificate))
-> Maybe PoolRetirementCertificate
-> Either Text (Maybe PoolRetirementCertificate)
forall a b. (a -> b) -> a -> b
$ PoolId -> EpochNo -> PoolRetirementCertificate
PoolRetirementCertificate PoolId
poolId (EpochNo -> PoolRetirementCertificate)
-> Maybe EpochNo -> Maybe PoolRetirementCertificate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe EpochNo
mRetirementEpoch

                parseMargin :: Either Text Percentage
parseMargin = Word64 -> Word64 -> Percentage
forall a. Integral a => a -> a -> Percentage
mkMargin
                    (Word64 -> Word64 -> Percentage)
-> Either Text Word64 -> Either Text (Word64 -> Percentage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistValue -> Either Text Word64
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue @Word64 PersistValue
fieldMarginNumerator
                    Either Text (Word64 -> Percentage)
-> Either Text Word64 -> Either Text Percentage
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PersistValue -> Either Text Word64
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue @Word64 PersistValue
fieldMarginDenominator
                  where
                    mkMargin :: a -> a -> Percentage
mkMargin a
n a
d = HasCallStack => Ratio Integer -> Percentage
Ratio Integer -> Percentage
unsafeMkPercentage (Ratio Integer -> Percentage) -> Ratio Integer -> Percentage
forall a b. (a -> b) -> a -> b
$ Ratio a -> Ratio Integer
forall a. Real a => a -> Ratio Integer
toRational (Ratio a -> Ratio Integer) -> Ratio a -> Ratio Integer
forall a b. (a -> b) -> a -> b
$ a
n a -> a -> Ratio a
forall a. Integral a => a -> a -> Ratio a
% a
d

                parseMetadata :: Either Text (Maybe (StakePoolMetadataUrl, StakePoolMetadataHash))
parseMetadata = do
                    Maybe StakePoolMetadataUrl
u <- PersistValue -> Either Text (Maybe StakePoolMetadataUrl)
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
fieldMetadataUrl
                    Maybe StakePoolMetadataHash
h <- PersistValue -> Either Text (Maybe StakePoolMetadataHash)
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
fieldMetadataHash
                    Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
-> Either
     Text (Maybe (StakePoolMetadataUrl, StakePoolMetadataHash))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
 -> Either
      Text (Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)))
-> Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
-> Either
     Text (Maybe (StakePoolMetadataUrl, StakePoolMetadataHash))
forall a b. (a -> b) -> a -> b
$ (,) (StakePoolMetadataUrl
 -> StakePoolMetadataHash
 -> (StakePoolMetadataUrl, StakePoolMetadataHash))
-> Maybe StakePoolMetadataUrl
-> Maybe
     (StakePoolMetadataHash
      -> (StakePoolMetadataUrl, StakePoolMetadataHash))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe StakePoolMetadataUrl
u Maybe
  (StakePoolMetadataHash
   -> (StakePoolMetadataUrl, StakePoolMetadataHash))
-> Maybe StakePoolMetadataHash
-> Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe StakePoolMetadataHash
h

        rollbackTo :: SlotNo -> ReaderT SqlBackend IO ()
rollbackTo SlotNo
point = do
            -- TODO(ADP-356): What if the conversion blocks or fails?
            --
            -- Missing a rollback would be bad.
            EpochNo Word31
epoch <- IO EpochNo -> ReaderT SqlBackend IO EpochNo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO EpochNo -> ReaderT SqlBackend IO EpochNo)
-> IO EpochNo -> ReaderT SqlBackend IO EpochNo
forall a b. (a -> b) -> a -> b
$ TimeInterpreter IO -> Qry EpochNo -> IO EpochNo
forall (m :: * -> *) a.
(HasCallStack, Monad m) =>
TimeInterpreter m -> Qry a -> m a
interpretQuery TimeInterpreter IO
ti (SlotNo -> Qry EpochNo
epochOf SlotNo
point)
            [Filter StakeDistribution] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [ EntityField StakeDistribution Word64
forall typ. (typ ~ Word64) => EntityField StakeDistribution typ
StakeDistributionEpoch EntityField StakeDistribution Word64
-> Word64 -> Filter StakeDistribution
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>. Word31 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word31
epoch ]

            [Filter PoolProduction] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [ EntityField PoolProduction SlotNo
forall typ. (typ ~ SlotNo) => EntityField PoolProduction typ
PoolProductionSlot EntityField PoolProduction SlotNo
-> SlotNo -> Filter PoolProduction
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>. SlotNo
point ]
            [Filter PoolRegistration] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [ EntityField PoolRegistration SlotNo
forall typ. (typ ~ SlotNo) => EntityField PoolRegistration typ
PoolRegistrationSlot EntityField PoolRegistration SlotNo
-> SlotNo -> Filter PoolRegistration
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>. SlotNo
point ]
            [Filter PoolRetirement] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [ EntityField PoolRetirement SlotNo
forall typ. (typ ~ SlotNo) => EntityField PoolRetirement typ
PoolRetirementSlot EntityField PoolRetirement SlotNo
-> SlotNo -> Filter PoolRetirement
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>. SlotNo
point ]
            [Filter BlockHeader] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [ EntityField BlockHeader SlotNo
forall typ. (typ ~ SlotNo) => EntityField BlockHeader typ
BlockSlot EntityField BlockHeader SlotNo -> SlotNo -> Filter BlockHeader
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>. SlotNo
point ]
            -- TODO: remove dangling metadata no longer attached to a pool

        putDelistedPools :: [PoolId] -> ReaderT backend m ()
putDelistedPools [PoolId]
pools = do
            [Filter PoolDelistment] -> ReaderT backend m ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ([] :: [Filter PoolDelistment])
            [PoolDelistment] -> ReaderT backend m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[record] -> ReaderT backend m ()
insertMany_ ([PoolDelistment] -> ReaderT backend m ())
-> [PoolDelistment] -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$ (PoolId -> PoolDelistment) -> [PoolId] -> [PoolDelistment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PoolId -> PoolDelistment
PoolDelistment [PoolId]
pools

        readDelistedPools :: ReaderT SqlBackend IO [PoolId]
readDelistedPools =
            (Entity PoolDelistment -> PoolId)
-> [Entity PoolDelistment] -> [PoolId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PoolDelistment -> PoolId
delistedPoolId (PoolDelistment -> PoolId)
-> (Entity PoolDelistment -> PoolDelistment)
-> Entity PoolDelistment
-> PoolId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity PoolDelistment -> PoolDelistment
forall record. Entity record -> record
entityVal) ([Entity PoolDelistment] -> [PoolId])
-> ReaderT SqlBackend IO [Entity PoolDelistment]
-> ReaderT SqlBackend IO [PoolId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Filter PoolDelistment]
-> [SelectOpt PoolDelistment]
-> ReaderT SqlBackend IO [Entity PoolDelistment]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [] []

        removePools :: [PoolId] -> ReaderT SqlBackend IO ()
removePools = (PoolId -> ReaderT SqlBackend IO ())
-> [PoolId] -> ReaderT SqlBackend IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((PoolId -> ReaderT SqlBackend IO ())
 -> [PoolId] -> ReaderT SqlBackend IO ())
-> (PoolId -> ReaderT SqlBackend IO ())
-> [PoolId]
-> ReaderT SqlBackend IO ()
forall a b. (a -> b) -> a -> b
$ \PoolId
pool -> do
            IO () -> ReaderT SqlBackend IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT SqlBackend IO ())
-> IO () -> ReaderT SqlBackend IO ()
forall a b. (a -> b) -> a -> b
$ Tracer IO PoolDbLog -> PoolDbLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO PoolDbLog
tr (PoolDbLog -> IO ()) -> PoolDbLog -> IO ()
forall a b. (a -> b) -> a -> b
$ PoolId -> PoolDbLog
MsgRemovingPool PoolId
pool
            [Filter PoolProduction] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [ EntityField PoolProduction PoolId
forall typ. (typ ~ PoolId) => EntityField PoolProduction typ
PoolProductionPoolId EntityField PoolProduction PoolId
-> PoolId -> Filter PoolProduction
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. PoolId
pool ]
            [Filter PoolOwner] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [ EntityField PoolOwner PoolId
forall typ. (typ ~ PoolId) => EntityField PoolOwner typ
PoolOwnerPoolId EntityField PoolOwner PoolId -> PoolId -> Filter PoolOwner
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. PoolId
pool ]
            [Filter PoolRegistration] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [ EntityField PoolRegistration PoolId
forall typ. (typ ~ PoolId) => EntityField PoolRegistration typ
PoolRegistrationPoolId EntityField PoolRegistration PoolId
-> PoolId -> Filter PoolRegistration
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. PoolId
pool ]
            [Filter PoolRetirement] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [ EntityField PoolRetirement PoolId
forall typ. (typ ~ PoolId) => EntityField PoolRetirement typ
PoolRetirementPoolId EntityField PoolRetirement PoolId
-> PoolId -> Filter PoolRetirement
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. PoolId
pool ]
            [Filter StakeDistribution] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [ EntityField StakeDistribution PoolId
forall typ. (typ ~ PoolId) => EntityField StakeDistribution typ
StakeDistributionPoolId EntityField StakeDistribution PoolId
-> PoolId -> Filter StakeDistribution
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. PoolId
pool ]

        removeRetiredPools :: EpochNo -> ReaderT SqlBackend IO [PoolRetirementCertificate]
removeRetiredPools EpochNo
epoch =
            Tracer (ReaderT SqlBackend IO) BracketLog
-> ReaderT SqlBackend IO [PoolRetirementCertificate]
-> ReaderT SqlBackend IO [PoolRetirementCertificate]
forall (m :: * -> *) a.
MonadUnliftIO m =>
Tracer m BracketLog -> m a -> m a
bracketTracer Tracer (ReaderT SqlBackend IO) BracketLog
traceOuter ReaderT SqlBackend IO [PoolRetirementCertificate]
action
          where
            action :: ReaderT SqlBackend IO [PoolRetirementCertificate]
action = EpochNo -> ReaderT SqlBackend IO [PoolRetirementCertificate]
listRetiredPools EpochNo
epoch ReaderT SqlBackend IO [PoolRetirementCertificate]
-> ([PoolRetirementCertificate]
    -> ReaderT SqlBackend IO [PoolRetirementCertificate])
-> ReaderT SqlBackend IO [PoolRetirementCertificate]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[PoolRetirementCertificate]
retirementCerts -> do
                [PoolRetirementCertificate] -> ReaderT SqlBackend IO ()
traceInner [PoolRetirementCertificate]
retirementCerts
                [PoolId] -> ReaderT SqlBackend IO ()
removePools (((PoolId -> Const PoolId PoolId)
 -> PoolRetirementCertificate
 -> Const PoolId PoolRetirementCertificate)
-> PoolRetirementCertificate -> PoolId
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "poolId"
  ((PoolId -> Const PoolId PoolId)
   -> PoolRetirementCertificate
   -> Const PoolId PoolRetirementCertificate)
(PoolId -> Const PoolId PoolId)
-> PoolRetirementCertificate
-> Const PoolId PoolRetirementCertificate
#poolId (PoolRetirementCertificate -> PoolId)
-> [PoolRetirementCertificate] -> [PoolId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PoolRetirementCertificate]
retirementCerts)
                [PoolRetirementCertificate]
-> ReaderT SqlBackend IO [PoolRetirementCertificate]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [PoolRetirementCertificate]
retirementCerts
            traceOuter :: Tracer (ReaderT SqlBackend IO) BracketLog
traceOuter = Tracer IO PoolDbLog
tr
                Tracer IO PoolDbLog
-> (Tracer IO PoolDbLog
    -> Tracer (ReaderT SqlBackend IO) PoolDbLog)
-> Tracer (ReaderT SqlBackend IO) PoolDbLog
forall a b. a -> (a -> b) -> b
& (forall x. IO x -> ReaderT SqlBackend IO x)
-> Tracer IO PoolDbLog -> Tracer (ReaderT SqlBackend IO) PoolDbLog
forall (m :: * -> *) (n :: * -> *) s.
(forall x. m x -> n x) -> Tracer m s -> Tracer n s
natTracer forall x. IO x -> ReaderT SqlBackend IO x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                Tracer (ReaderT SqlBackend IO) PoolDbLog
-> (Tracer (ReaderT SqlBackend IO) PoolDbLog
    -> Tracer (ReaderT SqlBackend IO) BracketLog)
-> Tracer (ReaderT SqlBackend IO) BracketLog
forall a b. a -> (a -> b) -> b
& (BracketLog -> PoolDbLog)
-> Tracer (ReaderT SqlBackend IO) PoolDbLog
-> Tracer (ReaderT SqlBackend IO) BracketLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (EpochNo -> BracketLog -> PoolDbLog
MsgRemovingRetiredPoolsForEpoch EpochNo
epoch)
            traceInner :: [PoolRetirementCertificate] -> ReaderT SqlBackend IO ()
traceInner = IO () -> ReaderT SqlBackend IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                (IO () -> ReaderT SqlBackend IO ())
-> ([PoolRetirementCertificate] -> IO ())
-> [PoolRetirementCertificate]
-> ReaderT SqlBackend IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tracer IO PoolDbLog -> PoolDbLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO PoolDbLog
tr
                (PoolDbLog -> IO ())
-> ([PoolRetirementCertificate] -> PoolDbLog)
-> [PoolRetirementCertificate]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PoolRetirementCertificate] -> PoolDbLog
MsgRemovingRetiredPools

        readPoolProductionCursor :: Int -> ReaderT backend m [BlockHeader]
readPoolProductionCursor Int
k = do
            [BlockHeader] -> [BlockHeader]
forall a. [a] -> [a]
reverse ([BlockHeader] -> [BlockHeader])
-> ([Entity PoolProduction] -> [BlockHeader])
-> [Entity PoolProduction]
-> [BlockHeader]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entity PoolProduction -> BlockHeader)
-> [Entity PoolProduction] -> [BlockHeader]
forall a b. (a -> b) -> [a] -> [b]
map ((PoolId, BlockHeader) -> BlockHeader
forall a b. (a, b) -> b
snd ((PoolId, BlockHeader) -> BlockHeader)
-> (Entity PoolProduction -> (PoolId, BlockHeader))
-> Entity PoolProduction
-> BlockHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolProduction -> (PoolId, BlockHeader)
fromPoolProduction (PoolProduction -> (PoolId, BlockHeader))
-> (Entity PoolProduction -> PoolProduction)
-> Entity PoolProduction
-> (PoolId, BlockHeader)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity PoolProduction -> PoolProduction
forall record. Entity record -> record
entityVal) ([Entity PoolProduction] -> [BlockHeader])
-> ReaderT backend m [Entity PoolProduction]
-> ReaderT backend m [BlockHeader]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Filter PoolProduction]
-> [SelectOpt PoolProduction]
-> ReaderT backend m [Entity PoolProduction]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList
                []
                [EntityField PoolProduction SlotNo -> SelectOpt PoolProduction
forall record typ. EntityField record typ -> SelectOpt record
Desc EntityField PoolProduction SlotNo
forall typ. (typ ~ SlotNo) => EntityField PoolProduction typ
PoolProductionSlot, Int -> SelectOpt PoolProduction
forall record. Int -> SelectOpt record
LimitTo Int
k]

        readSystemSeed :: ReaderT SqlBackend IO StdGen
readSystemSeed = do
            Maybe (Entity ArbitrarySeed)
mseed <- [Filter ArbitrarySeed]
-> [SelectOpt ArbitrarySeed]
-> ReaderT SqlBackend IO (Maybe (Entity ArbitrarySeed))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst [] []
            case Maybe (Entity ArbitrarySeed)
mseed of
                Maybe (Entity ArbitrarySeed)
Nothing -> do
                    StdGen
seed <- IO StdGen -> ReaderT SqlBackend IO StdGen
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
                    ArbitrarySeed -> ReaderT SqlBackend IO ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
record -> ReaderT backend m ()
insert_ (StdGen -> ArbitrarySeed
ArbitrarySeed StdGen
seed)
                    StdGen -> ReaderT SqlBackend IO StdGen
forall (m :: * -> *) a. Monad m => a -> m a
return StdGen
seed
                Just Entity ArbitrarySeed
seed ->
                    StdGen -> ReaderT SqlBackend IO StdGen
forall (m :: * -> *) a. Monad m => a -> m a
return (StdGen -> ReaderT SqlBackend IO StdGen)
-> StdGen -> ReaderT SqlBackend IO StdGen
forall a b. (a -> b) -> a -> b
$ ArbitrarySeed -> StdGen
seedSeed (ArbitrarySeed -> StdGen) -> ArbitrarySeed -> StdGen
forall a b. (a -> b) -> a -> b
$ Entity ArbitrarySeed -> ArbitrarySeed
forall record. Entity record -> record
entityVal Entity ArbitrarySeed
seed

        readSettings :: ReaderT SqlBackend IO Settings
readSettings = do
            [Entity Settings]
l <- [Filter Settings]
-> [SelectOpt Settings] -> ReaderT SqlBackend IO [Entity Settings]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList
                []
                -- only ever read the first row
                [EntityField Settings SettingsId -> SelectOpt Settings
forall record typ. EntityField record typ -> SelectOpt record
Asc EntityField Settings SettingsId
forall typ. (typ ~ SettingsId) => EntityField Settings typ
SettingsId, Int -> SelectOpt Settings
forall record. Int -> SelectOpt record
LimitTo Int
1]
            case [Entity Settings]
l of
                [] -> Settings -> ReaderT SqlBackend IO Settings
forall (f :: * -> *) a. Applicative f => a -> f a
pure Settings
defaultSettings
                (Entity Settings
x:[Entity Settings]
_) -> Settings -> ReaderT SqlBackend IO Settings
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Settings -> ReaderT SqlBackend IO Settings)
-> (Entity Settings -> Settings)
-> Entity Settings
-> ReaderT SqlBackend IO Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> Settings
fromSettings (Settings -> Settings)
-> (Entity Settings -> Settings) -> Entity Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity Settings -> Settings
forall record. Entity record -> record
entityVal (Entity Settings -> ReaderT SqlBackend IO Settings)
-> Entity Settings -> ReaderT SqlBackend IO Settings
forall a b. (a -> b) -> a -> b
$ Entity Settings
x

        putSettings :: Settings -> ReaderT SqlBackend IO ()
putSettings =
            SettingsId -> Settings -> ReaderT SqlBackend IO ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
repsert
                -- only ever write the first row
                (BackendKey SqlBackend -> SettingsId
SettingsKey BackendKey SqlBackend
1)
            (Settings -> ReaderT SqlBackend IO ())
-> (Settings -> Settings) -> Settings -> ReaderT SqlBackend IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> Settings
toSettings

        readLastMetadataGC :: ReaderT SqlBackend IO (Maybe POSIXTime)
readLastMetadataGC = do
            -- only ever read the first row
            Maybe (Entity InternalState)
result <- [Filter InternalState]
-> [SelectOpt InternalState]
-> ReaderT SqlBackend IO (Maybe (Entity InternalState))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst
                []
                [EntityField InternalState InternalStateId
-> SelectOpt InternalState
forall record typ. EntityField record typ -> SelectOpt record
Asc EntityField InternalState InternalStateId
forall typ.
(typ ~ InternalStateId) =>
EntityField InternalState typ
InternalStateId, Int -> SelectOpt InternalState
forall record. Int -> SelectOpt record
LimitTo Int
1]
            Maybe POSIXTime -> ReaderT SqlBackend IO (Maybe POSIXTime)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe POSIXTime -> ReaderT SqlBackend IO (Maybe POSIXTime))
-> Maybe POSIXTime -> ReaderT SqlBackend IO (Maybe POSIXTime)
forall a b. (a -> b) -> a -> b
$ (InternalState -> Maybe POSIXTime
W.lastMetadataGC (InternalState -> Maybe POSIXTime)
-> (Entity InternalState -> InternalState)
-> Entity InternalState
-> Maybe POSIXTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InternalState -> InternalState
fromInternalState (InternalState -> InternalState)
-> (Entity InternalState -> InternalState)
-> Entity InternalState
-> InternalState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity InternalState -> InternalState
forall record. Entity record -> record
entityVal) (Entity InternalState -> Maybe POSIXTime)
-> Maybe (Entity InternalState) -> Maybe POSIXTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Entity InternalState)
result

        putLastMetadataGC :: POSIXTime -> ReaderT backend m ()
putLastMetadataGC POSIXTime
utc = do
            Maybe (Entity InternalState)
result <- [Filter InternalState]
-> [SelectOpt InternalState]
-> ReaderT backend m (Maybe (Entity InternalState))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst
                [ EntityField InternalState InternalStateId
forall typ.
(typ ~ InternalStateId) =>
EntityField InternalState typ
InternalStateId EntityField InternalState InternalStateId
-> InternalStateId -> Filter InternalState
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. (BackendKey SqlBackend -> InternalStateId
InternalStateKey BackendKey SqlBackend
1) ]
                [ ]
            case Maybe (Entity InternalState)
result of
                Just Entity InternalState
_ -> InternalStateId -> [Update InternalState] -> ReaderT backend m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update (BackendKey SqlBackend -> InternalStateId
InternalStateKey BackendKey SqlBackend
1) [ EntityField InternalState (Maybe POSIXTime)
forall typ.
(typ ~ Maybe POSIXTime) =>
EntityField InternalState typ
LastGCMetadata EntityField InternalState (Maybe POSIXTime)
-> Maybe POSIXTime -> Update InternalState
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. POSIXTime -> Maybe POSIXTime
forall a. a -> Maybe a
Just POSIXTime
utc ]
                Maybe (Entity InternalState)
Nothing -> InternalState -> ReaderT backend m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
record -> ReaderT backend m ()
insert_ (Maybe POSIXTime -> InternalState
InternalState (Maybe POSIXTime -> InternalState)
-> Maybe POSIXTime -> InternalState
forall a b. (a -> b) -> a -> b
$ POSIXTime -> Maybe POSIXTime
forall a. a -> Maybe a
Just POSIXTime
utc)

        cleanDB :: ReaderT SqlBackend IO ()
cleanDB = do
            [Filter PoolProduction] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ([] :: [Filter PoolProduction])
            [Filter PoolOwner] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ([] :: [Filter PoolOwner])
            [Filter PoolRegistration] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ([] :: [Filter PoolRegistration])
            [Filter PoolRetirement] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ([] :: [Filter PoolRetirement])
            [Filter PoolDelistment] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ([] :: [Filter PoolDelistment])
            [Filter StakeDistribution] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ([] :: [Filter StakeDistribution])
            [Filter PoolMetadata] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ([] :: [Filter PoolMetadata])
            [Filter PoolMetadataFetchAttempts] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ([] :: [Filter PoolMetadataFetchAttempts])
            [Filter BlockHeader] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ([] :: [Filter TH.BlockHeader])
            [Filter Settings] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ([] :: [Filter Settings])
            [Filter InternalState] -> ReaderT SqlBackend IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ([] :: [Filter InternalState])

        atomically :: forall a. (SqlPersistT IO a -> IO a)
        atomically :: SqlPersistT IO a -> IO a
atomically = SqlPersistT IO a -> IO a
forall a. SqlPersistT IO a -> IO a
runQuery

        readPoolRegistration :: PoolId
-> ReaderT
     backend
     m
     (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
readPoolRegistration PoolId
poolId = do
            Maybe (Entity PoolRegistration)
result <- [Filter PoolRegistration]
-> [SelectOpt PoolRegistration]
-> ReaderT backend m (Maybe (Entity PoolRegistration))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst
                [ EntityField PoolRegistration PoolId
forall typ. (typ ~ PoolId) => EntityField PoolRegistration typ
PoolRegistrationPoolId EntityField PoolRegistration PoolId
-> PoolId -> Filter PoolRegistration
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. PoolId
poolId ]
                [ EntityField PoolRegistration SlotNo -> SelectOpt PoolRegistration
forall record typ. EntityField record typ -> SelectOpt record
Desc EntityField PoolRegistration SlotNo
forall typ. (typ ~ SlotNo) => EntityField PoolRegistration typ
PoolRegistrationSlot
                , EntityField PoolRegistration Word64 -> SelectOpt PoolRegistration
forall record typ. EntityField record typ -> SelectOpt record
Desc EntityField PoolRegistration Word64
forall typ. (typ ~ Word64) => EntityField PoolRegistration typ
PoolRegistrationSlotInternalIndex
                ]
            Maybe (Entity PoolRegistration)
-> (Entity PoolRegistration
    -> ReaderT
         backend
         m
         (CertificatePublicationTime, PoolRegistrationCertificate))
-> ReaderT
     backend
     m
     (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (Entity PoolRegistration)
result ((Entity PoolRegistration
  -> ReaderT
       backend
       m
       (CertificatePublicationTime, PoolRegistrationCertificate))
 -> ReaderT
      backend
      m
      (Maybe (CertificatePublicationTime, PoolRegistrationCertificate)))
-> (Entity PoolRegistration
    -> ReaderT
         backend
         m
         (CertificatePublicationTime, PoolRegistrationCertificate))
-> ReaderT
     backend
     m
     (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
forall a b. (a -> b) -> a -> b
$ \Entity PoolRegistration
meta -> do
                let PoolRegistration
                        PoolId
_poolId
                        SlotNo
slotNo
                        Word64
slotInternalIndex
                        Word64
marginNum
                        Word64
marginDen
                        Word64
poolCost_
                        Word64
poolPledge_
                        Maybe StakePoolMetadataUrl
poolMetadataUrl
                        Maybe StakePoolMetadataHash
poolMetadataHash = Entity PoolRegistration -> PoolRegistration
forall record. Entity record -> record
entityVal Entity PoolRegistration
meta
                let poolMargin :: Percentage
poolMargin = HasCallStack => Ratio Integer -> Percentage
Ratio Integer -> Percentage
unsafeMkPercentage (Ratio Integer -> Percentage) -> Ratio Integer -> Percentage
forall a b. (a -> b) -> a -> b
$
                        Ratio Word64 -> Ratio Integer
forall a. Real a => a -> Ratio Integer
toRational (Ratio Word64 -> Ratio Integer) -> Ratio Word64 -> Ratio Integer
forall a b. (a -> b) -> a -> b
$ Word64
marginNum Word64 -> Word64 -> Ratio Word64
forall a. Integral a => a -> a -> Ratio a
% Word64
marginDen
                let poolCost :: Coin
poolCost = Word64 -> Coin
Coin.fromWord64 Word64
poolCost_
                let poolPledge :: Coin
poolPledge = Word64 -> Coin
Coin.fromWord64 Word64
poolPledge_
                let poolMetadata :: Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
poolMetadata = (,) (StakePoolMetadataUrl
 -> StakePoolMetadataHash
 -> (StakePoolMetadataUrl, StakePoolMetadataHash))
-> Maybe StakePoolMetadataUrl
-> Maybe
     (StakePoolMetadataHash
      -> (StakePoolMetadataUrl, StakePoolMetadataHash))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe StakePoolMetadataUrl
poolMetadataUrl Maybe
  (StakePoolMetadataHash
   -> (StakePoolMetadataUrl, StakePoolMetadataHash))
-> Maybe StakePoolMetadataHash
-> Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe StakePoolMetadataHash
poolMetadataHash
                [PoolOwner]
poolOwners <- (Entity PoolOwner -> PoolOwner)
-> [Entity PoolOwner] -> [PoolOwner]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PoolOwner -> PoolOwner
poolOwnerOwner (PoolOwner -> PoolOwner)
-> (Entity PoolOwner -> PoolOwner) -> Entity PoolOwner -> PoolOwner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity PoolOwner -> PoolOwner
forall record. Entity record -> record
entityVal) ([Entity PoolOwner] -> [PoolOwner])
-> ReaderT backend m [Entity PoolOwner]
-> ReaderT backend m [PoolOwner]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    [Filter PoolOwner]
-> [SelectOpt PoolOwner] -> ReaderT backend m [Entity PoolOwner]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList
                        [ EntityField PoolOwner PoolId
forall typ. (typ ~ PoolId) => EntityField PoolOwner typ
PoolOwnerPoolId
                            EntityField PoolOwner PoolId -> PoolId -> Filter PoolOwner
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. PoolId
poolId
                        , EntityField PoolOwner SlotNo
forall typ. (typ ~ SlotNo) => EntityField PoolOwner typ
PoolOwnerSlot
                            EntityField PoolOwner SlotNo -> SlotNo -> Filter PoolOwner
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. SlotNo
slotNo
                        , EntityField PoolOwner Word64
forall typ. (typ ~ Word64) => EntityField PoolOwner typ
PoolOwnerSlotInternalIndex
                            EntityField PoolOwner Word64 -> Word64 -> Filter PoolOwner
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Word64
slotInternalIndex
                        ]
                        [ EntityField PoolOwner Word8 -> SelectOpt PoolOwner
forall record typ. EntityField record typ -> SelectOpt record
Asc EntityField PoolOwner Word8
forall typ. (typ ~ Word8) => EntityField PoolOwner typ
PoolOwnerIndex ]
                let cert :: PoolRegistrationCertificate
cert = PoolRegistrationCertificate :: PoolId
-> [PoolOwner]
-> Percentage
-> Coin
-> Coin
-> Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
-> PoolRegistrationCertificate
PoolRegistrationCertificate
                        { PoolId
$sel:poolId:PoolRegistrationCertificate :: PoolId
poolId :: PoolId
poolId
                        , [PoolOwner]
poolOwners :: [PoolOwner]
$sel:poolOwners:PoolRegistrationCertificate :: [PoolOwner]
poolOwners
                        , Percentage
poolMargin :: Percentage
$sel:poolMargin:PoolRegistrationCertificate :: Percentage
poolMargin
                        , Coin
poolCost :: Coin
$sel:poolCost:PoolRegistrationCertificate :: Coin
poolCost
                        , Coin
poolPledge :: Coin
$sel:poolPledge:PoolRegistrationCertificate :: Coin
poolPledge
                        , Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
poolMetadata :: Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
$sel:poolMetadata:PoolRegistrationCertificate :: Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
poolMetadata
                        }
                let cpt :: CertificatePublicationTime
cpt = CertificatePublicationTime :: SlotNo -> Word64 -> CertificatePublicationTime
CertificatePublicationTime {SlotNo
slotNo :: SlotNo
$sel:slotNo:CertificatePublicationTime :: SlotNo
slotNo, Word64
slotInternalIndex :: Word64
$sel:slotInternalIndex:CertificatePublicationTime :: Word64
slotInternalIndex}
                (CertificatePublicationTime, PoolRegistrationCertificate)
-> ReaderT
     backend m (CertificatePublicationTime, PoolRegistrationCertificate)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CertificatePublicationTime
cpt, PoolRegistrationCertificate
cert)

        readPoolRetirement :: PoolId
-> ReaderT
     backend
     m
     (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
readPoolRetirement PoolId
poolId = do
            Maybe (Entity PoolRetirement)
result <- [Filter PoolRetirement]
-> [SelectOpt PoolRetirement]
-> ReaderT backend m (Maybe (Entity PoolRetirement))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst
                [ EntityField PoolRetirement PoolId
forall typ. (typ ~ PoolId) => EntityField PoolRetirement typ
PoolRetirementPoolId EntityField PoolRetirement PoolId
-> PoolId -> Filter PoolRetirement
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. PoolId
poolId ]
                [ EntityField PoolRetirement SlotNo -> SelectOpt PoolRetirement
forall record typ. EntityField record typ -> SelectOpt record
Desc EntityField PoolRetirement SlotNo
forall typ. (typ ~ SlotNo) => EntityField PoolRetirement typ
PoolRetirementSlot
                , EntityField PoolRetirement Word64 -> SelectOpt PoolRetirement
forall record typ. EntityField record typ -> SelectOpt record
Desc EntityField PoolRetirement Word64
forall typ. (typ ~ Word64) => EntityField PoolRetirement typ
PoolRetirementSlotInternalIndex
                ]
            Maybe (Entity PoolRetirement)
-> (Entity PoolRetirement
    -> ReaderT
         backend m (CertificatePublicationTime, PoolRetirementCertificate))
-> ReaderT
     backend
     m
     (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (Entity PoolRetirement)
result ((Entity PoolRetirement
  -> ReaderT
       backend m (CertificatePublicationTime, PoolRetirementCertificate))
 -> ReaderT
      backend
      m
      (Maybe (CertificatePublicationTime, PoolRetirementCertificate)))
-> (Entity PoolRetirement
    -> ReaderT
         backend m (CertificatePublicationTime, PoolRetirementCertificate))
-> ReaderT
     backend
     m
     (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
forall a b. (a -> b) -> a -> b
$ \Entity PoolRetirement
meta -> do
                let PoolRetirement
                        PoolId
_poolId
                        SlotNo
slotNo
                        Word64
slotInternalIndex
                        Word64
retirementEpochNo = Entity PoolRetirement -> PoolRetirement
forall record. Entity record -> record
entityVal Entity PoolRetirement
meta
                let retirementEpoch :: EpochNo
retirementEpoch = Word31 -> EpochNo
EpochNo (Word64 -> Word31
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
retirementEpochNo)
                let cert :: PoolRetirementCertificate
cert = PoolRetirementCertificate :: PoolId -> EpochNo -> PoolRetirementCertificate
PoolRetirementCertificate {PoolId
$sel:poolId:PoolRetirementCertificate :: PoolId
poolId :: PoolId
poolId, EpochNo
$sel:retirementEpoch:PoolRetirementCertificate :: EpochNo
retirementEpoch :: EpochNo
retirementEpoch}
                let cpt :: CertificatePublicationTime
cpt = CertificatePublicationTime :: SlotNo -> Word64 -> CertificatePublicationTime
CertificatePublicationTime {SlotNo
slotNo :: SlotNo
$sel:slotNo:CertificatePublicationTime :: SlotNo
slotNo, Word64
slotInternalIndex :: Word64
$sel:slotInternalIndex:CertificatePublicationTime :: Word64
slotInternalIndex}
                (CertificatePublicationTime, PoolRetirementCertificate)
-> ReaderT
     backend m (CertificatePublicationTime, PoolRetirementCertificate)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CertificatePublicationTime
cpt, PoolRetirementCertificate
cert)

        putHeader :: BlockHeader -> ReaderT backend m ()
putHeader BlockHeader
point =
            let record :: BlockHeader
record = BlockHeader -> BlockHeader
mkBlockHeader BlockHeader
point
                key :: Word32
key = BlockHeader -> Word32
TH.blockHeight BlockHeader
record
            in Key BlockHeader -> BlockHeader -> ReaderT backend m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
repsert (Word32 -> Key BlockHeader
BlockHeaderKey Word32
key) BlockHeader
record

        listHeaders :: Int -> ReaderT backend m [BlockHeader]
listHeaders Int
k = do
            [BlockHeader] -> [BlockHeader]
forall a. [a] -> [a]
reverse ([BlockHeader] -> [BlockHeader])
-> ([Entity BlockHeader] -> [BlockHeader])
-> [Entity BlockHeader]
-> [BlockHeader]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entity BlockHeader -> BlockHeader)
-> [Entity BlockHeader] -> [BlockHeader]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BlockHeader -> BlockHeader
fromBlockHeaders (BlockHeader -> BlockHeader)
-> (Entity BlockHeader -> BlockHeader)
-> Entity BlockHeader
-> BlockHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity BlockHeader -> BlockHeader
forall record. Entity record -> record
entityVal) ([Entity BlockHeader] -> [BlockHeader])
-> ReaderT backend m [Entity BlockHeader]
-> ReaderT backend m [BlockHeader]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Filter BlockHeader]
-> [SelectOpt BlockHeader]
-> ReaderT backend m [Entity BlockHeader]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [ ]
                [ EntityField BlockHeader Word32 -> SelectOpt BlockHeader
forall record typ. EntityField record typ -> SelectOpt record
Desc EntityField BlockHeader Word32
forall typ. (typ ~ Word32) => EntityField BlockHeader typ
BlockHeight
                , Int -> SelectOpt BlockHeader
forall record. Int -> SelectOpt record
LimitTo Int
k
                ]

-- | Defines a raw SQL query, runnable with 'runRawQuery'.
--
data RawQuery a b = RawQuery
    { RawQuery a b -> Text
queryName :: Text
      -- ^ The name of the query.
    , RawQuery a b -> Text
queryDefinition :: Text
      -- ^ The SQL definition of the query.
    , RawQuery a b -> [PersistValue]
queryParameters :: [PersistValue]
      -- ^ Parameters of the query.
    , RawQuery a b -> a -> Either Text b
queryParser :: a -> Either Text b
      -- ^ A parser for a row of the result.
    }

-- | Runs a raw SQL query, logging any parse failures that occur.
--
runRawQuery
    :: forall a b. RawSql a
    => Tracer IO PoolDbLog
    -> RawQuery a b
    -> SqlPersistT IO [b]
runRawQuery :: Tracer IO PoolDbLog -> RawQuery a b -> SqlPersistT IO [b]
runRawQuery Tracer IO PoolDbLog
tr RawQuery a b
q = do
    ([Text]
failures, [b]
results) <- [Either Text b] -> ([Text], [b])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either Text b] -> ([Text], [b]))
-> ([a] -> [Either Text b]) -> [a] -> ([Text], [b])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Either Text b) -> [a] -> [Either Text b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RawQuery a b -> a -> Either Text b
forall a b. RawQuery a b -> a -> Either Text b
queryParser RawQuery a b
q) ([a] -> ([Text], [b]))
-> ReaderT SqlBackend IO [a] -> ReaderT SqlBackend IO ([Text], [b])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> [PersistValue] -> ReaderT SqlBackend IO [a]
forall a (m :: * -> *) backend.
(RawSql a, MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m [a]
rawSql
        (RawQuery a b -> Text
forall a b. RawQuery a b -> Text
queryDefinition RawQuery a b
q)
        (RawQuery a b -> [PersistValue]
forall a b. RawQuery a b -> [PersistValue]
queryParameters RawQuery a b
q)
    [Text]
-> (Text -> ReaderT SqlBackend IO ()) -> ReaderT SqlBackend IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
failures
        ((Text -> ReaderT SqlBackend IO ()) -> ReaderT SqlBackend IO ())
-> (Text -> ReaderT SqlBackend IO ()) -> ReaderT SqlBackend IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> ReaderT SqlBackend IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        (IO () -> ReaderT SqlBackend IO ())
-> (Text -> IO ()) -> Text -> ReaderT SqlBackend IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tracer IO PoolDbLog -> PoolDbLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO PoolDbLog
tr
        (PoolDbLog -> IO ()) -> (Text -> PoolDbLog) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseFailure -> PoolDbLog
MsgParseFailure
        (ParseFailure -> PoolDbLog)
-> (Text -> ParseFailure) -> Text -> PoolDbLog
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> ParseFailure
ParseFailure (RawQuery a b -> Text
forall a b. RawQuery a b -> Text
queryName RawQuery a b
q)
    [b] -> SqlPersistT IO [b]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [b]
results

createViews :: [ManualMigration]
createViews :: [ManualMigration]
createViews = (Connection -> IO ()) -> ManualMigration
ManualMigration ((Connection -> IO ()) -> ManualMigration)
-> [Connection -> IO ()] -> [ManualMigration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    [ DatabaseView -> Connection -> IO ()
createView DatabaseView
activePoolLifeCycleData
    , DatabaseView -> Connection -> IO ()
createView DatabaseView
activePoolOwners
    , DatabaseView -> Connection -> IO ()
createView DatabaseView
activePoolRegistrations
    , DatabaseView -> Connection -> IO ()
createView DatabaseView
activePoolRetirements
    ]

-- | Represents a database view.
--
data DatabaseView = DatabaseView
    { DatabaseView -> Text
databaseViewName :: Text
      -- ^ A name for the view.
    , DatabaseView -> Text
databaseViewDefinition :: Text
      -- ^ A select query to generate the view.
    }

-- | Creates the specified database view, if it does not already exist.
--
createView :: DatabaseView -> Sqlite.Connection -> IO ()
createView :: DatabaseView -> Connection -> IO ()
createView (DatabaseView Text
name Text
definition) Connection
conn = do
    Statement
deleteQuery <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
conn Text
deleteQueryString
    Statement -> IO StepResult
Sqlite.step Statement
deleteQuery IO StepResult -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Statement -> IO ()
Sqlite.finalize Statement
deleteQuery
    Statement
createQuery <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
conn Text
createQueryString
    Statement -> IO StepResult
Sqlite.step Statement
createQuery IO StepResult -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Statement -> IO ()
Sqlite.finalize Statement
createQuery
  where
    deleteQueryString :: Text
deleteQueryString = [Text] -> Text
T.unlines
        [ Text
"DROP VIEW IF EXISTS"
        , Text
name
        , Text
";"
        ]
    createQueryString :: Text
createQueryString = [Text] -> Text
T.unlines
        [ Text
"CREATE VIEW"
        , Text
name
        , Text
"AS"
        , Text
definition
        ]

-- | Views active lifecycle data for every pool in the set of known pools.
--
-- This view has exactly ONE row for each known pool, where each row
-- corresponds to the most-recently-seen registration certificate,
-- retirement certificate, and set of owners for that pool.
--
-- This view does NOT exclude pools that have retired.
--
activePoolLifeCycleData :: DatabaseView
activePoolLifeCycleData :: DatabaseView
activePoolLifeCycleData = Text -> Text -> DatabaseView
DatabaseView Text
"active_pool_lifecycle_data" [i|
    SELECT
        active_pool_registrations.pool_id as pool_id,
        active_pool_retirements.retirement_epoch as retirement_epoch,
        active_pool_owners.pool_owners as pool_owners,
        cost,
        pledge,
        margin_numerator,
        margin_denominator,
        metadata_hash,
        metadata_url
    FROM
        active_pool_registrations
    LEFT JOIN
        active_pool_retirements
    ON active_pool_registrations.pool_id = active_pool_retirements.pool_id
    LEFT JOIN
        active_pool_owners
    ON active_pool_registrations.pool_id = active_pool_owners.pool_id;
|]

-- | Views the set of active owners for all pools.
--
-- This view has exactly ONE row for each known pool, where each row
-- corresponds to the most-recently-seen set of owners for that pool.
--
-- This view does NOT exclude pools that have retired.
--
activePoolOwners :: DatabaseView
activePoolOwners :: DatabaseView
activePoolOwners = Text -> Text -> DatabaseView
DatabaseView Text
"active_pool_owners" [i|
    SELECT pool_id, pool_owners FROM (
        SELECT row_number() OVER w AS r, *
        FROM (
            SELECT
                pool_id,
                slot,
                slot_internal_index,
                group_concat(pool_owner, ' ') as pool_owners
            FROM (
                SELECT * FROM pool_owner ORDER BY pool_owner_index
            )
            GROUP BY pool_id, slot, slot_internal_index
        )
        WINDOW w AS (ORDER BY pool_id, slot desc, slot_internal_index desc)
    )
    GROUP BY pool_id;
|]

-- | Views the set of pool registrations that are currently active.
--
-- This view has exactly ONE row for each known pool, where each row
-- corresponds to the most-recently-seen registration certificate for
-- that pool.
--
-- This view does NOT exclude pools that have retired.
--
activePoolRegistrations :: DatabaseView
activePoolRegistrations :: DatabaseView
activePoolRegistrations = Text -> Text -> DatabaseView
DatabaseView Text
"active_pool_registrations" [i|
    SELECT
        pool_id,
        cost,
        pledge,
        margin_numerator,
        margin_denominator,
        metadata_hash,
        metadata_url
    FROM (
        SELECT row_number() OVER w AS r, *
        FROM pool_registration
        WINDOW w AS (ORDER BY pool_id, slot desc, slot_internal_index desc)
    )
    GROUP BY pool_id;
|]

-- | Views the set of pool retirements that are currently active.
--
-- This view includes all pools for which there are published retirement
-- certificates that have not been revoked or superseded.
--
-- This view does NOT include:
--
--    - pools for which there are no published retirement certificates.
--
--    - pools that have had their most-recently-published retirement
--      certificates revoked by subsequent re-registration certificates.
--
activePoolRetirements :: DatabaseView
activePoolRetirements :: DatabaseView
activePoolRetirements = Text -> Text -> DatabaseView
DatabaseView Text
"active_pool_retirements" [i|
    SELECT * FROM (
        SELECT
            pool_id,
            retirement_epoch
        FROM (
            SELECT row_number() OVER w AS r, *
            FROM (
                SELECT
                    pool_id, slot, slot_internal_index,
                    NULL as retirement_epoch
                    FROM pool_registration
                UNION
                SELECT
                    pool_id, slot, slot_internal_index,
                    epoch as retirement_epoch
                    FROM pool_retirement
            )
            WINDOW w AS (ORDER BY pool_id, slot desc, slot_internal_index desc)
        )
        GROUP BY pool_id
    )
    WHERE retirement_epoch IS NOT NULL;
|]

-- | 'Temporary', catches migration error from previous versions and if any,
-- _removes_ the database file completely before retrying to start the database.
--
-- This comes in handy to fix database schema in a non-backward compatible way
-- without altering too much the user experience. Indeed, the pools' database
-- can swiftly be re-synced from the chain, so instead of patching our mistakes
-- with ugly work-around we can, at least for now, reset it semi-manually when
-- needed to keep things tidy here.
handlingPersistError
    :: Tracer IO PoolDbLog
       -- ^ Logging object
    -> FilePath
       -- ^ Database file location, or Nothing for in-memory database
    -> IO a
       -- ^ Action to retry
    -> IO a
handlingPersistError :: Tracer IO PoolDbLog -> FilePath -> IO a -> IO a
handlingPersistError Tracer IO PoolDbLog
tr FilePath
fp IO a
action =
    IO a
action IO a -> (MigrationError -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(MigrationError
_e :: MigrationError) -> do
        Tracer IO PoolDbLog -> PoolDbLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO PoolDbLog
tr (PoolDbLog -> IO ()) -> PoolDbLog -> IO ()
forall a b. (a -> b) -> a -> b
$ DBLog -> PoolDbLog
MsgGeneric DBLog
MsgDatabaseReset
        FilePath -> IO ()
removeFile FilePath
fp
        IO a
action

-- | Compute a new date from a base date, with an increasing delay.
--
-- > backoff t 0
-- t+3s
--
-- > backoff t 1
-- t+9s
--
-- > backoff t 2
-- t+27s
--
-- ...
--
-- > backoff t 9
-- t+16h
--
-- > backoff t 10
-- t+49h
backoff :: UTCTime -> Word8 -> UTCTime
backoff :: UTCTime -> Word8 -> UTCTime
backoff UTCTime
time Word8
iter = POSIXTime -> UTCTime -> UTCTime
addUTCTime POSIXTime
delay UTCTime
time
  where
    delay :: POSIXTime
delay = forall b. (Integral Integer, Num b) => Integer -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Integer (Integer -> POSIXTime) -> Integer -> POSIXTime
forall a b. (a -> b) -> a -> b
$ (Integer -> Integer -> Integer) -> Integer -> [Integer] -> Integer
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*) Integer
3 (Int -> Integer -> [Integer]
forall a. Int -> a -> [a]
replicate (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
iter) Integer
3)

{-------------------------------------------------------------------------------
                                   Queries
-------------------------------------------------------------------------------}

selectPoolProduction
    :: TimeInterpreter IO
    -> EpochNo
    -> SqlPersistT IO [PoolProduction]
selectPoolProduction :: TimeInterpreter IO
-> EpochNo -> ReaderT SqlBackend IO [PoolProduction]
selectPoolProduction TimeInterpreter IO
ti EpochNo
epoch = do
    (SlotNo
e, SlotNo
eplus1) <- IO (SlotNo, SlotNo) -> ReaderT SqlBackend IO (SlotNo, SlotNo)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SlotNo, SlotNo) -> ReaderT SqlBackend IO (SlotNo, SlotNo))
-> IO (SlotNo, SlotNo) -> ReaderT SqlBackend IO (SlotNo, SlotNo)
forall a b. (a -> b) -> a -> b
$ TimeInterpreter IO -> Qry (SlotNo, SlotNo) -> IO (SlotNo, SlotNo)
forall (m :: * -> *) a.
(HasCallStack, Monad m) =>
TimeInterpreter m -> Qry a -> m a
interpretQuery TimeInterpreter IO
ti
        ((,) (SlotNo -> SlotNo -> (SlotNo, SlotNo))
-> Qry SlotNo -> Qry (SlotNo -> (SlotNo, SlotNo))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EpochNo -> Qry SlotNo
firstSlotInEpoch EpochNo
epoch Qry (SlotNo -> (SlotNo, SlotNo))
-> Qry SlotNo -> Qry (SlotNo, SlotNo)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EpochNo -> Qry SlotNo
firstSlotInEpoch (EpochNo
epoch EpochNo -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
+ EpochNo
1))
    (Entity PoolProduction -> PoolProduction)
-> [Entity PoolProduction] -> [PoolProduction]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Entity PoolProduction -> PoolProduction
forall record. Entity record -> record
entityVal ([Entity PoolProduction] -> [PoolProduction])
-> ReaderT SqlBackend IO [Entity PoolProduction]
-> ReaderT SqlBackend IO [PoolProduction]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Filter PoolProduction]
-> [SelectOpt PoolProduction]
-> ReaderT SqlBackend IO [Entity PoolProduction]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList
        [ EntityField PoolProduction SlotNo
forall typ. (typ ~ SlotNo) => EntityField PoolProduction typ
PoolProductionSlot EntityField PoolProduction SlotNo
-> SlotNo -> Filter PoolProduction
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>=. SlotNo
e
        , EntityField PoolProduction SlotNo
forall typ. (typ ~ SlotNo) => EntityField PoolProduction typ
PoolProductionSlot EntityField PoolProduction SlotNo
-> SlotNo -> Filter PoolProduction
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
<. SlotNo
eplus1 ]
        [EntityField PoolProduction SlotNo -> SelectOpt PoolProduction
forall record typ. EntityField record typ -> SelectOpt record
Asc EntityField PoolProduction SlotNo
forall typ. (typ ~ SlotNo) => EntityField PoolProduction typ
PoolProductionSlot]

{-------------------------------------------------------------------------------
                              To / From SQLite
-------------------------------------------------------------------------------}

mkPoolProduction
    :: PoolId
    -> BlockHeader
    -> PoolProduction
mkPoolProduction :: PoolId -> BlockHeader -> PoolProduction
mkPoolProduction PoolId
pool BlockHeader
block = PoolProduction :: PoolId -> SlotNo -> BlockId -> BlockId -> Word32 -> PoolProduction
PoolProduction
    { poolProductionPoolId :: PoolId
poolProductionPoolId = PoolId
pool
    , poolProductionSlot :: SlotNo
poolProductionSlot = ((SlotNo -> Const SlotNo SlotNo)
 -> BlockHeader -> Const SlotNo BlockHeader)
-> BlockHeader -> SlotNo
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "slotNo"
  ((SlotNo -> Const SlotNo SlotNo)
   -> BlockHeader -> Const SlotNo BlockHeader)
(SlotNo -> Const SlotNo SlotNo)
-> BlockHeader -> Const SlotNo BlockHeader
#slotNo BlockHeader
block
    , poolProductionHeaderHash :: BlockId
poolProductionHeaderHash = Hash "BlockHeader" -> BlockId
BlockId (BlockHeader -> Hash "BlockHeader"
headerHash BlockHeader
block)
    , poolProductionParentHash :: BlockId
poolProductionParentHash = Maybe (Hash "BlockHeader") -> BlockId
fromMaybeHash (BlockHeader -> Maybe (Hash "BlockHeader")
parentHeaderHash BlockHeader
block)
    , poolProductionBlockHeight :: Word32
poolProductionBlockHeight = Quantity "block" Word32 -> Word32
forall (unit :: Symbol) a. Quantity unit a -> a
getQuantity (BlockHeader -> Quantity "block" Word32
blockHeight BlockHeader
block)
    }

fromPoolProduction
    :: PoolProduction
    -> (PoolId, BlockHeader)
fromPoolProduction :: PoolProduction -> (PoolId, BlockHeader)
fromPoolProduction (PoolProduction PoolId
pool SlotNo
slot BlockId
headerH BlockId
parentH Word32
height) =
    ( PoolId
pool
    , BlockHeader :: SlotNo
-> Quantity "block" Word32
-> Hash "BlockHeader"
-> Maybe (Hash "BlockHeader")
-> BlockHeader
BlockHeader
        { $sel:slotNo:BlockHeader :: SlotNo
slotNo = SlotNo
slot
        , $sel:blockHeight:BlockHeader :: Quantity "block" Word32
blockHeight = Word32 -> Quantity "block" Word32
forall (unit :: Symbol) a. a -> Quantity unit a
Quantity Word32
height
        , $sel:headerHash:BlockHeader :: Hash "BlockHeader"
headerHash = BlockId -> Hash "BlockHeader"
getBlockId BlockId
headerH
        , $sel:parentHeaderHash:BlockHeader :: Maybe (Hash "BlockHeader")
parentHeaderHash = BlockId -> Maybe (Hash "BlockHeader")
toMaybeHash BlockId
parentH
        }
    )

mkBlockHeader
    :: BlockHeader
    -> TH.BlockHeader
mkBlockHeader :: BlockHeader -> BlockHeader
mkBlockHeader BlockHeader
block = BlockHeader :: SlotNo -> BlockId -> BlockId -> Word32 -> BlockHeader
TH.BlockHeader
    { blockSlot :: SlotNo
blockSlot = ((SlotNo -> Const SlotNo SlotNo)
 -> BlockHeader -> Const SlotNo BlockHeader)
-> BlockHeader -> SlotNo
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "slotNo"
  ((SlotNo -> Const SlotNo SlotNo)
   -> BlockHeader -> Const SlotNo BlockHeader)
(SlotNo -> Const SlotNo SlotNo)
-> BlockHeader -> Const SlotNo BlockHeader
#slotNo BlockHeader
block
    , blockHeaderHash :: BlockId
blockHeaderHash = Hash "BlockHeader" -> BlockId
BlockId (BlockHeader -> Hash "BlockHeader"
headerHash BlockHeader
block)
    , blockParentHash :: BlockId
blockParentHash = Maybe (Hash "BlockHeader") -> BlockId
fromMaybeHash (BlockHeader -> Maybe (Hash "BlockHeader")
parentHeaderHash BlockHeader
block)
    , blockHeight :: Word32
TH.blockHeight = Quantity "block" Word32 -> Word32
forall (unit :: Symbol) a. Quantity unit a -> a
getQuantity (BlockHeader -> Quantity "block" Word32
blockHeight BlockHeader
block)
    }

fromBlockHeaders :: TH.BlockHeader -> BlockHeader
fromBlockHeaders :: BlockHeader -> BlockHeader
fromBlockHeaders BlockHeader
h =
    SlotNo
-> Quantity "block" Word32
-> Hash "BlockHeader"
-> Maybe (Hash "BlockHeader")
-> BlockHeader
BlockHeader SlotNo
blockSlot
        (Word32 -> Quantity "block" Word32
forall (unit :: Symbol) a. a -> Quantity unit a
Quantity Word32
blockHeight)
        (BlockId -> Hash "BlockHeader"
getBlockId BlockId
blockHeaderHash)
        (BlockId -> Maybe (Hash "BlockHeader")
toMaybeHash BlockId
blockParentHash)
  where
    TH.BlockHeader
        { SlotNo
blockSlot :: SlotNo
blockSlot :: BlockHeader -> SlotNo
blockSlot
        , Word32
blockHeight :: Word32
blockHeight :: BlockHeader -> Word32
blockHeight
        , BlockId
blockHeaderHash :: BlockId
blockHeaderHash :: BlockHeader -> BlockId
blockHeaderHash
        , BlockId
blockParentHash :: BlockId
blockParentHash :: BlockHeader -> BlockId
blockParentHash
        } = BlockHeader
h

mkStakeDistribution
    :: EpochNo
    -> [(PoolId, Quantity "lovelace" Word64)]
    -> [StakeDistribution]
mkStakeDistribution :: EpochNo
-> [(PoolId, Quantity "lovelace" Word64)] -> [StakeDistribution]
mkStakeDistribution (EpochNo Word31
epoch) = ((PoolId, Quantity "lovelace" Word64) -> StakeDistribution)
-> [(PoolId, Quantity "lovelace" Word64)] -> [StakeDistribution]
forall a b. (a -> b) -> [a] -> [b]
map (((PoolId, Quantity "lovelace" Word64) -> StakeDistribution)
 -> [(PoolId, Quantity "lovelace" Word64)] -> [StakeDistribution])
-> ((PoolId, Quantity "lovelace" Word64) -> StakeDistribution)
-> [(PoolId, Quantity "lovelace" Word64)]
-> [StakeDistribution]
forall a b. (a -> b) -> a -> b
$ \(PoolId
pool, (Quantity Word64
stake)) ->
    StakeDistribution :: PoolId -> Word64 -> Word64 -> StakeDistribution
StakeDistribution
        { stakeDistributionPoolId :: PoolId
stakeDistributionPoolId = PoolId
pool
        , stakeDistributionEpoch :: Word64
stakeDistributionEpoch = Word31 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word31
epoch
        , stakeDistributionStake :: Word64
stakeDistributionStake = Word64
stake
        }

fromStakeDistribution
    :: StakeDistribution
    -> (PoolId, Quantity "lovelace" Word64)
fromStakeDistribution :: StakeDistribution -> (PoolId, Quantity "lovelace" Word64)
fromStakeDistribution StakeDistribution
distribution =
    ( StakeDistribution -> PoolId
stakeDistributionPoolId StakeDistribution
distribution
    , Word64 -> Quantity "lovelace" Word64
forall (unit :: Symbol) a. a -> Quantity unit a
Quantity (StakeDistribution -> Word64
stakeDistributionStake StakeDistribution
distribution)
    )

fromPoolMeta
    :: PoolMetadata
    -> (StakePoolMetadataHash, StakePoolMetadata)
fromPoolMeta :: PoolMetadata -> (StakePoolMetadataHash, StakePoolMetadata)
fromPoolMeta PoolMetadata
meta = (PoolMetadata -> StakePoolMetadataHash
poolMetadataHash PoolMetadata
meta,) (StakePoolMetadata -> (StakePoolMetadataHash, StakePoolMetadata))
-> StakePoolMetadata -> (StakePoolMetadataHash, StakePoolMetadata)
forall a b. (a -> b) -> a -> b
$
    StakePoolMetadata :: StakePoolTicker -> Text -> Maybe Text -> Text -> StakePoolMetadata
StakePoolMetadata
        { $sel:ticker:StakePoolMetadata :: StakePoolTicker
ticker = PoolMetadata -> StakePoolTicker
poolMetadataTicker PoolMetadata
meta
        , $sel:name:StakePoolMetadata :: Text
name = PoolMetadata -> Text
poolMetadataName PoolMetadata
meta
        , $sel:description:StakePoolMetadata :: Maybe Text
description = PoolMetadata -> Maybe Text
poolMetadataDescription PoolMetadata
meta
        , $sel:homepage:StakePoolMetadata :: Text
homepage = PoolMetadata -> Text
poolMetadataHomepage PoolMetadata
meta
        }

fromSettings
    :: Settings
    -> W.Settings
fromSettings :: Settings -> Settings
fromSettings (Settings PoolMetadataSource
pms) = PoolMetadataSource -> Settings
W.Settings PoolMetadataSource
pms

toSettings
    :: W.Settings
    -> Settings
toSettings :: Settings -> Settings
toSettings (W.Settings PoolMetadataSource
pms) = PoolMetadataSource -> Settings
Settings PoolMetadataSource
pms

fromInternalState
    :: InternalState
    -> W.InternalState
fromInternalState :: InternalState -> InternalState
fromInternalState (InternalState Maybe POSIXTime
utc) = Maybe POSIXTime -> InternalState
W.InternalState Maybe POSIXTime
utc