module Yam.DataSource(
DataSourceProvider
, DataSource
, DB
, runTrans
, primaryDatasourceMiddleware
, runTransWith
, datasourceMiddleware
, query
, selectValue
) where
import Control.Exception (bracket)
import Control.Monad.IO.Unlift
import Data.Acquire (withAcquire)
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.Pool
import Database.Persist.Sql hiding (Key)
import System.IO.Unsafe (unsafePerformIO)
import Yam hiding (LogFunc)
type DataSource = ConnectionPool
{-# NOINLINE dataSourceKey #-}
dataSourceKey :: Key DataSource
dataSourceKey = unsafePerformIO newKey
type DataSourceProvider = LoggingT IO DataSource
type DB = SqlPersistT
query
:: (MonadUnliftIO m)
=> Text
-> [PersistValue]
-> DB m [[PersistValue]]
query sql params = do
res <- rawQueryRes sql params
withAcquire res (\a -> runConduit $ a .| CL.fold (flip (:)) [])
selectValue :: (PersistField a, MonadUnliftIO m) => Text -> DB m [a]
selectValue sql = fmap unSingle <$> rawSql sql []
runTransWith :: (MonadUnliftIO m) => Key DataSource -> DB (AppM m) a -> AppM m a
runTransWith k a = requireAttr k >>= (`runDB` a)
runTrans :: (MonadUnliftIO m) => DB (AppM m) a -> AppM m a
runTrans = runTransWith dataSourceKey
{-# INLINE runDB #-}
runDB :: (MonadLoggerIO m, MonadUnliftIO m) => DataSource -> DB m a -> m a
runDB pool db = do
logger <- askLoggerIO
withRunInIO $ \run -> withResource pool $ run . \c -> runSqlConn db c { connLogFunc = logger }
{-# INLINE runInDB #-}
runInDB :: LogFunc -> DataSourceProvider -> (DataSource -> IO a) -> IO a
runInDB logfunc f g = bracket (runLoggingT f logfunc) destroyAllResources g
datasourceMiddleware :: Key DataSource -> DataSourceProvider -> AppMiddleware
datasourceMiddleware k dsp = AppMiddleware $ \env f -> do
lf <- askLoggerIO
logInfo "Datasource Initialized..."
liftIO $ runInDB lf dsp $ \ds -> runLoggingT (f (setAttr k ds env, id)) lf
primaryDatasourceMiddleware = datasourceMiddleware dataSourceKey