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.Apiary
import Control.Monad.Logger
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Control
import Web.Apiary.Logger
import Database.Persist.Sql
import Web.Apiary
import Control.Monad.Apiary.Action
import Control.Monad.Apiary.Filter
import qualified Data.Apiary.Dict as Dict
import Data.Apiary.Compat
import Data.Apiary.Extension
data Migrator
= Logging Migration
| Silent Migration
| Unsafe Migration
| NoMigrate
data Persist
= PersistPool ConnectionPool
| PersistConn 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 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 SqlBackend (LogWrapper exts m) -> Migration
-> Initializer m exts (Persist ': exts)
initPersist with = initPersist' runLogWrapper with . Logging
initPersistNoLog :: (MonadIO m, MonadBaseControl IO m)
=> With SqlBackend (NoLoggingT m)
-> 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 ConnectionPool n -> Migrator -> Initializer m exts (Persist ': exts)
initPersistPool' run with migr = initializer $ \es -> run es $
with $ \pool -> do
withResource pool $ doMigration migr
return (PersistPool pool)
initPersistPool :: (MonadIO m, MonadBaseControl IO m)
=> With ConnectionPool (LogWrapper exts m) -> Migration
-> Initializer m exts (Persist ': exts)
initPersistPool with = initPersistPool' runLogWrapper with . Logging
initPersistPoolNoLog :: (MonadIO m, MonadBaseControl IO m)
=> With ConnectionPool (NoLoggingT m)
-> Migration -> Initializer m es (Persist ': es)
initPersistPoolNoLog with = initPersistPool' (const runNoLoggingT) with . Silent
doMigration :: (MonadIO m, MonadBaseControl IO m) => Migrator -> SqlBackend -> 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 ()
class RunSQL m where
runSql :: SqlPersistT m a -> m a
runSql' :: MonadBaseControl IO m => SqlPersistT m a -> Persist -> m a
runSql' a persist = case persist of
PersistPool p -> runSqlPool a p
PersistConn c -> runSqlConn a c
instance (Has Persist exts, MonadBaseControl IO m) => RunSQL (ActionT exts prms m) where
runSql a = getExt (Proxy :: Proxy Persist) >>= runSql' a
instance (Has Persist exts, MonadBaseControl IO m, Monad actM) => RunSQL (ApiaryT exts prms actM m) where
runSql a = apiaryExt (Proxy :: Proxy Persist) >>= runSql' a
sql :: (Has Persist exts, MonadBaseControl IO actM, Dict.NotMember k prms)
=> Maybe Html
-> proxy k
-> SqlPersistT (ActionT exts prms actM) a
-> (a -> Maybe b)
-> ApiaryT exts (k := 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