persistent 0.6.4.4 → 0.7.0
raw patch · 18 files changed
+2170/−1364 lines, 18 filesdep +aesondep +conduitdep +lifted-basedep −data-objectdep −enumeratordep −pooldep ~monad-controldep ~path-piecesdep ~text
Dependencies added: aeson, conduit, lifted-base, pool-conduit
Dependencies removed: data-object, enumerator, pool
Dependency ranges changed: monad-control, path-pieces, text
Files
- Database/Persist.hs +11/−41
- Database/Persist/Base.hs +0/−593
- Database/Persist/EntityDef.hs +53/−0
- Database/Persist/GenericSql.hs +393/−225
- Database/Persist/GenericSql/Internal.hs +94/−243
- Database/Persist/GenericSql/Migration.hs +142/−0
- Database/Persist/GenericSql/Raw.hs +24/−8
- Database/Persist/Join.hs +0/−57
- Database/Persist/Join/Sql.hs +0/−113
- Database/Persist/Quasi.hs +133/−70
- Database/Persist/Query.hs +57/−0
- Database/Persist/Query/GenericSql.hs +354/−0
- Database/Persist/Query/Internal.hs +108/−0
- Database/Persist/Query/Join.hs +58/−0
- Database/Persist/Query/Join/Sql.hs +130/−0
- Database/Persist/Store.hs +582/−0
- Database/Persist/Util.hs +3/−1
- persistent.cabal +28/−13
Database/Persist.hs view
@@ -3,59 +3,29 @@ module Database.Persist ( PersistField (..) , PersistEntity (..)- , PersistBackend (..)+ , PersistStore (..)+ , PersistUnique (..)+ , PersistQuery (..) , Key (..)- , selectList+ , Entity (..) , insertBy , getJust , belongsTo , belongsToJust , getByValue , checkUnique- , Update (..)+ , selectList+ , deleteCascadeWhere+ , SelectOpt (..) , Filter (..)++ -- * query combinators , (=.), (+=.), (-=.), (*=.), (/=.) , (==.), (!=.), (<.), (>.), (<=.), (>=.) , (<-.), (/<-.) , (||.) ) where --- Export public items from Database.Persist.Base--- Also defines Filter creation and composition operators.-import Database.Persist.Base--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]]+import Database.Persist.Store+import Database.Persist.Query
− Database/Persist/Base.hs
@@ -1,593 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE CPP #-}---- | 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.Base- ( PersistValue (..)- , SqlType (..)- , PersistField (..)- , PersistEntity (..)- , PersistBackend (..)- , PersistFilter (..)- , PersistUpdate (..)- , SelectOpt (..)- , SomePersistField (..)-- , selectList- , insertBy- , getByValue- , getJust- , belongsTo- , belongsToJust-- , checkUnique- , DeleteCascade (..)- , deleteCascadeWhere- , PersistException (..)- , Update (..)- , updateFieldName- , Filter (..)- , Key (..)- -- * Definition- , EntityDef (..)- , ColumnName- , ColumnType- , ColumnDef (..)- , UniqueDef (..)- , fst3, snd3, third3- , limitOffsetOrder-- -- * Config- , PersistConfig (..)- ) where--import Data.Time (Day, TimeOfDay, UTCTime)-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, unsafeByteString)-import Text.Blaze.Renderer.Utf8 (renderHtml)-import qualified Data.Text as T-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import Data.Enumerator hiding (consume, map)-import Data.Enumerator.List (consume)-import qualified Data.Enumerator.List as EL-import qualified Control.Monad.IO.Class as Trans--import qualified Control.Exception as E-import Control.Monad.Trans.Error (Error (..))--import Data.Bits (bitSize)-import Control.Monad (liftM)--import qualified Data.Text.Encoding as T-import qualified Data.Text.Encoding.Error as T-import Web.PathPieces (SinglePiece (..))-import qualified Data.Text.Read-import Control.Monad.IO.Class (MonadIO)--#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 Data.Object (TextObject)--fst3 :: forall t t1 t2. (t, t1, t2) -> t-fst3 (x, _, _) = x-snd3 :: forall t t1 t2. (t, t1, t2) -> t1-snd3 (_, x, _) = x-third3 :: forall t t1 t2. (t, t1, t2) -> t2-third3 (_, _, x) = x--data PersistException- = PersistError String -- ^ Generic Exception- | PersistMarshalError String- | PersistInvalidField String- | PersistForeignConstraintUnmet String- | PersistMongoDBError String- | PersistMongoDBUnsupported String- deriving (Show, Typeable)--instance E.Exception PersistException-instance Error PersistException where strMsg msg = PersistError msg------ | 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- | PersistNull- | PersistList [PersistValue]- | PersistMap [(T.Text, PersistValue)]- | PersistObjectId ByteString -- ^ intended especially for MongoDB backend- deriving (Show, Read, Eq, Typeable, Ord)--instance SinglePiece PersistValue where- fromSinglePiece t =- case Data.Text.Read.signed Data.Text.Read.decimal t of- Right (i, t')- | T.null t' -> Just $ PersistInt64 i- _ -> Just $ PersistText t- toSinglePiece x =- case fromPersistValue x of- Left e -> error e- Right y -> y---- | 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- | SqlInteger -- ^ FIXME 8-byte integer; should be renamed SqlInt64- | SqlReal- | SqlBool- | SqlDay- | SqlTime- | SqlDayTime- | SqlBlob- deriving (Show, Read, Eq, Typeable)---- | A value which can be marshalled to and from a 'PersistValue'.-class PersistField a where- toPersistValue :: a -> PersistValue- fromPersistValue :: PersistValue -> Either String a- sqlType :: a -> SqlType- isNullable :: a -> Bool- isNullable _ = False--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 $ 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 PersistNull = Left "Unexpected null"- fromPersistValue (PersistBool b) = Right $ 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--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 $ T.pack $ show i- fromPersistValue (PersistDouble d) = Right $ T.pack $ show d- fromPersistValue (PersistDay d) = Right $ T.pack $ show d- fromPersistValue (PersistTimeOfDay d) = Right $ T.pack $ show d- fromPersistValue (PersistUTCTime d) = Right $ T.pack $ show d- fromPersistValue PersistNull = Left "Unexpected null"- fromPersistValue (PersistBool b) = Right $ T.pack $ 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 Html where- toPersistValue = PersistByteString . S.concat . L.toChunks . renderHtml- fromPersistValue = fmap unsafeByteString . 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- _ -> SqlInteger--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 _ = SqlInteger--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 _ = SqlInteger--instance PersistField Word64 where- toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x- sqlType _ = SqlInteger--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 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--data Update v = forall typ. PersistField typ => Update- { updateField :: EntityField v typ- , updateValue :: typ- , updateUpdate :: PersistUpdate -- FIXME Replace with expr down the road- }--updateFieldName :: PersistEntity v => Update v -> String-updateFieldName (Update f _ _) = columnName $ persistColumnDef f--data SelectOpt v = forall typ. Asc (EntityField v typ)- | forall typ. Desc (EntityField v typ)- | OffsetBy Int- | LimitTo Int---- | 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]---- | 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 :: * -> *- persistColumnDef :: EntityField val typ -> ColumnDef-- -- | Unique keys in existence on this entity.- data Unique val :: ((* -> *) -> * -> *) -> *-- entityDef :: val -> EntityDef- toPersistFields :: val -> [SomePersistField]- fromPersistValues :: [PersistValue] -> Either String val- halfDefined :: val-- persistUniqueToFieldNames :: Unique val backend -> [String]- persistUniqueToValues :: Unique val backend -> [PersistValue]- persistUniqueKeys :: val -> [Unique val backend]--data SomePersistField = forall a. PersistField a => SomePersistField a-instance PersistField SomePersistField where- toPersistValue (SomePersistField a) = toPersistValue a- fromPersistValue x = fmap SomePersistField (fromPersistValue x :: Either String String)- sqlType (SomePersistField a) = sqlType a--newtype Key (backend :: (* -> *) -> * -> *) entity = Key { unKey :: PersistValue }- deriving (Show, Read, Eq, Ord, PersistField)--class (Trans.MonadIO (b m), Trans.MonadIO m, Monad (b m), Monad m) => PersistBackend b m where-- -- | Create a new record in the database, returning the newly created- -- identifier.- insert :: PersistEntity val => val -> b m (Key b val)-- -- | Replace the record in the database with the given key. Result is- -- undefined if such a record does not exist.- replace :: PersistEntity val => Key b val -> val -> b m ()-- -- | Update individual fields on a specific record.- update :: PersistEntity val => Key b val -> [Update val] -> b m ()-- -- | Update individual fields on any record matching the given criterion.- updateWhere :: PersistEntity val => [Filter val] -> [Update val] -> b m ()-- -- | Delete a specific record by identifier. Does nothing if record does- -- not exist.- delete :: PersistEntity val => Key b val -> b m ()-- -- | Delete a specific record by unique key. Does nothing if no record- -- matches.- deleteBy :: PersistEntity val => Unique val b -> b m ()-- -- | Delete all records matching the given criterion.- deleteWhere :: PersistEntity val => [Filter val] -> b m ()-- -- | Get a record by identifier, if available.- get :: PersistEntity val => Key b val -> b m (Maybe val)-- -- | Get a record by unique key, if available. Returns also the identifier.- getBy :: PersistEntity val => Unique val b -> b m (Maybe (Key b val, val))-- -- | Get all records matching the given criterion in the specified order.- -- Returns also the identifiers.- selectEnum- :: PersistEntity val- => [Filter val]- -> [SelectOpt val]- -> Enumerator (Key b val, val) (b m) a-- -- | get just the first record for the criterion- selectFirst :: PersistEntity val- => [Filter val]- -> [SelectOpt val]- -> b m (Maybe (Key b val, val))- selectFirst filts opts = run_ $ selectEnum filts ((LimitTo 1):opts) ==<< EL.head--- -- | Get the 'Key's of all records matching the given criterion.- selectKeys :: PersistEntity val- => [Filter val]- -> Enumerator (Key b val) (b m) a-- -- | The total number of records fulfilling the given criterion.- count :: PersistEntity val => [Filter val] -> b m Int---- | 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, PersistBackend b m)- => v -> b m (Either (Key b v, v) (Key b 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, PersistBackend b m)- => v -> b m (Maybe (Key b v, 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 ::- (PersistBackend b m- , PersistEntity ent1- , PersistEntity ent2) => (ent1 -> Maybe (Key b ent2)) -> ent1 -> b 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 ::- (PersistBackend b m- , PersistEntity ent1- , PersistEntity ent2) => (ent1 -> Key b ent2) -> ent1 -> b 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 :: (PersistBackend b m, PersistEntity val, Show (Key b val)) => Key b val -> b m val-getJust key = get key >>= maybe- (Trans.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 :: (PersistEntity val, PersistBackend b m) => val -> b 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--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)---- | Call 'select' but return the result as a list.-selectList :: (PersistEntity val, PersistBackend b m)- => [Filter val]- -> [SelectOpt val]- -> b m [(Key b val, val)]-selectList a b = do- res <- run $ selectEnum a b ==<< consume- case res of- Left e -> Trans.liftIO . E.throwIO $ PersistError $ show e- Right x -> return x--data EntityDef = EntityDef- { entityName :: String- , entityAttribs :: [String]- , entityColumns :: [ColumnDef]- , entityUniques :: [UniqueDef]- , entityDerives :: [String]- }- deriving Show--type ColumnName = String-type ColumnType = String--data ColumnDef = ColumnDef -- FIXME rename to FieldDef? Also, do we need a columnHaskellName and columnDBName?- { columnName :: ColumnName- , columnType :: ColumnType- , columnAttribs :: [String]- }- deriving Show--data UniqueDef = UniqueDef- { uniqueName :: String- , uniqueColumns :: [ColumnName]- }- deriving Show--data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le | In | NotIn- | BackendSpecificFilter String- deriving (Read, Show)--class PersistEntity a => DeleteCascade a b where- deleteCascade :: PersistBackend b m => Key b a -> b m ()--deleteCascadeWhere :: (DeleteCascade a b, PersistBackend b m)- => [Filter a] -> b m ()-deleteCascadeWhere filts = do- res <- run $ selectKeys filts $ Continue iter- case res of- Left e -> Trans.liftIO . E.throwIO $ PersistError $ show e- Right () -> return ()- where- iter EOF = Iteratee $ return $ Yield () EOF- iter (Chunks keys) = Iteratee $ do- mapM_ deleteCascade keys- return $ Continue iter---data PersistUpdate = Assign | Add | Subtract | Multiply | Divide -- FIXME need something else here- deriving (Read, Show, Enum, Bounded)--instance PersistField PersistValue where- toPersistValue = id- fromPersistValue = Right- sqlType _ = SqlInteger -- 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- loadConfig :: TextObject -> Either String c- -- | I really don't want Applicative here, but it's necessary for Mongo.- withPool :: (Applicative m, MBCIO m, MonadIO m) => c -> (PersistConfigPool c -> m a) -> m a- runPool :: (MBCIO m, MonadIO m) => c -> PersistConfigBackend c m a- -> PersistConfigPool c- -> m a
+ Database/Persist/EntityDef.hs view
@@ -0,0 +1,53 @@+module Database.Persist.EntityDef+ ( -- * Helper types+ HaskellName (..)+ , DBName (..)+ , FieldType (..)+ , Attr+ -- * Defs+ , EntityDef (..)+ , FieldDef (..)+ , UniqueDef (..)+ , ExtraLine+ ) where++import Data.Text (Text)+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]+ }+ 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)+newtype FieldType = FieldType { unFieldType :: Text }+ deriving (Show, Eq, Read, Ord)++type Attr = Text++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)]+ }+ deriving (Show, Eq, Read, Ord)
Database/Persist/GenericSql.hs view
@@ -17,6 +17,15 @@ , Statement , runSqlConn , runSqlPool+ , Key (..)++ -- * Raw SQL queries+ -- $rawSql+ , rawSql+ , Entity(..)+ , Single(..)++ -- * Migrations , Migration , parseMigration , parseMigration'@@ -28,22 +37,20 @@ , migrate , commit , rollback- , Key (..) ) where -import Database.Persist.Base-import Data.List (intercalate)+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 Control.Monad.Trans.Class (MonadTrans (..))-import Data.Pool-import Control.Monad.Trans.Writer-import System.IO+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 (liftM, unless)-import Data.Enumerator (Stream (..), Iteratee (..), Step (..)) #if MIN_VERSION_monad_control(0, 3, 0) import Control.Monad.Trans.Control (MonadBaseControl, control) import qualified Control.Exception as E@@ -54,33 +61,33 @@ #define MBCIO MonadControlIO #endif-import Control.Exception (throw, toException)-import Data.Text (Text, pack, unpack, snoc)-import qualified Data.Text.IO-import Web.PathPieces (SinglePiece (..))+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.Monoid (Monoid, mappend)+import Database.Persist.EntityDef+import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL type ConnectionPool = Pool Connection -instance SinglePiece (Key SqlPersist entity) where- toSinglePiece (Key (PersistInt64 i)) = toSinglePiece i- toSinglePiece k = throw $ PersistInvalidField $ "Invalid Key: " ++ show k- fromSinglePiece t =+instance PathPiece (Key SqlPersist 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 -withStmt'- :: (MBCIO m, MonadIO m)- => Text -> [PersistValue]- -> (RowPopper (SqlPersist m) -> SqlPersist m a) -> SqlPersist m a-withStmt' = R.withStmt- execute' :: MonadIO 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 :: (MBCIO m, MonadIO m) => SqlPersist m a -> Pool Connection -> m a-runSqlPool r pconn = withPool' pconn $ runSqlConn r+runSqlPool r pconn = withResource pconn $ runSqlConn r runSqlConn :: (MBCIO m, MonadIO m) => SqlPersist m a -> Connection -> m a runSqlConn (SqlPersist r) conn = do@@ -92,19 +99,19 @@ liftIO $ commitC conn getter return x -instance (MonadIO m, MBCIO m) => PersistBackend SqlPersist m where+instance C.ResourceIO m => PersistStore SqlPersist m where insert val = do conn <- SqlPersist ask- let esql = insertSql conn (rawTableName t) (map fst3 $ tableColumns t)+ let esql = insertSql conn (entityDB t) (map fieldDB $ entityFields t) i <- case esql of- Left sql -> withStmt' sql vals $ \pop -> do- Just [PersistInt64 i] <- pop+ Left sql -> C.runResourceT $ R.withStmt sql vals C.$$ do+ Just [PersistInt64 i] <- CL.head return i Right (sql1, sql2) -> do execute' sql1 vals- withStmt' sql2 [] $ \pop -> do- Just [PersistInt64 i] <- pop+ C.runResourceT $ R.withStmt sql2 [] C.$$ do+ Just [PersistInt64 i] <- CL.head return i return $ Key $ PersistInt64 i where@@ -114,257 +121,126 @@ replace k val = do conn <- SqlPersist ask let t = entityDef val- let sql = pack $ concat+ let sql = concat [ "UPDATE "- , escapeName conn (rawTableName t)+ , escapeName conn (entityDB t) , " SET "- , intercalate "," (map (go conn . fst3) $ tableColumns t)+ , T.intercalate "," (map (go conn . fieldDB) $ entityFields t) , " WHERE id=?" ] execute' sql $ map toPersistValue (toPersistFields val)- ++ [unKey k]+ `mappend` [unKey k] where go conn x = escapeName conn x ++ "=?" + insertKey = insrepHelper "INSERT"++ repsert = insrepHelper "REPLACE"+ get k = do conn <- SqlPersist ask let t = entityDef $ dummyFromKey k- let cols = intercalate ","- $ map (\(x, _, _) -> escapeName conn x) $ tableColumns t- let sql = pack $ concat+ let cols = T.intercalate ","+ $ map (escapeName conn . fieldDB) $ entityFields t+ let sql = concat [ "SELECT " , cols , " FROM "- , escapeName conn $ rawTableName t+ , escapeName conn $ entityDB t , " WHERE id=?" ]- withStmt' sql [unKey k] $ \pop -> do- res <- pop+ C.runResourceT $ R.withStmt sql [unKey k] C.$$ do+ res <- CL.head case res of Nothing -> return Nothing Just vals -> case fromPersistValues vals of- Left e -> error $ "get " ++ show (unKey k) ++ ": " ++ e+ Left e -> error $ unpack $ "get " ++ show (unKey k) ++ ": " ++ e Right v -> return $ Just v - count filts = do- conn <- SqlPersist ask- let wher = if null filts- then ""- else filterClause False conn filts- let sql = pack $ concat- [ "SELECT COUNT(*) FROM "- , escapeName conn $ rawTableName t- , wher- ]- withStmt' sql (getFiltsValues conn filts) $ \pop -> do- Just [PersistInt64 i] <- pop- return $ fromIntegral i- where- t = entityDef $ dummyFromFilts filts-- selectEnum filts opts =- Iteratee . start- where- (limit, offset, orders) = limitOffsetOrder opts-- start x = do- conn <- SqlPersist ask- withStmt' (sql conn) (getFiltsValues conn filts) $ loop x- loop (Continue k) pop = do- res <- pop- case res of- Nothing -> return $ Continue k- Just vals -> do- case fromPersistValues' vals of- Left s -> return $ Error $ toException- $ PersistMarshalError s- Right row -> do- step <- runIteratee $ k $ Chunks [row]- loop step pop- loop step _ = return step- t = entityDef $ dummyFromFilts filts- fromPersistValues' (PersistInt64 x:xs) = do- case fromPersistValues xs of- Left e -> Left e- Right xs' -> Right (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 " ++ intercalate "," ords- lim conn = case (limit, offset) of- (0, 0) -> ""- (0, _) -> ' ' : noLimit conn- (_, _) -> " LIMIT " ++ show limit- off = if offset == 0- then ""- else " OFFSET " ++ show offset- cols conn = intercalate "," $ (unRawName $ rawTableIdName t)- : (map (\(x, _, _) -> escapeName conn x) $ tableColumns t)- sql conn = pack $ concat- [ "SELECT "- , cols conn- , " FROM "- , escapeName conn $ rawTableName t- , wher conn- , ord conn- , lim conn- , off- ]-- selectKeys filts =- Iteratee . start- where- start x = do- conn <- SqlPersist ask- withStmt' (sql conn) (getFiltsValues conn filts) $ loop x- loop (Continue k) pop = do- res <- pop- case res of- Nothing -> return $ Continue k- Just [PersistInt64 i] -> do- step <- runIteratee $ k $ Chunks [Key $ PersistInt64 i]- loop step pop- Just y -> return $ Error $ toException $ PersistMarshalError- $ "Unexpected in selectKeys: " ++ show y- loop step _ = return step- t = entityDef $ dummyFromFilts filts- wher conn = if null filts- then ""- else filterClause False conn filts- sql conn = pack $ concat- [ "SELECT id FROM "- , escapeName conn $ rawTableName t- , wher conn- ]- delete k = do conn <- SqlPersist ask execute' (sql conn) [unKey k] where t = entityDef $ dummyFromKey k- sql conn = pack $ concat+ sql conn = concat [ "DELETE FROM "- , escapeName conn $ rawTableName t+ , escapeName conn $ entityDB t , " WHERE id=?" ] - deleteWhere filts = do- conn <- SqlPersist ask- let t = entityDef $ dummyFromFilts filts- let wher = if null filts- then ""- else filterClause False conn filts- sql = pack $ concat- [ "DELETE FROM "- , escapeName conn $ rawTableName t- , wher- ]- execute' sql $ getFiltsValues conn filts+insrepHelper :: (MonadIO m, PersistEntity val)+ => Text+ -> Key SqlPersist 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.ResourceIO m => PersistUnique SqlPersist m where deleteBy uniq = do conn <- SqlPersist ask execute' (sql conn) $ persistUniqueToValues uniq where t = entityDef $ dummyFromUnique uniq- go = map (getFieldName t) . persistUniqueToFieldNames+ go = map snd . persistUniqueToFieldNames go' conn x = escapeName conn x ++ "=?"- sql conn = pack $ concat+ sql conn = concat [ "DELETE FROM "- , escapeName conn $ rawTableName t+ , escapeName conn $ entityDB t , " WHERE "- , intercalate " AND " $ map (go' conn) $ go uniq+ , T.intercalate " AND " $ map (go' conn) $ go uniq ] - update _ [] = return ()- update k upds = do- conn <- SqlPersist ask- let go'' n Assign = n ++ "=?"- go'' n Add = n ++ '=' : n ++ "+?"- go'' n Subtract = n ++ '=' : n ++ "-?"- go'' n Multiply = n ++ '=' : n ++ "*?"- go'' n Divide = n ++ '=' : n ++ "/?"- let go' (x, pu) = go'' (escapeName conn x) pu- let sql = pack $ concat- [ "UPDATE "- , escapeName conn $ rawTableName t- , " SET "- , intercalate "," $ map (go' . go) upds- , " WHERE id=?"- ]- execute' sql $- map updatePersistValue upds ++ [unKey k]- where- t = entityDef $ dummyFromKey k- go x = ( getFieldName t $ updateFieldName x- , updateUpdate x- )-- updateWhere _ [] = return ()- updateWhere filts upds = do- conn <- SqlPersist ask- let wher = if null filts- then ""- else filterClause False conn filts- let sql = pack $ concat- [ "UPDATE "- , escapeName conn $ rawTableName t- , " SET "- , intercalate "," $ map (go' conn . go) upds- , wher- ]- let dat = map updatePersistValue upds ++ getFiltsValues conn filts- execute' sql dat- where- t = entityDef $ dummyFromFilts filts- go'' n Assign = n ++ "=?"- go'' n Add = n ++ '=' : n ++ "+?"- go'' n Subtract = n ++ '=' : n ++ "-?"- go'' n Multiply = n ++ '=' : n ++ "*?"- go'' n Divide = n ++ '=' : n ++ "/?"- go' conn (x, pu) = go'' (escapeName conn x) pu- go x = ( getFieldName t $ updateFieldName x- , updateUpdate x- )- getBy uniq = do conn <- SqlPersist ask- let cols = intercalate "," $ (unRawName $ rawTableIdName t)- : (map (\(x, _, _) -> escapeName conn x) $ tableColumns t)- let sql = pack $ concat+ let cols = T.intercalate "," $ (escapeName conn $ entityID t)+ : map (escapeName conn . fieldDB) (entityFields t)+ let sql = concat [ "SELECT " , cols , " FROM "- , escapeName conn $ rawTableName t+ , escapeName conn $ entityDB t , " WHERE " , sqlClause conn ]- withStmt' sql (persistUniqueToValues uniq) $ \pop -> do- row <- pop+ C.runResourceT $ R.withStmt sql (persistUniqueToValues uniq) C.$$ do+ row <- CL.head case row of Nothing -> return Nothing Just (PersistInt64 k:vals) -> case fromPersistValues vals of- Left s -> error s- Right x -> return $ Just (Key $ PersistInt64 k, x)+ 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 =- intercalate " AND " $ map (go conn) $ toFieldNames' uniq+ T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq go conn x = escapeName conn x ++ "=?" t = entityDef $ dummyFromUnique uniq- toFieldNames' = map (getFieldName t) . persistUniqueToFieldNames--dummyFromUnique :: Unique v b -> v-dummyFromUnique _ = error "dummyFromUnique"+ toFieldNames' = map snd . persistUniqueToFieldNames dummyFromKey :: Key SqlPersist v -> v dummyFromKey _ = error "dummyFromKey" +{- FIXME+<<<<<<< HEAD type Sql = Text @@ -391,7 +267,7 @@ parseMigration' m = do x <- parseMigration m case x of- Left errs -> error $ unlines $ map unpack errs+ Left errs -> error $ unpack $ unlines errs Right sql -> return sql printMigration :: (MBCIO m, MonadIO m) => Migration (SqlPersist m) -> SqlPersist m ()@@ -425,10 +301,10 @@ mig <- parseMigration' m case unsafeSql mig of [] -> mapM (executeMigrate silent) $ safeSql mig- errs -> error $ concat+ errs -> error $ unpack $ concat [ "\n\nDatabase migration: manual intervention required.\n" , "The following actions are considered unsafe:\n\n"- , unlines $ map (\s -> " " ++ unpack s ++ ";") $ errs+ , unlines $ map (\s -> " " ++ s ++ ";") $ errs ] runMigrationUnsafe :: (MBCIO m, MonadIO m)@@ -440,17 +316,18 @@ executeMigrate :: MonadIO m => Bool -> Text -> SqlPersist m Text executeMigrate silent s = do- unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ unpack s+ unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ s execute' s [] return s migrate :: (MonadIO m, MBCIO m, PersistEntity val)- => val+ => [EntityDef]+ -> val -> Migration (SqlPersist m)-migrate val = do+migrate allDefs val = do conn <- lift $ lift $ SqlPersist ask let getter = R.getStmt' conn- res <- liftIO $ migrateSql conn getter val+ res <- liftIO $ migrateSql conn allDefs getter val either tell (lift . tell) res updatePersistValue :: Update v -> PersistValue@@ -469,10 +346,301 @@ conn <- SqlPersist ask let getter = R.getStmt' conn liftIO $ rollbackC conn getter >> begin conn getter+=======+-} +dummyFromUnique :: Unique v b -> 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+++-- $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', which is analogous to the tuples that+-- '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.ResourceIO 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 = R.withStmt $ T.concat $+ makeSubsts colSubsts $+ T.splitOn placeholder stmt+ where+ 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+ C.runResourceT $ 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 backend 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."++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 view
@@ -2,80 +2,75 @@ {-# 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- , RowPopper+ , createSqlPool , mkColumns , Column (..)- , UniqueDef'- , refName- , tableColumns- , rawFieldName- , rawTableName- , rawTableIdName- , RawName (..)- , filterClause- , filterClauseNoWhere- , getFieldName- , dummyFromFilts- , orderClause- , getFiltsValues ) where import qualified Data.Map as Map import Data.IORef import Control.Monad.IO.Class-import Data.Pool-import Database.Persist.Base-import Data.Maybe (fromMaybe)-import Control.Arrow-#if MIN_VERSION_monad_control(0, 3, 0)-import Control.Monad.Trans.Control (MonadBaseControl, control, restoreM)-import qualified Control.Exception as E-#define MBCIO MonadBaseControl IO-#else-import Control.Monad.IO.Control (MonadControlIO)-import Control.Exception.Control (bracket)--#define MBCIO MonadControlIO-#endif+import Data.Conduit.Pool+import Database.Persist.Store+import Control.Exception.Lifted (bracket) import Database.Persist.Util (nullable)-import Data.List (intercalate) import Data.Text (Text)--type RowPopper m = m (Maybe [PersistValue])+import qualified Data.Text as T+import Data.Monoid (Monoid, mappend, mconcat)+import Database.Persist.EntityDef+import qualified Data.Conduit as C data Connection = Connection { prepare :: Text -> IO Statement- , insertSql :: RawName -> [RawName] -> Either Text (Text, Text)+ -- ^ table name, column names, either 1 or 2 statements to run+ , insertSql :: DBName -> [DBName] -> Either Text (Text, Text) , stmtMap :: IORef (Map.Map Text Statement) , close :: IO () , migrateSql :: forall v. PersistEntity v- => (Text -> IO Statement) -> 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 :: RawName -> String- , noLimit :: String+ , escapeName :: DBName -> Text+ , noLimit :: Text } data Statement = Statement { finalize :: IO () , reset :: IO () , execute :: [PersistValue] -> IO ()- , withStmt :: forall a m. (MBCIO m, MonadIO m)- => [PersistValue] -> (RowPopper m -> m a) -> m a+ , withStmt :: forall m. C.ResourceIO m+ => [PersistValue]+ -> C.Source m [PersistValue] } -withSqlPool :: (MonadIO m, MBCIO m)- => IO Connection -> Int -> (Pool Connection -> m a) -> m a-withSqlPool mkConn = createPool mkConn close'+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 -withSqlConn :: (MonadIO m, MBCIO m) => IO Connection -> (Connection -> m a) -> m a+createSqlPool :: MonadIO m+ => IO Connection+ -> Int+ -> m (Pool Connection)+createSqlPool mkConn = liftIO . createPool mkConn close' 1 20++withSqlConn :: C.ResourceIO m+ => IO Connection -> (Connection -> m a) -> m a withSqlConn open = bracket (liftIO open) (liftIO . close') close' :: Connection -> IO ()@@ -83,51 +78,70 @@ 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 => val -> ([Column], [UniqueDef'])-mkColumns val =- (cols, uniqs)+mkColumns :: PersistEntity val => [EntityDef] -> val -> ([Column], [UniqueDef])+mkColumns allDefs val =+ (cols, entityUniques t) where- colNameMap = map (columnName &&& rawFieldName) $ entityColumns t- uniqs = map (RawName *** map (unjustLookup colNameMap))- $ map (uniqueName &&& uniqueColumns)- $ entityUniques t- cols = zipWith go (tableColumns t) $ toPersistFields $ halfDefined `asTypeOf` val-- -- Like fromJust . lookup, but gives a more useful error message- unjustLookup m a = fromMaybe (error $ "Column not found: " ++ a)- $ lookup a m+ cols :: [Column]+ cols = zipWith go (entityFields t)+ $ toPersistFields+ $ halfDefined `asTypeOf` val + t :: EntityDef t = entityDef val- tn = rawTableName t- go (name, t', as) p =- Column name (nullable as) (sqlType p) (def as) (ref name t' as)++ tn :: DBName+ tn = entityDB t++ go :: FieldDef -> SomePersistField -> Column+ go fd p =+ Column+ (fieldDB fd)+ (nullable $ fieldAttrs fd)+ (sqlType p)+ (def $ fieldAttrs fd)+ (ref (fieldDB fd) (fieldType fd) (fieldAttrs fd))++ def :: [Attr] -> Maybe Text def [] = Nothing- def (('d':'e':'f':'a':'u':'l':'t':'=':d):_) = Just d- def (_:rest) = def rest- ref c t' [] =- let l = length t'- (f, b) = splitAt (l - 2) t'- in if b == "Id"- then Just (RawName f, refName tn c)- else Nothing+ def (a:as)+ | Just d <- T.stripPrefix "default=" a = Just d+ | otherwise = def as++ ref :: DBName+ -> FieldType+ -> [Attr]+ -> Maybe (DBName, DBName) -- table name, constraint name+ ref c (FieldType t') []+ | Just f <- T.stripSuffix "Id" t' =+ Just (resolveTableName allDefs $ HaskellName f, refName tn c)+ | otherwise = Nothing ref _ _ ("noreference":_) = Nothing- ref c _ (('r':'e':'f':'e':'r':'e':'n':'c':'e':'=':x):_) =- Just (RawName x, refName tn c)- ref c x (_:y) = ref c x y+ ref c _ (a:_)+ | Just x <- T.stripPrefix "reference=" a =+ Just (DBName x, refName tn c)+ ref c x (_:as) = ref c x as -refName :: RawName -> RawName -> RawName-refName (RawName table) (RawName column) =- RawName $ table ++ '_' : column ++ "_fkey"+refName :: DBName -> DBName -> DBName+refName (DBName table) (DBName column) =+ DBName $ mconcat [table, "_", column, "_fkey"] data Column = Column- { cName :: RawName- , cNull :: Bool- , cType :: SqlType- , cDefault :: Maybe String- , cReference :: (Maybe (RawName, RawName)) -- table name, constraint name+ { cName :: DBName+ , cNull :: Bool+ , cType :: SqlType+ , cDefault :: Maybe Text+ , cReference :: (Maybe (DBName, DBName)) -- table name, constraint name } +{- FIXME getSqlValue :: [String] -> Maybe String getSqlValue (('s':'q':'l':'=':x):_) = Just x getSqlValue (_:x) = getSqlValue x@@ -137,148 +151,14 @@ 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--type UniqueDef' = (RawName, [RawName])--rawFieldName :: ColumnDef -> RawName-rawFieldName (ColumnDef n _ as) = RawName $- case getSqlValue as of- Just x -> x- Nothing -> n--rawTableName :: EntityDef -> RawName-rawTableName t = RawName $- case getSqlValue $ entityAttribs t of- Nothing -> entityName t- Just x -> x--rawTableIdName :: EntityDef -> RawName-rawTableIdName t = RawName $- case getIdNameValue $ entityAttribs t of- Nothing -> "id"- Just x -> x--newtype RawName = RawName { unRawName :: String } -- FIXME Text- deriving (Eq, Ord)--getFiltsValues :: forall val. PersistEntity val => Connection -> [Filter val] -> [PersistValue]-getFiltsValues conn = snd . filterClauseHelper False False conn--filterClause :: PersistEntity val- => Bool -- ^ include table name?- -> Connection -> [Filter val] -> String-filterClause b c = fst . filterClauseHelper b True c--filterClauseNoWhere :: PersistEntity val- => Bool -- ^ include table name?- -> Connection -> [Filter val] -> String-filterClauseNoWhere b c = fst . filterClauseHelper b False c--filterClauseHelper :: PersistEntity val- => Bool -- ^ include table name?- -> Bool -- ^ include WHERE?- -> Connection -> [Filter val] -> (String, [PersistValue])-filterClauseHelper includeTable includeWhere conn filters =- (if not (null sql) && includeWhere- then " WHERE " ++ sql- else sql, vals)- where- (sql, vals) = combineAND filters- combineAND = combine " AND "-- combine s fs =- (intercalate s $ map wrapP a, concat b)- where- (a, b) = unzip $ map go fs- wrapP x = concat ["(", x, ")"]-- go (FilterAnd []) = ("1=0", [])- go (FilterAnd fs) = combineAND fs- go (FilterOr []) = ("1=1", [])- 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, _) -> (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", [])- (False, In, _) -> (name ++ " IN " ++ qmarks, allVals)- (True, In, _) -> (concat- [ "("- , name- , " IS NULL OR "- , name- , " IN "- , qmarks- , ")"- ], notNullVals)- (_, NotIn, 0) -> ("1=1", [])- (False, NotIn, _) -> (concat- [ "("- , name- , " IS NULL OR "- , name- , " NOT IN "- , qmarks- , ")"- ], notNullVals)- (True, NotIn, _) -> (concat- [ "("- , name- , " IS NOT NULL AND "- , name- , " NOT IN "- , qmarks- , ")"- ], notNullVals)- _ -> (name ++ showSqlFilter pfilter ++ "?", allVals)- where- filterValueToPersistValues :: forall a. PersistField a => Either a [a] -> [PersistValue]- filterValueToPersistValues v = map toPersistValue $ either return id v-- isNull = any (== PersistNull) allVals- notNullVals = filter (/= PersistNull) allVals- allVals = filterValueToPersistValues value- t = entityDef $ dummyFromFilts [Filter field value pfilter]- name =- (if includeTable- then (++) (escapeName conn (rawTableName t) ++ ".")- else id)- $ escapeName conn $ getFieldName t $ columnName $ persistColumnDef field- qmarks = case value of- Left _ -> "?"- Right x ->- let x' = filter (/= PersistNull) $ map toPersistValue x- in '(' : 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--dummyFromFilts :: [Filter v] -> v-dummyFromFilts _ = error "dummyFromFilts"+-} +{- FIXME getFieldName :: EntityDef -> String -> RawName getFieldName t s = rawFieldName $ tableColumn t s @@ -291,33 +171,4 @@ go (ColumnDef x y z:rest) | x == s = ColumnDef x y z | otherwise = go rest--dummyFromOrder :: SelectOpt a -> a-dummyFromOrder _ = undefined--orderClause :: PersistEntity val => Bool -> Connection -> SelectOpt val -> String-orderClause includeTable conn o =- case o of- Asc x -> name x- Desc x -> name x ++ " DESC"- _ -> error $ "expected Asc or Desc, not limit or offset"- where- cd x = persistColumnDef x- t = entityDef $ dummyFromOrder o- name x =- (if includeTable- then (++) (escapeName conn (rawTableName t) ++ ".")- else id)- $ escapeName conn $ getFieldName t $ columnName $ cd x--#if MIN_VERSION_monad_control(0, 3, 0)-bracket :: MonadBaseControl IO m- => m a -- ^ computation to run first (\"acquire resource\")- -> (a -> m b) -- ^ computation to run last (\"release resource\")- -> (a -> m c) -- ^ computation to run in-between- -> m c-bracket before after thing = control $ \runInIO ->- E.bracket (runInIO before)- (\st -> runInIO $ restoreM st >>= after)- (\st -> runInIO $ restoreM st >>= thing)-#endif+-}
+ Database/Persist/GenericSql/Migration.hs view
@@ -0,0 +1,142 @@+{-# 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)+import qualified Data.Text.IO+import System.IO++execute' :: MonadIO 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)+ => 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)+ => Migration (SqlPersist m)+ -> SqlPersist m [Text]+runMigrationSilent m = runMigration' m True++runMigration'+ :: (MBCIO m, MonadIO m)+ => Migration (SqlPersist m)+ -> Bool -- ^ is silent?+ -> SqlPersist m [Text]+runMigration' m silent = do+ mig <- parseMigration' m+ case unsafeSql mig of+ [] -> mapM (executeMigrate silent) $ 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)+ => Migration (SqlPersist m)+ -> SqlPersist m ()+runMigrationUnsafe m = do+ mig <- parseMigration' m+ mapM_ (executeMigrate False) $ allSql mig++executeMigrate :: MonadIO m => Bool -> Text -> SqlPersist m Text+executeMigrate silent s = do+ unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ unpack s+ execute' s []+ return s++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 view
@@ -16,7 +16,7 @@ import qualified Database.Persist.GenericSql.Internal as I import Database.Persist.GenericSql.Internal hiding (execute, withStmt)-import Database.Persist.Base (PersistValue)+import Database.Persist.Store (PersistValue) import Data.IORef import Control.Monad.IO.Class import Control.Monad.Trans.Reader@@ -34,6 +34,8 @@ #endif import Data.Text (Text) import Control.Monad (MonadPlus)+import Control.Monad.Trans.Resource (ResourceThrow (..), ResourceIO)+import qualified Data.Conduit as C newtype SqlPersist m a = SqlPersist { unSqlPersist :: ReaderT Connection m a } deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadPlus@@ -42,6 +44,9 @@ #endif ) +instance ResourceThrow m => ResourceThrow (SqlPersist m) where+ resourceThrow = lift . resourceThrow+ instance MonadBase b m => MonadBase b (SqlPersist m) where liftBase = lift . liftBase @@ -56,13 +61,24 @@ restoreT = SqlPersist . ReaderT . const . liftM unStReader #endif -withStmt :: (MonadIO m, MBCIO m) => Text -> [PersistValue]- -> (RowPopper (SqlPersist m) -> SqlPersist m a) -> SqlPersist m a-withStmt sql vals pop = do- stmt <- getStmt sql- ret <- I.withStmt stmt vals pop- liftIO $ reset stmt- return ret+withStmt :: ResourceIO m+ => Text+ -> [PersistValue]+ -> C.Source (SqlPersist m) [PersistValue]+withStmt sql vals = C.Source $ do+ stmt <- lift $ getStmt sql+ src <- C.prepareSource $ I.withStmt stmt vals+ return C.PreparedSource+ { C.sourcePull = do+ res <- C.sourcePull src+ case res of+ C.Closed -> liftIO $ I.reset stmt+ _ -> return ()+ return res+ , C.sourceClose = do+ liftIO $ I.reset stmt+ C.sourceClose src+ } execute :: MonadIO m => Text -> [PersistValue] -> SqlPersist m () execute sql vals = do
− Database/Persist/Join.hs
@@ -1,57 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-module Database.Persist.Join- ( -- * Typeclass- RunJoin (..)- -- * One-to-many relation- , SelectOneMany (..)- , selectOneMany- ) where--import Database.Persist.Base-import Data.Maybe (mapMaybe)-import qualified Data.Map as Map-import Data.List (foldl')--class PersistBackend b m => RunJoin a b m where- type Result a- runJoin :: a -> b m (Result a)--data SelectOneMany backend one many = SelectOneMany- { somFilterOne :: [Filter one]- , somOrderOne :: [SelectOpt one]- , somFilterMany :: [Filter many]- , somOrderMany :: [SelectOpt many]- , somFilterKeys :: [Key backend one] -> Filter many- , somGetKey :: many -> Key backend one- , somIncludeNoMatch :: Bool- }--selectOneMany :: ([Key backend one] -> Filter many) -> (many -> Key backend one) -> SelectOneMany backend one many-selectOneMany filts get' = SelectOneMany [] [] [] [] filts get' False-instance (PersistEntity one, PersistEntity many, Ord (Key backend one), PersistBackend backend monad)- => RunJoin (SelectOneMany backend one many) backend monad where- type Result (SelectOneMany backend one many) =- [((Key backend one, one), [(Key backend many, 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 fst x) : manyF) manyO- let y' = foldl' go Map.empty y- return $ mapMaybe (go' y') x- where- go m many@(_, many') =- Map.insert (getKey many')- (case Map.lookup (getKey many') m of- Nothing -> (:) many- Just v -> v . (:) many- ) m- go' y' one@(k, _) =- case Map.lookup k y' of- Nothing ->- if isOuter- then Just (one, [])- else Nothing- Just many -> Just (one, many [])
− Database/Persist/Join/Sql.hs
@@ -1,113 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE CPP #-}-module Database.Persist.Join.Sql- ( RunJoin (..)- ) where--import Database.Persist.Join hiding (RunJoin (..))-import qualified Database.Persist.Join as J-import Database.Persist.Base-import Control.Monad (liftM)-import Data.Maybe (mapMaybe)-import Data.List (intercalate, groupBy)-import Database.Persist.GenericSql-import Database.Persist.GenericSql.Internal hiding (withStmt)-import Database.Persist.GenericSql.Raw (withStmt)-import Control.Monad.Trans.Reader (ask)-#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 Data.Function (on)-import Control.Arrow ((&&&))-import Data.Text (pack)-import Control.Monad.IO.Class (MonadIO)--fromPersistValuesId :: PersistEntity v => [PersistValue] -> Either String (Key SqlPersist v, v)-fromPersistValuesId [] = Left "fromPersistValuesId: No values provided"-fromPersistValuesId (PersistInt64 i:rest) =- case fromPersistValues rest of- Left e -> Left e- Right x -> Right (Key $ PersistInt64 i, x)-fromPersistValuesId _ = Left "fromPersistValuesId: invalid ID"--class RunJoin a where- runJoin :: (MonadIO m, MBCIO m) => a -> SqlPersist m (J.Result a)--instance (PersistEntity one, PersistEntity many, Eq (Key SqlPersist one))- => RunJoin (SelectOneMany SqlPersist one many) where- runJoin (SelectOneMany oneF oneO manyF manyO eq _getKey isOuter) = do- conn <- SqlPersist ask- liftM go $ withStmt (sql conn) (getFiltsValues conn oneF ++ getFiltsValues conn manyF) $ loop id- where- go :: Eq a => [((a, b), Maybe (c, d))] -> [((a, b), [(c, d)])]- go = map (fst . head &&& mapMaybe snd) . groupBy ((==) `on` (fst . fst))- loop front popper = do- x <- popper- 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')) popper- (Left e, _) -> error $ "selectOneMany: " ++ e- (Right y', Left e) ->- case z of- PersistNull:_ -> loop (front . (:) (y', Nothing)) popper- _ -> error $ "selectOneMany: " ++ e- oneCount = 1 + length (tableColumns $ entityDef one)- one = dummyFromFilts oneF- many = dummyFromFilts manyF- sql conn = pack $ concat- [ "SELECT "- , intercalate "," $ colsPlusId conn one ++ colsPlusId conn many- , " FROM "- , escapeName conn $ rawTableName $ entityDef one- , if isOuter then " LEFT JOIN " else " INNER JOIN "- , escapeName conn $ rawTableName $ entityDef many- , " ON "- , escapeName conn $ rawTableName $ entityDef one- , ".id = "- , escapeName conn $ rawTableName $ entityDef many- , "."- , escapeName conn $ RawName $ filterName $ eq undefined- , filts- , if null ords- then ""- else " ORDER BY " ++ intercalate ", " ords- ]- where- filts1 = filterClauseNoWhere True conn oneF- filts2 = filterClauseNoWhere True conn manyF-- orders :: PersistEntity val => [SelectOpt val] -> [SelectOpt val]- orders = third3 . limitOffsetOrder-- filts- | null filts1 && null filts2 = ""- | null filts1 = " WHERE " ++ filts2- | null filts2 = " WHERE " ++ filts1- | otherwise = " WHERE " ++ filts1 ++ " AND " ++ filts2- ords = map (orderClause True conn) (orders oneO) ++ map (orderClause True conn) (orders manyO)--addTable :: PersistEntity val =>- Connection -> val -> [Char] -> [Char]-addTable conn e s = concat [escapeName conn $ rawTableName $ entityDef e, ".", s]--colsPlusId :: PersistEntity e => Connection -> e -> [String]-colsPlusId conn e =- map (addTable conn e) $- id_ : (map (\(x, _, _) -> escapeName conn x) cols)- where- id_ = unRawName $ rawTableIdName $ entityDef e- cols = tableColumns $ entityDef e--filterName :: PersistEntity v => Filter v -> String-filterName (Filter f _ _) = columnName $ persistColumnDef f-filterName (FilterAnd _) = error "expected a raw filter, not an And"-filterName (FilterOr _) = error "expected a raw filter, not an Or"
Database/Persist/Quasi.hs view
@@ -1,39 +1,72 @@+{-# LANGUAGE OverloadedStrings #-} module Database.Persist.Quasi ( parse+ , PersistSettings (..)+ , upperCaseSettings+ , lowerCaseSettings ) where -import Database.Persist.Base+import Prelude hiding (lines)+import Database.Persist.EntityDef import Data.Char import Data.Maybe (mapMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Control.Arrow ((&&&))+import qualified Data.Map as Map +data PersistSettings = PersistSettings+ { psToDBName :: Text -> Text+ }++upperCaseSettings :: PersistSettings+upperCaseSettings = PersistSettings+ { psToDBName = id+ }++lowerCaseSettings :: PersistSettings+lowerCaseSettings = PersistSettings+ { psToDBName =+ let go c+ | isUpper c = T.pack ['_', toLower c]+ | otherwise = T.singleton c+ in T.dropWhile (== '_') . T.concatMap go+ }+ -- | Parses a quasi-quoted syntax into a list of entity definitions.-parse :: String -> [EntityDef]-parse = parse'+parse :: PersistSettings -> Text -> [EntityDef]+parse ps = parse' ps . removeSpaces . filter (not . empty) . map tokenize- . lines+ . T.lines -- | A token used by the parser. data Token = Spaces !Int -- ^ @Spaces n@ are @n@ consecutive spaces.- | Token String -- ^ @Token tok@ is token @tok@ already unquoted.+ | Token Text -- ^ @Token tok@ is token @tok@ already unquoted. -- | Tokenize a string.-tokenize :: String -> [Token]-tokenize [] = []-tokenize ('-':'-':_) = [] -- Comment until the end of the line.-tokenize ('"':xs) = go xs ""- where- go ('\"':rest) acc = Token (reverse acc) : tokenize rest- go ('\\':y:ys) acc = go ys (y:acc)- go (y:ys) acc = go ys (y:acc)- go [] acc = error $ "Unterminated quoted (\") string starting with " ++- show (reverse acc) ++ "."-tokenize (x:xs)- | isSpace x = let (spaces, rest) = span isSpace xs- in Spaces (1 + length spaces) : tokenize rest-tokenize xs = let (token, rest) = break isSpace xs- in Token token : tokenize rest+tokenize :: Text -> [Token]+tokenize t+ | T.null t = []+ | "--" `T.isPrefixOf` t = [] -- Comment until the end of the line.+ | T.head t == '"' = quotes (T.tail t) id+ | isSpace (T.head t) =+ let (spaces, rest) = T.span isSpace t+ in Spaces (T.length spaces) : tokenize rest+ | otherwise =+ let (token, rest) = T.break isSpace t+ in Token token : tokenize rest+ where+ quotes t' front+ | T.null t' = error $ T.unpack $ T.concat $+ "Unterminated quoted string starting with " : front []+ | T.head t' == '"' = Token (T.concat $ front []) : tokenize (T.tail t')+ | T.head t' == '\\' && T.length t' > 1 =+ quotes (T.drop 2 t') (front . (T.take 2 t':))+ | otherwise =+ let (x, y) = T.break (`elem` "\\\"") t'+ in quotes y (front . (x:)) -- | A string of tokens is empty when it has only spaces. There -- can't be two consecutive 'Spaces', so this takes /O(1)/ time.@@ -44,72 +77,102 @@ -- | A line. We don't care about spaces in the middle of the -- line. Also, we don't care about the ammount of indentation.-data Line = Line { lineType :: LineType- , tokens :: [String] }---- | A line may be part of a header or body.-data LineType = Header | Body- deriving (Eq)+data Line = Line { lineIndent :: Int+ , tokens :: [Text]+ } -- | Remove leading spaces and remove spaces in the middle of the -- tokens. removeSpaces :: [[Token]] -> [Line]-removeSpaces xs = map (makeLine . subtractSpace) xs- where- -- | Ammount of leading spaces.- s = minimum $ map headSpace xs-- -- | Ammount of leading space in a single token string.- headSpace (Spaces n : _) = n- headSpace _ = 0-- -- | Subtract the leading space.- subtractSpace ys | s == 0 = ys- subtractSpace (Spaces n : rest)- | n == s = rest- | otherwise = Spaces (n - s) : rest- subtractSpace _ = error "Database.Persist.Quasi: never here"+removeSpaces =+ map toLine+ where+ toLine (Spaces i:rest) = toLine' i rest+ toLine xs = toLine' 0 xs - -- | Get all tokens while ignoring spaces.- getTokens (Token tok : rest) = tok : getTokens rest- getTokens (Spaces _ : rest) = getTokens rest- getTokens [] = []+ toLine' i = Line i . mapMaybe toToken - -- | Make a 'Line' from a @[Token]@.- makeLine (Spaces _ : rest) = Line Body (getTokens rest)- makeLine rest = Line Header (getTokens rest)+ toToken (Token t) = Just t+ toToken Spaces{} = Nothing -- | Divide lines into blocks and make entity definitions.-parse' :: [Line] -> [EntityDef]-parse' (Line Header (name:entattribs) : rest) =- let (x, y) = span ((== Body) . lineType) rest- in mkEntityDef name entattribs (map tokens x) : parse' y-parse' ((Line Header []) : _) = error "Indented line must contain at least name."-parse' ((Line Body _) : _) = error "Blocks must begin with non-indented lines."-parse' [] = []+parse' :: PersistSettings -> [Line] -> [EntityDef]+parse' ps (Line indent (name:entattribs) : rest) =+ let (x, y) = span ((> indent) . lineIndent) rest+ in mkEntityDef ps name entattribs x : parse' ps y+parse' ps (Line _ []:rest) = parse' ps rest+parse' _ [] = [] -- | Construct an entity definition.-mkEntityDef :: String -> [String] -> [[String]] -> EntityDef-mkEntityDef name entattribs attribs =- EntityDef name entattribs cols uniqs derives+mkEntityDef :: PersistSettings+ -> Text -- ^ name+ -> [Attr] -- ^ entity attributes+ -> [Line] -- ^ indented lines+ -> EntityDef+mkEntityDef ps name entattribs lines =+ EntityDef+ (HaskellName name)+ (DBName $ psToDBName ps name)+ (DBName $ idName entattribs)+ entattribs cols uniqs derives+ extras where- cols = mapMaybe takeCols attribs- uniqs = mapMaybe takeUniqs attribs+ (attribs, extras) = splitExtras lines+ idName [] = "id"+ idName (t:ts) =+ case T.stripPrefix "id=" t of+ Nothing -> idName ts+ Just s -> s+ cols = mapMaybe (takeCols ps) attribs+ uniqs = mapMaybe (takeUniqs ps cols) attribs derives = case mapMaybe takeDerives attribs of [] -> ["Show", "Read", "Eq"] x -> concat x -takeCols :: [String] -> Maybe ColumnDef-takeCols ("deriving":_) = Nothing-takeCols (n@(f:_):ty:rest)- | isLower f = Just $ ColumnDef n ty rest-takeCols _ = Nothing+splitExtras :: [Line] -> ([[Text]], Map.Map Text [[Text]])+splitExtras [] = ([], Map.empty)+splitExtras (Line indent [name]:rest)+ | not (T.null name) && isUpper (T.head name) =+ let (children, rest') = span ((> indent) . lineIndent) rest+ (x, y) = splitExtras rest'+ in (x, Map.insert name (map tokens children) y)+splitExtras (Line _ ts:rest) =+ let (x, y) = splitExtras rest+ in (ts:x, y) -takeUniqs :: [String] -> Maybe UniqueDef-takeUniqs (n@(f:_):rest)- | isUpper f = Just $ UniqueDef n rest-takeUniqs _ = Nothing+takeCols :: PersistSettings -> [Text] -> Maybe FieldDef+takeCols _ ("deriving":_) = Nothing+takeCols ps (n:ty:rest)+ | not (T.null n) && isLower (T.head n) = Just $ FieldDef+ (HaskellName n)+ (DBName $ db rest)+ (FieldType ty)+ rest+ where+ db [] = psToDBName ps n+ db (a:as) =+ case T.stripPrefix "sql=" a of+ Nothing -> db as+ Just s -> s+takeCols _ _ = Nothing -takeDerives :: [String] -> Maybe [String]+takeUniqs :: PersistSettings+ -> [FieldDef]+ -> [Text]+ -> Maybe UniqueDef+takeUniqs ps defs (n:rest)+ | not (T.null n) && isUpper (T.head n)+ = Just $ UniqueDef+ (HaskellName n)+ (DBName $ psToDBName ps n)+ (map (HaskellName &&& getDBName defs) rest)+ where+ getDBName [] t = error $ "Unknown column in unique constraint: " ++ show t+ getDBName (d:ds) t+ | fieldHaskell d == HaskellName t = fieldDB d+ | otherwise = getDBName ds t+takeUniqs _ _ _ = Nothing++takeDerives :: [Text] -> Maybe [Text] takeDerives ("deriving":rest) = Just rest takeDerives _ = Nothing
+ Database/Persist/Query.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Database.Persist.Query+ ( PersistQuery (..)+ , selectList+ , 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 view
@@ -0,0 +1,354 @@+{-# 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+ , getFiltsValues+ , selectSourceConn+ , dummyFromFilts+ , orderClause+ )+ 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 qualified Data.Conduit as C+import qualified Data.Conduit.List as CL++import Control.Exception (throwIO)+import qualified Data.Text as T+import Database.Persist.EntityDef+import Data.Monoid (Monoid, mappend, mconcat)++-- orphaned instance for convenience of modularity+instance C.ResourceIO 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 id=?"+ ]+ 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+ ]+ C.runResourceT $ R.withStmt sql (getFiltsValues conn filts) C.$$ do+ Just [PersistInt64 i] <- CL.head+ return $ fromIntegral i+ where+ t = entityDef $ dummyFromFilts filts++ selectSource filts opts = C.Source $ do+ conn <- lift $ SqlPersist ask+ C.prepareSource $ R.withStmt (sql conn) (getFiltsValues conn filts) C.$= 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 = C.Source $ do+ conn <- lift $ SqlPersist ask+ C.prepareSource $ R.withStmt (sql conn) (getFiltsValues conn filts) C.$= 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+ ]++ deleteWhere 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+ ]+ execute' sql $ getFiltsValues conn filts++ updateWhere _ [] = return ()+ updateWhere 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+ execute' 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 :: Key SqlPersist v -> v +dummyFromKey _ = error "dummyFromKey"++execute' :: 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++filterClause :: PersistEntity val+ => Bool -- ^ include table name?+ -> Connection+ -> [Filter val]+ -> Text+filterClause b c = fst . filterClauseHelper b True c++filterClauseNoWhere :: PersistEntity val+ => Bool -- ^ include table name?+ -> Connection+ -> [Filter val]+ -> Text+filterClauseNoWhere b c = fst . filterClauseHelper b False c++filterClauseHelper :: PersistEntity val+ => Bool -- ^ include table name?+ -> Bool -- ^ include WHERE?+ -> Connection+ -> [Filter val]+ -> (Text, [PersistValue])+filterClauseHelper includeTable includeWhere conn 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 (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", [])+ (False, In, _) -> (name ++ " IN " ++ qmarks, 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 ++ "?", allVals)+ where+ filterValueToPersistValues :: forall a. PersistField a => Either a [a] -> [PersistValue]+ filterValueToPersistValues v = map toPersistValue $ either return id v++ 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 :: (C.ResourceIO m, PersistEntity val)+ => Connection+ -> [Filter val]+ -> [SelectOpt val]+ -> C.Source m (Entity SqlPersist val)+selectSourceConn conn fs opts =+ C.transSource (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 x+ Desc x -> name 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 $ persistFieldDef x
+ Database/Persist/Query/Internal.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Database.Persist.Query.Internal+ ( -- re-exported as public+ PersistQuery (..)+ , selectList++ -- just Internal+ , SelectOpt (..)+ , limitOffsetOrder+ , Filter (..)+ , PersistUpdate (..)+ , Update (..)+ , updateFieldDef+ , deleteCascadeWhere+ ) where++import Database.Persist.Store+import Database.Persist.EntityDef++import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+++class PersistStore b m => PersistQuery b m where+ -- | Update individual fields on a specific record.+ update :: PersistEntity val => Key b val -> [Update val] -> b m ()++ -- | Update individual fields on any record matching the given criterion.+ updateWhere :: PersistEntity val => [Filter val] -> [Update val] -> b m ()++ -- | Delete all records matching the given criterion.+ deleteWhere :: PersistEntity val => [Filter val] -> b m ()++ -- | Get all records matching the given criterion in the specified order.+ -- Returns also the identifiers.+ selectSource+ :: PersistEntity val+ => [Filter val]+ -> [SelectOpt val]+ -> C.Source (b m) (Entity b val)++ -- | get just the first record for the criterion+ selectFirst :: PersistEntity val+ => [Filter val]+ -> [SelectOpt val]+ -> b m (Maybe (Entity b val))+ selectFirst filts opts = C.runResourceT+ $ selectSource filts ((LimitTo 1):opts) C.$$ CL.head+++ -- | Get the 'Key's of all records matching the given criterion.+ selectKeys :: PersistEntity val+ => [Filter val]+ -> C.Source (b m) (Key b val)++ -- | The total number of records fulfilling the given criterion.+ count :: PersistEntity val => [Filter val] -> b m Int++-- | 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]+++data SelectOpt v = forall typ. Asc (EntityField v typ)+ | forall typ. Desc (EntityField v typ)+ | OffsetBy Int+ | LimitTo Int++-- | Call 'select' but return the result as a list.+selectList :: (PersistEntity val, PersistQuery b m)+ => [Filter val]+ -> [SelectOpt val]+ -> b m [Entity b val]+selectList a b = C.runResourceT $ selectSource 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 b m, PersistQuery b m)+ => [Filter a] -> b m ()+deleteCascadeWhere filts = do+ C.runResourceT $ selectKeys filts C.$$ CL.mapM_ deleteCascade
+ Database/Persist/Query/Join.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+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 b m => RunJoin a b m where+ type Result a+ runJoin :: a -> b m (Result a)++data SelectOneMany backend one many = SelectOneMany+ { somFilterOne :: [Filter one]+ , somOrderOne :: [SelectOpt one]+ , somFilterMany :: [Filter many]+ , somOrderMany :: [SelectOpt many]+ , somFilterKeys :: [Key backend one] -> Filter many+ , somGetKey :: many -> Key backend one+ , somIncludeNoMatch :: Bool+ }++selectOneMany :: ([Key backend one] -> Filter many) -> (many -> Key backend one) -> SelectOneMany backend one many+selectOneMany filts get' = SelectOneMany [] [] [] [] filts get' False+instance (PersistEntity one, PersistEntity many, Ord (Key backend one), PersistQuery backend monad)+ => RunJoin (SelectOneMany backend one many) backend monad where+ type Result (SelectOneMany backend one many) =+ [((Entity backend one), [(Entity backend 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 view
@@ -0,0 +1,130 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+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)+import Control.Monad.Trans.Reader (ask)+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++fromPersistValuesId :: PersistEntity v => [PersistValue] -> Either Text (Entity SqlPersist 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.ResourceIO m => a -> SqlPersist m (J.Result a)++instance (PersistEntity one, PersistEntity many, Eq (Key SqlPersist one))+ => RunJoin (SelectOneMany SqlPersist one many) where+ runJoin (SelectOneMany oneF oneO manyF manyO eq _getKey isOuter) = do+ conn <- SqlPersist ask+ C.runResourceT $ liftM go $ withStmt (sql conn) (getFiltsValues conn oneF ++ getFiltsValues conn manyF) C.$$ loop id+ where+ go :: [(Entity a b, Maybe (Entity c d))]+ -> [(Entity a b, [Entity c 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+ , filts+ , case ords of+ [] -> ""+ _ -> " ORDER BY " ++ T.intercalate ", " ords+ ]+ where+ filts1 = filterClauseNoWhere True conn oneF+ filts2 = filterClauseNoWhere True conn manyF++ orders :: PersistEntity val+ => [SelectOpt val]+ -> [SelectOpt val]+ orders x = let (_, _, y) = limitOffsetOrder x in y++ filts+ | null filts1 && null filts2 = ""+ | null filts1 = " WHERE " ++ filts2+ | null filts2 = " WHERE " ++ filts1+ | otherwise = " WHERE " ++ filts1 ++ " AND " ++ filts2+ 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"++infixr 5 +++(++) :: Monoid m => m -> m -> m+(++) = mappend
+ Database/Persist/Store.hs view
@@ -0,0 +1,582 @@+{-# 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 #-}+-- 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 (..)++ , insertBy+ , getByValue+ , getJust+ , belongsTo+ , belongsToJust++ , checkUnique+ , DeleteCascade (..)+ , PersistException (..)+ , Key (..)+ , Entity (..)++ -- * Config+ , PersistConfig (..)+ ) where++import qualified Prelude+import Prelude hiding ((++), show)+import Data.Monoid (mappend)+import Data.Time (Day, TimeOfDay, UTCTime)+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, unsafeByteString)+import Text.Blaze.Renderer.Utf8 (renderHtml)+import qualified Data.Text as T+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Control.Monad.IO.Class as Trans++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 qualified Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T+import Web.PathPieces (PathPiece (..))+import qualified Data.Text.Read+import qualified Data.Conduit as C++import Data.Aeson (Value)+import Data.Aeson.Types (Parser)++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++-- | 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+ | 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++-- | 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+ | SqlInteger -- ^ FIXME 8-byte integer; should be renamed SqlInt64+ | SqlReal+ | SqlBool+ | SqlDay+ | SqlTime+ | SqlDayTime+ | SqlBlob+ deriving (Show, Read, Eq, Typeable)++-- | 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 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 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 Html where+ toPersistValue = PersistByteString . S.concat . L.toChunks . renderHtml+ fromPersistValue = fmap unsafeByteString . 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+ _ -> SqlInteger++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 _ = SqlInteger++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 _ = SqlInteger++instance PersistField Word64 where+ toPersistValue = PersistInt64 . fromIntegral+ fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+ fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x+ sqlType _ = SqlInteger++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 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++-- | 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 backend -> [(HaskellName, DBName)]+ persistUniqueToValues :: Unique val backend -> [PersistValue]+ persistUniqueKeys :: val -> [Unique val backend]++ persistIdField :: EntityField val (Key (PersistEntityBackend val) val)++#ifdef WITH_MONGODB+instance PersistField a => PersistField [a] where+ toPersistValue = PersistList . map toPersistValue+ fromPersistValue (PersistList l) = fromPersistList l+ 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 x = Left $ "Expected PersistList, received: " ++ show x+ sqlType _ = SqlString++fromPersistList :: PersistField a => [PersistValue] -> Either String [a]+fromPersistList list =+ foldl (\eithList v ->+ case (eithList, fromPersistValue v) of+ (Left e, _) -> Left e+ (_, Left e) -> Left e+ (Right xs, Right x) -> Right (x:xs)+ ) (Right []) list++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 (PersistMap 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++ fromPersistValue x = Left $ "Expected PersistMap, received: " ++ show x+ sqlType _ = SqlString+#endif+++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 Key (backend :: (* -> *) -> * -> *) entity = Key { unKey :: PersistValue }+ deriving (Show, Read, Eq, Ord, PersistField)++-- | 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 backend entity =+ Entity { entityKey :: Key backend entity+ , entityVal :: entity }+ deriving (Eq, Ord, Show, Read)++class (C.ResourceIO m, C.ResourceIO (b m)) => PersistStore b m where++ -- | Create a new record in the database, returning an automatically created+ -- key (in SQL an auto-increment id).+ insert :: PersistEntity val => val -> b m (Key b val)++ -- | Create a new record in the database using the given key.+ insertKey :: PersistEntity val => Key b val -> val -> b 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 :: PersistEntity val => Key b val -> val -> b 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 :: PersistEntity val => Key b val -> val -> b m ()++ -- | Delete a specific record by identifier. Does nothing if record does+ -- not exist.+ delete :: PersistEntity val => Key b val -> b m ()++ -- | Get a record by identifier, if available.+ get :: PersistEntity val => Key b val -> b m (Maybe val)++class PersistStore b m => PersistUnique b m where+ -- | Get a record by unique key, if available. Returns also the identifier.+ getBy :: PersistEntity val => Unique val b -> b m (Maybe (Entity b val))++ -- | Delete a specific record by unique key. Does nothing if no record+ -- matches.+ deleteBy :: PersistEntity val => Unique val b -> b m ()++ -- | Like 'insert', but returns 'Nothing' when the record+ -- couldn't be inserted because of a uniqueness constraint.+ insertUnique :: PersistEntity val => val -> b m (Maybe (Key b val))+ insertUnique datum = do+ isUnique <- checkUnique datum+ if isUnique then Just <$> insert datum else return Nothing++++-- | Insert a value, checking for conflicts with any unique constraints. If a+-- duplicate exists in the database, it is returned as 'Left'. Otherwise, the+-- new 'Key' is returned as 'Right'.+insertBy :: (PersistEntity v, PersistStore b m, PersistUnique b m)+ => v -> b m (Either (Entity b v) (Key b 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 b m)+ => v -> b m (Maybe (Entity b 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 b m+ , PersistEntity ent1+ , PersistEntity ent2) => (ent1 -> Maybe (Key b ent2)) -> ent1 -> b 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 b m+ , PersistEntity ent1+ , PersistEntity ent2) => (ent1 -> Key b ent2) -> ent1 -> b 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 b m, PersistEntity val, Show (Key b val)) => Key b val -> b m val+getJust key = get key >>= maybe+ (Trans.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 :: (PersistEntity val, PersistUnique b m) => val -> b 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 PersistEntity a => DeleteCascade a b m where+ deleteCascade :: Key b a -> b m ()++instance PersistField PersistValue where+ toPersistValue = id+ fromPersistValue = Right+ sqlType _ = SqlInteger -- 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 :: C.ResourceIO 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
Database/Persist/Util.hs view
@@ -1,11 +1,13 @@+{-# LANGUAGE OverloadedStrings #-} module Database.Persist.Util ( nullable , deprecate ) where import System.IO.Unsafe (unsafePerformIO)+import Data.Text -nullable :: [String] -> Bool+nullable :: [Text] -> Bool nullable s | "Maybe" `elem` s = True | "null" `elem` s = deprecate "Please replace null with Maybe" True
persistent.cabal view
@@ -1,42 +1,57 @@ name: persistent-version: 0.6.4.4+version: 0.7.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> maintainer: Michael Snoyman <michael@snoyman.com>-synopsis: Type-safe, non-relational, multi-backend persistence.-description: This library provides just the general interface and helper functions. You must use a specific backend in order to make this useful.+synopsis: Type-safe, multi-backend data serialization.+description: Type-safe, data serialization. You must use a specific backend in order to make this useful. category: Database, Yesod stability: Stable cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/book/persistent +flag nooverlap+ default: False+ description: test out our assumption that OverlappingInstances is just for String+ library+ if flag(nooverlap)+ cpp-options: -DNO_OVERLAP+ build-depends: base >= 4 && < 5 , bytestring >= 0.9 && < 0.10 , transformers >= 0.2.1 && < 0.3 , time >= 1.1.4- , text >= 0.8 && < 0.12+ , text >= 0.8 && < 1 , containers >= 0.2 && < 0.5- , enumerator >= 0.4.9 && < 0.5- , monad-control >= 0.2 && < 0.4- , pool >= 0.1 && < 0.2+ , conduit >= 0.0 && < 0.2+ , monad-control >= 0.3 && < 0.4+ , lifted-base >= 0.1 && < 0.2+ , pool-conduit >= 0.0 && < 0.1 , blaze-html >= 0.4 && < 0.5- , path-pieces >= 0.0 && < 0.1+ , path-pieces >= 0.1 && < 0.2 , mtl >= 2.0 && < 2.1- , data-object >= 0.3.1.7 && < 0.4+ , aeson >= 0.5 && < 0.6 , transformers-base+ exposed-modules: Database.Persist- Database.Persist.Base+ Database.Persist.EntityDef+ Database.Persist.Store Database.Persist.Quasi Database.Persist.GenericSql- Database.Persist.GenericSql.Internal Database.Persist.GenericSql.Raw+ Database.Persist.GenericSql.Migration Database.Persist.TH.Library Database.Persist.Util- Database.Persist.Join- Database.Persist.Join.Sql+ Database.Persist.Query+ Database.Persist.Query.Internal+ Database.Persist.Query.GenericSql+ Database.Persist.Query.Join+ Database.Persist.Query.Join.Sql+ Database.Persist.GenericSql.Internal+ ghc-options: -Wall source-repository head