module Web.Apiary.Database.Persist
( Persist
, Migrator(..), With
, initPersist, initPersistNoLog
, initPersistPool, initPersistPoolNoLog
, initPersist', initPersistPool'
, runSql
, sql
) where
import Data.Pool
import Control.Monad
import Control.Monad.Logger
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Control
import Database.Persist.Sql
import Web.Apiary
import Web.Apiary.Logger
import Data.Apiary.SList
import Data.Apiary.Proxy
import Data.Apiary.Document
import Data.Apiary.Extension
import Data.Apiary.Extension.Internal
import Control.Monad.Apiary.Filter.Internal
data Migrator
= Logging Migration
| Silent Migration
| Unsafe Migration
| NoMigrate
data Persist
= PersistPool ConnectionPool
| PersistConn Connection
type With c m = forall a. (c -> m a) -> m a
initPersist' :: (MonadIO n, MonadBaseControl IO n)
=> (forall a. m a -> n a) -> (forall a. Extensions exts -> n a -> m a)
-> With Connection n -> Migrator -> Initializer m exts (Persist ': exts)
initPersist' wrap run with migr = Initializer $ \es m -> run es $
with $ \conn -> do
doMigration migr conn
wrap $ m (addExtension (PersistConn conn) es)
initPersist :: (MonadIO m, MonadBaseControl IO m)
=> With Connection (LogWrapper exts m) -> Migration
-> Initializer m exts (Persist ': exts)
initPersist with = initPersist' logWrapper runLogWrapper with . Logging
initPersistNoLog :: (MonadIO m, MonadBaseControl IO m)
=> With Connection (NoLoggingT m)
-> Migration -> Initializer m es (Persist ': es)
initPersistNoLog with = initPersist' NoLoggingT (const runNoLoggingT) with . Silent
initPersistPool' :: (MonadIO n, MonadBaseControl IO n)
=> (forall a. m a -> n a) -> (forall a. Extensions exts -> n a -> m a)
-> With ConnectionPool n -> Migrator -> Initializer m exts (Persist ': exts)
initPersistPool' wrap run with migr = Initializer $ \es m -> run es $
with $ \pool -> do
withResource pool $ doMigration migr
wrap $ m (addExtension (PersistPool pool) es)
initPersistPool :: (MonadIO m, MonadBaseControl IO m)
=> With ConnectionPool (LogWrapper exts m) -> Migration
-> Initializer m exts (Persist ': exts)
initPersistPool with = initPersistPool' logWrapper runLogWrapper with . Logging
initPersistPoolNoLog :: (MonadIO m, MonadBaseControl IO m)
=> With ConnectionPool (NoLoggingT m)
-> Migration -> Initializer m es (Persist ': es)
initPersistPoolNoLog with = initPersistPool' NoLoggingT (const runNoLoggingT) with . Silent
doMigration :: (MonadIO m, MonadBaseControl IO m) => Migrator -> Connection -> m ()
doMigration migr conn = case migr of
Logging m -> runReaderT (runMigration m) conn
Silent m -> runReaderT (void (runMigrationSilent m)) conn
Unsafe m -> runReaderT (runMigrationUnsafe m) conn
NoMigrate -> return ()
runSql :: (Has Persist exts, MonadBaseControl IO m)
=> SqlPersistT (ActionT exts m) a -> ActionT exts m a
runSql a = getExt (Proxy :: Proxy Persist) >>= \case
PersistPool p -> runSqlPool a p
PersistConn c -> runSqlConn a c
sql :: (Has Persist exts, MonadBaseControl IO actM)
=> Maybe Html
-> SqlPersistT (ActionT exts actM) a
-> (a -> Maybe b)
-> ApiaryT exts (b ': prms) actM m () -> ApiaryT exts prms actM m ()
sql doc q p = focus (maybe id DocPrecondition doc) $ \l ->
fmap p (runSql q) >>= \case
Nothing -> mzero
Just a -> return (a ::: l)