persistent 0.5.1 → 0.6.1
raw patch · 14 files changed
+1805/−2029 lines, 14 filesdep +bsondep +cerealdep +compact-string-fixdep −haskell98dep −test-frameworkdep −test-framework-hunitdep ~bytestringdep ~containersdep ~monad-controlsetup-changed
Dependencies added: bson, cereal, compact-string-fix, file-location, hspec, mongoDB, mtl, network, path-pieces, persistent
Dependencies removed: haskell98, test-framework, test-framework-hunit, web-routes-quasi
Dependency ranges changed: bytestring, containers, monad-control, template-haskell, text, transformers
Files
- Database/Persist.hs +60/−11
- Database/Persist/Base.hs +570/−454
- Database/Persist/GenericSql.hs +459/−427
- Database/Persist/GenericSql/Internal.hs +273/−249
- Database/Persist/GenericSql/Raw.hs +55/−54
- Database/Persist/Join.hs +57/−55
- Database/Persist/Join/Sql.hs +104/−98
- Database/Persist/Quasi.hs +84/−84
- Database/Persist/TH/Library.hs +19/−19
- Database/Persist/Util.hs +17/−17
- LICENSE +25/−25
- Setup.lhs +7/−7
- persistent.cabal +75/−72
- runtests.hs +0/−457
Database/Persist.hs view
@@ -1,11 +1,60 @@-module Database.Persist - ( PersistField (..) - , PersistEntity (..) - , PersistBackend (..) - , selectList - , insertBy - , getByValue - , checkUnique - ) where - -import Database.Persist.Base +{-# LANGUAGE ExistentialQuantification #-}+module Database.Persist+ ( PersistField (..)+ , PersistEntity (..)+ , PersistBackend (..)+ , Key (..)+ , selectList+ , insertBy+ , getJust+ , belongsTo+ , belongsToJust+ , getByValue+ , checkUnique+ , Update (..)+ , SelectOpt (..)+ , Filter (..)+ , (=.), (+=.), (-=.), (*=.), (/=.)+ , (==.), (!=.), (<.), (>.), (<=.), (>=.)+ , (<-.), (/<-.)+ , (||.)+ ) 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]]
Database/Persist/Base.hs view
@@ -1,454 +1,570 @@-{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} - --- | This defines the API for performing database actions. There are two levels --- to this API: dealing with fields, and dealing with entities. In SQL, a field --- corresponds to a column, and should be a single, non-composite value. An --- entity corresponds to a SQL table. In other words: An entity is a --- collection of fields. -module Database.Persist.Base - ( PersistValue (..) - , SqlType (..) - , PersistField (..) - , PersistEntity (..) - , EntityDef (..) - , PersistBackend (..) - , PersistFilter (..) - , PersistUpdate (..) - , PersistOrder (..) - , SomePersistField (..) - , selectList - , insertBy - , getByValue - , checkUnique - , DeleteCascade (..) - , deleteCascadeWhere - , PersistException (..) - ) 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) -import Data.Enumerator.List (consume) -import qualified Control.Exception as E -import Data.Bits (bitSize) -import Control.Monad (liftM) - -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T - --- | 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)] - | PersistForeignKey ByteString -- ^ intended especially for MongoDB backend. FIXME: rename to PersistObjectId - deriving (Show, Read, Eq, Typeable, Ord) - --- | 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 (PersistForeignKey _) = Left "Cannot convert PersistForeignKey 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 (PersistForeignKey _) = Left "Cannot convert PersistForeignKey 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 Show (Key val) => PersistEntity val where - -- | The unique identifier associated with this entity. In general, backends also define a type synonym for this, such that \"type MyEntityId = Key MyEntity\". - data Key val - -- | Fields which can be updated using the 'update' and 'updateWhere' - -- functions. - data Update val - -- | 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 val - -- | How you can sort the results of a 'select'. - data Order val - -- | Unique keys in existence on this entity. - data Unique val - - entityDef :: val -> EntityDef - toPersistFields :: val -> [SomePersistField] - fromPersistValues :: [PersistValue] -> Either String val - halfDefined :: val - toPersistKey :: PersistValue -> Key val - fromPersistKey :: Key val -> PersistValue - - persistFilterToFieldName :: Filter val -> String - persistFilterToFilter :: Filter val -> PersistFilter - persistFilterToValue :: Filter val -> Either PersistValue [PersistValue] - - persistOrderToFieldName :: Order val -> String - persistOrderToOrder :: Order val -> PersistOrder - - persistUpdateToFieldName :: Update val -> String - persistUpdateToUpdate :: Update val -> PersistUpdate - persistUpdateToValue :: Update val -> PersistValue - - persistUniqueToFieldNames :: Unique val -> [String] - persistUniqueToValues :: Unique val -> [PersistValue] - persistUniqueKeys :: val -> [Unique val] - -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 - -class Monad m => PersistBackend m where - -- | Create a new record in the database, returning the newly created - -- identifier. - insert :: PersistEntity val => val -> m (Key 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 val -> val -> m () - - -- | Update individual fields on a specific record. - update :: PersistEntity val => Key val -> [Update val] -> m () - - -- | Update individual fields on any record matching the given criterion. - updateWhere :: PersistEntity val => [Filter val] -> [Update val] -> m () - - -- | Delete a specific record by identifier. Does nothing if record does - -- not exist. - delete :: PersistEntity val => Key val -> m () - - -- | Delete a specific record by unique key. Does nothing if no record - -- matches. - deleteBy :: PersistEntity val => Unique val -> m () - - -- | Delete all records matching the given criterion. - deleteWhere :: PersistEntity val => [Filter val] -> m () - - -- | Get a record by identifier, if available. - get :: PersistEntity val => Key val -> m (Maybe val) - - -- | Get a record by unique key, if available. Returns also the identifier. - getBy :: PersistEntity val => Unique val -> m (Maybe (Key val, val)) - - -- | Get all records matching the given criterion in the specified order. - -- Returns also the identifiers. - selectEnum - :: PersistEntity val - => [Filter val] - -> [Order val] - -> Int -- ^ limit - -> Int -- ^ offset - -> Enumerator (Key val, val) m a - - -- | Get the 'Key's of all records matching the given criterion. - selectKeys :: PersistEntity val - => [Filter val] - -> Enumerator (Key val) m a - - -- | The total number of records fulfilling the given criterion. - count :: PersistEntity val => [Filter val] -> 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 m) - => v -> m (Either (Key v, v) (Key v)) -insertBy val = - go $ persistUniqueKeys val - where - go [] = Right `liftM` insert val - go (x:xs) = do - y <- getBy x - case y of - Nothing -> go xs - Just z -> return $ Left z - --- | A modification of 'getBy', which takes the 'PersistEntity' itself instead --- of a 'Unique' value. Returns a value matching /one/ of the unique keys. This --- function makes the most sense on entities with a single 'Unique' --- constructor. -getByValue :: (PersistEntity v, PersistBackend m) - => v -> m (Maybe (Key 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 - --- | 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 m) => val -> m Bool -checkUnique val = - go $ persistUniqueKeys val - where - go [] = return True - go (x:xs) = do - y <- getBy x - case y of - Nothing -> go xs - Just _ -> return False - --- | Call 'select' but return the result as a list. -selectList :: (PersistEntity val, PersistBackend m, Monad m) - => [Filter val] - -> [Order val] - -> Int -- ^ limit - -> Int -- ^ offset - -> m [(Key val, val)] -selectList a b c d = do - res <- run $ selectEnum a b c d ==<< consume - case res of - Left e -> error $ show e - Right x -> return x - -data EntityDef = EntityDef - { entityName :: String - , entityAttribs :: [String] - , entityColumns :: [(String, String, [String])] -- ^ name, type, attribs - , entityUniques :: [(String, [String])] -- ^ name, columns - , entityDerives :: [String] - } - deriving Show - -data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le | In | NotIn - deriving (Read, Show) - -data PersistOrder = Asc | Desc - deriving (Read, Show) - -class PersistEntity a => DeleteCascade a where - deleteCascade :: PersistBackend m => Key a -> m () - -deleteCascadeWhere :: (DeleteCascade a, PersistBackend m) - => [Filter a] -> m () -deleteCascadeWhere filts = do - res <- run $ selectKeys filts $ Continue iter - case res of - Left e -> error $ show e - Right () -> return () - where - iter EOF = Iteratee $ return $ Yield () EOF - iter (Chunks keys) = Iteratee $ do - mapM_ deleteCascade keys - return $ Continue iter - -data PersistException = PersistMarshalException String - deriving (Show, Typeable) -instance E.Exception PersistException - -data PersistUpdate = Update | Add | Subtract | Multiply | Divide - deriving (Read, Show) - -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 +{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | 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+ ) 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.Error.Class (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 Data.Maybe (fromMaybe, isJust)++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 = let (l,o,ord) = go opts (Nothing, Nothing, []) in+ (fromMaybe 0 l, fromMaybe 0 o, ord)+ where+ go [] tup = tup+ go (LimitTo x:xs) (_,o,ord) = let tup = (Just x, o, ord) in+ if isJust o then tup else go xs tup+ go (OffsetBy x:xs) (l,_,ord) = let tup = (l, Just x, ord) in+ if isJust l then tup else go xs tup+ go (x:xs) (l, o, ord) = go xs (l,o,x:ord)++-- | 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
Database/Persist/GenericSql.hs view
@@ -1,427 +1,459 @@-{-# LANGUAGE PackageImports #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | This is a helper module for creating SQL backends. Regular users do not --- need to use this module. -module Database.Persist.GenericSql - ( SqlPersist (..) - , Connection - , ConnectionPool - , Statement - , runSqlConn - , runSqlPool - , Migration - , parseMigration - , parseMigration' - , printMigration - , getMigration - , runMigration - , runMigrationSilent - , runMigrationUnsafe - , migrate - ) where - -import Database.Persist.Base -import Data.List (intercalate) -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 Database.Persist.GenericSql.Internal -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 (..)) -import Control.Monad.IO.Control (MonadControlIO) -import Control.Exception.Control (onException) -import Control.Exception (toException) -import Data.Text (Text, pack, unpack) - -type ConnectionPool = Pool Connection - -withStmt' :: MonadControlIO 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 - -runSqlPool :: MonadControlIO m => SqlPersist m a -> Pool Connection -> m a -runSqlPool r pconn = withPool' pconn $ runSqlConn r - -runSqlConn :: MonadControlIO m => SqlPersist m a -> Connection -> m a -runSqlConn (SqlPersist r) conn = do - let getter = R.getStmt' conn - liftIO $ begin conn getter - x <- onException - (runReaderT r conn) - (liftIO $ rollback conn getter) - liftIO $ commit conn getter - return x - -instance MonadControlIO m => PersistBackend (SqlPersist m) where - insert val = do - conn <- SqlPersist ask - let esql = insertSql conn (rawTableName t) (map fst3 $ tableColumns t) - i <- - case esql of - Left sql -> withStmt' sql vals $ \pop -> do - Just [i] <- pop - return i - Right (sql1, sql2) -> do - execute' sql1 vals - withStmt' sql2 [] $ \pop -> do - Just [i] <- pop - return i - return $ toPersistKey i - where - fst3 (x, _, _) = x - t = entityDef val - vals = map toPersistValue $ toPersistFields val - - replace k val = do - conn <- SqlPersist ask - let t = entityDef val - let sql = pack $ concat - [ "UPDATE " - , escapeName conn (rawTableName t) - , " SET " - , intercalate "," (map (go conn . fst3) $ tableColumns t) - , " WHERE id=?" - ] - execute' sql $ map toPersistValue (toPersistFields val) - ++ [fromPersistKey k] - where - go conn x = escapeName conn x ++ "=?" - fst3 (x, _, _) = x - - 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 - [ "SELECT " - , cols - , " FROM " - , escapeName conn $ rawTableName t - , " WHERE id=?" - ] - withStmt' sql [fromPersistKey k] $ \pop -> do - res <- pop - case res of - Nothing -> return Nothing - Just vals -> - case fromPersistValues vals of - Left e -> error $ "get " ++ show k ++ ": " ++ e - Right v -> return $ Just v - - count filts = do - conn <- SqlPersist ask - let wher = if null filts - then "" - else " WHERE " ++ - intercalate " AND " (map (filterClause False conn) filts) - let sql = pack $ concat - [ "SELECT COUNT(*) FROM " - , escapeName conn $ rawTableName t - , wher - ] - withStmt' sql (getFiltsValues filts) $ \pop -> do - Just [PersistInt64 i] <- pop - return $ fromIntegral i - where - t = entityDef $ dummyFromFilts filts - - selectEnum filts ords limit offset = - Iteratee . start - where - start x = do - conn <- SqlPersist ask - withStmt' (sql conn) (getFiltsValues 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 - $ PersistMarshalException s - Right row -> do - step <- runIteratee $ k $ Chunks [row] - loop step pop - loop step _ = return step - t = entityDef $ dummyFromFilts filts - fromPersistValues' (x:xs) = do - case fromPersistValues xs of - Left e -> Left e - Right xs' -> Right (toPersistKey x, xs') - fromPersistValues' _ = Left "error in fromPersistValues'" - wher conn = if null filts - then "" - else " WHERE " ++ - intercalate " AND " (map (filterClause False conn) filts) - ord conn = if null ords - then "" - else " ORDER BY " ++ - intercalate "," (map (orderClause False conn) 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 "," $ "id" - : (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 filts) $ loop x - loop (Continue k) pop = do - res <- pop - case res of - Nothing -> return $ Continue k - Just [i] -> do - step <- runIteratee $ k $ Chunks [toPersistKey i] - loop step pop - Just y -> return $ Error $ toException $ PersistMarshalException - $ "Unexpected in selectKeys: " ++ show y - loop step _ = return step - t = entityDef $ dummyFromFilts filts - wher conn = if null filts - then "" - else " WHERE " ++ - intercalate " AND " (map (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) [fromPersistKey k] - where - t = entityDef $ dummyFromKey k - sql conn = pack $ concat - [ "DELETE FROM " - , escapeName conn $ rawTableName t - , " WHERE id=?" - ] - - deleteWhere filts = do - conn <- SqlPersist ask - let t = entityDef $ dummyFromFilts filts - let wher = if null filts - then "" - else " WHERE " ++ - intercalate " AND " (map (filterClause False conn) filts) - sql = pack $ concat - [ "DELETE FROM " - , escapeName conn $ rawTableName t - , wher - ] - execute' sql $ getFiltsValues filts - - deleteBy uniq = do - conn <- SqlPersist ask - execute' (sql conn) $ persistUniqueToValues uniq - where - t = entityDef $ dummyFromUnique uniq - go = map (getFieldName t) . persistUniqueToFieldNames - go' conn x = escapeName conn x ++ "=?" - sql conn = pack $ concat - [ "DELETE FROM " - , escapeName conn $ rawTableName t - , " WHERE " - , intercalate " AND " $ map (go' conn) $ go uniq - ] - - update _ [] = return () - update k upds = do - conn <- SqlPersist ask - let go'' n Update = 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 persistUpdateToValue upds ++ [fromPersistKey k] - where - t = entityDef $ dummyFromKey k - go x = ( getFieldName t $ persistUpdateToFieldName x - , persistUpdateToUpdate x - ) - - updateWhere _ [] = return () - updateWhere filts upds = do - conn <- SqlPersist ask - let wher = if null filts - then "" - else " WHERE " ++ - intercalate " AND " (map (filterClause False conn) filts) - let sql = pack $ concat - [ "UPDATE " - , escapeName conn $ rawTableName t - , " SET " - , intercalate "," $ map (go' conn . go) upds - , wher - ] - let dat = map persistUpdateToValue upds ++ getFiltsValues filts - execute' sql dat - where - t = entityDef $ dummyFromFilts filts - go'' n Update = 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 $ persistUpdateToFieldName x - , persistUpdateToUpdate x - ) - - getBy uniq = do - conn <- SqlPersist ask - let cols = intercalate "," $ "id" - : (map (\(x, _, _) -> escapeName conn x) $ tableColumns t) - let sql = pack $ concat - [ "SELECT " - , cols - , " FROM " - , escapeName conn $ rawTableName t - , " WHERE " - , sqlClause conn - ] - withStmt' sql (persistUniqueToValues uniq) $ \pop -> do - row <- pop - case row of - Nothing -> return Nothing - Just (k:vals) -> - case fromPersistValues vals of - Left s -> error s - Right x -> return $ Just (toPersistKey k, x) - Just _ -> error "Database.Persist.GenericSql: Bad list in getBy" - where - sqlClause conn = - 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 -> v -dummyFromUnique _ = error "dummyFromUnique" - -dummyFromKey :: Key v -> v -dummyFromKey _ = error "dummyFromKey" - - -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 :: MonadControlIO m => Migration (SqlPersist m) -> SqlPersist m () -printMigration m = do - mig <- parseMigration' m - mapM_ (liftIO . putStrLn . unpack) (allSql mig) - -getMigration :: MonadControlIO m => Migration (SqlPersist m) -> SqlPersist m [Sql] -getMigration m = do - mig <- parseMigration' m - return $ allSql mig - -runMigration :: MonadControlIO 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 :: MonadControlIO m - => Migration (SqlPersist m) - -> SqlPersist m [Text] -runMigrationSilent m = runMigration' m True - -runMigration' :: MonadControlIO 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 :: MonadControlIO 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 :: (MonadControlIO m, PersistEntity val) - => val - -> Migration (SqlPersist m) -migrate val = do - conn <- lift $ lift $ SqlPersist ask - let getter = R.getStmt' conn - res <- liftIO $ migrateSql conn getter val - either tell (lift . tell) res +{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | This is a helper module for creating SQL backends. Regular users do not+-- need to use this module.+module Database.Persist.GenericSql+ ( SqlPersist (..)+ , Connection+ , ConnectionPool+ , Statement+ , runSqlConn+ , runSqlPool+ , Migration+ , parseMigration+ , parseMigration'+ , printMigration+ , getMigration+ , runMigration+ , runMigrationSilent+ , runMigrationUnsafe+ , migrate+ , commit+ , rollback+ , Key (..)+ ) where++import Database.Persist.Base+import Data.List (intercalate)+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 Database.Persist.GenericSql.Internal+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 (..))+import Control.Monad.IO.Control (MonadControlIO)+import Control.Exception.Control (onException)+import Control.Exception (throw, toException)+import Data.Text (Text, pack, unpack, snoc)+import qualified Data.Text.IO+import Web.PathPieces (SinglePiece (..))+import qualified Data.Text.Read++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 =+ case Data.Text.Read.decimal t of+ Right (i, "") -> Just $ Key $ PersistInt64 i+ _ -> Nothing++withStmt' :: MonadControlIO 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++runSqlPool :: MonadControlIO m => SqlPersist m a -> Pool Connection -> m a+runSqlPool r pconn = withPool' pconn $ runSqlConn r++runSqlConn :: MonadControlIO m => SqlPersist m a -> Connection -> m a+runSqlConn (SqlPersist r) conn = do+ let getter = R.getStmt' conn+ liftIO $ begin conn getter+ x <- onException+ (runReaderT r conn)+ (liftIO $ rollbackC conn getter)+ liftIO $ commitC conn getter+ return x++instance MonadControlIO m => PersistBackend SqlPersist m where+ insert val = do+ conn <- SqlPersist ask+ let esql = insertSql conn (rawTableName t) (map fst3 $ tableColumns t)+ i <-+ case esql of+ Left sql -> withStmt' sql vals $ \pop -> do+ Just [PersistInt64 i] <- pop+ return i+ Right (sql1, sql2) -> do+ execute' sql1 vals+ withStmt' sql2 [] $ \pop -> do+ Just [PersistInt64 i] <- pop+ return i+ return $ Key $ PersistInt64 i+ where+ t = entityDef val+ vals = map toPersistValue $ toPersistFields val++ replace k val = do+ conn <- SqlPersist ask+ let t = entityDef val+ let sql = pack $ concat+ [ "UPDATE "+ , escapeName conn (rawTableName t)+ , " SET "+ , intercalate "," (map (go conn . fst3) $ tableColumns t)+ , " WHERE id=?"+ ]+ execute' sql $ map toPersistValue (toPersistFields val)+ ++ [unKey k]+ where+ go conn x = escapeName conn x ++ "=?"++ 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+ [ "SELECT "+ , cols+ , " FROM "+ , escapeName conn $ rawTableName t+ , " WHERE id=?"+ ]+ withStmt' sql [unKey k] $ \pop -> do+ res <- pop+ case res of+ Nothing -> return Nothing+ Just vals ->+ case fromPersistValues vals of+ Left e -> error $ "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 = fst3 $ limitOffsetOrder opts+ offset = snd3 $ limitOffsetOrder opts+ orders = third3 $ 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 "," $ "id"+ : (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+ [ "DELETE FROM "+ , escapeName conn $ rawTableName 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++ deleteBy uniq = do+ conn <- SqlPersist ask+ execute' (sql conn) $ persistUniqueToValues uniq+ where+ t = entityDef $ dummyFromUnique uniq+ go = map (getFieldName t) . persistUniqueToFieldNames+ go' conn x = escapeName conn x ++ "=?"+ sql conn = pack $ concat+ [ "DELETE FROM "+ , escapeName conn $ rawTableName t+ , " WHERE "+ , 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 "," $ "id"+ : (map (\(x, _, _) -> escapeName conn x) $ tableColumns t)+ let sql = pack $ concat+ [ "SELECT "+ , cols+ , " FROM "+ , escapeName conn $ rawTableName t+ , " WHERE "+ , sqlClause conn+ ]+ withStmt' sql (persistUniqueToValues uniq) $ \pop -> do+ row <- pop+ 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)+ Just _ -> error "Database.Persist.GenericSql: Bad list in getBy"+ where+ sqlClause conn =+ 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"++dummyFromKey :: Key SqlPersist v -> v+dummyFromKey _ = error "dummyFromKey"+++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 :: MonadControlIO m => Migration (SqlPersist m) -> SqlPersist m ()+printMigration m = do+ mig <- parseMigration' m+ mapM_ (liftIO . Data.Text.IO.putStrLn . flip snoc ';') (allSql mig)++getMigration :: MonadControlIO m => Migration (SqlPersist m) -> SqlPersist m [Sql]+getMigration m = do+ mig <- parseMigration' m+ return $ allSql mig++runMigration :: MonadControlIO 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 :: MonadControlIO m+ => Migration (SqlPersist m)+ -> SqlPersist m [Text]+runMigrationSilent m = runMigration' m True++runMigration' :: MonadControlIO 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 :: MonadControlIO 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 :: (MonadControlIO m, PersistEntity val)+ => val+ -> Migration (SqlPersist m)+migrate val = do+ conn <- lift $ lift $ SqlPersist ask+ let getter = R.getStmt' conn+ res <- liftIO $ migrateSql conn getter val+ either tell (lift . tell) res++updatePersistValue :: Update v -> PersistValue+updatePersistValue (Update _ v _) = toPersistValue v++-- | 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/Internal.hs view
@@ -1,249 +1,273 @@-{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE PackageImports #-} --- | Code that is only needed for writing GenericSql backends. -module Database.Persist.GenericSql.Internal - ( Connection (..) - , Statement (..) - , withSqlConn - , withSqlPool - , RowPopper - , mkColumns - , Column (..) - , UniqueDef - , refName - , tableColumns - , rawFieldName - , rawTableName - , RawName (..) - , filterClause - , getFieldName - , dummyFromFilts - , getFiltsValues - , orderClause - ) 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 (fromJust) -import Control.Arrow -import Control.Monad.IO.Control (MonadControlIO) -import Control.Exception.Control (bracket) -import Database.Persist.Util (nullable) -import Data.List (intercalate) -import Data.Text (Text) - -type RowPopper m = m (Maybe [PersistValue]) - -data Connection = Connection - { prepare :: Text -> IO Statement - , insertSql :: RawName -> [RawName] -> Either Text (Text, Text) - , stmtMap :: IORef (Map.Map Text Statement) - , close :: IO () - , migrateSql :: forall v. PersistEntity v - => (Text -> IO Statement) -> v - -> IO (Either [Text] [(Bool, Text)]) - , begin :: (Text -> IO Statement) -> IO () - , commit :: (Text -> IO Statement) -> IO () - , rollback :: (Text -> IO Statement) -> IO () - , escapeName :: RawName -> String - , noLimit :: String - } -data Statement = Statement - { finalize :: IO () - , reset :: IO () - , execute :: [PersistValue] -> IO () - , withStmt :: forall a m. MonadControlIO m - => [PersistValue] -> (RowPopper m -> m a) -> m a - } - -withSqlPool :: MonadControlIO m - => IO Connection -> Int -> (Pool Connection -> m a) -> m a -withSqlPool mkConn = createPool mkConn close' - -withSqlConn :: MonadControlIO m => IO Connection -> (Connection -> m a) -> m a -withSqlConn open = bracket (liftIO open) (liftIO . close') - -close' :: Connection -> IO () -close' conn = do - readIORef (stmtMap conn) >>= mapM_ finalize . Map.elems - close conn - --- | Create the list of columns for the given entity. -mkColumns :: PersistEntity val => val -> ([Column], [UniqueDef]) -mkColumns val = - (cols, uniqs) - where - colNameMap = map ((\(x, _, _) -> x) &&& rawFieldName) $ entityColumns t - uniqs = map (RawName *** map (fromJust . flip lookup colNameMap)) - $ entityUniques t -- FIXME don't use fromJust - cols = zipWith go (tableColumns t) $ toPersistFields $ halfDefined `asTypeOf` val - t = entityDef val - tn = rawTableName t - go (name, t', as) p = - Column name (nullable as) (sqlType p) (def as) (ref name t' as) - 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 - 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 - -refName :: RawName -> RawName -> RawName -refName (RawName table) (RawName column) = - RawName $ table ++ '_' : column ++ "_fkey" - -data Column = Column - { cName :: RawName - , cNull :: Bool - , cType :: SqlType - , cDefault :: Maybe String - , cReference :: (Maybe (RawName, RawName)) -- table name, constraint name - } - -getSqlValue :: [String] -> Maybe String -getSqlValue (('s':'q':'l':'=':x):_) = Just x -getSqlValue (_:x) = getSqlValue x -getSqlValue [] = Nothing - -tableColumns :: EntityDef -> [(RawName, String, [String])] -tableColumns = map (\a@(_, y, z) -> (rawFieldName a, y, z)) . entityColumns - -type UniqueDef = (RawName, [RawName]) - -rawFieldName :: (String, String, [String]) -> RawName -rawFieldName (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 - -newtype RawName = RawName { unRawName :: String } -- FIXME Text - deriving (Eq, Ord) - -filterClause :: PersistEntity val - => Bool -- ^ include table name? - -> Connection -> Filter val -> String -filterClause includeTable conn f = - case (isNull, persistFilterToFilter f, varCount) of - (True, Eq, _) -> name ++ " IS NULL" - (True, Ne, _) -> name ++ " IS NOT NULL" - (False, Ne, _) -> concat - [ "(" - , name - , " IS NULL OR " - , name - , "<>?)" - ] - -- 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 - (True, In, _) -> concat - [ "(" - , name - , " IS NULL OR " - , name - , " IN " - , qmarks - , ")" - ] - (_, NotIn, 0) -> "1=1" - (False, NotIn, _) -> concat - [ "(" - , name - , " IS NULL OR " - , name - , " NOT IN " - , qmarks - , ")" - ] - (True, NotIn, _) -> concat - [ "(" - , name - , " IS NOT NULL AND " - , name - , " NOT IN " - , qmarks - , ")" - ] - _ -> name ++ showSqlFilter (persistFilterToFilter f) ++ "?" - where - isNull = any (== PersistNull) - $ either return id - $ persistFilterToValue f - t = entityDef $ dummyFromFilts [f] - name = - (if includeTable - then (++) (escapeName conn (rawTableName t) ++ ".") - else id) - $ escapeName conn $ getFieldName t $ persistFilterToFieldName f - qmarks = case persistFilterToValue f of - Left _ -> "?" - Right x -> - let x' = filter (/= PersistNull) x - in '(' : intercalate "," (map (const "?") x') ++ ")" - varCount = case persistFilterToValue f 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 " - -dummyFromFilts :: [Filter v] -> v -dummyFromFilts _ = error "dummyFromFilts" - -getFieldName :: EntityDef -> String -> RawName -getFieldName t s = rawFieldName $ tableColumn t s - -tableColumn :: EntityDef -> String -> (String, String, [String]) -tableColumn _ "id" = ("id", "Int64", []) -tableColumn t s = go $ entityColumns t - where - go [] = error $ "Unknown table column: " ++ s - go ((x, y, z):rest) - | x == s = (x, y, z) - | otherwise = go rest - -getFiltsValues :: PersistEntity val => [Filter val] -> [PersistValue] -getFiltsValues = - concatMap $ go . persistFilterToValue - where - go (Left PersistNull) = [] - go (Left x) = [x] - go (Right xs) = filter (/= PersistNull) xs - -dummyFromOrder :: Order a -> a -dummyFromOrder _ = undefined - -orderClause :: PersistEntity val => Bool -> Connection -> Order val -> String -orderClause includeTable conn o = - name ++ case persistOrderToOrder o of - Asc -> "" - Desc -> " DESC" - where - t = entityDef $ dummyFromOrder o - name = - (if includeTable - then (++) (escapeName conn (rawTableName t) ++ ".") - else id) - $ escapeName conn $ getFieldName t $ persistOrderToFieldName o +{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PackageImports #-}+-- | Code that is only needed for writing GenericSql backends.+module Database.Persist.GenericSql.Internal+ ( Connection (..)+ , Statement (..)+ , withSqlConn+ , withSqlPool+ , RowPopper+ , mkColumns+ , Column (..)+ , UniqueDef'+ , refName+ , tableColumns+ , rawFieldName+ , rawTableName+ , 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 (fromJust)+import Control.Arrow+import Control.Monad.IO.Control (MonadControlIO)+import Control.Exception.Control (bracket)+import Database.Persist.Util (nullable)+import Data.List (intercalate)+import Data.Text (Text)++type RowPopper m = m (Maybe [PersistValue])++data Connection = Connection+ { prepare :: Text -> IO Statement+ , insertSql :: RawName -> [RawName] -> Either Text (Text, Text)+ , stmtMap :: IORef (Map.Map Text Statement)+ , close :: IO ()+ , migrateSql :: forall v. PersistEntity v+ => (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+ }+data Statement = Statement+ { finalize :: IO ()+ , reset :: IO ()+ , execute :: [PersistValue] -> IO ()+ , withStmt :: forall a m. MonadControlIO m+ => [PersistValue] -> (RowPopper m -> m a) -> m a+ }++withSqlPool :: MonadControlIO m+ => IO Connection -> Int -> (Pool Connection -> m a) -> m a+withSqlPool mkConn = createPool mkConn close'++withSqlConn :: MonadControlIO m => IO Connection -> (Connection -> m a) -> m a+withSqlConn open = bracket (liftIO open) (liftIO . close')++close' :: Connection -> IO ()+close' conn = do+ readIORef (stmtMap conn) >>= mapM_ finalize . Map.elems+ close conn++-- | Create the list of columns for the given entity.+mkColumns :: PersistEntity val => val -> ([Column], [UniqueDef'])+mkColumns val =+ (cols, uniqs)+ where+ colNameMap = map (columnName &&& rawFieldName) $ entityColumns t+ uniqs = map (RawName *** map (fromJust . flip lookup colNameMap))+ $ map (uniqueName &&& uniqueColumns)+ $ entityUniques t -- FIXME don't use fromJust+ cols = zipWith go (tableColumns t) $ toPersistFields $ halfDefined `asTypeOf` val+ t = entityDef val+ tn = rawTableName t+ go (name, t', as) p =+ Column name (nullable as) (sqlType p) (def as) (ref name t' as)+ 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+ 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++refName :: RawName -> RawName -> RawName+refName (RawName table) (RawName column) =+ RawName $ table ++ '_' : column ++ "_fkey"++data Column = Column+ { cName :: RawName+ , cNull :: Bool+ , cType :: SqlType+ , cDefault :: Maybe String+ , cReference :: (Maybe (RawName, RawName)) -- table name, constraint name+ }++getSqlValue :: [String] -> Maybe String+getSqlValue (('s':'q':'l':'=':x):_) = Just x+getSqlValue (_:x) = getSqlValue x+getSqlValue [] = Nothing++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++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 fs) = combineAND fs+ 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, _) -> (name ++ " IS NULL", [])+ -- 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"++getFieldName :: EntityDef -> String -> RawName+getFieldName t s = rawFieldName $ tableColumn t s++tableColumn :: EntityDef -> String -> ColumnDef+tableColumn _ "id" = ColumnDef "id" "Int64" []+tableColumn t s = go $ entityColumns t+ where+ go [] = error $ "Unknown table column: " ++ s+ go (ColumnDef x y z:rest)+ | x == s = ColumnDef x y z+ | otherwise = go rest++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
Database/Persist/GenericSql/Raw.hs view
@@ -1,54 +1,55 @@-{-# LANGUAGE PackageImports #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} -module Database.Persist.GenericSql.Raw - ( withStmt - , execute - , SqlPersist (..) - , getStmt' - , getStmt - ) where - -import qualified Database.Persist.GenericSql.Internal as I -import Database.Persist.GenericSql.Internal hiding (execute, withStmt) -import Database.Persist.Base (PersistValue) -import Data.IORef -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader -import qualified Data.Map as Map -import Control.Applicative (Applicative) -import Control.Monad.Trans.Class (MonadTrans (..)) -import Control.Monad.IO.Control (MonadControlIO (..)) -import Data.Text (Text) - -newtype SqlPersist m a = SqlPersist { unSqlPersist :: ReaderT Connection m a } - deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadControlIO) - -withStmt :: MonadControlIO 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 - -execute :: MonadIO m => Text -> [PersistValue] -> SqlPersist m () -execute sql vals = do - stmt <- getStmt sql - liftIO $ I.execute stmt vals - liftIO $ reset stmt - -getStmt :: MonadIO m => Text -> SqlPersist m Statement -getStmt sql = do - conn <- SqlPersist ask - liftIO $ getStmt' conn sql - -getStmt' :: Connection -> Text -> IO Statement -getStmt' conn sql = do - smap <- liftIO $ readIORef $ stmtMap conn - case Map.lookup sql smap of - Just stmt -> return stmt - Nothing -> do - stmt <- liftIO $ prepare conn sql - liftIO $ writeIORef (stmtMap conn) $ Map.insert sql stmt smap - return stmt +{-# LANGUAGE PackageImports #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+module Database.Persist.GenericSql.Raw+ ( withStmt+ , execute+ , SqlPersist (..)+ , getStmt'+ , getStmt+ ) where++import qualified Database.Persist.GenericSql.Internal as I+import Database.Persist.GenericSql.Internal hiding (execute, withStmt)+import Database.Persist.Base (PersistValue)+import Data.IORef+import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import qualified Data.Map as Map+import Control.Applicative (Applicative)+import Control.Monad.Trans.Class (MonadTrans (..))+import Control.Monad.IO.Control (MonadControlIO (..))+import Data.Text (Text)+import Control.Monad (MonadPlus)++newtype SqlPersist m a = SqlPersist { unSqlPersist :: ReaderT Connection m a }+ deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadControlIO, MonadPlus)++withStmt :: MonadControlIO 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++execute :: MonadIO m => Text -> [PersistValue] -> SqlPersist m ()+execute sql vals = do+ stmt <- getStmt sql+ liftIO $ I.execute stmt vals+ liftIO $ reset stmt++getStmt :: MonadIO m => Text -> SqlPersist m Statement+getStmt sql = do+ conn <- SqlPersist ask+ liftIO $ getStmt' conn sql++getStmt' :: Connection -> Text -> IO Statement+getStmt' conn sql = do+ smap <- liftIO $ readIORef $ stmtMap conn+ case Map.lookup sql smap of+ Just stmt -> return stmt+ Nothing -> do+ stmt <- liftIO $ prepare conn sql+ liftIO $ writeIORef (stmtMap conn) $ Map.insert sql stmt smap+ return stmt
Database/Persist/Join.hs view
@@ -1,55 +1,57 @@-{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -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 RunJoin a where - type Result a - runJoin :: PersistBackend m => a -> m (Result a) - -data SelectOneMany one many = SelectOneMany - { somFilterOne :: [Filter one] - , somOrderOne :: [Order one] - , somFilterMany :: [Filter many] - , somOrderMany :: [Order many] - , somFilterKeys :: [Key one] -> Filter many - , somGetKey :: many -> Key one - , somIncludeNoMatch :: Bool - } - -selectOneMany :: ([Key one] -> Filter many) -> (many -> Key one) -> SelectOneMany one many -selectOneMany filts get' = SelectOneMany [] [] [] [] filts get' False -instance (PersistEntity one, PersistEntity many, Ord (Key one)) - => RunJoin (SelectOneMany one many) where - type Result (SelectOneMany one many) = - [((Key one, one), [(Key many, many)])] - runJoin (SelectOneMany oneF oneO manyF manyO eq getKey isOuter) = do - x <- selectList oneF oneO 0 0 - -- FIXME use select instead of selectList - y <- selectList (eq (map fst x) : manyF) manyO 0 0 - 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 []) +{-# 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 view
@@ -1,98 +1,104 @@-{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -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 (SqlPersist (SqlPersist)) -import Database.Persist.GenericSql.Internal hiding (withStmt) -import Database.Persist.GenericSql.Raw (withStmt) -import Control.Monad.Trans.Reader (ask) -import Control.Monad.IO.Control (MonadControlIO) -import Data.Function (on) -import Control.Arrow ((&&&)) -import Data.Text (pack) - -fromPersistValuesId :: PersistEntity v => [PersistValue] -> Either String (Key v, v) -fromPersistValuesId [] = Left "fromPersistValuesId: No values provided" -fromPersistValuesId (i:rest) = - case fromPersistValues rest of - Left e -> Left e - Right x -> Right (toPersistKey i, x) - -class RunJoin a where - runJoin :: MonadControlIO m => a -> SqlPersist m (J.Result a) - -instance (PersistEntity one, PersistEntity many, Eq (Key one)) - => RunJoin (SelectOneMany one many) where - runJoin = selectOneMany' - -selectOneMany' :: (MonadControlIO m, - PersistEntity d, - PersistEntity val1, - PersistEntity val, - PersistEntity b, - Eq (Key b)) => - SelectOneMany val val1 -> SqlPersist m [((Key b, b), [(Key d, d)])] -selectOneMany' (SelectOneMany oneF oneO manyF manyO eq _getKey isOuter) = do - conn <- SqlPersist ask - liftM go $ withStmt (sql conn) (getFiltsValues oneF ++ getFiltsValues 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 $ persistFilterToFieldName $ eq undefined - , if null filts - then "" - else " WHERE " ++ intercalate " AND " filts - , if null ords - then "" - else " ORDER BY " ++ intercalate ", " ords - ] - where - filts = map (filterClause True conn) oneF ++ map (filterClause True conn) manyF - ords = map (orderClause True conn) oneO ++ map (orderClause True conn) 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 - cols = tableColumns $ entityDef e +{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+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)+import Control.Monad.IO.Control (MonadControlIO)+import Data.Function (on)+import Control.Arrow ((&&&))+import Data.Text (pack)++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 :: MonadControlIO 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+ 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,84 +1,84 @@-module Database.Persist.Quasi - ( parse - ) where - -import Database.Persist.Base -import Data.Char -import Data.Maybe (mapMaybe) -import Text.ParserCombinators.Parsec hiding (parse, token) -import qualified Text.ParserCombinators.Parsec as Parsec - --- | Parses a quasi-quoted syntax into a list of entity definitions. -parse :: String -> [EntityDef] -parse = map parse' . nest . map words' - . removeLeadingSpaces - . map killCarriage - . lines - -removeLeadingSpaces :: [String] -> [String] -removeLeadingSpaces x = - let y = filter (not . null) x - in if all isSpace (map head y) - then removeLeadingSpaces (map tail y) - else y - -killCarriage :: String -> String -killCarriage "" = "" -killCarriage s - | last s == '\r' = init s - | otherwise = s - -words' :: String -> (Bool, [String]) -words' s = case Parsec.parse words'' s s of - Left e -> error $ show e - Right x -> x - -words'' :: Parser (Bool, [String]) -words'' = do - s <- fmap (not . null) $ many space - t <- many token - eof - return (s, takeWhile (/= "--") t) - where - token = do - t <- (char '"' >> quoted) <|> unquoted - spaces - return t - quoted = do - s <- many1 $ noneOf "\"" - _ <- char '"' - return s - unquoted = many1 $ noneOf " \t" - -nest :: [(Bool, [String])] -> [(String, [String], [[String]])] -nest ((False, name:entattribs):rest) = - let (x, y) = break (not . fst) rest - in (name, entattribs, map snd x) : nest y -nest ((False, []):_) = error "Indented line must contain at least name" -nest ((True, _):_) = error "Blocks must begin with non-indented lines" -nest [] = [] - -parse' :: (String, [String], [[String]]) -> EntityDef -parse' (name, entattribs, attribs) = - EntityDef name entattribs cols uniqs derives - where - cols = concatMap takeCols attribs - uniqs = concatMap takeUniqs attribs - derives = case mapMaybe takeDerives attribs of - [] -> ["Show", "Read", "Eq"] - x -> concat x - -takeCols :: [String] -> [(String, String, [String])] -takeCols ("deriving":_) = [] -takeCols (n@(f:_):ty:rest) - | isLower f = [(n, ty, rest)] -takeCols _ = [] - -takeUniqs :: [String] -> [(String, [String])] -takeUniqs (n@(f:_):rest) - | isUpper f = [(n, rest)] -takeUniqs _ = [] - -takeDerives :: [String] -> Maybe [String] -takeDerives ("deriving":rest) = Just rest -takeDerives _ = Nothing +module Database.Persist.Quasi+ ( parse + ) where++import Database.Persist.Base+import Data.Char+import Data.Maybe (mapMaybe)+import Text.ParserCombinators.Parsec hiding (parse, token)+import qualified Text.ParserCombinators.Parsec as Parsec++-- | Parses a quasi-quoted syntax into a list of entity definitions.+parse :: String -> [EntityDef]+parse = map parse' . nest . map words'+ . removeLeadingSpaces+ . map killCarriage+ . lines++removeLeadingSpaces :: [String] -> [String]+removeLeadingSpaces x =+ let y = filter (not . null) x+ in if all isSpace (map head y)+ then removeLeadingSpaces (map tail y)+ else y++killCarriage :: String -> String+killCarriage "" = ""+killCarriage s+ | last s == '\r' = init s+ | otherwise = s++words' :: String -> (Bool, [String])+words' s = case Parsec.parse words'' s s of+ Left e -> error $ show e+ Right x -> x++words'' :: Parser (Bool, [String])+words'' = do+ s <- fmap (not . null) $ many space+ t <- many token+ eof+ return (s, takeWhile (/= "--") t)+ where+ token = do+ t <- (char '"' >> quoted) <|> unquoted+ spaces+ return t+ quoted = do+ s <- many1 $ noneOf "\""+ _ <- char '"'+ return s+ unquoted = many1 $ noneOf " \t"++nest :: [(Bool, [String])] -> [(String, [String], [[String]])]+nest ((False, name:entattribs):rest) =+ let (x, y) = break (not . fst) rest+ in (name, entattribs, map snd x) : nest y+nest ((False, []):_) = error "Indented line must contain at least name"+nest ((True, _):_) = error "Blocks must begin with non-indented lines"+nest [] = []++parse' :: (String, [String], [[String]]) -> EntityDef+parse' (name, entattribs, attribs) =+ EntityDef name entattribs cols uniqs derives+ where+ cols = mapMaybe takeCols attribs+ uniqs = mapMaybe takeUniqs 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++takeUniqs :: [String] -> Maybe UniqueDef+takeUniqs (n@(f:_):rest)+ | isUpper f = Just $ UniqueDef n rest+takeUniqs _ = Nothing++takeDerives :: [String] -> Maybe [String]+takeDerives ("deriving":rest) = Just rest+takeDerives _ = Nothing
Database/Persist/TH/Library.hs view
@@ -1,19 +1,19 @@-{-# LANGUAGE CPP #-} -#include "cabal_macros.h" -module Database.Persist.TH.Library - ( apE - ) where - -#if MIN_VERSION_base(4,3,0) -import Control.Applicative -#endif - -apE :: Either x (y -> z) -> Either x y -> Either x z - -#if MIN_VERSION_base(4,3,0) -apE = (<*>) -#else -apE (Left x) _ = Left x -apE _ (Left x) = Left x -apE (Right f) (Right y) = Right (f y) -#endif +{-# LANGUAGE CPP #-}+#include "cabal_macros.h"+module Database.Persist.TH.Library+ ( apE+ ) where++#if MIN_VERSION_base(4,3,0)+import Control.Applicative+#endif++apE :: Either x (y -> z) -> Either x y -> Either x z++#if MIN_VERSION_base(4,3,0)+apE = (<*>)+#else+apE (Left x) _ = Left x+apE _ (Left x) = Left x+apE (Right f) (Right y) = Right (f y)+#endif
Database/Persist/Util.hs view
@@ -1,17 +1,17 @@-module Database.Persist.Util - ( nullable - , deprecate - ) where - -import System.IO.Unsafe (unsafePerformIO) - -nullable :: [String] -> Bool -nullable s - | "Maybe" `elem` s = True - | "null" `elem` s = deprecate "Please replace null with Maybe" True - | otherwise = False - -deprecate :: String -> a -> a -deprecate s x = unsafePerformIO $ do - putStrLn $ "DEPRECATED: " ++ s - return x +module Database.Persist.Util+ ( nullable+ , deprecate+ ) where++import System.IO.Unsafe (unsafePerformIO)++nullable :: [String] -> Bool+nullable s+ | "Maybe" `elem` s = True+ | "null" `elem` s = deprecate "Please replace null with Maybe" True+ | otherwise = False++deprecate :: String -> a -> a+deprecate s x = unsafePerformIO $ do+ putStrLn $ "DEPRECATED: " ++ s+ return x
LICENSE view
@@ -1,25 +1,25 @@-The following license covers this documentation, and the source code, except -where otherwise indicated. - -Copyright 2010, Michael Snoyman. All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -* Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO -EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, -INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, -OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE -OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2010, Michael Snoyman. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.lhs view
@@ -1,7 +1,7 @@-#!/usr/bin/env runhaskell - -> module Main where -> import Distribution.Simple - -> main :: IO () -> main = defaultMain +#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
persistent.cabal view
@@ -1,72 +1,75 @@-name: persistent -version: 0.5.1 -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. -category: Database, Yesod -stability: Stable -cabal-version: >= 1.6 -build-type: Simple -homepage: http://docs.yesodweb.com/book/persistent - -library - if flag(test) - Buildable: False - build-depends: base >= 4 && < 5 - , bytestring >= 0.9 && < 0.10 - , transformers >= 0.2.1 && < 0.3 - , time >= 1.1.4 && < 1.3 - , text >= 0.8 && < 0.12 - , containers >= 0.2 && < 0.5 - , parsec >= 2.1 && < 4 - , enumerator >= 0.4.9 && < 0.5 - , monad-control >= 0.2 && < 0.3 - , pool >= 0.1 && < 0.2 - , blaze-html >= 0.4 && < 0.5 - exposed-modules: Database.Persist - Database.Persist.Base - Database.Persist.Quasi - Database.Persist.GenericSql - Database.Persist.GenericSql.Internal - Database.Persist.GenericSql.Raw - Database.Persist.TH.Library - Database.Persist.Util - Database.Persist.Join - Database.Persist.Join.Sql - ghc-options: -Wall - -Flag test - Description: Build the runtests executables. - Default: False - -Flag test-postgresql - Description: Build the runtests executable with Postgresql support. - Default: True - -executable runtests - if flag(test) - Buildable: True - build-depends: haskell98, - HUnit, - test-framework, - test-framework-hunit, - base >= 4 && < 5, - template-haskell >= 2.4 && < 2.6, - HDBC-postgresql, - HDBC, - web-routes-quasi >= 0.7 && < 0.8 - if flag(test-postgresql) - cpp-options: -DWITH_POSTGRESQL - else - Buildable: False - hs-source-dirs: ., packages/template, backends/sqlite, backends/postgresql - main-is: runtests.hs - ghc-options: -Wall - extra-libraries: sqlite3 - -source-repository head - type: git - location: git://github.com/snoyberg/persistent.git +name: persistent+version: 0.6.1+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.+category: Database, Yesod+stability: Stable+cabal-version: >= 1.8+build-type: Simple+homepage: http://www.yesodweb.com/book/persistent++library+ build-depends: base >= 4 && < 5+ , bytestring >= 0.9 && < 0.10+ , transformers >= 0.2.1 && < 0.3+ , time >= 1.1.4 && < 1.3+ , text >= 0.8 && < 0.12+ , containers >= 0.2 && < 0.5+ , parsec >= 2.1 && < 4+ , enumerator >= 0.4.9 && < 0.5+ , monad-control >= 0.2 && < 0.3+ , pool >= 0.1 && < 0.2+ , blaze-html >= 0.4 && < 0.5+ , path-pieces >= 0.0 && < 0.1+ , mtl >= 2.0 && < 2.1+ exposed-modules: Database.Persist+ Database.Persist.Base+ Database.Persist.Quasi+ Database.Persist.GenericSql+ Database.Persist.GenericSql.Internal+ Database.Persist.GenericSql.Raw+ Database.Persist.TH.Library+ Database.Persist.Util+ Database.Persist.Join+ Database.Persist.Join.Sql+ ghc-options: -Wall++test-suite test+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: test, persistent-template, persistent-sqlite, persistent-postgresql, persistent-mongoDB++ build-depends: HUnit+ , hspec >= 0.6.1 && < 0.7+ , file-location >= 0.4 && < 0.5+ , base >= 4 && < 5+ , template-haskell >= 2.4 && < 2.7+ , HDBC-postgresql+ , HDBC+ -- mongoDB dependencies+ , mongoDB >= 1.0 && < 1.1+ , cereal+ , network+ , compact-string-fix+ , bson+ , persistent+ , path-pieces+ , text+ , transformers+ , monad-control+ , containers+ , bytestring++ -- these are mutually exclusive options+ -- cpp-options: -DWITH_POSTGRESQL+ -- cpp-options: -DWITH_MONGODB -DDEBUG+ ghc-options: -Wall+ extra-libraries: sqlite3++source-repository head+ type: git+ location: git://github.com/yesodweb/persistent.git
− runtests.hs
@@ -1,457 +0,0 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - -import Test.Framework (defaultMain, testGroup, Test) -import Test.Framework.Providers.HUnit --- import Test.Framework.Providers.QuickCheck -import Test.HUnit hiding (Test) - -import Database.Persist.Sqlite -#if WITH_POSTGRESQL -import Database.Persist.Postgresql -#endif -import Database.Persist.TH -import Control.Monad.IO.Class - -import Database.Persist.Join hiding (RunJoin) -import qualified Database.Persist.Join -import qualified Database.Persist.Join.Sql - -import Control.Monad.Trans.Reader -import Monad (unless) -import Data.Int -import Data.Word - -import Control.Exception (SomeException) -import qualified Control.Exception.Control as Control - -infix 1 /=@, @/= - -(/=@) :: (Eq a, Show a, MonadIO m) => a -> a -> m () -expected /=@ actual = liftIO $ assertNotEqual "" expected actual - -(@/=) :: (Eq a, Show a, MonadIO m) => a -> a -> m () -actual @/= expected = liftIO $ assertNotEqual "" expected actual - -assertNotEqual :: (Eq a, Show a) => String -> a -> a -> Assertion -assertNotEqual preface expected actual = - unless (actual /= expected) (assertFailure msg) - where msg = (if null preface then "" else preface ++ "\n") ++ - "expected: " ++ show expected ++ "\n to not equal: " ++ show actual - -infix 1 @==, ==@ -expected @== actual = liftIO $ expected @?= actual -expected ==@ actual = liftIO $ expected @=? actual - -data PetType = Cat | Dog - deriving (Show, Read, Eq) -derivePersistField "PetType" - - -- FIXME Empty -share2 mkPersist (mkMigrate "testMigrate") [$persist| - - Person - name String Update Eq Ne Desc - age Int Update "Asc" Desc Lt "some ignored -- attribute" Eq Add - color String Maybe Eq Ne -- this is a comment sql=foobarbaz - PersonNameKey name -- this is a comment sql=foobarbaz - Pet - owner PersonId - name String - type PetType - NeedsPet - pet PetId - Number - int Int - int32 Int32 - word32 Word32 - int64 Int64 - word64 Word64 - - Author - name String Eq Asc - Entry - author AuthorId In - title String Desc -|] - --- connstr = "user=test password=test host=localhost port=5432 dbname=yesod_test" - -runConn f = do - (withSqlitePool "testdb" 1) $ runSqlPool f -#if WITH_POSTGRESQL - (withPostgresqlPool "user=test password=test host=localhost port=5432 dbname=test" 1) $ runSqlPool f -#endif - --- TODO: run tests in transaction -sqliteTest :: SqlPersist IO () -> Assertion -sqliteTest actions = do - runConn actions - runConn cleanDB - -cleanDB :: SqlPersist IO () -cleanDB = do - deleteWhere ([] :: [Filter Pet]) - deleteWhere ([] :: [Filter Person]) - deleteWhere ([] :: [Filter Number]) - deleteWhere ([] :: [Filter Entry]) - deleteWhere ([] :: [Filter Author]) - -setup :: SqlPersist IO () -setup = do - runMigration testMigrate - cleanDB - -main :: IO () -main = do - runConn setup - defaultMain [testSuite] - -testSuite :: Test -testSuite = testGroup "Database.Persistent" $ reverse - [ testCase "sqlite persistent" case_sqlitePersistent - , testCase "sqlite deleteWhere" case_sqliteDeleteWhere - , testCase "sqlite deleteBy" case_sqliteDeleteBy - , testCase "sqlite delete" case_sqliteDelete - , testCase "sqlite replace" case_sqliteReplace - , testCase "sqlite getBy" case_sqliteGetBy - , testCase "sqlite update" case_sqliteUpdate - , testCase "sqlite updateWhere" case_sqliteUpdateWhere - , testCase "sqlite selectList" case_sqliteSelectList - , testCase "large numbers" case_largeNumbers - , testCase "insertBy" case_insertBy - , testCase "derivePersistField" case_derivePersistField - , testCase "afterException" case_afterException - , testCase "idIn" case_idIn - , testCase "join (non-SQL)" case_joinNonSql - , testCase "join (SQL)" case_joinSql - ] - - -assertEmpty xs = liftIO $ assertBool "" (null xs) -assertNotEmpty xs = liftIO $ assertBool "" (not (null xs)) - -case_sqliteDeleteWhere = sqliteTest _deleteWhere -case_sqliteDeleteBy = sqliteTest _deleteBy -case_sqliteDelete = sqliteTest _delete -case_sqliteReplace = sqliteTest _replace -case_sqliteGetBy = sqliteTest _getBy -case_sqliteUpdate = sqliteTest _update -case_sqliteUpdateWhere = sqliteTest _updateWhere -case_sqliteSelectList = sqliteTest _selectList -case_sqlitePersistent = sqliteTest _persistent -case_largeNumbers = sqliteTest _largeNumbers -case_insertBy = sqliteTest _insertBy -case_derivePersistField = sqliteTest _derivePersistField -case_afterException = (withSqlitePool "testdb" 1) $ runSqlPool _afterException -case_idIn = sqliteTest _idIn -case_joinNonSql = sqliteTest _joinNonSql -case_joinSql = sqliteTest _joinSql - -_deleteWhere = do - key2 <- insert $ Person "Michael2" 90 Nothing - _ <- insert $ Person "Michael3" 90 Nothing - let p91 = Person "Michael4" 91 Nothing - key91 <- insert $ p91 - - ps90 <- selectList [PersonAgeEq 90] [] 0 0 - assertNotEmpty ps90 - deleteWhere [PersonAgeEq 90] - ps90 <- selectList [PersonAgeEq 90] [] 0 0 - assertEmpty ps90 - Nothing <- get key2 - - Just p2_91 <- get key91 - p91 @== p2_91 - -_deleteBy = do - key2 <- insert $ Person "Michael2" 27 Nothing - let p3 = Person "Michael3" 27 Nothing - key3 <- insert $ p3 - - ps2 <- selectList [PersonNameEq "Michael2"] [] 0 0 - assertNotEmpty ps2 - - deleteBy $ PersonNameKey "Michael2" - ps2 <- selectList [PersonNameEq "Michael2"] [] 0 0 - assertEmpty ps2 - - Just p32 <- get key3 - p3 @== p32 - -_delete = do - key2 <- insert $ Person "Michael2" 27 Nothing - let p3 = Person "Michael3" 27 Nothing - key3 <- insert $ p3 - - pm2 <- selectList [PersonNameEq "Michael2"] [] 0 0 - assertNotEmpty pm2 - delete key2 - pm2 <- selectList [PersonNameEq "Michael2"] [] 0 0 - assertEmpty pm2 - - Just p <- get key3 - p3 @== p - --- also a decent test of get -_replace = do - key2 <- insert $ Person "Michael2" 27 Nothing - let p3 = Person "Michael3" 27 Nothing - replace key2 p3 - Just p <- get key2 - p @== p3 - - -- test replace an empty key - delete key2 - Nothing <- get key2 - undefined <- replace key2 p3 - Nothing <- get key2 - return () - -_getBy = do - let p2 = Person "Michael2" 27 Nothing - key2 <- insert p2 - Just (k, p) <- getBy $ PersonNameKey "Michael2" - p @== p2 - k @== key2 - Nothing <- getBy $ PersonNameKey "Michael3" - - Just (k', p') <- getByValue p2 - k' @== k - p' @== p - return () - -_update = do - let p25 = Person "Michael" 25 Nothing - key25 <- insert p25 - update key25 [PersonAge 28, PersonName "Updated"] - Just pBlue28 <- get key25 - pBlue28 @== Person "Updated" 28 Nothing - update key25 [PersonAgeAdd 2] - Just pBlue30 <- get key25 - pBlue30 @== Person "Updated" 30 Nothing - -_updateWhere = do - let p1 = Person "Michael" 25 Nothing - let p2 = Person "Michael2" 25 Nothing - key1 <- insert p1 - key2 <- insert p2 - updateWhere [PersonNameEq "Michael2"] - [PersonAgeAdd 3, PersonName "Updated"] - Just pBlue28 <- get key2 - pBlue28 @== Person "Updated" 28 Nothing - Just p <- get key1 - p @== p1 - -_selectList = do - let p25 = Person "Michael" 25 Nothing - let p26 = Person "Michael2" 26 Nothing - key25 <- insert p25 - key26 <- insert p26 - ps <- selectList [] [] 0 0 - ps @== [(key25, p25), (key26, p26)] - -- limit - ps <- selectList [] [] 1 0 - ps @== [(key25, p25)] - -- offset -- FAILS! - ps <- selectList [] [] 0 1 - ps @== [(key26, p26)] - -- limit & offset - ps <- selectList [] [] 1 1 - ps @== [(key26, p26)] - - ps <- selectList [] [PersonAgeDesc] 0 0 - ps @== [(key26, p26), (key25, p25)] - ps <- selectList [PersonAgeEq 26] [] 0 0 - ps @== [(key26, p26)] - --- general tests transferred from already exising test file -_persistent = do - let mic = Person "Michael" 25 Nothing - micK <- insert mic - Just p <- get micK - p @== mic - - replace micK $ Person "Michael" 25 Nothing - Just p <- get micK - p @== mic - - replace micK $ Person "Michael" 26 Nothing - Just mic26 <- get micK - mic26 @/= mic - personAge mic26 @== (personAge mic) + 1 - - results <- selectList [PersonNameEq "Michael"] [] 0 0 - results @== [(micK, mic26)] - - results <- selectList [PersonAgeLt 28] [] 0 0 - results @== [(micK, mic26)] - - update micK [PersonAge 28] - Just p28 <- get micK - personAge p28 @== 28 - - updateWhere [PersonNameEq "Michael"] [PersonAge 29] - Just mic29 <- get micK - personAge mic29 @== 29 - - let eli = Person "Eliezer" 2 $ Just "blue" - _ <- insert eli - pasc <- selectList [] [PersonAgeAsc] 0 0 - (map snd pasc) @== [eli, mic29] - - let abe30 = Person "Abe" 30 $ Just "black" - keyAbe30 <- insert abe30 - pdesc <- selectList [PersonAgeLt 30] [PersonNameDesc] 0 0 - (map snd pasc) @== [eli, mic29] - - abes <- selectList [PersonNameEq "Abe"] [] 0 0 - (map snd abes) @== [abe30] - - Just (k,p) <- getBy $ PersonNameKey "Michael" - p @== mic29 - - ps <- selectList [PersonColorEq $ Just "blue"] [] 0 0 - map snd ps @== [eli] - - ps <- selectList [PersonColorEq Nothing] [] 0 0 - map snd ps @== [mic29] - - ps <- selectList [PersonColorNe Nothing] [] 0 0 - map snd ps @== [eli, abe30] - - delete micK - Nothing <- get micK - return () - -_largeNumbers = do - go $ Number maxBound 0 0 0 0 - go $ Number 0 maxBound 0 0 0 - go $ Number 0 0 maxBound 0 0 - go $ Number 0 0 0 maxBound 0 - go $ Number 0 0 0 0 maxBound - - go $ Number minBound 0 0 0 0 - go $ Number 0 minBound 0 0 0 - go $ Number 0 0 minBound 0 0 - go $ Number 0 0 0 minBound 0 - go $ Number 0 0 0 0 minBound - where - go x = do - xid <- insert x - x' <- get xid - liftIO $ x' @?= Just x - -_insertBy = do - Right _ <- insertBy $ Person "name" 1 Nothing - Left _ <- insertBy $ Person "name" 1 Nothing - Right _ <- insertBy $ Person "name2" 1 Nothing - return () - -_derivePersistField = do - person <- insert $ Person "pet owner" 30 Nothing - cat <- insert $ Pet person "Mittens" Cat - Just cat' <- get cat - liftIO $ petType cat' @?= Cat - dog <- insert $ Pet person "Spike" Dog - Just dog' <- get dog - liftIO $ petType dog' @?= Dog - -_afterException = do - _ <- insert $ Person "A" 0 Nothing - _ <- (insert (Person "A" 1 Nothing) >> return ()) `Control.catch` catcher - _ <- insert $ Person "B" 0 Nothing - return () - where - catcher :: Monad m => SomeException -> m () - catcher _ = return () - -_idIn = do - let p1 = Person "A" 0 Nothing - p2 = Person "B" 1 Nothing - p3 = Person "C" 2 Nothing - pid1 <- insert p1 - _pid2 <- insert p2 - pid3 <- insert p3 - x <- selectList [PersonIdIn [pid1, pid3]] [] 0 0 - liftIO $ x @?= [(pid1, p1), (pid3, p3)] - -_joinNonSql = _joinGen Database.Persist.Join.runJoin -_joinSql = _joinGen Database.Persist.Join.Sql.runJoin - -_joinGen run = do - a <- insert $ Author "a" - a1 <- insert $ Entry a "a1" - a2 <- insert $ Entry a "a2" - a3 <- insert $ Entry a "a3" - b <- insert $ Author "b" - b1 <- insert $ Entry b "b1" - b2 <- insert $ Entry b "b2" - c <- insert $ Author "c" - - x <- run $ selectOneMany EntryAuthorIn entryAuthor - liftIO $ - x @?= - [ ((a, Author "a"), - [ (a1, Entry a "a1") - , (a2, Entry a "a2") - , (a3, Entry a "a3") - ]) - , ((b, Author "b"), - [ (b1, Entry b "b1") - , (b2, Entry b "b2") - ]) - ] - - y <- run $ (selectOneMany EntryAuthorIn entryAuthor) - { somFilterOne = [AuthorNameEq "a"] - } - liftIO $ - y @?= - [ ((a, Author "a"), - [ (a1, Entry a "a1") - , (a2, Entry a "a2") - , (a3, Entry a "a3") - ]) - ] - - z <- run (selectOneMany EntryAuthorIn entryAuthor) - { somOrderOne = [AuthorNameAsc] - , somOrderMany = [EntryTitleDesc] - } - liftIO $ - z @?= - [ ((a, Author "a"), - [ (a3, Entry a "a3") - , (a2, Entry a "a2") - , (a1, Entry a "a1") - ]) - , ((b, Author "b"), - [ (b2, Entry b "b2") - , (b1, Entry b "b1") - ]) - ] - - w <- run (selectOneMany EntryAuthorIn entryAuthor) - { somOrderOne = [AuthorNameAsc] - , somOrderMany = [EntryTitleDesc] - , somIncludeNoMatch = True - } - liftIO $ - w @?= - [ ((a, Author "a"), - [ (a3, Entry a "a3") - , (a2, Entry a "a2") - , (a1, Entry a "a1") - ]) - , ((b, Author "b"), - [ (b2, Entry b "b2") - , (b1, Entry b "b1") - ]) - , ((c, Author "c"), []) - ]