persistent 2.9.2 → 2.10.0
raw patch · 27 files changed
+631/−584 lines, 27 filesdep −blaze-markupdep −monad-controldep −old-localedep ~aesondep ~basedep ~blaze-htmlnew-uploader
Dependencies removed: blaze-markup, monad-control, old-locale, tagged, void
Dependency ranges changed: aeson, base, blaze-html, bytestring, conduit, containers, fast-logger, hspec, http-api-data, monad-logger, path-pieces, resource-pool, resourcet, text, time, transformers
Files
- ChangeLog.md +9/−0
- Database/Persist.hs +15/−27
- Database/Persist/Class.hs +7/−4
- Database/Persist/Class/DeleteCascade.hs +6/−8
- Database/Persist/Class/PersistConfig.hs +2/−6
- Database/Persist/Class/PersistEntity.hs +37/−27
- Database/Persist/Class/PersistField.hs +23/−52
- Database/Persist/Class/PersistQuery.hs +5/−10
- Database/Persist/Class/PersistStore.hs +11/−14
- Database/Persist/Class/PersistUnique.hs +195/−100
- Database/Persist/Quasi.hs +11/−7
- Database/Persist/Sql.hs +3/−2
- Database/Persist/Sql/Class.hs +19/−41
- Database/Persist/Sql/Internal.hs +4/−4
- Database/Persist/Sql/Migration.hs +5/−6
- Database/Persist/Sql/Orphan/PersistQuery.hs +35/−27
- Database/Persist/Sql/Orphan/PersistStore.hs +30/−34
- Database/Persist/Sql/Orphan/PersistUnique.hs +16/−17
- Database/Persist/Sql/Raw.hs +34/−39
- Database/Persist/Sql/Run.hs +30/−33
- Database/Persist/Sql/Types.hs +4/−21
- Database/Persist/Sql/Types/Internal.hs +12/−11
- Database/Persist/Sql/Util.hs +2/−2
- Database/Persist/Types.hs +1/−2
- Database/Persist/Types/Base.hs +69/−41
- persistent.cabal +46/−48
- test/main.hs +0/−1
ChangeLog.md view
@@ -1,5 +1,14 @@ # Changelog for persistent +## 2.10.0++* Added two type classes `OnlyOneUniqueKey` and `AtLeastOneUniqueKey`. These classes are used as constraints on functions that expect a certain amount of unique keys. They are defined automatically as part of the `persistent-template`'s generation. [#885](https://github.com/yesodweb/persistent/pull/885)+* Add the `entityComments` field to the `EntityDef` datatype, and `fieldComments` fields to the `FieldDef` datatype. The QuasiQuoter does not currently know how to add documentation comments to these types, but it can be expanded later. [#865](https://github.com/yesodweb/persistent/pull/865)+* Expose the `SqlReadT` and `SqlWriteT` constructors. [#887](https://github.com/yesodweb/persistent/pull/887)+* Remove deprecated `Connection` type synonym. Please use `SqlBackend` instead. [#894](https://github.com/yesodweb/persistent/pull/894)+* Remove deprecated `SqlPersist` type synonym. Please use `SqlPersistT` instead. [#894](https://github.com/yesodweb/persistent/pull/894)+* Alter the type of `connUpsertSql` to take a list of unique definitions. This paves the way for more efficient upsert implementations. [#895](https://github.com/yesodweb/persistent/pull/895)+ ## 2.9.2 * Add documentation for the `Migration` type and some helpers. [#860](https://github.com/yesodweb/persistent/pull/860)
Database/Persist.hs view
@@ -1,7 +1,4 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-} module Database.Persist ( module Database.Persist.Class , module Database.Persist.Types@@ -46,21 +43,16 @@ , limitOffsetOrder ) where -import Database.Persist.Types-import Database.Persist.Class-import Database.Persist.Class.PersistField (getPersistMap)+import Data.Aeson (toJSON, ToJSON)+import Data.Aeson.Text (encodeToTextBuilder) import qualified Data.Text as T import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder (toLazyText)-import Data.Aeson (toJSON, ToJSON)-#if MIN_VERSION_aeson(1, 0, 0)-import Data.Aeson.Text (encodeToTextBuilder)-#elif MIN_VERSION_aeson(0, 7, 0)-import Data.Aeson.Encode (encodeToTextBuilder)-#else-import Data.Aeson.Encode (fromValue)-#endif +import Database.Persist.Types+import Database.Persist.Class+import Database.Persist.Class.PersistField (getPersistMap)+ infixr 3 =., +=., -=., *=., /=. (=.), (+=.), (-=.), (*=.), (/=.) :: forall v typ. PersistField typ => EntityField v typ -> typ -> Update v@@ -77,7 +69,7 @@ -- Similar to `updateWhere` which is shown in the above example you can use other functions present in the module "Database.Persist.Class". Note that the first parameter of `updateWhere` is [`Filter` val] and second parameter is [`Update` val]. By comparing this with the type of `==.` and `=.`, you can see that they match up in the above usage. -- -- The above query when applied on <#dataset dataset-1>, will produce this:--- +-- -- > +-----+-----+--------+ -- > |id |name |age | -- > +-----+-----+--------+@@ -195,7 +187,7 @@ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ -f ==. a = Filter f (Left a) Eq+f ==. a = Filter f (FilterValue a) Eq -- | Non-equality check. --@@ -214,7 +206,7 @@ -- > |2 |Simon|41 | -- > +-----+-----+-----+ -f !=. a = Filter f (Left a) Ne+f !=. a = Filter f (FilterValue a) Ne -- | Less-than check. --@@ -233,7 +225,7 @@ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ -f <. a = Filter f (Left a) Lt+f <. a = Filter f (FilterValue a) Lt -- | Less-than or equal check. --@@ -252,7 +244,7 @@ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ -f <=. a = Filter f (Left a) Le+f <=. a = Filter f (FilterValue a) Le -- | Greater-than check. --@@ -271,7 +263,7 @@ -- > |2 |Simon|41 | -- > +-----+-----+-----+ -f >. a = Filter f (Left a) Gt+f >. a = Filter f (FilterValue a) Gt -- | Greater-than or equal check. --@@ -290,7 +282,7 @@ -- > |2 |Simon|41 | -- > +-----+-----+-----+ -f >=. a = Filter f (Left a) Ge+f >=. a = Filter f (FilterValue a) Ge infix 4 <-., /<-. (<-.), (/<-.) :: forall v typ. PersistField typ => EntityField v typ -> [typ] -> Filter v@@ -328,7 +320,7 @@ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ -f <-. a = Filter f (Right a) In+f <-. a = Filter f (FilterValues a) In -- | Check if value is not in given list. --@@ -347,7 +339,7 @@ -- > |2 |Simon|41 | -- > +-----+-----+-----+ -f /<-. a = Filter f (Right a) NotIn+f /<-. a = Filter f (FilterValues a) NotIn infixl 3 ||. (||.) :: forall v. [Filter v] -> [Filter v] -> [Filter v]@@ -392,11 +384,7 @@ -- | A more general way to convert instances of `ToJSON` type class to -- strict text 'T.Text'. toJsonText :: ToJSON j => j -> T.Text-#if MIN_VERSION_aeson(0, 7, 0) toJsonText = toStrict . toLazyText . encodeToTextBuilder . toJSON-#else-toJsonText = toStrict . toLazyText . fromValue . toJSON-#endif -- | FIXME What's this exactly? limitOffsetOrder :: PersistEntity val
Database/Persist/Class.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE ConstraintKinds #-}- module Database.Persist.Class ( ToBackendKey (..) @@ -91,6 +90,10 @@ , PersistUnique , PersistUniqueRead (..) , PersistUniqueWrite (..)+ , OnlyOneUniqueKey (..)+ , AtLeastOneUniqueKey (..)+ , NoUniqueKeysError+ , MultipleUniqueKeysError , getByValue , insertBy , insertUniqueEntity@@ -132,12 +135,12 @@ ) where import Database.Persist.Class.DeleteCascade-import Database.Persist.Class.PersistEntity-import Database.Persist.Class.PersistQuery-import Database.Persist.Class.PersistUnique import Database.Persist.Class.PersistConfig+import Database.Persist.Class.PersistEntity import Database.Persist.Class.PersistField+import Database.Persist.Class.PersistQuery import Database.Persist.Class.PersistStore+import Database.Persist.Class.PersistUnique -- | A backwards-compatible alias for those that don't care about distinguishing between read and write queries.
Database/Persist/Class/DeleteCascade.hs view
@@ -1,19 +1,17 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# 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 Data.Conduit-import qualified Data.Conduit.List as CL import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (ReaderT, ask, runReaderT)+import Data.Conduit+import qualified Data.Conduit.List as CL import Data.Acquire (with)++import Database.Persist.Class.PersistStore+import Database.Persist.Class.PersistQuery+import Database.Persist.Class.PersistEntity -- | For combinations of backends and entities that support -- cascade-deletion. “Cascade-deletion” means that entries that depend on
Database/Persist/Class/PersistConfig.hs view
@@ -1,14 +1,10 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-} module Database.Persist.Class.PersistConfig ( PersistConfig (..) ) where +import Control.Monad.IO.Unlift (MonadUnliftIO) import Data.Aeson (Value (Object)) import Data.Aeson.Types (Parser)-import Control.Monad.IO.Unlift (MonadUnliftIO)-import Control.Applicative as A ((<$>)) import qualified Data.HashMap.Strict as HashMap -- | Represents a value containing all the configuration options for a specific@@ -47,7 +43,7 @@ loadConfig (Object o) = case HashMap.lookup "left" o of- Just v -> Left A.<$> loadConfig v+ Just v -> Left <$> loadConfig v Nothing -> case HashMap.lookup "right" o of Just v -> Right <$> loadConfig v
Database/Persist/Class/PersistEntity.hs view
@@ -1,20 +1,19 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts, StandaloneDeriving, UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-} module Database.Persist.Class.PersistEntity ( PersistEntity (..) , Update (..) , BackendSpecificUpdate , SelectOpt (..) , Filter (..)+ , FilterValue (..) , BackendSpecificFilter , Entity (..) + , recordName , entityValues , keyValueEntityToJSON, keyValueEntityFromJSON , entityIdToJSON, entityIdFromJSON@@ -23,29 +22,25 @@ , toPersistValueEnum, fromPersistValueEnum ) where -import Database.Persist.Types.Base-import Database.Persist.Class.PersistField-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import qualified Data.Text.Lazy as LT-import qualified Data.Text.Lazy.Builder as TB import Data.Aeson (ToJSON (..), FromJSON (..), fromJSON, object, (.:), (.=), Value (Object)) import qualified Data.Aeson.Parser as AP import Data.Aeson.Types (Parser,Result(Error,Success))-#if MIN_VERSION_aeson(1,0,0) import Data.Aeson.Text (encodeToTextBuilder)-#else-import Data.Aeson.Encode (encodeToTextBuilder)-#endif import Data.Attoparsec.ByteString (parseOnly)-import Control.Applicative as A ((<$>), (<*>))-import Data.Monoid (mappend) import qualified Data.HashMap.Strict as HM-import Data.Typeable (Typeable) import Data.Maybe (isJust)+import Data.Monoid (mappend)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Builder as TB+import Data.Typeable (Typeable) import GHC.Generics +import Database.Persist.Class.PersistField+import Database.Persist.Types.Base+ -- | Persistent serialized Haskell records to the database. -- A Database 'Entity' (A row in SQL, a document in MongoDB, etc) -- corresponds to a 'Key' plus a Haskell record.@@ -104,6 +99,13 @@ type family BackendSpecificUpdate backend record +-- Moved over from Database.Persist.Class.PersistUnique+-- | Textual representation of the record+recordName+ :: (PersistEntity record)+ => record -> Text+recordName = unHaskellName . entityHaskell . entityDef . Just+ -- | Updating a database entity. -- -- Persistent users use combinators to create these.@@ -134,7 +136,7 @@ -- Persistent users use combinators to create these. data Filter record = forall typ. PersistField typ => Filter { filterField :: EntityField record typ- , filterValue :: Either typ [typ] -- FIXME+ , filterValue :: FilterValue typ , filterFilter :: PersistFilter -- FIXME } | FilterAnd [Filter record] -- ^ convenient for internal use, not needed for the API@@ -142,6 +144,14 @@ | BackendFilter (BackendSpecificFilter (PersistEntityBackend record) record) +-- | Value to filter with. Highly dependant on the type of filter used.+--+-- @since 2.10.0+data FilterValue typ where+ FilterValue :: typ -> FilterValue typ+ FilterValues :: [typ] -> FilterValue typ+ UnsafeValue :: forall a typ. PersistField a => a -> FilterValue typ+ -- | Datatype that represents an entity, with both its 'Key' and -- its Haskell record representation. --@@ -204,7 +214,7 @@ -- instance ToJSON (Entity User) where -- toJSON = keyValueEntityToJSON -- @-keyValueEntityToJSON :: (PersistEntity record, ToJSON record, ToJSON (Key record))+keyValueEntityToJSON :: (PersistEntity record, ToJSON record) => Entity record -> Value keyValueEntityToJSON (Entity key value) = object [ "key" .= key@@ -220,11 +230,11 @@ -- instance FromJSON (Entity User) where -- parseJSON = keyValueEntityFromJSON -- @-keyValueEntityFromJSON :: (PersistEntity record, FromJSON record, FromJSON (Key record))+keyValueEntityFromJSON :: (PersistEntity record, FromJSON record) => Value -> Parser (Entity record) keyValueEntityFromJSON (Object o) = Entity- A.<$> o .: "key"- A.<*> o .: "value"+ <$> o .: "key"+ <*> o .: "value" keyValueEntityFromJSON _ = fail "keyValueEntityFromJSON: not an object" -- | Predefined @toJSON@. The resulting JSON looks like@@ -236,7 +246,7 @@ -- instance ToJSON (Entity User) where -- toJSON = entityIdToJSON -- @-entityIdToJSON :: (PersistEntity record, ToJSON record, ToJSON (Key record)) => Entity record -> Value+entityIdToJSON :: (PersistEntity record, ToJSON record) => Entity record -> Value entityIdToJSON (Entity key value) = case toJSON value of Object o -> Object $ HM.insert "id" (toJSON key) o x -> x@@ -250,7 +260,7 @@ -- instance FromJSON (Entity User) where -- parseJSON = entityIdFromJSON -- @-entityIdFromJSON :: (PersistEntity record, FromJSON record, FromJSON (Key record)) => Value -> Parser (Entity record)+entityIdFromJSON :: (PersistEntity record, FromJSON record) => Value -> Parser (Entity record) entityIdFromJSON value@(Object o) = Entity <$> o .: "id" <*> parseJSON value entityIdFromJSON _ = fail "entityIdFromJSON: not an object"
Database/Persist/Class/PersistField.hs view
@@ -2,12 +2,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards #-}-{-# LANGUAGE OverloadedStrings #-}--#if !MIN_VERSION_base(4,8,0)-{-# LANGUAGE OverlappingInstances #-}-#endif- module Database.Persist.Class.PersistField ( PersistField (..) , SomePersistField (..)@@ -15,53 +9,39 @@ ) where import Control.Arrow (second)-import Database.Persist.Types.Base-import Data.Time (Day(..), TimeOfDay, UTCTime,-#if MIN_VERSION_time(1,5,0)- parseTimeM)-#else- parseTime)-#endif-#ifdef HIGH_PRECISION_DATE-import Data.Time.Clock.POSIX (posixSecondsToUTCTime)-#endif+import Control.Monad ((<=<))+import qualified Data.Aeson as A import Data.ByteString.Char8 (ByteString, unpack, readInt)-import Data.Int (Int8, Int16, Int32, Int64)-import Data.Word (Word, Word8, Word16, Word32, Word64)-import Data.Text (Text)-import Data.Text.Read (double)+import qualified Data.ByteString.Lazy as L import Data.Fixed+import Data.Int (Int8, Int16, Int32, Int64)+import qualified Data.IntMap as IM+import qualified Data.Map as M import Data.Monoid ((<>))--import Text.Blaze.Html-import Text.Blaze.Html.Renderer.Text (renderHtml)--import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.ByteString.Lazy as L--import Control.Monad ((<=<))--import qualified Data.Aeson as A- import qualified Data.Set as S-import qualified Data.Map as M-import qualified Data.IntMap as IM-+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Read (double) import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding.Error as TERR+import qualified Data.Text.Lazy as TL import qualified Data.Vector as V+import Data.Word (Word, Word8, Word16, Word32, Word64)+import Numeric.Natural (Natural)+import Text.Blaze.Html+import Text.Blaze.Html.Renderer.Text (renderHtml) -#if MIN_VERSION_time(1,5,0)+import Database.Persist.Types.Base++import Data.Time (Day(..), TimeOfDay, UTCTime,+ parseTimeM) import Data.Time (defaultTimeLocale)-#else-import System.Locale (defaultTimeLocale)-#endif -#if MIN_VERSION_base(4,8,0)-import Numeric.Natural (Natural)+#ifdef HIGH_PRECISION_DATE+import Data.Time.Clock.POSIX (posixSecondsToUTCTime) #endif + -- | This class teaches Persistent how to take a custom type and marshal it to and from a 'PersistValue', allowing it to be stored in a database. -- -- ==== __Examples__@@ -105,7 +85,7 @@ -- Tips: -- -- * This file contain dozens of 'PersistField' instances you can look at for examples.--- * Typically custom 'PersistField' instances will only accept a single 'PersistValue' constructor in 'fromPersistValue'. +-- * Typically custom 'PersistField' instances will only accept a single 'PersistValue' constructor in 'fromPersistValue'. -- * Internal 'PersistField' instances accept a wide variety of 'PersistValue's to accomodate e.g. storing booleans as integers, booleans or strings. -- * If you're making a custom instance and using a SQL database, you'll also need @PersistFieldSql@ to specify the type of the database column. class PersistField a where@@ -113,11 +93,7 @@ fromPersistValue :: PersistValue -> Either T.Text a #ifndef NO_OVERLAP-#if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPING #-} PersistField [Char] where-#else-instance PersistField [Char] where-#endif toPersistValue = PersistText . T.pack fromPersistValue (PersistText s) = Right $ T.unpack s fromPersistValue (PersistByteString bs) =@@ -133,6 +109,7 @@ fromPersistValue (PersistList _) = Left $ T.pack "Cannot convert PersistList to String" fromPersistValue (PersistMap _) = Left $ T.pack "Cannot convert PersistMap to String" fromPersistValue (PersistDbSpecific _) = Left $ T.pack "Cannot convert PersistDbSpecific to String. See the documentation of PersistDbSpecific for an example of using a custom database type with Persistent."+ fromPersistValue (PersistArray _) = Left $ T.pack "Cannot convert PersistArray to String" fromPersistValue (PersistObjectId _) = Left $ T.pack "Cannot convert PersistObjectId to String" #endif @@ -345,13 +322,11 @@ fromPersistValue x = Left $ fromPersistValueError "UTCTime" "time, integer, string, or bytestring" x -#if MIN_VERSION_base(4,8,0) instance PersistField Natural where toPersistValue = (toPersistValue :: Int64 -> PersistValue) . fromIntegral fromPersistValue x = case (fromPersistValue x :: Either Text Int64) of Left err -> Left $ T.replace "Int64" "Natural" err Right int -> Right $ fromIntegral int -- TODO use bimap?-#endif instance PersistField a => PersistField (Maybe a) where toPersistValue Nothing = PersistNull@@ -359,11 +334,7 @@ fromPersistValue PersistNull = Right Nothing fromPersistValue x = Just <$> fromPersistValue x -#if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPABLE #-} PersistField a => PersistField [a] where-#else-instance PersistField a => PersistField [a] where-#endif toPersistValue = PersistList . fmap toPersistValue fromPersistValue (PersistList l) = fromPersistList l fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t)
Database/Persist/Class/PersistQuery.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-} module Database.Persist.Class.PersistQuery ( PersistQueryRead (..) , PersistQueryWrite (..)@@ -11,16 +7,15 @@ , selectKeysList ) where -import Database.Persist.Types import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (ReaderT, MonadReader)-+import Control.Monad.Trans.Resource (MonadResource, release)+import Data.Acquire (Acquire, allocateAcquire, with) import Data.Conduit (ConduitM, (.|), await, runConduit) import qualified Data.Conduit.List as CL+ import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistEntity-import Control.Monad.Trans.Resource (MonadResource, release)-import Data.Acquire (Acquire, allocateAcquire, with) -- | Backends supporting conditional read operations. class (PersistCore backend, PersistStoreRead backend) => PersistQueryRead backend where@@ -65,7 +60,7 @@ -- | Get all records matching the given criterion in the specified order. -- Returns also the identifiers. selectSource- :: (PersistQueryRead (BaseBackend backend), MonadResource m, PersistEntity record, PersistEntityBackend record ~ BaseBackend (BaseBackend backend), MonadReader backend m, HasPersistBackend backend)+ :: (PersistQueryRead backend, MonadResource m, PersistRecordBackend record backend, MonadReader backend m) => [Filter record] -> [SelectOpt record] -> ConduitM () (Entity record) m ()@@ -76,7 +71,7 @@ release releaseKey -- | Get the 'Key's of all records matching the given criterion.-selectKeys :: (PersistQueryRead (BaseBackend backend), MonadResource m, PersistEntity record, BaseBackend (BaseBackend backend) ~ PersistEntityBackend record, MonadReader backend m, HasPersistBackend backend)+selectKeys :: (PersistQueryRead backend, MonadResource m, PersistRecordBackend record backend, MonadReader backend m) => [Filter record] -> [SelectOpt record] -> ConduitM () (Key record) m ()
Database/Persist/Class/PersistStore.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE TypeFamilies, FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ConstraintKinds #-} module Database.Persist.Class.PersistStore ( HasPersistBackend (..)@@ -21,19 +18,20 @@ , BackendCompatible(..) ) where -import qualified Data.Text as T-import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Exception (throwIO)-import Control.Monad.Trans.Reader (ReaderT)+import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (MonadReader (ask), runReaderT)-import Database.Persist.Class.PersistEntity-import Database.Persist.Class.PersistField-import Database.Persist.Types+import Control.Monad.Trans.Reader (ReaderT) import qualified Data.Aeson as A-import qualified Data.Map as Map import Data.Map (Map)+import qualified Data.Map as Map import qualified Data.Maybe as Maybe+import qualified Data.Text as T +import Database.Persist.Class.PersistEntity+import Database.Persist.Class.PersistField+import Database.Persist.Types+ -- | Class which allows the plucking of a @BaseBackend backend@ from some larger type. -- For example, -- @@@ -100,11 +98,11 @@ 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+ :: (MonadIO m, MonadReader backend m)+ => ReaderT backend IO b -> m b liftPersist f = do env <- ask- liftIO $ runReaderT f (persistBackend env)+ liftIO $ runReaderT f env -- | 'ToBackendKey' converts a 'PersistEntity' 'Key' into a 'BackendKey' -- This can be used by each backend to convert between a 'Key' and a plain@@ -586,7 +584,6 @@ -- -- This just throws an error. getJust :: ( PersistStoreRead backend- , Show (Key record) , PersistRecordBackend record backend , MonadIO m ) => Key record -> ReaderT backend m record
Database/Persist/Class/PersistUnique.hs view
@@ -1,32 +1,43 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-} module Database.Persist.Class.PersistUnique- (PersistUniqueRead(..)- ,PersistUniqueWrite(..)- ,getByValue- ,insertBy- ,insertUniqueEntity- ,replaceUnique- ,checkUnique- ,onlyUnique- ,defaultPutMany- ,persistUniqueKeyValues+ ( PersistUniqueRead(..)+ , PersistUniqueWrite(..)+ , OnlyOneUniqueKey(..)+ , onlyOneUniqueDef+ , AtLeastOneUniqueKey(..)+ , atLeastOneUniqueDef+ , NoUniqueKeysError+ , MultipleUniqueKeysError+ , getByValue+ , getByValueUniques+ , insertBy+ , insertUniqueEntity+ , replaceUnique+ , checkUnique+ , onlyUnique+ , defaultPutMany+ , persistUniqueKeyValues ) where -import Database.Persist.Types-import Control.Exception (throwIO) import Control.Monad (liftM)-import Control.Monad.IO.Class (liftIO, MonadIO)-import Data.List ((\\), deleteFirstsBy, nubBy)-import Data.Function (on)+import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Reader (ReaderT)+import Data.Function (on)+import Data.List ((\\), deleteFirstsBy)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NEL+import qualified Data.Map as Map+import Data.Maybe (catMaybes)+import Data.Text (Text)+import GHC.TypeLits (ErrorMessage(..))++import Database.Persist.Types import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistEntity-import Data.Monoid (mappend)-import Data.Text (unpack, Text)-import Data.Maybe (catMaybes) -- | Queries against 'Unique' keys (other than the id 'Key'). --@@ -98,6 +109,7 @@ 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. --@@ -127,13 +139,12 @@ case conflict of Nothing -> Just `liftM` insert datum Just _ -> return Nothing+ -- | Update based on a uniqueness constraint or insert: -- -- * insert the new record if it does not exist; -- * If the record exists (matched via it's uniqueness constraint), then update the existing record with the parameters which is passed on as list to the function. --- -- Throws an exception if there is more than 1 uniqueness constraint.- -- -- === __Example usage__ -- -- First, we try to explain 'upsert' using <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1>.@@ -154,7 +165,7 @@ -- > +-----+-----+--------+ -- -- > upsertX :: MonadIO m => [Update User] -> ReaderT SqlBackend m (Maybe (Entity User))- -- > upsertX updates = upsert (User "X" 999) upadtes+ -- > upsertX updates = upsert (User "X" 999) updates -- -- > mXEnt <- upsertX [UserAge +=. 15] --@@ -175,15 +186,21 @@ -- -- > mSpjEnt <- upsertSpj [UserAge +=. 15] --- -- Then, it throws an error message something like "Expected only one unique key, got"+ -- This fails with a compile-time type error alerting us to the fact+ -- that this record has multiple unique keys, and suggests that we look for+ -- 'upsertBy' to select the unique key we want. upsert- :: (MonadIO m, PersistRecordBackend record backend)- => record -- ^ new record to insert- -> [Update record] -- ^ updates to perform if the record already exists- -> ReaderT backend m (Entity record) -- ^ the record in the database after the operation+ :: (MonadIO m, PersistRecordBackend record backend, OnlyOneUniqueKey record)+ => record+ -- ^ new record to insert+ -> [Update record]+ -- ^ updates to perform if the record already exists+ -> ReaderT backend m (Entity record)+ -- ^ the record in the database after the operation upsert record updates = do uniqueKey <- onlyUnique record upsertBy uniqueKey record updates+ -- | Update based on a given uniqueness constraint or insert: -- -- * insert the new record if it does not exist;@@ -241,10 +258,14 @@ -- > +-----+-----+-----+ upsertBy :: (MonadIO m, PersistRecordBackend record backend)- => Unique record -- ^ uniqueness constraint to find by- -> record -- ^ new record to insert- -> [Update record] -- ^ updates to perform if the record already exists- -> ReaderT backend m (Entity record) -- ^ the record in the database after the operation+ => Unique record+ -- ^ uniqueness constraint to find by+ -> record+ -- ^ new record to insert+ -> [Update record]+ -- ^ updates to perform if the record already exists+ -> ReaderT backend m (Entity record)+ -- ^ the record in the database after the operation upsertBy uniqueKey record updates = do mrecord <- getBy uniqueKey maybe (insertEntity record) (`updateGetEntity` updates) mrecord@@ -256,13 +277,90 @@ -- -- * insert new records that do not exist (or violate any unique constraints) -- * replace existing records (matching any unique constraint)+ -- -- @since 2.8.1 putMany- :: (MonadIO m, PersistRecordBackend record backend)- => [record] -- ^ A list of the records you want to insert or replace.+ ::+ ( MonadIO m+ , PersistRecordBackend record backend+ )+ => [record]+ -- ^ A list of the records you want to insert or replace. -> ReaderT backend m () putMany = defaultPutMany +-- | This class is used to ensure that 'upsert' is only called on records+-- that have a single 'Unique' key. The quasiquoter automatically generates+-- working instances for appropriate records, and generates 'TypeError'+-- instances for records that have 0 or multiple unique keys.+--+-- @since 2.10.0+class PersistEntity record => OnlyOneUniqueKey record where+ onlyUniqueP :: record -> Unique record++-- | Given a proxy for a 'PersistEntity' record, this returns the sole+-- 'UniqueDef' for that entity.+--+-- @since 2.10.0+onlyOneUniqueDef+ :: (OnlyOneUniqueKey record, Monad proxy)+ => proxy record+ -> UniqueDef+onlyOneUniqueDef prxy =+ case entityUniques (entityDef prxy) of+ [uniq] -> uniq+ _ -> error "impossible due to OnlyOneUniqueKey constraint"++-- | This is an error message. It is used when writing instances of+-- 'OnlyOneUniqueKey' for an entity that has no unique keys.+--+-- @since 2.10.0+type NoUniqueKeysError ty =+ 'Text "The entity "+ ':<>: 'ShowType ty+ ':<>: 'Text " does not have any unique keys."+ ':$$: 'Text "The function you are trying to call requires a unique key "+ ':<>: 'Text "to be defined on the entity."++-- | This is an error message. It is used when an entity has multiple+-- unique keys, and the function expects a single unique key.+--+-- @since 2.10.0+type MultipleUniqueKeysError ty =+ 'Text "The entity "+ ':<>: 'ShowType ty+ ':<>: 'Text " has multiple unique keys."+ ':$$: 'Text "The function you are trying to call requires only a single "+ ':<>: 'Text "unique key."+ ':$$: 'Text "There is probably a variant of the function with 'By' "+ ':<>: 'Text "appended that will allow you to select a unique key "+ ':<>: 'Text "for the operation."++-- | This class is used to ensure that functions requring at least one+-- unique key are not called with records that have 0 unique keys. The+-- quasiquoter automatically writes working instances for appropriate+-- entities, and generates 'TypeError' instances for records that have+-- 0 unique keys.+--+-- @since 2.10.0+class PersistEntity record => AtLeastOneUniqueKey record where+ requireUniquesP :: record -> NonEmpty (Unique record)++-- | Given a proxy for a record that has an instance of+-- 'AtLeastOneUniqueKey', this returns a 'NonEmpty' list of the+-- 'UniqueDef's for that entity.+--+-- @since 2.10.0+atLeastOneUniqueDef+ :: (AtLeastOneUniqueKey record, Monad proxy)+ => proxy record+ -> NonEmpty UniqueDef+atLeastOneUniqueDef prxy =+ case entityUniques (entityDef prxy) of+ (x:xs) -> x :| xs+ _ ->+ error "impossible due to AtLeastOneUniqueKey record constraint"+ -- | 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'.@@ -278,9 +376,12 @@ -- -- First three lines return 'Left' because there're duplicates in given record's uniqueness constraints. While the last line returns a new key as 'Right'. insertBy- :: (MonadIO m- ,PersistUniqueWrite backend- ,PersistRecordBackend record backend)+ ::+ ( MonadIO m+ , PersistUniqueWrite backend+ , PersistRecordBackend record backend+ , AtLeastOneUniqueKey record+ ) => record -> ReaderT backend m (Either (Entity record) (Key record)) insertBy val = do res <- getByValue val@@ -288,17 +389,6 @@ 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- -- | Like 'insertEntity', but returns 'Nothing' when the record -- couldn't be inserted because of a uniqueness constraint. --@@ -351,26 +441,18 @@ -- -- > mSimonConst <- onlySimonConst ----- @mSimonConst@ would be Simon's uniqueness constraint. Note that @onlyUnique@ doesn't work if there're more than two constraints.+-- @mSimonConst@ would be Simon's uniqueness constraint. Note that+-- @onlyUnique@ doesn't work if there're more than two constraints. It will+-- fail with a type error instead. onlyUnique- :: (MonadIO m- ,PersistUniqueWrite backend- ,PersistRecordBackend record backend)+ ::+ ( MonadIO m+ , PersistUniqueWrite backend+ , PersistRecordBackend record backend+ , OnlyOneUniqueKey record+ ) => 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 record)- => record -> Either [Unique record] (Unique record)-onlyUniqueEither record =- case persistUniqueKeys record of- [u] -> Right u- us -> Left us+onlyUnique = pure . onlyUniqueP -- | A modification of 'getBy', which takes the 'PersistEntity' itself instead -- of a 'Unique' record. Returns a record matching /one/ of the unique keys. This@@ -394,12 +476,35 @@ -- > | 1 | SPJ | 40 | -- > +----+------+-----+ getByValue- :: (MonadIO m- ,PersistUniqueRead backend- ,PersistRecordBackend record backend)+ :: forall record m backend.+ ( MonadIO m+ , PersistUniqueRead backend+ , PersistRecordBackend record backend+ , AtLeastOneUniqueKey record+ ) => record -> ReaderT backend m (Maybe (Entity record))-getByValue record =- checkUniques =<< requireUniques record (persistUniqueKeys record)+getByValue record = do+ let uniqs = requireUniquesP record+ getByValueUniques (NEL.toList uniqs)++-- | Retrieve a record from the database using the given unique keys. It+-- will attempt to find a matching record for each 'Unique' in the list,+-- and returns the first one that has a match.+--+-- Returns 'Nothing' if you provide an empty list ('[]') or if no value+-- matches in the database.+--+-- @since 2.10.0+getByValueUniques+ ::+ ( MonadIO m+ , PersistUniqueRead backend+ , PersistRecordBackend record backend+ )+ => [Unique record]+ -> ReaderT backend m (Maybe (Entity record))+getByValueUniques uniqs =+ checkUniques uniqs where checkUniques [] = return Nothing checkUniques (x:xs) = do@@ -408,21 +513,6 @@ Nothing -> checkUniques xs Just z -> return $ Just z -requireUniques- :: (MonadIO m, PersistEntity record)- => record -> [Unique record] -> m [Unique record]-requireUniques record [] = liftIO $ throwIO $ userError errorMsg- where- errorMsg = "getByValue: " `Data.Monoid.mappend` unpack (recordName record) `mappend` " does not have any Unique"--requireUniques _ xs = return xs---- TODO: expose this to users-recordName- :: (PersistEntity record)- => record -> Text-recordName = unHaskellName . entityHaskell . entityDef . Just- -- | 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.@@ -432,11 +522,10 @@ -- -- @since 1.2.2.0 replaceUnique- :: (MonadIO m- ,Eq record- ,Eq (Unique record)- ,PersistRecordBackend record backend- ,PersistUniqueWrite backend)+ :: ( MonadIO m+ , Eq (Unique record)+ , PersistRecordBackend record backend+ , PersistUniqueWrite backend ) => Key record -> record -> ReaderT backend m (Maybe (Unique record)) replaceUnique key datumNew = getJust key >>= replaceOriginal where@@ -476,7 +565,6 @@ checkUniqueKeys :: (MonadIO m- ,PersistEntity record ,PersistUniqueRead backend ,PersistRecordBackend record backend) => [Unique record] -> ReaderT backend m (Maybe (Unique record))@@ -501,17 +589,23 @@ => [record] -> ReaderT backend m () defaultPutMany [] = return ()-defaultPutMany rsD = do- let uKeys = persistUniqueKeys . head $ rsD- case uKeys of+defaultPutMany rsD@(e:_) = do+ case persistUniqueKeys e of [] -> insertMany_ rsD _ -> go where go = do- let rs = nubBy ((==) `on` persistUniqueKeyValues) (reverse rsD)+ -- deduplicate the list of records in Haskell by unique key. The+ -- previous implementation used Data.List.nubBy which is O(n^2)+ -- complexity.+ let rs = map snd+ . Map.toList+ . Map.fromList+ . map (\r -> (persistUniqueKeyValues r, r))+ $ rsD -- lookup record(s) by their unique key- mEsOld <- mapM getByValue rs+ mEsOld <- mapM (getByValueUniques . persistUniqueKeys) rs -- find pre-existing entities and corresponding (incoming) records let merge (Just x) y = Just (x, y)@@ -534,7 +628,8 @@ -- replace existing records mapM_ (uncurry replace) krs --- | The _essence_ of a unique record.--- useful for comaparing records in haskell land for uniqueness equality.+-- | This function returns a list of 'PersistValue' that correspond to the+-- 'Unique' keys on that record. This is useful for comparing two @record@s+-- for equality only on the basis of their 'Unique' keys. persistUniqueKeyValues :: PersistEntity record => record -> [PersistValue]-persistUniqueKeyValues r = concat $ map persistUniqueToValues $ persistUniqueKeys r+persistUniqueKeyValues = concatMap persistUniqueToValues . persistUniqueKeys
Database/Persist/Quasi.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ViewPatterns #-}@@ -16,16 +15,17 @@ ) where import Prelude hiding (lines)-import Database.Persist.Types++import Control.Arrow ((&&&))+import Control.Monad (msum, mplus) import Data.Char+import Data.List (find, foldl')+import qualified Data.Map as M import Data.Maybe (mapMaybe, fromMaybe, maybeToList)+import Data.Monoid (mappend) import Data.Text (Text) import qualified Data.Text as T-import Control.Arrow ((&&&))-import qualified Data.Map as M-import Data.List (find, foldl')-import Data.Monoid (mappend)-import Control.Monad (msum, mplus)+import Database.Persist.Types data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show @@ -310,7 +310,9 @@ derives extras isSum+ comments where+ comments = Nothing entName = HaskellName name' (isSum, name') = case T.uncons name of@@ -358,6 +360,7 @@ , fieldReference = ForeignRef entName defaultReferenceTypeCon , fieldAttrs = [] , fieldStrict = True+ , fieldComments = Nothing } defaultReferenceTypeCon :: FieldType@@ -395,6 +398,7 @@ , fieldAttrs = rest , fieldStrict = fromMaybe (psStrictFields ps) mstrict , fieldReference = NoReference+ , fieldComments = Nothing } where (mstrict, n)
Database/Persist/Sql.hs view
@@ -23,6 +23,9 @@ , decorateSQLWithLimitOffset ) where +import Control.Monad.IO.Class+import Control.Monad.Trans.Reader (ReaderT, ask)+ import Database.Persist import Database.Persist.Sql.Types import Database.Persist.Sql.Types.Internal (IsolationLevel (..))@@ -35,8 +38,6 @@ import Database.Persist.Sql.Orphan.PersistQuery import Database.Persist.Sql.Orphan.PersistStore import Database.Persist.Sql.Orphan.PersistUnique ()-import Control.Monad.IO.Class-import Control.Monad.Trans.Reader (ReaderT, ask) -- | Commit the current transaction and begin a new one. --
Database/Persist/Sql/Class.hs view
@@ -1,48 +1,37 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE PatternGuards #-}--#if !MIN_VERSION_base(4,8,0)-{-# LANGUAGE OverlappingInstances #-}-#endif- module Database.Persist.Sql.Class ( RawSql (..) , PersistFieldSql (..) ) where -import Control.Applicative as A ((<$>), (<*>))-import Database.Persist-import Data.Monoid ((<>))-import Database.Persist.Sql.Types-import Data.Text (Text, intercalate, pack)-import Data.Maybe (fromMaybe)+import Data.Bits (bitSizeMaybe)+import Data.ByteString (ByteString) import Data.Fixed+import Data.Int+import qualified Data.IntMap as IM+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>)) import Data.Proxy (Proxy)+import qualified Data.Set as S+import Data.Text (Text, intercalate, pack) import qualified Data.Text as T import qualified Data.Text.Lazy as TL-import qualified Data.Map as M-import qualified Data.IntMap as IM-import qualified Data.Set as S import Data.Time (UTCTime, TimeOfDay, Day)-import Data.Int+import qualified Data.Vector as V import Data.Word-import Data.ByteString (ByteString)+import Numeric.Natural (Natural) import Text.Blaze.Html (Html)-import Data.Bits (bitSizeMaybe)-import qualified Data.Vector as V -#if MIN_VERSION_base(4,8,0)-import Numeric.Natural (Natural)-#endif+import Database.Persist+import Database.Persist.Sql.Types + -- | Class for data types that may be retrived from a 'rawSql' -- query. class RawSql a where@@ -60,7 +49,7 @@ instance PersistField a => RawSql (Single a) where rawSqlCols _ _ = (1, []) rawSqlColCountReason _ = "one column for a 'Single' data type"- rawSqlProcessRow [pv] = Single A.<$> fromPersistValue pv+ rawSqlProcessRow [pv] = Single <$> fromPersistValue pv rawSqlProcessRow _ = Left $ pack "RawSql (Single a): wrong number of columns." instance@@ -89,8 +78,8 @@ 1 -> "one column for an 'Entity' data type without fields" n -> show n ++ " columns for an 'Entity' data type" rawSqlProcessRow row = case splitAt nKeyFields row of- (rowKey, rowVal) -> Entity A.<$> keyFromValues rowKey- A.<*> fromPersistValues rowVal+ (rowKey, rowVal) -> Entity <$> keyFromValues rowKey+ <*> fromPersistValues rowVal where nKeyFields = length $ entityKeyFields entDef entDef = entityDef (Nothing :: Maybe record)@@ -272,12 +261,7 @@ sqlType :: Proxy a -> SqlType #ifndef NO_OVERLAP--#if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPING #-} PersistFieldSql [Char] where-#else-instance PersistFieldSql [Char] where-#endif sqlType _ = SqlString #endif @@ -321,11 +305,7 @@ sqlType _ = SqlTime instance PersistFieldSql UTCTime where sqlType _ = SqlDayTime-#if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPABLE #-} PersistFieldSql a => PersistFieldSql [a] where-#else-instance PersistFieldSql a => PersistFieldSql [a] where-#endif sqlType _ = SqlString instance PersistFieldSql a => PersistFieldSql (V.Vector a) where sqlType _ = SqlString@@ -352,10 +332,8 @@ instance PersistFieldSql Rational where sqlType _ = SqlNumeric 32 20 -- need to make this field big enough to handle Rational to Mumber string conversion for ODBC -#if MIN_VERSION_base(4,8,0) instance PersistFieldSql Natural where sqlType _ = SqlInt64-#endif -- An embedded Entity instance (PersistField record, PersistEntity record) => PersistFieldSql (Entity record) where
Database/Persist/Sql/Internal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} -- | Intended for creating new backends. module Database.Persist.Sql.Internal@@ -6,13 +5,14 @@ , defaultAttribute ) where -import Database.Persist.Types-import Database.Persist.Quasi import Data.Char (isSpace)+import Data.Monoid (mappend, mconcat) import Data.Text (Text) import qualified Data.Text as T-import Data.Monoid (mappend, mconcat)++import Database.Persist.Quasi import Database.Persist.Sql.Types+import Database.Persist.Types defaultAttribute :: [Attr] -> Maybe Text defaultAttribute [] = Nothing
Database/Persist/Sql/Migration.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-} module Database.Persist.Sql.Migration ( parseMigration , parseMigration'@@ -18,15 +16,16 @@ ) where -import Control.Monad.Trans.Class (MonadTrans (..))+import Control.Monad (liftM, unless) import Control.Monad.IO.Unlift-import Control.Monad.Trans.Writer+import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Trans.Reader (ReaderT (..), ask)-import Control.Monad (liftM, unless)+import Control.Monad.Trans.Writer import Data.Text (Text, unpack, snoc, isPrefixOf, pack) import qualified Data.Text.IO import System.IO import System.IO.Silently (hSilence)+ import Database.Persist.Sql.Types import Database.Persist.Sql.Raw import Database.Persist.Types@@ -83,7 +82,7 @@ -- | Same as 'runMigration', but returns a list of the SQL commands executed -- instead of printing them to stderr.-runMigrationSilent :: (MonadUnliftIO m, MonadIO m)+runMigrationSilent :: MonadUnliftIO m => Migration -> ReaderT SqlBackend m [Text] runMigrationSilent m = withRunInIO $ \run ->
Database/Persist/Sql/Orphan/PersistQuery.hs view
@@ -1,14 +1,27 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE LambdaCase #-}+ {-# OPTIONS_GHC -fno-warn-orphans #-}+ module Database.Persist.Sql.Orphan.PersistQuery ( deleteWhereCount , updateWhereCount , decorateSQLWithLimitOffset ) where +import Control.Exception (throwIO)+import Control.Monad.IO.Class+import Control.Monad.Trans.Reader (ReaderT, ask, withReaderT)+import Data.ByteString.Char8 (readInteger)+import Data.Conduit+import qualified Data.Conduit.List as CL+import Data.Int (Int64)+import Data.List (transpose, inits, find)+import Data.Maybe (isJust)+import Data.Monoid (Monoid (..), (<>))+import qualified Data.Text as T+import Data.Text (Text)+ import Database.Persist hiding (updateField) import Database.Persist.Sql.Util ( entityColumnNames, parseEntityValues, isIdField, updatePersistValue@@ -16,18 +29,6 @@ import Database.Persist.Sql.Types import Database.Persist.Sql.Raw import Database.Persist.Sql.Orphan.PersistStore (withRawQuery)-import qualified Data.Text as T-import Data.Text (Text)-import Data.Monoid (Monoid (..), (<>))-import Data.Int (Int64)-import Control.Monad.IO.Class-import Control.Monad.Trans.Reader (ReaderT, ask, withReaderT)-import Control.Exception (throwIO)-import qualified Data.Conduit.List as CL-import Data.Conduit-import Data.ByteString.Char8 (readInteger)-import Data.Maybe (isJust)-import Data.List (transpose, inits, find) -- orphaned instance for convenience of modularity instance PersistQueryRead SqlBackend where@@ -147,10 +148,10 @@ -- | Same as 'deleteWhere', but returns the number of rows affected. -- -- @since 1.1.5-deleteWhereCount :: (PersistEntity val, MonadIO m, PersistEntityBackend val ~ SqlBackend, IsSqlBackend backend)+deleteWhereCount :: (PersistEntity val, MonadIO m, PersistEntityBackend val ~ SqlBackend, BackendCompatible SqlBackend backend) => [Filter val] -> ReaderT backend m Int64-deleteWhereCount filts = withReaderT persistBackend $ do+deleteWhereCount filts = withReaderT projectBackend $ do conn <- ask let t = entityDef $ dummyFromFilts filts let wher = if null filts@@ -166,12 +167,12 @@ -- | Same as 'updateWhere', but returns the number of rows affected. -- -- @since 1.1.5-updateWhereCount :: (PersistEntity val, MonadIO m, SqlBackend ~ PersistEntityBackend val, IsSqlBackend backend)+updateWhereCount :: (PersistEntity val, MonadIO m, SqlBackend ~ PersistEntityBackend val, BackendCompatible SqlBackend backend) => [Filter val] -> [Update val] -> ReaderT backend m Int64 updateWhereCount _ [] = return 0-updateWhereCount filts upds = withReaderT persistBackend $ do+updateWhereCount filts upds = withReaderT projectBackend $ do conn <- ask let wher = if null filts then ""@@ -189,7 +190,7 @@ where t = entityDef $ dummyFromFilts filts -fieldName :: forall record typ. (PersistEntity record, PersistEntityBackend record ~ SqlBackend) => EntityField record typ -> DBName+fieldName :: forall record typ. (PersistEntity record, PersistEntityBackend record ~ SqlBackend) => EntityField record typ -> DBName fieldName f = fieldDB $ persistFieldDef f dummyFromFilts :: [Filter v] -> Maybe v@@ -320,8 +321,11 @@ fromPersistList (PersistList xs) = xs fromPersistList other = error $ "expected PersistList but found " ++ show other - filterValueToPersistValues :: forall a. PersistField a => Either a [a] -> [PersistValue]- filterValueToPersistValues v = map toPersistValue $ either return id v+ filterValueToPersistValues :: forall a. PersistField a => FilterValue a -> [PersistValue]+ filterValueToPersistValues = \case+ FilterValue a -> [toPersistValue a]+ FilterValues as -> toPersistValue <$> as+ UnsafeValue x -> [toPersistValue x] orNullSuffix = case orNull of@@ -339,10 +343,14 @@ else id) $ connEscapeName conn $ fieldName field qmarks = case value of- Left _ -> "?"- Right x ->- let x' = filter (/= PersistNull) $ map toPersistValue x- in "(" <> T.intercalate "," (map (const "?") x') <> ")"+ FilterValue{} -> "?"+ UnsafeValue{} -> "?"+ FilterValues xs ->+ let parens a = "(" <> a <> ")"+ commas = T.intercalate ","+ toQs = fmap $ const "?"+ nonNulls = filter (/= PersistNull) $ map toPersistValue xs+ in parens . commas . toQs $ nonNulls showSqlFilter Eq = "=" showSqlFilter Ne = "<>" showSqlFilter Gt = ">"
Database/Persist/Sql/Orphan/PersistStore.hs view
@@ -1,13 +1,7 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Rank2Types #-}+ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-} module Database.Persist.Sql.Orphan.PersistStore ( withRawQuery@@ -20,34 +14,37 @@ , fieldDBName ) where -import Database.Persist-import Database.Persist.Sql.Types-import Database.Persist.Sql.Raw-import Database.Persist.Sql.Util (- dbIdColumns, keyAndEntityColumnNames, parseEntityValues, entityColumnNames- , updatePersistValue, mkUpdateText, commaSeparated)-import Data.Conduit (ConduitM, (.|), runConduit)-import qualified Data.Conduit.List as CL-import qualified Data.Text as T-import Data.Text (Text, unpack)-import Data.Monoid (mappend, (<>))+import Control.Exception (throwIO) import Control.Monad.IO.Class-import Data.ByteString.Char8 (readInteger)-import Data.Maybe (isJust)-import Data.List (find, nubBy)-import Data.Void (Void) import Control.Monad.Trans.Reader (ReaderT, ask, withReaderT)+import Data.Conduit (ConduitM, (.|), runConduit)+import qualified Data.Conduit.List as CL import Data.Acquire (with)+import qualified Data.Aeson as A+import Data.ByteString.Char8 (readInteger)+import Data.Conduit (ConduitM, (.|), runConduit)+import qualified Data.Conduit.List as CL+import qualified Data.Foldable as Foldable+import Data.Function (on) import Data.Int (Int64)+import Data.List (find, nubBy)+import qualified Data.Map as Map+import Data.Maybe (isJust)+import Data.Monoid (mappend, (<>))+import Data.Text (Text, unpack)+import qualified Data.Text as T+import Data.Void (Void) import Web.PathPieces (PathPiece) import Web.HttpApiData (ToHttpApiData, FromHttpApiData)-import Database.Persist.Sql.Class (PersistFieldSql)-import qualified Data.Aeson as A-import Control.Exception (throwIO)++import Database.Persist import Database.Persist.Class ()-import qualified Data.Map as Map-import qualified Data.Foldable as Foldable-import Data.Function (on)+import Database.Persist.Sql.Class (PersistFieldSql)+import Database.Persist.Sql.Raw+import Database.Persist.Sql.Types+import Database.Persist.Sql.Util (+ dbIdColumns, keyAndEntityColumnNames, parseEntityValues, entityColumnNames+ , updatePersistValue, mkUpdateText, commaSeparated) withRawQuery :: MonadIO m => Text@@ -82,11 +79,10 @@ -- which does not operate in a Monad getTableName :: forall record m backend. ( PersistEntity record- , PersistEntityBackend record ~ SqlBackend- , IsSqlBackend backend+ , BackendCompatible SqlBackend backend , Monad m ) => record -> ReaderT backend m Text-getTableName rec = withReaderT persistBackend $ do+getTableName rec = withReaderT projectBackend $ do conn <- ask return $ connEscapeName conn $ tableDBName rec @@ -102,11 +98,11 @@ getFieldName :: forall record typ m backend. ( PersistEntity record , PersistEntityBackend record ~ SqlBackend- , IsSqlBackend backend+ , BackendCompatible SqlBackend backend , Monad m ) => EntityField record typ -> ReaderT backend m Text-getFieldName rec = withReaderT persistBackend $ do+getFieldName rec = withReaderT projectBackend $ do conn <- ask return $ connEscapeName conn $ fieldDBName rec
Database/Persist/Sql/Orphan/PersistUnique.hs view
@@ -1,33 +1,32 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}- module Database.Persist.Sql.Orphan.PersistUnique () where import Control.Exception (throwIO) import Control.Monad.IO.Class (liftIO, MonadIO)+import Control.Monad.Trans.Reader (ask, withReaderT, ReaderT)+import qualified Data.Conduit.List as CL+import Data.Function (on)+import Data.List (nubBy)+import Data.Monoid (mappend)+import qualified Data.Text as T+ import Database.Persist-import Database.Persist.Class.PersistUnique (defaultPutMany, persistUniqueKeyValues)+import Database.Persist.Class.PersistUnique (defaultPutMany, persistUniqueKeyValues, onlyOneUniqueDef) import Database.Persist.Sql.Types import Database.Persist.Sql.Raw import Database.Persist.Sql.Orphan.PersistStore (withRawQuery) import Database.Persist.Sql.Util (dbColumns, parseEntityValues, updatePersistValue, mkUpdateText')-import qualified Data.Text as T-import Data.Monoid (mappend)-import qualified Data.Conduit.List as CL-import Control.Monad.Trans.Reader (ask, withReaderT, ReaderT)-import Data.List (nubBy)-import Data.Function (on) defaultUpsert- :: (MonadIO m- ,PersistEntity record- ,PersistUniqueWrite backend- ,PersistEntityBackend record ~ BaseBackend backend)+ ::+ ( MonadIO m+ , PersistEntity record+ , PersistUniqueWrite backend+ , PersistEntityBackend record ~ BaseBackend backend+ , OnlyOneUniqueKey record+ ) => record -> [Update record] -> ReaderT backend m (Entity record) defaultUpsert record updates = do uniqueKey <- onlyUnique record@@ -45,7 +44,7 @@ [] -> defaultUpsert record updates _:_ -> do let upds = T.intercalate "," $ map mkUpdateText updates- sql = upsertSql t upds+ sql = upsertSql t (pure (onlyOneUniqueDef (Just record))) upds vals = map toPersistValue (toPersistFields record) ++ map updatePersistValue updates ++ unqs uniqueKey
Database/Persist/Sql/Raw.hs view
@@ -1,27 +1,24 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-} module Database.Persist.Sql.Raw where -import Database.Persist-import Database.Persist.Sql.Types-import Database.Persist.Sql.Class-import qualified Data.Map as Map+import Control.Exception (throwIO)+import Control.Monad (when, liftM) import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Logger (logDebugNS, runLoggingT) import Control.Monad.Reader (ReaderT, ask, MonadReader)+import Control.Monad.Trans.Resource (MonadResource,release) import Data.Acquire (allocateAcquire, Acquire, mkAcquire, with)+import Data.Conduit import Data.IORef (writeIORef, readIORef, newIORef)-import Control.Exception (throwIO)-import Control.Monad (when, liftM)-import Data.Text (Text, pack)-import Control.Monad.Logger (logDebugNS, runLoggingT)+import qualified Data.Map as Map import Data.Int (Int64)+import Data.Text (Text, pack) import qualified Data.Text as T-import Data.Conduit-import Control.Monad.Trans.Resource (MonadResource,release) -rawQuery :: (MonadResource m, MonadReader env m, HasPersistBackend env, BaseBackend env ~ SqlBackend)+import Database.Persist+import Database.Persist.Sql.Types+import Database.Persist.Sql.Class++rawQuery :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env) => Text -> [PersistValue] -> ConduitM () [PersistValue] m ()@@ -32,12 +29,12 @@ release releaseKey rawQueryRes- :: (MonadIO m1, MonadIO m2, IsSqlBackend env)+ :: (MonadIO m1, MonadIO m2, BackendCompatible SqlBackend env) => Text -> [PersistValue] -> ReaderT env m1 (Acquire (ConduitM () [PersistValue] m2 ())) rawQueryRes sql vals = do- conn <- persistBackend `liftM` ask+ conn <- projectBackend `liftM` ask let make = do runLoggingT (logDebugNS (pack "SQL") $ T.append sql $ pack $ "; " ++ show vals) (connLogFunc conn)@@ -86,11 +83,8 @@ let stmt = Statement { stmtFinalize = do active <- readIORef iactive- if active- then do- stmtFinalize stmt'- writeIORef iactive False- else return ()+ when active $ do stmtFinalize stmt'+ writeIORef iactive False , stmtReset = do active <- readIORef iactive when active $ stmtReset stmt'@@ -109,7 +103,8 @@ return stmt -- | Execute a raw SQL statement and return its results as a--- list.+-- list. If you do not expect a return value, use of+-- `rawExecute` is recommended. -- -- If you're using 'Entity'@s@ (which is quite likely), then you -- /must/ use entity selection placeholders (double question@@ -145,19 +140,19 @@ -- deriving Show -- |] -- @--- +-- -- Examples based on the above schema:--- --- @ +--+-- @ -- getPerson :: MonadIO m => ReaderT SqlBackend m [Entity Person] -- getPerson = rawSql "select ?? from person where name=?" [PersistText "john"]--- +-- -- getAge :: MonadIO m => ReaderT SqlBackend m [Single Int] -- getAge = rawSql "select person.age from person where name=?" [PersistText "john"]--- +-- -- getAgeName :: MonadIO m => ReaderT SqlBackend m [(Single Int, Single Text)] -- getAgeName = rawSql "select person.age, person.name from person where name=?" [PersistText "john"]--- +-- -- getPersonBlog :: MonadIO m => ReaderT SqlBackend m [(Entity Person, Entity BlogPost)] -- getPersonBlog = rawSql "select ??,?? from person,blog_post where person.id = blog_post.author_id" [] -- @@@ -173,7 +168,7 @@ -- > {-# LANGUAGE QuasiQuotes #-} -- > {-# LANGUAGE TemplateHaskell #-} -- > {-# LANGUAGE TypeFamilies #-}--- > +-- > -- > import Control.Monad.IO.Class (liftIO) -- > import Control.Monad.Logger (runStderrLoggingT) -- > import Database.Persist@@ -182,32 +177,32 @@ -- > import Database.Persist.Sql -- > import Database.Persist.Postgresql -- > import Database.Persist.TH--- > +-- > -- > share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -- > Person -- > name String -- > age Int Maybe -- > deriving Show -- > |]--- > +-- > -- > conn = "host=localhost dbname=new_db user=postgres password=postgres port=5432"--- > +-- > -- > getPerson :: MonadIO m => ReaderT SqlBackend m [Entity Person] -- > getPerson = rawSql "select ?? from person where name=?" [PersistText "sibi"]--- > +-- > -- > liftSqlPersistMPool y x = liftIO (runSqlPersistMPool y x)--- > +-- > -- > main :: IO () -- > main = runStderrLoggingT $ withPostgresqlPool conn 10 $ liftSqlPersistMPool $ do -- > runMigration migrateAll -- > xs <- getPerson -- > liftIO (print xs)--- > +-- > -rawSql :: (RawSql a, MonadIO m)+rawSql :: (RawSql a, MonadIO m, BackendCompatible SqlBackend backend) => Text -- ^ SQL statement, possibly with placeholders. -> [PersistValue] -- ^ Values to fill the placeholders.- -> ReaderT SqlBackend m [a]+ -> ReaderT backend m [a] rawSql stmt = run where getType :: (x -> m [a]) -> a@@ -235,7 +230,7 @@ ] run params = do- conn <- ask+ conn <- projectBackend `liftM` ask let (colCount, colSubsts) = rawSqlCols (connEscapeName conn) x withStmt' colSubsts params $ firstRow colCount
Database/Persist/Sql/Run.hs view
@@ -1,25 +1,22 @@-{-# 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.Types.Internal (IsolationLevel)-import Database.Persist.Sql.Raw-import Data.Pool as P+import Control.Exception (bracket, mask, onException)+import Control.Monad (liftM)+import Control.Monad.IO.Unlift+import Control.Monad.Logger import Control.Monad.Trans.Reader hiding (local) import Control.Monad.Trans.Resource-import Control.Monad.Logger-import Control.Exception (onException, bracket)-import Control.Monad.IO.Unlift-import Control.Exception (mask)-import System.Timeout (timeout) import Data.IORef (readIORef)+import Data.Pool as P import qualified Data.Map as Map-import Control.Monad (liftM)+import System.Timeout (timeout) +import Database.Persist.Class.PersistStore+import Database.Persist.Sql.Types+import Database.Persist.Sql.Types.Internal (IsolationLevel)+import Database.Persist.Sql.Raw+ -- | Get a connection from the pool, run the given action, and then return the -- connection to the pool. --@@ -27,7 +24,7 @@ -- was buggy and caused more problems than it solved. Since version 2.1.2, it -- performs no timeout checks. runSqlPool- :: (MonadUnliftIO m, IsSqlBackend backend)+ :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Pool backend -> m a runSqlPool r pconn = withRunInIO $ \run -> withResource pconn $ run . runSqlConn r @@ -35,7 +32,7 @@ -- -- @since 2.9.0 runSqlPoolWithIsolation- :: (MonadUnliftIO m, IsSqlBackend backend)+ :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Pool backend -> IsolationLevel -> m a runSqlPoolWithIsolation r pconn i = withRunInIO $ \run -> withResource pconn $ run . (\conn -> runSqlConnWithIsolation r conn i) @@ -61,9 +58,9 @@ return ret {-# INLINABLE withResourceTimeout #-} -runSqlConn :: (MonadUnliftIO m, IsSqlBackend backend) => ReaderT backend m a -> backend -> m a+runSqlConn :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> backend -> m a runSqlConn r conn = withRunInIO $ \runInIO -> mask $ \restore -> do- let conn' = persistBackend conn+ let conn' = projectBackend conn getter = getStmtConn conn' restore $ connBegin conn' getter Nothing x <- onException@@ -75,9 +72,9 @@ -- | Like 'runSqlConn', but supports specifying an isolation level. -- -- @since 2.9.0-runSqlConnWithIsolation :: (MonadUnliftIO m, IsSqlBackend backend) => ReaderT backend m a -> backend -> IsolationLevel -> m a+runSqlConnWithIsolation :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> backend -> IsolationLevel -> m a runSqlConnWithIsolation r conn isolation = withRunInIO $ \runInIO -> mask $ \restore -> do- let conn' = persistBackend conn+ let conn' = projectBackend conn getter = getStmtConn conn' restore $ connBegin conn' getter $ Just isolation x <- onException@@ -87,22 +84,22 @@ return x runSqlPersistM- :: (IsSqlBackend backend)+ :: (BackendCompatible SqlBackend backend) => ReaderT backend (NoLoggingT (ResourceT IO)) a -> backend -> IO a runSqlPersistM x conn = runResourceT $ runNoLoggingT $ runSqlConn x conn runSqlPersistMPool- :: (IsSqlBackend backend)+ :: (BackendCompatible SqlBackend backend) => ReaderT backend (NoLoggingT (ResourceT IO)) a -> Pool backend -> IO a runSqlPersistMPool x pool = runResourceT $ runNoLoggingT $ runSqlPool x pool liftSqlPersistMPool- :: (MonadIO m, IsSqlBackend backend)+ :: (MonadIO m, BackendCompatible SqlBackend backend) => ReaderT backend (NoLoggingT (ResourceT IO)) a -> Pool backend -> m a liftSqlPersistMPool x pool = liftIO (runSqlPersistMPool x pool) withSqlPool- :: (MonadLogger m, MonadUnliftIO m, IsSqlBackend backend)+ :: (MonadLogger m, MonadUnliftIO m, BackendCompatible SqlBackend backend) => (LogFunc -> IO backend) -- ^ create a new connection -> Int -- ^ connection count -> (Pool backend -> m a)@@ -113,7 +110,7 @@ (unliftIO u . f) createSqlPool- :: (MonadLogger m, MonadUnliftIO m, IsSqlBackend backend)+ :: (MonadLogger m, MonadUnliftIO m, BackendCompatible SqlBackend backend) => (LogFunc -> IO backend) -> Int -> m (Pool backend)@@ -144,7 +141,7 @@ -- > {-# LANGUAGE TemplateHaskell#-} -- > {-# LANGUAGE QuasiQuotes#-} -- > {-# LANGUAGE GeneralizedNewtypeDeriving #-}--- > +-- > -- > import Control.Monad.IO.Class (liftIO) -- > import Control.Monad.Logger -- > import Conduit@@ -152,14 +149,14 @@ -- > import Database.Sqlite -- > import Database.Persist.Sqlite -- > import Database.Persist.TH--- > +-- > -- > share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -- > Person -- > name String -- > age Int Maybe -- > deriving Show -- > |]--- > +-- > -- > openConnection :: LogFunc -> IO SqlBackend -- > openConnection logfn = do -- > conn <- open "/home/sibi/test.db"@@ -181,10 +178,10 @@ -- -- > Migrating: CREATE TABLE "person"("id" INTEGER PRIMARY KEY,"name" VARCHAR NOT NULL,"age" INTEGER NULL) -- > [Entity {entityKey = PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 1}}, entityVal = Person {personName = "John doe", personAge = Just 35}},Entity {entityKey = PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 2}}, entityVal = Person {personName = "Hema", personAge = Just 36}}]--- +-- withSqlConn- :: (MonadUnliftIO m, MonadLogger m, IsSqlBackend backend)+ :: (MonadUnliftIO m, MonadLogger m, BackendCompatible SqlBackend backend) => (LogFunc -> IO backend) -> (backend -> m a) -> m a withSqlConn open f = do logFunc <- askLogFunc@@ -193,7 +190,7 @@ close' (run . f) -close' :: (IsSqlBackend backend) => backend -> IO ()+close' :: (BackendCompatible SqlBackend backend) => backend -> IO () close' conn = do- readIORef (connStmtMap $ persistBackend conn) >>= mapM_ stmtFinalize . Map.elems- connClose $ persistBackend conn+ readIORef (connStmtMap $ projectBackend conn) >>= mapM_ stmtFinalize . Map.elems+ connClose $ projectBackend conn
Database/Persist/Sql/Types.hs view
@@ -1,14 +1,3 @@-{-# 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 ( module Database.Persist.Sql.Types , SqlBackend (..), SqlReadBackend (..), SqlWriteBackend (..)@@ -18,19 +7,16 @@ ) where import Control.Exception (Exception)-import Control.Monad.Trans.Resource (ResourceT) import Control.Monad.Logger (NoLoggingT) import Control.Monad.Trans.Reader (ReaderT (..))+import Control.Monad.Trans.Resource (ResourceT) import Control.Monad.Trans.Writer (WriterT)-import Data.Typeable (Typeable)-import Database.Persist.Types-import Database.Persist.Sql.Types.Internal import Data.Pool (Pool) import Data.Text (Text)+import Data.Typeable (Typeable) --- | Deprecated synonym for @SqlBackend@.-type Connection = SqlBackend-{-# DEPRECATED Connection "Please use SqlBackend instead" #-}+import Database.Persist.Types+import Database.Persist.Sql.Types.Internal data Column = Column { cName :: !DBName@@ -49,9 +35,6 @@ instance Exception PersistentSqlException type SqlPersistT = ReaderT SqlBackend--type SqlPersist = SqlPersistT-{-# DEPRECATED SqlPersist "Please use SqlPersistT instead" #-} type SqlPersistM = SqlPersistT (NoLoggingT (ResourceT IO))
Database/Persist/Sql/Types/Internal.hs view
@@ -1,16 +1,11 @@-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-+{-# LANGUAGE RankNTypes #-} module Database.Persist.Sql.Types.Internal ( HasPersistBackend (..) , IsPersistBackend (..)- , SqlReadBackend (unSqlReadBackend)- , SqlWriteBackend (unSqlWriteBackend)+ , SqlReadBackend (..)+ , SqlWriteBackend (..) , readToUnknown , readToWrite , writeToUnknown@@ -27,6 +22,7 @@ , IsSqlBackend ) where +import Data.List.NonEmpty (NonEmpty(..)) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Logger (LogSource, LogLevel) import Control.Monad.Trans.Class (lift)@@ -40,6 +36,9 @@ import Data.String (IsString) import Data.Text (Text) import Data.Typeable (Typeable)+import Language.Haskell.TH.Syntax (Loc)+import System.Log.FastLogger (LogStr)+ import Database.Persist.Class ( HasPersistBackend (..) , PersistQueryRead, PersistQueryWrite@@ -49,8 +48,6 @@ ) 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 () @@ -90,7 +87,7 @@ -- ^ 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'.- , connUpsertSql :: Maybe (EntityDef -> Text -> Text)+ , connUpsertSql :: Maybe (EntityDef -> NonEmpty UniqueDef -> Text -> Text) -- ^ Some databases support performing UPSERT _and_ RETURN entity -- in a single call. --@@ -157,6 +154,8 @@ mkPersistBackend = id -- | An SQL backend which can only handle read queries+--+-- The constructor was exposed in 2.10.0. newtype SqlReadBackend = SqlReadBackend { unSqlReadBackend :: SqlBackend } deriving Typeable instance HasPersistBackend SqlReadBackend where type BaseBackend SqlReadBackend = SqlBackend@@ -165,6 +164,8 @@ mkPersistBackend = SqlReadBackend -- | An SQL backend which can handle read or write queries+--+-- The constructor was exposed in 2.10.0 newtype SqlWriteBackend = SqlWriteBackend { unSqlWriteBackend :: SqlBackend } deriving Typeable instance HasPersistBackend SqlWriteBackend where type BaseBackend SqlWriteBackend = SqlBackend
Database/Persist/Sql/Util.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} module Database.Persist.Sql.Util ( parseEntityValues , entityColumnNames@@ -19,8 +18,9 @@ import Data.Maybe (isJust) import Data.Monoid ((<>))-import qualified Data.Text as T import Data.Text (Text, pack)+import qualified Data.Text as T+ import Database.Persist ( Entity(Entity), EntityDef, EntityField, HaskellName(HaskellName) , PersistEntity, PersistValue
Database/Persist/Types.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE TypeFamilies #-} module Database.Persist.Types ( module Database.Persist.Types.Base , SomePersistField (..)@@ -7,6 +5,7 @@ , BackendSpecificUpdate , SelectOpt (..) , Filter (..)+ , FilterValue (..) , BackendSpecificFilter , Key , Entity (..)
Database/Persist/Types/Base.hs view
@@ -1,39 +1,33 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} -- usage of Error typeclass module Database.Persist.Types.Base where -import qualified Data.Aeson as A+import Control.Arrow (second) import Control.Exception (Exception)-import Web.PathPieces (PathPiece(..))-import Web.HttpApiData (ToHttpApiData (..), FromHttpApiData (..), parseUrlPieceMaybe, showTextData, readTextData, parseBoundedTextData) import Control.Monad.Trans.Error (Error (..))-import Data.Typeable (Typeable)+import qualified Data.Aeson as A+import Data.Bits (shiftL, shiftR)+import Data.ByteString (ByteString, foldl')+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Char8 as BS8+import qualified Data.HashMap.Strict as HM+import Data.Int (Int64)+import Data.Map (Map)+import qualified Data.Scientific import Data.Text (Text, pack) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.Text.Encoding.Error (lenientDecode)-import qualified Data.ByteString.Base64 as B64-import qualified Data.Vector as V-import Control.Arrow (second)-import Control.Applicative as A ((<$>)) import Data.Time (Day, TimeOfDay, UTCTime)-import Data.Int (Int64)-import Data.ByteString (ByteString, foldl')-import Data.Bits (shiftL, shiftR)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BS8-import Data.Map (Map)-import qualified Data.HashMap.Strict as HM+import Data.Typeable (Typeable)+import qualified Data.Vector as V import Data.Word (Word32) import Numeric (showHex, readHex)-#if MIN_VERSION_aeson(0, 7, 0)-import qualified Data.Scientific-#else-import qualified Data.Attoparsec.Number as AN-#endif+import Web.PathPieces (PathPiece(..))+import Web.HttpApiData (ToHttpApiData (..), FromHttpApiData (..), parseUrlPieceMaybe, showTextData, readTextData, parseBoundedTextData) + -- | A 'Checkmark' should be used as a field type whenever a -- uniqueness constraint should guarantee that a certain kind of -- record may appear at most once, but other kinds of records may@@ -112,17 +106,38 @@ | ByNullableAttr deriving (Eq, Show) +-- | An 'EntityDef' represents the information that @persistent@ knows+-- about an Entity. It uses this information to generate the Haskell+-- datatype, the SQL migrations, and other relevant conversions. data EntityDef = EntityDef { entityHaskell :: !HaskellName+ -- ^ The name of the entity as Haskell understands it. , entityDB :: !DBName+ -- ^ The name of the database table corresponding to the entity. , entityId :: !FieldDef+ -- ^ The entity's primary key or identifier. , entityAttrs :: ![Attr]+ -- ^ The @persistent@ entity syntax allows you to add arbitrary 'Attr's+ -- to an entity using the @!@ operator. Those attributes are stored in+ -- this list. , entityFields :: ![FieldDef]+ -- ^ The fields for this entity. Note that the ID field will not be+ -- present in this list. To get all of the fields for an entity, use+ -- 'keyAndEntityFields'. , entityUniques :: ![UniqueDef]+ -- ^ The Uniqueness constraints for this entity. , entityForeigns:: ![ForeignDef]+ -- ^ The foreign key relationships that this entity has to other+ -- entities. , entityDerives :: ![Text]+ -- ^ A list of type classes that have been derived for this entity. , entityExtra :: !(Map Text [ExtraLine]) , entitySum :: !Bool+ -- ^ Whether or not this entity represents a sum type in the database.+ , entityComments :: !(Maybe Text)+ -- ^ Optional comments on the entity.+ --+ -- @since 2.10.0 } deriving (Show, Eq, Read, Ord) @@ -159,14 +174,35 @@ | FTList FieldType deriving (Show, Eq, Read, Ord) +-- | A 'FieldDef' represents the inormation that @persistent@ knows about+-- a field of a datatype. This includes information used to parse the field+-- out of the database and what the field corresponds to. data FieldDef = FieldDef- { fieldHaskell :: !HaskellName -- ^ name of the field+ { fieldHaskell :: !HaskellName+ -- ^ The name of the field. Note that this does not corresponds to the+ -- record labels generated for the particular entity - record labels+ -- are generated with the type name prefixed to the field, so+ -- a 'FieldDef' that contains a @'HaskellName' "name"@ for a type+ -- @User@ will have a record field @userName@. , fieldDB :: !DBName+ -- ^ The name of the field in the database. For SQL databases, this+ -- corresponds to the column name. , fieldType :: !FieldType+ -- ^ The type of the field in Haskell. , fieldSqlType :: !SqlType- , fieldAttrs :: ![Attr] -- ^ user annotations for a field- , fieldStrict :: !Bool -- ^ a strict field in the data type. Default: true+ -- ^ The type of the field in a SQL database.+ , fieldAttrs :: ![Attr]+ -- ^ User annotations for a field. These are provided with the @!@+ -- operator.+ , fieldStrict :: !Bool+ -- ^ If this is 'True', then the Haskell datatype will have a strict+ -- record field. The default value for this is 'True'. , fieldReference :: !ReferenceDef+ , fieldComments :: !(Maybe Text)+ -- ^ Optional comments for a 'Field'. There is not currently a way to+ -- attach comments to a field in the quasiquoter.+ --+ -- @since 2.10.0 } deriving (Show, Eq, Read, Ord) @@ -237,7 +273,7 @@ -- (DBName (packPTH "unique_age")) [(HaskellName (packPTH "age"), DBName (packPTH "age"))] [] -- data UniqueDef = UniqueDef- { uniqueHaskell :: !HaskellName + { uniqueHaskell :: !HaskellName , uniqueDBName :: !DBName , uniqueFields :: ![(HaskellName, DBName)] , uniqueAttrs :: ![Attr]@@ -293,6 +329,7 @@ | PersistList [PersistValue] | PersistMap [(Text, PersistValue)] | PersistObjectId ByteString -- ^ Intended especially for MongoDB backend+ | PersistArray [PersistValue] -- ^ Intended especially for PostgreSQL backend for text arrays | PersistDbSpecific ByteString -- ^ Using 'PersistDbSpecific' allows you to use types specific to a particular backend -- For example, below is a simple example of the PostGIS geography type: --@@ -330,9 +367,9 @@ instance FromHttpApiData PersistValue where parseUrlPiece input =- PersistInt64 A.<$> parseUrlPiece input- <!> PersistList A.<$> readTextData input- <!> PersistText A.<$> return input+ PersistInt64 <$> parseUrlPiece input+ <!> PersistList <$> readTextData input+ <!> PersistText <$> return input where infixl 3 <!> Left _ <!> y = y@@ -357,19 +394,14 @@ fromPersistValueText (PersistList _) = Left "Cannot convert PersistList to Text" fromPersistValueText (PersistMap _) = Left "Cannot convert PersistMap to Text" fromPersistValueText (PersistObjectId _) = Left "Cannot convert PersistObjectId to Text"+fromPersistValueText (PersistArray _) = Left "Cannot convert PersistArray to Text" fromPersistValueText (PersistDbSpecific _) = Left "Cannot convert PersistDbSpecific to Text. See the documentation of PersistDbSpecific for an example of using a custom database type with Persistent." instance A.ToJSON PersistValue where toJSON (PersistText t) = A.String $ T.cons 's' t toJSON (PersistByteString b) = A.String $ T.cons 'b' $ TE.decodeUtf8 $ B64.encode b toJSON (PersistInt64 i) = A.Number $ fromIntegral i- toJSON (PersistDouble d) = A.Number $-#if MIN_VERSION_aeson(0, 7, 0)- Data.Scientific.fromFloatDigits-#else- AN.D-#endif- d+ toJSON (PersistDouble d) = A.Number $ Data.Scientific.fromFloatDigits d toJSON (PersistRational r) = A.String $ T.pack $ 'r' : show r toJSON (PersistBool b) = A.Bool b toJSON (PersistTimeOfDay t) = A.String $ T.pack $ 't' : show t@@ -379,6 +411,7 @@ toJSON (PersistList l) = A.Array $ V.fromList $ map A.toJSON l toJSON (PersistMap m) = A.object $ map (second A.toJSON) m toJSON (PersistDbSpecific b) = A.String $ T.cons 'p' $ TE.decodeUtf8 $ B64.encode b+ toJSON (PersistArray a) = A.Array $ V.fromList $ map A.toJSON a toJSON (PersistObjectId o) = A.toJSON $ showChar 'o' $ showHexLen 8 (bs2i four) $ showHexLen 16 (bs2i eight) "" where@@ -428,15 +461,10 @@ {-# INLINE i2bs #-} -#if MIN_VERSION_aeson(0, 7, 0) parseJSON (A.Number n) = return $ if fromInteger (floor n) == n then PersistInt64 $ floor n else PersistDouble $ fromRational $ toRational n-#else- parseJSON (A.Number (AN.I i)) = return $ PersistInt64 $ fromInteger i- parseJSON (A.Number (AN.D d)) = return $ PersistDouble d-#endif parseJSON (A.Bool b) = return $ PersistBool b parseJSON A.Null = return $ PersistNull parseJSON (A.Array a) = fmap PersistList (mapM A.parseJSON $ V.toList a)
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.9.2+version: 2.10.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -8,7 +8,7 @@ description: Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/persistent>. category: Database, Yesod stability: Stable-cabal-version: >= 1.8+cabal-version: >= 1.10 build-type: Simple homepage: http://www.yesodweb.com/book/persistent bug-reports: https://github.com/yesodweb/persistent/issues@@ -22,35 +22,36 @@ if flag(nooverlap) cpp-options: -DNO_OVERLAP - build-depends: base >= 4.8 && < 5- , bytestring >= 0.9- , transformers >= 0.2.1- , time >= 1.1.4- , old-locale- , text >= 0.8- , containers >= 0.2- , conduit >= 1.2.8- , resourcet >= 1.1.10- , resource-pool >= 0.2.2.0- , path-pieces >= 0.1- , http-api-data >= 0.2- , aeson >= 0.5- , monad-logger >= 0.3.28- , base64-bytestring- , unordered-containers- , vector+ build-depends: base >= 4.9 && < 5+ , aeson >= 1.0 , attoparsec- , template-haskell- , blaze-html >= 0.5- , blaze-markup >= 0.5.1- , silently+ , base64-bytestring+ , blaze-html >= 0.9+ , bytestring >= 0.10+ , conduit >= 1.2.12+ , containers >= 0.5+ , fast-logger >= 2.4+ , http-api-data >= 0.3+ , monad-logger >= 0.3.28 , mtl- , fast-logger >= 2.1+ , path-pieces >= 0.2+ , resource-pool >= 0.2.3+ , resourcet >= 1.1.10 , scientific- , tagged+ , silently+ , template-haskell+ , text >= 1.2+ , time >= 1.6+ , transformers >= 0.5 , unliftio-core- , void+ , unordered-containers+ , vector + default-extensions: FlexibleContexts+ , MultiParamTypeClasses+ , OverloadedStrings+ , TypeFamilies+ exposed-modules: Database.Persist Database.Persist.Quasi @@ -80,45 +81,42 @@ Database.Persist.Sql.Orphan.PersistUnique ghc-options: -Wall+ default-language: Haskell2010 test-suite test type: exitcode-stdio-1.0 main-is: test/main.hs - build-depends: base >= 4.8 && < 5- , hspec >= 1.3+ build-depends: base >= 4.9 && < 5+ , aeson+ , attoparsec+ , base64-bytestring+ , blaze-html+ , bytestring , containers+ , hspec >= 2.4+ , http-api-data+ , path-pieces+ , scientific , text- , unordered-containers , time- , old-locale- , bytestring- , vector- , base64-bytestring- , attoparsec , transformers- , path-pieces- , http-api-data- , aeson- , resourcet- , monad-logger- , conduit- , monad-control- , blaze-html- , scientific- , tagged- , fast-logger >= 2.1- , mtl- , template-haskell- , resource-pool+ , unordered-containers+ , vector cpp-options: -DTEST + default-extensions: FlexibleContexts+ , MultiParamTypeClasses+ , OverloadedStrings+ , TypeFamilies+ other-modules: Database.Persist.Class.PersistEntity Database.Persist.Class.PersistField Database.Persist.Quasi Database.Persist.Types Database.Persist.Types.Base+ default-language: Haskell2010 source-repository head type: git
test/main.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} import Test.Hspec import Database.Persist.Quasi