persistent 0.6.4.2 → 0.6.4.3
raw patch · 6 files changed
+117/−26 lines, 6 filesdep +transformers-basedep ~monad-control
Dependencies added: transformers-base
Dependency ranges changed: monad-control
Files
- Database/Persist/Base.hs +10/−2
- Database/Persist/GenericSql.hs +36/−15
- Database/Persist/GenericSql/Internal.hs +25/−3
- Database/Persist/GenericSql/Raw.hs +34/−3
- Database/Persist/Join/Sql.hs +9/−1
- persistent.cabal +3/−2
Database/Persist/Base.hs view
@@ -8,6 +8,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-} -- | API for database actions. The API deals with fields and entities. -- In SQL, a field corresponds to a column, and should be a single non-composite value.@@ -77,8 +78,15 @@ import qualified Data.Text.Encoding.Error as T import Web.PathPieces (SinglePiece (..)) import qualified Data.Text.Read+import Control.Monad.IO.Class (MonadIO) +#if MIN_VERSION_monad_control(0, 3, 0)+import Control.Monad.Trans.Control (MonadBaseControl)+#define MBCIO MonadBaseControl IO+#else import Control.Monad.IO.Control (MonadControlIO)+#define MBCIO MonadControlIO+#endif import Data.Object (TextObject) fst3 :: forall t t1 t2. (t, t1, t2) -> t@@ -579,7 +587,7 @@ type PersistConfigPool c loadConfig :: TextObject -> Either String c -- | I really don't want Applicative here, but it's necessary for Mongo.- withPool :: (Applicative m, MonadControlIO m) => c -> (PersistConfigPool c -> m a) -> m a- runPool :: MonadControlIO m => c -> PersistConfigBackend c m a+ withPool :: (Applicative m, MBCIO m, MonadIO m) => c -> (PersistConfigPool c -> m a) -> m a+ runPool :: (MBCIO m, MonadIO m) => c -> PersistConfigBackend c m a -> PersistConfigPool c -> m a
Database/Persist/GenericSql.hs view
@@ -4,6 +4,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-} -- FIXME {-# OPTIONS_GHC -fno-warn-orphans #-} -- | This is a helper module for creating SQL backends. Regular users do not -- need to use this module.@@ -41,8 +44,16 @@ import Database.Persist.GenericSql.Raw (SqlPersist (..)) import Control.Monad (liftM, unless) import Data.Enumerator (Stream (..), Iteratee (..), Step (..))+#if MIN_VERSION_monad_control(0, 3, 0)+import Control.Monad.Trans.Control (MonadBaseControl, control)+import qualified Control.Exception as E+#define MBCIO MonadBaseControl IO+#else import Control.Monad.IO.Control (MonadControlIO) import Control.Exception.Control (onException)++#define MBCIO MonadControlIO+#endif import Control.Exception (throw, toException) import Data.Text (Text, pack, unpack, snoc) import qualified Data.Text.IO@@ -59,17 +70,19 @@ Right (i, "") -> Just $ Key $ PersistInt64 i _ -> Nothing -withStmt' :: MonadControlIO m => Text -> [PersistValue]- -> (RowPopper (SqlPersist m) -> SqlPersist m a) -> SqlPersist m a+withStmt'+ :: (MBCIO m, MonadIO m)+ => Text -> [PersistValue]+ -> (RowPopper (SqlPersist m) -> SqlPersist m a) -> SqlPersist m a withStmt' = R.withStmt execute' :: MonadIO m => Text -> [PersistValue] -> SqlPersist m () execute' = R.execute -runSqlPool :: MonadControlIO m => SqlPersist m a -> Pool Connection -> m a+runSqlPool :: (MBCIO m, MonadIO m) => SqlPersist m a -> Pool Connection -> m a runSqlPool r pconn = withPool' pconn $ runSqlConn r -runSqlConn :: MonadControlIO m => SqlPersist m a -> Connection -> m a+runSqlConn :: (MBCIO m, MonadIO m) => SqlPersist m a -> Connection -> m a runSqlConn (SqlPersist r) conn = do let getter = R.getStmt' conn liftIO $ begin conn getter@@ -79,7 +92,7 @@ liftIO $ commitC conn getter return x -instance MonadControlIO m => PersistBackend SqlPersist m where+instance (MonadIO m, MBCIO m) => PersistBackend SqlPersist m where insert val = do conn <- SqlPersist ask let esql = insertSql conn (rawTableName t) (map fst3 $ tableColumns t)@@ -381,32 +394,33 @@ Left errs -> error $ unlines $ map unpack errs Right sql -> return sql -printMigration :: MonadControlIO m => Migration (SqlPersist m) -> SqlPersist m ()+printMigration :: (MBCIO m, MonadIO m) => Migration (SqlPersist m) -> SqlPersist m () printMigration m = do mig <- parseMigration' m mapM_ (liftIO . Data.Text.IO.putStrLn . flip snoc ';') (allSql mig) -getMigration :: MonadControlIO m => Migration (SqlPersist m) -> SqlPersist m [Sql]+getMigration :: (MBCIO m, MonadIO m) => Migration (SqlPersist m) -> SqlPersist m [Sql] getMigration m = do mig <- parseMigration' m return $ allSql mig -runMigration :: MonadControlIO m+runMigration :: (MonadIO m, MBCIO m) => Migration (SqlPersist m) -> SqlPersist m () runMigration m = runMigration' m False >> return () -- | Same as 'runMigration', but returns a list of the SQL commands executed -- instead of printing them to stderr.-runMigrationSilent :: MonadControlIO m+runMigrationSilent :: (MBCIO m, MonadIO m) => Migration (SqlPersist m) -> SqlPersist m [Text] runMigrationSilent m = runMigration' m True -runMigration' :: MonadControlIO m- => Migration (SqlPersist m)- -> Bool -- ^ is silent?- -> SqlPersist m [Text]+runMigration'+ :: (MBCIO m, MonadIO m)+ => Migration (SqlPersist m)+ -> Bool -- ^ is silent?+ -> SqlPersist m [Text] runMigration' m silent = do mig <- parseMigration' m case unsafeSql mig of@@ -417,7 +431,7 @@ , unlines $ map (\s -> " " ++ unpack s ++ ";") $ errs ] -runMigrationUnsafe :: MonadControlIO m+runMigrationUnsafe :: (MBCIO m, MonadIO m) => Migration (SqlPersist m) -> SqlPersist m () runMigrationUnsafe m = do@@ -430,7 +444,7 @@ execute' s [] return s -migrate :: (MonadControlIO m, PersistEntity val)+migrate :: (MonadIO m, MBCIO m, PersistEntity val) => val -> Migration (SqlPersist m) migrate val = do@@ -455,3 +469,10 @@ conn <- SqlPersist ask let getter = R.getStmt' conn liftIO $ rollbackC conn getter >> begin conn getter++#if MIN_VERSION_monad_control(0, 3, 0)+onException :: MonadBaseControl IO m => m α -> m β -> m α+onException m what = control $ \runInIO ->+ E.onException (runInIO m)+ (runInIO what)+#endif
Database/Persist/GenericSql/Internal.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE PackageImports #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} -- | Code that is only needed for writing GenericSql backends. module Database.Persist.GenericSql.Internal ( Connection (..)@@ -31,8 +33,16 @@ import Database.Persist.Base import Data.Maybe (fromMaybe) import Control.Arrow+#if MIN_VERSION_monad_control(0, 3, 0)+import Control.Monad.Trans.Control (MonadBaseControl, control, restoreM)+import qualified Control.Exception as E+#define MBCIO MonadBaseControl IO+#else import Control.Monad.IO.Control (MonadControlIO) import Control.Exception.Control (bracket)++#define MBCIO MonadControlIO+#endif import Database.Persist.Util (nullable) import Data.List (intercalate) import Data.Text (Text)@@ -57,15 +67,15 @@ { finalize :: IO () , reset :: IO () , execute :: [PersistValue] -> IO ()- , withStmt :: forall a m. MonadControlIO m+ , withStmt :: forall a m. (MBCIO m, MonadIO m) => [PersistValue] -> (RowPopper m -> m a) -> m a } -withSqlPool :: MonadControlIO m+withSqlPool :: (MonadIO m, MBCIO m) => IO Connection -> Int -> (Pool Connection -> m a) -> m a withSqlPool mkConn = createPool mkConn close' -withSqlConn :: MonadControlIO m => IO Connection -> (Connection -> m a) -> m a+withSqlConn :: (MonadIO m, MBCIO m) => IO Connection -> (Connection -> m a) -> m a withSqlConn open = bracket (liftIO open) (liftIO . close') close' :: Connection -> IO ()@@ -297,3 +307,15 @@ then (++) (escapeName conn (rawTableName t) ++ ".") else id) $ escapeName conn $ getFieldName t $ columnName $ cd x++#if MIN_VERSION_monad_control(0, 3, 0)+bracket :: MonadBaseControl IO m+ => m a -- ^ computation to run first (\"acquire resource\")+ -> (a -> m b) -- ^ computation to run last (\"release resource\")+ -> (a -> m c) -- ^ computation to run in-between+ -> m c+bracket before after thing = control $ \runInIO ->+ E.bracket (runInIO before)+ (\st -> runInIO $ restoreM st >>= after)+ (\st -> runInIO $ restoreM st >>= thing)+#endif
Database/Persist/GenericSql/Raw.hs view
@@ -1,6 +1,11 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-} module Database.Persist.GenericSql.Raw ( withStmt , execute@@ -18,14 +23,40 @@ import qualified Data.Map as Map import Control.Applicative (Applicative) import Control.Monad.Trans.Class (MonadTrans (..))-import Control.Monad.IO.Control (MonadControlIO (..))+import Control.Monad.Base (MonadBase (liftBase))+#if MIN_VERSION_monad_control(0, 3, 0)+import Control.Monad.Trans.Control (MonadBaseControl (..), ComposeSt, defaultLiftBaseWith, defaultRestoreM, MonadTransControl (..))+import Control.Monad (liftM)+#define MBCIO MonadBaseControl IO+#else+import Control.Monad.IO.Control (MonadControlIO)+#define MBCIO MonadControlIO+#endif import Data.Text (Text) import Control.Monad (MonadPlus) newtype SqlPersist m a = SqlPersist { unSqlPersist :: ReaderT Connection m a }- deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadControlIO, MonadPlus)+ deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadPlus+#if !MIN_VERSION_monad_control(0, 3, 0)+ , MonadControlIO+#endif+ ) -withStmt :: MonadControlIO m => Text -> [PersistValue]+instance MonadBase b m => MonadBase b (SqlPersist m) where+ liftBase = lift . liftBase++#if MIN_VERSION_monad_control(0, 3, 0)+instance MonadBaseControl b m => MonadBaseControl b (SqlPersist m) where+ newtype StM (SqlPersist m) a = StMSP {unStMSP :: ComposeSt SqlPersist m a}+ liftBaseWith = defaultLiftBaseWith StMSP+ restoreM = defaultRestoreM unStMSP+instance MonadTransControl SqlPersist where+ newtype StT SqlPersist a = StReader {unStReader :: a}+ liftWith f = SqlPersist $ ReaderT $ \r -> f $ \t -> liftM StReader $ runReaderT (unSqlPersist t) r+ restoreT = SqlPersist . ReaderT . const . liftM unStReader+#endif++withStmt :: (MonadIO m, MBCIO m) => Text -> [PersistValue] -> (RowPopper (SqlPersist m) -> SqlPersist m a) -> SqlPersist m a withStmt sql vals pop = do stmt <- getStmt sql
Database/Persist/Join/Sql.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-} module Database.Persist.Join.Sql ( RunJoin (..) ) where@@ -15,10 +16,17 @@ import Database.Persist.GenericSql.Internal hiding (withStmt) import Database.Persist.GenericSql.Raw (withStmt) import Control.Monad.Trans.Reader (ask)+#if MIN_VERSION_monad_control(0, 3, 0)+import Control.Monad.Trans.Control (MonadBaseControl)+#define MBCIO MonadBaseControl IO+#else import Control.Monad.IO.Control (MonadControlIO)+#define MBCIO MonadControlIO+#endif import Data.Function (on) import Control.Arrow ((&&&)) import Data.Text (pack)+import Control.Monad.IO.Class (MonadIO) fromPersistValuesId :: PersistEntity v => [PersistValue] -> Either String (Key SqlPersist v, v) fromPersistValuesId [] = Left "fromPersistValuesId: No values provided"@@ -29,7 +37,7 @@ fromPersistValuesId _ = Left "fromPersistValuesId: invalid ID" class RunJoin a where- runJoin :: MonadControlIO m => a -> SqlPersist m (J.Result a)+ runJoin :: (MonadIO m, MBCIO m) => a -> SqlPersist m (J.Result a) instance (PersistEntity one, PersistEntity many, Eq (Key SqlPersist one)) => RunJoin (SelectOneMany SqlPersist one many) where
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 0.6.4.2+version: 0.6.4.3 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -20,12 +20,13 @@ , text >= 0.8 && < 0.12 , containers >= 0.2 && < 0.5 , enumerator >= 0.4.9 && < 0.5- , monad-control >= 0.2 && < 0.3+ , monad-control >= 0.2 && < 0.4 , pool >= 0.1 && < 0.2 , blaze-html >= 0.4 && < 0.5 , path-pieces >= 0.0 && < 0.1 , mtl >= 2.0 && < 2.1 , data-object >= 0.3.1.7 && < 0.4+ , transformers-base exposed-modules: Database.Persist Database.Persist.Base Database.Persist.Quasi