packages feed

persistent 1.2.1.2 → 1.2.2.0

raw patch · 7 files changed

+172/−122 lines, 7 filesdep ~base

Dependency ranges changed: base

Files

Database/Persist.hs view
@@ -5,18 +5,6 @@     ( module Database.Persist.Class     , module Database.Persist.Types -      -- * Store functions-    , insertBy-    , getJust-    , belongsTo-    , belongsToJust-    , getByValue--      -- * Query functions-    , selectList-    , selectKeysList-    , deleteCascadeWhere-       -- * query combinators     , (=.), (+=.), (-=.), (*=.), (/=.)     , (==.), (!=.), (<.), (>.), (<=.), (>=.)@@ -36,75 +24,11 @@ import Database.Persist.Class import Database.Persist.Class.PersistField (getPersistMap) import qualified Data.Text as T-import qualified Control.Exception as E-import Control.Monad (liftM)-import Control.Monad.IO.Class (MonadIO, liftIO)-import qualified Data.Conduit as C-import qualified Data.Conduit.List as CL import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder (toLazyText) import Data.Aeson (toJSON) import Data.Aeson.Encode (fromValue) --- | 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 m, PersistUnique m, PersistMonadBackend m ~ PersistEntityBackend v)-          => v -> m (Either (Entity v) (Key v))-insertBy val =-    go $ persistUniqueKeys val-  where-    go [] = Right `liftM` insert val-    go (x:xs) = do-        y <- getBy x-        case y of-            Nothing -> go xs-            Just z -> return $ Left z---- | A modification of 'getBy', which takes the 'PersistEntity' itself instead--- 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 m, PersistEntityBackend v ~ PersistMonadBackend m)-           => v -> m (Maybe (Entity v))-getByValue val =-    go $ persistUniqueKeys val-  where-    go [] = return Nothing-    go (x:xs) = do-        y <- getBy x-        case y of-            Nothing -> go xs-            Just z -> return $ Just z---- | curry this to make a convenience function that loads an associated model---   > foreign = belongsTo foeignId-belongsTo ::-  (PersistStore m-  , PersistEntity ent1-  , 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 m-  , PersistEntity ent1-  , 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 m, PersistEntity val, Show (Key val), PersistMonadBackend m ~ PersistEntityBackend val) => Key val -> m val-getJust key = get key >>= maybe-  (liftIO $ E.throwIO $ PersistForeignConstraintUnmet $ T.pack $ show key)-  return- infixr 3 =., +=., -=., *=., /=. (=.), (+=.), (-=.), (*=.), (/=.) :: forall v typ.  PersistField typ => EntityField v typ -> typ -> Update v -- | assign a field a value@@ -139,24 +63,6 @@ (||.) :: forall v. [Filter v] -> [Filter v] -> [Filter v] -- | the OR of two lists of filters a ||. b = [FilterOr  [FilterAnd a, FilterAnd b]]---- | Call 'selectSource' but return the result as a list.-selectList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m)-           => [Filter val]-           -> [SelectOpt val]-           -> 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 m, PersistEntityBackend val ~ PersistMonadBackend m)-               => [Filter val]-               -> [SelectOpt val]-               -> m [Key val]-selectKeysList a b = selectKeys a b C.$$ CL.consume--deleteCascadeWhere :: (DeleteCascade a m, PersistQuery m)-                   => [Filter a] -> m ()-deleteCascadeWhere filts = selectKeys filts [] C.$$ CL.mapM_ deleteCascade  listToJSON :: [PersistValue] -> T.Text listToJSON = toStrict . toLazyText . fromValue . toJSON
Database/Persist/Class.hs view
@@ -1,11 +1,33 @@ module Database.Persist.Class-    ( DeleteCascade (..)-    , PersistEntity (..)-    , PersistQuery (..)+    (+    -- * PersistStore+      PersistStore (..)+    , getJust+    , belongsTo+    , belongsToJust++    -- * PersistUnique     , PersistUnique (..)-    , PersistConfig (..)+    , getByValue+    , insertBy+    , replaceUnique++    -- * PersistQuery+    , PersistQuery (..)+    , selectList+    , selectKeysList++    -- * DeleteCascade+    , DeleteCascade (..)+    , deleteCascadeWhere++    -- * PersistEntity+    , PersistEntity (..)+    -- * PersistField     , PersistField (..)-    , PersistStore (..)+    -- * PersistConfig+    , PersistConfig (..)+     ) where  import Database.Persist.Class.DeleteCascade
Database/Persist/Class/DeleteCascade.hs view
@@ -2,10 +2,19 @@ {-# LANGUAGE TypeFamilies #-} module Database.Persist.Class.DeleteCascade     ( DeleteCascade (..)+    , deleteCascadeWhere     ) where  import Database.Persist.Class.PersistStore+import Database.Persist.Class.PersistQuery import Database.Persist.Class.PersistEntity +import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+ class (PersistStore m, PersistEntity a, PersistEntityBackend a ~ PersistMonadBackend m) => DeleteCascade a m where     deleteCascade :: Key a -> m ()++deleteCascadeWhere :: (DeleteCascade a m, PersistQuery m)+                   => [Filter a] -> m ()+deleteCascadeWhere filts = selectKeys filts [] C.$$ CL.mapM_ deleteCascade
Database/Persist/Class/PersistQuery.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE TypeFamilies #-} module Database.Persist.Class.PersistQuery     ( PersistQuery (..)+    , selectList+    , selectKeysList     ) where  import Control.Exception (throwIO)@@ -83,6 +85,21 @@     -- | The total number of records fulfilling the given criterion.     count :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)           => [Filter val] -> m Int++-- | Call 'selectSource' but return the result as a list.+selectList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m)+           => [Filter val]+           -> [SelectOpt val]+           -> 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 m, PersistEntityBackend val ~ PersistMonadBackend m)+               => [Filter val]+               -> [SelectOpt val]+               -> m [Key val]+selectKeysList a b = selectKeys a b C.$$ CL.consume+  #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)
Database/Persist/Class/PersistStore.hs view
@@ -1,16 +1,22 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies, FlexibleContexts #-} module Database.Persist.Class.PersistStore     ( PersistStore (..)+    , getJust+    , belongsTo+    , belongsToJust     ) where  import qualified Prelude import Prelude hiding ((++), show) +import qualified Data.Text as T+ import Control.Monad.Trans.Error (Error (..)) import Control.Monad.Trans.Class (lift)-import Control.Monad.IO.Class (MonadIO)+import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Monoid (Monoid)+import Control.Exception.Lifted (throwIO)  import Data.Conduit.Internal (Pipe, ConduitM) import Control.Monad.Logger (LoggingT)@@ -30,6 +36,7 @@ import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )  import Database.Persist.Class.PersistEntity+import Database.Persist.Types  class MonadIO m => PersistStore m where     type PersistMonadBackend m@@ -76,6 +83,34 @@     -- not exist.     delete :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)            => Key val -> m ()++-- | 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 m, PersistEntity val, Show (Key val), PersistMonadBackend m ~ PersistEntityBackend val) => Key val -> m val+getJust key = get key >>= maybe+  (liftIO $ throwIO $ PersistForeignConstraintUnmet $ T.pack $ Prelude.show key)+  return++-- | curry this to make a convenience function that loads an associated model+--   > foreign = belongsTo foeignId+belongsTo ::+  (PersistStore m+  , PersistEntity ent1+  , 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 m+  , PersistEntity ent1+  , PersistEntity ent2+  , PersistMonadBackend m ~ PersistEntityBackend ent2)+  => (ent1 -> Key ent2) -> ent1 -> m ent2+belongsToJust getForeignKey model = getJust $ getForeignKey model  #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)
Database/Persist/Class/PersistUnique.hs view
@@ -1,7 +1,10 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies, FlexibleContexts #-} module Database.Persist.Class.PersistUnique     ( PersistUnique (..)+    , getByValue+    , insertBy+    , replaceUnique     ) where  import qualified Prelude@@ -11,6 +14,7 @@ import Control.Monad.Trans.Error (Error (..)) import Control.Monad.Trans.Class (lift) import Data.Monoid (Monoid)+import Data.List ((\\))  import Data.Conduit.Internal (Pipe) import Control.Monad.Logger (LoggingT)@@ -35,7 +39,12 @@ -- -- Please read the general Persistent documentation to learn how to create -- Unique keys.--- SQL backends automatically create uniqueness constraints, but for MongoDB you must place a unique index on the field.+-- SQL backends automatically create uniqueness constraints, but for MongoDB you must manually place a unique index on the field.+--+-- Some functions in this module (insertUnique, insertBy, and replaceUnique) first query the unique indexes to check for conflicts.+-- You could instead optimistically attempt to perform the operation (e.g. replace instead of replaceUnique). However,+-- * there is some fragility to tryting to catch the correct exception and determing the column of failure.+-- * an exception will automatically abort the current SQL transaction class PersistStore m => PersistUnique m where     -- | Get a record by unique key, if available. Returns also the identifier.     getBy :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => Unique val -> m (Maybe (Entity val))@@ -48,9 +57,77 @@     -- couldn't be inserted because of a uniqueness constraint.     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+        conflict <- checkUnique datum+        case conflict of+          Nothing -> Just `liftM` insert datum+          Just _ -> return Nothing +-- | 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 val, PersistUnique m, PersistEntityBackend val ~ PersistMonadBackend m)+         => val -> m (Either (Entity val) (Key val))++insertBy val = do+    res <- getByValue val+    case res of+      Nothing -> Right `liftM` insert val+      Just z -> return $ Left z++-- | A modification of 'getBy', which takes the 'PersistEntity' itself instead+-- 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 value, PersistUnique m, PersistEntityBackend value ~ PersistMonadBackend m)+           => value -> m (Maybe (Entity value))+getByValue = checkUniques . persistUniqueKeys+  where+    checkUniques [] = return Nothing+    checkUniques (x:xs) = do+        y <- getBy x+        case y of+            Nothing -> checkUniques xs+            Just z -> return $ Just z+++-- | attempt to replace the record of the given key with the given new record+-- First query the unique fields to make sure the replacement maintains uniqueness constraints+-- Return Nothing if the replacement was made.+-- If uniqueness is violated, Return a Just with the Unque violation+--+-- Since 1.2.2.0+replaceUnique :: (Eq record, Eq (Unique record), PersistEntityBackend record ~ PersistMonadBackend m, PersistEntity record, PersistStore m, PersistUnique m)+              => Key record -> record -> m (Maybe (Unique record))+replaceUnique key datumNew = getJust key >>= replaceOriginal+  where+    uniqueKeysNew = persistUniqueKeys datumNew+    replaceOriginal original = do+        conflict <- checkUniqueKeys changedKeys+        case conflict of+          Nothing -> replace key datumNew >> return Nothing+          (Just conflictingKey) -> return $ Just conflictingKey+      where+        changedKeys = uniqueKeysOriginal \\ uniqueKeysNew+        uniqueKeysOriginal = persistUniqueKeys original++-- | Check whether there are any conflicts for unique keys with this entity and+-- existing entities in the database.+--+-- Returns 'Nothing' if the entity would be unique, and could thus safely be inserted.+-- on a conflict returns the conflicting key+checkUnique :: (PersistEntityBackend record ~ PersistMonadBackend m, PersistEntity record, PersistUnique m)+            => record -> m (Maybe (Unique record))+checkUnique = checkUniqueKeys . persistUniqueKeys++checkUniqueKeys :: (PersistEntity record, PersistUnique m, PersistEntityBackend record ~ PersistMonadBackend m)+                => [Unique record] -> m (Maybe (Unique record))+checkUniqueKeys [] = return Nothing+checkUniqueKeys (x:xs) = do+    y <- getBy x+    case y of+        Nothing -> checkUniqueKeys xs+        Just _ -> return (Just x)+ #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)@@ -74,19 +151,3 @@ #undef DEF #undef GO #undef GOX---- | Check whether there are any conflicts for unique keys with this entity and--- existing entities in the database.------ Returns 'True' if the entity would be unique, and could thus safely be--- 'insert'ed; returns 'False' on a conflict.-checkUnique :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val, PersistUnique m) => val -> m Bool-checkUnique val =-    go $ persistUniqueKeys val-  where-    go [] = return True-    go (x:xs) = do-        y <- getBy x-        case y of-            Nothing -> go xs-            Just _ -> return False
persistent.cabal view
@@ -1,5 +1,5 @@ name:            persistent-version:         1.2.1.2+version:         1.2.2.0 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>