persistent 1.0.2.2 → 1.1.0
raw patch · 9 files changed
+303/−122 lines, 9 filesdep ~basedep ~conduitdep ~monad-logger
Dependency ranges changed: base, conduit, monad-logger, pool-conduit, resourcet
Files
- Database/Persist.hs +2/−1
- Database/Persist/GenericSql.hs +21/−19
- Database/Persist/GenericSql/Raw.hs +40/−3
- Database/Persist/Query/GenericSql.hs +9/−10
- Database/Persist/Query/Internal.hs +80/−27
- Database/Persist/Query/Join.hs +17/−9
- Database/Persist/Query/Join/Sql.hs +8/−9
- Database/Persist/Store.hs +121/−39
- persistent.cabal +5/−5
Database/Persist.hs view
@@ -6,7 +6,8 @@ , PersistStore (..) , PersistUnique (..) , PersistQuery (..)- , Key (..)+ , KeyBackend (..)+ , Key , Entity (..) , insertBy , getJust
Database/Persist/GenericSql.hs view
@@ -17,7 +17,7 @@ , Statement , runSqlConn , runSqlPool- , Key (..)+ , Key -- * Raw SQL queries -- $rawSql@@ -65,10 +65,11 @@ import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import Control.Monad.Logger (MonadLogger)+import Control.Monad.Base (liftBase) type ConnectionPool = Pool Connection -instance PathPiece (Key SqlPersist entity) where+instance PathPiece (KeyBackend R.SqlBackend entity) where toPathPiece (Key (PersistInt64 i)) = toPathPiece i toPathPiece k = throw $ PersistInvalidField $ "Invalid Key: " ++ show k fromPathPiece t =@@ -81,26 +82,27 @@ -- | Get a connection from the pool, run the given action, and then return the -- connection to the pool.-runSqlPool :: (MonadBaseControl IO m, MonadIO m) => SqlPersist m a -> Pool Connection -> m a+runSqlPool :: MonadBaseControl IO m => SqlPersist m a -> Pool Connection -> m a runSqlPool r pconn = withResource pconn $ runSqlConn r -runSqlConn :: (MonadBaseControl IO m, MonadIO m) => SqlPersist m a -> Connection -> m a+runSqlConn :: MonadBaseControl IO m => SqlPersist m a -> Connection -> m a runSqlConn (SqlPersist r) conn = do let getter = R.getStmt' conn- liftIO $ begin conn getter+ liftBase $ begin conn getter x <- onException (runReaderT r conn)- (liftIO $ rollbackC conn getter)- liftIO $ commitC conn getter+ (liftBase $ rollbackC conn getter)+ liftBase $ commitC conn getter return x -instance (MonadBaseControl IO m, MonadIO m, C.MonadThrow m, C.MonadUnsafeIO m, MonadLogger m) => PersistStore SqlPersist m where+instance (C.MonadResource m, MonadLogger m) => PersistStore (SqlPersist m) where+ type PersistMonadBackend (SqlPersist m) = R.SqlBackend insert val = do conn <- SqlPersist ask let esql = insertSql conn (entityDB t) (map fieldDB $ entityFields t) (entityID t) i <- case esql of- ISRSingle sql -> C.runResourceT $ R.withStmt sql vals C.$$ do+ ISRSingle sql -> R.withStmt sql vals C.$$ do x <- CL.head case x of Just [PersistInt64 i] -> return i@@ -108,7 +110,7 @@ Just vals' -> error $ "Invalid result from a SQL insert, got: " P.++ P.show vals' ISRInsertGet sql1 sql2 -> do execute' sql1 vals- C.runResourceT $ R.withStmt sql2 [] C.$$ do+ R.withStmt sql2 [] C.$$ do Just [PersistInt64 i] <- CL.head return i return $ Key $ PersistInt64 i@@ -155,7 +157,7 @@ , "=?" ] vals' = [unKey k]- C.runResourceT $ R.withStmt sql vals' C.$$ do+ R.withStmt sql vals' C.$$ do res <- CL.head case res of Nothing -> return Nothing@@ -179,7 +181,7 @@ insrepHelper :: (MonadIO m, PersistEntity val, MonadLogger m) => Text- -> Key SqlPersist val+ -> Key val -> val -> SqlPersist m () insrepHelper command (Key k) val = do@@ -201,7 +203,7 @@ ] vals = k : map toPersistValue (toPersistFields val) -instance (MonadBaseControl IO m, C.MonadUnsafeIO m, MonadIO m, C.MonadThrow m, MonadLogger m) => PersistUnique SqlPersist m where+instance (C.MonadResource m, MonadLogger m) => PersistUnique (SqlPersist m) where deleteBy uniq = do conn <- SqlPersist ask let sql' = sql conn@@ -231,7 +233,7 @@ , sqlClause conn ] vals' = persistUniqueToValues uniq- C.runResourceT $ R.withStmt sql vals' C.$$ do+ R.withStmt sql vals' C.$$ do row <- CL.head case row of Nothing -> return Nothing@@ -247,7 +249,7 @@ t = entityDef $ dummyFromUnique uniq toFieldNames' = map snd . persistUniqueToFieldNames -dummyFromKey :: Key SqlPersist v -> v+dummyFromKey :: KeyBackend R.SqlBackend v -> v dummyFromKey _ = error "dummyFromKey" {- FIXME@@ -360,7 +362,7 @@ ======= -} -dummyFromUnique :: Unique v b -> v+dummyFromUnique :: Unique v -> v dummyFromUnique _ = error "dummyFromUnique" #if MIN_VERSION_monad_control(0, 3, 0)@@ -468,8 +470,8 @@ -- However, most common problems are mitigated by using the -- entity selection placeholder @??@, and you shouldn't see any -- error at all if you're not using 'Single'.-rawSql :: (RawSql a, C.MonadUnsafeIO m, C.MonadThrow m, MonadIO m, MonadBaseControl IO m, MonadLogger m) =>- Text -- ^ SQL statement, possibly with placeholders.+rawSql :: (RawSql a, C.MonadResource m, MonadLogger m)+ => Text -- ^ SQL statement, possibly with placeholders. -> [PersistValue] -- ^ Values to fill the placeholders. -> SqlPersist m [a] rawSql stmt = run@@ -500,7 +502,7 @@ run params = do conn <- SqlPersist ask let (colCount, colSubsts) = rawSqlCols (escapeName conn) x- C.runResourceT $ withStmt' colSubsts params C.$$ firstRow colCount+ withStmt' colSubsts params C.$$ firstRow colCount firstRow colCount = do mrow <- CL.head
Database/Persist/GenericSql/Raw.hs view
@@ -7,12 +7,15 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE EmptyDataDecls #-} module Database.Persist.GenericSql.Raw ( withStmt , execute , SqlPersist (..) , getStmt' , getStmt+ , SqlBackend+ , MonadSqlPersist (..) ) where import qualified Database.Persist.GenericSql.Internal as I@@ -33,7 +36,24 @@ import Control.Monad.Trans.Resource (MonadResource (..)) import Data.Conduit import Control.Monad.Logger (MonadLogger (..))+import Data.Monoid (Monoid) +import Control.Monad.Logger (LoggingT)+import Control.Monad.Trans.Identity ( IdentityT)+import Control.Monad.Trans.List ( ListT )+import Control.Monad.Trans.Maybe ( MaybeT )+import Control.Monad.Trans.Error ( ErrorT, Error)+import Control.Monad.Trans.Cont ( ContT )+import Control.Monad.Trans.State ( StateT )+import Control.Monad.Trans.Writer ( WriterT )+import Control.Monad.Trans.RWS ( RWST )++import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST )+import qualified Control.Monad.Trans.State.Strict as Strict ( StateT )+import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )++data SqlBackend+ newtype SqlPersist m a = SqlPersist { unSqlPersist :: ReaderT Connection m a } deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadPlus) @@ -67,9 +87,26 @@ instance (MonadIO m, MonadLogger m) => MonadSqlPersist (SqlPersist m) where askSqlConn = SqlPersist ask-instance MonadSqlPersist m => MonadSqlPersist (ResourceT m) where- askSqlConn = lift askSqlConn--- FIXME add a bunch of MonadSqlPersist instances for all transformers++#define GO(T) instance (MonadSqlPersist m) => MonadSqlPersist (T m) where askSqlConn = lift askSqlConn+#define GOX(X, T) instance (X, MonadSqlPersist m) => MonadSqlPersist (T m) where askSqlConn = lift askSqlConn+GO(LoggingT)+GO(IdentityT)+GO(ListT)+GO(MaybeT)+GOX(Error e, ErrorT e)+GO(ReaderT r)+GO(ContT r)+GO(StateT s)+GO(ResourceT)+GO(Pipe l i o u)+GOX(Monoid w, WriterT w)+GOX(Monoid w, RWST r w s)+GOX(Monoid w, Strict.RWST r w s)+GO(Strict.StateT s)+GOX(Monoid w, Strict.WriterT w)+#undef GO+#undef GOX instance MonadLogger m => MonadLogger (SqlPersist m) where monadLoggerLog a b c = lift $ monadLoggerLog a b c
Database/Persist/Query/GenericSql.hs view
@@ -32,11 +32,9 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Reader-import Control.Monad.Trans.Control (MonadBaseControl) import Data.Conduit import qualified Data.Conduit.List as CL-import Control.Monad.Trans.Resource (transResourceT) import Control.Exception (throwIO) import qualified Data.Text as T@@ -45,7 +43,7 @@ import Control.Monad.Logger (MonadLogger) -- orphaned instance for convenience of modularity-instance (MonadThrow m, MonadIO m, MonadUnsafeIO m, MonadBaseControl IO m, MonadLogger m) => PersistQuery SqlPersist m where+instance (MonadResource m, MonadLogger m) => PersistQuery (SqlPersist m) where update _ [] = return () update k upds = do conn <- SqlPersist ask@@ -78,14 +76,14 @@ , escapeName conn $ entityDB t , wher ]- runResourceT $ R.withStmt sql (getFiltsValues conn filts) $$ do+ R.withStmt sql (getFiltsValues conn filts) $$ do Just [PersistInt64 i] <- CL.head return $ fromIntegral i where t = entityDef $ dummyFromFilts filts selectSource filts opts = do- conn <- lift $ lift $ SqlPersist ask+ conn <- lift $ SqlPersist ask R.withStmt (sql conn) (getFiltsValues conn filts) $= CL.mapM parse where (limit, offset, orders) = limitOffsetOrder opts@@ -130,7 +128,7 @@ ] selectKeys filts opts = do- conn <- lift $ lift $ SqlPersist ask+ conn <- lift $ SqlPersist ask R.withStmt (sql conn) (getFiltsValues conn filts) $= CL.mapM parse where parse [PersistInt64 i] = return $ Key $ PersistInt64 i@@ -206,7 +204,7 @@ updatePersistValue :: Update v -> PersistValue updatePersistValue (Update _ v _) = toPersistValue v -dummyFromKey :: Key SqlPersist v -> v +dummyFromKey :: KeyBackend R.SqlBackend v -> v dummyFromKey _ = error "dummyFromKey" execute' :: (MonadLogger m, MonadIO m) => Text -> [PersistValue] -> SqlPersist m ()@@ -259,6 +257,7 @@ (a, b) = unzip $ map go fs wrapP x = T.concat ["(", x, ")"] + go (BackendFilter _) = error "BackendFilter not expected" go (FilterAnd []) = ("1=1", []) go (FilterAnd fs) = combineAND fs go (FilterOr []) = ("1=0", [])@@ -357,13 +356,13 @@ -- the environment inside a 'SqlPersist' monad, provide an explicit -- 'Connection'. This can allow you to use the returned 'Source' in an -- arbitrary monad.-selectSourceConn :: (PersistEntity val, SqlPersist ~ PersistEntityBackend val, MonadThrow m, MonadUnsafeIO m, MonadIO m, MonadBaseControl IO m, MonadLogger m)+selectSourceConn :: (PersistEntity val, MonadResource m, MonadLogger m, PersistEntityBackend val ~ R.SqlBackend, MonadBaseControl IO m) => Connection -> [Filter val] -> [SelectOpt val]- -> Source (ResourceT m) (Entity val)+ -> Source m (Entity val) selectSourceConn conn fs opts =- transPipe (transResourceT $ flip runSqlConn conn) (selectSource fs opts)+ transPipe (flip runSqlConn conn) (selectSource fs opts) dummyFromFilts :: [Filter v] -> v dummyFromFilts _ = error "dummyFromFilts"
Database/Persist/Query/Internal.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-} module Database.Persist.Query.Internal ( -- re-exported as public PersistQuery (..)@@ -19,70 +20,122 @@ -- * Exceptions , UpdateGetException (..)++ -- * Filters+ , BackendSpecificFilter ) where import Database.Persist.Store import Database.Persist.EntityDef-import Control.Monad.Trans.Class (lift)-import Control.Monad.Base (liftBase)+import Control.Monad.IO.Class (liftIO) import Control.Exception (Exception, throwIO) import Data.Typeable (Typeable) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL +import Control.Monad.Trans.Class (lift)+import Data.Monoid (Monoid)++import Data.Conduit (Pipe)+import Control.Monad.Logger (LoggingT)+import Control.Monad.Trans.Identity ( IdentityT)+import Control.Monad.Trans.List ( ListT )+import Control.Monad.Trans.Maybe ( MaybeT )+import Control.Monad.Trans.Error ( ErrorT, Error )+import Control.Monad.Trans.Reader ( ReaderT )+import Control.Monad.Trans.Cont ( ContT )+import Control.Monad.Trans.State ( StateT )+import Control.Monad.Trans.Writer ( WriterT )+import Control.Monad.Trans.RWS ( RWST )+import Control.Monad.Trans.Resource ( ResourceT)++import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST )+import qualified Control.Monad.Trans.State.Strict as Strict ( StateT )+import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )+ data UpdateGetException = KeyNotFound String deriving Typeable instance Show UpdateGetException where show (KeyNotFound key) = "Key not found during updateGet: " ++ key instance Exception UpdateGetException -class PersistStore backend m => PersistQuery backend m where+class PersistStore m => PersistQuery m where -- | Update individual fields on a specific record.- update :: PersistEntity val => Key backend val -> [Update val] -> backend m ()+ update :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)+ => Key val -> [Update val] -> m () -- | Update individual fields on a specific record, and retrieve the -- updated value from the database. -- -- Note that this function will throw an exception if the given key is not -- found in the database.- updateGet :: PersistEntity val => Key backend val -> [Update val] -> backend m val+ updateGet :: (PersistEntity val, PersistMonadBackend m ~ PersistEntityBackend val)+ => Key val -> [Update val] -> m val updateGet key ups = do update key ups- get key >>= maybe (liftBase $ throwIO $ KeyNotFound $ show key) return+ get key >>= maybe (liftIO $ throwIO $ KeyNotFound $ show key) return -- | Update individual fields on any record matching the given criterion.- updateWhere :: PersistEntity val => [Filter val] -> [Update val] -> backend m ()+ updateWhere :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)+ => [Filter val] -> [Update val] -> m () -- | Delete all records matching the given criterion.- deleteWhere :: PersistEntity val => [Filter val] -> backend m ()+ deleteWhere :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)+ => [Filter val] -> m () -- | Get all records matching the given criterion in the specified order. -- Returns also the identifiers. selectSource- :: (PersistEntity val, PersistEntityBackend val ~ backend)+ :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m) => [Filter val] -> [SelectOpt val]- -> C.Source (C.ResourceT (backend m)) (Entity val)+ -> C.Source m (Entity val) -- | get just the first record for the criterion- selectFirst :: (PersistEntity val, PersistEntityBackend val ~ backend)+ selectFirst :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m) => [Filter val] -> [SelectOpt val]- -> backend m (Maybe (Entity val))- selectFirst filts opts = C.runResourceT- $ selectSource filts ((LimitTo 1):opts) C.$$ CL.head+ -> m (Maybe (Entity val))+ selectFirst filts opts = selectSource filts ((LimitTo 1):opts) C.$$ CL.head -- | Get the 'Key's of all records matching the given criterion.- selectKeys :: PersistEntity val+ selectKeys :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m) => [Filter val] -> [SelectOpt val]- -> C.Source (C.ResourceT (backend m)) (Key backend val)+ -> C.Source m (Key val) -- | The total number of records fulfilling the given criterion.- count :: PersistEntity val => [Filter val] -> backend m Int+ count :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)+ => [Filter val] -> m Int +#define DEF(T) { update k = lift . update k; updateGet k = lift . updateGet k; updateWhere f = lift . updateWhere f; deleteWhere = lift . deleteWhere; selectSource f = C.transPipe lift . selectSource f; selectFirst f = lift . selectFirst f; selectKeys f = C.transPipe lift . selectKeys f; count = lift . count }+#define GO(T) instance (PersistQuery m) => PersistQuery (T m) where DEF(T)+#define GOX(X, T) instance (X, PersistQuery m) => PersistQuery (T m) where DEF(T)++GO(LoggingT)+GO(IdentityT)+GO(ListT)+GO(MaybeT)+GOX(Error e, ErrorT e)+GO(ReaderT r)+GO(ContT r)+GO(StateT s)+GO(ResourceT)+GO(Pipe l i o u)+GOX(Monoid w, WriterT w)+GOX(Monoid w, RWST r w s)+GOX(Monoid w, Strict.RWST r w s)+GO(Strict.StateT s)+GOX(Monoid w, Strict.WriterT w)++#undef DEF+#undef GO+#undef GOX++type family BackendSpecificFilter b v+ -- | Filters which are available for 'select', 'updateWhere' and -- 'deleteWhere'. Each filter constructor specifies the field being -- filtered on, the type of comparison applied (equals, not equals, etc)@@ -94,6 +147,7 @@ } | FilterAnd [Filter v] -- ^ convenient for internal use, not needed for the API | FilterOr [Filter v]+ | BackendFilter (BackendSpecificFilter (PersistEntityBackend v) v) data SelectOpt v = forall typ. Asc (EntityField v typ)@@ -102,18 +156,18 @@ | LimitTo Int -- | Call 'selectSource' but return the result as a list.-selectList :: (PersistEntity val, PersistQuery backend m, PersistEntityBackend val ~ backend)+selectList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m) => [Filter val] -> [SelectOpt val]- -> backend m [Entity val]-selectList a b = C.runResourceT $ selectSource a b C.$$ CL.consume+ -> m [Entity val]+selectList a b = selectSource a b C.$$ CL.consume -- | Call 'selectKeys' but return the result as a list.-selectKeysList :: (PersistEntity val, PersistQuery b m, PersistEntityBackend val ~ b)+selectKeysList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m) => [Filter val] -> [SelectOpt val]- -> b m [Key b val]-selectKeysList a b = C.runResourceT $ selectKeys a b C.$$ CL.consume+ -> m [Key val]+selectKeysList a b = selectKeys a b C.$$ CL.consume data PersistUpdate = Assign | Add | Subtract | Multiply | Divide -- FIXME need something else here deriving (Read, Show, Enum, Bounded)@@ -135,7 +189,6 @@ updateFieldDef :: PersistEntity v => Update v -> FieldDef updateFieldDef (Update f _ _) = persistFieldDef f -deleteCascadeWhere :: (DeleteCascade a backend m, PersistQuery backend m)- => [Filter a] -> backend m ()-deleteCascadeWhere filts = do- C.runResourceT $ selectKeys filts [] C.$$ CL.mapM_ (lift . deleteCascade)+deleteCascadeWhere :: (DeleteCascade a m, PersistQuery m)+ => [Filter a] -> m ()+deleteCascadeWhere filts = selectKeys filts [] C.$$ CL.mapM_ deleteCascade
Database/Persist/Query/Join.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} module Database.Persist.Query.Join ( -- * Typeclass RunJoin (..)@@ -16,25 +17,32 @@ import qualified Data.Map as Map import Data.List (foldl') -class PersistQuery backend m => RunJoin a backend m where+class PersistQuery m => RunJoin a m where type Result a- runJoin :: a -> backend m (Result a)+ runJoin :: a -> m (Result a) -data SelectOneMany backend one many = SelectOneMany+data SelectOneMany one many = SelectOneMany { somFilterOne :: [Filter one] , somOrderOne :: [SelectOpt one] , somFilterMany :: [Filter many] , somOrderMany :: [SelectOpt many]- , somFilterKeys :: [Key backend one] -> Filter many- , somGetKey :: many -> Key backend one+ , somFilterKeys :: [Key one] -> Filter many+ , somGetKey :: many -> Key one , somIncludeNoMatch :: Bool } -selectOneMany :: ([Key backend one] -> Filter many) -> (many -> Key backend one) -> SelectOneMany backend one many+selectOneMany :: ([Key one] -> Filter many) -> (many -> Key one) -> SelectOneMany one many selectOneMany filts get' = SelectOneMany [] [] [] [] filts get' False-instance (PersistEntity one, PersistEntity many, Ord (Key backend one), PersistQuery backend monad, backend ~ PersistEntityBackend one, backend ~ PersistEntityBackend many)- => RunJoin (SelectOneMany backend one many) backend monad where- type Result (SelectOneMany backend one many) =++instance ( PersistEntity one+ , PersistEntity many+ , Ord (Key one)+ , PersistQuery monad+ , PersistMonadBackend monad ~ PersistEntityBackend one+ , PersistEntityBackend one ~ PersistEntityBackend many+ )+ => RunJoin (SelectOneMany one many) monad where+ type Result (SelectOneMany one many) = [((Entity one), [(Entity many)])] runJoin (SelectOneMany oneF oneO manyF manyO eq getKey isOuter) = do x <- selectList oneF oneO
Database/Persist/Query/Join/Sql.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-} module Database.Persist.Query.Join.Sql ( RunJoin (..) ) where@@ -18,8 +19,7 @@ import Data.List (groupBy) import Database.Persist.GenericSql import Database.Persist.GenericSql.Internal hiding (withStmt)-import Database.Persist.GenericSql.Raw (withStmt)-import Control.Monad.Trans.Reader (ask)+import Database.Persist.GenericSql.Raw (withStmt, MonadSqlPersist, askSqlConn) import Data.Function (on) import Control.Arrow ((&&&)) import Data.Text (Text, concat, null)@@ -28,8 +28,6 @@ import qualified Data.Text as T import qualified Data.Conduit as C import qualified Data.Conduit.List as CL-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Logger (MonadLogger) fromPersistValuesId :: PersistEntity v => [PersistValue] -> Either Text (Entity v)@@ -41,13 +39,13 @@ fromPersistValuesId _ = Left "fromPersistValuesId: invalid ID" class RunJoin a where- runJoin :: (C.MonadThrow m, C.MonadUnsafeIO m, MonadIO m, MonadBaseControl IO m, MonadLogger m) => a -> SqlPersist m (J.Result a)+ runJoin :: (C.MonadResource m, MonadLogger m, MonadSqlPersist m) => a -> m (J.Result a) -instance (PersistEntity one, PersistEntity many, Eq (Key SqlPersist one))- => RunJoin (SelectOneMany SqlPersist one many) where+instance (PersistEntity one, PersistEntity many, Eq (Key one))+ => RunJoin (SelectOneMany one many) where runJoin (SelectOneMany oneF oneO manyF manyO eq _getKey isOuter) = do- conn <- SqlPersist ask- C.runResourceT $ liftM go $ withStmt (sql conn) (getFiltsValues conn oneF ++ getFiltsValues conn manyF) C.$$ loop id+ conn <- askSqlConn+ liftM go $ withStmt (sql conn) (getFiltsValues conn oneF ++ getFiltsValues conn manyF) C.$$ loop id where go :: [(Entity b, Maybe (Entity d))] -> [(Entity b, [Entity d])]@@ -137,6 +135,7 @@ filterName (Filter f _ _) = fieldDB $ persistFieldDef f filterName (FilterAnd _) = error "expected a raw filter, not an And" filterName (FilterOr _) = error "expected a raw filter, not an Or"+filterName (BackendFilter _) = error "expected a raw filter, not a BackendFilter" infixr 5 ++ (++) :: Monoid m => m -> m -> m
Database/Persist/Store.hs view
@@ -41,7 +41,8 @@ , checkUnique , DeleteCascade (..) , PersistException (..)- , Key (..)+ , KeyBackend (..)+ , Key , Entity (..) -- * Helpers@@ -103,9 +104,27 @@ import Data.Text.Lazy.Builder (toLazyText) import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Monad.Base (liftBase)-import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Monoid (Monoid) +import Data.Conduit (Pipe)+import Control.Monad.Logger (LoggingT)+import Control.Monad.Trans.Identity ( IdentityT)+import Control.Monad.Trans.List ( ListT )+import Control.Monad.Trans.Maybe ( MaybeT )+import Control.Monad.Trans.Error ( ErrorT )+import Control.Monad.Trans.Reader ( ReaderT )+import Control.Monad.Trans.Cont ( ContT )+import Control.Monad.Trans.State ( StateT )+import Control.Monad.Trans.Writer ( WriterT )+import Control.Monad.Trans.RWS ( RWST )+import Control.Monad.Trans.Resource ( ResourceT)++import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST )+import qualified Control.Monad.Trans.State.Strict as Strict ( StateT )+import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )+ data PersistException = PersistError T.Text -- ^ Generic Exception | PersistMarshalError T.Text@@ -406,6 +425,11 @@ sqlType _ = sqlType (error "this is the problem" :: a) isNullable _ = True +-- | Helper wrapper, equivalent to @Key (PersistEntityBackend val) val@.+--+-- Since 1.1.0+type Key val = KeyBackend (PersistEntityBackend val) val+ -- | A single database entity. For example, if writing a blog application, a -- blog entry would be an entry, containing fields such as title and content. class PersistEntity val where@@ -413,21 +437,21 @@ data EntityField val :: * -> * persistFieldDef :: EntityField val typ -> FieldDef - type PersistEntityBackend val :: ((* -> *) -> * -> *)+ type PersistEntityBackend val -- | Unique keys in existence on this entity.- data Unique val :: ((* -> *) -> * -> *) -> *+ data Unique val entityDef :: val -> EntityDef toPersistFields :: val -> [SomePersistField] fromPersistValues :: [PersistValue] -> Either T.Text val halfDefined :: val - persistUniqueToFieldNames :: Unique val backend -> [(HaskellName, DBName)]- persistUniqueToValues :: Unique val backend -> [PersistValue]- persistUniqueKeys :: val -> [Unique val backend]+ persistUniqueToFieldNames :: Unique val -> [(HaskellName, DBName)]+ persistUniqueToValues :: Unique val -> [PersistValue]+ persistUniqueKeys :: val -> [Unique val] - persistIdField :: EntityField val (Key (PersistEntityBackend val) val)+ persistIdField :: EntityField val (Key val) instance PersistField a => PersistField [a] where toPersistValue = PersistList . map toPersistValue@@ -495,13 +519,13 @@ fromPersistValue x = fmap SomePersistField (fromPersistValue x :: Either T.Text T.Text) sqlType (SomePersistField a) = sqlType a -newtype Key (backend :: (* -> *) -> * -> *) entity = Key { unKey :: PersistValue }+newtype KeyBackend backend entity = Key { unKey :: PersistValue } deriving (Show, Read, Eq, Ord, PersistField) -instance A.ToJSON (Key backend entity) where+instance A.ToJSON (KeyBackend backend entity) where toJSON (Key val) = A.toJSON val -instance A.FromJSON (Key backend entity) where+instance A.FromJSON (KeyBackend backend entity) where parseJSON = fmap Key . A.parseJSON -- | Datatype that represents an entity, with both its key and@@ -535,59 +559,113 @@ -- Entity backend b)@), then you must you use @SELECT ??, ?? -- WHERE ...@, and so on. data Entity entity =- Entity { entityKey :: Key (PersistEntityBackend entity) entity+ Entity { entityKey :: Key entity , entityVal :: entity } deriving (Eq, Ord, Show, Read) -class (MonadBaseControl IO m, MonadBaseControl IO (backend m)) => PersistStore backend m where+class MonadIO m => PersistStore m where+ type PersistMonadBackend m -- | Create a new record in the database, returning an automatically created -- key (in SQL an auto-increment id).- insert :: PersistEntity val => val -> backend m (Key backend val)+ insert :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)+ => val -> m (Key val) -- | Create a new record in the database using the given key.- insertKey :: PersistEntity val => Key backend val -> val -> backend m ()+ insertKey :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)+ => Key val -> val -> m () -- | Put the record in the database with the given key. -- Unlike 'replace', if a record with the given key does not -- exist then a new record will be inserted.- repsert :: PersistEntity val => Key backend val -> val -> backend m ()+ repsert :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)+ => Key val -> val -> m () -- | Replace the record in the database with the given -- key. Note that the result is undefined if such record does- -- not exist, so you must use 'insertKey' or 'repsert' in+ -- not exist, so you must use 'insertKey or 'repsert' in -- these cases.- replace :: PersistEntity val => Key backend val -> val -> backend m ()+ replace :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)+ => Key val -> val -> m () -- | Delete a specific record by identifier. Does nothing if record does -- not exist.- delete :: PersistEntity val => Key backend val -> backend m ()+ delete :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)+ => Key val -> m () -- | Get a record by identifier, if available.- get :: PersistEntity val => Key backend val -> backend m (Maybe val)+ get :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)+ => Key val -> m (Maybe val) -class PersistStore backend m => PersistUnique backend m where+#define DEF(T) { type PersistMonadBackend (T m) = PersistMonadBackend m; insert = lift . insert; insertKey k = lift . insertKey k; repsert k = lift . repsert k; replace k = lift . replace k; delete = lift . delete; get = lift . get }+#define GO(T) instance (PersistStore m) => PersistStore (T m) where DEF(T)+#define GOX(X, T) instance (X, PersistStore m) => PersistStore (T m) where DEF(T)++GO(LoggingT)+GO(IdentityT)+GO(ListT)+GO(MaybeT)+GOX(Error e, ErrorT e)+GO(ReaderT r)+GO(ContT r)+GO(StateT s)+GO(ResourceT)+GO(Pipe l i o u)+GOX(Monoid w, WriterT w)+GOX(Monoid w, RWST r w s)+GOX(Monoid w, Strict.RWST r w s)+GO(Strict.StateT s)+GOX(Monoid w, Strict.WriterT w)++#undef DEF+#undef GO+#undef GOX++class PersistStore m => PersistUnique m where -- | Get a record by unique key, if available. Returns also the identifier.- getBy :: (PersistEntityBackend val ~ backend, PersistEntity val) => Unique val backend -> backend m (Maybe (Entity val))+ getBy :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => Unique val -> m (Maybe (Entity val)) -- | Delete a specific record by unique key. Does nothing if no record -- matches.- deleteBy :: PersistEntity val => Unique val backend -> backend m ()+ deleteBy :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => Unique val -> m () -- | Like 'insert', but returns 'Nothing' when the record -- couldn't be inserted because of a uniqueness constraint.- insertUnique :: (backend ~ PersistEntityBackend val, PersistEntity val) => val -> backend m (Maybe (Key backend val))+ insertUnique :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => val -> m (Maybe (Key val)) insertUnique datum = do isUnique <- checkUnique datum if isUnique then Just `liftM` insert datum else return Nothing +#define DEF(T) { getBy = lift . getBy; deleteBy = lift . deleteBy; insertUnique = lift . insertUnique }+#define GO(T) instance (PersistUnique m) => PersistUnique (T m) where DEF(T)+#define GOX(X, T) instance (X, PersistUnique m) => PersistUnique (T m) where DEF(T) +GO(LoggingT)+GO(IdentityT)+GO(ListT)+GO(MaybeT)+GOX(Error e, ErrorT e)+GO(ReaderT r)+GO(ContT r)+GO(StateT s)+GO(ResourceT)+GO(Pipe l i o u)+GOX(Monoid w, WriterT w)+GOX(Monoid w, RWST r w s)+GOX(Monoid w, Strict.RWST r w s)+GO(Strict.StateT s)+GOX(Monoid w, Strict.WriterT w) +#undef DEF+#undef GO+#undef GOX++ -- | Insert a value, checking for conflicts with any unique constraints. If a -- duplicate exists in the database, it is returned as 'Left'. Otherwise, the--- new 'Key' is returned as 'Right'.-insertBy :: (PersistEntity v, PersistStore backend m, PersistUnique backend m, backend ~ PersistEntityBackend v)- => v -> backend m (Either (Entity v) (Key backend v))+-- new 'Key is returned as 'Right'.+insertBy :: (PersistEntity v, PersistStore m, PersistUnique m, PersistMonadBackend m ~ PersistEntityBackend v)+ => v -> m (Either (Entity v) (Key v)) insertBy val = go $ persistUniqueKeys val where@@ -602,8 +680,8 @@ -- of a 'Unique' value. Returns a value matching /one/ of the unique keys. This -- function makes the most sense on entities with a single 'Unique' -- constructor.-getByValue :: (PersistEntity v, PersistUnique backend m, PersistEntityBackend v ~ backend)- => v -> backend m (Maybe (Entity v))+getByValue :: (PersistEntity v, PersistUnique m, PersistEntityBackend v ~ PersistMonadBackend m)+ => v -> m (Maybe (Entity v)) getByValue val = go $ persistUniqueKeys val where@@ -617,25 +695,29 @@ -- | curry this to make a convenience function that loads an associated model -- > foreign = belongsTo foeignId belongsTo ::- (PersistStore backend m+ (PersistStore m , PersistEntity ent1- , PersistEntity ent2) => (ent1 -> Maybe (Key backend ent2)) -> ent1 -> backend m (Maybe ent2)+ , PersistEntity ent2+ , PersistMonadBackend m ~ PersistEntityBackend ent2+ ) => (ent1 -> Maybe (Key ent2)) -> ent1 -> m (Maybe ent2) belongsTo foreignKeyField model = case foreignKeyField model of Nothing -> return Nothing Just f -> get f -- | same as belongsTo, but uses @getJust@ and therefore is similarly unsafe belongsToJust ::- (PersistStore backend m+ (PersistStore m , PersistEntity ent1- , PersistEntity ent2) => (ent1 -> Key backend ent2) -> ent1 -> backend m ent2+ , PersistEntity ent2+ , PersistMonadBackend m ~ PersistEntityBackend ent2)+ => (ent1 -> Key ent2) -> ent1 -> m ent2 belongsToJust getForeignKey model = getJust $ getForeignKey model -- | Same as get, but for a non-null (not Maybe) foreign key -- Unsafe unless your database is enforcing that the foreign key is valid-getJust :: (PersistStore backend m, PersistEntity val, Show (Key backend val)) => Key backend val -> backend m val+getJust :: (PersistStore m, PersistEntity val, Show (Key val), PersistMonadBackend m ~ PersistEntityBackend val) => Key val -> m val getJust key = get key >>= maybe- (liftBase $ E.throwIO $ PersistForeignConstraintUnmet $ show key)+ (liftIO $ E.throwIO $ PersistForeignConstraintUnmet $ show key) return @@ -644,7 +726,7 @@ -- -- Returns 'True' if the entity would be unique, and could thus safely be -- 'insert'ed; returns 'False' on a conflict.-checkUnique :: (PersistEntityBackend val ~ backend, PersistEntity val, PersistUnique backend m) => val -> backend m Bool+checkUnique :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val, PersistUnique m) => val -> m Bool checkUnique val = go $ persistUniqueKeys val where@@ -659,8 +741,8 @@ | BackendSpecificFilter T.Text deriving (Read, Show) -class PersistEntity a => DeleteCascade a backend m where- deleteCascade :: Key backend a -> backend m ()+class (PersistStore m, PersistEntity a, PersistEntityBackend a ~ PersistMonadBackend m) => DeleteCascade a m where+ deleteCascade :: Key a -> m () instance PersistField PersistValue where toPersistValue = id
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 1.0.2.2+version: 1.1.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -32,14 +32,14 @@ , time >= 1.1.4 , text >= 0.8 , containers >= 0.2- , conduit >= 0.5 && < 0.6- , resourcet >= 0.3 && < 0.5+ , conduit >= 0.5.5 && < 0.6+ , resourcet >= 0.4 && < 0.5 , monad-control >= 0.3 && < 0.4 , lifted-base >= 0.1- , pool-conduit >= 0.1 && < 0.2+ , pool-conduit >= 0.1.1 && < 0.2 , path-pieces >= 0.1 && < 0.2 , aeson >= 0.5 && < 0.7- , monad-logger >= 0.2.1 && < 0.3+ , monad-logger >= 0.2.3 && < 0.3 , transformers-base , base64-bytestring , unordered-containers