module Yam.Transaction(
Transaction
, TransactionPool(..)
, DataSource(..)
, MonadTransaction(..)
, DataSourceConnector
, DataSourceProvider
, HasDataSource(..)
, runTrans
, selectValue
, selectNow
, now
, initDataSource
, runSecondaryTrans
, query
) where
import Yam.Import
import Yam.Logger
import Yam.Prop
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Acquire (with)
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.Either (rights)
import qualified Data.Map as M
import Data.Pool
import qualified Data.Text as T
import Database.Persist.Sql
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
instance FromJSON DataSource where
parseJSON v = parseProp v $ do
dsDt <- getPropOrDefault (dbtype def) "type"
dsCn <- getPropOrDefault (conn def) "conn"
dsTh <- getPropOrDefault (thread def) "thread"
dsMi <- getPropOrDefault (Yam.Transaction.migrate def) "migrate"
dsEx <- getProp "extra"
return $ DataSource dsDt dsCn dsTh dsMi dsEx
instance Default DataSource where
def = DataSource "sqlite" ":memory:" 10 True Nothing
class (MonadIO m, MonadBaseControl IO m, MonadYamLogger m, MonadMask 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 ds ds2nd action
where go map ds ds2 action = do
logger <- toMonadLogger
getConnector map logger ds $ \p ->
case ds2 of
Nothing -> setConnectionPool p Nothing >> action
Just s2 -> getConnector map logger s2 $ \v -> setConnectionPool p (Just v) >> action
getConnector map logger ds = case M.lookup (dbtype ds) map of
Nothing -> error $ "Datasource " <> cs (dbtype ds) <> " not supported"
Just db -> db logger ds
runTrans :: MonadTransaction m => Transaction a -> m a
runTrans trans = connectionPool >>= executePool trans
executePool trans p = liftIO (runSqlPool trans p)
runSecondaryTrans :: MonadTransaction m => Transaction a -> m a
runSecondaryTrans trans = do
pool <- secondaryPool
case pool of
Nothing -> error "Secondary Pool not exists"
Just p -> withLoggerName "Backup" $ executePool trans p
class FromPersistValue a where
parsePersistValue :: [PersistValue] -> a
instance PersistField a => FromPersistValue [a] where
parsePersistValue = rights . map fromPersistValue
instance FromPersistValue Text where
parsePersistValue = T.intercalate "," . rights . map fromPersistValueText
query :: FromPersistValue a => Text -> [PersistValue] -> Transaction [a]
query sql params = do res <- rawQueryRes sql params
liftIO $ with res ($$ CL.fold i [])
where i b ps = parsePersistValue ps : b
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