persistent 2.2.4.1 → 2.5
raw patch · 15 files changed
+492/−238 lines, 15 files
Files
- ChangeLog.md +6/−0
- Database/Persist/Class.hs +28/−3
- Database/Persist/Class/DeleteCascade.hs +2/−2
- Database/Persist/Class/PersistQuery.hs +46/−41
- Database/Persist/Class/PersistStore.hs +77/−49
- Database/Persist/Class/PersistUnique.hs +35/−21
- Database/Persist/Sql/Class.hs +13/−8
- Database/Persist/Sql/Orphan/PersistQuery.hs +21/−11
- Database/Persist/Sql/Orphan/PersistStore.hs +46/−24
- Database/Persist/Sql/Orphan/PersistUnique.hs +13/−3
- Database/Persist/Sql/Raw.hs +14/−9
- Database/Persist/Sql/Run.hs +39/−24
- Database/Persist/Sql/Types.hs +10/−42
- Database/Persist/Sql/Types/Internal.hs +140/−0
- persistent.cabal +2/−1
ChangeLog.md view
@@ -1,3 +1,8 @@+## 2.5++* read/write typeclass split+* add insertOrGet convenience function to PersistUnique+ ## 2.2.4.1 * Documentation updates [#515](https://github.com/yesodweb/persistent/pull/515)@@ -14,6 +19,7 @@ ## 2.2.2 * Add liftSqlPersistMPool function+* support http-api-data for url serialization ## 2.2.1
Database/Persist/Class.hs view
@@ -1,15 +1,24 @@+{-# LANGUAGE ConstraintKinds #-}+ module Database.Persist.Class ( ToBackendKey (..) -- * PersistStore- , PersistStore (..)+ , PersistCore (..)+ , PersistStore+ , PersistStoreRead (..)+ , PersistStoreWrite (..)+ , BaseBackend(..)+ , PersistRecordBackend , getJust , belongsTo , belongsToJust , insertEntity -- * PersistUnique- , PersistUnique (..)+ , PersistUnique+ , PersistUniqueRead (..)+ , PersistUniqueWrite (..) , getByValue , insertBy , replaceUnique@@ -17,7 +26,9 @@ , onlyUnique -- * PersistQuery- , PersistQuery (..)+ , PersistQuery+ , PersistQueryRead (..)+ , PersistQueryWrite (..) , selectSource , selectKeys , selectList@@ -37,6 +48,7 @@ -- * Lifting , HasPersistBackend (..)+ , IsPersistBackend () , liftPersist -- * JSON utilities@@ -52,3 +64,16 @@ import Database.Persist.Class.PersistConfig import Database.Persist.Class.PersistField import Database.Persist.Class.PersistStore+++-- | A backwards-compatible alias for those that don't care about distinguishing between read and write queries.+-- It signifies the assumption that, by default, a backend can write as well as read.+type PersistUnique a = PersistUniqueWrite a++-- | A backwards-compatible alias for those that don't care about distinguishing between read and write queries.+-- It signifies the assumption that, by default, a backend can write as well as read.+type PersistQuery a = PersistQueryWrite a++-- | A backwards-compatible alias for those that don't care about distinguishing between read and write queries.+-- It signifies the assumption that, by default, a backend can write as well as read.+type PersistStore a = PersistStoreWrite a
Database/Persist/Class/DeleteCascade.hs view
@@ -18,7 +18,7 @@ -- | For combinations of backends and entities that support -- cascade-deletion. “Cascade-deletion” means that entries that depend on -- other entries to be deleted will be deleted as well.-class (PersistStore backend, PersistEntity record, backend ~ PersistEntityBackend record)+class (PersistStoreWrite backend, PersistEntity record, BaseBackend backend ~ PersistEntityBackend record) => DeleteCascade record backend where -- | Perform cascade-deletion of single database@@ -26,7 +26,7 @@ deleteCascade :: MonadIO m => Key record -> ReaderT backend m () -- | Cascade-deletion of entries satisfying given filters.-deleteCascadeWhere :: (MonadIO m, DeleteCascade record backend, PersistQuery backend)+deleteCascadeWhere :: (MonadIO m, DeleteCascade record backend, PersistQueryWrite backend) => [Filter record] -> ReaderT backend m () deleteCascadeWhere filts = do srcRes <- selectKeysRes filts []
Database/Persist/Class/PersistQuery.hs view
@@ -1,7 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-} module Database.Persist.Class.PersistQuery- ( PersistQuery (..)+ ( PersistQueryRead (..)+ , PersistQueryWrite (..) , selectSource , selectKeys , selectList@@ -19,51 +22,53 @@ import Control.Monad.Trans.Resource (MonadResource, release) import Data.Acquire (Acquire, allocateAcquire, with) --- | Backends supporting conditional operations.-class PersistStore backend => PersistQuery backend where- -- | Update individual fields on any record matching the given criterion.- updateWhere :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val)- => [Filter val] -> [Update val] -> ReaderT backend m ()-- -- | Delete all records matching the given criterion.- deleteWhere :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val)- => [Filter val] -> ReaderT backend m ()-+-- | Backends supporting conditional read operations.+class (PersistCore backend, PersistStoreRead backend) => PersistQueryRead backend where -- | Get all records matching the given criterion in the specified order. -- Returns also the identifiers. selectSourceRes- :: (PersistEntity val, PersistEntityBackend val ~ backend, MonadIO m1, MonadIO m2)- => [Filter val]- -> [SelectOpt val]- -> ReaderT backend m1 (Acquire (C.Source m2 (Entity val)))+ :: (PersistRecordBackend record backend, MonadIO m1, MonadIO m2)+ => [Filter record]+ -> [SelectOpt record]+ -> ReaderT backend m1 (Acquire (C.Source m2 (Entity record))) -- | Get just the first record for the criterion.- selectFirst :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val)- => [Filter val]- -> [SelectOpt val]- -> ReaderT backend m (Maybe (Entity val))+ selectFirst :: (MonadIO m, PersistRecordBackend record backend)+ => [Filter record]+ -> [SelectOpt record]+ -> ReaderT backend m (Maybe (Entity record)) selectFirst filts opts = do srcRes <- selectSourceRes filts (LimitTo 1 : opts) liftIO $ with srcRes (C.$$ CL.head) -- | Get the 'Key's of all records matching the given criterion. selectKeysRes- :: (MonadIO m1, MonadIO m2, PersistEntity val, backend ~ PersistEntityBackend val)- => [Filter val]- -> [SelectOpt val]- -> ReaderT backend m1 (Acquire (C.Source m2 (Key val)))+ :: (MonadIO m1, MonadIO m2, PersistRecordBackend record backend)+ => [Filter record]+ -> [SelectOpt record]+ -> ReaderT backend m1 (Acquire (C.Source m2 (Key record))) -- | The total number of records fulfilling the given criterion.- count :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val)- => [Filter val] -> ReaderT backend m Int+ count :: (MonadIO m, PersistRecordBackend record backend)+ => [Filter record] -> ReaderT backend m Int +-- | Backends supporting conditional write operations+class (PersistQueryRead backend, PersistStoreWrite backend) => PersistQueryWrite backend where+ -- | Update individual fields on any record matching the given criterion.+ updateWhere :: (MonadIO m, PersistRecordBackend record backend)+ => [Filter record] -> [Update record] -> ReaderT backend m ()++ -- | Delete all records matching the given criterion.+ deleteWhere :: (MonadIO m, PersistRecordBackend record backend)+ => [Filter record] -> ReaderT backend m ()+ -- | Get all records matching the given criterion in the specified order. -- Returns also the identifiers. selectSource- :: (PersistQuery backend, MonadResource m, PersistEntity val, PersistEntityBackend val ~ backend, MonadReader env m, HasPersistBackend env backend)- => [Filter val]- -> [SelectOpt val]- -> C.Source m (Entity val)+ :: (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) selectSource filts opts = do srcRes <- liftPersist $ selectSourceRes filts opts (releaseKey, src) <- allocateAcquire srcRes@@ -71,10 +76,10 @@ release releaseKey -- | Get the 'Key's of all records matching the given criterion.-selectKeys :: (PersistQuery backend, MonadResource m, PersistEntity val, backend ~ PersistEntityBackend val, MonadReader env m, HasPersistBackend env backend)- => [Filter val]- -> [SelectOpt val]- -> C.Source m (Key val)+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) selectKeys filts opts = do srcRes <- liftPersist $ selectKeysRes filts opts (releaseKey, src) <- allocateAcquire srcRes@@ -82,19 +87,19 @@ release releaseKey -- | Call 'selectSource' but return the result as a list.-selectList :: (MonadIO m, PersistEntity val, PersistQuery backend, PersistEntityBackend val ~ backend)- => [Filter val]- -> [SelectOpt val]- -> ReaderT backend m [Entity val]+selectList :: (MonadIO m, PersistQueryRead backend, PersistRecordBackend record backend)+ => [Filter record]+ -> [SelectOpt record]+ -> ReaderT backend m [Entity record] selectList filts opts = do srcRes <- selectSourceRes filts opts liftIO $ with srcRes (C.$$ CL.consume) -- | Call 'selectKeys' but return the result as a list.-selectKeysList :: (MonadIO m, PersistEntity val, PersistQuery backend, PersistEntityBackend val ~ backend)- => [Filter val]- -> [SelectOpt val]- -> ReaderT backend m [Key val]+selectKeysList :: (MonadIO m, PersistQueryRead backend, PersistRecordBackend record backend)+ => [Filter record]+ -> [SelectOpt record]+ -> ReaderT backend m [Key record] selectKeysList filts opts = do srcRes <- selectKeysRes filts opts liftIO $ with srcRes (C.$$ CL.consume)
Database/Persist/Class/PersistStore.hs view
@@ -1,10 +1,15 @@ {-# LANGUAGE TypeFamilies, FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ConstraintKinds #-} module Database.Persist.Class.PersistStore ( HasPersistBackend (..)+ , IsPersistBackend (..)+ , PersistRecordBackend , liftPersist- , PersistStore (..)+ , PersistCore (..)+ , PersistStoreRead (..)+ , PersistStoreWrite (..) , getJust , belongsTo , belongsToJust@@ -22,12 +27,30 @@ import Database.Persist.Types import qualified Data.Aeson as A -class HasPersistBackend env backend | env -> backend where- persistBackend :: env -> backend+-- | Class which allows the plucking of a @BaseBackend backend@ from some larger type.+-- For example,+-- @+-- instance HasPersistBackend (SqlReadBackend, Int) where+-- type BaseBackend (SqlReadBackend, Int) = SqlBackend+-- persistBackend = unSqlReadBackend . fst+-- @+class HasPersistBackend backend where+ type BaseBackend backend+ persistBackend :: backend -> BaseBackend backend+-- | Class which witnesses that @backend@ is essentially the same as @BaseBackend backend@.+-- That is, they're isomorphic and @backend@ is just some wrapper over @BaseBackend backend@.+class (HasPersistBackend backend) => IsPersistBackend backend where+ -- | This function is how we actually construct and tag a backend as having read or write capabilities.+ -- It should be used carefully and only when actually constructing a @backend@. Careless use allows us+ -- to accidentally run a write query against a read-only database.+ mkPersistBackend :: BaseBackend backend -> backend -liftPersist :: (MonadReader env m, HasPersistBackend env backend, MonadIO m)- => ReaderT backend IO a- -> m a+-- | A convenient alias for common type signatures+type PersistRecordBackend record backend = (PersistEntity record, PersistEntityBackend record ~ BaseBackend backend)++liftPersist+ :: (MonadIO m, MonadReader backend m, HasPersistBackend backend)+ => ReaderT (BaseBackend backend) IO b -> m b liftPersist f = do env <- ask liftIO $ runReaderT f (persistBackend env)@@ -43,31 +66,40 @@ -- 'ToBackendKey'. class ( PersistEntity record , PersistEntityBackend record ~ backend- , PersistStore backend+ , PersistCore backend ) => ToBackendKey backend record where toBackendKey :: Key record -> BackendKey backend fromBackendKey :: BackendKey backend -> Key record +class PersistCore backend where+ data BackendKey backend+ class ( Show (BackendKey backend), Read (BackendKey backend) , Eq (BackendKey backend), Ord (BackendKey backend)+ , PersistCore backend , PersistField (BackendKey backend), A.ToJSON (BackendKey backend), A.FromJSON (BackendKey backend)- ) => PersistStore backend where- data BackendKey backend-+ ) => PersistStoreRead backend where -- | Get a record by identifier, if available.- get :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val)- => Key val -> ReaderT backend m (Maybe val)+ get :: (MonadIO m, PersistRecordBackend record backend)+ => Key record -> ReaderT backend m (Maybe record) +class+ ( Show (BackendKey backend), Read (BackendKey backend)+ , Eq (BackendKey backend), Ord (BackendKey backend)+ , PersistStoreRead backend+ , PersistField (BackendKey backend), A.ToJSON (BackendKey backend), A.FromJSON (BackendKey backend)+ ) => PersistStoreWrite backend where+ -- | Create a new record in the database, returning an automatically created -- key (in SQL an auto-increment id).- insert :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val)- => val -> ReaderT backend m (Key val)+ insert :: (MonadIO m, PersistRecordBackend record backend)+ => record -> ReaderT backend m (Key record) -- | Same as 'insert', but doesn't return a @Key@.- insert_ :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val)- => val -> ReaderT backend m ()- insert_ val = insert val >> return ()+ insert_ :: (MonadIO m, PersistRecordBackend record backend)+ => record -> ReaderT backend m ()+ insert_ record = insert record >> return () -- | Create multiple records in the database and return their 'Key's. --@@ -78,16 +110,16 @@ -- -- The SQLite and MySQL backends use the slow, default implementation of -- @mapM insert@.- insertMany :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val)- => [val] -> ReaderT backend m [Key val]+ insertMany :: (MonadIO m, PersistRecordBackend record backend)+ => [record] -> ReaderT backend m [Key record] insertMany = mapM insert -- | Same as 'insertMany', but doesn't return any 'Key's. -- -- The MongoDB, PostgreSQL, SQLite and MySQL backends insert all records in -- one database query.- insertMany_ :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val)- => [val] -> ReaderT backend m ()+ insertMany_ :: (MonadIO m, PersistRecordBackend record backend)+ => [record] -> ReaderT backend m () insertMany_ x = insertMany x >> return () -- | Same as 'insertMany_', but takes an 'Entity' instead of just a record.@@ -99,43 +131,43 @@ -- -- The SQL backends use the slow, default implementation of -- @mapM_ insertKey@.- insertEntityMany :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val)- => [Entity val] -> ReaderT backend m ()+ insertEntityMany :: (MonadIO m, PersistRecordBackend record backend)+ => [Entity record] -> ReaderT backend m () insertEntityMany = mapM_ (\(Entity k record) -> insertKey k record) -- | Create a new record in the database using the given key.- insertKey :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val)- => Key val -> val -> ReaderT backend m ()+ insertKey :: (MonadIO m, PersistRecordBackend record backend)+ => Key record -> record -> ReaderT backend 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 :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val)- => Key val -> val -> ReaderT backend m ()+ repsert :: (MonadIO m, PersistRecordBackend record backend)+ => Key record -> record -> ReaderT backend 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 -- these cases.- replace :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val)- => Key val -> val -> ReaderT backend m ()+ replace :: (MonadIO m, PersistRecordBackend record backend)+ => Key record -> record -> ReaderT backend m () -- | Delete a specific record by identifier. Does nothing if record does -- not exist.- delete :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val)- => Key val -> ReaderT backend m ()+ delete :: (MonadIO m, PersistRecordBackend record backend)+ => Key record -> ReaderT backend m () -- | Update individual fields on a specific record.- update :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val)- => Key val -> [Update val] -> ReaderT backend m ()+ update :: (MonadIO m, PersistRecordBackend record backend)+ => Key record -> [Update record] -> ReaderT backend 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 :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val)- => Key val -> [Update val] -> ReaderT backend m val+ updateGet :: (MonadIO m, PersistRecordBackend record backend)+ => Key record -> [Update record] -> ReaderT backend m record updateGet key ups = do update key ups get key >>= maybe (liftIO $ throwIO $ KeyNotFound $ show key) return@@ -143,12 +175,11 @@ -- | 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- , PersistEntity val- , Show (Key val)- , backend ~ PersistEntityBackend val+getJust :: ( PersistStoreRead backend+ , Show (Key record)+ , PersistRecordBackend record backend , MonadIO m- ) => Key val -> ReaderT backend m val+ ) => Key record -> ReaderT backend m record getJust key = get key >>= maybe (liftIO $ throwIO $ PersistForeignConstraintUnmet $ T.pack $ show key) return@@ -157,10 +188,9 @@ -- -- > foreign = belongsTo foreignId belongsTo ::- ( PersistStore backend+ ( PersistStoreRead backend , PersistEntity ent1- , PersistEntity ent2- , backend ~ PersistEntityBackend ent2+ , PersistRecordBackend ent2 backend , MonadIO m ) => (ent1 -> Maybe (Key ent2)) -> ent1 -> ReaderT backend m (Maybe ent2) belongsTo foreignKeyField model = case foreignKeyField model of@@ -169,10 +199,9 @@ -- | Same as 'belongsTo', but uses @getJust@ and therefore is similarly unsafe. belongsToJust ::- ( PersistStore backend+ ( PersistStoreRead backend , PersistEntity ent1- , PersistEntity ent2- , backend ~ PersistEntityBackend ent2+ , PersistRecordBackend ent2 backend , MonadIO m ) => (ent1 -> Key ent2) -> ent1 -> ReaderT backend m ent2@@ -180,9 +209,8 @@ -- | Like @insert@, but returns the complete @Entity@. insertEntity ::- ( PersistStore backend- , PersistEntity e- , backend ~ PersistEntityBackend e+ ( PersistStoreWrite backend+ , PersistRecordBackend e backend , MonadIO m ) => e -> ReaderT backend m (Entity e) insertEntity e = do
Database/Persist/Class/PersistUnique.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-} module Database.Persist.Class.PersistUnique- ( PersistUnique (..)+ ( PersistUniqueRead (..)+ , PersistUniqueWrite (..) , getByValue , insertBy , replaceUnique@@ -35,7 +36,11 @@ -- you must manually place a unique index on a field to have a uniqueness -- constraint. ----- Some functions in this module ('insertUnique', 'insertBy', and+class (PersistCore backend, PersistStoreRead backend) => PersistUniqueRead backend where+ -- | Get a record by unique key, if available. Returns also the identifier.+ getBy :: (MonadIO m, PersistRecordBackend record backend) => Unique record -> ReaderT backend m (Maybe (Entity record))++-- | 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,@@ -44,17 +49,15 @@ -- determing the column of failure; -- -- * an exception will automatically abort the current SQL transaction.-class PersistStore backend => PersistUnique backend where- -- | Get a record by unique key, if available. Returns also the identifier.- getBy :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) => Unique val -> ReaderT backend m (Maybe (Entity val))+class (PersistUniqueRead backend, PersistStoreWrite backend) => PersistUniqueWrite backend where -- | Delete a specific record by unique key. Does nothing if no record -- matches.- deleteBy :: (MonadIO m, PersistEntityBackend val ~ backend, PersistEntity val) => Unique val -> ReaderT backend m ()+ deleteBy :: (MonadIO m, PersistRecordBackend record backend) => Unique record -> ReaderT backend m () -- | Like 'insert', but returns 'Nothing' when the record -- couldn't be inserted because of a uniqueness constraint.- insertUnique :: (MonadIO m, PersistEntityBackend val ~ backend, PersistEntity val) => val -> ReaderT backend m (Maybe (Key val))+ insertUnique :: (MonadIO m, PersistRecordBackend record backend) => record -> ReaderT backend m (Maybe (Key record)) insertUnique datum = do conflict <- checkUnique datum case conflict of@@ -67,13 +70,13 @@ -- * update the existing record that matches the uniqueness contraint. -- -- Throws an exception if there is more than 1 uniqueness contraint.- upsert :: (MonadIO m, PersistEntityBackend val ~ backend, PersistEntity val)- => val -- ^ new record to insert- -> [Update val]+ upsert :: (MonadIO m, PersistRecordBackend record backend)+ => record -- ^ new record to insert+ -> [Update record] -- ^ updates to perform if the record already exists (leaving -- this empty is the equivalent of performing a 'repsert' on a -- unique key)- -> ReaderT backend m (Entity val)+ -> ReaderT backend m (Entity record) -- ^ the record in the database after the operation upsert record updates = do uniqueKey <- onlyUnique record@@ -89,22 +92,33 @@ -- | 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 :: (MonadIO m, PersistEntity val, PersistUnique backend, PersistEntityBackend val ~ backend)- => val -> ReaderT backend m (Either (Entity val) (Key val))+insertBy :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend record backend)+ => record -> ReaderT backend m (Either (Entity record) (Key record)) insertBy val = do res <- getByValue val case res of Nothing -> Right `liftM` insert val Just z -> return $ Left z +-- | Insert a value, checking for conflicts with any unique constraints. If a+-- duplicate exists in the database, it is left untouched. The key of the+-- existing or new entry is returned+insertOrGet :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend record backend)+ => record -> ReaderT backend m (Key record)+insertOrGet val = do+ res <- getByValue val+ case res of+ Nothing -> insert val+ Just (Entity key _) -> return key+ -- | Return the single unique key for a record.-onlyUnique :: (MonadIO m, PersistEntity val, PersistUnique backend, PersistEntityBackend val ~ backend)- => val -> ReaderT backend m (Unique val)+onlyUnique :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend record backend)+ => record -> ReaderT backend m (Unique record) onlyUnique record = case onlyUniqueEither record of Right u -> return u Left us -> requireUniques record us >>= liftIO . throwIO . OnlyUniqueException . show . length -onlyUniqueEither :: (PersistEntity val) => val -> Either [Unique val] (Unique val)+onlyUniqueEither :: (PersistEntity record) => record -> Either [Unique record] (Unique record) onlyUniqueEither record = case persistUniqueKeys record of [u] -> Right u us -> Left us@@ -113,7 +127,7 @@ -- of a 'Unique' record. Returns a record matching /one/ of the unique keys. This -- function makes the most sense on entities with a single 'Unique' -- constructor.-getByValue :: (MonadIO m, PersistEntity record, PersistUnique backend, PersistEntityBackend record ~ backend)+getByValue :: (MonadIO m, PersistUniqueRead backend, PersistRecordBackend record backend) => record -> ReaderT backend m (Maybe (Entity record)) getByValue record = checkUniques =<< requireUniques record (persistUniqueKeys record) where@@ -142,7 +156,7 @@ -- If uniqueness is violated, return a 'Just' with the 'Unique' violation -- -- Since 1.2.2.0-replaceUnique :: (MonadIO m, Eq record, Eq (Unique record), PersistEntityBackend record ~ backend, PersistEntity record, PersistUnique backend)+replaceUnique :: (MonadIO m, Eq record, Eq (Unique record), PersistRecordBackend record backend, PersistUniqueWrite backend) => Key record -> record -> ReaderT backend m (Maybe (Unique record)) replaceUnique key datumNew = getJust key >>= replaceOriginal where@@ -161,11 +175,11 @@ -- -- Returns 'Nothing' if the entity would be unique, and could thus safely be inserted. -- on a conflict returns the conflicting key-checkUnique :: (MonadIO m, PersistEntityBackend record ~ backend, PersistEntity record, PersistUnique backend)+checkUnique :: (MonadIO m, PersistRecordBackend record backend, PersistUniqueRead backend) => record -> ReaderT backend m (Maybe (Unique record)) checkUnique = checkUniqueKeys . persistUniqueKeys -checkUniqueKeys :: (MonadIO m, PersistEntity record, PersistUnique backend, PersistEntityBackend record ~ backend)+checkUniqueKeys :: (MonadIO m, PersistEntity record, PersistUniqueRead backend, PersistRecordBackend record backend) => [Unique record] -> ReaderT backend m (Maybe (Unique record)) checkUniqueKeys [] = return Nothing checkUniqueKeys (x:xs) = do
Database/Persist/Sql/Class.hs view
@@ -4,7 +4,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-} #ifndef NO_OVERLAP {-# LANGUAGE OverlappingInstances #-} #endif@@ -58,15 +60,18 @@ rawSqlProcessRow [pv] = Single <$> fromPersistValue pv rawSqlProcessRow _ = Left $ pack "RawSql (Single a): wrong number of columns." -instance (PersistEntity a, PersistEntityBackend a ~ SqlBackend) => RawSql (Key a) where- rawSqlCols _ key = (length $ keyToValues key, [])- rawSqlColCountReason key = "The primary key is composed of "- ++ (show $ length $ keyToValues key)- ++ " columns"- rawSqlProcessRow = keyFromValues+instance+ (PersistEntity a, PersistEntityBackend a ~ backend, IsPersistBackend backend) =>+ RawSql (Key a) where+ rawSqlCols _ key = (length $ keyToValues key, [])+ rawSqlColCountReason key = "The primary key is composed of "+ ++ (show $ length $ keyToValues key)+ ++ " columns"+ rawSqlProcessRow = keyFromValues -instance (PersistEntity record, PersistEntityBackend record ~ SqlBackend)- => RawSql (Entity record) where+instance+ (PersistEntity record, PersistEntityBackend record ~ backend, IsPersistBackend backend) =>+ RawSql (Entity record) where rawSqlCols escape ent = (length sqlFields, [intercalate ", " sqlFields]) where sqlFields = map (((name <> ".") <>) . escape)
Database/Persist/Sql/Orphan/PersistQuery.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-}@@ -20,7 +21,7 @@ import Data.Monoid (Monoid (..), (<>)) import Data.Int (Int64) import Control.Monad.IO.Class-import Control.Monad.Trans.Reader (ReaderT, ask)+import Control.Monad.Trans.Reader (ReaderT, ask, withReaderT) import Control.Exception (throwIO) import qualified Data.Conduit.List as CL import Data.Conduit@@ -29,7 +30,7 @@ import Data.List (transpose, inits, find) -- orphaned instance for convenience of modularity-instance PersistQuery SqlBackend where+instance PersistQueryRead SqlBackend where count filts = do conn <- ask let wher = if null filts@@ -123,24 +124,33 @@ case keyFromValues keyvals of Right k -> return k Left _ -> error "selectKeysImpl: keyFromValues failed"--+instance PersistQueryRead SqlReadBackend where+ count filts = withReaderT persistBackend $ count filts+ selectSourceRes filts opts = withReaderT persistBackend $ selectSourceRes filts opts+ selectKeysRes filts opts = withReaderT persistBackend $ selectKeysRes filts opts+instance PersistQueryRead SqlWriteBackend where+ count filts = withReaderT persistBackend $ count filts+ selectSourceRes filts opts = withReaderT persistBackend $ selectSourceRes filts opts+ selectKeysRes filts opts = withReaderT persistBackend $ selectKeysRes filts opts +instance PersistQueryWrite SqlBackend where deleteWhere filts = do _ <- deleteWhereCount filts return ()- updateWhere filts upds = do _ <- updateWhereCount filts upds return ()+instance PersistQueryWrite SqlWriteBackend where+ deleteWhere filts = withReaderT persistBackend $ deleteWhere filts+ updateWhere filts upds = withReaderT persistBackend $ updateWhere filts upds -- | Same as 'deleteWhere', but returns the number of rows affected. -- -- Since 1.1.5-deleteWhereCount :: (PersistEntity val, MonadIO m, PersistEntityBackend val ~ SqlBackend)+deleteWhereCount :: (PersistEntity val, MonadIO m, PersistEntityBackend val ~ SqlBackend, IsSqlBackend backend) => [Filter val]- -> ReaderT SqlBackend m Int64-deleteWhereCount filts = do+ -> ReaderT backend m Int64+deleteWhereCount filts = withReaderT persistBackend $ do conn <- ask let t = entityDef $ dummyFromFilts filts let wher = if null filts@@ -156,12 +166,12 @@ -- | Same as 'updateWhere', but returns the number of rows affected. -- -- Since 1.1.5-updateWhereCount :: (PersistEntity val, MonadIO m, SqlBackend ~ PersistEntityBackend val)+updateWhereCount :: (PersistEntity val, MonadIO m, SqlBackend ~ PersistEntityBackend val, IsSqlBackend backend) => [Filter val] -> [Update val]- -> ReaderT SqlBackend m Int64+ -> ReaderT backend m Int64 updateWhereCount _ [] = return 0-updateWhereCount filts upds = do+updateWhereCount filts upds = withReaderT persistBackend $ do conn <- ask let wher = if null filts then ""
Database/Persist/Sql/Orphan/PersistStore.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -30,7 +31,7 @@ import Data.ByteString.Char8 (readInteger) import Data.Maybe (isJust) import Data.List (find)-import Control.Monad.Trans.Reader (ReaderT, ask)+import Control.Monad.Trans.Reader (ReaderT, ask, withReaderT) import Data.Acquire (with) import Data.Int (Int64) import Web.PathPieces (PathPiece)@@ -68,20 +69,18 @@ -- -- Your backend may provide a more convenient tableName function -- which does not operate in a Monad-getTableName :: forall record m.+getTableName :: forall record m backend. ( PersistEntity record , PersistEntityBackend record ~ SqlBackend+ , IsSqlBackend backend , Monad m- ) => record -> ReaderT SqlBackend m Text-getTableName rec = do+ ) => record -> ReaderT backend m Text+getTableName rec = withReaderT persistBackend $ do conn <- ask return $ connEscapeName conn $ tableDBName rec -- | useful for a backend to implement tableName by adding escaping-tableDBName :: forall record.- ( PersistEntity record- , PersistEntityBackend record ~ SqlBackend- ) => record -> DBName+tableDBName :: (PersistEntity record) => record -> DBName tableDBName rec = entityDB $ entityDef (Just rec) -- | get the SQL string for the field that an EntityField represents@@ -89,13 +88,14 @@ -- -- Your backend may provide a more convenient fieldName function -- which does not operate in a Monad-getFieldName :: forall record typ m.+getFieldName :: forall record typ m backend. ( PersistEntity record , PersistEntityBackend record ~ SqlBackend+ , IsSqlBackend backend , Monad m )- => EntityField record typ -> ReaderT SqlBackend m Text-getFieldName rec = do+ => EntityField record typ -> ReaderT backend m Text+getFieldName rec = withReaderT persistBackend $ do conn <- ask return $ connEscapeName conn $ fieldDBName rec @@ -104,10 +104,17 @@ fieldDBName = fieldDB . persistFieldDef -instance PersistStore SqlBackend where+instance PersistCore SqlBackend where newtype BackendKey SqlBackend = SqlBackendKey { unSqlBackendKey :: Int64 } deriving (Show, Read, Eq, Ord, Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON)+instance PersistCore SqlReadBackend where+ newtype BackendKey SqlReadBackend = SqlReadBackendKey { unSqlReadBackendKey :: Int64 }+ deriving (Show, Read, Eq, Ord, Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON)+instance PersistCore SqlWriteBackend where+ newtype BackendKey SqlWriteBackend = SqlWriteBackendKey { unSqlWriteBackendKey :: Int64 }+ deriving (Show, Read, Eq, Ord, Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON) +instance PersistStoreWrite SqlBackend where update _ [] = return () update k upds = do conn <- ask@@ -247,6 +254,29 @@ Nothing -> insertKey key value Just _ -> replace key value + delete k = do+ conn <- ask+ rawExecute (sql conn) (keyToValues k)+ where+ wher conn = whereStmtForKey conn k+ sql conn = T.concat+ [ "DELETE FROM "+ , connEscapeName conn $ tableDBName $ recordTypeFromKey k+ , " WHERE "+ , wher conn+ ]+instance PersistStoreWrite SqlWriteBackend where+ insert v = withReaderT persistBackend $ insert v+ insertMany vs = withReaderT persistBackend $ insertMany vs+ insertMany_ vs = withReaderT persistBackend $ insertMany_ vs+ insertKey k v = withReaderT persistBackend $ insertKey k v+ repsert k v = withReaderT persistBackend $ repsert k v+ replace k v = withReaderT persistBackend $ replace k v+ delete k = withReaderT persistBackend $ delete k+ update k upds = withReaderT persistBackend $ update k upds+++instance PersistStoreRead SqlBackend where get k = do conn <- ask let t = entityDef $ dummyFromKey k@@ -271,18 +301,10 @@ case fromPersistValues $ if noColumns then [] else vals of Left e -> error $ "get " ++ show k ++ ": " ++ unpack e Right v -> return $ Just v-- delete k = do- conn <- ask- rawExecute (sql conn) (keyToValues k)- where- wher conn = whereStmtForKey conn k- sql conn = T.concat- [ "DELETE FROM "- , connEscapeName conn $ tableDBName $ recordTypeFromKey k- , " WHERE "- , wher conn- ]+instance PersistStoreRead SqlReadBackend where+ get k = withReaderT persistBackend $ get k+instance PersistStoreRead SqlWriteBackend where+ get k = withReaderT persistBackend $ get k dummyFromKey :: Key record -> Maybe record dummyFromKey = Just . recordTypeFromKey
Database/Persist/Sql/Orphan/PersistUnique.hs view
@@ -1,9 +1,12 @@+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Sql.Orphan.PersistUnique () where import Control.Exception (throwIO)-import Control.Monad.IO.Class (liftIO)+import Control.Monad.IO.Class (liftIO, MonadIO)+import Control.Monad.Trans.Reader (ReaderT) import Database.Persist import Database.Persist.Sql.Types import Database.Persist.Sql.Raw@@ -12,9 +15,9 @@ import qualified Data.Text as T import Data.Monoid (mappend) import qualified Data.Conduit.List as CL-import Control.Monad.Trans.Reader (ask)+import Control.Monad.Trans.Reader (ask, withReaderT) -instance PersistUnique SqlBackend where+instance PersistUniqueWrite SqlBackend where deleteBy uniq = do conn <- ask let sql' = sql conn@@ -30,7 +33,10 @@ , " WHERE " , T.intercalate " AND " $ map (go' conn) $ go uniq ]+instance PersistUniqueWrite SqlWriteBackend where+ deleteBy uniq = withReaderT persistBackend $ deleteBy uniq +instance PersistUniqueRead SqlBackend where getBy uniq = do conn <- ask let sql = T.concat@@ -56,6 +62,10 @@ go conn x = connEscapeName conn x `mappend` "=?" t = entityDef $ dummyFromUnique uniq toFieldNames' = map snd . persistUniqueToFieldNames+instance PersistUniqueRead SqlReadBackend where+ getBy uniq = withReaderT persistBackend $ getBy uniq+instance PersistUniqueRead SqlWriteBackend where+ getBy uniq = withReaderT persistBackend $ getBy uniq dummyFromUnique :: Unique v -> Maybe v dummyFromUnique _ = Nothing
Database/Persist/Sql/Raw.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-} module Database.Persist.Sql.Raw where import Database.Persist@@ -9,6 +11,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (ReaderT, ask, MonadReader) import Data.Acquire (allocateAcquire, Acquire, mkAcquire, with)+import Data.Functor ((<$>)) import Data.IORef (writeIORef, readIORef, newIORef) import Control.Exception (throwIO) import Control.Monad (when, liftM)@@ -19,7 +22,7 @@ import Data.Conduit import Control.Monad.Trans.Resource (MonadResource,release) -rawQuery :: (MonadResource m, MonadReader env m, HasPersistBackend env SqlBackend)+rawQuery :: (MonadResource m, MonadReader env m, HasPersistBackend env, BaseBackend env ~ SqlBackend) => Text -> [PersistValue] -> Source m [PersistValue]@@ -30,12 +33,12 @@ release releaseKey rawQueryRes- :: (MonadIO m1, MonadIO m2)+ :: (MonadIO m1, MonadIO m2, IsSqlBackend env) => Text -> [PersistValue]- -> ReaderT SqlBackend m1 (Acquire (Source m2 [PersistValue]))+ -> ReaderT env m1 (Acquire (Source m2 [PersistValue])) rawQueryRes sql vals = do- conn <- ask+ conn <- persistBackend `liftM` ask let make = do runLoggingT (logDebugNS (pack "SQL") $ T.append sql $ pack $ "; " ++ show vals) (connLogFunc conn)@@ -53,12 +56,12 @@ -- | Execute a raw SQL statement and return the number of -- rows it has modified.-rawExecuteCount :: MonadIO m+rawExecuteCount :: (MonadIO m, IsSqlBackend backend) => Text -- ^ SQL statement, possibly with placeholders. -> [PersistValue] -- ^ Values to fill the placeholders.- -> ReaderT SqlBackend m Int64+ -> ReaderT backend m Int64 rawExecuteCount sql vals = do- conn <- ask+ conn <- persistBackend `liftM` ask runLoggingT (logDebugNS (pack "SQL") $ T.append sql $ pack $ "; " ++ show vals) (connLogFunc conn) stmt <- getStmt sql@@ -66,9 +69,11 @@ liftIO $ stmtReset stmt return res -getStmt :: MonadIO m => Text -> ReaderT SqlBackend m Statement+getStmt+ :: (MonadIO m, IsSqlBackend backend)+ => Text -> ReaderT backend m Statement getStmt sql = do- conn <- ask+ conn <- persistBackend `liftM` ask liftIO $ getStmtConn conn sql getStmtConn :: SqlBackend -> Text -> IO Statement
Database/Persist/Sql/Run.hs view
@@ -1,7 +1,10 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} module Database.Persist.Sql.Run where +import Database.Persist.Class.PersistStore import Database.Persist.Sql.Types import Database.Persist.Sql.Raw import Control.Monad.Trans.Control@@ -24,7 +27,9 @@ -- Note: This function previously timed out after 2 seconds, but this behavior -- was buggy and caused more problems than it solved. Since version 2.1.2, it -- performs no timeout checks.-runSqlPool :: MonadBaseControl IO m => SqlPersistT m a -> Pool SqlBackend -> m a+runSqlPool+ :: (MonadBaseControl IO m, IsSqlBackend backend)+ => ReaderT backend m a -> Pool backend -> m a runSqlPool r pconn = withResource pconn $ runSqlConn r -- | Like 'withResource', but times out the operation if resource@@ -49,37 +54,46 @@ return ret {-# INLINABLE withResourceTimeout #-} -runSqlConn :: MonadBaseControl IO m => SqlPersistT m a -> SqlBackend -> m a+runSqlConn :: (MonadBaseControl IO m, IsSqlBackend backend) => ReaderT backend m a -> backend -> m a runSqlConn r conn = control $ \runInIO -> mask $ \restore -> do- let getter = getStmtConn conn- restore $ connBegin conn getter+ let conn' = persistBackend conn+ getter = getStmtConn conn'+ restore $ connBegin conn' getter x <- onException (restore $ runInIO $ runReaderT r conn)- (restore $ connRollback conn getter)- restore $ connCommit conn getter+ (restore $ connRollback conn' getter)+ restore $ connCommit conn' getter return x -runSqlPersistM :: SqlPersistM a -> SqlBackend -> IO a+runSqlPersistM+ :: (IsSqlBackend backend)+ => ReaderT backend (NoLoggingT (ResourceT IO)) a -> backend -> IO a runSqlPersistM x conn = runResourceT $ runNoLoggingT $ runSqlConn x conn -runSqlPersistMPool :: SqlPersistM a -> Pool SqlBackend -> IO a+runSqlPersistMPool+ :: (IsSqlBackend backend)+ => ReaderT backend (NoLoggingT (ResourceT IO)) a -> Pool backend -> IO a runSqlPersistMPool x pool = runResourceT $ runNoLoggingT $ runSqlPool x pool -liftSqlPersistMPool :: MonadIO m => SqlPersistM a -> Pool SqlBackend -> m a+liftSqlPersistMPool+ :: (MonadIO m, IsSqlBackend backend)+ => ReaderT backend (NoLoggingT (ResourceT IO)) a -> Pool backend -> m a liftSqlPersistMPool x pool = liftIO (runSqlPersistMPool x pool) -withSqlPool :: (MonadIO m, MonadLogger m, MonadBaseControl IO m)- => (LogFunc -> IO SqlBackend) -- ^ create a new connection- -> Int -- ^ connection count- -> (Pool SqlBackend -> m a)- -> m a-withSqlPool mkConn connCount f = do+withSqlPool+ :: (MonadIO m, MonadLogger m, MonadBaseControl IO 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 -createSqlPool :: (MonadIO m, MonadLogger m, MonadBaseControl IO m)- => (LogFunc -> IO SqlBackend)- -> Int- -> m (Pool SqlBackend)+createSqlPool+ :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, IsSqlBackend backend)+ => (LogFunc -> IO backend)+ -> Int+ -> m (Pool backend) createSqlPool mkConn size = do logFunc <- askLogFunc liftIO $ createPool (mkConn logFunc) close' 1 20 size@@ -99,13 +113,14 @@ _ <- runInBase (monadLoggerLog a b c d) return () -withSqlConn :: (MonadIO m, MonadBaseControl IO m, MonadLogger m)- => (LogFunc -> IO SqlBackend) -> (SqlBackend -> m a) -> m a+withSqlConn+ :: (MonadIO m, MonadBaseControl IO 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 -close' :: SqlBackend -> IO ()+close' :: (IsSqlBackend backend) => backend -> IO () close' conn = do- readIORef (connStmtMap conn) >>= mapM_ stmtFinalize . Map.elems- connClose conn+ readIORef (connStmtMap $ persistBackend conn) >>= mapM_ stmtFinalize . Map.elems+ connClose $ persistBackend conn
Database/Persist/Sql/Types.hs view
@@ -1,13 +1,21 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-}-module Database.Persist.Sql.Types where+module Database.Persist.Sql.Types+ ( module Database.Persist.Sql.Types+ , SqlBackend (..), SqlReadBackend (..), SqlWriteBackend (..)+ , Statement (..), LogFunc, InsertSqlResult (..)+ , readToUnknown, readToWrite, writeToUnknown+ , SqlBackendCanRead, SqlBackendCanWrite, SqlReadT, SqlWriteT, IsSqlBackend+ ) where import Control.Exception (Exception) import Control.Monad.Trans.Resource (ResourceT)@@ -18,7 +26,7 @@ import Control.Monad.Trans.Writer (WriterT) import Data.Typeable (Typeable) import Database.Persist.Types-import Database.Persist.Class (HasPersistBackend (..))+import Database.Persist.Sql.Types.Internal import Data.IORef (IORef) import Data.Map (Map) import Data.Int (Int64)@@ -29,49 +37,9 @@ import System.Log.FastLogger (LogStr) import Data.Text (Text) -data InsertSqlResult = ISRSingle Text- | ISRInsertGet Text Text- | ISRManyKeys Text [PersistValue]- -- | Deprecated synonym for @SqlBackend@. type Connection = SqlBackend {-# DEPRECATED Connection "Please use SqlBackend instead" #-}--data SqlBackend = SqlBackend- { connPrepare :: Text -> IO Statement- -- | table name, column names, id name, either 1 or 2 statements to run- , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult- , connInsertManySql :: Maybe (EntityDef -> [[PersistValue]] -> InsertSqlResult) -- ^ SQL for inserting many rows and returning their primary keys, for backends that support this functioanlity. If 'Nothing', rows will be inserted one-at-a-time using 'connInsertSql'.- , connStmtMap :: IORef (Map Text Statement)- , connClose :: IO ()- , connMigrateSql- :: [EntityDef]- -> (Text -> IO Statement)- -> EntityDef- -> IO (Either [Text] [(Bool, Text)])- , connBegin :: (Text -> IO Statement) -> IO ()- , connCommit :: (Text -> IO Statement) -> IO ()- , connRollback :: (Text -> IO Statement) -> IO ()- , connEscapeName :: DBName -> Text- , connNoLimit :: Text- , connRDBMS :: Text- , connLimitOffset :: (Int,Int) -> Bool -> Text -> Text- , connLogFunc :: LogFunc- }- deriving Typeable-instance HasPersistBackend SqlBackend SqlBackend where- persistBackend = id--type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()--data Statement = Statement- { stmtFinalize :: IO ()- , stmtReset :: IO ()- , stmtExecute :: [PersistValue] -> IO Int64- , stmtQuery :: forall m. MonadIO m- => [PersistValue]- -> Acquire (Source m [PersistValue])- } data Column = Column { cName :: !DBName
+ Database/Persist/Sql/Types/Internal.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Database.Persist.Sql.Types.Internal+ ( HasPersistBackend (..)+ , IsPersistBackend (..)+ , SqlReadBackend (unSqlReadBackend)+ , SqlWriteBackend (unSqlWriteBackend)+ , readToUnknown+ , readToWrite+ , writeToUnknown+ , LogFunc+ , InsertSqlResult (..)+ , Statement (..)+ , SqlBackend (..)+ , SqlBackendCanRead+ , SqlBackendCanWrite+ , SqlReadT+ , SqlWriteT+ , IsSqlBackend+ ) where++import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Logger (LogSource, LogLevel)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)+import Data.Acquire (Acquire)+import Data.Conduit (Source)+import Data.Int (Int64)+import Data.IORef (IORef)+import Data.Map (Map)+import Data.Text (Text)+import Data.Typeable (Typeable)+import Database.Persist.Class+ ( HasPersistBackend (..)+ , PersistQueryRead, PersistQueryWrite+ , PersistStoreRead, PersistStoreWrite+ , PersistUniqueRead, PersistUniqueWrite+ )+import Database.Persist.Class.PersistStore (IsPersistBackend (..))+import Database.Persist.Types+import Language.Haskell.TH.Syntax (Loc)+import System.Log.FastLogger (LogStr)++type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()++data InsertSqlResult = ISRSingle Text+ | ISRInsertGet Text Text+ | ISRManyKeys Text [PersistValue]++data Statement = Statement+ { stmtFinalize :: IO ()+ , stmtReset :: IO ()+ , stmtExecute :: [PersistValue] -> IO Int64+ , stmtQuery :: forall m. MonadIO m+ => [PersistValue]+ -> Acquire (Source m [PersistValue])+ }++data SqlBackend = SqlBackend+ { connPrepare :: Text -> IO Statement+ -- | table name, column names, id name, either 1 or 2 statements to run+ , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult+ , connInsertManySql :: Maybe (EntityDef -> [[PersistValue]] -> InsertSqlResult) -- ^ SQL for inserting many rows and returning their primary keys, for backends that support this functioanlity. If 'Nothing', rows will be inserted one-at-a-time using 'connInsertSql'.+ , connStmtMap :: IORef (Map Text Statement)+ , connClose :: IO ()+ , connMigrateSql+ :: [EntityDef]+ -> (Text -> IO Statement)+ -> EntityDef+ -> IO (Either [Text] [(Bool, Text)])+ , connBegin :: (Text -> IO Statement) -> IO ()+ , connCommit :: (Text -> IO Statement) -> IO ()+ , connRollback :: (Text -> IO Statement) -> IO ()+ , connEscapeName :: DBName -> Text+ , connNoLimit :: Text+ , connRDBMS :: Text+ , connLimitOffset :: (Int,Int) -> Bool -> Text -> Text+ , connLogFunc :: LogFunc+ }+ deriving Typeable+instance HasPersistBackend SqlBackend where+ type BaseBackend SqlBackend = SqlBackend+ persistBackend = id+instance IsPersistBackend SqlBackend where+ mkPersistBackend = id++-- | An SQL backend which can only handle read queries+newtype SqlReadBackend = SqlReadBackend { unSqlReadBackend :: SqlBackend } deriving Typeable+instance HasPersistBackend SqlReadBackend where+ type BaseBackend SqlReadBackend = SqlBackend+ persistBackend = unSqlReadBackend+instance IsPersistBackend SqlReadBackend where+ mkPersistBackend = SqlReadBackend++-- | An SQL backend which can handle read or write queries+newtype SqlWriteBackend = SqlWriteBackend { unSqlWriteBackend :: SqlBackend } deriving Typeable+instance HasPersistBackend SqlWriteBackend where+ type BaseBackend SqlWriteBackend = SqlBackend+ persistBackend = unSqlWriteBackend+instance IsPersistBackend SqlWriteBackend where+ mkPersistBackend = SqlWriteBackend++-- | Useful for running a write query against an untagged backend with unknown capabilities.+writeToUnknown :: Monad m => ReaderT SqlWriteBackend m a -> ReaderT SqlBackend m a+writeToUnknown ma = do+ unknown <- ask+ lift . runReaderT ma $ SqlWriteBackend unknown++-- | Useful for running a read query against a backend with read and write capabilities.+readToWrite :: Monad m => ReaderT SqlReadBackend m a -> ReaderT SqlWriteBackend m a+readToWrite ma = do+ write <- ask+ lift . runReaderT ma . SqlReadBackend $ unSqlWriteBackend write++-- | Useful for running a read query against a backend with unknown capabilities.+readToUnknown :: Monad m => ReaderT SqlReadBackend m a -> ReaderT SqlBackend m a+readToUnknown ma = do+ unknown <- ask+ lift . runReaderT ma $ SqlReadBackend unknown++-- | A constraint synonym which witnesses that a backend is SQL and can run read queries.+type SqlBackendCanRead backend =+ ( IsSqlBackend backend+ , PersistQueryRead backend, PersistStoreRead backend, PersistUniqueRead backend+ )+-- | A constraint synonym which witnesses that a backend is SQL and can run read and write queries.+type SqlBackendCanWrite backend =+ ( SqlBackendCanRead backend+ , PersistQueryWrite backend, PersistStoreWrite backend, PersistUniqueWrite backend+ )+-- | Like @SqlPersistT@ but compatible with any SQL backend which can handle read queries.+type SqlReadT m a = forall backend. (SqlBackendCanRead backend) => ReaderT backend m a+-- | Like @SqlPersistT@ but compatible with any SQL backend which can handle read and write queries.+type SqlWriteT m a = forall backend. (SqlBackendCanWrite backend) => ReaderT backend m a+-- | A backend which is a wrapper around @SqlBackend@.+type IsSqlBackend backend = (IsPersistBackend backend, BaseBackend backend ~ SqlBackend)
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.2.4.1+version: 2.5 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -60,6 +60,7 @@ Database.Persist.Class Database.Persist.Sql Database.Persist.Sql.Util+ Database.Persist.Sql.Types.Internal other-modules: Database.Persist.Types.Base Database.Persist.Class.DeleteCascade