{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
module Yam.Transaction(
Transaction
, TransactionPool(..)
, DataSource(..)
, MonadTransaction(..)
, DataSourceConnector
, DataSourceProvider
, HasDataSource(..)
, runTrans
, selectValue
, selectNow
, now
, initDataSource
, runSecondaryTrans
) where
import Yam.Import
import Yam.Logger
import Yam.Logger.MonadLogger
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Aeson
import Data.Default
import qualified Data.Map as M
import Data.Pool
import Data.Proxy
import Data.Reflection
import Database.Persist.Sql
import GHC.TypeLits
type Transaction = SqlPersistT IO
type TransactionPool = Pool SqlBackend
data DataSource = DataSource
{ dbtype :: Text
, conn :: Text
, thread :: Int
, migrate :: Bool
, extra :: Maybe (M.Map Text Text)
} deriving (Show, Generic, FromJSON)
instance Default DataSource where
def = DataSource "sqlite" ":memory:" 10 True Nothing
class (MonadIO m, MonadBaseControl IO m, MonadLogger m) => MonadTransaction m where
connectionPool :: m TransactionPool
setConnectionPool :: TransactionPool -> Maybe TransactionPool -> m ()
secondaryPool :: m (Maybe TransactionPool)
secondaryPool = return Nothing
type DataSourceConnector m a = LogFunc -> DataSource -> (TransactionPool -> m a) -> m a
type DataSourceProvider m a = (Text, DataSourceConnector m a)
class HasDataSource ds where
connector :: MonadTransaction m => Proxy ds -> DataSourceConnector m a
initDataSource :: MonadTransaction m => [DataSourceProvider m a] -> DataSource -> Maybe DataSource -> m a -> m a
initDataSource maps ds ds2nd action = let map = M.fromList maps in go map (Just ds) $ go map ds2nd action
where go _ Nothing action = action
go map (Just ds) action = case M.lookup (dbtype ds) map of
Nothing -> error $ "Datasource " <> cs (dbtype ds) <> " not supported"
Just db -> do
logger <- toMonadLogger
db logger ds $ \p -> setConnectionPool p Nothing >> action
runTrans :: MonadTransaction m => Transaction a -> m a
runTrans trans = connectionPool >>= liftIO . runSqlPool trans
runSecondaryTrans :: MonadTransaction m => Transaction a -> m a
runSecondaryTrans trans = do
pool <- secondaryPool
case pool of
Nothing -> error "Secondary Pool not exists"
Just p -> liftIO $ runSqlPool trans p
selectNow :: Transaction UTCTime
selectNow = head <$> (ask >>= dbNow . connRDBMS)
where dbNow :: Text -> Transaction [UTCTime]
dbNow "sqlite" = selectValue "SELECT CURRENT_TIMESTAMP"
dbNow "postgresql" = selectValue "SELECT CURRENT_TIMESTAMP"
dbNow "oracle" = selectValue "SELECT SYSDATE FROM DUAL"
dbNow dbms = error $ "Datasource " <> cs dbms <> " not supported"
selectValue :: (PersistField a) => Text -> Transaction [a]
selectValue sql = fmap unSingle <$> rawSql sql []
now :: MonadTransaction m => m UTCTime
now = runTrans selectNow