{-# LANGUAGE CPP #-}

module Database.Persist.Class.PersistConfig
    ( PersistConfig (..)
    ) where

import Control.Monad.IO.Unlift (MonadUnliftIO)
import Data.Aeson (Value (Object))
import Data.Aeson.Types (Parser)

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as AM
#else
import qualified Data.HashMap.Strict as AM
#endif

import Data.Kind (Type)

-- | Represents a value containing all the configuration options for a specific
-- backend. This abstraction makes it easier to write code that can easily swap
-- backends.
class PersistConfig c where
    type PersistConfigBackend c :: (Type -> Type) -> Type -> Type
    type PersistConfigPool c

    -- | Load the config settings from a 'Value', most likely taken from a YAML
    -- config file.
    loadConfig :: Value -> Parser c

    -- | Modify the config settings based on environment variables.
    applyEnv :: c -> IO c
    applyEnv = c -> IO c
forall (m :: * -> *) a. Monad m => a -> m a
return

    -- | Create a new connection pool based on the given config settings.
    createPoolConfig :: c -> IO (PersistConfigPool c)

    -- | Run a database action by taking a connection from the pool.
    runPool :: MonadUnliftIO m
            => c
            -> PersistConfigBackend c m a
            -> PersistConfigPool c
            -> m a

instance
  ( PersistConfig c1
  , PersistConfig c2
  , PersistConfigPool c1 ~ PersistConfigPool c2
  , PersistConfigBackend c1 ~ PersistConfigBackend c2
  ) => PersistConfig (Either c1 c2) where
    type PersistConfigBackend (Either c1 c2) = PersistConfigBackend c1
    type PersistConfigPool (Either c1 c2) = PersistConfigPool c1

    loadConfig :: Value -> Parser (Either c1 c2)
loadConfig (Object Object
o) =
        case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
AM.lookup Key
"left" Object
o of
            Just Value
v -> c1 -> Either c1 c2
forall a b. a -> Either a b
Left (c1 -> Either c1 c2) -> Parser c1 -> Parser (Either c1 c2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser c1
forall c. PersistConfig c => Value -> Parser c
loadConfig Value
v
            Maybe Value
Nothing ->
                case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
AM.lookup Key
"right" Object
o of
                    Just Value
v -> c2 -> Either c1 c2
forall a b. b -> Either a b
Right (c2 -> Either c1 c2) -> Parser c2 -> Parser (Either c1 c2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser c2
forall c. PersistConfig c => Value -> Parser c
loadConfig Value
v
                    Maybe Value
Nothing -> String -> Parser (Either c1 c2)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"PersistConfig for Either: need either a left or right"
    loadConfig Value
_ = String -> Parser (Either c1 c2)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"PersistConfig for Either: need an object"

    createPoolConfig :: Either c1 c2 -> IO (PersistConfigPool (Either c1 c2))
createPoolConfig = (c1 -> IO (PersistConfigPool c2))
-> (c2 -> IO (PersistConfigPool c2))
-> Either c1 c2
-> IO (PersistConfigPool c2)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either c1 -> IO (PersistConfigPool c2)
forall c. PersistConfig c => c -> IO (PersistConfigPool c)
createPoolConfig c2 -> IO (PersistConfigPool c2)
forall c. PersistConfig c => c -> IO (PersistConfigPool c)
createPoolConfig

    runPool :: Either c1 c2
-> PersistConfigBackend (Either c1 c2) m a
-> PersistConfigPool (Either c1 c2)
-> m a
runPool (Left c1
c) = c1 -> PersistConfigBackend c1 m a -> PersistConfigPool c1 -> m a
forall c (m :: * -> *) a.
(PersistConfig c, MonadUnliftIO m) =>
c -> PersistConfigBackend c m a -> PersistConfigPool c -> m a
runPool c1
c
    runPool (Right c2
c) = c2 -> PersistConfigBackend c2 m a -> PersistConfigPool c2 -> m a
forall c (m :: * -> *) a.
(PersistConfig c, MonadUnliftIO m) =>
c -> PersistConfigBackend c m a -> PersistConfigPool c -> m a
runPool c2
c