module Web.Apiary.Database.Persist
( Persist
, Migrator(..), With
, initPersist, initPersistNoLog
, initPersistPool, initPersistPoolNoLog
, initPersist', initPersistPool'
, runSql
, sql
) where
import qualified Data.Pool as Pool
import Control.Monad(void, mzero)
import Control.Monad.IO.Class(MonadIO(..))
import Control.Monad.Logger(NoLoggingT(runNoLoggingT))
import Control.Monad.Trans.Reader(runReaderT)
import Control.Monad.Trans.Control(MonadBaseControl)
import Web.Apiary.Logger(LogWrapper, runLogWrapper)
import qualified Database.Persist.Sql as Sql
import Web.Apiary(Html)
import Control.Monad.Apiary(ApiaryT)
import Control.Monad.Apiary.Action(ActionT, getParams)
import Control.Monad.Apiary.Filter(focus, Doc(DocPrecondition))
import qualified Data.Apiary.Dict as Dict
import Data.Apiary.Compat(Proxy(..), KnownSymbol)
import Data.Apiary.Extension
(Has, Initializer, initializer, Extensions, Extension, MonadExts, getExt)
data Migrator
= Logging Sql.Migration
| Silent Sql.Migration
| Unsafe Sql.Migration
| NoMigrate
data Persist
= PersistPool Sql.ConnectionPool
| PersistConn Sql.SqlBackend
instance Extension Persist
type With c m = forall a. (c -> m a) -> m a
initPersist' :: (MonadIO n, MonadBaseControl IO n, Monad m)
=> (forall a. Extensions exts -> n a -> m a)
-> With Sql.SqlBackend n -> Migrator -> Initializer m exts (Persist ': exts)
initPersist' run with migr = initializer $ \es -> run es $
with $ \conn -> do
doMigration migr conn
return (PersistConn conn)
initPersist :: (MonadIO m, MonadBaseControl IO m)
=> With Sql.SqlBackend (LogWrapper exts m) -> Sql.Migration
-> Initializer m exts (Persist ': exts)
initPersist with = initPersist' runLogWrapper with . Logging
initPersistNoLog :: (MonadIO m, MonadBaseControl IO m)
=> With Sql.SqlBackend (NoLoggingT m)
-> Sql.Migration -> Initializer m es (Persist ': es)
initPersistNoLog with = initPersist' (const runNoLoggingT) with . Silent
initPersistPool' :: (MonadIO n, MonadBaseControl IO n, Monad m)
=> (forall a. Extensions exts -> n a -> m a)
-> With Sql.ConnectionPool n -> Migrator -> Initializer m exts (Persist ': exts)
initPersistPool' run with migr = initializer $ \es -> run es $
with $ \pool -> do
Pool.withResource pool $ doMigration migr
return (PersistPool pool)
initPersistPool :: (MonadIO m, MonadBaseControl IO m)
=> With Sql.ConnectionPool (LogWrapper exts m) -> Sql.Migration
-> Initializer m exts (Persist ': exts)
initPersistPool with = initPersistPool' runLogWrapper with . Logging
initPersistPoolNoLog :: (MonadIO m, MonadBaseControl IO m)
=> With Sql.ConnectionPool (NoLoggingT m)
-> Sql.Migration -> Initializer m es (Persist ': es)
initPersistPoolNoLog with = initPersistPool' (const runNoLoggingT) with . Silent
doMigration :: (MonadIO m, MonadBaseControl IO m) => Migrator -> Sql.SqlBackend -> m ()
doMigration migr conn = case migr of
Logging m -> runReaderT (Sql.runMigration m) conn
Silent m -> runReaderT (void $ Sql.runMigrationSilent m) conn
Unsafe m -> runReaderT (Sql.runMigrationUnsafe m) conn
NoMigrate -> return ()
class RunSQL m where
runSql :: Sql.SqlPersistT m a -> m a
runSql' :: MonadBaseControl IO m => Sql.SqlPersistT m a -> Persist -> m a
runSql' a persist = case persist of
PersistPool p -> Sql.runSqlPool a p
PersistConn c -> Sql.runSqlConn a c
instance (Has Persist es, MonadExts es m, MonadBaseControl IO m) => RunSQL m where
runSql a = getExt (Proxy :: Proxy Persist) >>= runSql' a
sql :: (KnownSymbol k, Has Persist exts, MonadBaseControl IO actM, Dict.NotMember k prms)
=> Maybe Html
-> proxy k
-> Sql.SqlPersistT (ActionT exts prms actM) a
-> (a -> Maybe b)
-> ApiaryT exts (k Dict.:= b ': prms) actM m () -> ApiaryT exts prms actM m ()
sql doc k q p = focus (maybe id DocPrecondition doc) $ do
fmap p (runSql q) >>= \case
Nothing -> mzero
Just a -> Dict.insert k a `fmap` getParams