packages feed

persistent 1.3.3 → 2.0.0

raw patch · 21 files changed

+714/−743 lines, 21 filesdep +fast-loggerdep +mtldep +taggeddep ~basedep ~exceptionsdep ~resourcet

Dependencies added: fast-logger, mtl, tagged

Dependency ranges changed: base, exceptions, resourcet

Files

Database/Persist/Class.hs view
@@ -11,9 +11,13 @@     , getByValue     , insertBy     , replaceUnique+    , checkUnique+    , onlyUnique      -- * PersistQuery     , PersistQuery (..)+    , selectSource+    , selectKeys     , selectList     , selectKeysList @@ -27,6 +31,10 @@     , PersistField (..)     -- * PersistConfig     , PersistConfig (..)++    -- * Lifting+    , HasPersistBackend (..)+    , liftPersist      -- * JSON utilities     , keyValueEntityToJSON, keyValueEntityFromJSON
Database/Persist/Class/DeleteCascade.hs view
@@ -11,10 +11,17 @@  import qualified Data.Conduit as C import qualified Data.Conduit.List as CL+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader (ReaderT, ask, runReaderT)+import Data.Acquire (with) -class (PersistStore m, PersistEntity a, PersistEntityBackend a ~ PersistMonadBackend m) => DeleteCascade a m where-    deleteCascade :: Key a -> m ()+class (PersistStore backend, PersistEntity record, backend ~ PersistEntityBackend record)+  => DeleteCascade record backend where+    deleteCascade :: MonadIO m => Key record -> ReaderT backend m () -deleteCascadeWhere :: (DeleteCascade a m, PersistQuery m)-                   => [Filter a] -> m ()-deleteCascadeWhere filts = selectKeys filts [] C.$$ CL.mapM_ deleteCascade+deleteCascadeWhere :: (MonadIO m, DeleteCascade record backend, PersistQuery backend)+                   => [Filter record] -> ReaderT backend m ()+deleteCascadeWhere filts = do+    srcRes <- selectKeysRes filts []+    conn <- ask+    liftIO $ with srcRes (C.$$ CL.mapM_ (flip runReaderT conn . deleteCascade))
Database/Persist/Class/PersistEntity.hs view
@@ -2,13 +2,14 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts, StandaloneDeriving, UndecidableInstances #-} module Database.Persist.Class.PersistEntity     ( PersistEntity (..)     , Update (..)+    , BackendSpecificUpdate     , SelectOpt (..)-    , BackendSpecificFilter     , Filter (..)-    , Key+    , BackendSpecificFilter     , Entity (..)      , keyValueEntityToJSON, keyValueEntityFromJSON@@ -36,35 +37,45 @@ -- -- Some advanced type system capabilities are used to make this process type-safe. -- Persistent users usually don't need to understand the class associated data and functions.-class PersistEntity record where-    -- | An 'EntityField' is parameterised by the Haskell record it belongs to-    -- and the additional type of that field-    data EntityField record :: * -> *--    -- | return meta-data for a given 'EntityField'-    persistFieldDef :: EntityField record typ -> FieldDef SqlType--    -- | Persistent allows multiple different backends+class ( PersistField (Key record), ToJSON (Key record), FromJSON (Key record)+      , Show (Key record), Read (Key record), Eq (Key record), Ord (Key record))+  => PersistEntity record where+    -- | Persistent allows multiple different backends (databases)     type PersistEntityBackend record -    -- | Unique keys besided the Key-    data Unique record+    -- | By default, a backend will automatically generate the key+    -- Instead you can specify a Primary key made up of unique values.+    data Key record+    -- | a lower-level key operation+    keyToValues :: Key record -> [PersistValue]+    -- | a lower-level key operation+    keyFromValues :: [PersistValue] -> Either Text (Key record)+    -- | a meta-operation to retrieve the Key EntityField+    persistIdField :: EntityField record (Key record)      -- | retrieve the EntityDef meta-data for the record-    entityDef :: Monad m => m record -> EntityDef SqlType+    entityDef :: Monad m => m record -> EntityDef -    -- | Get the database fields of a record+    -- | An 'EntityField' is parameterised by the Haskell record it belongs to+    -- and the additional type of that field+    data EntityField record :: * -> *+    -- | return meta-data for a given 'EntityField'+    persistFieldDef :: EntityField record typ -> FieldDef+    -- | A meta-operation to get the database fields of a record     toPersistFields :: record -> [SomePersistField]--    -- | Convert from database values to a Haskell record+    -- | A lower-level operation to convert from database values to a Haskell record     fromPersistValues :: [PersistValue] -> Either Text record +    -- | Unique keys besided the Key+    data Unique record+    -- | A meta operation to retrieve all the Unique keys+    persistUniqueKeys :: record -> [Unique record]+    -- | A lower level operation     persistUniqueToFieldNames :: Unique record -> [(HaskellName, DBName)]+    -- | A lower level operation     persistUniqueToValues :: Unique record -> [PersistValue]-    persistUniqueKeys :: record -> [Unique record] -    persistIdField :: EntityField record (Key record)-+    -- | Use a PersistField as a lens     fieldLens :: EntityField record field               -> (forall f. Functor f => (field -> f field) -> Entity record -> f (Entity record)) @@ -108,11 +119,6 @@     | BackendFilter           (BackendSpecificFilter (PersistEntityBackend record) record) --- | Helper wrapper, equivalent to @Key (PersistEntityBackend val) val@.------ Since 1.1.0-type Key record = KeyBackend (PersistEntityBackend record) record- -- | Datatype that represents an entity, with both its 'Key' and -- its Haskell record representation. --@@ -143,11 +149,15 @@ -- your query returns two entities (i.e. @(Entity backend a, -- Entity backend b)@), then you must you use @SELECT ??, ?? -- WHERE ...@, and so on.-data Entity entity =-    Entity { entityKey :: Key entity-           , entityVal :: entity }-    deriving (Eq, Ord, Show, Read)+data PersistEntity record => Entity record =+    Entity { entityKey :: Key record+           , entityVal :: record } +deriving instance (PersistEntity record, Eq (Key record), Eq record) => Eq (Entity record)+deriving instance (PersistEntity record, Ord (Key record), Ord record) => Ord (Entity record)+deriving instance (PersistEntity record, Show (Key record), Show record) => Show (Entity record)+deriving instance (PersistEntity record, Read (Key record), Read record) => Read (Entity record)+ -- | Predefined @toJSON@. The resulting JSON looks like -- @{\"key\": 1, \"value\": {\"name\": ...}}@. --@@ -157,7 +167,8 @@ --   instance ToJSON User where --       toJSON = keyValueEntityToJSON -- @-keyValueEntityToJSON :: ToJSON e => Entity e -> Value+keyValueEntityToJSON :: (PersistEntity record, ToJSON record, ToJSON (Key record))+                     => Entity record -> Value keyValueEntityToJSON (Entity key value) = object     [ "key" .= key     , "value" .= value@@ -172,7 +183,8 @@ --   instance FromJSON User where --       parseJSON = keyValueEntityFromJSON -- @-keyValueEntityFromJSON :: FromJSON e => Value -> Parser (Entity e)+keyValueEntityFromJSON :: (PersistEntity record, FromJSON record, FromJSON (Key record))+                       => Value -> Parser (Entity record) keyValueEntityFromJSON (Object o) = Entity     <$> o .: "key"     <*> o .: "value"@@ -187,7 +199,7 @@ --   instance ToJSON User where --       toJSON = entityIdToJSON -- @-entityIdToJSON :: ToJSON e => Entity e -> Value+entityIdToJSON :: (PersistEntity record, ToJSON record, ToJSON (Key record)) => Entity record -> Value entityIdToJSON (Entity key value) = case toJSON value of     Object o -> Object $ HM.insert "id" (toJSON key) o     x -> x@@ -201,21 +213,22 @@ --   instance FromJSON User where --       parseJSON = entityIdFromJSON -- @-entityIdFromJSON :: FromJSON e => Value -> Parser (Entity e)+entityIdFromJSON :: (PersistEntity record, FromJSON record, FromJSON (Key record)) => Value -> Parser (Entity record) entityIdFromJSON value@(Object o) = Entity <$> o .: "id" <*> parseJSON value entityIdFromJSON _ = fail "entityIdFromJSON: not an object" -instance PersistField entity => PersistField (Entity entity) where+instance (PersistEntity record, PersistField record, PersistField (Key record))+  => PersistField (Entity record) where     toPersistValue (Entity key value) = case toPersistValue value of         (PersistMap alist) -> PersistMap ((idField, toPersistValue key) : alist)         _ -> error $ T.unpack $ errMsg "expected PersistMap"      fromPersistValue (PersistMap alist) = case after of         [] -> Left $ errMsg $ "did not find " `mappend` idField `mappend` " field"-        ("_id", k):afterRest ->-            case fromPersistValue (PersistMap (before ++ afterRest)) of-                Right record -> Right $ Entity (Key k) record-                Left err     -> Left err+        ("_id", kv):afterRest ->+            fromPersistValue (PersistMap (before ++ afterRest)) >>= \record ->+                keyFromValues [kv] >>= \k ->+                    Right (Entity k record)         _ -> Left $ errMsg $ "impossible id field: " `mappend` T.pack (show alist)       where         (before, after) = break ((== idField) . fst) alist
Database/Persist/Class/PersistField.hs view
@@ -19,7 +19,6 @@ #ifdef HIGH_PRECISION_DATE import Data.Time.Clock.POSIX (posixSecondsToUTCTime) #endif-import Data.Time.LocalTime (ZonedTime) import Data.ByteString.Char8 (ByteString, unpack, readInt) import Control.Applicative import Data.Int (Int8, Int16, Int32, Int64)@@ -47,6 +46,7 @@ import qualified Data.Map as M  import qualified Data.Text.Encoding as TE+import qualified Data.Vector as V  -- | A value which can be marshalled to and from a 'PersistValue'. class PersistField a where@@ -65,7 +65,6 @@     fromPersistValue (PersistDay d) = Right $ Prelude.show d     fromPersistValue (PersistTimeOfDay d) = Right $ Prelude.show d     fromPersistValue (PersistUTCTime d) = Right $ Prelude.show d-    fromPersistValue (PersistZonedTime (ZT z)) = Right $ Prelude.show z     fromPersistValue PersistNull = Left $ T.pack "Unexpected null"     fromPersistValue (PersistBool b) = Right $ Prelude.show b     fromPersistValue (PersistList _) = Left $ T.pack "Cannot convert PersistList to String"@@ -81,7 +80,7 @@  instance PersistField T.Text where     toPersistValue = PersistText-    fromPersistValue = either (Left . T.pack) Right . fromPersistValueText+    fromPersistValue = fromPersistValueText  instance PersistField TL.Text where     toPersistValue = toPersistValue . TL.toStrict@@ -230,19 +229,6 @@      fromPersistValue x = Left $ T.pack $ "Expected UTCTime, received: " ++ show x -instance PersistField ZonedTime where-    toPersistValue = PersistZonedTime . ZT-    fromPersistValue (PersistZonedTime (ZT z)) = Right z-    fromPersistValue x@(PersistText t) =-        case reads $ T.unpack t of-            (z, _):_ -> Right z-            _ -> Left $ T.pack $ "Expected ZonedTime, received " ++ show x-    fromPersistValue x@(PersistByteString s) =-        case reads $ unpack s of-            (z, _):_ -> Right z-            _ -> Left $ T.pack $ "Expected ZonedTime, received " ++ show x-    fromPersistValue x = Left $ T.pack $ "Expected ZonedTime, received: " ++ show x- instance PersistField a => PersistField (Maybe a) where     toPersistValue Nothing = PersistNull     toPersistValue (Just a) = toPersistValue a@@ -260,6 +246,11 @@     fromPersistValue (PersistNull) = Right []     fromPersistValue x = Left $ T.pack $ "Expected PersistList, received: " ++ show x +instance PersistField a => PersistField (V.Vector a) where+  toPersistValue = toPersistValue . V.toList+  fromPersistValue = either (\e -> Left ("Vector: " `T.append` e))+                            (Right . V.fromList) . fromPersistValue+ instance (Ord a, PersistField a) => PersistField (S.Set a) where     toPersistValue = PersistList . map toPersistValue . S.toList     fromPersistValue (PersistList list) =@@ -286,8 +277,6 @@ instance PersistField PersistValue where     toPersistValue = id     fromPersistValue = Right--deriving instance PersistField (KeyBackend backend entity)  fromPersistList :: PersistField a => [PersistValue] -> Either T.Text [a] fromPersistList = mapM fromPersistValue
Database/Persist/Class/PersistQuery.hs view
@@ -2,136 +2,99 @@ {-# LANGUAGE TypeFamilies #-} module Database.Persist.Class.PersistQuery     ( PersistQuery (..)+    , selectSource+    , selectKeys     , selectList     , selectKeysList     ) where -import Control.Exception (throwIO) import Database.Persist.Types--import Control.Monad.Trans.Error (Error (..))--import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Monoid (Monoid)--import Data.Conduit.Internal (Pipe, ConduitM)-import Control.Monad.Logger (LoggingT)-import Control.Monad.Trans.Identity ( IdentityT)-import Control.Monad.Trans.List     ( ListT    )-import Control.Monad.Trans.Maybe    ( MaybeT   )-import Control.Monad.Trans.Error    ( ErrorT   )--#if MIN_VERSION_transformers(0,4,0)-import Control.Monad.Trans.Except   ( ExceptT  )-#endif--import Control.Monad.Trans.Reader   ( ReaderT  )-import Control.Monad.Trans.Cont     ( ContT  )-import Control.Monad.Trans.State    ( StateT   )-import Control.Monad.Trans.Writer   ( WriterT  )-import Control.Monad.Trans.RWS      ( RWST     )-import Control.Monad.Trans.Resource ( ResourceT)+import Control.Monad.Reader   ( ReaderT, MonadReader  ) -import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )-import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )-import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistEntity--class PersistStore m => PersistQuery m where-    -- | Update individual fields on a specific record.-    update :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)-           => Key val -> [Update val] -> m ()--    -- | Update individual fields on a specific record, and retrieve the-    -- updated value from the database.-    ---    -- Note that this function will throw an exception if the given key is not-    -- found in the database.-    updateGet :: (PersistEntity val, PersistMonadBackend m ~ PersistEntityBackend val)-              => Key val -> [Update val] -> m val-    updateGet key ups = do-        update key ups-        get key >>= maybe (liftIO $ throwIO $ KeyNotFound $ show key) return+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Resource (MonadResource, release)+import Data.Acquire (Acquire, mkAcquire, allocateAcquire, with) +class PersistStore backend => PersistQuery backend where     -- | Update individual fields on any record matching the given criterion.-    updateWhere :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)-                => [Filter val] -> [Update val] -> m ()+    updateWhere :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val)+                => [Filter val] -> [Update val] -> ReaderT backend m ()      -- | Delete all records matching the given criterion.-    deleteWhere :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)-                => [Filter val] -> m ()+    deleteWhere :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val)+                => [Filter val] -> ReaderT backend m ()      -- | Get all records matching the given criterion in the specified order.     -- Returns also the identifiers.-    selectSource-           :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)+    selectSourceRes+           :: (PersistEntity val, PersistEntityBackend val ~ backend, MonadIO m1, MonadIO m2)            => [Filter val]            -> [SelectOpt val]-           -> C.Source m (Entity val)+           -> ReaderT backend m1 (Acquire (C.Source m2 (Entity val)))      -- | get just the first record for the criterion-    selectFirst :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)+    selectFirst :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val)                 => [Filter val]                 -> [SelectOpt val]-                -> m (Maybe (Entity val))-    selectFirst filts opts = selectSource filts ((LimitTo 1):opts) C.$$ CL.head-+                -> ReaderT backend m (Maybe (Entity val))+    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.-    selectKeys :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)-               => [Filter val]-               -> [SelectOpt val]-               -> C.Source m (Key val)+    selectKeysRes+        :: (MonadIO m1, MonadIO m2, PersistEntity val, backend ~ PersistEntityBackend val)+        => [Filter val]+        -> [SelectOpt val]+        -> ReaderT backend m1 (Acquire (C.Source m2 (Key val)))      -- | The total number of records fulfilling the given criterion.-    count :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)-          => [Filter val] -> m Int+    count :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val)+          => [Filter val] -> ReaderT backend m Int +-- | 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)+selectSource filts opts = do+    srcRes <- liftPersist $ selectSourceRes filts opts+    (releaseKey, src) <- allocateAcquire srcRes+    src+    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 filts opts = do+    srcRes <- liftPersist $ selectKeysRes filts opts+    (releaseKey, src) <- allocateAcquire srcRes+    src+    release releaseKey+ -- | Call 'selectSource' but return the result as a list.-selectList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m)+selectList :: (MonadIO m, PersistEntity val, PersistQuery backend, PersistEntityBackend val ~ backend)            => [Filter val]            -> [SelectOpt val]-           -> m [Entity val]-selectList a b = selectSource a b C.$$ CL.consume+           -> ReaderT backend m [Entity val]+selectList filts opts = do+    srcRes <- selectSourceRes filts opts+    liftIO $ with srcRes (C.$$ CL.consume)  -- | Call 'selectKeys' but return the result as a list.-selectKeysList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m)+selectKeysList :: (MonadIO m, PersistEntity val, PersistQuery backend, PersistEntityBackend val ~ backend)                => [Filter val]                -> [SelectOpt val]-               -> m [Key val]-selectKeysList a b = selectKeys a b C.$$ CL.consume---#define DEF(T) { update k = lift . update k; updateGet k = lift . updateGet k; updateWhere f = lift . updateWhere f; deleteWhere = lift . deleteWhere; selectSource f = C.transPipe lift . selectSource f; selectFirst f = lift . selectFirst f; selectKeys f = C.transPipe lift . selectKeys f; count = lift . count }-#define GO(T) instance (PersistQuery m) => PersistQuery (T m) where DEF(T)-#define GOX(X, T) instance (X, PersistQuery m) => PersistQuery (T m) where DEF(T)--GO(LoggingT)-GO(IdentityT)-GO(ListT)-GO(MaybeT)-GOX(Error e, ErrorT e)--#if MIN_VERSION_transformers(0,4,0)-GO(ExceptT e)-#endif--GO(ReaderT r)-GO(ContT r)-GO(StateT s)-GO(ResourceT)-GO(Pipe l i o u)-GO(ConduitM i o)-GOX(Monoid w, WriterT w)-GOX(Monoid w, RWST r w s)-GOX(Monoid w, Strict.RWST r w s)-GO(Strict.StateT s)-GOX(Monoid w, Strict.WriterT w)--#undef DEF-#undef GO-#undef GOX+               -> ReaderT backend m [Key val]+selectKeysList filts opts = do+    srcRes <- selectKeysRes filts opts+    liftIO $ with srcRes (C.$$ CL.consume)
Database/Persist/Class/PersistStore.hs view
@@ -1,7 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-} module Database.Persist.Class.PersistStore-    ( PersistStore (..)+    ( HasPersistBackend (..)+    , liftPersist+    , PersistStore (..)     , getJust     , belongsTo     , belongsToJust@@ -13,85 +18,107 @@ import qualified Data.Text as T  import Control.Monad.Trans.Error (Error (..))-import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Monoid (Monoid) import Control.Exception.Lifted (throwIO)  import Data.Conduit.Internal (Pipe, ConduitM)-import Control.Monad.Logger (LoggingT)-import Control.Monad.Trans.Identity ( IdentityT)-import Control.Monad.Trans.List     ( ListT    )-import Control.Monad.Trans.Maybe    ( MaybeT   )-import Control.Monad.Trans.Error    ( ErrorT   ) -#if MIN_VERSION_transformers(0,4,0)-import Control.Monad.Trans.Except   ( ExceptT  )-#endif- import Control.Monad.Trans.Reader   ( ReaderT  )-import Control.Monad.Trans.Cont     ( ContT  )-import Control.Monad.Trans.State    ( StateT   )-import Control.Monad.Trans.Writer   ( WriterT  )-import Control.Monad.Trans.RWS      ( RWST     )-import Control.Monad.Trans.Resource ( ResourceT)+import Control.Monad.Reader (MonadReader (ask), runReaderT) -import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )-import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )-import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )  import Database.Persist.Class.PersistEntity+import Database.Persist.Class.PersistField import Database.Persist.Types+import qualified Data.Aeson as A -class MonadIO m => PersistStore m where-    type PersistMonadBackend m+class HasPersistBackend env backend | env -> backend where+    persistBackend :: env -> backend +liftPersist :: (MonadReader env m, HasPersistBackend env backend, MonadIO m)+            => ReaderT backend IO a+            -> m a+liftPersist f = do+    env <- ask+    liftIO $ runReaderT f (persistBackend env)++class+  ( Show (BackendKey backend), Read (BackendKey backend)+  , Eq (BackendKey backend), Ord (BackendKey backend)+  , PersistField (BackendKey backend), A.ToJSON (BackendKey backend), A.FromJSON (BackendKey backend)+  ) => PersistStore backend where+    data BackendKey backend++    backendKeyToValues :: BackendKey backend -> [PersistValue]+    backendKeyFromValues :: [PersistValue] -> Either T.Text (BackendKey backend)+     -- | Get a record by identifier, if available.-    get :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)-        => Key val -> m (Maybe val)+    get :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val)+        => Key val -> ReaderT backend m (Maybe val)      -- | Create a new record in the database, returning an automatically created     -- key (in SQL an auto-increment id).-    insert :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)-           => val -> m (Key val)+    insert :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val)+           => val -> ReaderT backend m (Key val)      -- | Same as 'insert', but doesn't return a @Key@.-    insert_ :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)-            => val -> m ()+    insert_ :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val)+            => val -> ReaderT backend m ()     insert_ val = insert val >> return ()      -- | Create multiple records in the database.     -- SQL backends currently use the slow default implementation of     -- @mapM insert@-    insertMany :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)-                => [val] -> m [Key val]+    insertMany :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val)+               => [val] -> ReaderT backend m [Key val]     insertMany = mapM insert      -- | Create a new record in the database using the given key.-    insertKey :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)-              => Key val -> val -> m ()+    insertKey :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val)+              => Key val -> val -> 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 :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)-            => Key val -> val -> m ()+    repsert :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val)+            => Key val -> val -> 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 :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)-            => Key val -> val -> m ()+    replace :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val)+            => Key val -> val -> ReaderT backend m ()      -- | Delete a specific record by identifier. Does nothing if record does     -- not exist.-    delete :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)-           => Key val -> m ()+    delete :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val)+           => Key val -> 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 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 key ups = do+        update key ups+        get key >>= maybe (liftIO $ throwIO $ KeyNotFound $ Prelude.show key) return++ -- | Same as get, but for a non-null (not Maybe) foreign key --   Unsafe unless your database is enforcing that the foreign key is valid-getJust :: (PersistStore m, PersistEntity val, Show (Key val), PersistMonadBackend m ~ PersistEntityBackend val) => Key val -> m val+getJust :: ( PersistStore backend+           , PersistEntity val+           , Show (Key val)+           , backend ~ PersistEntityBackend val+           , MonadIO m+           ) => Key val -> ReaderT backend m val getJust key = get key >>= maybe   (liftIO $ throwIO $ PersistForeignConstraintUnmet $ T.pack $ Prelude.show key)   return@@ -99,50 +126,23 @@ -- | curry this to make a convenience function that loads an associated model --   > foreign = belongsTo foeignId belongsTo ::-  (PersistStore m+  ( PersistStore backend   , PersistEntity ent1   , PersistEntity ent2-  , PersistMonadBackend m ~ PersistEntityBackend ent2-  ) => (ent1 -> Maybe (Key ent2)) -> ent1 -> m (Maybe ent2)+  , backend ~ PersistEntityBackend ent2+  , MonadIO m+  ) => (ent1 -> Maybe (Key ent2)) -> ent1 -> ReaderT backend m (Maybe ent2) belongsTo foreignKeyField model = case foreignKeyField model of     Nothing -> return Nothing     Just f -> get f  -- | same as belongsTo, but uses @getJust@ and therefore is similarly unsafe belongsToJust ::-  (PersistStore m+  ( PersistStore backend   , PersistEntity ent1   , PersistEntity ent2-  , PersistMonadBackend m ~ PersistEntityBackend ent2)-  => (ent1 -> Key ent2) -> ent1 -> m ent2+  , backend ~ PersistEntityBackend ent2+  , MonadIO m+  )+  => (ent1 -> Key ent2) -> ent1 -> ReaderT backend m ent2 belongsToJust getForeignKey model = getJust $ getForeignKey model--#define DEF(T) { type PersistMonadBackend (T m) = PersistMonadBackend m; insert = lift . insert; insertKey k = lift . insertKey k; repsert k = lift . repsert k; replace k = lift . replace k; delete = lift . delete; get = lift . get }-#define GO(T) instance (PersistStore m) => PersistStore (T m) where DEF(T)-#define GOX(X, T) instance (X, PersistStore m) => PersistStore (T m) where DEF(T)--GO(LoggingT)-GO(IdentityT)-GO(ListT)-GO(MaybeT)-GOX(Error e, ErrorT e)--#if MIN_VERSION_transformers(0,4,0)-GO(ExceptT e)-#endif--GO(ReaderT r)-GO(ContT r)-GO(StateT s)-GO(ResourceT)-GO(Pipe l i o u)-GO(ConduitM i o)-GOX(Monoid w, WriterT w)-GOX(Monoid w, RWST r w s)-GOX(Monoid w, Strict.RWST r w s)-GO(Strict.StateT s)-GOX(Monoid w, Strict.WriterT w)--#undef DEF-#undef GO-#undef GOX
Database/Persist/Class/PersistUnique.hs view
@@ -6,38 +6,21 @@     , insertBy     , replaceUnique     , checkUnique+    , onlyUnique     ) where +import Database.Persist.Types import qualified Prelude-import Prelude hiding ((++), show)+import Prelude hiding ((++)) -import Control.Monad (liftM)-import Control.Monad.Trans.Error (Error (..))-import Control.Monad.Trans.Class (lift)-import Data.Monoid (Monoid)+import Control.Exception (throwIO)+import Control.Monad (liftM, when)+import Control.Monad.IO.Class (liftIO) import Data.List ((\\)) -import Data.Conduit.Internal (Pipe)-import Control.Monad.Logger (LoggingT)-import Control.Monad.Trans.Identity ( IdentityT)-import Control.Monad.Trans.List     ( ListT    )-import Control.Monad.Trans.Maybe    ( MaybeT   )-import Control.Monad.Trans.Error    ( ErrorT   )--#if MIN_VERSION_transformers(0,4,0)-import Control.Monad.Trans.Except   ( ExceptT  )-#endif- import Control.Monad.Trans.Reader   ( ReaderT  )-import Control.Monad.Trans.Cont     ( ContT  )-import Control.Monad.Trans.State    ( StateT   )-import Control.Monad.Trans.Writer   ( WriterT  )-import Control.Monad.Trans.RWS      ( RWST     )-import Control.Monad.Trans.Resource ( ResourceT)+import Control.Monad.IO.Class (MonadIO) -import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )-import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )-import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistEntity @@ -53,41 +36,74 @@ --  * there is some fragility to trying to catch the correct exception and determing the column of failure. -- --  * an exception will automatically abort the current SQL transaction-class PersistStore m => PersistUnique m where+class PersistStore backend => PersistUnique backend where     -- | Get a record by unique key, if available. Returns also the identifier.-    getBy :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => Unique val -> m (Maybe (Entity val))+    getBy :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) => Unique val -> ReaderT backend m (Maybe (Entity val))      -- | Delete a specific record by unique key. Does nothing if no record     -- matches.-    deleteBy :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => Unique val -> m ()+    deleteBy :: (MonadIO m, PersistEntityBackend val ~ backend, PersistEntity val) => Unique val -> ReaderT backend m ()      -- | Like 'insert', but returns 'Nothing' when the record     -- couldn't be inserted because of a uniqueness constraint.-    insertUnique :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => val -> m (Maybe (Key val))+    insertUnique :: (MonadIO m, PersistEntityBackend val ~ backend, PersistEntity val) => val -> ReaderT backend m (Maybe (Key val))     insertUnique datum = do         conflict <- checkUnique datum         case conflict of           Nothing -> Just `liftM` insert datum           Just _ -> return Nothing +    -- | update based on a uniquness constraint or insert+    --+    -- insert the new record if it does not exist+    -- 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] -- ^ 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) -- ^ the record in the database after the operation+    upsert record updates = do+        uniqueKey <- onlyUnique record +        mExists <- getBy uniqueKey+        k <- case mExists of+            Just (Entity k _) -> do+              when (null updates) (replace k record)+              return k+            Nothing           -> insert record+        Entity k `liftM` updateGet k updates++ -- | Insert a value, checking for conflicts with any unique constraints.  If a -- duplicate exists in the database, it is returned as 'Left'. Otherwise, the -- new 'Key is returned as 'Right'.-insertBy :: (PersistEntity val, PersistUnique m, PersistEntityBackend val ~ PersistMonadBackend m)-         => val -> m (Either (Entity val) (Key val))-+insertBy :: (MonadIO m, PersistEntity val, PersistUnique backend, PersistEntityBackend val ~ backend)+         => val -> ReaderT backend m (Either (Entity val) (Key val)) insertBy val = do     res <- getByValue val     case res of       Nothing -> Right `liftM` insert val       Just z -> return $ Left z +-- | 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 record = case onlyUniqueEither record of+    Right u -> return u+    Left us -> liftIO $ throwIO $ OnlyUniqueException $ show $ length us++onlyUniqueEither :: (PersistEntity val) => val -> Either [Unique val] (Unique val)+onlyUniqueEither record = case persistUniqueKeys record of+    (u:[]) -> Right u+    us     -> Left us+ -- | A modification of 'getBy', which takes the 'PersistEntity' itself instead -- of a 'Unique' value. Returns a value matching /one/ of the unique keys. This -- function makes the most sense on entities with a single 'Unique' -- constructor.-getByValue :: (PersistEntity value, PersistUnique m, PersistEntityBackend value ~ PersistMonadBackend m)-           => value -> m (Maybe (Entity value))+getByValue :: (MonadIO m, PersistEntity value, PersistUnique backend, PersistEntityBackend value ~ backend)+           => value -> ReaderT backend m (Maybe (Entity value)) getByValue = checkUniques . persistUniqueKeys   where     checkUniques [] = return Nothing@@ -104,8 +120,8 @@ -- If uniqueness is violated, return a 'Just' with the 'Unique' violation -- -- Since 1.2.2.0-replaceUnique :: (Eq record, Eq (Unique record), PersistEntityBackend record ~ PersistMonadBackend m, PersistEntity record, PersistStore m, PersistUnique m)-              => Key record -> record -> m (Maybe (Unique record))+replaceUnique :: (MonadIO m, Eq record, Eq (Unique record), PersistEntityBackend record ~ backend, PersistEntity record, PersistUnique backend)+              => Key record -> record -> ReaderT backend m (Maybe (Unique record)) replaceUnique key datumNew = getJust key >>= replaceOriginal   where     uniqueKeysNew = persistUniqueKeys datumNew@@ -123,44 +139,15 @@ -- -- Returns 'Nothing' if the entity would be unique, and could thus safely be inserted. -- on a conflict returns the conflicting key-checkUnique :: (PersistEntityBackend record ~ PersistMonadBackend m, PersistEntity record, PersistUnique m)-            => record -> m (Maybe (Unique record))+checkUnique :: (MonadIO m, PersistEntityBackend record ~ backend, PersistEntity record, PersistUnique backend)+            => record -> ReaderT backend m (Maybe (Unique record)) checkUnique = checkUniqueKeys . persistUniqueKeys -checkUniqueKeys :: (PersistEntity record, PersistUnique m, PersistEntityBackend record ~ PersistMonadBackend m)-                => [Unique record] -> m (Maybe (Unique record))+checkUniqueKeys :: (MonadIO m, PersistEntity record, PersistUnique backend, PersistEntityBackend record ~ backend)+                => [Unique record] -> ReaderT backend m (Maybe (Unique record)) checkUniqueKeys [] = return Nothing checkUniqueKeys (x:xs) = do     y <- getBy x     case y of         Nothing -> checkUniqueKeys xs         Just _ -> return (Just x)--#define DEF(T) { getBy = lift . getBy; deleteBy = lift . deleteBy; insertUnique = lift . insertUnique }-#define GO(T) instance (PersistUnique m) => PersistUnique (T m) where DEF(T)-#define GOX(X, T) instance (X, PersistUnique m) => PersistUnique (T m) where DEF(T)--GO(LoggingT)-GO(IdentityT)-GO(ListT)-GO(MaybeT)-GOX(Error e, ErrorT e)--#if MIN_VERSION_transformers(0,4,0)-GO(ExceptT e)-#endif--GO(ReaderT r)-GO(ContT r)-GO(StateT s)-GO(ResourceT)-GO(Pipe l i o u)-GOX(Monoid w, WriterT w)-GOX(Monoid w, RWST r w s)-GOX(Monoid w, Strict.RWST r w s)-GO(Strict.StateT s)-GOX(Monoid w, Strict.WriterT w)--#undef DEF-#undef GO-#undef GOX
Database/Persist/Quasi.hs view
@@ -7,7 +7,6 @@     , PersistSettings (..)     , upperCaseSettings     , lowerCaseSettings-    , stripId     , nullable #if TEST     , Token (..)@@ -100,7 +99,7 @@     }  -- | Parses a quasi-quoted syntax into a list of entity definitions.-parse :: PersistSettings -> Text -> [EntityDef ()]+parse :: PersistSettings -> Text -> [EntityDef] parse ps = parseLines ps       . removeSpaces       . filter (not . empty)@@ -192,7 +191,7 @@     fromToken Spaces{}  = Nothing  -- | Divide lines into blocks and make entity definitions.-parseLines :: PersistSettings -> [Line] -> [EntityDef ()]+parseLines :: PersistSettings -> [Line] -> [EntityDef] parseLines ps lines =     fixForeignKeysAll $ toEnts lines   where@@ -202,34 +201,48 @@     toEnts (Line _ []:rest) = toEnts rest     toEnts [] = [] -fixForeignKeysAll :: [EntityDef ()] -> [EntityDef ()]+fixForeignKeysAll :: [EntityDef] -> [EntityDef] fixForeignKeysAll ents = map fixForeignKeys ents-  where fixForeignKeys :: EntityDef () -> EntityDef ()-        fixForeignKeys ent = ent { entityForeigns = map (fixForeignKey ent) (entityForeigns ent) }-        -- check the count and the sqltypes match and update the foreignFields with the names of the primary columns-        chktypes :: [FieldDef ()] -> HaskellName -> [FieldDef ()] -> HaskellName -> Bool-        chktypes fflds fkey pflds pkey = case (filter ((== fkey) . fieldHaskell) fflds, filter ((== pkey) . fieldHaskell) pflds) of-                                            ([ffld],[pfld]) -> fieldType ffld == fieldType pfld-                                            xs -> error $ "unexpected result "++ show xs-        fixForeignKey :: EntityDef () -> ForeignDef -> ForeignDef-        fixForeignKey fent fdef = -           case find ((== foreignRefTableHaskell fdef) . entityHaskell) ents of-             Just pent -> case entityPrimary pent of-                           Just pdef -> if length (foreignFields fdef) == length (primaryFields pdef) -                                         then fdef { foreignFields = zipWith (\(a,b,_,_) (a',b') -> -                                                          if chktypes (entityFields fent) a (entityFields pent) a' -                                                            then (a,b,a',b') -                                                            else error ("type mismatch between foreign key and primary column" ++ show (a,a') ++ " primary ent="++show pent ++ " foreign ent="++show fent)) (foreignFields fdef) (primaryFields pdef) }-                                         else error $ "found " ++ show (length (foreignFields fdef)) ++ " fkeys and " ++ show (length (primaryFields pdef)) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef -                           Nothing -> error $ "no explicit primary key fdef="++show fdef++ " fent="++show fent-             Nothing -> error $ "could not find table " ++ show (foreignRefTableHaskell fdef) ++ " fdef=" ++ show fdef ++ " allnames=" ++ show (map (unHaskellName . entityHaskell) ents) ++ "\n\nents=" ++ show ents+  where+    fixForeignKeys :: EntityDef -> EntityDef+    fixForeignKeys ent = ent { entityForeigns = map (fixForeignKey ent) (entityForeigns ent) }+    -- check the count and the sqltypes match and update the foreignFields with the names of the primary columns+    chktypes :: [FieldDef] -> HaskellName -> [FieldDef] -> HaskellName -> Bool+    chktypes fflds fkey pflds pkey = case (filter ((== fkey) . fieldHaskell) fflds, filter ((== pkey) . fieldHaskell) pflds) of+                                        ([ffld],[pfld]) -> fieldType ffld == fieldType pfld+                                        xs -> error $ "unexpected result "++ show xs+    fixForeignKey :: EntityDef -> ForeignDef -> ForeignDef+    fixForeignKey fent fdef =+        case find ((== foreignRefTableHaskell fdef) . entityHaskell) ents of+          Just pent -> case entityPrimary pent of+             Just pdef ->+                 if length (foreignFields fdef) == length (primaryFields pdef)+                   then+                     fdef { foreignFields = zipWith (toForeignFields pent)+                              (foreignFields fdef)+                              (primaryFields pdef) }+                   else+                     error $ "found " ++ show (length (foreignFields fdef)) ++ " fkeys and " ++ show (length (primaryFields pdef)) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef+             Nothing ->+                 error $ "no explicit primary key fdef="++show fdef++ " fent="++show fent+          Nothing ->+             error $ "could not find table " ++ show (foreignRefTableHaskell fdef)+               ++ " fdef=" ++ show fdef ++ " allnames="+               ++ show (map (unHaskellName . entityHaskell) ents)+               ++ "\n\nents=" ++ show ents+      where+        toForeignFields pent (a,b,_,_) fd =+           let (a', b') = (fieldHaskell fd, fieldDB fd) in+              if chktypes (entityFields fent) a (entityFields pent) a'+                then (a,b,a',b')+                else error ("type mismatch between foreign key and primary column" ++ show (a,a') ++ " primary ent="++show pent ++ " foreign ent="++show fent)  -- | Construct an entity definition. mkEntityDef :: PersistSettings             -> Text -- ^ name             -> [Attr] -- ^ entity attributes             -> [Line] -- ^ indented lines-            -> EntityDef ()+            -> EntityDef mkEntityDef ps name entattribs lines =     EntityDef         (HaskellName name')@@ -262,7 +275,7 @@                      derives = concat $ mapMaybe takeDerives attribs -    cols :: [FieldDef ()]+    cols :: [FieldDef]     cols = mapMaybe (takeCols ps) attribs  splitExtras :: [Line] -> ([[Text]], M.Map Text [[Text]])@@ -276,7 +289,7 @@     let (x, y) = splitExtras rest      in (ts:x, y) -takeCols :: PersistSettings -> [Text] -> Maybe (FieldDef ())+takeCols :: PersistSettings -> [Text] -> Maybe FieldDef takeCols _ ("deriving":_) = Nothing takeCols ps (n':typ:rest)     | not (T.null n) && isLower (T.head n) =@@ -286,10 +299,10 @@                 { fieldHaskell = HaskellName n                 , fieldDB = DBName $ getDbName ps n rest                 , fieldType = ft-                , fieldSqlType = ()+                , fieldSqlType = SqlOther $ "SqlType unset for " `mappend` n                 , fieldAttrs = rest                 , fieldStrict = fromMaybe (psStrictFields ps) mstrict-                , fieldEmbedded = Nothing+                , fieldReference = NoReference                 }   where     (mstrict, n)@@ -300,14 +313,11 @@  getDbName :: PersistSettings -> Text -> [Text] -> Text getDbName ps n [] = psToDBName ps n-getDbName ps n (a:as) =-    case T.stripPrefix "sql=" a of-      Nothing -> getDbName ps n as-      Just s  -> s+getDbName ps n (a:as) = fromMaybe (getDbName ps n as) $ T.stripPrefix "sql=" a  takeConstraint :: PersistSettings           -> Text-          -> [FieldDef a]+          -> [FieldDef]           -> [Text]           -> (Maybe PrimaryDef, Maybe UniqueDef, Maybe ForeignDef) takeConstraint ps tableName defs (n:rest) | not (T.null n) && isUpper (T.head n) = takeConstraint' @@ -318,25 +328,25 @@             | otherwise      = (Nothing, Just $ takeUniq ps "" defs (n:rest), Nothing) -- retain compatibility with original unique constraint takeConstraint _ _ _ _ = (Nothing, Nothing, Nothing)     -takePrimary :: [FieldDef a]+takePrimary :: [FieldDef]             -> [Text]             -> PrimaryDef takePrimary defs pkcols         = PrimaryDef-            (map (HaskellName &&& getDBName defs) pkcols)+            (map (getDef defs) pkcols)             attrs   where     (_, attrs) = break ("!" `T.isPrefixOf`) pkcols-    getDBName [] t = error $ "Unknown column in primary key constraint: " ++ show t-    getDBName (d:ds) t+    getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t+    getDef (d:ds) t         | nullable (fieldAttrs d) /= NotNullable = error $ "primary key column cannot be nullable: " ++ show t-        | fieldHaskell d == HaskellName t = fieldDB d-        | otherwise = getDBName ds t+        | fieldHaskell d == HaskellName t = d+        | otherwise = getDef ds t  -- Unique UppercaseConstraintName list of lowercasefields     takeUniq :: PersistSettings           -> Text-          -> [FieldDef a]+          -> [FieldDef]           -> [Text]           -> UniqueDef takeUniq ps tableName defs (n:rest)@@ -356,7 +366,7 @@  takeForeign :: PersistSettings           -> Text-          -> [FieldDef a]+          -> [FieldDef]           -> [Text]           -> ForeignDef takeForeign ps tableName defs (refTableName:n:rest)@@ -380,10 +390,6 @@ takeDerives :: [Text] -> Maybe [Text] takeDerives ("deriving":rest) = Just rest takeDerives _ = Nothing--stripId :: FieldType -> Maybe Text-stripId (FTTypeCon Nothing t) = T.stripSuffix "Id" t-stripId _ = Nothing  nullable :: [Text] -> IsNullable nullable s
Database/Persist/Sql.hs view
@@ -4,7 +4,9 @@     , module Database.Persist.Sql.Run     , module Database.Persist.Sql.Migration     , module Database.Persist+    , module Database.Persist.Sql.Orphan.PersistStore     , rawQuery+    , rawQueryRes     , rawExecute     , rawExecuteCount     , rawSql@@ -27,24 +29,25 @@ import Database.Persist.Sql.Internal  import Database.Persist.Sql.Orphan.PersistQuery -import Database.Persist.Sql.Orphan.PersistStore ()+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. -- -- Since 1.2.0-transactionSave :: MonadSqlPersist m => m ()+transactionSave :: MonadIO m => ReaderT Connection m () transactionSave = do-    conn <- askSqlConn+    conn <- ask     let getter = getStmtConn conn     liftIO $ connCommit conn getter >> connBegin conn getter  -- | Roll back the current transaction and begin a new one. -- -- Since 1.2.0-transactionUndo :: MonadSqlPersist m => m ()+transactionUndo :: MonadIO m => ReaderT Connection m () transactionUndo = do-    conn <- askSqlConn+    conn <- ask     let getter = getStmtConn conn     liftIO $ connRollback conn getter >> connBegin conn getter
Database/Persist/Sql/Class.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-}@@ -7,8 +8,7 @@ {-# LANGUAGE OverlappingInstances #-} #endif module Database.Persist.Sql.Class-    ( MonadSqlPersist (..)-    , RawSql (..)+    ( RawSql (..)     , PersistFieldSql (..)     ) where @@ -20,11 +20,8 @@ import Data.Text (Text, intercalate, pack) import Data.Maybe (fromMaybe) import Data.Fixed--import Data.Monoid (Monoid)-import Control.Monad.Trans.Class (lift)+import Data.Proxy (Proxy) -import Control.Monad.Logger (LoggingT) import Control.Monad.Trans.Identity ( IdentityT) import Control.Monad.Trans.List     ( ListT    ) import Control.Monad.Trans.Maybe    ( MaybeT   )@@ -34,66 +31,24 @@ import Control.Monad.Trans.Except   ( ExceptT  ) #endif -import Control.Monad.Trans.Cont     ( ContT  )-import Control.Monad.Trans.State    ( StateT   )-import Control.Monad.Trans.Writer   ( WriterT  )-import Control.Monad.Trans.RWS      ( RWST     ) import Control.Monad.Trans.Reader   ( ReaderT, ask  ) import Control.Monad.Trans.Resource ( ResourceT ) import Data.Conduit.Internal (Pipe, ConduitM) -import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )-import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )-import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (MonadTrans)-import Control.Monad.Logger (MonadLogger)  import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Map as M import qualified Data.Set as S-import Data.Time (ZonedTime, UTCTime, TimeOfDay, Day)+import Data.Time (UTCTime, TimeOfDay, Day) import Data.Int import Data.Word import Data.ByteString (ByteString) import Text.Blaze.Html (Html) import Data.Bits (bitSize)--class (MonadIO m, MonadLogger m) => MonadSqlPersist m where-    askSqlConn :: m Connection-    default askSqlConn :: (MonadSqlPersist m, MonadTrans t, MonadLogger (t m))-                       => t m Connection-    askSqlConn = lift askSqlConn--instance (MonadIO m, MonadLogger m) => MonadSqlPersist (SqlPersistT m) where-    askSqlConn = SqlPersistT ask--#define GO(T) instance (MonadSqlPersist m) => MonadSqlPersist (T m)-#define GOX(X, T) instance (X, MonadSqlPersist m) => MonadSqlPersist (T m)-GO(LoggingT)-GO(IdentityT)-GO(ListT)-GO(MaybeT)-GOX(Error e, ErrorT e)--#if MIN_VERSION_transformers(0,4,0)-GO(ExceptT e)-#endif--GO(ReaderT r)-GO(ContT r)-GO(StateT s)-GO(ResourceT)-GO(Pipe l i o u)-GO(ConduitM i o)-GOX(Monoid w, WriterT w)-GOX(Monoid w, RWST r w s)-GOX(Monoid w, Strict.RWST r w s)-GO(Strict.StateT s)-GOX(Monoid w, Strict.WriterT w)-#undef GO-#undef GOX+import qualified Data.Vector as V  -- | Class for data types that may be retrived from a 'rawSql' -- query.@@ -115,7 +70,7 @@     rawSqlProcessRow [pv]  = Single <$> fromPersistValue pv     rawSqlProcessRow _     = Left $ pack "RawSql (Single a): wrong number of columns." -instance PersistEntity a => RawSql (Entity a) where+instance (PersistEntity a, PersistEntityBackend a ~ SqlBackend) => RawSql (Entity a) where     rawSqlCols escape = ((+1) . length . entityFields &&& process) . entityDef . Just . entityVal         where           process ed = (:[]) $@@ -251,7 +206,7 @@ extractMaybe = fromMaybe (error "Database.Persist.GenericSql.extractMaybe")  class PersistField a => PersistFieldSql a where-    sqlType :: Monad m => m a -> SqlType+    sqlType :: Proxy a -> SqlType  #ifndef NO_OVERLAP instance PersistFieldSql String where@@ -298,10 +253,10 @@     sqlType _ = SqlTime instance PersistFieldSql UTCTime where     sqlType _ = SqlDayTime-instance PersistFieldSql ZonedTime where-    sqlType _ = SqlDayTimeZoned instance PersistFieldSql a => PersistFieldSql [a] where     sqlType _ = SqlString+instance PersistFieldSql a => PersistFieldSql (V.Vector a) where+  sqlType _ = SqlString instance (Ord a, PersistFieldSql a) => PersistFieldSql (S.Set a) where     sqlType _ = SqlString instance (PersistFieldSql a, PersistFieldSql b) => PersistFieldSql (a,b) where@@ -323,9 +278,6 @@ instance PersistFieldSql Rational where     sqlType _ = SqlNumeric 32 20   --  need to make this field big enough to handle Rational to Mumber string conversion for ODBC --- perhaps a SQL user can figure this sqlType out?--- It is really intended for MongoDB though.-instance PersistField entity => PersistFieldSql (Entity entity) where-    sqlType _ = SqlOther "embedded entity, hard to type"-instance PersistFieldSql (KeyBackend SqlBackend a) where-    sqlType _ = SqlInt64+-- An embedded Entity+instance (PersistField record, PersistEntity record) => PersistFieldSql (Entity record) where+    sqlType _ = SqlString
Database/Persist/Sql/Internal.hs view
@@ -3,7 +3,6 @@ -- | Intended for creating new backends. module Database.Persist.Sql.Internal     ( mkColumns-    , convertKey     ) where  import Database.Persist.Types@@ -11,12 +10,11 @@ import Data.Char (isSpace) import Data.Text (Text) import qualified Data.Text as T-import Data.Monoid (Monoid, mappend, mconcat)-import Data.Maybe (mapMaybe, listToMaybe)+import Data.Monoid (mappend, mconcat) import Database.Persist.Sql.Types  -- | Create the list of columns for the given entity.-mkColumns :: [EntityDef a] -> EntityDef SqlType -> ([Column], [UniqueDef], [ForeignDef])+mkColumns :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) mkColumns allDefs t =     (cols, entityUniques t, entityForeigns t)   where@@ -26,19 +24,16 @@     tn :: DBName     tn = entityDB t -    go :: FieldDef SqlType -> Column+    go :: FieldDef -> Column     go fd =         Column             (fieldDB fd)             (nullable (fieldAttrs fd) /= NotNullable || entitySum t)-            (maybe-                (fieldSqlType fd)-                SqlOther-                (listToMaybe $ mapMaybe (T.stripPrefix "sqltype=") $ fieldAttrs fd))+            (fieldSqlType fd)             (def $ fieldAttrs fd)             Nothing             (maxLen $ fieldAttrs fd)-            (ref (fieldDB fd) (fieldType fd) (fieldAttrs fd))+            (ref (fieldDB fd) (fieldReference fd) (fieldAttrs fd))      def :: [Attr] -> Maybe Text     def [] = Nothing@@ -57,12 +52,12 @@         | otherwise = maxLen as      ref :: DBName-        -> FieldType+        -> ReferenceDef         -> [Attr]         -> Maybe (DBName, DBName) -- table name, constraint name-    ref c ft []-        | Just f <- stripId ft =-            Just (resolveTableName allDefs $ HaskellName f, refName tn c)+    ref c fe []+        | ForeignRef f <- fe =+            Just (resolveTableName allDefs f, refName tn c)         | otherwise = Nothing     ref _ _ ("noreference":_) = Nothing     ref c _ (a:_)@@ -74,13 +69,8 @@ refName (DBName table) (DBName column) =     DBName $ mconcat [table, "_", column, "_fkey"] -resolveTableName :: [EntityDef a] -> HaskellName -> DBName+resolveTableName :: [EntityDef] -> HaskellName -> DBName resolveTableName [] (HaskellName hn) = error $ "Table not found: " `mappend` T.unpack hn resolveTableName (e:es) hn     | entityHaskell e == hn = entityDB e     | otherwise = resolveTableName es hn--convertKey :: Bool -> KeyBackend t t1 -> [PersistValue]-convertKey True (Key (PersistList fks)) = fks-convertKey False (Key ret@(PersistInt64 _)) = [ret]-convertKey composite k = error $ "invalid key type " ++ show k ++ " composite=" ++ show composite
Database/Persist/Sql/Migration.hs view
@@ -16,6 +16,7 @@ import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.IO.Class import Control.Monad.Trans.Writer+import Control.Monad.Trans.Reader (ReaderT (..), ask) import Control.Monad (liftM, unless) import Data.Text (Text, unpack, snoc, isPrefixOf, pack) import qualified Data.Text.IO@@ -23,7 +24,6 @@ import System.IO.Silently (hSilence) import Control.Monad.Trans.Control (liftBaseOp_) import Database.Persist.Sql.Types-import Database.Persist.Sql.Class import Database.Persist.Sql.Raw import Database.Persist.Types @@ -34,48 +34,50 @@ safeSql :: CautiousMigration -> [Sql] safeSql = allSql . filter (not . fst) -parseMigration :: Monad m => Migration m -> m (Either [Text] CautiousMigration)+parseMigration :: MonadIO m => Migration -> ReaderT Connection m (Either [Text] CautiousMigration) parseMigration =-    liftM go . runWriterT . execWriterT+    liftIOReader . liftM go . runWriterT . execWriterT   where     go ([], sql) = Right sql     go (errs, _) = Left errs +    liftIOReader (ReaderT m) = ReaderT $ liftIO . m+ -- like parseMigration, but call error or return the CautiousMigration-parseMigration' :: Monad m => Migration m -> m (CautiousMigration)+parseMigration' :: MonadIO m => Migration -> ReaderT Connection m (CautiousMigration) parseMigration' m = do   x <- parseMigration m   case x of       Left errs -> error $ unlines $ map unpack errs       Right sql -> return sql -printMigration :: MonadIO m => Migration m -> m ()+printMigration :: MonadIO m => Migration -> ReaderT Connection m () printMigration m = do   mig <- parseMigration' m   mapM_ (liftIO . Data.Text.IO.putStrLn . flip snoc ';') (allSql mig) -getMigration :: (MonadBaseControl IO m, MonadIO m) => Migration m -> m [Sql]+getMigration :: (MonadBaseControl IO m, MonadIO m) => Migration -> ReaderT Connection m [Sql] getMigration m = do   mig <- parseMigration' m   return $ allSql mig -runMigration :: MonadSqlPersist m-             => Migration m-             -> m ()+runMigration :: MonadIO m+             => Migration+             -> ReaderT Connection m () runMigration m = runMigration' m False >> return ()  -- | Same as 'runMigration', but returns a list of the SQL commands executed -- instead of printing them to stderr.-runMigrationSilent :: (MonadBaseControl IO m, MonadSqlPersist m)-                   => Migration m-                   -> m [Text]+runMigrationSilent :: (MonadBaseControl IO m, MonadIO m)+                   => Migration+                   -> ReaderT Connection m [Text] runMigrationSilent m = liftBaseOp_ (hSilence [stderr]) $ runMigration' m True  runMigration'-    :: MonadSqlPersist m-    => Migration m+    :: MonadIO m+    => Migration     -> Bool -- ^ is silent?-    -> m [Text]+    -> ReaderT Connection m [Text] runMigration' m silent = do     mig <- parseMigration' m     case unsafeSql mig of@@ -86,14 +88,14 @@             , unlines $ map (\s -> "    " ++ unpack s ++ ";") $ errs             ] -runMigrationUnsafe :: MonadSqlPersist m-                   => Migration m-                   -> m ()+runMigrationUnsafe :: MonadIO m+                   => Migration+                   -> ReaderT Connection m () runMigrationUnsafe m = do     mig <- parseMigration' m     mapM_ (executeMigrate False) $ sortMigrations $ allSql mig -executeMigrate :: MonadSqlPersist m => Bool -> Text -> m Text+executeMigrate :: MonadIO m => Bool -> Text -> ReaderT Connection m Text executeMigrate silent s = do     unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ unpack s     rawExecute s []@@ -109,11 +111,10 @@     -- choose to have this special sorting applied.     isCreate t = pack "CREATe " `isPrefixOf` t -migrate :: MonadSqlPersist m-        => [EntityDef SqlType]-        -> EntityDef SqlType-        -> Migration m+migrate :: [EntityDef]+        -> EntityDef+        -> Migration migrate allDefs val = do-    conn <- askSqlConn+    conn <- lift $ lift ask     res <- liftIO $ connMigrateSql conn allDefs (getStmtConn conn) val     either tell (lift . tell) res
Database/Persist/Sql/Orphan/PersistQuery.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Sql.Orphan.PersistQuery@@ -9,18 +10,14 @@  import Database.Persist import Database.Persist.Sql.Types-import Database.Persist.Sql.Class import Database.Persist.Sql.Raw-import Database.Persist.Sql.Orphan.PersistStore ()-import Database.Persist.Sql.Internal (convertKey)+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.Logger import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Control.Monad.Trans.Resource (MonadResource)+import Control.Monad.Trans.Reader (ReaderT, ask) import Control.Exception (throwIO) import qualified Data.Conduit.List as CL import Data.Conduit@@ -29,36 +26,9 @@ import Data.List (transpose, inits, find)  -- orphaned instance for convenience of modularity-instance (MonadResource m, MonadLogger m) => PersistQuery (SqlPersistT m) where-    update _ [] = return ()-    update k upds = do-        conn <- askSqlConn-        let go'' n Assign = n <> "=?"-            go'' n Add = T.concat [n, "=", n, "+?"]-            go'' n Subtract = T.concat [n, "=", n, "-?"]-            go'' n Multiply = T.concat [n, "=", n, "*?"]-            go'' n Divide = T.concat [n, "=", n, "/?"]-        let go' (x, pu) = go'' (connEscapeName conn x) pu-        let composite = isJust $ entityPrimary t-        let wher = case entityPrimary t of-                Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (snd fld) <> "=? ") $ primaryFields pdef-                Nothing   -> connEscapeName conn (entityID t) <> "=?"-        let sql = T.concat-                [ "UPDATE "-                , connEscapeName conn $ entityDB t-                , " SET "-                , T.intercalate "," $ map (go' . go) upds-                , " WHERE "-                , wher-                ]-        rawExecute sql $-            map updatePersistValue upds `mappend` (convertKey composite k)-      where-        t = entityDef $ dummyFromKey k-        go x = (fieldDB $ updateFieldDef x, updateUpdate x)-+instance PersistQuery Connection where     count filts = do-        conn <- askSqlConn+        conn <- ask         let wher = if null filts                     then ""                     else filterClause False conn filts@@ -67,7 +37,7 @@                 , connEscapeName conn $ entityDB t                 , wher                 ]-        rawQuery sql (getFiltsValues conn filts) $$ do+        withRawQuery sql (getFiltsValues conn filts) $ do             mm <- CL.head             case mm of               Just [PersistInt64 i] -> return $ fromIntegral i@@ -80,9 +50,10 @@       where         t = entityDef $ dummyFromFilts filts -    selectSource filts opts = do-        conn <- lift askSqlConn-        rawQuery (sql conn) (getFiltsValues conn filts) $= CL.mapM parse+    selectSourceRes filts opts = do+        conn <- ask+        srcRes <- rawQueryRes (sql conn) (getFiltsValues conn filts)+        return $ fmap ($= CL.mapM parse) srcRes       where         composite = isJust $ entityPrimary t         (limit, offset, orders) = limitOffsetOrder opts@@ -90,7 +61,7 @@         parse vals =           case entityPrimary t of             Just pdef -> -                  let pks = map fst $ primaryFields pdef+                  let pks = map fieldHaskell $ primaryFields pdef                       keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) vals                   in case fromPersistValuesComposite' keyvals vals of                       Left s -> liftIO $ throwIO $ PersistMarshalError s@@ -101,21 +72,26 @@                     Right row -> return row          t = entityDef $ dummyFromFilts filts-        fromPersistValues' (PersistInt64 x:xs) = -            case fromPersistValues xs of-                Left e -> Left e-                Right xs' -> Right (Entity (Key $ PersistInt64 x) xs')-        fromPersistValues' (PersistDouble x:xs) = -- oracle returns Double ++        fromPersistValues' (kpv:xs) = -- oracle returns Double              case fromPersistValues xs of                 Left e -> Left e-                Right xs' -> Right (Entity (Key $ PersistInt64 (truncate x)) xs') -- convert back to int64+                Right xs' ->+                    case keyFromValues [kpv] of+                        Left _ -> error $ "fromPersistValues': keyFromValues failed on " ++ show kpv+                        Right k -> Right (Entity k xs')++         fromPersistValues' xs = Left $ T.pack ("error in fromPersistValues' xs=" ++ show xs)          fromPersistValuesComposite' keyvals xs =             case fromPersistValues xs of                 Left e -> Left e-                Right xs' -> Right (Entity (Key $ PersistList keyvals) xs')+                Right xs' -> case keyFromValues keyvals of+                    Left _ -> error "fromPersistValuesComposite': keyFromValues failed"+                    Right key -> Right (Entity key xs') +         wher conn = if null filts                     then ""                     else filterClause False conn filts@@ -135,13 +111,14 @@             , ord conn             ] -    selectKeys filts opts = do-        conn <- lift askSqlConn-        rawQuery (sql conn) (getFiltsValues conn filts) $= CL.mapM parse+    selectKeysRes filts opts = do+        conn <- ask+        srcRes <- rawQueryRes (sql conn) (getFiltsValues conn filts)+        return $ fmap ($= CL.mapM parse) srcRes       where         t = entityDef $ dummyFromFilts filts         cols conn = case entityPrimary t of -                     Just pdef -> T.intercalate "," $ map (connEscapeName conn . snd) $ primaryFields pdef+                     Just pdef -> T.intercalate "," $ map (connEscapeName conn . fieldDB) $ primaryFields pdef                      Nothing   -> connEscapeName conn $ entityID t                                wher conn = if null filts@@ -163,17 +140,23 @@                 [] -> ""                 ords -> " ORDER BY " <> T.intercalate "," ords -        parse xs = case entityPrimary t of+        parse xs = do+            keyvals <- case entityPrimary t of                       Nothing ->                          case xs of-                           [PersistInt64 x] -> return $ Key $ PersistInt64 x-                           [PersistDouble x] -> return $ Key $ PersistInt64 (truncate x) -- oracle returns Double +                           [PersistInt64 x] -> return [PersistInt64 x]+                           [PersistDouble x] -> return [PersistInt64 (truncate x)] -- oracle returns Double                             _ -> liftIO $ throwIO $ PersistMarshalError $ "Unexpected in selectKeys False: " <> T.pack (show xs)                       Just pdef -> -                           let pks = map fst $ primaryFields pdef+                           let pks = map fieldHaskell $ primaryFields pdef                                keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) xs-                           in return $ Key $ PersistList keyvals+                           in return keyvals+            case keyFromValues keyvals of+                Right k -> return k+                Left _ -> error "selectKeysImpl: keyFromValues failed" ++     deleteWhere filts = do         _ <- deleteWhereCount filts         return ()@@ -185,11 +168,11 @@ -- | Same as 'deleteWhere', but returns the number of rows affected. -- -- Since 1.1.5-deleteWhereCount :: (PersistEntity val, MonadSqlPersist m)+deleteWhereCount :: (PersistEntity val, MonadIO m)                  => [Filter val]-                 -> m Int64+                 -> ReaderT Connection m Int64 deleteWhereCount filts = do-    conn <- askSqlConn+    conn <- ask     let t = entityDef $ dummyFromFilts filts     let wher = if null filts                 then ""@@ -204,13 +187,13 @@ -- | Same as 'updateWhere', but returns the number of rows affected. -- -- Since 1.1.5-updateWhereCount :: (PersistEntity val, MonadSqlPersist m)+updateWhereCount :: (PersistEntity val, MonadIO m, SqlBackend ~ PersistEntityBackend val)                  => [Filter val]                  -> [Update val]-                 -> m Int64+                 -> ReaderT Connection m Int64 updateWhereCount _ [] = return 0 updateWhereCount filts upds = do-    conn <- askSqlConn+    conn <- ask     let wher = if null filts                 then ""                 else filterClause False conn filts@@ -234,8 +217,9 @@     go' conn (x, pu) = go'' (connEscapeName conn x) pu     go x = (fieldDB $ updateFieldDef x, updateUpdate x) -updateFieldDef :: PersistEntity v => Update v -> FieldDef SqlType+updateFieldDef :: PersistEntity v => Update v -> FieldDef updateFieldDef (Update f _ _) = persistFieldDef f+updateFieldDef _ = error "BackendUpdate not implemented"  dummyFromFilts :: [Filter v] -> Maybe v dummyFromFilts _ = Nothing@@ -281,23 +265,23 @@                     else                       case (allVals, pfilter, isCompFilter pfilter) of                         ([PersistList xs], Eq, _) -> -                           let sqlcl=T.intercalate " and " (map (\a -> connEscapeName conn (snd a) <> showSqlFilter pfilter <> "? ")  (primaryFields pdef))+                           let sqlcl=T.intercalate " and " (map (\a -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "? ")  (primaryFields pdef))                            in (wrapSql sqlcl,xs)                         ([PersistList xs], Ne, _) -> -                           let sqlcl=T.intercalate " or " (map (\a -> connEscapeName conn (snd a) <> showSqlFilter pfilter <> "? ")  (primaryFields pdef))+                           let sqlcl=T.intercalate " or " (map (\a -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "? ")  (primaryFields pdef))                            in (wrapSql sqlcl,xs)                         (_, In, _) ->                             let xxs = transpose (map fromPersistList allVals)-                               sqls=map (\(a,xs) -> connEscapeName conn (snd a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (primaryFields pdef) xxs)+                               sqls=map (\(a,xs) -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (primaryFields pdef) xxs)                            in (wrapSql (T.intercalate " and " (map wrapSql sqls)), concat xxs)                         (_, NotIn, _) ->                             let xxs = transpose (map fromPersistList allVals)-                               sqls=map (\(a,xs) -> connEscapeName conn (snd a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (primaryFields pdef) xxs)+                               sqls=map (\(a,xs) -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (primaryFields pdef) xxs)                            in (wrapSql (T.intercalate " or " (map wrapSql sqls)), concat xxs)                         ([PersistList xs], _, True) ->                             let zs = tail (inits (primaryFields pdef))                                sql1 = map (\b -> wrapSql (T.intercalate " and " (map (\(i,a) -> sql2 (i==length b) a) (zip [1..] b)))) zs-                               sql2 islast a = connEscapeName conn (snd a) <> (if islast then showSqlFilter pfilter else showSqlFilter Eq) <> "? "+                               sql2 islast a = connEscapeName conn (fieldDB a) <> (if islast then showSqlFilter pfilter else showSqlFilter Eq) <> "? "                                sqlcl = T.intercalate " or " sql1                            in (wrapSql sqlcl, concat (tail (inits xs)))                         (_, BackendSpecificFilter _, _) -> error "unhandled type BackendSpecificFilter for composite/non id primary keys"@@ -399,6 +383,7 @@  updatePersistValue :: Update v -> PersistValue updatePersistValue (Update _ v _) = toPersistValue v+updatePersistValue _ = error "BackendUpdate not implemented"  filterClause :: PersistEntity val              => Bool -- ^ include table name?@@ -416,7 +401,7 @@     case o of         Asc  x -> name $ persistFieldDef x         Desc x -> name (persistFieldDef x) <> " DESC"-        _ -> error $ "orderClause: expected Asc or Desc, not limit or offset"+        _ -> error "orderClause: expected Asc or Desc, not limit or offset"   where     dummyFromOrder :: SelectOpt a -> Maybe a     dummyFromOrder _ = Nothing@@ -428,9 +413,6 @@             then ((tn <> ".") <>)             else id)         $ connEscapeName conn $ fieldDB x--dummyFromKey :: KeyBackend SqlBackend v -> Maybe v-dummyFromKey _ = Nothing  -- | Generates sql for limit and offset for postgres, sqlite and mysql. decorateSQLWithLimitOffset::Text -> (Int,Int) -> Bool -> Text -> Text
Database/Persist/Sql/Orphan/PersistStore.hs view
@@ -1,58 +1,113 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-module Database.Persist.Sql.Orphan.PersistStore () where+module Database.Persist.Sql.Orphan.PersistStore (withRawQuery, BackendKey(..)) where  import Database.Persist import Database.Persist.Sql.Types-import Database.Persist.Sql.Class import Database.Persist.Sql.Raw-import Database.Persist.Sql.Internal (convertKey) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL-import Control.Monad.Logger import qualified Data.Text as T-import Data.Text (Text, unpack)+import Data.Text (Text, unpack, pack) import Data.Monoid (mappend, (<>)) import Control.Monad.IO.Class import Data.ByteString.Char8 (readInteger) import Data.Maybe (isJust) import Data.List (find)-import Control.Monad.Trans.Resource (MonadResource)+import Control.Monad.Trans.Reader (ReaderT, ask)+import Data.Acquire (with)+import Data.Int (Int64)+import Web.PathPieces (PathPiece)+import Database.Persist.Sql.Class (PersistFieldSql)+import qualified Data.Aeson as A -instance (MonadResource m, MonadLogger m) => PersistStore (SqlPersistT m) where-    type PersistMonadBackend (SqlPersistT m) = SqlBackend+withRawQuery :: MonadIO m+             => Text+             -> [PersistValue]+             -> C.Sink [PersistValue] IO a+             -> ReaderT Connection m a+withRawQuery sql vals sink = do+    srcRes <- rawQueryRes sql vals+    liftIO $ with srcRes (C.$$ sink)++instance PersistStore Connection where+    newtype BackendKey SqlBackend = SqlBackendKey { unSqlBackendKey :: Int64 }+        deriving (Show, Read, Eq, Ord, Num, Integral, PersistField, PersistFieldSql, PathPiece, Real, Enum, Bounded, A.ToJSON, A.FromJSON)++    backendKeyToValues (SqlBackendKey i)   = [PersistInt64 i]+    backendKeyFromValues [PersistInt64 i]  = Right $ SqlBackendKey i+    backendKeyFromValues [PersistDouble i] = Right $ SqlBackendKey $ truncate i+    backendKeyFromValues s = Left $ pack $ show s++    update _ [] = return ()+    update k upds = do+        conn <- ask+        let go'' n Assign = n <> "=?"+            go'' n Add = T.concat [n, "=", n, "+?"]+            go'' n Subtract = T.concat [n, "=", n, "-?"]+            go'' n Multiply = T.concat [n, "=", n, "*?"]+            go'' n Divide = T.concat [n, "=", n, "/?"]+        let go' (x, pu) = go'' (connEscapeName conn x) pu+        let wher = case entityPrimary t of+                Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (fieldDB fld) <> "=? ") $ primaryFields pdef+                Nothing   -> connEscapeName conn (entityID t) <> "=?"+        let sql = T.concat+                [ "UPDATE "+                , connEscapeName conn $ entityDB t+                , " SET "+                , T.intercalate "," $ map (go' . go) upds+                , " WHERE "+                , wher+                ]+        rawExecute sql $+            map updatePersistValue upds `mappend` keyToValues k+      where+        t = entityDef $ dummyFromKey k+        go x = (fieldDB $ updateFieldDef x, updateUpdate x)+     insert val = do-        conn <- askSqlConn+        conn <- ask         let esql = connInsertSql conn t vals         key <-             case esql of-                ISRSingle sql -> rawQuery sql vals C.$$ do+                ISRSingle sql -> withRawQuery sql vals $ do                     x <- CL.head                     case x of-                        Just [PersistInt64 i] -> return $ Key $ PersistInt64 i+                        Just [PersistInt64 i] -> case keyFromValues [PersistInt64 i] of+                            Left err -> error $ "SQL insert: keyFromValues: PersistInt64 " `mappend` show i `mappend` " " `mappend` unpack err+                            Right k -> return k                         Nothing -> error $ "SQL insert did not return a result giving the generated ID"-                        Just vals' -> error $ "Invalid result from a SQL insert, got: " ++ show vals'+                        Just vals' -> case keyFromValues vals' of+                            Left _ -> error $ "Invalid result from a SQL insert, got: " ++ show vals'+                            Right k -> return k+                 ISRInsertGet sql1 sql2 -> do                     rawExecute sql1 vals-                    rawQuery sql2 [] C.$$ do+                    withRawQuery sql2 [] $ do                         mm <- CL.head-                        case mm of-                          Just [PersistInt64 i] -> return $ Key $ PersistInt64 i-                          Just [PersistDouble i] ->return $ Key $ PersistInt64 $ truncate i -- oracle need this!-                          Just [PersistByteString i] -> case readInteger i of -- mssql-                                                          Just (ret,"") -> return $ Key $ PersistInt64 $ fromIntegral ret-                                                          xs -> error $ "invalid number i["++show i++"] xs[" ++ show xs ++ "]"-                          Just xs -> error $ "invalid sql2 return xs["++show xs++"] sql2["++show sql2++"] sql1["++show sql1++"]"-                          Nothing -> error $ "invalid sql2 returned nothing sql2["++show sql2++"] sql1["++show sql1++"]"+                        i <- case mm of+                            Just [PersistInt64 i] -> return $ i+                            Just [PersistDouble i] ->return $ truncate i -- oracle need this!+                            Just [PersistByteString i] -> case readInteger i of -- mssql+                                                            Just (ret,"") -> return $ fromIntegral ret+                                                            xs -> error $ "invalid number i["++show i++"] xs[" ++ show xs ++ "]"+                            Just xs -> error $ "invalid sql2 return xs["++show xs++"] sql2["++show sql2++"] sql1["++show sql1++"]"+                            Nothing -> error $ "invalid sql2 returned nothing sql2["++show sql2++"] sql1["++show sql1++"]"+                        case keyFromValues [PersistInt64 i] of+                            Right k -> return k+                            Left err -> error $ "ISRInsertGet: keyFromValues failed: " `mappend` unpack err                 ISRManyKeys sql fs -> do                     rawExecute sql vals                      case entityPrimary t of                        Nothing -> error $ "ISRManyKeys is used when Primary is defined " ++ show sql                        Just pdef -> -                            let pks = map fst $ primaryFields pdef+                            let pks = map fieldHaskell $ primaryFields pdef                                 keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) fs-                            in return $ Key $ PersistList keyvals+                            in  case keyFromValues keyvals of+                                    Right k -> return k+                                    Left e  -> error $ "ISRManyKeys: unexpected keyvals result: " `mappend` unpack e          return key       where@@ -60,7 +115,7 @@         vals = map toPersistValue $ toPersistFields val      replace k val = do-        conn <- askSqlConn+        conn <- ask         let t = entityDef $ Just val         let sql = T.concat                 [ "UPDATE "@@ -71,7 +126,7 @@                 , connEscapeName conn $ entityID t                 , "=?"                 ]-            vals = map toPersistValue (toPersistFields val) `mappend` [unKey k]+            vals = map toPersistValue (toPersistFields val) `mappend` keyToValues k         rawExecute sql vals       where         go conn x = connEscapeName conn x `T.append` "=?"@@ -85,15 +140,14 @@           Just _ -> replace key value      get k = do-        conn <- askSqlConn+        conn <- ask         let t = entityDef $ dummyFromKey k-        let composite = isJust $ entityPrimary t         let cols = T.intercalate ","                  $ map (connEscapeName conn . fieldDB) $ entityFields t             noColumns :: Bool             noColumns = null $ entityFields t         let wher = case entityPrimary t of-                     Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (snd fld) <> "=? ") $ primaryFields pdef+                     Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (fieldDB fld) <> "=? ") $ primaryFields pdef                      Nothing   -> connEscapeName conn (entityID t) <> "=?"         let sql = T.concat                 [ "SELECT "@@ -103,24 +157,23 @@                 , " WHERE "                 , wher                 ]-        rawQuery sql (convertKey composite k) C.$$ do+        withRawQuery sql (keyToValues k) $ do             res <- CL.head             case res of                 Nothing -> return Nothing                 Just vals ->                     case fromPersistValues $ if noColumns then [] else vals of-                        Left e -> error $ "get " ++ show (unKey k) ++ ": " ++ unpack e+                        Left e -> error $ "get " ++ show k ++ ": " ++ unpack e                         Right v -> return $ Just v      delete k = do-        conn <- askSqlConn-        rawExecute (sql conn) (convertKey composite k)+        conn <- ask+        rawExecute (sql conn) (keyToValues k)       where         t = entityDef $ dummyFromKey k-        composite = isJust $ entityPrimary t          wher conn =                case entityPrimary t of-                Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (snd fld) <> "=? ") $ primaryFields pdef+                Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (fieldDB fld) <> "=? ") $ primaryFields pdef                 Nothing   -> connEscapeName conn (entityID t) <> "=?"         sql conn = T.concat             [ "DELETE FROM "@@ -129,16 +182,16 @@             , wher conn             ] -dummyFromKey :: KeyBackend SqlBackend v -> Maybe v+dummyFromKey :: Key v -> Maybe v dummyFromKey _ = Nothing -insrepHelper :: (MonadIO m, PersistEntity val, MonadLogger m, MonadSqlPersist m)+insrepHelper :: (MonadIO m, PersistEntity val)              => Text              -> Key val              -> val-             -> m ()-insrepHelper command (Key k) val = do-    conn <- askSqlConn+             -> ReaderT Connection m ()+insrepHelper command k val = do+    conn <- ask     rawExecute (sql conn) vals   where     t = entityDef $ Just val@@ -154,4 +207,11 @@         , T.intercalate "," ("?" : map (const "?") (entityFields t))         , ")"         ]-    vals = k : map toPersistValue (toPersistFields val)+    vals = keyToValues k ++ map toPersistValue (toPersistFields val)++updateFieldDef :: PersistEntity v => Update v -> FieldDef+updateFieldDef (Update f _ _) = persistFieldDef f+updateFieldDef (BackendUpdate {}) = error "updateFieldDef did not expect BackendUpdate"++updatePersistValue :: Update v -> PersistValue+updatePersistValue (Update _ v _) = toPersistValue v
Database/Persist/Sql/Orphan/PersistUnique.hs view
@@ -4,26 +4,25 @@  import Database.Persist import Database.Persist.Sql.Types-import Database.Persist.Sql.Class import Database.Persist.Sql.Raw-import Database.Persist.Sql.Orphan.PersistStore ()+import Database.Persist.Sql.Orphan.PersistStore (withRawQuery) import qualified Data.Text as T-import Data.Monoid ((<>))+import Data.Monoid (mappend) import Control.Monad.Logger import qualified Data.Conduit.List as CL import Data.Conduit-import Control.Monad.Trans.Resource (MonadResource)+import Control.Monad.Trans.Reader (ask) -instance (MonadResource m, MonadLogger m) => PersistUnique (SqlPersistT m) where+instance PersistUnique Connection where     deleteBy uniq = do-        conn <- askSqlConn+        conn <- ask         let sql' = sql conn             vals = persistUniqueToValues uniq         rawExecute sql' vals       where         t = entityDef $ dummyFromUnique uniq         go = map snd . persistUniqueToFieldNames-        go' conn x = connEscapeName conn x <> "=?"+        go' conn x = connEscapeName conn x `mappend` "=?"         sql conn = T.concat             [ "DELETE FROM "             , connEscapeName conn $ entityDB t@@ -32,7 +31,7 @@             ]      getBy uniq = do-        conn <- askSqlConn+        conn <- ask         let flds = map (connEscapeName conn . fieldDB) (entityFields t)         let cols = case entityPrimary t of                      Just _ -> T.intercalate "," flds@@ -46,23 +45,22 @@                 , sqlClause conn                 ]             vals' = persistUniqueToValues uniq-        rawQuery sql vals' $$ do+        withRawQuery sql vals' $ do             row <- CL.head             case row of                 Nothing -> return Nothing-                Just (PersistInt64 k:vals) ->-                    case fromPersistValues vals of-                        Left s -> error $ T.unpack s-                        Right x -> return $ Just (Entity (Key $ PersistInt64 k) x)-                Just (PersistDouble k:vals) ->   -- oracle+                Just [] -> error "getBy: empty row"+                Just (kpv:vals) ->                     case fromPersistValues vals of                         Left s -> error $ T.unpack s-                        Right x -> return $ Just (Entity (Key $ PersistInt64 $ truncate k) x)-                Just xs -> error $ "Database.Persist.GenericSql: Bad list in getBy xs="++show xs+                        Right x ->+                            case keyFromValues [kpv] of+                                Right k -> return $ Just (Entity k x)+                                Left _ -> error $ "getBy: keyFromValues failed: " `mappend` show kpv       where         sqlClause conn =             T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq-        go conn x = connEscapeName conn x <> "=?"+        go conn x = connEscapeName conn x `mappend` "=?"         t = entityDef $ dummyFromUnique uniq         toFieldNames' = map snd . persistUniqueToFieldNames
Database/Persist/Sql/Raw.hs view
@@ -1,49 +1,67 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-} 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.Monad.IO.Class (liftIO)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader (ReaderT, ask, MonadReader)+import Control.Monad.Trans.Resource (release)+import Data.Acquire (allocateAcquire, Acquire, mkAcquire, with) import Data.IORef (writeIORef, readIORef, newIORef) import Control.Exception (throwIO) import Control.Monad (when, liftM) import Data.Text (Text, pack)-import Control.Monad.Logger (logDebugS)+import Control.Monad.Logger (logDebugS, runLoggingT) import Data.Int (Int64)-import Control.Monad.Trans.Class (lift) import qualified Data.Text as T import Data.Conduit import Control.Monad.Trans.Resource (MonadResource) -rawQuery :: (MonadSqlPersist m, MonadResource m)+rawQuery :: (MonadResource m, MonadReader env m, HasPersistBackend env Connection)          => Text          -> [PersistValue]          -> Source m [PersistValue] rawQuery sql vals = do-    lift $ $logDebugS (pack "SQL") $ pack $ show sql ++ " " ++ show vals-    conn <- lift askSqlConn-    bracketP-        (getStmtConn conn sql)-        stmtReset-        (flip stmtQuery vals)+    srcRes <- liftPersist $ rawQueryRes sql vals+    (releaseKey, src) <- allocateAcquire srcRes+    src+    release releaseKey -rawExecute :: MonadSqlPersist m => Text -> [PersistValue] -> m ()+rawQueryRes+    :: (MonadIO m1, MonadIO m2)+    => Text+    -> [PersistValue]+    -> ReaderT Connection m1 (Acquire (Source m2 [PersistValue]))+rawQueryRes sql vals = do+    conn <- ask+    let make = do+            runLoggingT ($logDebugS (pack "SQL") $ pack $ show sql ++ " " ++ show vals)+                (connLogFunc conn)+            getStmtConn conn sql+    return $ do+        stmt <- mkAcquire make stmtReset+        stmtQuery stmt vals++rawExecute :: MonadIO m => Text -> [PersistValue] -> ReaderT Connection m () rawExecute x y = liftM (const ()) $ rawExecuteCount x y -rawExecuteCount :: MonadSqlPersist m => Text -> [PersistValue] -> m Int64+rawExecuteCount :: MonadIO m => Text -> [PersistValue] -> ReaderT Connection m Int64 rawExecuteCount sql vals = do-    $logDebugS (pack "SQL") $ pack $ show sql ++ " " ++ show vals+    conn <- ask+    runLoggingT ($logDebugS (pack "SQL") $ pack $ show sql ++ " " ++ show vals)+        (connLogFunc conn)     stmt <- getStmt sql     res <- liftIO $ stmtExecute stmt vals     liftIO $ stmtReset stmt     return res -getStmt :: MonadSqlPersist m => Text -> m Statement+getStmt :: MonadIO m => Text -> ReaderT Connection m Statement getStmt sql = do-    conn <- askSqlConn+    conn <- ask     liftIO $ getStmtConn conn sql  getStmtConn :: Connection -> Text -> IO Statement@@ -101,10 +119,10 @@ -- However, most common problems are mitigated by using the -- entity selection placeholder @??@, and you shouldn't see any -- error at all if you're not using 'Single'.-rawSql :: (RawSql a, MonadSqlPersist m, MonadResource m)+rawSql :: (RawSql a, MonadIO m)        => Text             -- ^ SQL statement, possibly with placeholders.        -> [PersistValue]   -- ^ Values to fill the placeholders.-       -> m [a]+       -> ReaderT Connection m [a] rawSql stmt = run     where       getType :: (x -> m [a]) -> a@@ -113,8 +131,9 @@       x = getType run       process = rawSqlProcessRow -      withStmt' colSubsts params = do-            rawQuery sql params+      withStmt' colSubsts params sink = do+            srcRes <- rawQueryRes sql params+            liftIO $ with srcRes ($$ sink)           where             sql = T.concat $ makeSubsts colSubsts $ T.splitOn placeholder stmt             placeholder = "??"@@ -131,9 +150,9 @@                         ]        run params = do-        conn <- askSqlConn+        conn <- ask         let (colCount, colSubsts) = rawSqlCols (connEscapeName conn) x-        withStmt' colSubsts params $$ firstRow colCount+        withStmt' colSubsts params $ firstRow colCount        firstRow colCount = do         mrow <- await
Database/Persist/Sql/Run.hs view
@@ -3,8 +3,9 @@  import Database.Persist.Sql.Types import Database.Persist.Sql.Raw+import Control.Monad.Trans.Control import Data.Pool as P-import Control.Monad.Trans.Reader+import Control.Monad.Trans.Reader hiding (local) import Control.Monad.Trans.Resource import Control.Monad.Logger import Control.Monad.Base@@ -17,7 +18,9 @@ import Data.IORef (readIORef) import qualified Data.Map as Map import Control.Exception.Lifted (throwIO)+import Control.Exception (mask) import Control.Monad (liftM)+import System.Timeout (timeout)  -- | Get a connection from the pool, run the given action, and then return the -- connection to the pool.@@ -26,26 +29,30 @@     mres <- withResourceTimeout 2000000 pconn $ runSqlConn r     maybe (throwIO Couldn'tGetSQLConnection) return mres -withResourceTimeout-  :: (MonadBaseControl IO m)+-- | Like 'withResource', but times out the operation if resource+-- allocation does not complete within the given timeout period.+--+-- Since 2.0.0+withResourceTimeout ::+    (MonadBaseControl IO m)   => Int -- ^ Timeout period in microseconds-  -> P.Pool a+  -> Pool a   -> (a -> m b)   -> m (Maybe b)-{-# SPECIALIZE withResourceTimeout :: Int -> P.Pool a -> (a -> IO b) -> IO (Maybe b) #-}+{-# SPECIALIZE withResourceTimeout :: Int -> Pool a -> (a -> IO b) -> IO (Maybe b) #-} withResourceTimeout ms pool act = control $ \runInIO -> mask $ \restore -> do-    mres <- timeout ms $ P.takeResource pool+    mres <- timeout ms $ takeResource pool     case mres of         Nothing -> runInIO $ return Nothing         Just (resource, local) -> do             ret <- restore (runInIO (liftM Just $ act resource)) `onException`-                    P.destroyResource pool local resource-            P.putResource local resource+                    destroyResource pool local resource+            putResource local resource             return ret {-# INLINABLE withResourceTimeout #-}  runSqlConn :: MonadBaseControl IO m => SqlPersistT m a -> Connection -> m a-runSqlConn (SqlPersistT r) conn = do+runSqlConn r conn = do     let getter = getStmtConn conn     liftBase $ connBegin conn getter     x <- onException@@ -60,8 +67,8 @@ runSqlPersistMPool :: SqlPersistM a -> Pool Connection -> IO a runSqlPersistMPool x pool = runResourceT $ runNoLoggingT $ runSqlPool x pool -withSqlPool :: MonadIO m-            => IO Connection -- ^ create a new connection+withSqlPool :: (MonadIO m, MonadLogger m, MonadBaseControl IO m)+            => (LogFunc -> IO Connection) -- ^ create a new connection             -> Int -- ^ connection count             -> (Pool Connection -> m a)             -> m a@@ -69,15 +76,28 @@     pool <- createSqlPool mkConn connCount     f pool -createSqlPool :: MonadIO m-              => IO Connection+createSqlPool :: (MonadIO m, MonadLogger m, MonadBaseControl IO m)+              => (LogFunc -> IO Connection)               -> Int               -> m (Pool Connection)-createSqlPool mkConn = liftIO . createPool mkConn close' 1 20+createSqlPool mkConn size = do+    logFunc <- askLogFunc+    liftIO $ createPool (mkConn logFunc) close' 1 20 size -withSqlConn :: (MonadIO m, MonadBaseControl IO m)-            => IO Connection -> (Connection -> m a) -> m a-withSqlConn open = bracket (liftIO open) (liftIO . close')+-- NOTE: This function is a terrible, ugly hack. It would be much better to+-- just clean up monad-logger.+askLogFunc :: (MonadBaseControl IO m, MonadLogger m) => m LogFunc+askLogFunc = do+    runInBase <- control $ \run -> run $ return run+    return $ \a b c d -> do+        _ <- runInBase (monadLoggerLog a b c d)+        return ()++withSqlConn :: (MonadIO m, MonadBaseControl IO m, MonadLogger m)+            => (LogFunc -> IO Connection) -> (Connection -> m a) -> m a+withSqlConn open f = do+    logFunc <- askLogFunc+    bracket (liftIO $ open logFunc) (liftIO . close') f  close' :: Connection -> IO () close' conn = do
Database/Persist/Sql/Types.hs view
@@ -10,32 +10,26 @@ module Database.Persist.Sql.Types where  import Control.Exception (Exception)-import Control.Monad.Trans.Resource (MonadResource (..), MonadThrow (..), ResourceT)-#if MIN_VERSION_exceptions(0,6,0)-import Control.Monad.Catch (MonadCatch, MonadMask)-#endif-import Control.Monad.Logger (MonadLogger (..), NoLoggingT)+import Control.Monad.Trans.Resource (MonadResource (..), ResourceT)+import Data.Acquire (Acquire)+import Control.Monad.Logger (NoLoggingT) import Control.Monad.Trans.Control-import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Reader (ReaderT (..))-import Control.Applicative (Applicative (..)) import Control.Monad.Trans.Writer (WriterT)-import Control.Monad.Base (MonadBase (..))-import Control.Monad (MonadPlus (..)) import Data.Typeable (Typeable) import Control.Monad (liftM) import Database.Persist.Types-import Data.Text (Text, pack)-import qualified Data.Text as T+import Database.Persist.Class (HasPersistBackend (..)) import Data.IORef (IORef) import Data.Map (Map) import Data.Int (Int64) import Data.Conduit (Source) import Data.Pool (Pool)-import Web.PathPieces-import Control.Exception (throw)-import qualified Data.Text.Read+import Language.Haskell.TH.Syntax (Loc)+import Control.Monad.Logger (LogSource, LogLevel)+import System.Log.FastLogger (LogStr)+import Data.Text (Text)  data InsertSqlResult = ISRSingle Text                      | ISRInsertGet Text Text@@ -44,13 +38,13 @@ data Connection = Connection     { connPrepare :: Text -> IO Statement     -- | table name, column names, id name, either 1 or 2 statements to run-    , connInsertSql :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult+    , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult     , connStmtMap :: IORef (Map Text Statement)     , connClose :: IO ()     , connMigrateSql-        :: [EntityDef SqlType]+        :: [EntityDef]         -> (Text -> IO Statement)-        -> EntityDef SqlType+        -> EntityDef         -> IO (Either [Text] [(Bool, Text)])     , connBegin :: (Text -> IO Statement) -> IO ()     , connCommit :: (Text -> IO Statement) -> IO ()@@ -59,15 +53,21 @@     , connNoLimit :: Text     , connRDBMS :: Text     , connLimitOffset :: (Int,Int) -> Bool -> Text -> Text+    , connLogFunc :: LogFunc     }+    deriving Typeable+instance HasPersistBackend Connection Connection where+    persistBackend = id +type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()+ data Statement = Statement     { stmtFinalize :: IO ()     , stmtReset :: IO ()     , stmtExecute :: [PersistValue] -> IO Int64-    , stmtQuery :: forall m. MonadResource m+    , stmtQuery :: forall m. MonadIO m                 => [PersistValue]-                -> Source m [PersistValue]+                -> Acquire (Source m [PersistValue])     }  data Column = Column@@ -86,71 +86,23 @@     deriving (Typeable, Show) instance Exception PersistentSqlException -data SqlBackend-    deriving Typeable+type SqlBackend = Connection -- FIXME -newtype SqlPersistT m a = SqlPersistT { unSqlPersistT :: ReaderT Connection m a }-    deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadPlus-#if MIN_VERSION_exceptions(0,6,0)-#if MIN_VERSION_resourcet(1,1,0)-        , MonadThrow-        , MonadCatch-        , MonadMask-#endif-#endif-    )+type SqlPersistT = ReaderT Connection -- FIXME rename connection  type SqlPersist = SqlPersistT {-# DEPRECATED SqlPersist "Please use SqlPersistT instead" #-}  type SqlPersistM = SqlPersistT (NoLoggingT (ResourceT IO)) -#if MIN_VERSION_resourcet(1,1,0)-#if !MIN_VERSION_exceptions(0,6,0)-instance MonadThrow m => MonadThrow (SqlPersistT m) where-    throwM = lift . throwM-#endif--#else-instance MonadThrow m => MonadThrow (SqlPersistT m) where-    monadThrow = lift . monadThrow-#endif--instance MonadBase backend m => MonadBase backend (SqlPersistT m) where-    liftBase = lift . liftBase--instance MonadBaseControl backend m => MonadBaseControl backend (SqlPersistT m) where-     newtype StM (SqlPersistT m) a = StMSP {unStMSP :: ComposeSt SqlPersistT m a}-     liftBaseWith = defaultLiftBaseWith StMSP-     restoreM     = defaultRestoreM   unStMSP-instance MonadTransControl SqlPersistT where-    newtype StT SqlPersistT a = StReader {unStReader :: a}-    liftWith f = SqlPersistT $ ReaderT $ \r -> f $ \t -> liftM StReader $ runReaderT (unSqlPersistT t) r-    restoreT = SqlPersistT . ReaderT . const . liftM unStReader--instance MonadResource m => MonadResource (SqlPersistT m) where-    liftResourceT = lift . liftResourceT--instance MonadLogger m => MonadLogger (SqlPersistT m) where-    monadLoggerLog a b c = lift . monadLoggerLog a b c- type Sql = Text  -- Bool indicates if the Sql is safe type CautiousMigration = [(Bool, Sql)] -type Migration m = WriterT [Text] (WriterT CautiousMigration m) ()+type Migration = WriterT [Text] (WriterT CautiousMigration (ReaderT Connection IO)) ()  type ConnectionPool = Pool Connection--instance PathPiece (KeyBackend SqlBackend entity) where-    toPathPiece (Key (PersistInt64 i)) = toPathPiece i-    toPathPiece k = throw $ PersistInvalidField $ pack $ "Invalid Key: " ++ show k-    fromPathPiece t =-        case Data.Text.Read.signed Data.Text.Read.decimal t of-            Right (i, t') | T.null t' -> Just $ Key $ PersistInt64 i-            _ -> Nothing-  -- $rawSql --
Database/Persist/Types/Base.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-} module Database.Persist.Types.Base where  import qualified Data.Aeson as A@@ -24,7 +25,6 @@ import Data.Bits (shiftL, shiftR) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8-import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone) import Data.Map (Map) import qualified Data.HashMap.Strict as HM import Data.Word (Word32)@@ -105,12 +105,12 @@                  | ByNullableAttr                   deriving (Eq, Show) -data EntityDef sqlType = EntityDef+data EntityDef = EntityDef     { entityHaskell :: !HaskellName     , entityDB      :: !DBName     , entityID      :: !DBName     , entityAttrs   :: ![Attr]-    , entityFields  :: ![FieldDef sqlType]+    , entityFields  :: ![FieldDef]     , entityPrimary :: Maybe PrimaryDef     , entityUniques :: ![UniqueDef]     , entityForeigns:: ![ForeignDef]@@ -118,7 +118,7 @@     , entityExtra   :: !(Map Text [ExtraLine])     , entitySum     :: !Bool     }-    deriving (Show, Eq, Read, Ord, Functor)+    deriving (Show, Eq, Read, Ord)  type ExtraLine = [Text] @@ -136,17 +136,53 @@     | FTList FieldType   deriving (Show, Eq, Read, Ord) -data FieldDef sqlType = FieldDef-    { fieldHaskell  :: !HaskellName -- ^ name of the field-    , fieldDB       :: !DBName-    , fieldType     :: !FieldType-    , fieldSqlType  :: !sqlType-    , fieldAttrs    :: ![Attr]   -- ^ user annotations for a field-    , fieldStrict   :: !Bool      -- ^ a strict field in the data type. Default: true-    , fieldEmbedded :: Maybe (EntityDef ()) -- ^ indicates that the field uses an embedded entity+data FieldDef = FieldDef+    { fieldHaskell   :: !HaskellName -- ^ name of the field+    , fieldDB        :: !DBName+    , fieldType      :: !FieldType+    , fieldSqlType   :: !SqlType+    , fieldAttrs     :: ![Attr]   -- ^ user annotations for a field+    , fieldStrict    :: !Bool      -- ^ a strict field in the data type. Default: true+    , fieldReference :: !ReferenceDef     }-    deriving (Show, Eq, Read, Ord, Functor)+    deriving (Show, Eq, Read, Ord) +data ReferenceDef = ForeignRef !HaskellName+                  | EmbedRef EmbedEntityDef+                  | NoReference+                  deriving (Show, Eq, Read, Ord)++-- | An EmbedEntityDef is the same as an EntityDef+-- But it is only used for fieldReference+-- so it only has data needed for embedding+data EmbedEntityDef = EmbedEntityDef+    { embeddedHaskell :: !HaskellName+    , embeddedFields  :: ![EmbedFieldDef]+    } deriving (Show, Eq, Read, Ord)++-- | An EmbedFieldDef is the same as a FieldDef+-- But it is only used for embeddedFields+-- so it only has data needed for embedding+data EmbedFieldDef = EmbedFieldDef+    { emFieldDB       :: !DBName+    , emFieldEmbed :: Maybe EmbedEntityDef+    }+    deriving (Show, Eq, Read, Ord)++toEmbedEntityDef :: EntityDef -> EmbedEntityDef+toEmbedEntityDef ent = EmbedEntityDef+  { embeddedHaskell = entityHaskell ent+  , embeddedFields = map toEmbedFieldDef $ entityFields ent+  }++toEmbedFieldDef :: FieldDef -> EmbedFieldDef+toEmbedFieldDef field =+  EmbedFieldDef { emFieldDB       = fieldDB field+                   , emFieldEmbed = case fieldReference field of+                       EmbedRef em -> Just em+                       _ -> Nothing+                   }+ data UniqueDef = UniqueDef     { uniqueHaskell :: !HaskellName     , uniqueDBName  :: !DBName@@ -156,7 +192,7 @@     deriving (Show, Eq, Read, Ord)  data PrimaryDef = PrimaryDef-    { primaryFields  :: ![(HaskellName, DBName)]+    { primaryFields  :: ![FieldDef]     , primaryAttrs   :: ![Attr]     }     deriving (Show, Eq, Read, Ord)@@ -184,14 +220,6 @@ instance Error PersistException where     strMsg = PersistError . pack --- | Avoid orphan instances.-newtype ZT = ZT ZonedTime deriving (Show, Read, Typeable)--instance Eq ZT where-    ZT a /= ZT b = zonedTimeToLocalTime a /= zonedTimeToLocalTime b || zonedTimeZone a /= zonedTimeZone b-instance Ord ZT where-    ZT a `compare` ZT b = zonedTimeToUTC a `compare` zonedTimeToUTC b- -- | A raw value which can be stored in any backend and can be marshalled to -- and from a 'PersistField'. data PersistValue = PersistText Text@@ -203,7 +231,6 @@                   | PersistDay Day                   | PersistTimeOfDay TimeOfDay                   | PersistUTCTime UTCTime-                  | PersistZonedTime ZT                   | PersistNull                   | PersistList [PersistValue]                   | PersistMap [(Text, PersistValue)]@@ -247,10 +274,10 @@                     _ -> Just $ PersistText t     toPathPiece x =         case fromPersistValueText x of-            Left e -> error e+            Left e -> error $ T.unpack e             Right y -> y -fromPersistValueText :: PersistValue -> Either String Text+fromPersistValueText :: PersistValue -> Either Text Text fromPersistValueText (PersistText s) = Right s fromPersistValueText (PersistByteString bs) =     Right $ TE.decodeUtf8With lenientDecode bs@@ -260,7 +287,6 @@ fromPersistValueText (PersistDay d) = Right $ T.pack $ show d fromPersistValueText (PersistTimeOfDay d) = Right $ T.pack $ show d fromPersistValueText (PersistUTCTime d) = Right $ T.pack $ show d-fromPersistValueText (PersistZonedTime (ZT z)) = Right $ T.pack $ show z fromPersistValueText PersistNull = Left "Unexpected null" fromPersistValueText (PersistBool b) = Right $ T.pack $ show b fromPersistValueText (PersistList _) = Left "Cannot convert PersistList to Text"@@ -283,7 +309,6 @@     toJSON (PersistBool b) = A.Bool b     toJSON (PersistTimeOfDay t) = A.String $ T.pack $ 't' : show t     toJSON (PersistUTCTime u) = A.String $ T.pack $ 'u' : show u-    toJSON (PersistZonedTime z) = A.String $ T.pack $ 'z' : show z     toJSON (PersistDay d) = A.String $ T.pack $ 'd' : show d     toJSON PersistNull = A.Null     toJSON (PersistList l) = A.Array $ V.fromList $ map A.toJSON l@@ -317,7 +342,6 @@                            $ B64.decode $ TE.encodeUtf8 t             Just ('t', t) -> fmap PersistTimeOfDay $ readMay t             Just ('u', t) -> fmap PersistUTCTime $ readMay t-            Just ('z', t) -> fmap PersistZonedTime $ readMay t             Just ('d', t) -> fmap PersistDay $ readMay t             Just ('r', t) -> fmap PersistRational $ readMay t             Just ('o', t) -> maybe (fail "Invalid base64") (return . PersistObjectId) $@@ -367,33 +391,29 @@              | SqlBool              | SqlDay              | SqlTime-             | SqlDayTime-             | SqlDayTimeZoned+             | SqlDayTime -- ^ Always uses UTC timezone              | SqlBlob              | SqlOther T.Text -- ^ a backend-specific name     deriving (Show, Read, Eq, Typeable, Ord) -newtype KeyBackend backend entity = Key { unKey :: PersistValue }-    deriving (Show, Read, Eq, Ord)--type family KeyEntity key-type instance KeyEntity (KeyBackend backend entity) = entity--instance A.ToJSON (KeyBackend backend entity) where-    toJSON (Key val) = A.toJSON val--instance A.FromJSON (KeyBackend backend entity) where-    parseJSON = fmap Key . A.parseJSON- data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le | In | NotIn                    | BackendSpecificFilter T.Text     deriving (Read, Show) -data UpdateGetException = KeyNotFound String+data UpdateException = KeyNotFound String+                     | UpsertError String     deriving Typeable-instance Show UpdateGetException where+instance Show UpdateException where     show (KeyNotFound key) = "Key not found during updateGet: " ++ key-instance Exception UpdateGetException+    show (UpsertError msg) = "Error during upsert: " ++ msg+instance Exception UpdateException++data OnlyUniqueException = OnlyUniqueException String deriving Typeable+instance Show OnlyUniqueException where+    show (OnlyUniqueException uniqueMsg) =+      "Expected only one unique key, got " ++ uniqueMsg+instance Exception OnlyUniqueException+  data PersistUpdate = Assign | Add | Subtract | Multiply | Divide -- FIXME need something else here     deriving (Read, Show, Enum, Bounded)
persistent.cabal view
@@ -1,5 +1,5 @@ name:            persistent-version:         1.3.3+version:         2.0.0 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -28,10 +28,11 @@                    , text                     >= 0.8                    , containers               >= 0.2                    , conduit                  >= 1.0-                   , resourcet                >= 0.4-                   , exceptions+                   , resourcet                >= 1.1+                   , exceptions               >= 0.6                    , monad-control            >= 0.3                    , lifted-base              >= 0.1+                   , resource-pool                    , path-pieces              >= 0.1                    , aeson                    >= 0.5                    , monad-logger             >= 0.3@@ -44,8 +45,11 @@                    , blaze-html               >= 0.5                    , blaze-markup             >= 0.5.1                    , silently+                   , mtl+                   , fast-logger              >= 2.1                    , scientific                    , resource-pool+                   , tagged      exposed-modules: Database.Persist                      Database.Persist.Quasi
test/main.hs view
@@ -101,6 +101,3 @@                 baz = FTTypeCon Nothing "Baz"             parseFieldType "Foo [Bar] Baz" `shouldBe` Just (                 foo `FTApp` bars `FTApp` baz)-    describe "stripId" $ do-        it "works" $-            (parseFieldType "FooId" >>= stripId) `shouldBe` Just "Foo"