{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

module Hyperion.Database.HasDB where

import           Control.Lens           (Lens', views)
import           Control.Monad.Catch    (MonadCatch, try)
import           Control.Monad.IO.Class (MonadIO, liftIO)
import           Control.Monad.Reader   (MonadReader)
import qualified Data.Pool              as Pool
import qualified Database.SQLite.Simple as Sql
import qualified Hyperion.Log           as Log
import           Hyperion.ProgramId     (ProgramId)
import           Hyperion.Util          (retryExponential)
import           Prelude                hiding (lookup)

-- * General comments
-- $
-- "Hyperion.Database.HasDB" provides typeclass 'HasDB' which describes environments that contain a
-- 'DatabaseConfig', which is extracted by 'Lens'' 'dbConfigLens'.
--
-- This is used in the following way: if we have a monad @m@ that
--
-- 1. is an instance of 'MonadIO', i.e. embeds 'IO' actions,
-- 2. an instance of 'MonadReader', i.e. it carries an environment,
-- 3. this environment is an instance of 'HasDB',
--
-- then we can create @m@-actions using 'withConnection', i.e.
--
-- > doStuffWithConnection :: Sql.Connection -> IO a
-- > ...
-- > do -- here we are in m monad
-- >   ...
-- >   result <- withConnection doStuffWithConnection
-- >   ...
--
-- 'withConnection' uses "Data.Pool". See 'Data.Pool.withResource' for details.

-- * Documentation

-- | Database information datatype
data DatabaseConfig = DatabaseConfig
  { DatabaseConfig -> Pool Connection
dbPool      :: Pool.Pool Sql.Connection
  , DatabaseConfig -> ProgramId
dbProgramId :: ProgramId
  , DatabaseConfig -> Int
dbRetries   :: Int
  }

-- | 'HasDB' typeclass
class HasDB env where
  dbConfigLens :: Lens' env DatabaseConfig

instance HasDB DatabaseConfig where
  dbConfigLens :: (DatabaseConfig -> f DatabaseConfig)
-> DatabaseConfig -> f DatabaseConfig
dbConfigLens = (DatabaseConfig -> f DatabaseConfig)
-> DatabaseConfig -> f DatabaseConfig
forall a. a -> a
id

type Pool = Pool.Pool Sql.Connection

-- | Produces a default pool with connections to the SQLite DB in the given file
newDefaultPool :: FilePath -> IO (Pool.Pool Sql.Connection)
newDefaultPool :: FilePath -> IO (Pool Connection)
newDefaultPool FilePath
dbPath = do
  let
    stripes :: Int
stripes = Int
1
    connectionTime :: NominalDiffTime
connectionTime = NominalDiffTime
5
    poolSize :: Int
poolSize = Int
1
  IO Connection
-> (Connection -> IO ())
-> Int
-> NominalDiffTime
-> Int
-> IO (Pool Connection)
forall a.
IO a
-> (a -> IO ()) -> Int -> NominalDiffTime -> Int -> IO (Pool a)
Pool.createPool (FilePath -> IO Connection
Sql.open FilePath
dbPath) Connection -> IO ()
Sql.close Int
stripes NominalDiffTime
connectionTime Int
poolSize

-- | Extracts the connection pool from the environment of our monad, gets a
-- connection and runs the supplied function with it
withConnection
  :: forall m env a . (MonadIO m, MonadReader env m, HasDB env)
  => (Sql.Connection -> IO a)
  -> m a
withConnection :: (Connection -> IO a) -> m a
withConnection Connection -> IO a
go = do
  Pool Connection
pool <- LensLike' (Const (Pool Connection)) env DatabaseConfig
-> (DatabaseConfig -> Pool Connection) -> m (Pool Connection)
forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views LensLike' (Const (Pool Connection)) env DatabaseConfig
forall env. HasDB env => Lens' env DatabaseConfig
dbConfigLens DatabaseConfig -> Pool Connection
dbPool
  IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ Pool Connection -> (Connection -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
Pool.withResource Pool Connection
pool Connection -> IO a
go

-- | Tries 'withConnection' until succeeds. Failure means that 'Sql.SQLError' is
-- thrown during execution of the function. Otherwise execution is deemed successful.
-- The number of attempts is determined by DatabaseConfig in the environment.
-- If last attempt is a failure, the last exception propagates
-- outside of 'withConnectionRetry'. Uses 'retryRepeated' internally.
withConnectionRetry
  :: forall m env a . (MonadIO m, MonadReader env m, HasDB env, MonadCatch m)
  => (Sql.Connection -> IO a)
  -> m a
withConnectionRetry :: (Connection -> IO a) -> m a
withConnectionRetry Connection -> IO a
go =
  (m a -> m (Either SQLError a))
-> (WaitRetry SQLError -> m ()) -> m a -> m a
forall (m :: * -> *) a e.
MonadIO m =>
(m a -> m (Either e a)) -> (WaitRetry e -> m ()) -> m a -> m a
retryExponential (forall a.
(MonadCatch m, Exception SQLError) =>
m a -> m (Either SQLError a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @m @Sql.SQLError) (Text -> WaitRetry SQLError -> m ()
forall a (m :: * -> *). (Show a, MonadIO m) => Text -> a -> m ()
Log.warn Text
"Unsuccessful") ((Connection -> IO a) -> m a
forall (m :: * -> *) env a.
(MonadIO m, MonadReader env m, HasDB env) =>
(Connection -> IO a) -> m a
withConnection Connection -> IO a
go)