packages feed

persistent 2.7.3.1 → 2.8.0

raw patch · 13 files changed

+83/−80 lines, 13 filesdep +unliftio-coredep +voiddep −exceptionsdep −lifted-basedep −transformers-basedep ~basedep ~conduitdep ~monad-control

Dependencies added: unliftio-core, void

Dependencies removed: exceptions, lifted-base, transformers-base

Dependency ranges changed: base, conduit, monad-control, monad-logger, resourcet

Files

ChangeLog.md view
@@ -1,3 +1,8 @@+## 2.8.0++* Switch from `MonadBaseControl` to `MonadUnliftIO`+* Reapplies [#723](https://github.com/yesodweb/persistent/pull/723), which was reverted in version 2.7.3.+ ## 2.7.3.1    * Improve error messages when failing to parse database results into Persistent records. [#741](https://github.com/yesodweb/persistent/pull/741)
Database/Persist/Class/DeleteCascade.hs view
@@ -9,7 +9,7 @@ import Database.Persist.Class.PersistQuery import Database.Persist.Class.PersistEntity -import qualified Data.Conduit as C+import Data.Conduit import qualified Data.Conduit.List as CL import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (ReaderT, ask, runReaderT)@@ -31,4 +31,4 @@ deleteCascadeWhere filts = do     srcRes <- selectKeysRes filts []     conn <- ask-    liftIO $ with srcRes (C.$$ CL.mapM_ (flip runReaderT conn . deleteCascade))+    liftIO $ with srcRes (\src -> runConduit $ src .| CL.mapM_ (flip runReaderT conn . deleteCascade))
Database/Persist/Class/PersistConfig.hs view
@@ -7,8 +7,7 @@  import Data.Aeson (Value (Object)) import Data.Aeson.Types (Parser)-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Applicative as A ((<$>)) import qualified Data.HashMap.Strict as HashMap @@ -31,7 +30,7 @@     createPoolConfig :: c -> IO (PersistConfigPool c)      -- | Run a database action by taking a connection from the pool.-    runPool :: (MonadBaseControl IO m, MonadIO m)+    runPool :: MonadUnliftIO m             => c             -> PersistConfigBackend c m a             -> PersistConfigPool c
Database/Persist/Class/PersistEntity.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-}@@ -43,6 +44,7 @@ import qualified Data.HashMap.Strict as HM import Data.Typeable (Typeable) import Data.Maybe (isJust)+import GHC.Generics  -- | Persistent serialized Haskell records to the database. -- A Database 'Entity' (A row in SQL, a document in MongoDB, etc)@@ -170,17 +172,16 @@ -- your query returns two entities (i.e. @(Entity backend a, -- Entity backend b)@), then you must you use @SELECT ??, ?? -- WHERE ...@, and so on.-data Entity record = PersistEntity record =>+data Entity record =     Entity { entityKey :: Key record            , entityVal :: record }+    deriving Typeable -deriving instance (PersistEntity record, Eq (Key record), Eq record) => Eq (Entity record)-deriving instance (PersistEntity record, Ord (Key record), Ord record) => Ord (Entity record)-deriving instance (PersistEntity record, Show (Key record), Show record) => Show (Entity record)-deriving instance (PersistEntity record, Read (Key record), Read record) => Read (Entity record)-#if MIN_VERSION_base(4,7,0)-deriving instance Typeable Entity-#endif+deriving instance (Generic (Key record), Generic record) => Generic (Entity record)+deriving instance (Eq (Key record), Eq record) => Eq (Entity record)+deriving instance (Ord (Key record), Ord record) => Ord (Entity record)+deriving instance (Show (Key record), Show record) => Show (Entity record)+deriving instance (Read (Key record), Read record) => Read (Entity record)  -- | Get list of values corresponding to given entity. entityValues :: PersistEntity record => Entity record -> [PersistValue]
Database/Persist/Class/PersistQuery.hs view
@@ -15,7 +15,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader   (ReaderT, MonadReader) -import qualified Data.Conduit as C+import Data.Conduit (ConduitM, (.|), await, runConduit) import qualified Data.Conduit.List as CL import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistEntity@@ -30,7 +30,7 @@            :: (PersistRecordBackend record backend, MonadIO m1, MonadIO m2)            => [Filter record]            -> [SelectOpt record]-           -> ReaderT backend m1 (Acquire (C.Source m2 (Entity record)))+           -> ReaderT backend m1 (Acquire (ConduitM () (Entity record) m2 ()))      -- | Get just the first record for the criterion.     selectFirst :: (MonadIO m, PersistRecordBackend record backend)@@ -39,14 +39,14 @@                 -> ReaderT backend m (Maybe (Entity record))     selectFirst filts opts = do         srcRes <- selectSourceRes filts (LimitTo 1 : opts)-        liftIO $ with srcRes (C.$$ CL.head)+        liftIO $ with srcRes (\src -> runConduit $ src .| await)      -- | Get the 'Key's of all records matching the given criterion.     selectKeysRes         :: (MonadIO m1, MonadIO m2, PersistRecordBackend record backend)         => [Filter record]         -> [SelectOpt record]-        -> ReaderT backend m1 (Acquire (C.Source m2 (Key record)))+        -> ReaderT backend m1 (Acquire (ConduitM () (Key record) m2 ()))      -- | The total number of records fulfilling the given criterion.     count :: (MonadIO m, PersistRecordBackend record backend)@@ -68,7 +68,7 @@        :: (PersistQueryRead (BaseBackend backend), MonadResource m, PersistEntity record, PersistEntityBackend record ~ BaseBackend (BaseBackend backend), MonadReader backend m, HasPersistBackend backend)        => [Filter record]        -> [SelectOpt record]-       -> C.Source m (Entity record)+       -> ConduitM () (Entity record) m () selectSource filts opts = do     srcRes <- liftPersist $ selectSourceRes filts opts     (releaseKey, src) <- allocateAcquire srcRes@@ -79,7 +79,7 @@ selectKeys :: (PersistQueryRead (BaseBackend backend), MonadResource m, PersistEntity record, BaseBackend (BaseBackend backend) ~ PersistEntityBackend record, MonadReader backend m, HasPersistBackend backend)            => [Filter record]            -> [SelectOpt record]-           -> C.Source m (Key record)+           -> ConduitM () (Key record) m () selectKeys filts opts = do     srcRes <- liftPersist $ selectKeysRes filts opts     (releaseKey, src) <- allocateAcquire srcRes@@ -93,7 +93,7 @@            -> ReaderT backend m [Entity record] selectList filts opts = do     srcRes <- selectSourceRes filts opts-    liftIO $ with srcRes (C.$$ CL.consume)+    liftIO $ with srcRes (\src -> runConduit $ src .| CL.consume)  -- | Call 'selectKeys' but return the result as a list. selectKeysList :: (MonadIO m, PersistQueryRead backend, PersistRecordBackend record backend)@@ -102,4 +102,4 @@                -> ReaderT backend m [Key record] selectKeysList filts opts = do     srcRes <- selectKeysRes filts opts-    liftIO $ with srcRes (C.$$ CL.consume)+    liftIO $ with srcRes (\src -> runConduit $ src .| CL.consume)
Database/Persist/Class/PersistStore.hs view
@@ -23,7 +23,7 @@  import qualified Data.Text as T import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Exception.Lifted (throwIO)+import Control.Exception (throwIO) import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.Reader (MonadReader (ask), runReaderT) import Database.Persist.Class.PersistEntity
Database/Persist/Sql/Migration.hs view
@@ -13,9 +13,8 @@   ) where  -import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Class (MonadTrans (..))-import Control.Monad.IO.Class+import Control.Monad.IO.Unlift import Control.Monad.Trans.Writer import Control.Monad.Trans.Reader (ReaderT (..), ask) import Control.Monad (liftM, unless)@@ -23,10 +22,10 @@ import qualified Data.Text.IO import System.IO import System.IO.Silently (hSilence)-import Control.Monad.Trans.Control (liftBaseOp_) import Database.Persist.Sql.Types import Database.Persist.Sql.Raw import Database.Persist.Types+import Database.Persist.Sql.Orphan.PersistStore()  allSql :: CautiousMigration -> [Sql] allSql = map snd@@ -79,10 +78,11 @@  -- | Same as 'runMigration', but returns a list of the SQL commands executed -- instead of printing them to stderr.-runMigrationSilent :: (MonadBaseControl IO m, MonadIO m)+runMigrationSilent :: (MonadUnliftIO m, MonadIO m)                    => Migration                    -> ReaderT SqlBackend m [Text]-runMigrationSilent m = liftBaseOp_ (hSilence [stderr]) $ runMigration' m True+runMigrationSilent m = withRunInIO $ \run ->+  hSilence [stderr] $ run $ runMigration' m True  -- | Run the given migration against the database. If the migration fails -- to parse, or there are any unsafe migrations, then this will error at
Database/Persist/Sql/Orphan/PersistQuery.hs view
@@ -57,7 +57,7 @@     selectSourceRes filts opts = do         conn <- ask         srcRes <- rawQueryRes (sql conn) (getFiltsValues conn filts)-        return $ fmap ($= CL.mapM parse) srcRes+        return $ fmap (.| CL.mapM parse) srcRes       where         (limit, offset, orders) = limitOffsetOrder opts @@ -85,7 +85,7 @@     selectKeysRes filts opts = do         conn <- ask         srcRes <- rawQueryRes (sql conn) (getFiltsValues conn filts)-        return $ fmap ($= CL.mapM parse) srcRes+        return $ fmap (.| CL.mapM parse) srcRes       where         t = entityDef $ dummyFromFilts filts         cols conn = T.intercalate "," $ dbIdColumns conn t
Database/Persist/Sql/Orphan/PersistStore.hs view
@@ -23,7 +23,7 @@ import Database.Persist.Sql.Types import Database.Persist.Sql.Raw import Database.Persist.Sql.Util (dbIdColumns, keyAndEntityColumnNames)-import qualified Data.Conduit as C+import Data.Conduit import qualified Data.Conduit.List as CL import qualified Data.Text as T import Data.Text (Text, unpack)@@ -32,6 +32,7 @@ import Data.ByteString.Char8 (readInteger) import Data.Maybe (isJust) import Data.List (find)+import Data.Void (Void) import Control.Monad.Trans.Reader (ReaderT, ask, withReaderT) import Data.Acquire (with) import Data.Int (Int64)@@ -39,17 +40,17 @@ import Web.HttpApiData (ToHttpApiData, FromHttpApiData) import Database.Persist.Sql.Class (PersistFieldSql) import qualified Data.Aeson as A-import Control.Exception.Lifted (throwIO)+import Control.Exception (throwIO) import Database.Persist.Class ()  withRawQuery :: MonadIO m              => Text              -> [PersistValue]-             -> C.Sink [PersistValue] IO a+             -> ConduitM [PersistValue] Void IO a              -> ReaderT SqlBackend m a withRawQuery sql vals sink = do     srcRes <- rawQueryRes sql vals-    liftIO $ with srcRes (C.$$ sink)+    liftIO $ with srcRes (\src -> runConduit $ src .| sink)  toSqlKey :: ToBackendKey SqlBackend record => Int64 -> Key record toSqlKey = fromBackendKey . SqlBackendKey
Database/Persist/Sql/Raw.hs view
@@ -24,7 +24,7 @@ rawQuery :: (MonadResource m, MonadReader env m, HasPersistBackend env, BaseBackend env ~ SqlBackend)          => Text          -> [PersistValue]-         -> Source m [PersistValue]+         -> ConduitM () [PersistValue] m () rawQuery sql vals = do     srcRes <- liftPersist $ rawQueryRes sql vals     (releaseKey, src) <- allocateAcquire srcRes@@ -35,7 +35,7 @@     :: (MonadIO m1, MonadIO m2, IsSqlBackend env)     => Text     -> [PersistValue]-    -> ReaderT env m1 (Acquire (Source m2 [PersistValue]))+    -> ReaderT env m1 (Acquire (ConduitM () [PersistValue] m2 ())) rawQueryRes sql vals = do     conn <- persistBackend `liftM` ask     let make = do@@ -47,20 +47,20 @@         stmtQuery stmt vals  -- | Execute a raw SQL statement-rawExecute :: MonadIO m+rawExecute :: (MonadIO m, BackendCompatible SqlBackend backend)            => Text            -- ^ SQL statement, possibly with placeholders.            -> [PersistValue]  -- ^ Values to fill the placeholders.-           -> ReaderT SqlBackend m ()+           -> ReaderT backend m () rawExecute x y = liftM (const ()) $ rawExecuteCount x y  -- | Execute a raw SQL statement and return the number of -- rows it has modified.-rawExecuteCount :: (MonadIO m, IsSqlBackend backend)+rawExecuteCount :: (MonadIO m, BackendCompatible SqlBackend backend)                 => Text            -- ^ SQL statement, possibly with placeholders.                 -> [PersistValue]  -- ^ Values to fill the placeholders.                 -> ReaderT backend m Int64 rawExecuteCount sql vals = do-    conn <- persistBackend `liftM` ask+    conn <- projectBackend `liftM` ask     runLoggingT (logDebugNS (pack "SQL") $ T.append sql $ pack $ "; " ++ show vals)         (connLogFunc conn)     stmt <- getStmt sql@@ -69,10 +69,10 @@     return res  getStmt-  :: (MonadIO m, IsSqlBackend backend)+  :: (MonadIO m, BackendCompatible SqlBackend backend)   => Text -> ReaderT backend m Statement getStmt sql = do-    conn <- persistBackend `liftM` ask+    conn <- projectBackend `liftM` ask     liftIO $ getStmtConn conn sql  getStmtConn :: SqlBackend -> Text -> IO Statement@@ -218,7 +218,7 @@        withStmt' colSubsts params sink = do             srcRes <- rawQueryRes sql params-            liftIO $ with srcRes ($$ sink)+            liftIO $ with srcRes (\src -> runConduit $ src .| sink)           where             sql = T.concat $ makeSubsts colSubsts $ T.splitOn placeholder stmt             placeholder = "??"
Database/Persist/Sql/Run.hs view
@@ -7,17 +7,15 @@ import Database.Persist.Class.PersistStore import Database.Persist.Sql.Types import Database.Persist.Sql.Raw-import Control.Monad.Trans.Control import Data.Pool as P import Control.Monad.Trans.Reader hiding (local) import Control.Monad.Trans.Resource import Control.Monad.Logger-import Control.Monad.Base-import Control.Exception.Lifted (onException, bracket)-import Control.Monad.IO.Class+import Control.Exception (onException, bracket)+import Control.Monad.IO.Unlift import Control.Exception (mask) import System.Timeout (timeout)-import Data.IORef (readIORef, writeIORef, newIORef)+import Data.IORef (readIORef) import qualified Data.Map as Map import Control.Monad (liftM) @@ -28,22 +26,22 @@ -- was buggy and caused more problems than it solved. Since version 2.1.2, it -- performs no timeout checks. runSqlPool-    :: (MonadBaseControl IO m, IsSqlBackend backend)+    :: (MonadUnliftIO m, IsSqlBackend backend)     => ReaderT backend m a -> Pool backend -> m a-runSqlPool r pconn = withResource pconn $ runSqlConn r+runSqlPool r pconn = withRunInIO $ \run -> withResource pconn $ run . runSqlConn r  -- | Like 'withResource', but times out the operation if resource -- allocation does not complete within the given timeout period. -- -- @since 2.0.0 withResourceTimeout-  :: forall a m b.  (MonadBaseControl IO m)+  :: forall a m b.  (MonadUnliftIO m)   => Int -- ^ Timeout period in microseconds   -> Pool a   -> (a -> m b)   -> m (Maybe b) {-# SPECIALIZE withResourceTimeout :: Int -> Pool a -> (a -> IO b) -> IO (Maybe b) #-}-withResourceTimeout ms pool act = control $ \runInIO -> mask $ \restore -> do+withResourceTimeout ms pool act = withRunInIO $ \runInIO -> mask $ \restore -> do     mres <- timeout ms $ takeResource pool     case mres of         Nothing -> runInIO $ return (Nothing :: Maybe b)@@ -54,8 +52,8 @@             return ret {-# INLINABLE withResourceTimeout #-} -runSqlConn :: (MonadBaseControl IO m, IsSqlBackend backend) => ReaderT backend m a -> backend -> m a-runSqlConn r conn = control $ \runInIO -> mask $ \restore -> do+runSqlConn :: (MonadUnliftIO m, IsSqlBackend backend) => ReaderT backend m a -> backend -> m a+runSqlConn r conn = withRunInIO $ \runInIO -> mask $ \restore -> do     let conn' = persistBackend conn         getter = getStmtConn conn'     restore $ connBegin conn' getter@@ -81,16 +79,18 @@ liftSqlPersistMPool x pool = liftIO (runSqlPersistMPool x pool)  withSqlPool-    :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, IsSqlBackend backend)+    :: (MonadLogger m, MonadUnliftIO m, IsSqlBackend backend)     => (LogFunc -> IO backend) -- ^ create a new connection     -> Int -- ^ connection count     -> (Pool backend -> m a)     -> m a-withSqlPool mkConn connCount f =-    bracket (createSqlPool mkConn connCount) (liftIO . destroyAllResources) f+withSqlPool mkConn connCount f = withUnliftIO $ \u -> bracket+    (unliftIO u $ createSqlPool mkConn connCount)+    destroyAllResources+    (unliftIO u . f)  createSqlPool-    :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, IsSqlBackend backend)+    :: (MonadLogger m, MonadUnliftIO m, IsSqlBackend backend)     => (LogFunc -> IO backend)     -> Int     -> m (Pool backend)@@ -104,21 +104,19 @@ -- FIXME: in a future release, switch over to the new askLoggerIO function -- added in monad-logger 0.3.10. That function was not available at the time -- this code was written.-askLogFunc :: forall m. (MonadBaseControl IO m, MonadLogger m) => m LogFunc-askLogFunc = do-    ref <- liftBase $ newIORef undefined-    liftBaseWith $ \run -> writeIORef ref run-    runInBase <- liftBase $ readIORef ref-    return $ \a b c d -> do-        _ <- runInBase (monadLoggerLog a b c d)-        return ()+askLogFunc :: forall m. (MonadUnliftIO m, MonadLogger m) => m LogFunc+askLogFunc = withRunInIO $ \run ->+    return $ \a b c d -> run (monadLoggerLog a b c d)  withSqlConn-    :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, IsSqlBackend backend)+    :: (MonadUnliftIO m, MonadLogger m, IsSqlBackend backend)     => (LogFunc -> IO backend) -> (backend -> m a) -> m a withSqlConn open f = do     logFunc <- askLogFunc-    bracket (liftIO $ open logFunc) (liftIO . close') f+    withRunInIO $ \run -> bracket+      (open logFunc)+      close'+      (run . f)  close' :: (IsSqlBackend backend) => backend -> IO () close' conn = do
Database/Persist/Sql/Types/Internal.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -28,7 +29,7 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask) import Data.Acquire (Acquire)-import Data.Conduit (Source)+import Data.Conduit (ConduitM) import Data.Int (Int64) import Data.IORef (IORef) import Data.Map (Map)@@ -39,6 +40,7 @@   , PersistQueryRead, PersistQueryWrite   , PersistStoreRead, PersistStoreWrite   , PersistUniqueRead, PersistUniqueWrite+  , BackendCompatible(..)   ) import Database.Persist.Class.PersistStore (IsPersistBackend (..)) import Database.Persist.Types@@ -57,7 +59,7 @@     , stmtExecute :: [PersistValue] -> IO Int64     , stmtQuery :: forall m. MonadIO m                 => [PersistValue]-                -> Acquire (Source m [PersistValue])+                -> Acquire (ConduitM () [PersistValue] m ())     }  data SqlBackend = SqlBackend@@ -130,7 +132,7 @@  -- | A constraint synonym which witnesses that a backend is SQL and can run read queries. type SqlBackendCanRead backend =-  ( IsSqlBackend backend+  ( BackendCompatible SqlBackend backend   , PersistQueryRead backend, PersistStoreRead backend, PersistUniqueRead backend   ) -- | A constraint synonym which witnesses that a backend is SQL and can run read and write queries.
persistent.cabal view
@@ -1,5 +1,5 @@ name:            persistent-version:         2.7.3.1+version:         2.8.0 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -29,17 +29,13 @@                    , old-locale                    , text                     >= 0.8                    , containers               >= 0.2-                   , conduit                  >= 1.0-                   , resourcet                >= 1.1-                   , exceptions               >= 0.6-                   , monad-control            >= 0.3-                   , lifted-base              >= 0.1+                   , conduit                  >= 1.2.8+                   , resourcet                >= 1.1.10                    , resource-pool            >= 0.2.2.0                    , path-pieces              >= 0.1                    , http-api-data            >= 0.2       && < 0.4                    , aeson                    >= 0.5-                   , monad-logger             >= 0.3-                   , transformers-base+                   , monad-logger             >= 0.3.28                    , base64-bytestring                    , unordered-containers                    , vector@@ -53,6 +49,8 @@                    , fast-logger              >= 2.1                    , scientific                    , tagged+                   , unliftio-core+                   , void      exposed-modules: Database.Persist                      Database.Persist.Quasi@@ -89,7 +87,7 @@     type:          exitcode-stdio-1.0     main-is:       test/main.hs -    build-depends:   base >= 4.6 && < 5+    build-depends:   base >= 4.8 && < 5                    , hspec >= 1.3                    , containers                    , text@@ -112,7 +110,6 @@                    , scientific                    , tagged                    , fast-logger              >= 2.1-                   , lifted-base              >= 0.1                    , mtl                    , template-haskell                    , resource-pool