diff --git a/Database/Persist.hs b/Database/Persist.hs --- a/Database/Persist.hs +++ b/Database/Persist.hs @@ -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]] diff --git a/Database/Persist/Base.hs b/Database/Persist/Base.hs --- a/Database/Persist/Base.hs +++ b/Database/Persist/Base.hs @@ -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 diff --git a/Database/Persist/GenericSql.hs b/Database/Persist/GenericSql.hs --- a/Database/Persist/GenericSql.hs +++ b/Database/Persist/GenericSql.hs @@ -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 diff --git a/Database/Persist/GenericSql/Internal.hs b/Database/Persist/GenericSql/Internal.hs --- a/Database/Persist/GenericSql/Internal.hs +++ b/Database/Persist/GenericSql/Internal.hs @@ -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 diff --git a/Database/Persist/GenericSql/Raw.hs b/Database/Persist/GenericSql/Raw.hs --- a/Database/Persist/GenericSql/Raw.hs +++ b/Database/Persist/GenericSql/Raw.hs @@ -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 diff --git a/Database/Persist/Join.hs b/Database/Persist/Join.hs --- a/Database/Persist/Join.hs +++ b/Database/Persist/Join.hs @@ -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 []) diff --git a/Database/Persist/Join/Sql.hs b/Database/Persist/Join/Sql.hs --- a/Database/Persist/Join/Sql.hs +++ b/Database/Persist/Join/Sql.hs @@ -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" diff --git a/Database/Persist/Quasi.hs b/Database/Persist/Quasi.hs --- a/Database/Persist/Quasi.hs +++ b/Database/Persist/Quasi.hs @@ -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 diff --git a/Database/Persist/TH/Library.hs b/Database/Persist/TH/Library.hs --- a/Database/Persist/TH/Library.hs +++ b/Database/Persist/TH/Library.hs @@ -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 diff --git a/Database/Persist/Util.hs b/Database/Persist/Util.hs --- a/Database/Persist/Util.hs +++ b/Database/Persist/Util.hs @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -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 diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,72 +1,75 @@ -name: persistent -version: 0.5.1 -license: BSD3 -license-file: LICENSE -author: Michael Snoyman -maintainer: Michael Snoyman -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 +maintainer: Michael Snoyman +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 diff --git a/runtests.hs b/runtests.hs deleted file mode 100644 --- a/runtests.hs +++ /dev/null @@ -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"), []) - ]