diff --git a/apiary-persistent.cabal b/apiary-persistent.cabal --- a/apiary-persistent.cabal +++ b/apiary-persistent.cabal @@ -1,5 +1,5 @@ name: apiary-persistent -version: 0.13.1.1 +version: 0.16.0 synopsis: persistent support for apiary web framework. description: example: @@ -18,17 +18,19 @@ library exposed-modules: Web.Apiary.Database.Persist - other-modules: - build-depends: base >=4.6 && <4.8 - , persistent >=1.3 && <1.4 - , apiary >=0.13 && <0.16 - , monad-logger >=0.3 && <0.4 - , resourcet >=1.1 && <1.2 - , mtl >=2.1 && <2.3 - , reflection >=1.4 && <1.6 - , transformers-base >=0.4 && <0.5 - , blaze-html >=0.7 && <0.8 + build-depends: base >=4.6 && <4.8 + , persistent >=2.0 && <2.1 + , apiary >=0.16 && <0.17 + , apiary-logger >=0.16 && <0.17 + + , resourcet >=1.1 && <1.2 + , resource-pool >=0.2 && <0.3 + + , monad-logger >=0.3 && <0.4 + , transformers >=0.2 && <0.5 + , transformers-base >=0.4 && <0.5 + , monad-control >=0.3 && <0.4 hs-source-dirs: src ghc-options: -O2 -Wall default-language: Haskell2010 diff --git a/src/Web/Apiary/Database/Persist.hs b/src/Web/Apiary/Database/Persist.hs --- a/src/Web/Apiary/Database/Persist.hs +++ b/src/Web/Apiary/Database/Persist.hs @@ -1,75 +1,127 @@ -{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Web.Apiary.Database.Persist ( - -- * runner - withWithSqlPool +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} - -- * execute sql +module Web.Apiary.Database.Persist + ( Persist + -- * initializer + , Migrator(..), With + , initPersist, initPersistNoLog + , initPersistPool, initPersistPoolNoLog + -- ** low level + , initPersist', initPersistPool' + -- * query , runSql - - -- * types - , HasPersist - -- * filter , sql - , BoolLike(..) - - -- * reexport - , module Database.Persist.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 Control.Applicative -import Control.Monad.Trans.Resource -import Control.Monad.Apiary.Filter.Internal - -import Text.Blaze.Html -import Data.Reflection +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 -type HasPersist = Given Persist +data Migrator + = Logging Migration + | Silent Migration + | Unsafe Migration + | NoMigrate -newtype Persist = Persist - { getPool :: ConnectionPool - } +data Persist + = PersistPool ConnectionPool + | PersistConn Connection -runSql :: (MonadBaseControl IO m, HasPersist) => SqlPersistT (ResourceT m) a -> m a -runSql a = runResourceT $ runSqlPool a (getPool given) +type With c m = forall a. (c -> m a) -> m a -withWithSqlPool :: (forall a. (ConnectionPool -> m a) -> m a) - -> (HasPersist => m b) -> m b -withWithSqlPool with m = with $ \pool -> - give (Persist pool) m +initPersist' :: (MonadIO n, MonadBaseControl IO n) + => (forall a. Extensions exts -> n a -> m a) + -> With Connection n + -> Migrator + -> Initializer exts m (Persist ': exts) +initPersist' run with migr = Initializer $ \e -> + run e $ with $ \conn -> do + doMigration migr conn + return $ addExtension (PersistConn conn) e -class BoolLike a where - type UnBool a - unBool :: a -> Maybe (UnBool a) +-- | construct persist extension initializer with no connection pool. +-- +-- example: +-- +-- @ +-- initPersist (withSqliteConn "db.sqlite") migrateAll +-- @ +initPersist :: (MonadIO m, MonadBaseControl IO m, Has Logger exts) + => With Connection (LogWrapper exts m) -> Migration + -> Initializer exts m (Persist ': exts) +initPersist w = initPersist' runLogWrapper w . Logging -instance BoolLike (Maybe a) where - type UnBool (Maybe a) = a - unBool = id +initPersistNoLog :: (MonadIO m, MonadBaseControl IO m) + => With Connection (NoLoggingT m) + -> Migration -> Initializer es m (Persist ': es) +initPersistNoLog w = initPersist' (const runNoLoggingT) w . Silent -instance BoolLike [a] where - type UnBool [a] = [a] - unBool [] = Nothing - unBool a = Just a +initPersistPool' :: (MonadIO n, MonadBaseControl IO n) + => (forall a. Extensions exts -> n a -> m a) + -> With ConnectionPool n + -> Migrator + -> Initializer exts m (Persist ': exts) +initPersistPool' run with migr = Initializer $ \e -> + run e $ with $ \pool -> do + withResource pool $ doMigration migr + return $ addExtension (PersistPool pool) e +initPersistPool :: (MonadIO m, MonadBaseControl IO m, Has Logger exts) + => With ConnectionPool (LogWrapper exts m) -> Migration + -> Initializer exts m (Persist ': exts) +initPersistPool w = initPersistPool' runLogWrapper w . Logging + +initPersistPoolNoLog :: (MonadIO m, MonadBaseControl IO m) + => With ConnectionPool (NoLoggingT m) -> Migration + -> Initializer exts m (Persist ': exts) +initPersistPoolNoLog w = initPersistPool' (const runNoLoggingT) w . 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 () + +-- | execute sql in action. +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 + -- | filter by sql query. since 0.9.0.0. -sql :: (BoolLike a, Functor n, Monad n, MonadBaseControl IO (ActionT n), HasPersist) - => Maybe Html - -> SqlPersistT (ResourceT (ActionT n)) a - -> ApiaryT (Snoc as (UnBool a)) n m b - -> ApiaryT as n m b -sql doc p = focus (maybe id DocPrecondition doc) $ \l -> do - r <- runSql p - maybe empty (\i -> return $ sSnoc l i) $ unBool r +sql :: (Has Persist exts, MonadBaseControl IO actM) + => Maybe Html -- ^ documentation. + -> SqlPersistT (ActionT exts actM) a + -> (a -> Maybe b) -- ^ result check function. Nothing: fail filter, Just a: success filter and add parameter. + -> 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)