apiary-persistent 0.13.1.1 → 0.16.0

raw patch · 2 files changed

+117/−63 lines, 2 filesdep +apiary-loggerdep +monad-controldep +resource-pooldep −blaze-htmldep −mtldep −reflectiondep ~apiarydep ~persistentPVP ok

version bump matches the API change (PVP)

Dependencies added: apiary-logger, monad-control, resource-pool, transformers

Dependencies removed: blaze-html, mtl, reflection

Dependency ranges changed: apiary, persistent

API changes (from Hackage documentation)

Files

• apiary-persistent.cabal +13/−11
• src/Web/Apiary/Database/Persist.hs +104/−52

@@ -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: <https://github.com/philopon/apiary/blob/master/examples/persistent.hs>@@ -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

@@ -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)