packages feed

persistent 1.1.5.1 → 1.2.0

raw patch · 37 files changed

+3080/−3061 lines, 37 filesdep ~aesondep ~basedep ~blaze-html

Dependency ranges changed: aeson, base, blaze-html, bytestring, conduit, monad-control, monad-logger, path-pieces, pool-conduit, resourcet, time, transformers

Files

Database/Persist.hs view
@@ -1,32 +1,173 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} module Database.Persist-    ( PersistField (..)-    , PersistEntity (..)-    , PersistStore (..)-    , PersistUnique (..)-    , PersistQuery (..)-    , KeyBackend (..)-    , Key-    , Entity (..)+    ( module Database.Persist.Class+    , module Database.Persist.Types++      -- * Store functions     , insertBy     , getJust     , belongsTo     , belongsToJust     , getByValue-    , checkUnique++      -- * Query functions     , selectList+    , selectKeysList     , deleteCascadeWhere -    , SelectOpt (..)-    , Filter (..)--    -- * query combinators+      -- * query combinators     , (=.), (+=.), (-=.), (*=.), (/=.)     , (==.), (!=.), (<.), (>.), (<=.), (>=.)     , (<-.), (/<-.)     , (||.)++      -- * JSON Utilities+    , listToJSON+    , mapToJSON+    , getPersistMap++      -- * Other utililities+    , limitOffsetOrder     ) where -import Database.Persist.Store-import Database.Persist.Query+import Database.Persist.Types+import Database.Persist.Class+import Database.Persist.Class.PersistField (getPersistMap)+import qualified Data.Text as T+import qualified Control.Exception as E+import Control.Monad (liftM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Builder (toLazyText)+import Data.Aeson (toJSON)+import Data.Aeson.Encode (fromValue)++-- | Insert a value, checking for conflicts with any unique constraints.  If a+-- duplicate exists in the database, it is returned as 'Left'. Otherwise, the+-- new 'Key is returned as 'Right'.+insertBy :: (PersistEntity v, PersistStore m, PersistUnique m, PersistMonadBackend m ~ PersistEntityBackend v)+          => v -> m (Either (Entity v) (Key v))+insertBy val =+    go $ persistUniqueKeys val+  where+    go [] = Right `liftM` insert val+    go (x:xs) = do+        y <- getBy x+        case y of+            Nothing -> go xs+            Just z -> return $ Left z++-- | A modification of 'getBy', which takes the 'PersistEntity' itself instead+-- of a 'Unique' value. Returns a value matching /one/ of the unique keys. This+-- function makes the most sense on entities with a single 'Unique'+-- constructor.+getByValue :: (PersistEntity v, PersistUnique m, PersistEntityBackend v ~ PersistMonadBackend m)+           => v -> m (Maybe (Entity v))+getByValue val =+    go $ persistUniqueKeys val+  where+    go [] = return Nothing+    go (x:xs) = do+        y <- getBy x+        case y of+            Nothing -> go xs+            Just z -> return $ Just z++-- | curry this to make a convenience function that loads an associated model+--   > foreign = belongsTo foeignId+belongsTo ::+  (PersistStore m+  , PersistEntity ent1+  , PersistEntity ent2+  , PersistMonadBackend m ~ PersistEntityBackend ent2+  ) => (ent1 -> Maybe (Key ent2)) -> ent1 -> m (Maybe ent2)+belongsTo foreignKeyField model = case foreignKeyField model of+    Nothing -> return Nothing+    Just f -> get f++-- | same as belongsTo, but uses @getJust@ and therefore is similarly unsafe+belongsToJust ::+  (PersistStore m+  , PersistEntity ent1+  , PersistEntity ent2+  , PersistMonadBackend m ~ PersistEntityBackend ent2)+  => (ent1 -> Key ent2) -> ent1 -> m ent2+belongsToJust getForeignKey model = getJust $ getForeignKey model++-- | Same as get, but for a non-null (not Maybe) foreign key+--   Unsafe unless your database is enforcing that the foreign key is valid+getJust :: (PersistStore m, PersistEntity val, Show (Key val), PersistMonadBackend m ~ PersistEntityBackend val) => Key val -> m val+getJust key = get key >>= maybe+  (liftIO $ E.throwIO $ PersistForeignConstraintUnmet $ T.pack $ show key)+  return++infixr 3 =., +=., -=., *=., /=.+(=.), (+=.), (-=.), (*=.), (/=.) :: forall v typ.  PersistField typ => EntityField v typ -> typ -> Update v+-- | assign a field a value+f =. a = Update f a Assign+-- | assign a field by addition (+=)+f +=. a = Update f a Add+-- | assign a field by subtraction (-=)+f -=. a = Update f a Subtract+-- | assign a field by multiplication (*=)+f *=. a = Update f a Multiply+-- | assign a field by division (/=)+f /=. a = Update f a Divide++infix 4 ==., <., <=., >., >=., !=.+(==.), (!=.), (<.), (<=.), (>.), (>=.) ::+  forall v typ.  PersistField typ => EntityField v typ -> typ -> Filter v+f ==. a  = Filter f (Left a) Eq+f !=. a = Filter f (Left a) Ne+f <. a  = Filter f (Left a) Lt+f <=. a  = Filter f (Left a) Le+f >. a  = Filter f (Left a) Gt+f >=. a  = Filter f (Left a) Ge++infix 4 <-., /<-.+(<-.), (/<-.) :: forall v typ.  PersistField typ => EntityField v typ -> [typ] -> Filter v+-- | In+f <-. a = Filter f (Right a) In+-- | NotIn+f /<-. a = Filter f (Right a) NotIn++infixl 3 ||.+(||.) :: forall v. [Filter v] -> [Filter v] -> [Filter v]+-- | the OR of two lists of filters+a ||. b = [FilterOr  [FilterAnd a, FilterAnd b]]++-- | Call 'selectSource' but return the result as a list.+selectList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m)+           => [Filter val]+           -> [SelectOpt val]+           -> m [Entity val]+selectList a b = selectSource a b C.$$ CL.consume++-- | Call 'selectKeys' but return the result as a list.+selectKeysList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m)+               => [Filter val]+               -> [SelectOpt val]+               -> m [Key val]+selectKeysList a b = selectKeys a b C.$$ CL.consume++deleteCascadeWhere :: (DeleteCascade a m, PersistQuery m)+                   => [Filter a] -> m ()+deleteCascadeWhere filts = selectKeys filts [] C.$$ CL.mapM_ deleteCascade++listToJSON :: [PersistValue] -> T.Text+listToJSON = toStrict . toLazyText . fromValue . toJSON++mapToJSON :: [(T.Text, PersistValue)] -> T.Text+mapToJSON = toStrict . toLazyText . fromValue . toJSON++limitOffsetOrder :: PersistEntity val => [SelectOpt val] -> (Int, Int, [SelectOpt val])+limitOffsetOrder opts =+    foldr go (0, 0, []) opts+  where+    go (LimitTo l) (_, b, c) = (l, b ,c)+    go (OffsetBy o) (a, _, c) = (a, o, c)+    go x (a, b, c) = (a, b, x : c)
+ Database/Persist/Class.hs view
@@ -0,0 +1,17 @@+module Database.Persist.Class+    ( DeleteCascade (..)+    , PersistEntity (..)+    , PersistQuery (..)+    , PersistUnique (..)+    , PersistConfig (..)+    , PersistField (..)+    , PersistStore (..)+    ) where++import Database.Persist.Class.DeleteCascade+import Database.Persist.Class.PersistEntity+import Database.Persist.Class.PersistQuery+import Database.Persist.Class.PersistUnique+import Database.Persist.Class.PersistConfig+import Database.Persist.Class.PersistField+import Database.Persist.Class.PersistStore
+ Database/Persist/Class/DeleteCascade.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+module Database.Persist.Class.DeleteCascade+    ( DeleteCascade (..)+    ) where++import Database.Persist.Class.PersistStore+import Database.Persist.Class.PersistEntity++class (PersistStore m, PersistEntity a, PersistEntityBackend a ~ PersistMonadBackend m) => DeleteCascade a m where+    deleteCascade :: Key a -> m ()
+ Database/Persist/Class/PersistConfig.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+module Database.Persist.Class.PersistConfig+    ( PersistConfig (..)+    ) where++import Data.Aeson (Value (Object))+import Data.Aeson.Types (Parser)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Applicative ((<$>))+import qualified Data.HashMap.Strict as HashMap++-- | Represents a value containing all the configuration options for a specific+-- backend. This abstraction makes it easier to write code that can easily swap+-- backends.+class PersistConfig c where+    type PersistConfigBackend c :: (* -> *) -> * -> *+    type PersistConfigPool c++    -- | Load the config settings from a 'Value', most likely taken from a YAML+    -- config file.+    loadConfig :: Value -> Parser c++    -- | Modify the config settings based on environment variables.+    applyEnv :: c -> IO c+    applyEnv = return++    -- | Create a new connection pool based on the given config settings.+    createPoolConfig :: c -> IO (PersistConfigPool c)++    -- | Run a database action by taking a connection from the pool.+    runPool :: (MonadBaseControl IO m, MonadIO m)+            => c+            -> PersistConfigBackend c m a+            -> PersistConfigPool c+            -> m a++instance+  ( PersistConfig c1+  , PersistConfig c2+  , PersistConfigPool c1 ~ PersistConfigPool c2+  , PersistConfigBackend c1 ~ PersistConfigBackend c2+  ) => PersistConfig (Either c1 c2) where+    type PersistConfigBackend (Either c1 c2) = PersistConfigBackend c1+    type PersistConfigPool (Either c1 c2) = PersistConfigPool c1++    loadConfig (Object o) =+        case HashMap.lookup "left" o of+            Just v -> Left <$> loadConfig v+            Nothing ->+                case HashMap.lookup "right" o of+                    Just v -> Right <$> loadConfig v+                    Nothing -> fail "PersistConfig for Either: need either a left or right"+    loadConfig _ = fail "PersistConfig for Either: need an object"++    createPoolConfig = either createPoolConfig createPoolConfig++    runPool (Left c) = runPool c+    runPool (Right c) = runPool c
+ Database/Persist/Class/PersistEntity.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+module Database.Persist.Class.PersistEntity+    ( PersistEntity (..)+    , Update (..)+    , SelectOpt (..)+    , BackendSpecificFilter+    , Filter (..)+    , Key+    , Entity (..)+    ) where++import Database.Persist.Types.Base+import Database.Persist.Class.PersistField+import Data.Text (Text)+import Data.Aeson (ToJSON (..), FromJSON (..), object, (.:), (.=), Value (Object))+import Control.Applicative ((<$>), (<*>))++-- | A single database entity. For example, if writing a blog application, a+-- blog entry would be an entry, containing fields such as title and content.+class PersistEntity val where+    -- | Parameters: val and datatype of the field+    data EntityField val :: * -> *+    persistFieldDef :: EntityField val typ -> FieldDef SqlType++    type PersistEntityBackend val++    -- | Unique keys in existence on this entity.+    data Unique val++    entityDef :: Monad m => m val -> EntityDef SqlType+    toPersistFields :: val -> [SomePersistField]+    fromPersistValues :: [PersistValue] -> Either Text val++    persistUniqueToFieldNames :: Unique val -> [(HaskellName, DBName)]+    persistUniqueToValues :: Unique val -> [PersistValue]+    persistUniqueKeys :: val -> [Unique val]++    persistIdField :: EntityField val (Key val)++    fieldLens :: EntityField val field+              -> (forall f. Functor f => (field -> f field) -> Entity val -> f (Entity val))++data Update v = forall typ. PersistField typ => Update+    { updateField :: EntityField v typ+    , updateValue :: typ+    , updateUpdate :: PersistUpdate -- FIXME Replace with expr down the road+    }++data SelectOpt v = forall typ. Asc (EntityField v typ)+                 | forall typ. Desc (EntityField v typ)+                 | OffsetBy Int+                 | LimitTo Int++type family BackendSpecificFilter b v++-- | Filters which are available for 'select', 'updateWhere' and+-- 'deleteWhere'. Each filter constructor specifies the field being+-- filtered on, the type of comparison applied (equals, not equals, etc)+-- and the argument for the comparison.+data Filter v = forall typ. PersistField typ => Filter+    { filterField  :: EntityField v typ+    , filterValue  :: Either typ [typ] -- FIXME+    , filterFilter :: PersistFilter -- FIXME+    }+    | FilterAnd [Filter v] -- ^ convenient for internal use, not needed for the API+    | FilterOr  [Filter v]+    | BackendFilter (BackendSpecificFilter (PersistEntityBackend v) v)++-- | Helper wrapper, equivalent to @Key (PersistEntityBackend val) val@.+--+-- Since 1.1.0+type Key val = KeyBackend (PersistEntityBackend val) val++-- | Datatype that represents an entity, with both its key and+-- its Haskell representation.+--+-- When using the an SQL-based backend (such as SQLite or+-- PostgreSQL), an 'Entity' may take any number of columns+-- depending on how many fields it has. In order to reconstruct+-- your entity on the Haskell side, @persistent@ needs all of+-- your entity columns and in the right order.  Note that you+-- don't need to worry about this when using @persistent@\'s API+-- since everything is handled correctly behind the scenes.+--+-- However, if you want to issue a raw SQL command that returns+-- an 'Entity', then you have to be careful with the column+-- order.  While you could use @SELECT Entity.* WHERE ...@ and+-- that would work most of the time, there are times when the+-- order of the columns on your database is different from the+-- order that @persistent@ expects (for example, if you add a new+-- field in the middle of you entity definition and then use the+-- migration code -- @persistent@ will expect the column to be in+-- the middle, but your DBMS will put it as the last column).+-- So, instead of using a query like the one above, you may use+-- 'Database.Persist.GenericSql.rawSql' (from the+-- "Database.Persist.GenericSql" module) with its /entity+-- selection placeholder/ (a double question mark @??@).  Using+-- @rawSql@ the query above must be written as @SELECT ??  WHERE+-- ..@.  Then @rawSql@ will replace @??@ with the list of all+-- columns that we need from your entity in the right order.  If+-- 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)++instance ToJSON e => ToJSON (Entity e) where+    toJSON (Entity k v) = object+        [ "key" .= k+        , "value" .= v+        ]+instance FromJSON e => FromJSON (Entity e) where+    parseJSON (Object o) = Entity+        <$> o .: "key"+        <*> o .: "value"+    parseJSON _ = fail "FromJSON Entity: not an object"
+ Database/Persist/Class/PersistField.hs view
@@ -0,0 +1,353 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE OverloadedStrings #-}+#ifndef NO_OVERLAP+{-# LANGUAGE OverlappingInstances #-}+#endif+module Database.Persist.Class.PersistField+    ( PersistField (..)+    , SomePersistField (..)+    , getPersistMap+    ) where++import Database.Persist.Types.Base+import Data.Monoid (mappend)+import Data.Time (Day(..), TimeOfDay, UTCTime)+#ifdef HIGH_PRECISION_DATE+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+#endif+import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone)+import Data.ByteString.Char8 (ByteString, unpack)+import Control.Applicative+import Data.Typeable (Typeable)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word, Word8, Word16, Word32, Word64)+import Data.Text (Text)+import Data.Fixed+import Data.Monoid ((<>))++import Text.Blaze.Html+import Text.Blaze.Html.Renderer.Text (renderHtml)++import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.ByteString.Lazy as L++import qualified Control.Exception as E+import Control.Monad.Trans.Error (Error (..))++import Data.Bits (bitSize)+import Control.Monad (liftM, (<=<))+import Control.Arrow (second)++import qualified Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T+import Web.PathPieces (PathPiece (..))+import qualified Data.Text.Read++import Data.Aeson (Value)+import Data.Aeson.Types (Parser)+import qualified Data.Aeson as A+import qualified Data.Attoparsec.Number as AN+import qualified Data.Vector as V++import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.HashMap.Strict as HM++import qualified Data.Text.Encoding as TE+import qualified Data.ByteString.Base64 as B64++import Data.Aeson (toJSON)+import Data.Aeson.Encode (fromValue)+import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Builder (toLazyText)++import Control.Monad.Trans.Control (MonadBaseControl)+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   )+import Control.Monad.Trans.Reader   ( ReaderT  )+import Control.Monad.Trans.Cont     ( ContT  )+import Control.Monad.Trans.State    ( StateT   )+import Control.Monad.Trans.Writer   ( WriterT  )+import Control.Monad.Trans.RWS      ( RWST     )+import Control.Monad.Trans.Resource ( ResourceT)++import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )+import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )+import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )++-- | A value which can be marshalled to and from a 'PersistValue'.+class PersistField a where+    toPersistValue :: a -> PersistValue+    fromPersistValue :: PersistValue -> Either T.Text a++#ifndef NO_OVERLAP+instance PersistField String where+    toPersistValue = PersistText . T.pack+    fromPersistValue (PersistText s) = Right $ T.unpack s+    fromPersistValue (PersistByteString bs) =+        Right $ T.unpack $ T.decodeUtf8With T.lenientDecode bs+    fromPersistValue (PersistInt64 i) = Right $ Prelude.show i+    fromPersistValue (PersistDouble d) = Right $ Prelude.show d+    fromPersistValue (PersistRational r) = Right $ Prelude.show r+    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"+    fromPersistValue (PersistMap _) = Left $ T.pack "Cannot convert PersistMap to String"+    fromPersistValue (PersistObjectId _) = Left $ T.pack "Cannot convert PersistObjectId to String"+#endif++instance PersistField ByteString where+    toPersistValue = PersistByteString+    fromPersistValue (PersistByteString bs) = Right bs+    fromPersistValue x = T.encodeUtf8 <$> fromPersistValue x++instance PersistField T.Text where+    toPersistValue = PersistText+    fromPersistValue = either (Left . T.pack) Right . fromPersistValueText++instance PersistField TL.Text where+    toPersistValue = toPersistValue . TL.toStrict+    fromPersistValue = fmap TL.fromStrict . fromPersistValue++instance PersistField Html where+    toPersistValue = PersistText . TL.toStrict . renderHtml+    fromPersistValue = fmap (preEscapedToMarkup :: T.Text -> Html) . fromPersistValue++instance PersistField Int where+    toPersistValue = PersistInt64 . fromIntegral+    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+    fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x++instance PersistField Int8 where+    toPersistValue = PersistInt64 . fromIntegral+    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+    fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x++instance PersistField Int16 where+    toPersistValue = PersistInt64 . fromIntegral+    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+    fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x++instance PersistField Int32 where+    toPersistValue = PersistInt64 . fromIntegral+    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+    fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x++instance PersistField Int64 where+    toPersistValue = PersistInt64 . fromIntegral+    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+    fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x++instance PersistField Word where+    toPersistValue = PersistInt64 . fromIntegral+    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+    fromPersistValue x = Left $ T.pack $ "Expected Word, received: " ++ show x++instance PersistField Word8 where+    toPersistValue = PersistInt64 . fromIntegral+    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+    fromPersistValue x = Left $ T.pack $ "Expected Word, received: " ++ show x++instance PersistField Word16 where+    toPersistValue = PersistInt64 . fromIntegral+    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+    fromPersistValue x = Left $ T.pack $ "Expected Word, received: " ++ show x++instance PersistField Word32 where+    toPersistValue = PersistInt64 . fromIntegral+    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+    fromPersistValue x = Left $ T.pack $ "Expected Word, received: " ++ show x++instance PersistField Word64 where+    toPersistValue = PersistInt64 . fromIntegral+    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+    fromPersistValue x = Left $ T.pack $ "Expected Word, received: " ++ show x++instance PersistField Double where+    toPersistValue = PersistDouble+    fromPersistValue (PersistDouble d) = Right d+    fromPersistValue (PersistRational r) = Right $ fromRational r+    fromPersistValue x = Left $ T.pack $ "Expected Double, received: " ++ show x++instance (HasResolution a) => PersistField (Fixed a) where+  toPersistValue = PersistRational . toRational+  fromPersistValue (PersistRational r) = Right $ fromRational r+  fromPersistValue (PersistText t) = case reads $ T.unpack t of --  NOTE: Sqlite can store rationals just as string+    [(a, "")] -> Right a+    _ -> Left $ "Can not read " <> t <> " as Fixed"+  fromPersistValue (PersistDouble d) = Right $ realToFrac d+  fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+  fromPersistValue x = Left $ "Expected Rational, received: " <> T.pack (show x)++instance PersistField Rational where+  toPersistValue = PersistRational+  fromPersistValue (PersistRational r) = Right r+  fromPersistValue (PersistDouble d) = Right $ toRational d+  fromPersistValue (PersistText t) = case reads $ T.unpack t of --  NOTE: Sqlite can store rationals just as string+    [(a, "")] -> Right $ toRational (a :: Pico)+    _ -> Left $ "Can not read " <> t <> " as Rational (Pico in fact)"+  fromPersistValue x = Left $ "Expected Rational, received: " <> T.pack (show x)++instance PersistField Bool where+    toPersistValue = PersistBool+    fromPersistValue (PersistBool b) = Right b+    fromPersistValue (PersistInt64 i) = Right $ i /= 0+    fromPersistValue x = Left $ T.pack $ "Expected Bool, received: " ++ show x++instance PersistField Day where+    toPersistValue = PersistDay+    fromPersistValue (PersistDay d) = Right d+    fromPersistValue (PersistInt64 i) = Right $ ModifiedJulianDay $ toInteger i+    fromPersistValue x@(PersistText t) =+        case reads $ T.unpack t of+            (d, _):_ -> Right d+            _ -> Left $ T.pack $ "Expected Day, received " ++ show x+    fromPersistValue x@(PersistByteString s) =+        case reads $ unpack s of+            (d, _):_ -> Right d+            _ -> Left $ T.pack $ "Expected Day, received " ++ show x+    fromPersistValue x = Left $ T.pack $ "Expected Day, received: " ++ show x++instance PersistField TimeOfDay where+    toPersistValue = PersistTimeOfDay+    fromPersistValue (PersistTimeOfDay d) = Right d+    fromPersistValue x@(PersistText t) =+        case reads $ T.unpack t of+            (d, _):_ -> Right d+            _ -> Left $ T.pack $ "Expected TimeOfDay, received " ++ show x+    fromPersistValue x@(PersistByteString s) =+        case reads $ unpack s of+            (d, _):_ -> Right d+            _ -> Left $ T.pack $ "Expected TimeOfDay, received " ++ show x+    fromPersistValue x = Left $ T.pack $ "Expected TimeOfDay, received: " ++ show x++instance PersistField UTCTime where+    toPersistValue = PersistUTCTime+    fromPersistValue (PersistUTCTime d) = Right d+#ifdef HIGH_PRECISION_DATE+    fromPersistValue (PersistInt64 i)   = Right $ posixSecondsToUTCTime $ (/ (1000 * 1000 * 1000)) $ fromIntegral $ i+#endif+    fromPersistValue x@(PersistText t)  =+        case reads $ T.unpack t of+            (d, _):_ -> Right d+            _ -> Left $ T.pack $ "Expected UTCTime, received " ++ show x+    fromPersistValue x@(PersistByteString s) =+        case reads $ unpack s of+            (d, _):_ -> Right d+            _ -> Left $ T.pack $ "Expected UTCTime, received " ++ show x++    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+    fromPersistValue PersistNull = Right Nothing+    fromPersistValue x = fmap Just $ fromPersistValue x++instance PersistField a => PersistField [a] where+    toPersistValue = PersistList . map toPersistValue+    fromPersistValue (PersistList l) = fromPersistList l+    fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t)+    fromPersistValue (PersistByteString bs)+        | Just values <- A.decode' (L.fromChunks [bs]) = fromPersistList values+    fromPersistValue x = Left $ T.pack $ "Expected PersistList, received: " ++ show x++instance (Ord a, PersistField a) => PersistField (S.Set a) where+    toPersistValue = PersistList . map toPersistValue . S.toList+    fromPersistValue (PersistList list) =+      either Left (Right . S.fromList) $ fromPersistList list+    fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t)+    fromPersistValue (PersistByteString bs)+        | Just values <- A.decode' (L.fromChunks [bs]) =+            either Left (Right . S.fromList) $ fromPersistList values+    fromPersistValue x = Left $ T.pack $ "Expected PersistSet, received: " ++ show x++instance (PersistField a, PersistField b) => PersistField (a,b) where+    toPersistValue (x,y) = PersistList [toPersistValue x, toPersistValue y]+    fromPersistValue (PersistList (vx:vy:[])) =+      case (fromPersistValue vx, fromPersistValue vy) of+        (Right x, Right y) -> Right (x, y)+        (Left e, _) -> Left e+        (_, Left e) -> Left e+    fromPersistValue x = Left $ T.pack $ "Expected 2 item PersistList, received: " ++ show x++instance PersistField v => PersistField (M.Map T.Text v) where+    toPersistValue = PersistMap . map (\(k,v) -> (k, toPersistValue v)) . M.toList+    fromPersistValue = fromPersistMap <=< getPersistMap++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++fromPersistMap :: PersistField v+               => [(T.Text, PersistValue)]+               -> Either T.Text (M.Map T.Text v)+fromPersistMap kvs =+      case (+        foldl (\eithAssocs (k,v) ->+              case (eithAssocs, fromPersistValue v) of+                (Left e, _) -> Left e+                (_, Left e)   -> Left e+                (Right assocs, Right v') -> Right ((k,v'):assocs)+              ) (Right []) kvs+      ) of+        Right vs -> Right $ M.fromList vs+        Left e -> Left e++getPersistMap :: PersistValue -> Either T.Text [(T.Text, PersistValue)]+getPersistMap (PersistMap kvs) = Right kvs+getPersistMap (PersistText t)  = getPersistMap (PersistByteString $ TE.encodeUtf8 t)+getPersistMap (PersistByteString bs)+    | Just pairs <- A.decode' (L.fromChunks [bs]) = Right pairs+getPersistMap x = Left $ T.pack $ "Expected PersistMap, received: " ++ show x++data SomePersistField = forall a. PersistField a => SomePersistField a+instance PersistField SomePersistField where+    toPersistValue (SomePersistField a) = toPersistValue a+    fromPersistValue x = fmap SomePersistField (fromPersistValue x :: Either Text Text)++instance PersistField Checkmark where+    toPersistValue Active   = PersistBool True+    toPersistValue Inactive = PersistNull+    fromPersistValue PersistNull         = Right Inactive+    fromPersistValue (PersistBool True)  = Right Active+    fromPersistValue (PersistBool False) =+      Left $ T.pack "PersistField Checkmark: found unexpected FALSE value"+    fromPersistValue other =+      Left $ T.pack $ "PersistField Checkmark: unknown value " ++ show other
+ Database/Persist/Class/PersistQuery.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+module Database.Persist.Class.PersistQuery+    ( PersistQuery (..)+    ) where++import Data.Monoid (mappend)+import Control.Exception (throwIO)+import Database.Persist.Types+import Data.Time (Day, TimeOfDay, UTCTime)+import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone)+import Data.ByteString.Char8 (ByteString, unpack)+import Control.Applicative+import Data.Typeable (Typeable)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64)++import Text.Blaze.Html+import Text.Blaze.Html.Renderer.Text (renderHtml)++import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.ByteString.Lazy as L++import qualified Control.Exception as E+import Control.Monad.Trans.Error (Error (..))++import Data.Bits (bitSize)+import Control.Monad (liftM, (<=<))+import Control.Arrow (second)++import qualified Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T+import Web.PathPieces (PathPiece (..))+import qualified Data.Text.Read++import Data.Aeson (Value)+import Data.Aeson.Types (Parser)+import qualified Data.Aeson as A+import qualified Data.Attoparsec.Number as AN+import qualified Data.Vector as V++import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.HashMap.Strict as HM++import qualified Data.Text.Encoding as TE+import qualified Data.ByteString.Base64 as B64++import Data.Aeson (toJSON)+import Data.Aeson.Encode (fromValue)+import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Builder (toLazyText)++import Control.Monad.Trans.Control (MonadBaseControl)+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   )+import Control.Monad.Trans.Reader   ( ReaderT  )+import Control.Monad.Trans.Cont     ( ContT  )+import Control.Monad.Trans.State    ( StateT   )+import Control.Monad.Trans.Writer   ( WriterT  )+import Control.Monad.Trans.RWS      ( RWST     )+import Control.Monad.Trans.Resource ( ResourceT)++import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )+import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )+import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )+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++    -- | Update individual fields on any record matching the given criterion.+    updateWhere :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)+                => [Filter val] -> [Update val] -> m ()++    -- | Delete all records matching the given criterion.+    deleteWhere :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)+                => [Filter val] -> m ()++    -- | Get all records matching the given criterion in the specified order.+    -- Returns also the identifiers.+    selectSource+           :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)+           => [Filter val]+           -> [SelectOpt val]+           -> C.Source m (Entity val)++    -- | get just the first record for the criterion+    selectFirst :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)+                => [Filter val]+                -> [SelectOpt val]+                -> m (Maybe (Entity val))+    selectFirst filts opts = selectSource filts ((LimitTo 1):opts) C.$$ CL.head+++    -- | Get the 'Key's of all records matching the given criterion.+    selectKeys :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)+               => [Filter val]+               -> [SelectOpt val]+               -> C.Source m (Key val)++    -- | The total number of records fulfilling the given criterion.+    count :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)+          => [Filter val] -> m Int++#define DEF(T) { update k = lift . update k; updateGet k = lift . updateGet k; updateWhere f = lift . updateWhere f; deleteWhere = lift . deleteWhere; selectSource f = C.transPipe lift . selectSource f; selectFirst f = lift . selectFirst f; selectKeys f = C.transPipe lift . selectKeys f; count = lift . count }+#define GO(T) instance (PersistQuery m) => PersistQuery (T m) where DEF(T)+#define GOX(X, T) instance (X, PersistQuery m) => PersistQuery (T m) where DEF(T)++GO(LoggingT)+GO(IdentityT)+GO(ListT)+GO(MaybeT)+GOX(Error e, ErrorT e)+GO(ReaderT r)+GO(ContT r)+GO(StateT s)+GO(ResourceT)+GO(Pipe l i o u)+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/PersistStore.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+module Database.Persist.Class.PersistStore+    ( PersistStore (..)+    ) where++import qualified Prelude+import Prelude hiding ((++), show)+import Data.Monoid (mappend)+import Data.Time (Day, TimeOfDay, UTCTime)+import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone)+import Data.ByteString.Char8 (ByteString, unpack)+import Control.Applicative+import Data.Typeable (Typeable)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64)++import Text.Blaze.Html+import Text.Blaze.Html.Renderer.Text (renderHtml)++import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.ByteString.Lazy as L++import qualified Control.Exception as E+import Control.Monad.Trans.Error (Error (..))++import Data.Bits (bitSize)+import Control.Monad (liftM, (<=<))+import Control.Arrow (second)++import qualified Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T+import Web.PathPieces (PathPiece (..))+import qualified Data.Text.Read++import Data.Aeson (Value)+import Data.Aeson.Types (Parser)+import qualified Data.Aeson as A+import qualified Data.Attoparsec.Number as AN+import qualified Data.Vector as V++import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.HashMap.Strict as HM++import qualified Data.Text.Encoding as TE+import qualified Data.ByteString.Base64 as B64++import Data.Aeson (toJSON)+import Data.Aeson.Encode (fromValue)+import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Builder (toLazyText)++import Control.Monad.Trans.Control (MonadBaseControl)+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   )+import Control.Monad.Trans.Reader   ( ReaderT  )+import Control.Monad.Trans.Cont     ( ContT  )+import Control.Monad.Trans.State    ( StateT   )+import Control.Monad.Trans.Writer   ( WriterT  )+import Control.Monad.Trans.RWS      ( RWST     )+import Control.Monad.Trans.Resource ( ResourceT)++import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )+import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )+import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )++import Database.Persist.Class.PersistEntity++class MonadIO m => PersistStore m where+    type PersistMonadBackend m++    -- | Create a new record in the database, returning an automatically created+    -- key (in SQL an auto-increment id).+    insert :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)+           => val -> m (Key val)++    -- | Same as 'insert', but doesn't return a @Key@.+    insert_ :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)+            => val -> m ()+    insert_ val = insert val >> return ()++    -- | Create a new record in the database using the given key.+    insertKey :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)+              => Key val -> val -> m ()++    -- | Put the record in the database with the given key.+    -- Unlike 'replace', if a record with the given key does not+    -- exist then a new record will be inserted.+    repsert :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)+            => Key val -> val -> m ()++    -- | Replace the record in the database with the given+    -- key. Note that the result is undefined if such record does+    -- not exist, so you must use 'insertKey or 'repsert' in+    -- these cases.+    replace :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)+            => Key val -> val -> m ()++    -- | Delete a specific record by identifier. Does nothing if record does+    -- not exist.+    delete :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)+           => Key val -> m ()++    -- | Get a record by identifier, if available.+    get :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)+        => Key val -> m (Maybe val)++#define DEF(T) { type PersistMonadBackend (T m) = PersistMonadBackend m; insert = lift . insert; insertKey k = lift . insertKey k; repsert k = lift . repsert k; replace k = lift . replace k; delete = lift . delete; get = lift . get }+#define GO(T) instance (PersistStore m) => PersistStore (T m) where DEF(T)+#define GOX(X, T) instance (X, PersistStore m) => PersistStore (T m) where DEF(T)++GO(LoggingT)+GO(IdentityT)+GO(ListT)+GO(MaybeT)+GOX(Error e, ErrorT e)+GO(ReaderT r)+GO(ContT r)+GO(StateT s)+GO(ResourceT)+GO(Pipe l i o u)+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
@@ -0,0 +1,137 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+module Database.Persist.Class.PersistUnique+    ( PersistUnique (..)+    ) where++import qualified Prelude+import Prelude hiding ((++), show)+import Data.Monoid (mappend)+import Data.Time (Day, TimeOfDay, UTCTime)+import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone)+import Data.ByteString.Char8 (ByteString, unpack)+import Control.Applicative+import Data.Typeable (Typeable)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64)++import Text.Blaze.Html+import Text.Blaze.Html.Renderer.Text (renderHtml)++import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.ByteString.Lazy as L++import qualified Control.Exception as E+import Control.Monad.Trans.Error (Error (..))++import Data.Bits (bitSize)+import Control.Monad (liftM, (<=<))+import Control.Arrow (second)++import qualified Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T+import Web.PathPieces (PathPiece (..))+import qualified Data.Text.Read++import Data.Aeson (Value)+import Data.Aeson.Types (Parser)+import qualified Data.Aeson as A+import qualified Data.Attoparsec.Number as AN+import qualified Data.Vector as V++import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.HashMap.Strict as HM++import qualified Data.Text.Encoding as TE+import qualified Data.ByteString.Base64 as B64++import Data.Aeson (toJSON)+import Data.Aeson.Encode (fromValue)+import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Builder (toLazyText)++import Control.Monad.Trans.Control (MonadBaseControl)+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   )+import Control.Monad.Trans.Reader   ( ReaderT  )+import Control.Monad.Trans.Cont     ( ContT  )+import Control.Monad.Trans.State    ( StateT   )+import Control.Monad.Trans.Writer   ( WriterT  )+import Control.Monad.Trans.RWS      ( RWST     )+import Control.Monad.Trans.Resource ( ResourceT)++import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )+import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )+import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )+import Database.Persist.Class.PersistStore+import Database.Persist.Class.PersistEntity++-- | Queries against unique keys (other than the id).+--+-- Please read the general Persistent documentation to learn how to create+-- Unique keys.+-- SQL backends automatically create uniqueness constraints, but for MongoDB you must place a unique index on the field.+class PersistStore m => PersistUnique m where+    -- | Get a record by unique key, if available. Returns also the identifier.+    getBy :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => Unique val -> m (Maybe (Entity val))++    -- | Delete a specific record by unique key. Does nothing if no record+    -- matches.+    deleteBy :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => Unique val -> m ()++    -- | Like 'insert', but returns 'Nothing' when the record+    -- couldn't be inserted because of a uniqueness constraint.+    insertUnique :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => val -> m (Maybe (Key val))+    insertUnique datum = do+        isUnique <- checkUnique datum+        if isUnique then Just `liftM` insert datum else return Nothing++#define DEF(T) { getBy = lift . getBy; deleteBy = lift . deleteBy; insertUnique = lift . insertUnique }+#define GO(T) instance (PersistUnique m) => PersistUnique (T m) where DEF(T)+#define GOX(X, T) instance (X, PersistUnique m) => PersistUnique (T m) where DEF(T)++GO(LoggingT)+GO(IdentityT)+GO(ListT)+GO(MaybeT)+GOX(Error e, ErrorT e)+GO(ReaderT r)+GO(ContT r)+GO(StateT s)+GO(ResourceT)+GO(Pipe l i o u)+GOX(Monoid w, WriterT w)+GOX(Monoid w, RWST r w s)+GOX(Monoid w, Strict.RWST r w s)+GO(Strict.StateT s)+GOX(Monoid w, Strict.WriterT w)++#undef DEF+#undef GO+#undef GOX++-- | Check whether there are any conflicts for unique keys with this entity and+-- existing entities in the database.+--+-- Returns 'True' if the entity would be unique, and could thus safely be+-- 'insert'ed; returns 'False' on a conflict.+checkUnique :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val, PersistUnique m) => val -> m Bool+checkUnique val =+    go $ persistUniqueKeys val+  where+    go [] = return True+    go (x:xs) = do+        y <- getBy x+        case y of+            Nothing -> go xs+            Just _ -> return False
− Database/Persist/EntityDef.hs 
@@ -1,65 +0,0 @@-module Database.Persist.EntityDef-    ( -- * Helper types-      HaskellName (..)-    , DBName (..)-    , Attr-      -- * Defs-    , EntityDef (..)-    , FieldDef (..)-    , FieldType (..)-    , UniqueDef (..)-    , ExtraLine-      -- * Utils-    , stripId-    ) where--import Data.Text (Text, stripSuffix, pack)-import Data.Map (Map)--data EntityDef = EntityDef-    { entityHaskell :: HaskellName-    , entityDB      :: DBName-    , entityID      :: DBName-    , entityAttrs   :: [Attr]-    , entityFields  :: [FieldDef]-    , entityUniques :: [UniqueDef]-    , entityDerives :: [Text]-    , entityExtra   :: Map Text [ExtraLine]-    , entitySum     :: Bool-    }-    deriving (Show, Eq, Read, Ord)--type ExtraLine = [Text]--newtype HaskellName = HaskellName { unHaskellName :: Text }-    deriving (Show, Eq, Read, Ord)-newtype DBName = DBName { unDBName :: Text }-    deriving (Show, Eq, Read, Ord)--type Attr = Text--data FieldType-    = FTTypeCon (Maybe Text) Text -- ^ optional module, name-    | FTApp FieldType FieldType-    | FTList FieldType-  deriving (Show, Eq, Read, Ord)--data FieldDef = FieldDef-    { fieldHaskell :: HaskellName-    , fieldDB      :: DBName-    , fieldType    :: FieldType-    , fieldAttrs   :: [Attr]-    }-    deriving (Show, Eq, Read, Ord)--data UniqueDef = UniqueDef-    { uniqueHaskell :: HaskellName-    , uniqueDBName  :: DBName-    , uniqueFields  :: [(HaskellName, DBName)]-    , uniqueAttrs   :: [Attr]-    }-    deriving (Show, Eq, Read, Ord)--stripId :: FieldType -> Maybe Text-stripId (FTTypeCon Nothing t) = stripSuffix (pack "Id") t-stripId _ = Nothing
− Database/Persist/GenericSql.hs 
@@ -1,643 +0,0 @@-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-} -- FIXME-{-# OPTIONS_GHC -fno-warn-orphans #-}--- | This is a helper module for creating SQL backends. Regular users do not--- need to use this module.-module Database.Persist.GenericSql-    ( SqlPersist (..)-    , Connection-    , ConnectionPool-    , Statement-    , runSqlConn-    , runSqlPool-    , Key--    -- * Useful data types-    , Checkmark(..)--    -- * Raw SQL queries-    -- $rawSql-    , rawSql-    , Entity(..)-    , Single(..)-    , RawSql--    -- * Migrations-    , Migration-    , parseMigration-    , parseMigration'-    , printMigration-    , getMigration-    , runMigration-    , runMigrationSilent-    , runMigrationUnsafe-    , migrate-    , commit-    , rollback-    ) where--import qualified Prelude as P-import Prelude hiding ((++), unlines, concat, show)-import Control.Applicative ((<$>), (<*>))-import Control.Arrow ((&&&))-import Database.Persist.Store-import Control.Monad.IO.Class-import Control.Monad.Trans.Reader-import Data.Conduit.Pool-import Database.Persist.GenericSql.Internal-import Database.Persist.GenericSql.Migration-import qualified Database.Persist.GenericSql.Raw as R-import Database.Persist.GenericSql.Raw (SqlPersist (..))-import Control.Monad.Trans.Control (MonadBaseControl, control)-import qualified Control.Exception as E-import Control.Exception (throw)-import Data.Text (Text, pack, unpack, concat)-import qualified Data.Text as T-import Web.PathPieces (PathPiece (..))-import qualified Data.Text.Read-import Data.Maybe (fromMaybe)-import Data.Monoid (Monoid, mappend)-import Database.Persist.EntityDef-import qualified Data.Conduit as C-import qualified Data.Conduit.List as CL-import Control.Monad.Logger (MonadLogger)-import Control.Monad.Base (liftBase)--type ConnectionPool = Pool Connection--instance PathPiece (KeyBackend R.SqlBackend entity) where-    toPathPiece (Key (PersistInt64 i)) = toPathPiece i-    toPathPiece k = throw $ PersistInvalidField $ "Invalid Key: " ++ show k-    fromPathPiece t =-        case Data.Text.Read.signed Data.Text.Read.decimal t of-            Right (i, "") -> Just $ Key $ PersistInt64 i-            _ -> Nothing--execute' :: (MonadIO m, MonadLogger m) => Text -> [PersistValue] -> SqlPersist m ()-execute' = R.execute---- | Get a connection from the pool, run the given action, and then return the--- connection to the pool.-runSqlPool :: MonadBaseControl IO m => SqlPersist m a -> Pool Connection -> m a-runSqlPool r pconn = withResource pconn $ runSqlConn r--runSqlConn :: MonadBaseControl IO m => SqlPersist m a -> Connection -> m a-runSqlConn (SqlPersist r) conn = do-    let getter = R.getStmt' conn-    liftBase $ begin conn getter-    x <- onException-            (runReaderT r conn)-            (liftBase $ rollbackC conn getter)-    liftBase $ commitC conn getter-    return x--instance (C.MonadResource m, MonadLogger m) => PersistStore (SqlPersist m) where-    type PersistMonadBackend (SqlPersist m) = R.SqlBackend-    insert val = do-        conn <- SqlPersist ask-        let esql = insertSql conn (entityDB t) (map fieldDB $ entityFields t) (entityID t)-        i <--            case esql of-                ISRSingle sql -> R.withStmt sql vals C.$$ do-                    x <- CL.head-                    case x of-                        Just [PersistInt64 i] -> return i-                        Nothing -> error $ "SQL insert did not return a result giving the generated ID"-                        Just vals' -> error $ "Invalid result from a SQL insert, got: " P.++ P.show vals'-                ISRInsertGet sql1 sql2 -> do-                    execute' sql1 vals-                    R.withStmt sql2 [] C.$$ do-                        Just [PersistInt64 i] <- CL.head-                        return i-        return $ Key $ PersistInt64 i-      where-        t = entityDef val-        vals = map toPersistValue $ toPersistFields val--    replace k val = do-        conn <- SqlPersist ask-        let t = entityDef val-        let sql = concat-                [ "UPDATE "-                , escapeName conn (entityDB t)-                , " SET "-                , T.intercalate "," (map (go conn . fieldDB) $ entityFields t)-                , " WHERE "-                , escapeName conn $ entityID t-                , "=?"-                ]-            vals = map toPersistValue (toPersistFields val) `mappend` [unKey k]-        execute' sql vals-      where-        go conn x = escapeName conn x ++ "=?"--    insertKey = insrepHelper "INSERT"--    repsert key value = do-        -- FIXME use this for sqlite insrepHelper "REPLACE"-        delete key-        insertKey key value--    get k = do-        conn <- SqlPersist ask-        let t = entityDef $ dummyFromKey k-        let cols = T.intercalate ","-                 $ map (escapeName conn . fieldDB) $ entityFields t-        let sql = concat-                [ "SELECT "-                , cols-                , " FROM "-                , escapeName conn $ entityDB t-                , " WHERE "-                , escapeName conn $ entityID t-                , "=?"-                ]-            vals' = [unKey k]-        R.withStmt sql vals' C.$$ do-            res <- CL.head-            case res of-                Nothing -> return Nothing-                Just vals ->-                    case fromPersistValues vals of-                        Left e -> error $ unpack $ "get " ++ show (unKey k) ++ ": " ++ e-                        Right v -> return $ Just v--    delete k = do-        conn <- SqlPersist ask-        execute' (sql conn) [unKey k]-      where-        t = entityDef $ dummyFromKey k-        sql conn = concat-            [ "DELETE FROM "-            , escapeName conn $ entityDB t-            , " WHERE "-            , escapeName conn $ entityID t-            , "=?"-            ]--insrepHelper :: (MonadIO m, PersistEntity val, MonadLogger m)-             => Text-             -> Key val-             -> val-             -> SqlPersist m ()-insrepHelper command (Key k) val = do-    conn <- SqlPersist ask-    execute' (sql conn) vals-  where-    t = entityDef val-    sql conn = concat-        [ command-        , " INTO "-        , escapeName conn (entityDB t)-        , "("-        , T.intercalate ","-            $ map (escapeName conn)-            $ entityID t : map fieldDB (entityFields t)-        , ") VALUES("-        , T.intercalate "," ("?" : map (const "?") (entityFields t))-        , ")"-        ]-    vals = k : map toPersistValue (toPersistFields val)--instance (C.MonadResource m, MonadLogger m) => PersistUnique (SqlPersist m) where-    deleteBy uniq = do-        conn <- SqlPersist ask-        let sql' = sql conn-            vals = persistUniqueToValues uniq-        execute' sql' vals-      where-        t = entityDef $ dummyFromUnique uniq-        go = map snd . persistUniqueToFieldNames-        go' conn x = escapeName conn x ++ "=?"-        sql conn = concat-            [ "DELETE FROM "-            , escapeName conn $ entityDB t-            , " WHERE "-            , T.intercalate " AND " $ map (go' conn) $ go uniq-            ]--    getBy uniq = do-        conn <- SqlPersist ask-        let cols = T.intercalate "," $ (escapeName conn $ entityID t)-                 : map (escapeName conn . fieldDB) (entityFields t)-        let sql = concat-                [ "SELECT "-                , cols-                , " FROM "-                , escapeName conn $ entityDB t-                , " WHERE "-                , sqlClause conn-                ]-            vals' = persistUniqueToValues uniq-        R.withStmt sql vals' C.$$ do-            row <- CL.head-            case row of-                Nothing -> return Nothing-                Just (PersistInt64 k:vals) ->-                    case fromPersistValues vals of-                        Left s -> error $ unpack s-                        Right x -> return $ Just (Entity (Key $ PersistInt64 k) x)-                Just _ -> error "Database.Persist.GenericSql: Bad list in getBy"-      where-        sqlClause conn =-            T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq-        go conn x = escapeName conn x ++ "=?"-        t = entityDef $ dummyFromUnique uniq-        toFieldNames' = map snd . persistUniqueToFieldNames--dummyFromKey :: KeyBackend R.SqlBackend v -> v-dummyFromKey _ = error "dummyFromKey"--dummyFromUnique :: Unique v -> v-dummyFromUnique _ = error "dummyFromUnique"--#if MIN_VERSION_monad_control(0, 3, 0)-onException :: MonadBaseControl IO m => m α -> m β -> m α-onException m what = control $ \runInIO ->-                       E.onException (runInIO m)-                                     (runInIO what)-#endif--infixr 5 ++-(++) :: Text -> Text -> Text-(++) = mappend--show :: Show a => a -> Text-show = pack . P.show----- | A 'Checkmark' should be used as a field type whenever a--- uniqueness constraint should guarantee that a certain kind of--- record may appear at most once, but other kinds of records may--- appear any number of times.------ /NOTE:/ You need to mark any @Checkmark@ fields as @nullable@--- (see the following example).------ For example, suppose there's a @Location@ entity that--- represents where a user has lived:------ @--- Location---     user    UserId---     name    Text---     current Checkmark nullable------     UniqueLocation user current--- @------ The @UniqueLocation@ constraint allows any number of--- 'Inactive' @Location@s to be @current@.  However, there may be--- at most one @current@ @Location@ per user (i.e., either zero--- or one per user).------ This data type works because of the way that SQL treats--- @NULL@able fields within uniqueness constraints.  The SQL--- standard says that @NULL@ values should be considered--- different, so we represent 'Inactive' as SQL @NULL@, thus--- allowing any number of 'Inactive' records.  On the other hand,--- we represent 'Active' as @TRUE@, so the uniqueness constraint--- will disallow more than one 'Active' record.------ /Note:/ There may be DBMSs that do not respect the SQL--- standard's treatment of @NULL@ values on uniqueness--- constraints, please check if this data type works before--- relying on it.------ The SQL @BOOLEAN@ type is used because it's the smallest data--- type available.  Note that we never use @FALSE@, just @TRUE@--- and @NULL@.  Provides the same behavior @Maybe ()@ would if--- @()@ was a valid 'PersistField'.-data Checkmark = Active-                 -- ^ When used on a uniqueness constraint, there-                 -- may be at most one 'Active' record.-               | Inactive-                 -- ^ When used on a uniqueness constraint, there-                 -- may be any number of 'Inactive' records.-    deriving (Eq, Ord, Read, Show, Enum, Bounded)--instance PersistField Checkmark where-    toPersistValue Active   = PersistBool True-    toPersistValue Inactive = PersistNull-    fromPersistValue PersistNull         = Right Inactive-    fromPersistValue (PersistBool True)  = Right Active-    fromPersistValue (PersistBool False) =-      Left "PersistField Checkmark: found unexpected FALSE value"-    fromPersistValue other =-      Left $ "PersistField Checkmark: unknown value " ++ show other-    sqlType    _ = SqlBool-    isNullable _ = True--instance PathPiece Checkmark where-    toPathPiece = show-    fromPathPiece txt =-      case reads (T.unpack txt) of-        [(a, "")] -> Just a-        _         -> Nothing----- $rawSql------ Although it covers most of the useful cases, @persistent@'s--- API may not be enough for some of your tasks.  May be you need--- some complex @JOIN@ query, or a database-specific command--- needs to be issued.------ To issue raw SQL queries you could use 'R.withStmt', which--- allows you to do anything you need.  However, its API is--- /low-level/ and you need to parse each row yourself.  However,--- most of your complex queries will have simple results -- some--- of your entities and maybe a couple of derived columns.------ This is where 'rawSql' comes in.  Like 'R.withStmt', you may--- issue /any/ SQL query.  However, it does all the hard work for--- you and automatically parses the rows of the result.  It may--- return:------   * An 'Entity', that which 'selectList' returns.---     All of your entity's fields are---     automatically parsed.------   * A @'Single' a@, which is a single, raw column of type @a@.---     You may use a Haskell type (such as in your entity---     definitions), for example @Single Text@ or @Single Int@,---     or you may get the raw column value with @Single---     'PersistValue'@.------   * A tuple combining any of these (including other tuples).---     Using tuples allows you to return many entities in one---     query.------ The only difference between issuing SQL queries with 'rawSql'--- and using other means is that we have an /entity selection/--- /placeholder/, the double question mark @??@.  It /must/ be--- used whenever you want to @SELECT@ an 'Entity' from your--- query.  Here's a sample SQL query @sampleStmt@ that may be--- issued:------ @--- SELECT ??, ??--- FROM \"Person\", \"Likes\", \"Object\"--- WHERE \"Person\".id = \"Likes\".\"personId\"--- AND \"Object\".id = \"Likes\".\"objectId\"--- AND \"Person\".name LIKE ?--- @------ To use that query, you could say------ @--- do results <- 'rawSql' sampleStmt [\"%Luke%\"]---    forM_ results $---      \\( Entity personKey person---       , Entity objectKey object---       ) -> do ...--- @------ Note that 'rawSql' knows how to replace the double question--- marks @??@ because of the type of the @results@.----- | A single column (see 'rawSql').  Any 'PersistField' may be--- used here, including 'PersistValue' (which does not do any--- processing).-newtype Single a = Single {unSingle :: a}-    deriving (Eq, Ord, Show, Read)----- | Execute a raw SQL statement and return its results as a--- list.------ If you're using 'Entity'@s@ (which is quite likely), then you--- /must/ use entity selection placeholders (double question--- mark, @??@).  These @??@ placeholders are then replaced for--- the names of the columns that we need for your entities.--- You'll receive an error if you don't use the placeholders.--- Please see the 'Entity'@s@ documentation for more details.------ You may put value placeholders (question marks, @?@) in your--- SQL query.  These placeholders are then replaced by the values--- you pass on the second parameter, already correctly escaped.--- You may want to use 'toPersistValue' to help you constructing--- the placeholder values.------ Since you're giving a raw SQL statement, you don't get any--- guarantees regarding safety.  If 'rawSql' is not able to parse--- the results of your query back, then an exception is raised.--- However, most common problems are mitigated by using the--- entity selection placeholder @??@, and you shouldn't see any--- error at all if you're not using 'Single'.-rawSql :: (RawSql a, C.MonadResource m, MonadLogger m)-       => Text             -- ^ SQL statement, possibly with placeholders.-       -> [PersistValue]   -- ^ Values to fill the placeholders.-       -> SqlPersist m [a]-rawSql stmt = run-    where-      getType :: (x -> SqlPersist m [a]) -> a-      getType = undefined--      x = getType run-      process = rawSqlProcessRow--      withStmt' colSubsts params = do-            R.withStmt sql params-          where-            sql = T.concat $ makeSubsts colSubsts $ T.splitOn placeholder stmt-            placeholder = "??"-            makeSubsts (s:ss) (t:ts) = t : s : makeSubsts ss ts-            makeSubsts []     []     = []-            makeSubsts []     ts     = [T.intercalate placeholder ts]-            makeSubsts ss     []     = error (P.concat err)-                where-                  err = [ "rawsql: there are still ", P.show (length ss)-                        , "'??' placeholder substitutions to be made "-                        , "but all '??' placeholders have already been "-                        , "consumed.  Please read 'rawSql's documentation "-                        , "on how '??' placeholders work."-                        ]--      run params = do-        conn <- SqlPersist ask-        let (colCount, colSubsts) = rawSqlCols (escapeName conn) x-        withStmt' colSubsts params C.$$ firstRow colCount--      firstRow colCount = do-        mrow <- CL.head-        case mrow of-          Nothing -> return []-          Just row-              | colCount == length row -> getter mrow-              | otherwise              -> fail $ P.concat-                  [ "rawSql: wrong number of columns, got "-                  , P.show (length row), " but expected ", P.show colCount-                  , " (", rawSqlColCountReason x, ")." ]--      getter = go id-          where-            go acc Nothing = return (acc [])-            go acc (Just row) =-              case process row of-                Left err -> fail (T.unpack err)-                Right r  -> CL.head >>= go (acc . (r:))----- | Class for data types that may be retrived from a 'rawSql'--- query.-class RawSql a where-    -- | Number of columns that this data type needs and the list-    -- of substitutions for @SELECT@ placeholders @??@.-    rawSqlCols :: (DBName -> Text) -> a -> (Int, [Text])--    -- | A string telling the user why the column count is what-    -- it is.-    rawSqlColCountReason :: a -> String--    -- | Transform a row of the result into the data type.-    rawSqlProcessRow :: [PersistValue] -> Either Text a--instance PersistField a => RawSql (Single a) where-    rawSqlCols _ _         = (1, [])-    rawSqlColCountReason _ = "one column for a 'Single' data type"-    rawSqlProcessRow [pv]  = Single <$> fromPersistValue pv-    rawSqlProcessRow _     = Left "RawSql (Single a): wrong number of columns."--instance PersistEntity a => RawSql (Entity a) where-    rawSqlCols escape = ((+1) . length . entityFields &&& process) . entityDef . entityVal-        where-          process ed = (:[]) $-                       T.intercalate ", " $-                       map ((name ed ++) . escape) $-                       (entityID ed:) $-                       map fieldDB $-                       entityFields ed-          name ed = escape (entityDB ed) ++ "."--    rawSqlColCountReason a =-        case fst (rawSqlCols undefined a) of-          1 -> "one column for an 'Entity' data type without fields"-          n -> P.show n P.++ " columns for an 'Entity' data type"-    rawSqlProcessRow (idCol:ent) = Entity <$> fromPersistValue idCol-                                          <*> fromPersistValues ent-    rawSqlProcessRow _ = Left "RawSql (Entity a): wrong number of columns."---- | Since 1.0.1.-instance RawSql a => RawSql (Maybe a) where-    rawSqlCols e = rawSqlCols e . extractMaybe-    rawSqlColCountReason = rawSqlColCountReason . extractMaybe-    rawSqlProcessRow cols-      | all isNull cols = return Nothing-      | otherwise       =-        case rawSqlProcessRow cols of-          Right v  -> Right (Just v)-          Left msg -> Left $ "RawSql (Maybe a): not all columns were Null " ++-                             "but the inner parser has failed.  Its message " ++-                             "was \"" ++ msg ++ "\".  Did you apply Maybe " ++-                             "to a tuple, perhaps?  The main use case for " ++-                             "Maybe is to allow OUTER JOINs to be written, " ++-                             "in which case 'Maybe (Entity v)' is used."-      where isNull PersistNull = True-            isNull _           = False--extractMaybe :: Maybe a -> a-extractMaybe = fromMaybe (error "Database.Persist.GenericSql.extractMaybe")--instance (RawSql a, RawSql b) => RawSql (a, b) where-    rawSqlCols e x = rawSqlCols e (fst x) # rawSqlCols e (snd x)-        where (cnta, lsta) # (cntb, lstb) = (cnta + cntb, lsta P.++ lstb)-    rawSqlColCountReason x = rawSqlColCountReason (fst x) P.++ ", " P.++-                             rawSqlColCountReason (snd x)-    rawSqlProcessRow =-        let x = getType processRow-            getType :: (z -> Either y x) -> x-            getType = undefined--            colCountFst = fst $ rawSqlCols undefined (fst x)-            processRow row =-                let (rowFst, rowSnd) = splitAt colCountFst row-                in (,) <$> rawSqlProcessRow rowFst-                       <*> rawSqlProcessRow rowSnd--        in colCountFst `seq` processRow-           -- Avoids recalculating 'colCountFst'.--instance (RawSql a, RawSql b, RawSql c) => RawSql (a, b, c) where-    rawSqlCols e         = rawSqlCols e         . from3-    rawSqlColCountReason = rawSqlColCountReason . from3-    rawSqlProcessRow     = fmap to3 . rawSqlProcessRow--from3 :: (a,b,c) -> ((a,b),c)-from3 (a,b,c) = ((a,b),c)--to3 :: ((a,b),c) -> (a,b,c)-to3 ((a,b),c) = (a,b,c)--instance (RawSql a, RawSql b, RawSql c, RawSql d) => RawSql (a, b, c, d) where-    rawSqlCols e         = rawSqlCols e         . from4-    rawSqlColCountReason = rawSqlColCountReason . from4-    rawSqlProcessRow     = fmap to4 . rawSqlProcessRow--from4 :: (a,b,c,d) -> ((a,b),(c,d))-from4 (a,b,c,d) = ((a,b),(c,d))--to4 :: ((a,b),(c,d)) -> (a,b,c,d)-to4 ((a,b),(c,d)) = (a,b,c,d)--instance (RawSql a, RawSql b, RawSql c,-          RawSql d, RawSql e)-       => RawSql (a, b, c, d, e) where-    rawSqlCols e         = rawSqlCols e         . from5-    rawSqlColCountReason = rawSqlColCountReason . from5-    rawSqlProcessRow     = fmap to5 . rawSqlProcessRow--from5 :: (a,b,c,d,e) -> ((a,b),(c,d),e)-from5 (a,b,c,d,e) = ((a,b),(c,d),e)--to5 :: ((a,b),(c,d),e) -> (a,b,c,d,e)-to5 ((a,b),(c,d),e) = (a,b,c,d,e)--instance (RawSql a, RawSql b, RawSql c,-          RawSql d, RawSql e, RawSql f)-       => RawSql (a, b, c, d, e, f) where-    rawSqlCols e         = rawSqlCols e         . from6-    rawSqlColCountReason = rawSqlColCountReason . from6-    rawSqlProcessRow     = fmap to6 . rawSqlProcessRow--from6 :: (a,b,c,d,e,f) -> ((a,b),(c,d),(e,f))-from6 (a,b,c,d,e,f) = ((a,b),(c,d),(e,f))--to6 :: ((a,b),(c,d),(e,f)) -> (a,b,c,d,e,f)-to6 ((a,b),(c,d),(e,f)) = (a,b,c,d,e,f)--instance (RawSql a, RawSql b, RawSql c,-          RawSql d, RawSql e, RawSql f,-          RawSql g)-       => RawSql (a, b, c, d, e, f, g) where-    rawSqlCols e         = rawSqlCols e         . from7-    rawSqlColCountReason = rawSqlColCountReason . from7-    rawSqlProcessRow     = fmap to7 . rawSqlProcessRow--from7 :: (a,b,c,d,e,f,g) -> ((a,b),(c,d),(e,f),g)-from7 (a,b,c,d,e,f,g) = ((a,b),(c,d),(e,f),g)--to7 :: ((a,b),(c,d),(e,f),g) -> (a,b,c,d,e,f,g)-to7 ((a,b),(c,d),(e,f),g) = (a,b,c,d,e,f,g)--instance (RawSql a, RawSql b, RawSql c,-          RawSql d, RawSql e, RawSql f,-          RawSql g, RawSql h)-       => RawSql (a, b, c, d, e, f, g, h) where-    rawSqlCols e         = rawSqlCols e         . from8-    rawSqlColCountReason = rawSqlColCountReason . from8-    rawSqlProcessRow     = fmap to8 . rawSqlProcessRow--from8 :: (a,b,c,d,e,f,g,h) -> ((a,b),(c,d),(e,f),(g,h))-from8 (a,b,c,d,e,f,g,h) = ((a,b),(c,d),(e,f),(g,h))--to8 :: ((a,b),(c,d),(e,f),(g,h)) -> (a,b,c,d,e,f,g,h)-to8 ((a,b),(c,d),(e,f),(g,h)) = (a,b,c,d,e,f,g,h)
− Database/Persist/GenericSql/Internal.hs 
@@ -1,202 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards #-}--- | Code that is only needed for writing GenericSql backends.-module Database.Persist.GenericSql.Internal-    ( Connection (..)-    , Statement (..)-    , withSqlConn-    , withSqlPool-    , createSqlPool-    , mkColumns-    , Column (..)-    , logSQL-    , InsertSqlResult (..)-    ) where--import qualified Data.Map as Map-import Data.Char (isSpace)-import Data.IORef-import Control.Monad.IO.Class-import Data.Conduit.Pool-import Database.Persist.Store-import Control.Exception.Lifted (bracket)-import Control.Monad.Trans.Control (MonadBaseControl)-import Database.Persist.Util (nullable, IsNullable(NotNullable))-import Data.Text (Text)-import qualified Data.Text as T-import Data.Monoid (Monoid, mappend, mconcat)-import Database.Persist.EntityDef-import qualified Data.Conduit as C-import Language.Haskell.TH.Syntax (Q, Exp)-import Control.Monad.Logger (logDebugS)-import Data.Maybe (mapMaybe, listToMaybe)-import Data.Int (Int64)--data InsertSqlResult = ISRSingle Text-                     | ISRInsertGet Text Text--data Connection = Connection-    { prepare :: Text -> IO Statement-    -- ^ table name, column names, id name, either 1 or 2 statements to run-    , insertSql :: DBName -> [DBName] -> DBName -> InsertSqlResult-    , stmtMap :: IORef (Map.Map Text Statement)-    , close :: IO ()-    , migrateSql :: forall v. PersistEntity v-                 => [EntityDef]-                 -> (Text -> IO Statement)-                 -> v-                 -> IO (Either [Text] [(Bool, Text)])-    , begin :: (Text -> IO Statement) -> IO ()-    , commitC :: (Text -> IO Statement) -> IO ()-    , rollbackC :: (Text -> IO Statement) -> IO ()-    , escapeName :: DBName -> Text-    , noLimit :: Text-    }-data Statement = Statement-    { finalize :: IO ()-    , reset :: IO ()-    , execute :: [PersistValue] -> IO Int64-    , withStmt :: forall m. C.MonadResource m-               => [PersistValue]-               -> C.Source m [PersistValue]-    }--withSqlPool :: MonadIO m-            => IO Connection -- ^ create a new connection-            -> Int -- ^ connection count-            -> (Pool Connection -> m a)-            -> m a-withSqlPool mkConn connCount f = do-    pool <- createSqlPool mkConn connCount-    f pool--createSqlPool :: MonadIO m-              => IO Connection-              -> Int-              -> m (Pool Connection)-createSqlPool mkConn = liftIO . createPool mkConn close' 1 20--withSqlConn :: (MonadIO m, MonadBaseControl IO m)-            => IO Connection -> (Connection -> m a) -> m a-withSqlConn open = bracket (liftIO open) (liftIO . close')--close' :: Connection -> IO ()-close' conn = do-    readIORef (stmtMap conn) >>= mapM_ finalize . Map.elems-    close conn--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---- | Create the list of columns for the given entity.-mkColumns :: PersistEntity val => [EntityDef] -> val -> ([Column], [UniqueDef])-mkColumns allDefs val =-    (cols, entityUniques t)-  where-    cols :: [Column]-    cols = zipWith go (entityFields t)-         $ toPersistFields-         $ halfDefined `asTypeOf` val--    t :: EntityDef-    t = entityDef val--    tn :: DBName-    tn = entityDB t--    go :: FieldDef -> SomePersistField -> Column-    go fd p =-        Column-            (fieldDB fd)-            (nullable (fieldAttrs fd) /= NotNullable || entitySum t)-            (maybe (sqlType p) SqlOther $ listToMaybe $ mapMaybe (T.stripPrefix "sqltype=") $ fieldAttrs fd)-            (def $ fieldAttrs fd)-            (maxLen $ fieldAttrs fd)-            (ref (fieldDB fd) (fieldType fd) (fieldAttrs fd))--    def :: [Attr] -> Maybe Text-    def [] = Nothing-    def (a:as)-        | Just d <- T.stripPrefix "default=" a = Just d-        | otherwise = def as--    maxLen :: [Attr] -> Maybe Integer-    maxLen [] = Nothing-    maxLen (a:as)-        | Just d <- T.stripPrefix "maxlen=" a =-            case reads (T.unpack d) of-              [(i, s)] | all isSpace s -> Just i-              _ -> error $ "Could not parse maxlen field with value " ++-                           show d ++ " on " ++ show tn-        | otherwise = maxLen as--    ref :: DBName-        -> FieldType-        -> [Attr]-        -> Maybe (DBName, DBName) -- table name, constraint name-    ref c ft []-        | Just f <- stripId ft =-            Just (resolveTableName allDefs $ HaskellName f, refName tn c)-        | otherwise = Nothing-    ref _ _ ("noreference":_) = Nothing-    ref c _ (a:_)-        | Just x <- T.stripPrefix "reference=" a =-            Just (DBName x, refName tn c)-    ref c x (_:as) = ref c x as--refName :: DBName -> DBName -> DBName-refName (DBName table) (DBName column) =-    DBName $ mconcat [table, "_", column, "_fkey"]--data Column = Column-    { cName      :: DBName-    , cNull      :: Bool-    , cType      :: SqlType-    , cDefault   :: Maybe Text-    , cMaxLen    :: Maybe Integer-    , cReference :: (Maybe (DBName, DBName)) -- table name, constraint name-    }-    deriving (Eq, Ord, Show)--{- FIXME-getSqlValue :: [String] -> Maybe String-getSqlValue (('s':'q':'l':'=':x):_) = Just x-getSqlValue (_:x) = getSqlValue x-getSqlValue [] = Nothing--getIdNameValue :: [String] -> Maybe String-getIdNameValue (('i':'d':'=':x):_) = Just x-getIdNameValue (_:x) = getIdNameValue x-getIdNameValue [] = Nothing--}--{- FIXME-tableColumns :: EntityDef -> [(RawName, String, [String])]-tableColumns = map (\a@(ColumnDef _ y z) -> (rawFieldName a, y, z)) . entityColumns--}--{- FIXME-getFieldName :: EntityDef -> String -> RawName-getFieldName t s = rawFieldName $ tableColumn t s--tableColumn :: EntityDef -> String -> ColumnDef-tableColumn t s | s == id_ = ColumnDef id_ "Int64" []-  where id_ = unRawName $ rawTableIdName t-tableColumn t s = go $ entityColumns t-  where-    go [] = error $ "Unknown table column: " ++ s-    go (ColumnDef x y z:rest)-        | x == s = ColumnDef x y z-        | otherwise = go rest--}--logSQL :: Q Exp-logSQL = [|\sql_foo params_foo -> $logDebugS (T.pack "SQL") $ T.pack $ show (sql_foo :: Text) ++ " " ++ show (params_foo :: [PersistValue])|]
− Database/Persist/GenericSql/Migration.hs 
@@ -1,156 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-module Database.Persist.GenericSql.Migration-  (   Migration-    , parseMigration-    , parseMigration'-    , printMigration-    , getMigration-    , runMigration-    , runMigrationSilent-    , runMigrationUnsafe-    , migrate-    , commit-    , rollback-  ) where---import Database.Persist.GenericSql.Internal-import Database.Persist.EntityDef-import qualified Database.Persist.GenericSql.Raw as R-import Database.Persist.Store-import Database.Persist.GenericSql.Raw (SqlPersist (..))-#if MIN_VERSION_monad_control(0, 3, 0)-import Control.Monad.Trans.Control (MonadBaseControl)-#define MBCIO MonadBaseControl IO-#else-import Control.Monad.IO.Control (MonadControlIO)-#define MBCIO MonadControlIO-#endif-import Control.Monad.Trans.Class (MonadTrans (..))-import Control.Monad.IO.Class-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Writer-import Control.Monad (liftM, unless)-import Data.Text (Text, unpack, snoc, isPrefixOf, pack)-import qualified Data.Text.IO-import System.IO-import Control.Monad.Logger (MonadLogger)-import System.IO.Silently (hSilence)-import System.IO (stderr)-import Control.Monad.Trans.Control (liftBaseOp_)--execute' :: (MonadIO m, MonadLogger m) => Text -> [PersistValue] -> SqlPersist m ()-execute' = R.execute--type Sql = Text---- Bool indicates if the Sql is safe-type CautiousMigration = [(Bool, Sql)]-allSql :: CautiousMigration -> [Sql]-allSql = map snd-unsafeSql :: CautiousMigration -> [Sql]-unsafeSql = allSql . filter fst-safeSql :: CautiousMigration -> [Sql]-safeSql = allSql . filter (not . fst)--type Migration m = WriterT [Text] (WriterT CautiousMigration m) ()--parseMigration :: Monad m => Migration m -> m (Either [Text] CautiousMigration)-parseMigration =-    liftM go . runWriterT . execWriterT-  where-    go ([], sql) = Right sql-    go (errs, _) = Left errs---- like parseMigration, but call error or return the CautiousMigration-parseMigration' :: Monad m => Migration m -> m (CautiousMigration)-parseMigration' m = do-  x <- parseMigration m-  case x of-      Left errs -> error $ unlines $ map unpack errs-      Right sql -> return sql--printMigration :: (MBCIO m, MonadIO m) => Migration (SqlPersist m) -> SqlPersist m ()-printMigration m = do-  mig <- parseMigration' m-  mapM_ (liftIO . Data.Text.IO.putStrLn . flip snoc ';') (allSql mig)--getMigration :: (MBCIO m, MonadIO m) => Migration (SqlPersist m) -> SqlPersist m [Sql]-getMigration m = do-  mig <- parseMigration' m-  return $ allSql mig--runMigration :: (MonadIO m, MBCIO m, MonadLogger m)-             => Migration (SqlPersist m)-             -> SqlPersist 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 :: (MBCIO m, MonadIO m, MonadLogger m)-                   => Migration (SqlPersist m)-                   -> SqlPersist m [Text]-runMigrationSilent m = liftBaseOp_ (hSilence [stderr]) $ runMigration' m True--runMigration'-    :: (MBCIO m, MonadIO m, MonadLogger m)-    => Migration (SqlPersist m)-    -> Bool -- ^ is silent?-    -> SqlPersist m [Text]-runMigration' m silent = do-    mig <- parseMigration' m-    case unsafeSql mig of-        []   -> mapM (executeMigrate silent) $ sortMigrations $ safeSql mig-        errs -> error $ concat-            [ "\n\nDatabase migration: manual intervention required.\n"-            , "The following actions are considered unsafe:\n\n"-            , unlines $ map (\s -> "    " ++ unpack s ++ ";") $ errs-            ]--runMigrationUnsafe :: (MBCIO m, MonadIO m, MonadLogger m)-                   => Migration (SqlPersist m)-                   -> SqlPersist m ()-runMigrationUnsafe m = do-    mig <- parseMigration' m-    mapM_ (executeMigrate False) $ sortMigrations $ allSql mig--executeMigrate :: (MonadIO m, MonadLogger m) => Bool -> Text -> SqlPersist m Text-executeMigrate silent s = do-    unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ unpack s-    execute' s []-    return s---- | Sort the alter DB statements so tables are created before constraints are--- added.-sortMigrations :: [Sql] -> [Sql]-sortMigrations x =-    filter isCreate x ++ filter (not . isCreate) x-  where-    -- Note the use of lower-case e. This (hack) allows backends to explicitly-    -- choose to have this special sorting applied.-    isCreate t = pack "CREATe " `isPrefixOf` t--migrate :: (MonadIO m, MBCIO m, PersistEntity val)-        => [EntityDef]-        -> val-        -> Migration (SqlPersist m)-migrate allDefs val = do-    conn <- lift $ lift $ SqlPersist ask-    let getter = R.getStmt' conn-    res <- liftIO $ migrateSql conn allDefs getter val-    either tell (lift . tell) res---- | Perform a database commit.-commit :: MonadIO m => SqlPersist m ()-commit = do-    conn <- SqlPersist ask-    let getter = R.getStmt' conn-    liftIO $ commitC conn getter >> begin conn getter---- | Perform a database rollback.-rollback :: MonadIO m => SqlPersist m ()-rollback = do-    conn <- SqlPersist ask-    let getter = R.getStmt' conn-    liftIO $ rollbackC conn getter >> begin conn getter
− Database/Persist/GenericSql/Raw.hs 
@@ -1,195 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE DeriveDataTypeable #-}-module Database.Persist.GenericSql.Raw-    ( withStmt-    , execute-    , executeCount-    , SqlPersist (..)-    , getStmt'-    , getStmt-    , SqlBackend-    , MonadSqlPersist (..)-    , StatementAlreadyFinalized (..)-    ) where--import qualified Database.Persist.GenericSql.Internal as I-import Database.Persist.GenericSql.Internal hiding (execute, withStmt)-import Database.Persist.Store (PersistValue)-import Data.IORef-import Control.Monad.IO.Class-import Control.Monad.Logger (logDebugS)-import Control.Monad.Trans.Reader-import qualified Data.Map as Map-import Control.Applicative (Applicative)-import Control.Monad.Trans.Class (MonadTrans (..))-import Control.Monad.Base (MonadBase (liftBase))-import Control.Monad.Trans.Control (MonadBaseControl (..), ComposeSt, defaultLiftBaseWith, defaultRestoreM, MonadTransControl (..))-import Control.Monad (liftM, when)-import Control.Exception (throwIO, Exception)-#define MBCIO MonadBaseControl IO-import Data.Text (Text, pack)-import Control.Monad (MonadPlus)-import Control.Monad.Trans.Resource (MonadResource (..))-import Data.Conduit-#if MIN_VERSION_conduit(1, 0, 0)-import Data.Conduit.Internal (Pipe, ConduitM)-#endif-import Control.Monad.Logger (MonadLogger (..))-import Data.Monoid (Monoid)-import Data.Typeable (Typeable)-import Data.Int (Int64)--import Control.Monad.Logger (LoggingT)-import Control.Monad.Trans.Identity ( IdentityT)-import Control.Monad.Trans.List     ( ListT    )-import Control.Monad.Trans.Maybe    ( MaybeT   )-import Control.Monad.Trans.Error    ( ErrorT, Error)-import Control.Monad.Trans.Cont     ( ContT  )-import Control.Monad.Trans.State    ( StateT   )-import Control.Monad.Trans.Writer   ( WriterT  )-import Control.Monad.Trans.RWS      ( RWST     )--import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )-import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )-import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )--data SqlBackend--newtype SqlPersist m a = SqlPersist { unSqlPersist :: ReaderT Connection m a }-    deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadPlus)--instance MonadThrow m => MonadThrow (SqlPersist m) where-    monadThrow = lift . monadThrow--instance MonadBase backend m => MonadBase backend (SqlPersist m) where-    liftBase = lift . liftBase--instance MonadBaseControl backend m => MonadBaseControl backend (SqlPersist m) where-     newtype StM (SqlPersist m) a = StMSP {unStMSP :: ComposeSt SqlPersist m a}-     liftBaseWith = defaultLiftBaseWith StMSP-     restoreM     = defaultRestoreM   unStMSP-instance MonadTransControl SqlPersist where-    newtype StT SqlPersist a = StReader {unStReader :: a}-    liftWith f = SqlPersist $ ReaderT $ \r -> f $ \t -> liftM StReader $ runReaderT (unSqlPersist t) r-    restoreT = SqlPersist . ReaderT . const . liftM unStReader--instance MonadResource m => MonadResource (SqlPersist m) where-#if MIN_VERSION_resourcet(0,4,0)-    liftResourceT = lift . liftResourceT-#else-    register = lift . register-    release = lift . release-    allocate a = lift . allocate a-    resourceMask = lift . resourceMask-#endif--class (MonadIO m, MonadLogger m) => MonadSqlPersist m where-    askSqlConn :: m Connection--instance (MonadIO m, MonadLogger m) => MonadSqlPersist (SqlPersist m) where-    askSqlConn = SqlPersist ask--#define GO(T) instance (MonadSqlPersist m) => MonadSqlPersist (T m) where askSqlConn = lift askSqlConn-#define GOX(X, T) instance (X, MonadSqlPersist m) => MonadSqlPersist (T m) where askSqlConn = lift askSqlConn-GO(LoggingT)-GO(IdentityT)-GO(ListT)-GO(MaybeT)-GOX(Error e, ErrorT e)-GO(ReaderT r)-GO(ContT r)-GO(StateT s)-GO(ResourceT)-GO(Pipe l i o u)-#if MIN_VERSION_conduit(1, 0, 0)-GO(ConduitM i o)-#endif-GOX(Monoid w, WriterT w)-GOX(Monoid w, RWST r w s)-GOX(Monoid w, Strict.RWST r w s)-GO(Strict.StateT s)-GOX(Monoid w, Strict.WriterT w)-#undef GO-#undef GOX--instance MonadLogger m => MonadLogger (SqlPersist m) where-#if MIN_VERSION_monad_logger(0, 3, 0)-    monadLoggerLog a b c = lift . monadLoggerLog a b c-#else-    monadLoggerLog a b c = lift $ monadLoggerLog a b c-    monadLoggerLogSource a b c = lift . monadLoggerLogSource a b c-#endif--withStmt :: (MonadSqlPersist m, MonadResource m)-         => Text-         -> [PersistValue]-         -> Source m [PersistValue]-withStmt sql vals = do-    lift $ $logDebugS (pack "SQL") $ pack $ show sql ++ " " ++ show vals-    conn <- lift askSqlConn-    bracketP-        (getStmt' conn sql)-        I.reset-        (flip I.withStmt vals)--execute :: MonadSqlPersist m => Text -> [PersistValue] -> m ()-execute x y = liftM (const ()) $ executeCount x y--executeCount :: MonadSqlPersist m => Text -> [PersistValue] -> m Int64-executeCount sql vals = do-    $logDebugS (pack "SQL") $ pack $ show sql ++ " " ++ show vals-    stmt <- getStmt sql-    res <- liftIO $ I.execute stmt vals-    liftIO $ reset stmt-    return res--getStmt :: MonadSqlPersist m => Text -> m Statement-getStmt sql = do-    conn <- askSqlConn-    liftIO $ getStmt' conn sql--getStmt' :: Connection -> Text -> IO Statement-getStmt' conn sql = do-    smap <- liftIO $ readIORef $ stmtMap conn-    case Map.lookup sql smap of-        Just stmt -> return stmt-        Nothing -> do-            stmt' <- liftIO $ prepare conn sql-            iactive <- liftIO $ newIORef True-            let stmt = I.Statement-                    { finalize = do-                        active <- readIORef iactive-                        if active-                            then do-                                finalize stmt'-                                writeIORef iactive False-                            else return ()-                    , reset = do-                        active <- readIORef iactive-                        when active $ reset stmt'-                    , I.execute = \x -> do-                        active <- readIORef iactive-                        if active-                            then I.execute stmt' x-                            else throwIO $ StatementAlreadyFinalized sql-                    , I.withStmt = \x -> do-                        active <- liftIO $ readIORef iactive-                        if active-                            then I.withStmt stmt' x-                            else liftIO $ throwIO $ StatementAlreadyFinalized sql-                    }-            liftIO $ writeIORef (stmtMap conn) $ Map.insert sql stmt smap-            return stmt--data StatementAlreadyFinalized = StatementAlreadyFinalized Text-    deriving (Typeable, Show)-instance Exception StatementAlreadyFinalized
Database/Persist/Quasi.hs view
@@ -1,10 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE PatternGuards #-} module Database.Persist.Quasi     ( parse     , PersistSettings (..)     , upperCaseSettings     , lowerCaseSettings+    , stripId+    , nullable #if TEST     , Token (..)     , tokenize@@ -13,9 +16,9 @@     ) where  import Prelude hiding (lines)-import Database.Persist.EntityDef+import Database.Persist.Types import Data.Char-import Data.Maybe (mapMaybe)+import Data.Maybe (mapMaybe, fromMaybe) import Data.Text (Text) import qualified Data.Text as T import Control.Arrow ((&&&))@@ -71,12 +74,17 @@             _ -> PSSuccess (front []) t  data PersistSettings = PersistSettings-    { psToDBName :: Text -> Text+    { psToDBName :: !(Text -> Text)+    , psStrictFields :: !Bool+    -- ^ Whether fields are by default strict. Default value: @True@.+    --+    -- Since 1.2     }  upperCaseSettings :: PersistSettings upperCaseSettings = PersistSettings     { psToDBName = id+    , psStrictFields = True     }  lowerCaseSettings :: PersistSettings@@ -86,10 +94,11 @@                 | isUpper c = T.pack ['_', toLower c]                 | otherwise = T.singleton c          in T.dropWhile (== '_') . T.concatMap go+    , psStrictFields = True     }  -- | 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)@@ -168,7 +177,7 @@     fromToken Spaces{}  = Nothing  -- | Divide lines into blocks and make entity definitions.-parseLines :: PersistSettings -> [Line] -> [EntityDef]+parseLines :: PersistSettings -> [Line] -> [EntityDef ()] parseLines ps lines =     toEnts lines   where@@ -183,7 +192,7 @@             -> Text -- ^ name             -> [Attr] -- ^ entity attributes             -> [Line] -- ^ indented lines-            -> EntityDef+            -> EntityDef () mkEntityDef ps name entattribs lines =     EntityDef         (HaskellName name')@@ -206,7 +215,7 @@     uniqs = mapMaybe (takeUniqs ps cols) attribs     derives = concat $ mapMaybe takeDerives attribs -    cols :: [FieldDef]+    cols :: [FieldDef ()]     cols = mapMaybe (takeCols ps) attribs  splitExtras :: [Line] -> ([[Text]], M.Map Text [[Text]])@@ -220,17 +229,26 @@     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)+takeCols ps (n':typ:rest)     | not (T.null n) && isLower (T.head n) =         case parseFieldType typ of             Nothing -> error $ "Invalid field type: " ++ show typ-            Just ft -> Just $ FieldDef-                (HaskellName n)-                (DBName $ getDbName ps n rest)-                ft-                rest+            Just ft -> Just FieldDef+                { fieldHaskell = HaskellName n+                , fieldDB = DBName $ getDbName ps n rest+                , fieldType = ft+                , fieldSqlType = ()+                , fieldAttrs = rest+                , fieldStrict = fromMaybe (psStrictFields ps) mstrict+                , fieldEmbedded = Nothing+                }+  where+    (mstrict, n)+        | Just x <- T.stripPrefix "!" n' = (Just True, x)+        | Just x <- T.stripPrefix "~" n' = (Just False, x)+        | otherwise = (Nothing, n') takeCols _ _ = Nothing  getDbName :: PersistSettings -> Text -> [Text] -> Text@@ -241,7 +259,7 @@       Just s  -> s  takeUniqs :: PersistSettings-          -> [FieldDef]+          -> [FieldDef a]           -> [Text]           -> Maybe UniqueDef takeUniqs ps defs (n:rest)@@ -262,3 +280,13 @@ 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+    | "Maybe"    `elem` s = Nullable ByMaybeAttr+    | "nullable" `elem` s = Nullable ByNullableAttr+    | otherwise = NotNullable
− Database/Persist/Query.hs 
@@ -1,58 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Database.Persist.Query-  (   PersistQuery (..)-    , selectList-    , selectKeysList-    , deleteCascadeWhere--    , SelectOpt (..)-    , Filter (..)--    -- * query combinators-    , (=.), (+=.), (-=.), (*=.), (/=.)-    , (==.), (!=.), (<.), (>.), (<=.), (>=.)-    , (<-.), (/<-.)-    , (||.)-  ) where--import Database.Persist.Store-import Database.Persist.Query.Internal---- import and export the GenericSql instance (orphaned for convenience of modularity)-import Database.Persist.Query.GenericSql ()--infixr 3 =., +=., -=., *=., /=.-(=.), (+=.), (-=.), (*=.), (/=.) :: forall v typ.  PersistField typ => EntityField v typ -> typ -> Update v--- | assign a field a value-f =. a = Update f a Assign--- | assign a field by addition (+=)-f +=. a = Update f a Add--- | assign a field by subtraction (-=)-f -=. a = Update f a Subtract--- | assign a field by multiplication (*=)-f *=. a = Update f a Multiply--- | assign a field by division (/=)-f /=. a = Update f a Divide--infix 4 ==., <., <=., >., >=., !=.-(==.), (!=.), (<.), (<=.), (>.), (>=.) ::-  forall v typ.  PersistField typ => EntityField v typ -> typ -> Filter v-f ==. a  = Filter f (Left a) Eq-f !=. a = Filter f (Left a) Ne-f <. a  = Filter f (Left a) Lt-f <=. a  = Filter f (Left a) Le-f >. a  = Filter f (Left a) Gt-f >=. a  = Filter f (Left a) Ge--infix 4 <-., /<-.-(<-.), (/<-.) :: forall v typ.  PersistField typ => EntityField v typ -> [typ] -> Filter v--- | In-f <-. a = Filter f (Right a) In--- | NotIn-f /<-. a = Filter f (Right a) NotIn--infixl 3 ||.-(||.) :: forall v. [Filter v] -> [Filter v] -> [Filter v]--- | the OR of two lists of filters-a ||. b = [FilterOr  [FilterAnd a, FilterAnd b]]
− Database/Persist/Query/GenericSql.hs 
@@ -1,416 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE UndecidableInstances #-} -- FIXME--module Database.Persist.Query.GenericSql-  ( PersistQuery (..)-    , SqlPersist (..)-    , filterClauseNoWhere-    , filterClauseNoWhereOrNull-    , getFiltsValues-    , selectSourceConn-    , dummyFromFilts-    , orderClause-    , deleteWhereCount-    , updateWhereCount-  )-  where--import qualified Prelude-import Prelude hiding ((++), unlines, concat, show)-import Data.Text (Text, pack, concat)-import Database.Persist.Store-import Database.Persist.Query.Internal-import Database.Persist.GenericSql-import Database.Persist.GenericSql.Internal-import qualified Database.Persist.GenericSql.Raw as R--import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Control.Monad.Trans.Reader--import Data.Conduit-import qualified Data.Conduit.List as CL-import Data.Int (Int64)--import Control.Exception (throwIO)-import qualified Data.Text as T-import Database.Persist.EntityDef-import Data.Monoid (Monoid, mappend, mconcat)-import Control.Monad.Logger (MonadLogger)---- orphaned instance for convenience of modularity-instance (MonadResource m, MonadLogger m) => PersistQuery (SqlPersist m) where-    update _ [] = return ()-    update k upds = do-        conn <- SqlPersist ask-        let go'' n Assign = n ++ "=?"-            go'' n Add = concat [n, "=", n, "+?"]-            go'' n Subtract = concat [n, "=", n, "-?"]-            go'' n Multiply = concat [n, "=", n, "*?"]-            go'' n Divide = concat [n, "=", n, "/?"]-        let go' (x, pu) = go'' (escapeName conn x) pu-        let sql = concat-                [ "UPDATE "-                , escapeName conn $ entityDB t-                , " SET "-                , T.intercalate "," $ map (go' . go) upds-                , " WHERE "-                , escapeName conn $ entityID t-                , "=?"-                ]-        execute' sql $-            map updatePersistValue upds `mappend` [unKey k]-      where-        t = entityDef $ dummyFromKey k-        go x = (fieldDB $ updateFieldDef x, updateUpdate x)--    count filts = do-        conn <- SqlPersist ask-        let wher = if null filts-                    then ""-                    else filterClause False conn filts-        let sql = concat-                [ "SELECT COUNT(*) FROM "-                , escapeName conn $ entityDB t-                , wher-                ]-        R.withStmt sql (getFiltsValues conn filts) $$ do-            Just [PersistInt64 i] <- CL.head-            return $ fromIntegral i-      where-        t = entityDef $ dummyFromFilts filts--    selectSource filts opts = do-        conn <- lift $ SqlPersist ask-        R.withStmt (sql conn) (getFiltsValues conn filts) $= CL.mapM parse-      where-        (limit, offset, orders) = limitOffsetOrder opts--        parse vals =-            case fromPersistValues' vals of-                Left s -> liftIO $ throwIO $ PersistMarshalError s-                Right row -> return row--        t = entityDef $ dummyFromFilts filts-        fromPersistValues' (PersistInt64 x:xs) = do-            case fromPersistValues xs of-                Left e -> Left e-                Right xs' -> Right (Entity (Key $ PersistInt64 x) xs')-        fromPersistValues' _ = Left "error in fromPersistValues'"-        wher conn = if null filts-                    then ""-                    else filterClause False conn filts-        ord conn =-            case map (orderClause False conn) orders of-                [] -> ""-                ords -> " ORDER BY " ++ T.intercalate "," ords-        lim conn = case (limit, offset) of-                (0, 0) -> ""-                (0, _) -> T.cons ' ' $ noLimit conn-                (_, _) -> " LIMIT " ++ show limit-        off = if offset == 0-                    then ""-                    else " OFFSET " ++ show offset-        cols conn = T.intercalate ","-                  $ (escapeName conn $ entityID t)-                  : map (escapeName conn . fieldDB) (entityFields t)-        sql conn = concat-            [ "SELECT "-            , cols conn-            , " FROM "-            , escapeName conn $ entityDB t-            , wher conn-            , ord conn-            , lim conn-            , off-            ]--    selectKeys filts opts = do-        conn <- lift $ SqlPersist ask-        R.withStmt (sql conn) (getFiltsValues conn filts) $= CL.mapM parse-      where-        parse [PersistInt64 i] = return $ Key $ PersistInt64 i-        parse y = liftIO $ throwIO $ PersistMarshalError $ "Unexpected in selectKeys: " ++ show y-        t = entityDef $ dummyFromFilts filts-        wher conn = if null filts-                    then ""-                    else filterClause False conn filts-        sql conn = concat-            [ "SELECT "-            , escapeName conn $ entityID t-            , " FROM "-            , escapeName conn $ entityDB t-            , wher conn-            , ord conn-            , lim conn-            , off-            ]--        (limit, offset, orders) = limitOffsetOrder opts--        ord conn =-            case map (orderClause False conn) orders of-                [] -> ""-                ords -> " ORDER BY " ++ T.intercalate "," ords-        lim conn = case (limit, offset) of-                (0, 0) -> ""-                (0, _) -> T.cons ' ' $ noLimit conn-                (_, _) -> " LIMIT " ++ show limit-        off = if offset == 0-                    then ""-                    else " OFFSET " ++ show offset--    deleteWhere filts = do-        _ <- deleteWhereCount filts-        return ()--    updateWhere filts upds = do-        _ <- updateWhereCount filts upds-        return ()---- | Same as 'deleteWhere', but returns the number of rows affected.------ Since 1.1.5-deleteWhereCount :: (PersistEntity val, MonadIO m, MonadLogger m)-                 => [Filter val]-                 -> SqlPersist m Int64-deleteWhereCount filts = do-    conn <- SqlPersist ask-    let t = entityDef $ dummyFromFilts filts-    let wher = if null filts-                then ""-                else filterClause False conn filts-        sql = concat-            [ "DELETE FROM "-            , escapeName conn $ entityDB t-            , wher-            ]-    R.executeCount sql $ getFiltsValues conn filts---- | Same as 'updateWhere', but returns the number of rows affected.------ Since 1.1.5-updateWhereCount :: (PersistEntity val, MonadIO m, MonadLogger m)-                 => [Filter val]-                 -> [Update val]-                 -> SqlPersist m Int64-updateWhereCount _ [] = return 0-updateWhereCount filts upds = do-    conn <- SqlPersist ask-    let wher = if null filts-                then ""-                else filterClause False conn filts-    let sql = concat-            [ "UPDATE "-            , escapeName conn $ entityDB t-            , " SET "-            , T.intercalate "," $ map (go' conn . go) upds-            , wher-            ]-    let dat = map updatePersistValue upds `mappend`-              getFiltsValues conn filts-    R.executeCount sql dat-  where-    t = entityDef $ dummyFromFilts filts-    go'' n Assign = n ++ "=?"-    go'' n Add = concat [n, "=", n, "+?"]-    go'' n Subtract = concat [n, "=", n, "-?"]-    go'' n Multiply = concat [n, "=", n, "*?"]-    go'' n Divide = concat [n, "=", n, "/?"]-    go' conn (x, pu) = go'' (escapeName conn x) pu-    go x = (fieldDB $ updateFieldDef x, updateUpdate x)--updatePersistValue :: Update v -> PersistValue-updatePersistValue (Update _ v _) = toPersistValue v--dummyFromKey :: KeyBackend R.SqlBackend v -> v-dummyFromKey _ = error "dummyFromKey"--execute' :: (MonadLogger m, MonadIO m) => Text -> [PersistValue] -> SqlPersist m ()-execute' = R.execute--getFiltsValues :: forall val.  PersistEntity val => Connection -> [Filter val] -> [PersistValue]-getFiltsValues conn = snd . filterClauseHelper False False conn OrNullNo--filterClause :: PersistEntity val-             => Bool -- ^ include table name?-             -> Connection-             -> [Filter val]-             -> Text-filterClause b c = fst . filterClauseHelper b True c OrNullNo--data OrNull = OrNullYes | OrNullNo--filterClauseNoWhere :: PersistEntity val-                    => Bool -- ^ include table name?-                    -> Connection-                    -> [Filter val]-                    -> Text-filterClauseNoWhere b c = fst . filterClauseHelper b False c OrNullNo--filterClauseNoWhereOrNull :: PersistEntity val-                    => Bool -- ^ include table name?-                    -> Connection-                    -> [Filter val]-                    -> Text-filterClauseNoWhereOrNull b c = fst . filterClauseHelper b False c OrNullYes--filterClauseHelper :: PersistEntity val-             => Bool -- ^ include table name?-             -> Bool -- ^ include WHERE?-             -> Connection-             -> OrNull-             -> [Filter val]-             -> (Text, [PersistValue])-filterClauseHelper includeTable includeWhere conn orNull filters =-    (if not (T.null sql) && includeWhere-        then " WHERE " ++ sql-        else sql, vals)-  where-    (sql, vals) = combineAND filters-    combineAND = combine " AND "--    combine s fs =-        (T.intercalate s $ map wrapP a, mconcat b)-      where-        (a, b) = unzip $ map go fs-        wrapP x = T.concat ["(", x, ")"]--    go (BackendFilter _) = error "BackendFilter not expected"-    go (FilterAnd []) = ("1=1", [])-    go (FilterAnd fs) = combineAND fs-    go (FilterOr []) = ("1=0", [])-    go (FilterOr fs)  = combine " OR " fs-    go (Filter field value pfilter) =-        case (isNull, pfilter, varCount) of-            (True, Eq, _) -> (name ++ " IS NULL", [])-            (True, Ne, _) -> (name ++ " IS NOT NULL", [])-            (False, Ne, _) -> (T.concat-                [ "("-                , name-                , " IS NULL OR "-                , name-                , " <> "-                , qmarks-                , ")"-                ], notNullVals)-            -- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since-            -- not all databases support those words directly.-            (_, In, 0) -> ("1=2" ++ orNullSuffix, [])-            (False, In, _) -> (name ++ " IN " ++ qmarks ++ orNullSuffix, allVals)-            (True, In, _) -> (T.concat-                [ "("-                , name-                , " IS NULL OR "-                , name-                , " IN "-                , qmarks-                , ")"-                ], notNullVals)-            (_, NotIn, 0) -> ("1=1", [])-            (False, NotIn, _) -> (T.concat-                [ "("-                , name-                , " IS NULL OR "-                , name-                , " NOT IN "-                , qmarks-                , ")"-                ], notNullVals)-            (True, NotIn, _) -> (T.concat-                [ "("-                , name-                , " IS NOT NULL AND "-                , name-                , " NOT IN "-                , qmarks-                , ")"-                ], notNullVals)-            _ -> (name ++ showSqlFilter pfilter ++ "?" ++ orNullSuffix, allVals)-      where-        filterValueToPersistValues :: forall a.  PersistField a => Either a [a] -> [PersistValue]-        filterValueToPersistValues v = map toPersistValue $ either return id v--        orNullSuffix =-            case orNull of-                OrNullYes -> concat [" OR ", name, " IS NULL"]-                OrNullNo -> ""--        isNull = any (== PersistNull) allVals-        notNullVals = filter (/= PersistNull) allVals-        allVals = filterValueToPersistValues value-        tn = escapeName conn $ entityDB-           $ entityDef $ dummyFromFilts [Filter field value pfilter]-        name =-            (if includeTable-                then ((tn ++ ".") ++)-                else id)-            $ escapeName conn $ fieldDB $ persistFieldDef field-        qmarks = case value of-                    Left _ -> "?"-                    Right x ->-                        let x' = filter (/= PersistNull) $ map toPersistValue x-                         in "(" ++ T.intercalate "," (map (const "?") x') ++ ")"-        varCount = case value of-                    Left _ -> 1-                    Right x -> length x-        showSqlFilter Eq = "="-        showSqlFilter Ne = "++"-        showSqlFilter Gt = ">"-        showSqlFilter Lt = "<"-        showSqlFilter Ge = ">="-        showSqlFilter Le = "<="-        showSqlFilter In = " IN "-        showSqlFilter NotIn = " NOT IN "-        showSqlFilter (BackendSpecificFilter s) = s--infixr 5 ++-(++) :: Text -> Text -> Text-(++) = mappend--show :: Show a => a -> Text-show = pack . Prelude.show---- | Equivalent to 'selectSource', but instead of getting the connection from--- the environment inside a 'SqlPersist' monad, provide an explicit--- 'Connection'. This can allow you to use the returned 'Source' in an--- arbitrary monad.-selectSourceConn :: (PersistEntity val, MonadResource m, MonadLogger m, PersistEntityBackend val ~ R.SqlBackend, MonadBaseControl IO m)-                 => Connection-                 -> [Filter val]-                 -> [SelectOpt val]-                 -> Source m (Entity val)-selectSourceConn conn fs opts =-    transPipe (flip runSqlConn conn) (selectSource fs opts)--dummyFromFilts :: [Filter v] -> v-dummyFromFilts _ = error "dummyFromFilts"--orderClause :: PersistEntity val-            => Bool -- ^ include the table name-            -> Connection-            -> SelectOpt val-            -> Text-orderClause includeTable conn o =-    case o of-        Asc  x -> name $ persistFieldDef x-        Desc x -> name (persistFieldDef x) ++ " DESC"-        _ -> error $ "orderClause: expected Asc or Desc, not limit or offset"-  where-    dummyFromOrder :: SelectOpt a -> a-    dummyFromOrder _ = undefined--    tn = escapeName conn $ entityDB $ entityDef $ dummyFromOrder o--    name x =-        (if includeTable-            then ((tn ++ ".") ++)-            else id)-        $ escapeName conn $ fieldDB x
− Database/Persist/Query/Internal.hs 
@@ -1,201 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE CPP #-}-module Database.Persist.Query.Internal-  ( -- re-exported as public-      PersistQuery (..)-    , selectList-    , selectKeysList--    -- just Internal-    , SelectOpt (..)-    , limitOffsetOrder-    , Filter (..)-    , PersistUpdate (..)-    , Update (..)-    , updateFieldDef-    , deleteCascadeWhere--    -- * Exceptions-    , UpdateGetException (..)--    -- * Filters-    , BackendSpecificFilter-  ) where--import Database.Persist.Store-import Database.Persist.EntityDef-import Control.Monad.IO.Class (liftIO)-import Control.Exception (Exception, throwIO)-import Data.Typeable (Typeable)--import qualified Data.Conduit as C-import qualified Data.Conduit.List as CL--import Control.Monad.Trans.Class (lift)-import Data.Monoid (Monoid)--#if MIN_VERSION_conduit(1, 0, 0)-import Data.Conduit.Internal (Pipe, ConduitM)-#else-import Data.Conduit (Pipe)-#endif-import Control.Monad.Logger (LoggingT)-import Control.Monad.Trans.Identity ( IdentityT)-import Control.Monad.Trans.List     ( ListT    )-import Control.Monad.Trans.Maybe    ( MaybeT   )-import Control.Monad.Trans.Error    ( ErrorT, Error   )-import Control.Monad.Trans.Reader   ( ReaderT  )-import Control.Monad.Trans.Cont     ( ContT  )-import Control.Monad.Trans.State    ( StateT   )-import Control.Monad.Trans.Writer   ( WriterT  )-import Control.Monad.Trans.RWS      ( RWST     )-import Control.Monad.Trans.Resource ( ResourceT)--import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )-import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )-import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )--data UpdateGetException = KeyNotFound String-    deriving Typeable-instance Show UpdateGetException where-    show (KeyNotFound key) = "Key not found during updateGet: " ++ key-instance Exception UpdateGetException--class PersistStore 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--    -- | Update individual fields on any record matching the given criterion.-    updateWhere :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)-                => [Filter val] -> [Update val] -> m ()--    -- | Delete all records matching the given criterion.-    deleteWhere :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)-                => [Filter val] -> m ()--    -- | Get all records matching the given criterion in the specified order.-    -- Returns also the identifiers.-    selectSource-           :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)-           => [Filter val]-           -> [SelectOpt val]-           -> C.Source m (Entity val)--    -- | get just the first record for the criterion-    selectFirst :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)-                => [Filter val]-                -> [SelectOpt val]-                -> m (Maybe (Entity val))-    selectFirst filts opts = selectSource filts ((LimitTo 1):opts) C.$$ CL.head---    -- | Get the 'Key's of all records matching the given criterion.-    selectKeys :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)-               => [Filter val]-               -> [SelectOpt val]-               -> C.Source m (Key val)--    -- | The total number of records fulfilling the given criterion.-    count :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m)-          => [Filter val] -> m Int--#define DEF(T) { update k = lift . update k; updateGet k = lift . updateGet k; updateWhere f = lift . updateWhere f; deleteWhere = lift . deleteWhere; selectSource f = C.transPipe lift . selectSource f; selectFirst f = lift . selectFirst f; selectKeys f = C.transPipe lift . selectKeys f; count = lift . count }-#define GO(T) instance (PersistQuery m) => PersistQuery (T m) where DEF(T)-#define GOX(X, T) instance (X, PersistQuery m) => PersistQuery (T m) where DEF(T)--GO(LoggingT)-GO(IdentityT)-GO(ListT)-GO(MaybeT)-GOX(Error e, ErrorT e)-GO(ReaderT r)-GO(ContT r)-GO(StateT s)-GO(ResourceT)-GO(Pipe l i o u)-#if MIN_VERSION_conduit(1, 0, 0)-GO(ConduitM i o)-#endif-GOX(Monoid w, WriterT w)-GOX(Monoid w, RWST r w s)-GOX(Monoid w, Strict.RWST r w s)-GO(Strict.StateT s)-GOX(Monoid w, Strict.WriterT w)--#undef DEF-#undef GO-#undef GOX--type family BackendSpecificFilter b v---- | Filters which are available for 'select', 'updateWhere' and--- 'deleteWhere'. Each filter constructor specifies the field being--- filtered on, the type of comparison applied (equals, not equals, etc)--- and the argument for the comparison.-data Filter v = forall typ. PersistField typ => Filter-    { filterField  :: EntityField v typ-    , filterValue  :: Either typ [typ] -- FIXME-    , filterFilter :: PersistFilter -- FIXME-    }-    | FilterAnd [Filter v] -- ^ convenient for internal use, not needed for the API-    | FilterOr  [Filter v]-    | BackendFilter (BackendSpecificFilter (PersistEntityBackend v) v)---data SelectOpt v = forall typ. Asc (EntityField v typ)-                 | forall typ. Desc (EntityField v typ)-                 | OffsetBy Int-                 | LimitTo Int---- | Call 'selectSource' but return the result as a list.-selectList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m)-           => [Filter val]-           -> [SelectOpt val]-           -> m [Entity val]-selectList a b = selectSource a b C.$$ CL.consume---- | Call 'selectKeys' but return the result as a list.-selectKeysList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m)-               => [Filter val]-               -> [SelectOpt val]-               -> m [Key val]-selectKeysList a b = selectKeys a b C.$$ CL.consume--data PersistUpdate = Assign | Add | Subtract | Multiply | Divide -- FIXME need something else here-    deriving (Read, Show, Enum, Bounded)--data Update v = forall typ. PersistField typ => Update-    { updateField :: EntityField v typ-    , updateValue :: typ-    , updateUpdate :: PersistUpdate -- FIXME Replace with expr down the road-    }--limitOffsetOrder :: PersistEntity val => [SelectOpt val] -> (Int, Int, [SelectOpt val])-limitOffsetOrder opts =-    foldr go (0, 0, []) opts-  where-    go (LimitTo l) (_, b, c) = (l, b ,c)-    go (OffsetBy o) (a, _, c) = (a, o, c)-    go x (a, b, c) = (a, b, x : c)--updateFieldDef :: PersistEntity v => Update v -> FieldDef-updateFieldDef (Update f _ _) = persistFieldDef f--deleteCascadeWhere :: (DeleteCascade a m, PersistQuery m)-                   => [Filter a] -> m ()-deleteCascadeWhere filts = selectKeys filts [] C.$$ CL.mapM_ deleteCascade
− Database/Persist/Query/Join.hs 
@@ -1,66 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-module Database.Persist.Query.Join-    ( -- * Typeclass-      RunJoin (..)-      -- * One-to-many relation-    , SelectOneMany (..)-    , selectOneMany-    ) where--import Database.Persist.Store-import Database.Persist.Query.Internal-import Data.Maybe (mapMaybe)-import qualified Data.Map as Map-import Data.List (foldl')--class PersistQuery m => RunJoin a m where-    type Result a-    runJoin :: a -> m (Result a)--data SelectOneMany one many = SelectOneMany-    { somFilterOne :: [Filter one]-    , somOrderOne :: [SelectOpt one]-    , somFilterMany :: [Filter many]-    , somOrderMany :: [SelectOpt many]-    , somFilterKeys :: [Key one] -> Filter many-    , somGetKey :: many -> Key one-    , somIncludeNoMatch :: Bool-    }--selectOneMany :: ([Key one] -> Filter many) -> (many -> Key one) -> SelectOneMany one many-selectOneMany filts get' = SelectOneMany [] [] [] [] filts get' False--instance ( PersistEntity one-         , PersistEntity many-         , Ord (Key one)-         , PersistQuery monad-         , PersistMonadBackend monad ~ PersistEntityBackend one-         , PersistEntityBackend one ~ PersistEntityBackend many-         )-    => RunJoin (SelectOneMany one many) monad where-    type Result (SelectOneMany one many) =-        [((Entity one), [(Entity many)])]-    runJoin (SelectOneMany oneF oneO manyF manyO eq getKey isOuter) = do-        x <- selectList oneF oneO-        -- FIXME use select instead of selectList-        y <- selectList (eq (map entityKey x) : manyF) manyO-        let y' = foldl' go Map.empty y-        return $ mapMaybe (go' y') x-      where-        go m many@(Entity _ many') =-            Map.insert (getKey many')-            (case Map.lookup (getKey many') m of-                Nothing -> (:) many-                Just v -> v . (:) many-                ) m-        go' y' one@(Entity k _) =-            case Map.lookup k y' of-                Nothing ->-                    if isOuter-                        then Just (one, [])-                        else Nothing-                Just many -> Just (one, many [])
− Database/Persist/Query/Join/Sql.hs 
@@ -1,142 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE UndecidableInstances #-}-module Database.Persist.Query.Join.Sql-    ( RunJoin (..)-    ) where--import Database.Persist.Query.Join hiding (RunJoin (..))-import Database.Persist.EntityDef-import qualified Database.Persist.Query.Join as J-import Database.Persist.Store-import Database.Persist.Query.Internal-import Database.Persist.Query.GenericSql-import Control.Monad (liftM)-import Data.Maybe (mapMaybe)-import Data.List (groupBy)-import Database.Persist.GenericSql-import Database.Persist.GenericSql.Internal hiding (withStmt)-import Database.Persist.GenericSql.Raw (withStmt, MonadSqlPersist, askSqlConn)-import Data.Function (on)-import Control.Arrow ((&&&))-import Data.Text (Text, concat, null)-import Prelude hiding ((++), unlines, concat, show, null)-import Data.Monoid (Monoid, mappend)-import qualified Data.Text as T-import qualified Data.Conduit as C-import qualified Data.Conduit.List as CL-import Control.Monad.Logger (MonadLogger)--fromPersistValuesId :: PersistEntity v => [PersistValue] -> Either Text (Entity v)-fromPersistValuesId [] = Left "fromPersistValuesId: No values provided"-fromPersistValuesId (PersistInt64 i:rest) =-    case fromPersistValues rest of-        Left e -> Left e-        Right x -> Right (Entity (Key $ PersistInt64 i) x)-fromPersistValuesId _ = Left "fromPersistValuesId: invalid ID"--class RunJoin a where-    runJoin :: (C.MonadResource m, MonadLogger m, MonadSqlPersist m) => a -> m (J.Result a)--instance (PersistEntity one, PersistEntity many, Eq (Key one))-    => RunJoin (SelectOneMany one many) where-    runJoin (SelectOneMany oneF oneO manyF manyO eq _getKey isOuter) = do-        conn <- askSqlConn-        liftM go $ withStmt (sql conn) (getFiltsValues conn oneF ++ getFiltsValues conn manyF) C.$$ loop id-      where-        go :: [(Entity b, Maybe (Entity d))]-           -> [(Entity b, [Entity d])]-        go = map (fst . head &&& mapMaybe snd)-           . groupBy ((==) `on` (entityKey . fst))--        loop front = do-            x <- CL.head-            case x of-                Nothing -> return $ front []-                Just vals -> do-                    let (y, z) = splitAt oneCount vals-                    case (fromPersistValuesId y, fromPersistValuesId z) of-                        (Right y', Right z') -> loop (front . (:) (y', Just z'))-                        (Left e, _) -> error $ "selectOneMany: " ++ T.unpack e-                        (Right y', Left e) ->-                            case z of-                                PersistNull:_ -> loop (front . (:) (y', Nothing))-                                _ -> error $ "selectOneMany: " ++ T.unpack e-        oneCount = 1 + length (entityFields $ entityDef one)-        one = dummyFromFilts oneF-        many = dummyFromFilts manyF-        sql conn = concat-            [ "SELECT "-            , T.intercalate "," $ colsPlusId conn one ++ colsPlusId conn many-            , " FROM "-            , escapeName conn $ entityDB $ entityDef one-            , if isOuter then " LEFT JOIN " else " INNER JOIN "-            , escapeName conn $ entityDB $ entityDef many-            , " ON "-            , escapeName conn $ entityDB $ entityDef one-            , ".id = "-            , escapeName conn $ entityDB $ entityDef many-            , "."-            , escapeName conn $ filterName $ eq undefined-            , onFilts-            , whereFilts-            , case ords of-                [] -> ""-                _ -> " ORDER BY " ++ T.intercalate ", " ords-            ]-          where-            filts1 = filterClauseNoWhere True conn oneF-            filts2 = (if isOuter then filterClauseNoWhereOrNull else filterClauseNoWhere) True conn manyF--            whereFilts-                | isOuter =-                    if null filts1-                        then ""-                        else " WHERE " ++ filts1-                | null filts1 && null filts2 = ""-                | null filts1 = " WHERE " ++ filts2-                | null filts2 = " WHERE " ++ filts1-                | otherwise = " WHERE " ++ filts1 ++ " AND " ++ filts2--            onFilts-                | isOuter && not (null filts2) = " AND " ++ filts2-                | otherwise = ""--            orders :: PersistEntity val-                   => [SelectOpt val]-                   -> [SelectOpt val]-            orders x = let (_, _, y) = limitOffsetOrder x in y--            ords = map (orderClause True conn) (orders oneO) ++ map (orderClause True conn) (orders manyO)--addTable :: PersistEntity val-         => Connection-         -> val-         -> Text-         -> Text-addTable conn e s = concat-    [ escapeName conn $ entityDB $ entityDef e-    , "."-    , s-    ]--colsPlusId :: PersistEntity e => Connection -> e -> [Text]-colsPlusId conn e =-    map (addTable conn e) $-    id_ : (map (escapeName conn . fieldDB) cols)-  where-    id_ = escapeName conn $ entityID $ entityDef e-    cols = entityFields $ entityDef e--filterName :: PersistEntity v => Filter v -> DBName-filterName (Filter f _ _) = fieldDB $ persistFieldDef f-filterName (FilterAnd _) = error "expected a raw filter, not an And"-filterName (FilterOr _) = error "expected a raw filter, not an Or"-filterName (BackendFilter _) = error "expected a raw filter, not a BackendFilter"--infixr 5 ++-(++) :: Monoid m => m -> m -> m-(++) = mappend
+ Database/Persist/Sql.hs view
@@ -0,0 +1,49 @@+module Database.Persist.Sql+    ( module Database.Persist.Sql.Types+    , module Database.Persist.Sql.Class+    , module Database.Persist.Sql.Run+    , module Database.Persist.Sql.Migration+    , module Database.Persist+    , rawQuery+    , rawExecute+    , rawExecuteCount+    , rawSql+    , deleteWhereCount+    , updateWhereCount+    , transactionSave+    , transactionUndo+    , getStmtConn+      -- * Internal+    , module Database.Persist.Sql.Internal+    ) where++import Database.Persist+import Database.Persist.Sql.Types+import Database.Persist.Sql.Class+import Database.Persist.Sql.Run+import Database.Persist.Sql.Raw+import Database.Persist.Sql.Migration+import Database.Persist.Sql.Internal++import Database.Persist.Sql.Orphan.PersistQuery+import Database.Persist.Sql.Orphan.PersistStore ()+import Database.Persist.Sql.Orphan.PersistUnique ()+import Control.Monad.IO.Class++-- | Commit the current transaction and begin a new one.+--+-- Since 1.2.0+transactionSave :: MonadSqlPersist m => m ()+transactionSave = do+    conn <- askSqlConn+    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 = do+    conn <- askSqlConn+    let getter = getStmtConn conn+    liftIO $ connRollback conn getter >> connBegin conn getter
+ Database/Persist/Sql/Class.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+#ifndef NO_OVERLAP+{-# LANGUAGE OverlappingInstances #-}+#endif+module Database.Persist.Sql.Class+    ( MonadSqlPersist (..)+    , RawSql (..)+    , PersistFieldSql (..)+    ) where++import Control.Applicative ((<$>), (<*>))+import Database.Persist+import Data.Monoid ((<>))+import Database.Persist.Sql.Types+import Control.Arrow ((&&&))+import Data.Text (Text, intercalate, pack)+import Data.Maybe (fromMaybe)+import Data.Fixed++import Data.Monoid (Monoid)+import Control.Monad.Trans.Class (lift)++import Control.Monad.Logger (LoggingT)+import Control.Monad.Trans.Identity ( IdentityT)+import Control.Monad.Trans.List     ( ListT    )+import Control.Monad.Trans.Maybe    ( MaybeT   )+import Control.Monad.Trans.Error    ( ErrorT, Error)+import Control.Monad.Trans.Cont     ( ContT  )+import Control.Monad.Trans.State    ( StateT   )+import Control.Monad.Trans.Writer   ( WriterT  )+import Control.Monad.Trans.RWS      ( RWST     )+import 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.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)+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++-- | Class for data types that may be retrived from a 'rawSql'+-- query.+class RawSql a where+    -- | Number of columns that this data type needs and the list+    -- of substitutions for @SELECT@ placeholders @??@.+    rawSqlCols :: (DBName -> Text) -> a -> (Int, [Text])++    -- | A string telling the user why the column count is what+    -- it is.+    rawSqlColCountReason :: a -> String++    -- | Transform a row of the result into the data type.+    rawSqlProcessRow :: [PersistValue] -> Either Text a++instance PersistField a => RawSql (Single a) where+    rawSqlCols _ _         = (1, [])+    rawSqlColCountReason _ = "one column for a 'Single' data type"+    rawSqlProcessRow [pv]  = Single <$> fromPersistValue pv+    rawSqlProcessRow _     = Left $ pack "RawSql (Single a): wrong number of columns."++instance PersistEntity a => RawSql (Entity a) where+    rawSqlCols escape = ((+1) . length . entityFields &&& process) . entityDef . Just . entityVal+        where+          process ed = (:[]) $+                       intercalate ", " $+                       map ((name ed <>) . escape) $+                       (entityID ed:) $+                       map fieldDB $+                       entityFields ed+          name ed = escape (entityDB ed) <> "."++    rawSqlColCountReason a =+        case fst (rawSqlCols (error "RawSql") a) of+          1 -> "one column for an 'Entity' data type without fields"+          n -> show n ++ " columns for an 'Entity' data type"+    rawSqlProcessRow (idCol:ent) = Entity <$> fromPersistValue idCol+                                          <*> fromPersistValues ent+    rawSqlProcessRow _ = Left "RawSql (Entity a): wrong number of columns."++-- | Since 1.0.1.+instance RawSql a => RawSql (Maybe a) where+    rawSqlCols e = rawSqlCols e . extractMaybe+    rawSqlColCountReason = rawSqlColCountReason . extractMaybe+    rawSqlProcessRow cols+      | all isNull cols = return Nothing+      | otherwise       =+        case rawSqlProcessRow cols of+          Right v  -> Right (Just v)+          Left msg -> Left $ "RawSql (Maybe a): not all columns were Null " <>+                             "but the inner parser has failed.  Its message " <>+                             "was \"" <> msg <> "\".  Did you apply Maybe " <>+                             "to a tuple, perhaps?  The main use case for " <>+                             "Maybe is to allow OUTER JOINs to be written, " <>+                             "in which case 'Maybe (Entity v)' is used."+      where isNull PersistNull = True+            isNull _           = False++instance (RawSql a, RawSql b) => RawSql (a, b) where+    rawSqlCols e x = rawSqlCols e (fst x) # rawSqlCols e (snd x)+        where (cnta, lsta) # (cntb, lstb) = (cnta + cntb, lsta ++ lstb)+    rawSqlColCountReason x = rawSqlColCountReason (fst x) ++ ", " +++                             rawSqlColCountReason (snd x)+    rawSqlProcessRow =+        let x = getType processRow+            getType :: (z -> Either y x) -> x+            getType = error "RawSql.getType"++            colCountFst = fst $ rawSqlCols (error "RawSql.getType2") (fst x)+            processRow row =+                let (rowFst, rowSnd) = splitAt colCountFst row+                in (,) <$> rawSqlProcessRow rowFst+                       <*> rawSqlProcessRow rowSnd++        in colCountFst `seq` processRow+           -- Avoids recalculating 'colCountFst'.++instance (RawSql a, RawSql b, RawSql c) => RawSql (a, b, c) where+    rawSqlCols e         = rawSqlCols e         . from3+    rawSqlColCountReason = rawSqlColCountReason . from3+    rawSqlProcessRow     = fmap to3 . rawSqlProcessRow++from3 :: (a,b,c) -> ((a,b),c)+from3 (a,b,c) = ((a,b),c)++to3 :: ((a,b),c) -> (a,b,c)+to3 ((a,b),c) = (a,b,c)++instance (RawSql a, RawSql b, RawSql c, RawSql d) => RawSql (a, b, c, d) where+    rawSqlCols e         = rawSqlCols e         . from4+    rawSqlColCountReason = rawSqlColCountReason . from4+    rawSqlProcessRow     = fmap to4 . rawSqlProcessRow++from4 :: (a,b,c,d) -> ((a,b),(c,d))+from4 (a,b,c,d) = ((a,b),(c,d))++to4 :: ((a,b),(c,d)) -> (a,b,c,d)+to4 ((a,b),(c,d)) = (a,b,c,d)++instance (RawSql a, RawSql b, RawSql c,+          RawSql d, RawSql e)+       => RawSql (a, b, c, d, e) where+    rawSqlCols e         = rawSqlCols e         . from5+    rawSqlColCountReason = rawSqlColCountReason . from5+    rawSqlProcessRow     = fmap to5 . rawSqlProcessRow++from5 :: (a,b,c,d,e) -> ((a,b),(c,d),e)+from5 (a,b,c,d,e) = ((a,b),(c,d),e)++to5 :: ((a,b),(c,d),e) -> (a,b,c,d,e)+to5 ((a,b),(c,d),e) = (a,b,c,d,e)++instance (RawSql a, RawSql b, RawSql c,+          RawSql d, RawSql e, RawSql f)+       => RawSql (a, b, c, d, e, f) where+    rawSqlCols e         = rawSqlCols e         . from6+    rawSqlColCountReason = rawSqlColCountReason . from6+    rawSqlProcessRow     = fmap to6 . rawSqlProcessRow++from6 :: (a,b,c,d,e,f) -> ((a,b),(c,d),(e,f))+from6 (a,b,c,d,e,f) = ((a,b),(c,d),(e,f))++to6 :: ((a,b),(c,d),(e,f)) -> (a,b,c,d,e,f)+to6 ((a,b),(c,d),(e,f)) = (a,b,c,d,e,f)++instance (RawSql a, RawSql b, RawSql c,+          RawSql d, RawSql e, RawSql f,+          RawSql g)+       => RawSql (a, b, c, d, e, f, g) where+    rawSqlCols e         = rawSqlCols e         . from7+    rawSqlColCountReason = rawSqlColCountReason . from7+    rawSqlProcessRow     = fmap to7 . rawSqlProcessRow++from7 :: (a,b,c,d,e,f,g) -> ((a,b),(c,d),(e,f),g)+from7 (a,b,c,d,e,f,g) = ((a,b),(c,d),(e,f),g)++to7 :: ((a,b),(c,d),(e,f),g) -> (a,b,c,d,e,f,g)+to7 ((a,b),(c,d),(e,f),g) = (a,b,c,d,e,f,g)++instance (RawSql a, RawSql b, RawSql c,+          RawSql d, RawSql e, RawSql f,+          RawSql g, RawSql h)+       => RawSql (a, b, c, d, e, f, g, h) where+    rawSqlCols e         = rawSqlCols e         . from8+    rawSqlColCountReason = rawSqlColCountReason . from8+    rawSqlProcessRow     = fmap to8 . rawSqlProcessRow++from8 :: (a,b,c,d,e,f,g,h) -> ((a,b),(c,d),(e,f),(g,h))+from8 (a,b,c,d,e,f,g,h) = ((a,b),(c,d),(e,f),(g,h))++to8 :: ((a,b),(c,d),(e,f),(g,h)) -> (a,b,c,d,e,f,g,h)+to8 ((a,b),(c,d),(e,f),(g,h)) = (a,b,c,d,e,f,g,h)++extractMaybe :: Maybe a -> a+extractMaybe = fromMaybe (error "Database.Persist.GenericSql.extractMaybe")++class PersistField a => PersistFieldSql a where+    sqlType :: Monad m => m a -> SqlType++#ifndef NO_OVERLAP+instance PersistFieldSql String where+    sqlType _ = SqlString+#endif++instance PersistFieldSql ByteString where+    sqlType _ = SqlBlob+instance PersistFieldSql T.Text where+    sqlType _ = SqlString+instance PersistFieldSql TL.Text where+    sqlType _ = SqlString+instance PersistFieldSql Html where+    sqlType _ = SqlString+instance PersistFieldSql Int where+    sqlType _+        | bitSize (0 :: Int) <= 32 = SqlInt32+        | otherwise = SqlInt64+instance PersistFieldSql Int8 where+    sqlType _ = SqlInt32+instance PersistFieldSql Int16 where+    sqlType _ = SqlInt32+instance PersistFieldSql Int32 where+    sqlType _ = SqlInt32+instance PersistFieldSql Int64 where+    sqlType _ = SqlInt64+instance PersistFieldSql Word where+    sqlType _ = SqlInt64+instance PersistFieldSql Word8 where+    sqlType _ = SqlInt32+instance PersistFieldSql Word16 where+    sqlType _ = SqlInt32+instance PersistFieldSql Word32 where+    sqlType _ = SqlInt64+instance PersistFieldSql Word64 where+    sqlType _ = SqlInt64+instance PersistFieldSql Double where+    sqlType _ = SqlReal+instance PersistFieldSql Bool where+    sqlType _ = SqlBool+instance PersistFieldSql Day where+    sqlType _ = SqlDay+instance PersistFieldSql TimeOfDay where+    sqlType _ = SqlTime+instance PersistFieldSql UTCTime where+    sqlType _ = SqlDayTime+instance PersistFieldSql ZonedTime where+    sqlType _ = SqlDayTimeZoned+instance PersistFieldSql a => PersistFieldSql [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+    sqlType _ = SqlString+instance PersistFieldSql v => PersistFieldSql (M.Map T.Text v) where+    sqlType _ = SqlString+instance PersistFieldSql PersistValue where+    sqlType _ = SqlInt64 -- since PersistValue should only be used like this for keys, which in SQL are Int64+instance PersistFieldSql Checkmark where+    sqlType    _ = SqlBool+instance (HasResolution a) => PersistFieldSql (Fixed a) where+    sqlType a =+        SqlNumeric long prec+      where+        prec = round $ (log $ fromIntegral $ resolution n) / (log 10) --  FIXME: May lead to problems with big numbers+        long = prec + 10                                              --  FIXME: Is this enough ?+        n = 0+        mn = return n `asTypeOf` a+instance PersistFieldSql Rational where+    sqlType a = SqlNumeric 22 12   --  FIXME: Ambigous, 12 is from Pico which is used to convert Rational to number string
+ Database/Persist/Sql/Internal.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+-- | Intended for creating new backends.+module Database.Persist.Sql.Internal+    ( mkColumns+    ) where++import Database.Persist.Types+import Database.Persist.Class+import Database.Persist.Quasi+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 Database.Persist.Sql.Types+import Database.Persist.Sql.Class++-- | Create the list of columns for the given entity.+mkColumns :: [EntityDef a] -> EntityDef SqlType -> ([Column], [UniqueDef])+mkColumns allDefs t =+    (cols, entityUniques t)+  where+    cols :: [Column]+    cols = map go (entityFields t)++    tn :: DBName+    tn = entityDB t++    go :: FieldDef SqlType -> Column+    go fd =+        Column+            (fieldDB fd)+            (nullable (fieldAttrs fd) /= NotNullable || entitySum t)+            (maybe+                (fieldSqlType fd)+                SqlOther+                (listToMaybe $ mapMaybe (T.stripPrefix "sqltype=") $ fieldAttrs fd))+            (def $ fieldAttrs fd)+            (maxLen $ fieldAttrs fd)+            (ref (fieldDB fd) (fieldType fd) (fieldAttrs fd))++    def :: [Attr] -> Maybe Text+    def [] = Nothing+    def (a:as)+        | Just d <- T.stripPrefix "default=" a = Just d+        | otherwise = def as++    maxLen :: [Attr] -> Maybe Integer+    maxLen [] = Nothing+    maxLen (a:as)+        | Just d <- T.stripPrefix "maxlen=" a =+            case reads (T.unpack d) of+              [(i, s)] | all isSpace s -> Just i+              _ -> error $ "Could not parse maxlen field with value " +++                           show d ++ " on " ++ show tn+        | otherwise = maxLen as++    ref :: DBName+        -> FieldType+        -> [Attr]+        -> Maybe (DBName, DBName) -- table name, constraint name+    ref c ft []+        | Just f <- stripId ft =+            Just (resolveTableName allDefs $ HaskellName f, refName tn c)+        | otherwise = Nothing+    ref _ _ ("noreference":_) = Nothing+    ref c _ (a:_)+        | Just x <- T.stripPrefix "reference=" a =+            Just (DBName x, refName tn c)+    ref c x (_:as) = ref c x as++refName :: DBName -> DBName -> DBName+refName (DBName table) (DBName column) =+    DBName $ mconcat [table, "_", column, "_fkey"]++resolveTableName :: [EntityDef a] -> 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
+ Database/Persist/Sql/Migration.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+module Database.Persist.Sql.Migration+  ( parseMigration+  , parseMigration'+  , printMigration+  , getMigration+  , runMigration+  , runMigrationSilent+  , runMigrationUnsafe+  , migrate+  ) where+++import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Trans.Class (MonadTrans (..))+import Control.Monad.IO.Class+import Control.Monad.Trans.Writer+import Control.Monad (liftM, unless)+import Data.Text (Text, unpack, snoc, isPrefixOf, pack)+import qualified Data.Text.IO+import System.IO+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.Class+import Database.Persist.Types++allSql :: CautiousMigration -> [Sql]+allSql = map snd+unsafeSql :: CautiousMigration -> [Sql]+unsafeSql = allSql . filter fst+safeSql :: CautiousMigration -> [Sql]+safeSql = allSql . filter (not . fst)++parseMigration :: Monad m => Migration m -> m (Either [Text] CautiousMigration)+parseMigration =+    liftM go . runWriterT . execWriterT+  where+    go ([], sql) = Right sql+    go (errs, _) = Left errs++-- like parseMigration, but call error or return the CautiousMigration+parseMigration' :: Monad m => Migration m -> 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 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 m = do+  mig <- parseMigration' m+  return $ allSql mig++runMigration :: MonadSqlPersist m+             => Migration m+             -> 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 m = liftBaseOp_ (hSilence [stderr]) $ runMigration' m True++runMigration'+    :: MonadSqlPersist m+    => Migration m+    -> Bool -- ^ is silent?+    -> m [Text]+runMigration' m silent = do+    mig <- parseMigration' m+    case unsafeSql mig of+        []   -> mapM (executeMigrate silent) $ sortMigrations $ safeSql mig+        errs -> error $ concat+            [ "\n\nDatabase migration: manual intervention required.\n"+            , "The following actions are considered unsafe:\n\n"+            , unlines $ map (\s -> "    " ++ unpack s ++ ";") $ errs+            ]++runMigrationUnsafe :: MonadSqlPersist m+                   => Migration m+                   -> m ()+runMigrationUnsafe m = do+    mig <- parseMigration' m+    mapM_ (executeMigrate False) $ sortMigrations $ allSql mig++executeMigrate :: MonadSqlPersist m => Bool -> Text -> m Text+executeMigrate silent s = do+    unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ unpack s+    rawExecute s []+    return s++-- | Sort the alter DB statements so tables are created before constraints are+-- added.+sortMigrations :: [Sql] -> [Sql]+sortMigrations x =+    filter isCreate x ++ filter (not . isCreate) x+  where+    -- Note the use of lower-case e. This (hack) allows backends to explicitly+    -- choose to have this special sorting applied.+    isCreate t = pack "CREATe " `isPrefixOf` t++migrate :: MonadSqlPersist m+        => [EntityDef SqlType]+        -> EntityDef SqlType+        -> Migration m+migrate allDefs val = do+    conn <- askSqlConn+    res <- liftIO $ connMigrateSql conn allDefs (getStmtConn conn) val+    either tell (lift . tell) res
+ Database/Persist/Sql/Orphan/PersistQuery.hs view
@@ -0,0 +1,360 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Database.Persist.Sql.Orphan.PersistQuery+    ( deleteWhereCount+    , updateWhereCount+    ) where++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 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.Exception (throwIO)+import qualified Data.Conduit.List as CL+import Data.Conduit++-- 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 sql = T.concat+                [ "UPDATE "+                , connEscapeName conn $ entityDB t+                , " SET "+                , T.intercalate "," $ map (go' . go) upds+                , " WHERE "+                , connEscapeName conn $ entityID t+                , "=?"+                ]+        rawExecute sql $+            map updatePersistValue upds `mappend` [unKey k]+      where+        t = entityDef $ dummyFromKey k+        go x = (fieldDB $ updateFieldDef x, updateUpdate x)++    count filts = do+        conn <- askSqlConn+        let wher = if null filts+                    then ""+                    else filterClause False conn filts+        let sql = mconcat+                [ "SELECT COUNT(*) FROM "+                , connEscapeName conn $ entityDB t+                , wher+                ]+        rawQuery sql (getFiltsValues conn filts) $$ do+            Just [PersistInt64 i] <- CL.head+            return $ fromIntegral i+      where+        t = entityDef $ dummyFromFilts filts++    selectSource filts opts = do+        conn <- lift askSqlConn+        rawQuery (sql conn) (getFiltsValues conn filts) $= CL.mapM parse+      where+        (limit, offset, orders) = limitOffsetOrder opts++        parse vals =+            case fromPersistValues' vals of+                Left s -> liftIO $ throwIO $ PersistMarshalError s+                Right row -> return row++        t = entityDef $ dummyFromFilts filts+        fromPersistValues' (PersistInt64 x:xs) = do+            case fromPersistValues xs of+                Left e -> Left e+                Right xs' -> Right (Entity (Key $ PersistInt64 x) xs')+        fromPersistValues' _ = Left "error in fromPersistValues'"+        wher conn = if null filts+                    then ""+                    else filterClause False conn filts+        ord conn =+            case map (orderClause False conn) orders of+                [] -> ""+                ords -> " ORDER BY " <> T.intercalate "," ords+        lim conn = case (limit, offset) of+                (0, 0) -> ""+                (0, _) -> T.cons ' ' $ connNoLimit conn+                (_, _) -> " LIMIT " <> T.pack (show limit)+        off = if offset == 0+                    then ""+                    else " OFFSET " <> T.pack (show offset)+        cols conn = T.intercalate ","+                  $ (connEscapeName conn $ entityID t)+                  : map (connEscapeName conn . fieldDB) (entityFields t)+        sql conn = mconcat+            [ "SELECT "+            , cols conn+            , " FROM "+            , connEscapeName conn $ entityDB t+            , wher conn+            , ord conn+            , lim conn+            , off+            ]++    selectKeys filts opts = do+        conn <- lift askSqlConn+        rawQuery (sql conn) (getFiltsValues conn filts) $= CL.mapM parse+      where+        parse [PersistInt64 i] = return $ Key $ PersistInt64 i+        parse y = liftIO $ throwIO $ PersistMarshalError $ "Unexpected in selectKeys: " <> T.pack (show y)+        t = entityDef $ dummyFromFilts filts+        wher conn = if null filts+                    then ""+                    else filterClause False conn filts+        sql conn = mconcat+            [ "SELECT "+            , connEscapeName conn $ entityID t+            , " FROM "+            , connEscapeName conn $ entityDB t+            , wher conn+            , ord conn+            , lim conn+            , off+            ]++        (limit, offset, orders) = limitOffsetOrder opts++        ord conn =+            case map (orderClause False conn) orders of+                [] -> ""+                ords -> " ORDER BY " <> T.intercalate "," ords+        lim conn = case (limit, offset) of+                (0, 0) -> ""+                (0, _) -> T.cons ' ' $ connNoLimit conn+                (_, _) -> " LIMIT " <> T.pack (show limit)+        off = if offset == 0+                    then ""+                    else " OFFSET " <> T.pack (show offset)++    deleteWhere filts = do+        _ <- deleteWhereCount filts+        return ()++    updateWhere filts upds = do+        _ <- updateWhereCount filts upds+        return ()++-- | Same as 'deleteWhere', but returns the number of rows affected.+--+-- Since 1.1.5+deleteWhereCount :: (PersistEntity val, MonadSqlPersist m)+                 => [Filter val]+                 -> m Int64+deleteWhereCount filts = do+    conn <- askSqlConn+    let t = entityDef $ dummyFromFilts filts+    let wher = if null filts+                then ""+                else filterClause False conn filts+        sql = mconcat+            [ "DELETE FROM "+            , connEscapeName conn $ entityDB t+            , wher+            ]+    rawExecuteCount sql $ getFiltsValues conn filts++-- | Same as 'updateWhere', but returns the number of rows affected.+--+-- Since 1.1.5+updateWhereCount :: (PersistEntity val, MonadSqlPersist m)+                 => [Filter val]+                 -> [Update val]+                 -> m Int64+updateWhereCount _ [] = return 0+updateWhereCount filts upds = do+    conn <- askSqlConn+    let wher = if null filts+                then ""+                else filterClause False conn filts+    let sql = mconcat+            [ "UPDATE "+            , connEscapeName conn $ entityDB t+            , " SET "+            , T.intercalate "," $ map (go' conn . go) upds+            , wher+            ]+    let dat = map updatePersistValue upds `mappend`+              getFiltsValues conn filts+    rawExecuteCount sql dat+  where+    t = entityDef $ dummyFromFilts filts+    go'' n Assign = n <> "=?"+    go'' n Add = mconcat [n, "=", n, "+?"]+    go'' n Subtract = mconcat [n, "=", n, "-?"]+    go'' n Multiply = mconcat [n, "=", n, "*?"]+    go'' n Divide = mconcat [n, "=", n, "/?"]+    go' conn (x, pu) = go'' (connEscapeName conn x) pu+    go x = (fieldDB $ updateFieldDef x, updateUpdate x)++updateFieldDef :: PersistEntity v => Update v -> FieldDef SqlType+updateFieldDef (Update f _ _) = persistFieldDef f++dummyFromFilts :: [Filter v] -> Maybe v+dummyFromFilts _ = Nothing++getFiltsValues :: forall val.  PersistEntity val => Connection -> [Filter val] -> [PersistValue]+getFiltsValues conn = snd . filterClauseHelper False False conn OrNullNo++data OrNull = OrNullYes | OrNullNo++filterClauseHelper :: PersistEntity val+             => Bool -- ^ include table name?+             -> Bool -- ^ include WHERE?+             -> Connection+             -> OrNull+             -> [Filter val]+             -> (Text, [PersistValue])+filterClauseHelper includeTable includeWhere conn orNull filters =+    (if not (T.null sql) && includeWhere+        then " WHERE " <> sql+        else sql, vals)+  where+    (sql, vals) = combineAND filters+    combineAND = combine " AND "++    combine s fs =+        (T.intercalate s $ map wrapP a, mconcat b)+      where+        (a, b) = unzip $ map go fs+        wrapP x = T.concat ["(", x, ")"]++    go (BackendFilter _) = error "BackendFilter not expected"+    go (FilterAnd []) = ("1=1", [])+    go (FilterAnd fs) = combineAND fs+    go (FilterOr []) = ("1=0", [])+    go (FilterOr fs)  = combine " OR " fs+    go (Filter field value pfilter) =+        case (isNull, pfilter, varCount) of+            (True, Eq, _) -> (name <> " IS NULL", [])+            (True, Ne, _) -> (name <> " IS NOT NULL", [])+            (False, Ne, _) -> (T.concat+                [ "("+                , name+                , " IS NULL OR "+                , name+                , " <> "+                , qmarks+                , ")"+                ], notNullVals)+            -- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since+            -- not all databases support those words directly.+            (_, In, 0) -> ("1=2" <> orNullSuffix, [])+            (False, In, _) -> (name <> " IN " <> qmarks <> orNullSuffix, allVals)+            (True, In, _) -> (T.concat+                [ "("+                , name+                , " IS NULL OR "+                , name+                , " IN "+                , qmarks+                , ")"+                ], notNullVals)+            (_, NotIn, 0) -> ("1=1", [])+            (False, NotIn, _) -> (T.concat+                [ "("+                , name+                , " IS NULL OR "+                , name+                , " NOT IN "+                , qmarks+                , ")"+                ], notNullVals)+            (True, NotIn, _) -> (T.concat+                [ "("+                , name+                , " IS NOT NULL AND "+                , name+                , " NOT IN "+                , qmarks+                , ")"+                ], notNullVals)+            _ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals)+      where+        filterValueToPersistValues :: forall a.  PersistField a => Either a [a] -> [PersistValue]+        filterValueToPersistValues v = map toPersistValue $ either return id v++        orNullSuffix =+            case orNull of+                OrNullYes -> mconcat [" OR ", name, " IS NULL"]+                OrNullNo -> ""++        isNull = any (== PersistNull) allVals+        notNullVals = filter (/= PersistNull) allVals+        allVals = filterValueToPersistValues value+        tn = connEscapeName conn $ entityDB+           $ entityDef $ dummyFromFilts [Filter field value pfilter]+        name =+            (if includeTable+                then ((tn <> ".") <>)+                else id)+            $ connEscapeName conn $ fieldDB $ persistFieldDef field+        qmarks = case value of+                    Left _ -> "?"+                    Right x ->+                        let x' = filter (/= PersistNull) $ map toPersistValue x+                         in "(" <> T.intercalate "," (map (const "?") x') <> ")"+        varCount = case value of+                    Left _ -> 1+                    Right x -> length x+        showSqlFilter Eq = "="+        showSqlFilter Ne = "<>"+        showSqlFilter Gt = ">"+        showSqlFilter Lt = "<"+        showSqlFilter Ge = ">="+        showSqlFilter Le = "<="+        showSqlFilter In = " IN "+        showSqlFilter NotIn = " NOT IN "+        showSqlFilter (BackendSpecificFilter s) = s++updatePersistValue :: Update v -> PersistValue+updatePersistValue (Update _ v _) = toPersistValue v++filterClause :: PersistEntity val+             => Bool -- ^ include table name?+             -> Connection+             -> [Filter val]+             -> Text+filterClause b c = fst . filterClauseHelper b True c OrNullNo++orderClause :: PersistEntity val+            => Bool -- ^ include the table name+            -> Connection+            -> SelectOpt val+            -> Text+orderClause includeTable conn o =+    case o of+        Asc  x -> name $ persistFieldDef x+        Desc x -> name (persistFieldDef x) <> " DESC"+        _ -> error $ "orderClause: expected Asc or Desc, not limit or offset"+  where+    dummyFromOrder :: SelectOpt a -> Maybe a+    dummyFromOrder _ = Nothing++    tn = connEscapeName conn $ entityDB $ entityDef $ dummyFromOrder o++    name x =+        (if includeTable+            then ((tn <> ".") <>)+            else id)+        $ connEscapeName conn $ fieldDB x++dummyFromKey :: KeyBackend SqlBackend v -> Maybe v+dummyFromKey _ = Nothing
+ Database/Persist/Sql/Orphan/PersistStore.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Database.Persist.Sql.Orphan.PersistStore () where++import Database.Persist+import Database.Persist.Sql.Types+import Database.Persist.Sql.Class+import Database.Persist.Sql.Raw+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.Monoid (mappend)+import Control.Monad.IO.Class++instance (C.MonadResource m, MonadLogger m) => PersistStore (SqlPersistT m) where+    type PersistMonadBackend (SqlPersistT m) = SqlBackend+    insert val = do+        conn <- askSqlConn+        let esql = connInsertSql conn (entityDB t) (map fieldDB $ entityFields t) (entityID t)+        i <-+            case esql of+                ISRSingle sql -> rawQuery sql vals C.$$ do+                    x <- CL.head+                    case x of+                        Just [PersistInt64 i] -> return i+                        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'+                ISRInsertGet sql1 sql2 -> do+                    rawExecute sql1 vals+                    rawQuery sql2 [] C.$$ do+                        Just [PersistInt64 i] <- CL.head+                        return i+        return $ Key $ PersistInt64 i+      where+        t = entityDef $ Just val+        vals = map toPersistValue $ toPersistFields val++    replace k val = do+        conn <- askSqlConn+        let t = entityDef $ Just val+        let sql = T.concat+                [ "UPDATE "+                , connEscapeName conn (entityDB t)+                , " SET "+                , T.intercalate "," (map (go conn . fieldDB) $ entityFields t)+                , " WHERE "+                , connEscapeName conn $ entityID t+                , "=?"+                ]+            vals = map toPersistValue (toPersistFields val) `mappend` [unKey k]+        rawExecute sql vals+      where+        go conn x = connEscapeName conn x `T.append` "=?"++    insertKey = insrepHelper "INSERT"++    repsert key value = do+        -- FIXME use this for sqlite insrepHelper "REPLACE"+        delete key+        insertKey key value++    get k = do+        conn <- askSqlConn+        let t = entityDef $ dummyFromKey k+        let cols = T.intercalate ","+                 $ map (connEscapeName conn . fieldDB) $ entityFields t+        let sql = T.concat+                [ "SELECT "+                , cols+                , " FROM "+                , connEscapeName conn $ entityDB t+                , " WHERE "+                , connEscapeName conn $ entityID t+                , "=?"+                ]+            vals' = [unKey k]+        rawQuery sql vals' C.$$ do+            res <- CL.head+            case res of+                Nothing -> return Nothing+                Just vals ->+                    case fromPersistValues vals of+                        Left e -> error $ "get " ++ show (unKey k) ++ ": " ++ unpack e+                        Right v -> return $ Just v++    delete k = do+        conn <- askSqlConn+        rawExecute (sql conn) [unKey k]+      where+        t = entityDef $ dummyFromKey k+        sql conn = T.concat+            [ "DELETE FROM "+            , connEscapeName conn $ entityDB t+            , " WHERE "+            , connEscapeName conn $ entityID t+            , "=?"+            ]++dummyFromKey :: KeyBackend SqlBackend v -> Maybe v+dummyFromKey _ = Nothing++insrepHelper :: (MonadIO m, PersistEntity val, MonadLogger m, MonadSqlPersist m)+             => Text+             -> Key val+             -> val+             -> m ()+insrepHelper command (Key k) val = do+    conn <- askSqlConn+    rawExecute (sql conn) vals+  where+    t = entityDef $ Just val+    sql conn = T.concat+        [ command+        , " INTO "+        , connEscapeName conn (entityDB t)+        , "("+        , T.intercalate ","+            $ map (connEscapeName conn)+            $ entityID t : map fieldDB (entityFields t)+        , ") VALUES("+        , T.intercalate "," ("?" : map (const "?") (entityFields t))+        , ")"+        ]+    vals = k : map toPersistValue (toPersistFields val)
+ Database/Persist/Sql/Orphan/PersistUnique.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Database.Persist.Sql.Orphan.PersistUnique () where++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 qualified Data.Text as T+import Data.Monoid ((<>))+import Control.Monad.Logger+import qualified Data.Conduit.List as CL+import Data.Conduit++instance (MonadResource m, MonadLogger m) => PersistUnique (SqlPersistT m) where+    deleteBy uniq = do+        conn <- askSqlConn+        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 <> "=?"+        sql conn = T.concat+            [ "DELETE FROM "+            , connEscapeName conn $ entityDB t+            , " WHERE "+            , T.intercalate " AND " $ map (go' conn) $ go uniq+            ]++    getBy uniq = do+        conn <- askSqlConn+        let cols = T.intercalate "," $ (connEscapeName conn $ entityID t)+                 : map (connEscapeName conn . fieldDB) (entityFields t)+        let sql = T.concat+                [ "SELECT "+                , cols+                , " FROM "+                , connEscapeName conn $ entityDB t+                , " WHERE "+                , sqlClause conn+                ]+            vals' = persistUniqueToValues uniq+        rawQuery 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 _ -> error "Database.Persist.GenericSql: Bad list in getBy"+      where+        sqlClause conn =+            T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq+        go conn x = connEscapeName conn x <> "=?"+        t = entityDef $ dummyFromUnique uniq+        toFieldNames' = map snd . persistUniqueToFieldNames++dummyFromUnique :: Unique v -> Maybe v+dummyFromUnique _ = Nothing
+ Database/Persist/Sql/Raw.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+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 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 Data.Int (Int64)+import Control.Monad.Trans.Class (lift)+import qualified Data.Text as T+import Data.Conduit++rawQuery :: (MonadSqlPersist m, MonadResource m)+         => 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)++rawExecute :: MonadSqlPersist m => Text -> [PersistValue] -> m ()+rawExecute x y = liftM (const ()) $ rawExecuteCount x y++rawExecuteCount :: MonadSqlPersist m => Text -> [PersistValue] -> m Int64+rawExecuteCount sql vals = do+    $logDebugS (pack "SQL") $ pack $ show sql ++ " " ++ show vals+    stmt <- getStmt sql+    res <- liftIO $ stmtExecute stmt vals+    liftIO $ stmtReset stmt+    return res++getStmt :: MonadSqlPersist m => Text -> m Statement+getStmt sql = do+    conn <- askSqlConn+    liftIO $ getStmtConn conn sql++getStmtConn :: Connection -> Text -> IO Statement+getStmtConn conn sql = do+    smap <- liftIO $ readIORef $ connStmtMap conn+    case Map.lookup sql smap of+        Just stmt -> return stmt+        Nothing -> do+            stmt' <- liftIO $ connPrepare conn sql+            iactive <- liftIO $ newIORef True+            let stmt = Statement+                    { stmtFinalize = do+                        active <- readIORef iactive+                        if active+                            then do+                                stmtFinalize stmt'+                                writeIORef iactive False+                            else return ()+                    , stmtReset = do+                        active <- readIORef iactive+                        when active $ stmtReset stmt'+                    , stmtExecute = \x -> do+                        active <- readIORef iactive+                        if active+                            then stmtExecute stmt' x+                            else throwIO $ StatementAlreadyFinalized sql+                    , stmtQuery = \x -> do+                        active <- liftIO $ readIORef iactive+                        if active+                            then stmtQuery stmt' x+                            else liftIO $ throwIO $ StatementAlreadyFinalized sql+                    }+            liftIO $ writeIORef (connStmtMap conn) $ Map.insert sql stmt smap+            return stmt++-- | Execute a raw SQL statement and return its results as a+-- list.+--+-- If you're using 'Entity'@s@ (which is quite likely), then you+-- /must/ use entity selection placeholders (double question+-- mark, @??@).  These @??@ placeholders are then replaced for+-- the names of the columns that we need for your entities.+-- You'll receive an error if you don't use the placeholders.+-- Please see the 'Entity'@s@ documentation for more details.+--+-- You may put value placeholders (question marks, @?@) in your+-- SQL query.  These placeholders are then replaced by the values+-- you pass on the second parameter, already correctly escaped.+-- You may want to use 'toPersistValue' to help you constructing+-- the placeholder values.+--+-- Since you're giving a raw SQL statement, you don't get any+-- guarantees regarding safety.  If 'rawSql' is not able to parse+-- the results of your query back, then an exception is raised.+-- 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)+       => Text             -- ^ SQL statement, possibly with placeholders.+       -> [PersistValue]   -- ^ Values to fill the placeholders.+       -> m [a]+rawSql stmt = run+    where+      getType :: (x -> m [a]) -> a+      getType = error "rawSql.getType"++      x = getType run+      process = rawSqlProcessRow++      withStmt' colSubsts params = do+            rawQuery sql params+          where+            sql = T.concat $ makeSubsts colSubsts $ T.splitOn placeholder stmt+            placeholder = "??"+            makeSubsts (s:ss) (t:ts) = t : s : makeSubsts ss ts+            makeSubsts []     []     = []+            makeSubsts []     ts     = [T.intercalate placeholder ts]+            makeSubsts ss     []     = error (concat err)+                where+                  err = [ "rawsql: there are still ", show (length ss)+                        , "'??' placeholder substitutions to be made "+                        , "but all '??' placeholders have already been "+                        , "consumed.  Please read 'rawSql's documentation "+                        , "on how '??' placeholders work."+                        ]++      run params = do+        conn <- askSqlConn+        let (colCount, colSubsts) = rawSqlCols (connEscapeName conn) x+        withStmt' colSubsts params $$ firstRow colCount++      firstRow colCount = do+        mrow <- await+        case mrow of+          Nothing -> return []+          Just row+              | colCount == length row -> getter mrow+              | otherwise              -> fail $ concat+                  [ "rawSql: wrong number of columns, got "+                  , show (length row), " but expected ", show colCount+                  , " (", rawSqlColCountReason x, ")." ]++      getter = go id+          where+            go acc Nothing = return (acc [])+            go acc (Just row) =+              case process row of+                Left err -> fail (T.unpack err)+                Right r  -> await >>= go (acc . (r:))
+ Database/Persist/Sql/Run.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleContexts #-}+module Database.Persist.Sql.Run where++import Database.Persist.Sql.Types+import Database.Persist.Sql.Raw+import Data.Conduit.Pool+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Resource+import Control.Monad.Logger+import Control.Monad.Base+import Control.Exception.Lifted (onException)+import Control.Monad.IO.Class+import Control.Exception.Lifted (bracket)+import Data.IORef (readIORef)+import qualified Data.Map as Map+import Control.Exception.Lifted (throwIO)++-- | Get a connection from the pool, run the given action, and then return the+-- connection to the pool.+runSqlPool :: MonadBaseControl IO m => SqlPersistT m a -> Pool Connection -> m a+runSqlPool r pconn = do+    mres <- withResourceTimeout 2000000 pconn $ runSqlConn r+    maybe (throwIO Couldn'tGetSQLConnection) return mres++runSqlConn :: MonadBaseControl IO m => SqlPersistT m a -> Connection -> m a+runSqlConn (SqlPersistT r) conn = do+    let getter = getStmtConn conn+    liftBase $ connBegin conn getter+    x <- onException+            (runReaderT r conn)+            (liftBase $ connRollback conn getter)+    liftBase $ connCommit conn getter+    return x++runSqlPersistM :: SqlPersistM a -> Connection -> IO a+runSqlPersistM x conn = runResourceT $ runNoLoggingT $ runReaderT (unSqlPersistT x) conn++runSqlPersistMPool :: SqlPersistM a -> Pool Connection -> IO a+runSqlPersistMPool x pool = runResourceT $ runNoLoggingT $ runSqlPool x pool++withSqlPool :: MonadIO m+            => IO Connection -- ^ create a new connection+            -> Int -- ^ connection count+            -> (Pool Connection -> m a)+            -> m a+withSqlPool mkConn connCount f = do+    pool <- createSqlPool mkConn connCount+    f pool++createSqlPool :: MonadIO m+              => IO Connection+              -> Int+              -> m (Pool Connection)+createSqlPool mkConn = liftIO . createPool mkConn close' 1 20++withSqlConn :: (MonadIO m, MonadBaseControl IO m)+            => IO Connection -> (Connection -> m a) -> m a+withSqlConn open = bracket (liftIO open) (liftIO . close')++close' :: Connection -> IO ()+close' conn = do+    readIORef (connStmtMap conn) >>= mapM_ stmtFinalize . Map.elems+    connClose conn
+ Database/Persist/Sql/Types.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Database.Persist.Sql.Types where++import Control.Exception (Exception)+import Control.Monad.Trans.Resource (MonadResource (..), MonadThrow (..), ResourceT)+import Control.Monad.Logger (MonadLogger (..), 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 Data.IORef (IORef)+import Data.Map (Map)+import Data.Int (Int64)+import Data.Conduit (Source)+import Data.Conduit.Pool (Pool)+import Web.PathPieces+import Control.Exception (throw)+import qualified Data.Text.Read++data InsertSqlResult = ISRSingle Text+                     | ISRInsertGet Text Text++data Connection = Connection+    { connPrepare :: Text -> IO Statement+    -- | table name, column names, id name, either 1 or 2 statements to run+    , connInsertSql :: DBName -> [DBName] -> DBName -> InsertSqlResult+    , connStmtMap :: IORef (Map Text Statement)+    , connClose :: IO ()+    , connMigrateSql+        :: [EntityDef SqlType]+        -> (Text -> IO Statement)+        -> EntityDef SqlType+        -> IO (Either [Text] [(Bool, Text)])+    , connBegin :: (Text -> IO Statement) -> IO ()+    , connCommit :: (Text -> IO Statement) -> IO ()+    , connRollback :: (Text -> IO Statement) -> IO ()+    , connEscapeName :: DBName -> Text+    , connNoLimit :: Text+    , connRDBMS :: Text+    }++data Statement = Statement+    { stmtFinalize :: IO ()+    , stmtReset :: IO ()+    , stmtExecute :: [PersistValue] -> IO Int64+    , stmtQuery :: forall m. MonadResource m+                => [PersistValue]+                -> Source m [PersistValue]+    }++data Column = Column+    { cName      :: !DBName+    , cNull      :: !Bool+    , cSqlType   :: !SqlType+    , cDefault   :: !(Maybe Text)+    , cMaxLen    :: !(Maybe Integer)+    , cReference :: !(Maybe (DBName, DBName)) -- table name, constraint name+    }+    deriving (Eq, Ord, Show)++data PersistentSqlException = StatementAlreadyFinalized Text+                            | Couldn'tGetSQLConnection+    deriving (Typeable, Show)+instance Exception PersistentSqlException++data SqlBackend++newtype SqlPersistT m a = SqlPersistT { unSqlPersistT :: ReaderT Connection m a }+    deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadPlus)++type SqlPersist = SqlPersistT+{-# DEPRECATED SqlPersist "Please use SqlPersistT instead" #-}++type SqlPersistM = SqlPersistT (NoLoggingT (ResourceT IO))++instance MonadThrow m => MonadThrow (SqlPersistT m) where+    monadThrow = lift . monadThrow++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 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+--+-- Although it covers most of the useful cases, @persistent@'s+-- API may not be enough for some of your tasks.  May be you need+-- some complex @JOIN@ query, or a database-specific command+-- needs to be issued.+--+-- To issue raw SQL queries you could use 'R.withStmt', which+-- allows you to do anything you need.  However, its API is+-- /low-level/ and you need to parse each row yourself.  However,+-- most of your complex queries will have simple results -- some+-- of your entities and maybe a couple of derived columns.+--+-- This is where 'rawSql' comes in.  Like 'R.withStmt', you may+-- issue /any/ SQL query.  However, it does all the hard work for+-- you and automatically parses the rows of the result.  It may+-- return:+--+--   * An 'Entity', that which 'selectList' returns.+--     All of your entity's fields are+--     automatically parsed.+--+--   * A @'Single' a@, which is a single, raw column of type @a@.+--     You may use a Haskell type (such as in your entity+--     definitions), for example @Single Text@ or @Single Int@,+--     or you may get the raw column value with @Single+--     'PersistValue'@.+--+--   * A tuple combining any of these (including other tuples).+--     Using tuples allows you to return many entities in one+--     query.+--+-- The only difference between issuing SQL queries with 'rawSql'+-- and using other means is that we have an /entity selection/+-- /placeholder/, the double question mark @??@.  It /must/ be+-- used whenever you want to @SELECT@ an 'Entity' from your+-- query.  Here's a sample SQL query @sampleStmt@ that may be+-- issued:+--+-- @+-- SELECT ??, ??+-- FROM \"Person\", \"Likes\", \"Object\"+-- WHERE \"Person\".id = \"Likes\".\"personId\"+-- AND \"Object\".id = \"Likes\".\"objectId\"+-- AND \"Person\".name LIKE ?+-- @+--+-- To use that query, you could say+--+-- @+-- do results <- 'rawSql' sampleStmt [\"%Luke%\"]+--    forM_ results $+--      \\( Entity personKey person+--       , Entity objectKey object+--       ) -> do ...+-- @+--+-- Note that 'rawSql' knows how to replace the double question+-- marks @??@ because of the type of the @results@.+++-- | A single column (see 'rawSql').  Any 'PersistField' may be+-- used here, including 'PersistValue' (which does not do any+-- processing).+newtype Single a = Single {unSingle :: a}+    deriving (Eq, Ord, Show, Read)
− Database/Persist/Store.hs 
@@ -1,814 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE RankNTypes #-}--- This is to test our assumption that OverlappingInstances is just for String-#ifndef NO_OVERLAP-{-# LANGUAGE OverlappingInstances #-}-#endif---- | API for database actions. The API deals with fields and entities.--- In SQL, a field corresponds to a column, and should be a single non-composite value.--- An entity corresponds to a SQL table, so an entity is a collection of fields.-module Database.Persist.Store-    ( PersistValue (..)-    , SqlType (..)-    , PersistField (..)-    , PersistEntity (..)-    , PersistStore (..)-    , PersistUnique (..)-    , PersistFilter (..)-    , SomePersistField (..)--    , ZT (..) -- ZonedTime wrapper--    , insertBy-    , getByValue-    , getJust-    , belongsTo-    , belongsToJust--    , checkUnique-    , DeleteCascade (..)-    , PersistException (..)-    , KeyBackend (..)-    , Key-    , Entity (..)--      -- * Helpers-    , getPersistMap-    , listToJSON-    , mapToJSON--      -- * Config-    , PersistConfig (..)-    ) where--import qualified Prelude-import Prelude hiding ((++), show)-import Data.Monoid (mappend)-import Data.Time (Day, TimeOfDay, UTCTime)-import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone)-import Data.ByteString.Char8 (ByteString, unpack)-import Control.Applicative-import Data.Typeable (Typeable)-import Data.Int (Int8, Int16, Int32, Int64)-import Data.Word (Word8, Word16, Word32, Word64)--import Text.Blaze.Html-import Text.Blaze.Html.Renderer.Text (renderHtml)--import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.ByteString.Lazy as L--import qualified Control.Exception as E-import Control.Monad.Trans.Error (Error (..))-import Database.Persist.EntityDef--import Data.Bits (bitSize)-import Control.Monad (liftM, (<=<))-import Control.Arrow (second)--import qualified Data.Text.Encoding as T-import qualified Data.Text.Encoding.Error as T-import Web.PathPieces (PathPiece (..))-import qualified Data.Text.Read--import Data.Aeson (Value)-import Data.Aeson.Types (Parser)-import qualified Data.Aeson as A-import qualified Data.Attoparsec.Number as AN-import qualified Data.Vector as V--import qualified Data.Set as S-import qualified Data.Map as M-import qualified Data.HashMap.Strict as HM--import qualified Data.Text.Encoding as TE-import qualified Data.ByteString.Base64 as B64--import Data.Aeson (toJSON)-import Data.Aeson.Encode (fromValue)-import Data.Text.Lazy (toStrict)-import Data.Text.Lazy.Builder (toLazyText)--import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Monad.Trans.Class (lift)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Monoid (Monoid)--#if MIN_VERSION_conduit(1, 0, 0)-import Data.Conduit.Internal (Pipe, ConduitM)-#else-import Data.Conduit (Pipe)-#endif-import Control.Monad.Logger (LoggingT)-import Control.Monad.Trans.Identity ( IdentityT)-import Control.Monad.Trans.List     ( ListT    )-import Control.Monad.Trans.Maybe    ( MaybeT   )-import Control.Monad.Trans.Error    ( ErrorT   )-import Control.Monad.Trans.Reader   ( ReaderT  )-import Control.Monad.Trans.Cont     ( ContT  )-import Control.Monad.Trans.State    ( StateT   )-import Control.Monad.Trans.Writer   ( WriterT  )-import Control.Monad.Trans.RWS      ( RWST     )-import Control.Monad.Trans.Resource ( ResourceT)--import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )-import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )-import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )--data PersistException-  = PersistError T.Text -- ^ Generic Exception-  | PersistMarshalError T.Text-  | PersistInvalidField T.Text-  | PersistForeignConstraintUnmet T.Text-  | PersistMongoDBError T.Text-  | PersistMongoDBUnsupported T.Text-    deriving (Show, Typeable)--instance E.Exception PersistException-instance Error PersistException where-    strMsg = PersistError . T.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 T.Text-                  | PersistByteString ByteString-                  | PersistInt64 Int64-                  | PersistDouble Double-                  | PersistBool Bool-                  | PersistDay Day-                  | PersistTimeOfDay TimeOfDay-                  | PersistUTCTime UTCTime-                  | PersistZonedTime ZT-                  | PersistNull-                  | PersistList [PersistValue]-                  | PersistMap [(T.Text, PersistValue)]-                  | PersistObjectId ByteString -- ^ intended especially for MongoDB backend-    deriving (Show, Read, Eq, Typeable, Ord)--instance PathPiece PersistValue where-    fromPathPiece t =-        case Data.Text.Read.signed Data.Text.Read.decimal t of-            Right (i, t')-                | T.null t' -> Just $ PersistInt64 i-            _ -> Just $ PersistText t-    toPathPiece x =-        case fromPersistValue x of-            Left e -> error $ T.unpack e-            Right y -> y--instance A.ToJSON PersistValue where-    toJSON (PersistText t) = A.String $ T.cons 's' t-    toJSON (PersistByteString b) = A.String $ T.cons 'b' $ TE.decodeUtf8 $ B64.encode b-    toJSON (PersistInt64 i) = A.Number $ fromIntegral i-    toJSON (PersistDouble d) = A.Number $ AN.D d-    toJSON (PersistBool b) = A.Bool b-    toJSON (PersistTimeOfDay t) = A.String $ T.cons 't' $ show t-    toJSON (PersistUTCTime u) = A.String $ T.cons 'u' $ show u-    toJSON (PersistZonedTime z) = A.String $ T.cons 'z' $ show z-    toJSON (PersistDay d) = A.String $ T.cons 'd' $ show d-    toJSON PersistNull = A.Null-    toJSON (PersistList l) = A.Array $ V.fromList $ map A.toJSON l-    toJSON (PersistMap m) = A.object $ map (second A.toJSON) m-    toJSON (PersistObjectId o) = A.String $ T.cons 'o' $ TE.decodeUtf8 $ B64.encode o--instance A.FromJSON PersistValue where-    parseJSON (A.String t0) =-        case T.uncons t0 of-            Nothing -> fail "Null string"-            Just ('s', t) -> return $ PersistText t-            Just ('b', t) -> either (fail "Invalid base64") (return . PersistByteString)-                           $ 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 ('o', t) -> either (fail "Invalid base64") (return . PersistObjectId)-                           $ B64.decode $ TE.encodeUtf8 t-            Just (c, _) -> fail $ "Unknown prefix: " `mappend` [c]-      where-        readMay :: (Read a, Monad m) => T.Text -> m a-        readMay t =-            case reads $ T.unpack t of-                (x, _):_ -> return x-                [] -> fail "Could not read"-    parseJSON (A.Number (AN.I i)) = return $ PersistInt64 $ fromInteger i-    parseJSON (A.Number (AN.D d)) = return $ PersistDouble d-    parseJSON (A.Bool b) = return $ PersistBool b-    parseJSON A.Null = return $ PersistNull-    parseJSON (A.Array a) = fmap PersistList (mapM A.parseJSON $ V.toList a)-    parseJSON (A.Object o) =-        fmap PersistMap $ mapM go $ HM.toList o-      where-        go (k, v) = fmap ((,) k) $ A.parseJSON v---- | A SQL data type. Naming attempts to reflect the underlying Haskell--- datatypes, eg SqlString instead of SqlVarchar. Different SQL databases may--- have different translations for these types.-data SqlType = SqlString-             | SqlInt32-             | SqlInt64-             | SqlReal-             | SqlBool-             | SqlDay-             | SqlTime-             | SqlDayTime-             | SqlDayTimeZoned-             | SqlBlob-             | SqlOther T.Text -- ^ a backend-specific name-    deriving (Show, Read, Eq, Typeable, Ord)---- | A value which can be marshalled to and from a 'PersistValue'.-class PersistField a where-    toPersistValue :: a -> PersistValue-    fromPersistValue :: PersistValue -> Either T.Text a-    sqlType :: a -> SqlType-    isNullable :: a -> Bool-    isNullable _ = False--#ifndef NO_OVERLAP-instance PersistField String where-    toPersistValue = PersistText . T.pack-    fromPersistValue (PersistText s) = Right $ T.unpack s-    fromPersistValue (PersistByteString bs) =-        Right $ T.unpack $ T.decodeUtf8With T.lenientDecode bs-    fromPersistValue (PersistInt64 i) = Right $ Prelude.show i-    fromPersistValue (PersistDouble d) = Right $ Prelude.show d-    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 "Unexpected null"-    fromPersistValue (PersistBool b) = Right $ Prelude.show b-    fromPersistValue (PersistList _) = Left "Cannot convert PersistList to String"-    fromPersistValue (PersistMap _) = Left "Cannot convert PersistMap to String"-    fromPersistValue (PersistObjectId _) = Left "Cannot convert PersistObjectId to String"-    sqlType _ = SqlString-#endif--instance PersistField ByteString where-    toPersistValue = PersistByteString-    fromPersistValue (PersistByteString bs) = Right bs-    fromPersistValue x = T.encodeUtf8 <$> fromPersistValue x-    sqlType _ = SqlBlob--instance PersistField T.Text where-    toPersistValue = PersistText-    fromPersistValue (PersistText s) = Right s-    fromPersistValue (PersistByteString bs) =-        Right $ T.decodeUtf8With T.lenientDecode bs-    fromPersistValue (PersistInt64 i) = Right $ show i-    fromPersistValue (PersistDouble d) = Right $ show d-    fromPersistValue (PersistDay d) = Right $ show d-    fromPersistValue (PersistTimeOfDay d) = Right $ show d-    fromPersistValue (PersistUTCTime d) = Right $ show d-    fromPersistValue (PersistZonedTime (ZT z)) = Right $ show z-    fromPersistValue PersistNull = Left "Unexpected null"-    fromPersistValue (PersistBool b) = Right $ show b-    fromPersistValue (PersistList _) = Left "Cannot convert PersistList to Text"-    fromPersistValue (PersistMap _) = Left "Cannot convert PersistMap to Text"-    fromPersistValue (PersistObjectId _) = Left "Cannot convert PersistObjectId to Text"-    sqlType _ = SqlString--instance PersistField TL.Text where-    toPersistValue = toPersistValue . TL.toStrict-    fromPersistValue = fmap TL.fromStrict . fromPersistValue-    sqlType _ = SqlString--instance PersistField Html where-    toPersistValue = PersistText . TL.toStrict . renderHtml-    fromPersistValue = fmap (preEscapedToMarkup :: T.Text -> Html) . fromPersistValue-    sqlType _ = SqlString--instance PersistField Int where-    toPersistValue = PersistInt64 . fromIntegral-    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i-    fromPersistValue x = Left $ "Expected Integer, received: " ++ show x-    sqlType x = case bitSize x of-                    32 -> SqlInt32-                    _ -> SqlInt64--instance PersistField Int8 where-    toPersistValue = PersistInt64 . fromIntegral-    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i-    fromPersistValue x = Left $ "Expected Integer, received: " ++ show x-    sqlType _ = SqlInt32--instance PersistField Int16 where-    toPersistValue = PersistInt64 . fromIntegral-    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i-    fromPersistValue x = Left $ "Expected Integer, received: " ++ show x-    sqlType _ = SqlInt32--instance PersistField Int32 where-    toPersistValue = PersistInt64 . fromIntegral-    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i-    fromPersistValue x = Left $ "Expected Integer, received: " ++ show x-    sqlType _ = SqlInt32--instance PersistField Int64 where-    toPersistValue = PersistInt64 . fromIntegral-    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i-    fromPersistValue x = Left $ "Expected Integer, received: " ++ show x-    sqlType _ = SqlInt64--instance PersistField Word8 where-    toPersistValue = PersistInt64 . fromIntegral-    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i-    fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x-    sqlType _ = SqlInt32--instance PersistField Word16 where-    toPersistValue = PersistInt64 . fromIntegral-    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i-    fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x-    sqlType _ = SqlInt32--instance PersistField Word32 where-    toPersistValue = PersistInt64 . fromIntegral-    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i-    fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x-    sqlType _ = SqlInt64--instance PersistField Word64 where-    toPersistValue = PersistInt64 . fromIntegral-    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i-    fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x-    sqlType _ = SqlInt64--instance PersistField Double where-    toPersistValue = PersistDouble-    fromPersistValue (PersistDouble d) = Right d-    fromPersistValue x = Left $ "Expected Double, received: " ++ show x-    sqlType _ = SqlReal--instance PersistField Bool where-    toPersistValue = PersistBool-    fromPersistValue (PersistBool b) = Right b-    fromPersistValue (PersistInt64 i) = Right $ i /= 0-    fromPersistValue x = Left $ "Expected Bool, received: " ++ show x-    sqlType _ = SqlBool--instance PersistField Day where-    toPersistValue = PersistDay-    fromPersistValue (PersistDay d) = Right d-    fromPersistValue x@(PersistText t) =-        case reads $ T.unpack t of-            (d, _):_ -> Right d-            _ -> Left $ "Expected Day, received " ++ show x-    fromPersistValue x@(PersistByteString s) =-        case reads $ unpack s of-            (d, _):_ -> Right d-            _ -> Left $ "Expected Day, received " ++ show x-    fromPersistValue x = Left $ "Expected Day, received: " ++ show x-    sqlType _ = SqlDay--instance PersistField TimeOfDay where-    toPersistValue = PersistTimeOfDay-    fromPersistValue (PersistTimeOfDay d) = Right d-    fromPersistValue x@(PersistText t) =-        case reads $ T.unpack t of-            (d, _):_ -> Right d-            _ -> Left $ "Expected TimeOfDay, received " ++ show x-    fromPersistValue x@(PersistByteString s) =-        case reads $ unpack s of-            (d, _):_ -> Right d-            _ -> Left $ "Expected TimeOfDay, received " ++ show x-    fromPersistValue x = Left $ "Expected TimeOfDay, received: " ++ show x-    sqlType _ = SqlTime--instance PersistField UTCTime where-    toPersistValue = PersistUTCTime-    fromPersistValue (PersistUTCTime d) = Right d-    fromPersistValue x@(PersistText t) =-        case reads $ T.unpack t of-            (d, _):_ -> Right d-            _ -> Left $ "Expected UTCTime, received " ++ show x-    fromPersistValue x@(PersistByteString s) =-        case reads $ unpack s of-            (d, _):_ -> Right d-            _ -> Left $ "Expected UTCTime, received " ++ show x-    fromPersistValue x = Left $ "Expected UTCTime, received: " ++ show x-    sqlType _ = SqlDayTime--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 $ "Expected ZonedTime, received " ++ show x-    fromPersistValue x@(PersistByteString s) =-        case reads $ unpack s of-            (z, _):_ -> Right z-            _ -> Left $ "Expected ZonedTime, received " ++ show x-    fromPersistValue x = Left $ "Expected ZonedTime, received: " ++ show x-    sqlType _ = SqlDayTimeZoned--instance PersistField a => PersistField (Maybe a) where-    toPersistValue Nothing = PersistNull-    toPersistValue (Just a) = toPersistValue a-    fromPersistValue PersistNull = Right Nothing-    fromPersistValue x = fmap Just $ fromPersistValue x-    sqlType _ = sqlType (error "this is the problem" :: a)-    isNullable _ = True---- | Helper wrapper, equivalent to @Key (PersistEntityBackend val) val@.------ Since 1.1.0-type Key val = KeyBackend (PersistEntityBackend val) val---- | A single database entity. For example, if writing a blog application, a--- blog entry would be an entry, containing fields such as title and content.-class PersistEntity val where-    -- | Parameters: val and datatype of the field-    data EntityField val :: * -> *-    persistFieldDef :: EntityField val typ -> FieldDef--    type PersistEntityBackend val--    -- | Unique keys in existence on this entity.-    data Unique val--    entityDef :: val -> EntityDef-    toPersistFields :: val -> [SomePersistField]-    fromPersistValues :: [PersistValue] -> Either T.Text val-    halfDefined :: val--    persistUniqueToFieldNames :: Unique val -> [(HaskellName, DBName)]-    persistUniqueToValues :: Unique val -> [PersistValue]-    persistUniqueKeys :: val -> [Unique val]--    persistIdField :: EntityField val (Key val)--    fieldLens :: EntityField val field-              -> (forall f. Functor f => (field -> f field) -> Entity val -> f (Entity val))--instance PersistField a => PersistField [a] where-    toPersistValue = PersistList . map toPersistValue-    fromPersistValue (PersistList l) = fromPersistList l-    fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t)-    fromPersistValue (PersistByteString bs)-        | Just values <- A.decode' (L.fromChunks [bs]) = fromPersistList values-    fromPersistValue x = Left $ "Expected PersistList, received: " ++ show x-    sqlType _ = SqlString--instance (Ord a, PersistField a) => PersistField (S.Set a) where-    toPersistValue = PersistList . map toPersistValue . S.toList-    fromPersistValue (PersistList list) =-      either Left (Right . S.fromList) $ fromPersistList list-    fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t)-    fromPersistValue (PersistByteString bs)-        | Just values <- A.decode' (L.fromChunks [bs]) =-            either Left (Right . S.fromList) $ fromPersistList values-    fromPersistValue x = Left $ "Expected PersistSet, received: " ++ show x-    sqlType _ = SqlString--fromPersistList :: PersistField a => [PersistValue] -> Either T.Text [a]-fromPersistList = mapM fromPersistValue--instance (PersistField a, PersistField b) => PersistField (a,b) where-    toPersistValue (x,y) = PersistList [toPersistValue x, toPersistValue y]-    fromPersistValue (PersistList (vx:vy:[])) =-      case (fromPersistValue vx, fromPersistValue vy) of-        (Right x, Right y) -> Right (x, y)-        (Left e, _) -> Left e-        (_, Left e) -> Left e-    fromPersistValue x = Left $ "Expected 2 item PersistList, received: " ++ show x-    sqlType _ = SqlString--instance PersistField v => PersistField (M.Map T.Text v) where-    toPersistValue = PersistMap . map (\(k,v) -> (k, toPersistValue v)) . M.toList-    fromPersistValue = fromPersistMap <=< getPersistMap-    sqlType _ = SqlString--getPersistMap :: PersistValue -> Either T.Text [(T.Text, PersistValue)]-getPersistMap (PersistMap kvs) = Right kvs-getPersistMap (PersistText t)  = getPersistMap (PersistByteString $ TE.encodeUtf8 t)-getPersistMap (PersistByteString bs)-    | Just pairs <- A.decode' (L.fromChunks [bs]) = Right pairs-getPersistMap x = Left $ "Expected PersistMap, received: " ++ show x--fromPersistMap :: PersistField v-               => [(T.Text, PersistValue)]-               -> Either T.Text (M.Map T.Text v)-fromPersistMap kvs =-      case (-        foldl (\eithAssocs (k,v) ->-              case (eithAssocs, fromPersistValue v) of-                (Left e, _) -> Left e-                (_, Left e)   -> Left e-                (Right assocs, Right v') -> Right ((k,v'):assocs)-              ) (Right []) kvs-      ) of-        Right vs -> Right $ M.fromList vs-        Left e -> Left e--data SomePersistField = forall a. PersistField a => SomePersistField a-instance PersistField SomePersistField where-    toPersistValue (SomePersistField a) = toPersistValue a-    fromPersistValue x = fmap SomePersistField (fromPersistValue x :: Either T.Text T.Text)-    sqlType (SomePersistField a) = sqlType a--newtype KeyBackend backend entity = Key { unKey :: PersistValue }-    deriving (Show, Read, Eq, Ord, PersistField)--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---- | Datatype that represents an entity, with both its key and--- its Haskell representation.------ When using the an SQL-based backend (such as SQLite or--- PostgreSQL), an 'Entity' may take any number of columns--- depending on how many fields it has. In order to reconstruct--- your entity on the Haskell side, @persistent@ needs all of--- your entity columns and in the right order.  Note that you--- don't need to worry about this when using @persistent@\'s API--- since everything is handled correctly behind the scenes.------ However, if you want to issue a raw SQL command that returns--- an 'Entity', then you have to be careful with the column--- order.  While you could use @SELECT Entity.* WHERE ...@ and--- that would work most of the time, there are times when the--- order of the columns on your database is different from the--- order that @persistent@ expects (for example, if you add a new--- field in the middle of you entity definition and then use the--- migration code -- @persistent@ will expect the column to be in--- the middle, but your DBMS will put it as the last column).--- So, instead of using a query like the one above, you may use--- 'Database.Persist.GenericSql.rawSql' (from the--- "Database.Persist.GenericSql" module) with its /entity--- selection placeholder/ (a double question mark @??@).  Using--- @rawSql@ the query above must be written as @SELECT ??  WHERE--- ..@.  Then @rawSql@ will replace @??@ with the list of all--- columns that we need from your entity in the right order.  If--- 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)--class MonadIO m => PersistStore m where-    type PersistMonadBackend m--    -- | Create a new record in the database, returning an automatically created-    -- key (in SQL an auto-increment id).-    insert :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)-           => val -> m (Key val)--    -- | Same as 'insert', but doesn't return a @Key@.-    insert_ :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)-            => val -> m ()-    insert_ val = insert val >> return ()--    -- | Create a new record in the database using the given key.-    insertKey :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)-              => Key val -> val -> m ()--    -- | Put the record in the database with the given key.-    -- Unlike 'replace', if a record with the given key does not-    -- exist then a new record will be inserted.-    repsert :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)-            => Key val -> val -> m ()--    -- | Replace the record in the database with the given-    -- key. Note that the result is undefined if such record does-    -- not exist, so you must use 'insertKey or 'repsert' in-    -- these cases.-    replace :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)-            => Key val -> val -> m ()--    -- | Delete a specific record by identifier. Does nothing if record does-    -- not exist.-    delete :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)-           => Key val -> m ()--    -- | Get a record by identifier, if available.-    get :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)-        => Key val -> m (Maybe val)--#define DEF(T) { type PersistMonadBackend (T m) = PersistMonadBackend m; insert = lift . insert; insertKey k = lift . insertKey k; repsert k = lift . repsert k; replace k = lift . replace k; delete = lift . delete; get = lift . get }-#define GO(T) instance (PersistStore m) => PersistStore (T m) where DEF(T)-#define GOX(X, T) instance (X, PersistStore m) => PersistStore (T m) where DEF(T)--GO(LoggingT)-GO(IdentityT)-GO(ListT)-GO(MaybeT)-GOX(Error e, ErrorT e)-GO(ReaderT r)-GO(ContT r)-GO(StateT s)-GO(ResourceT)-GO(Pipe l i o u)-#if MIN_VERSION_conduit(1, 0, 0)-GO(ConduitM i o)-#endif-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---- | Queries against unique keys (other than the id).------ Please read the general Persistent documentation to learn how to create--- Unique keys.--- SQL backends automatically create uniqueness constraints, but for MongoDB you must place a unique index on the field.-class PersistStore m => PersistUnique m where-    -- | Get a record by unique key, if available. Returns also the identifier.-    getBy :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => Unique val -> m (Maybe (Entity val))--    -- | Delete a specific record by unique key. Does nothing if no record-    -- matches.-    deleteBy :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => Unique val -> m ()--    -- | Like 'insert', but returns 'Nothing' when the record-    -- couldn't be inserted because of a uniqueness constraint.-    insertUnique :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => val -> m (Maybe (Key val))-    insertUnique datum = do-        isUnique <- checkUnique datum-        if isUnique then Just `liftM` insert datum else return Nothing--#define DEF(T) { getBy = lift . getBy; deleteBy = lift . deleteBy; insertUnique = lift . insertUnique }-#define GO(T) instance (PersistUnique m) => PersistUnique (T m) where DEF(T)-#define GOX(X, T) instance (X, PersistUnique m) => PersistUnique (T m) where DEF(T)--GO(LoggingT)-GO(IdentityT)-GO(ListT)-GO(MaybeT)-GOX(Error e, ErrorT e)-GO(ReaderT r)-GO(ContT r)-GO(StateT s)-GO(ResourceT)-GO(Pipe l i o u)-GOX(Monoid w, WriterT w)-GOX(Monoid w, RWST r w s)-GOX(Monoid w, Strict.RWST r w s)-GO(Strict.StateT s)-GOX(Monoid w, Strict.WriterT w)--#undef DEF-#undef GO-#undef GOX----- | Insert a value, checking for conflicts with any unique constraints.  If a--- duplicate exists in the database, it is returned as 'Left'. Otherwise, the--- new 'Key is returned as 'Right'.-insertBy :: (PersistEntity v, PersistStore m, PersistUnique m, PersistMonadBackend m ~ PersistEntityBackend v)-          => v -> m (Either (Entity v) (Key v))-insertBy val =-    go $ persistUniqueKeys val-  where-    go [] = Right `liftM` insert val-    go (x:xs) = do-        y <- getBy x-        case y of-            Nothing -> go xs-            Just z -> return $ Left z---- | A modification of 'getBy', which takes the 'PersistEntity' itself instead--- of a 'Unique' value. Returns a value matching /one/ of the unique keys. This--- function makes the most sense on entities with a single 'Unique'--- constructor.-getByValue :: (PersistEntity v, PersistUnique m, PersistEntityBackend v ~ PersistMonadBackend m)-           => v -> m (Maybe (Entity v))-getByValue val =-    go $ persistUniqueKeys val-  where-    go [] = return Nothing-    go (x:xs) = do-        y <- getBy x-        case y of-            Nothing -> go xs-            Just z -> return $ Just z---- | curry this to make a convenience function that loads an associated model---   > foreign = belongsTo foeignId-belongsTo ::-  (PersistStore m-  , PersistEntity ent1-  , PersistEntity ent2-  , PersistMonadBackend m ~ PersistEntityBackend ent2-  ) => (ent1 -> Maybe (Key ent2)) -> ent1 -> m (Maybe ent2)-belongsTo foreignKeyField model = case foreignKeyField model of-    Nothing -> return Nothing-    Just f -> get f---- | same as belongsTo, but uses @getJust@ and therefore is similarly unsafe-belongsToJust ::-  (PersistStore m-  , PersistEntity ent1-  , PersistEntity ent2-  , PersistMonadBackend m ~ PersistEntityBackend ent2)-  => (ent1 -> Key ent2) -> ent1 -> m ent2-belongsToJust getForeignKey model = getJust $ getForeignKey model---- | Same as get, but for a non-null (not Maybe) foreign key---   Unsafe unless your database is enforcing that the foreign key is valid-getJust :: (PersistStore m, PersistEntity val, Show (Key val), PersistMonadBackend m ~ PersistEntityBackend val) => Key val -> m val-getJust key = get key >>= maybe-  (liftIO $ E.throwIO $ PersistForeignConstraintUnmet $ show key)-  return----- | Check whether there are any conflicts for unique keys with this entity and--- existing entities in the database.------ Returns 'True' if the entity would be unique, and could thus safely be--- 'insert'ed; returns 'False' on a conflict.-checkUnique :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val, PersistUnique m) => val -> m Bool-checkUnique val =-    go $ persistUniqueKeys val-  where-    go [] = return True-    go (x:xs) = do-        y <- getBy x-        case y of-            Nothing -> go xs-            Just _ -> return False--data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le | In | NotIn-                   | BackendSpecificFilter T.Text-    deriving (Read, Show)--class (PersistStore m, PersistEntity a, PersistEntityBackend a ~ PersistMonadBackend m) => DeleteCascade a m where-    deleteCascade :: Key a -> m ()--instance PersistField PersistValue where-    toPersistValue = id-    fromPersistValue = Right-    sqlType _ = SqlInt64 -- since PersistValue should only be used like this for keys, which in SQL are Int64---- | Represents a value containing all the configuration options for a specific--- backend. This abstraction makes it easier to write code that can easily swap--- backends.-class PersistConfig c where-    type PersistConfigBackend c :: (* -> *) -> * -> *-    type PersistConfigPool c--    -- | Load the config settings from a 'Value', most likely taken from a YAML-    -- config file.-    loadConfig :: Value -> Parser c--    -- | Modify the config settings based on environment variables.-    applyEnv :: c -> IO c-    applyEnv = return--    -- | Create a new connection pool based on the given config settings.-    createPoolConfig :: c -> IO (PersistConfigPool c)--    -- | Run a database action by taking a connection from the pool.-    runPool :: (MonadBaseControl IO m, MonadIO m)-            => c-            -> PersistConfigBackend c m a-            -> PersistConfigPool c-            -> m a--infixr 5 ++-(++) :: T.Text -> T.Text -> T.Text-(++) = mappend--show :: Show a => a -> T.Text-show = T.pack . Prelude.show--listToJSON :: [PersistValue] -> T.Text-listToJSON = toStrict . toLazyText . fromValue . toJSON--mapToJSON :: [(T.Text, PersistValue)] -> T.Text-mapToJSON = toStrict . toLazyText . fromValue . toJSON
− Database/Persist/TH/Library.hs 
@@ -1,18 +0,0 @@-{-# LANGUAGE CPP #-}-module Database.Persist.TH.Library-    ( apE-    ) where--#if MIN_VERSION_base(4,3,0)-import Control.Applicative-#endif--apE :: Either x (y -> z) -> Either x y -> Either x z--#if MIN_VERSION_base(4,3,0)-apE = (<*>)-#else-apE (Left x)   _         = Left x-apE _          (Left x)  = Left x-apE (Right f)  (Right y) = Right (f y)-#endif
+ Database/Persist/Types.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE TypeFamilies #-}+module Database.Persist.Types+    ( module Database.Persist.Types.Base+    , SomePersistField (..)+    , Update (..)+    , SelectOpt (..)+    , BackendSpecificFilter+    , Filter (..)+    , Key+    , Entity (..)+    ) where++import Database.Persist.Types.Base+import Database.Persist.Class.PersistField+import Database.Persist.Class.PersistEntity
+ Database/Persist/Types/Base.hs view
@@ -0,0 +1,301 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Database.Persist.Types.Base where++import qualified Data.Aeson as A+import Control.Exception (Exception)+import Web.PathPieces (PathPiece (..))+import Control.Monad.Trans.Error (Error (..))+import Data.Typeable (Typeable)+import Data.Text (Text, pack)+import qualified Data.Text as T+import qualified Data.Attoparsec.Number as AN+import qualified Data.Text.Encoding as TE+import Data.Text.Encoding.Error (lenientDecode)+import qualified Data.ByteString.Base64 as B64+import qualified Data.Vector as V+import Control.Arrow (second)+import Data.Time (Day, TimeOfDay, UTCTime)+import Data.Int (Int64)+import qualified Data.Text.Read+import Data.ByteString (ByteString)+import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone)+import Data.Map (Map)+import qualified Data.HashMap.Strict as HM+import Data.Word (Word32)++-- | A 'Checkmark' should be used as a field type whenever a+-- uniqueness constraint should guarantee that a certain kind of+-- record may appear at most once, but other kinds of records may+-- appear any number of times.+--+-- /NOTE:/ You need to mark any @Checkmark@ fields as @nullable@+-- (see the following example).+--+-- For example, suppose there's a @Location@ entity that+-- represents where a user has lived:+--+-- @+-- Location+--     user    UserId+--     name    Text+--     current Checkmark nullable+--+--     UniqueLocation user current+-- @+--+-- The @UniqueLocation@ constraint allows any number of+-- 'Inactive' @Location@s to be @current@.  However, there may be+-- at most one @current@ @Location@ per user (i.e., either zero+-- or one per user).+--+-- This data type works because of the way that SQL treats+-- @NULL@able fields within uniqueness constraints.  The SQL+-- standard says that @NULL@ values should be considered+-- different, so we represent 'Inactive' as SQL @NULL@, thus+-- allowing any number of 'Inactive' records.  On the other hand,+-- we represent 'Active' as @TRUE@, so the uniqueness constraint+-- will disallow more than one 'Active' record.+--+-- /Note:/ There may be DBMSs that do not respect the SQL+-- standard's treatment of @NULL@ values on uniqueness+-- constraints, please check if this data type works before+-- relying on it.+--+-- The SQL @BOOLEAN@ type is used because it's the smallest data+-- type available.  Note that we never use @FALSE@, just @TRUE@+-- and @NULL@.  Provides the same behavior @Maybe ()@ would if+-- @()@ was a valid 'PersistField'.+data Checkmark = Active+                 -- ^ When used on a uniqueness constraint, there+                 -- may be at most one 'Active' record.+               | Inactive+                 -- ^ When used on a uniqueness constraint, there+                 -- may be any number of 'Inactive' records.+    deriving (Eq, Ord, Read, Show, Enum, Bounded)++instance PathPiece Checkmark where+    toPathPiece = pack . show+    fromPathPiece txt =+      case reads (T.unpack txt) of+        [(a, "")] -> Just a+        _         -> Nothing++data IsNullable = Nullable !WhyNullable+                | NotNullable+                  deriving (Eq, Show)++-- | The reason why a field is 'nullable' is very important.  A+-- field that is nullable because of a @Maybe@ tag will have its+-- type changed from @A@ to @Maybe A@.  OTOH, a field that is+-- nullable because of a @nullable@ tag will remain with the same+-- type.+data WhyNullable = ByMaybeAttr+                 | ByNullableAttr+                  deriving (Eq, Show)++data EntityDef sqlType = EntityDef+    { entityHaskell :: !HaskellName+    , entityDB      :: !DBName+    , entityID      :: !DBName+    , entityAttrs   :: ![Attr]+    , entityFields  :: ![FieldDef sqlType]+    , entityUniques :: ![UniqueDef]+    , entityDerives :: ![Text]+    , entityExtra   :: !(Map Text [ExtraLine])+    , entitySum     :: !Bool+    }+    deriving (Show, Eq, Read, Ord, Functor)++type ExtraLine = [Text]++newtype HaskellName = HaskellName { unHaskellName :: Text }+    deriving (Show, Eq, Read, Ord)+newtype DBName = DBName { unDBName :: Text }+    deriving (Show, Eq, Read, Ord)++type Attr = Text++data FieldType+    = FTTypeCon (Maybe Text) -- ^ optional module+                Text         -- ^ name+    | FTApp FieldType FieldType+    | 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+    }+    deriving (Show, Eq, Read, Ord, Functor)++data UniqueDef = UniqueDef+    { uniqueHaskell :: !HaskellName+    , uniqueDBName  :: !DBName+    , uniqueFields  :: ![(HaskellName, DBName)]+    , uniqueAttrs   :: ![Attr]+    }+    deriving (Show, Eq, Read, Ord)++data PersistException+  = PersistError Text -- ^ Generic Exception+  | PersistMarshalError Text+  | PersistInvalidField Text+  | PersistForeignConstraintUnmet Text+  | PersistMongoDBError Text+  | PersistMongoDBUnsupported Text+    deriving (Show, Typeable)++instance Exception PersistException+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+                  | PersistByteString ByteString+                  | PersistInt64 Int64+                  | PersistDouble Double+                  | PersistRational Rational+                  | PersistBool Bool+                  | PersistDay Day+                  | PersistTimeOfDay TimeOfDay+                  | PersistUTCTime UTCTime+                  | PersistZonedTime ZT+                  | PersistNull+                  | PersistList [PersistValue]+                  | PersistMap [(Text, PersistValue)]+                  | PersistObjectId ByteString -- ^ intended especially for MongoDB backend+    deriving (Show, Read, Eq, Typeable, Ord)++instance PathPiece PersistValue where+    fromPathPiece t =+        case Data.Text.Read.signed Data.Text.Read.decimal t of+            Right (i, t')+                | T.null t' -> Just $ PersistInt64 i+            _ -> Just $ PersistText t+    toPathPiece x =+        case fromPersistValueText x of+            Left e -> error e+            Right y -> y++fromPersistValueText :: PersistValue -> Either String Text+fromPersistValueText (PersistText s) = Right s+fromPersistValueText (PersistByteString bs) =+    Right $ TE.decodeUtf8With lenientDecode bs+fromPersistValueText (PersistInt64 i) = Right $ T.pack $ show i+fromPersistValueText (PersistDouble d) = Right $ T.pack $ show d+fromPersistValueText (PersistRational r) = Right $ T.pack $ show r+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"+fromPersistValueText (PersistMap _) = Left "Cannot convert PersistMap to Text"+fromPersistValueText (PersistObjectId _) = Left "Cannot convert PersistObjectId to Text"++instance A.ToJSON PersistValue where+    toJSON (PersistText t) = A.String $ T.cons 's' t+    toJSON (PersistByteString b) = A.String $ T.cons 'b' $ TE.decodeUtf8 $ B64.encode b+    toJSON (PersistInt64 i) = A.Number $ fromIntegral i+    toJSON (PersistDouble d) = A.Number $ AN.D d+    toJSON (PersistRational r) = A.String $ T.pack $ 'r' : show r+    toJSON (PersistBool b) = A.Bool b+    toJSON (PersistTimeOfDay t) = A.String $ T.pack $ 't' : show t+    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+    toJSON (PersistMap m) = A.object $ map (second A.toJSON) m+    toJSON (PersistObjectId o) = A.String $ T.cons 'o' $ TE.decodeUtf8 $ B64.encode o++instance A.FromJSON PersistValue where+    parseJSON (A.String t0) =+        case T.uncons t0 of+            Nothing -> fail "Null string"+            Just ('s', t) -> return $ PersistText t+            Just ('b', t) -> either (fail "Invalid base64") (return . PersistByteString)+                           $ 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) -> either (fail "Invalid base64") (return . PersistObjectId)+                           $ B64.decode $ TE.encodeUtf8 t+            Just (c, _) -> fail $ "Unknown prefix: " ++ [c]+      where+        readMay :: (Read a, Monad m) => T.Text -> m a+        readMay t =+            case reads $ T.unpack t of+                (x, _):_ -> return x+                [] -> fail "Could not read"+    parseJSON (A.Number (AN.I i)) = return $ PersistInt64 $ fromInteger i+    parseJSON (A.Number (AN.D d)) = return $ PersistDouble d+    parseJSON (A.Bool b) = return $ PersistBool b+    parseJSON A.Null = return $ PersistNull+    parseJSON (A.Array a) = fmap PersistList (mapM A.parseJSON $ V.toList a)+    parseJSON (A.Object o) =+        fmap PersistMap $ mapM go $ HM.toList o+      where+        go (k, v) = fmap ((,) k) $ A.parseJSON v++-- | A SQL data type. Naming attempts to reflect the underlying Haskell+-- datatypes, eg SqlString instead of SqlVarchar. Different SQL databases may+-- have different translations for these types.+data SqlType = SqlString+             | SqlInt32+             | SqlInt64+             | SqlReal+             | SqlNumeric Word32 Word32+             | SqlBool+             | SqlDay+             | SqlTime+             | SqlDayTime+             | SqlDayTimeZoned+             | 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+    deriving Typeable+instance Show UpdateGetException where+    show (KeyNotFound key) = "Key not found during updateGet: " ++ key+instance Exception UpdateGetException++data PersistUpdate = Assign | Add | Subtract | Multiply | Divide -- FIXME need something else here+    deriving (Read, Show, Enum, Bounded)
− Database/Persist/Util.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Database.Persist.Util-    ( nullable-    , IsNullable(..)-    , WhyNullable(..)-    , deprecate-    ) where--import System.IO.Unsafe (unsafePerformIO)-import Data.Text--nullable :: [Text] -> IsNullable-nullable s-    | "Maybe"    `elem` s = Nullable ByMaybeAttr-    | "nullable" `elem` s = Nullable ByNullableAttr-    | "null"     `elem` s = deprecate "Please replace null with Maybe" (Nullable ByMaybeAttr)-    | otherwise = NotNullable---data IsNullable = Nullable !WhyNullable-                | NotNullable-                  deriving (Eq, Show)---- | The reason why a field is 'nullable' is very important.  A--- field that is nullable because of a @Maybe@ tag will have its--- type changed from @A@ to @Maybe A@.  OTOH, a field that is--- nullable because of a @nullable@ tag will remain with the same--- type.-data WhyNullable = ByMaybeAttr-                 | ByNullableAttr-                  deriving (Eq, Show)---deprecate :: String -> a -> a-deprecate s x = unsafePerformIO $ do-    putStrLn $ "DEPRECATED: " ++ s-    return x
persistent.cabal view
@@ -1,5 +1,5 @@ name:            persistent-version:         1.1.5.1+version:         1.2.0 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -26,14 +26,14 @@                    , time                     >= 1.1.4                    , text                     >= 0.8                    , containers               >= 0.2-                   , conduit                  >= 0.5.5+                   , conduit                  >= 1.0                    , resourcet                >= 0.4                    , monad-control            >= 0.3                    , lifted-base              >= 0.1-                   , pool-conduit             >= 0.1.1+                   , pool-conduit             >= 0.1.2                    , path-pieces              >= 0.1                    , aeson                    >= 0.5-                   , monad-logger             >= 0.2.3+                   , monad-logger             >= 0.3                    , transformers-base                    , base64-bytestring                    , unordered-containers@@ -45,21 +45,31 @@                    , silently      exposed-modules: Database.Persist-                     Database.Persist.EntityDef-                     Database.Persist.Store                      Database.Persist.Quasi-                     Database.Persist.GenericSql-                     Database.Persist.GenericSql.Raw-                     Database.Persist.GenericSql.Migration-                     Database.Persist.TH.Library-                     Database.Persist.Util-                     Database.Persist.Query-                     Database.Persist.Query.Internal-                     Database.Persist.Query.GenericSql-                     Database.Persist.Query.Join-                     Database.Persist.Query.Join.Sql-                     Database.Persist.GenericSql.Internal +                     Database.Persist.Types+                     Database.Persist.Class+                     Database.Persist.Sql++    other-modules:   Database.Persist.Types.Base+                     Database.Persist.Class.DeleteCascade+                     Database.Persist.Class.PersistEntity+                     Database.Persist.Class.PersistQuery+                     Database.Persist.Class.PersistUnique+                     Database.Persist.Class.PersistConfig+                     Database.Persist.Class.PersistField+                     Database.Persist.Class.PersistStore++                     Database.Persist.Sql.Migration+                     Database.Persist.Sql.Internal+                     Database.Persist.Sql.Types+                     Database.Persist.Sql.Raw+                     Database.Persist.Sql.Run+                     Database.Persist.Sql.Class+                     Database.Persist.Sql.Orphan.PersistQuery+                     Database.Persist.Sql.Orphan.PersistStore+                     Database.Persist.Sql.Orphan.PersistUnique+     ghc-options:     -Wall  test-suite test@@ -70,6 +80,20 @@                    , hspec >= 1.3                    , containers                    , text+                   , unordered-containers+                   , time+                   , bytestring+                   , vector+                   , base64-bytestring+                   , attoparsec+                   , transformers+                   , path-pieces+                   , aeson+                   , resourcet+                   , monad-logger+                   , conduit+                   , monad-control+                   , blaze-html      cpp-options: -DTEST
test/main.hs view
@@ -2,7 +2,7 @@ import Test.Hspec  import Database.Persist.Quasi-import Database.Persist.EntityDef+import Database.Persist.Types  main :: IO () main = hspec $ do