diff --git a/Database/Persist.hs b/Database/Persist.hs --- a/Database/Persist.hs +++ b/Database/Persist.hs @@ -3,59 +3,29 @@ module Database.Persist ( PersistField (..) , PersistEntity (..) - , PersistBackend (..) + , PersistStore (..) + , PersistUnique (..) + , PersistQuery (..) , Key (..) - , selectList + , Entity (..) , insertBy , getJust , belongsTo , belongsToJust , getByValue , checkUnique - , Update (..) + , selectList + , deleteCascadeWhere + , SelectOpt (..) , Filter (..) + + -- * query combinators , (=.), (+=.), (-=.), (*=.), (/=.) , (==.), (!=.), (<.), (>.), (<=.), (>=.) , (<-.), (/<-.) , (||.) ) where --- Export public items from Database.Persist.Base --- Also defines Filter creation and composition operators. -import Database.Persist.Base - -infixr 3 =., +=., -=., *=., /=. -(=.), (+=.), (-=.), (*=.), (/=.) :: forall v typ. PersistField typ => EntityField v typ -> typ -> Update v --- | assign a field a value -f =. a = Update f a Assign --- | assign a field by addition (+=) -f +=. a = Update f a Add --- | assign a field by subtraction (-=) -f -=. a = Update f a Subtract --- | assign a field by multiplication (*=) -f *=. a = Update f a Multiply --- | assign a field by division (/=) -f /=. a = Update f a Divide - -infix 4 ==., <., <=., >., >=., !=. -(==.), (!=.), (<.), (<=.), (>.), (>=.) :: - forall v typ. PersistField typ => EntityField v typ -> typ -> Filter v -f ==. a = Filter f (Left a) Eq -f !=. a = Filter f (Left a) Ne -f <. a = Filter f (Left a) Lt -f <=. a = Filter f (Left a) Le -f >. a = Filter f (Left a) Gt -f >=. a = Filter f (Left a) Ge - -infix 4 <-., /<-. -(<-.), (/<-.) :: forall v typ. PersistField typ => EntityField v typ -> [typ] -> Filter v --- | In -f <-. a = Filter f (Right a) In --- | NotIn -f /<-. a = Filter f (Right a) NotIn - -infixl 3 ||. -(||.) :: forall v. [Filter v] -> [Filter v] -> [Filter v] --- | the OR of two lists of filters -a ||. b = [FilterOr [FilterAnd a, FilterAnd b]] +import Database.Persist.Store +import Database.Persist.Query diff --git a/Database/Persist/Base.hs b/Database/Persist/Base.hs deleted file mode 100644 --- a/Database/Persist/Base.hs +++ /dev/null @@ -1,593 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE CPP #-} - --- | API for database actions. The API deals with fields and entities. --- In SQL, a field corresponds to a column, and should be a single non-composite value. --- An entity corresponds to a SQL table, so an entity is a collection of fields. -module Database.Persist.Base - ( PersistValue (..) - , SqlType (..) - , PersistField (..) - , PersistEntity (..) - , PersistBackend (..) - , PersistFilter (..) - , PersistUpdate (..) - , SelectOpt (..) - , SomePersistField (..) - - , selectList - , insertBy - , getByValue - , getJust - , belongsTo - , belongsToJust - - , checkUnique - , DeleteCascade (..) - , deleteCascadeWhere - , PersistException (..) - , Update (..) - , updateFieldName - , Filter (..) - , Key (..) - -- * Definition - , EntityDef (..) - , ColumnName - , ColumnType - , ColumnDef (..) - , UniqueDef (..) - , fst3, snd3, third3 - , limitOffsetOrder - - -- * Config - , PersistConfig (..) - ) where - -import Data.Time (Day, TimeOfDay, UTCTime) -import Data.ByteString.Char8 (ByteString, unpack) -import Control.Applicative -import Data.Typeable (Typeable) -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Word (Word8, Word16, Word32, Word64) -import Text.Blaze (Html, unsafeByteString) -import Text.Blaze.Renderer.Utf8 (renderHtml) -import qualified Data.Text as T -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import Data.Enumerator hiding (consume, map) -import Data.Enumerator.List (consume) -import qualified Data.Enumerator.List as EL -import qualified Control.Monad.IO.Class as Trans - -import qualified Control.Exception as E -import Control.Monad.Trans.Error (Error (..)) - -import Data.Bits (bitSize) -import Control.Monad (liftM) - -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T -import Web.PathPieces (SinglePiece (..)) -import qualified Data.Text.Read -import Control.Monad.IO.Class (MonadIO) - -#if MIN_VERSION_monad_control(0, 3, 0) -import Control.Monad.Trans.Control (MonadBaseControl) -#define MBCIO MonadBaseControl IO -#else -import Control.Monad.IO.Control (MonadControlIO) -#define MBCIO MonadControlIO -#endif -import Data.Object (TextObject) - -fst3 :: forall t t1 t2. (t, t1, t2) -> t -fst3 (x, _, _) = x -snd3 :: forall t t1 t2. (t, t1, t2) -> t1 -snd3 (_, x, _) = x -third3 :: forall t t1 t2. (t, t1, t2) -> t2 -third3 (_, _, x) = x - -data PersistException - = PersistError String -- ^ Generic Exception - | PersistMarshalError String - | PersistInvalidField String - | PersistForeignConstraintUnmet String - | PersistMongoDBError String - | PersistMongoDBUnsupported String - deriving (Show, Typeable) - -instance E.Exception PersistException -instance Error PersistException where strMsg msg = PersistError msg - - - --- | A raw value which can be stored in any backend and can be marshalled to --- and from a 'PersistField'. -data PersistValue = PersistText T.Text - | PersistByteString ByteString - | PersistInt64 Int64 - | PersistDouble Double - | PersistBool Bool - | PersistDay Day - | PersistTimeOfDay TimeOfDay - | PersistUTCTime UTCTime - | PersistNull - | PersistList [PersistValue] - | PersistMap [(T.Text, PersistValue)] - | PersistObjectId ByteString -- ^ intended especially for MongoDB backend - deriving (Show, Read, Eq, Typeable, Ord) - -instance SinglePiece PersistValue where - fromSinglePiece t = - case Data.Text.Read.signed Data.Text.Read.decimal t of - Right (i, t') - | T.null t' -> Just $ PersistInt64 i - _ -> Just $ PersistText t - toSinglePiece x = - case fromPersistValue x of - Left e -> error e - Right y -> y - --- | A SQL data type. Naming attempts to reflect the underlying Haskell --- datatypes, eg SqlString instead of SqlVarchar. Different SQL databases may --- have different translations for these types. -data SqlType = SqlString - | SqlInt32 - | SqlInteger -- ^ FIXME 8-byte integer; should be renamed SqlInt64 - | SqlReal - | SqlBool - | SqlDay - | SqlTime - | SqlDayTime - | SqlBlob - deriving (Show, Read, Eq, Typeable) - --- | A value which can be marshalled to and from a 'PersistValue'. -class PersistField a where - toPersistValue :: a -> PersistValue - fromPersistValue :: PersistValue -> Either String a - sqlType :: a -> SqlType - isNullable :: a -> Bool - isNullable _ = False - -instance PersistField String where - toPersistValue = PersistText . T.pack - fromPersistValue (PersistText s) = Right $ T.unpack s - fromPersistValue (PersistByteString bs) = - Right $ T.unpack $ T.decodeUtf8With T.lenientDecode bs - fromPersistValue (PersistInt64 i) = Right $ show i - fromPersistValue (PersistDouble d) = Right $ show d - fromPersistValue (PersistDay d) = Right $ show d - fromPersistValue (PersistTimeOfDay d) = Right $ show d - fromPersistValue (PersistUTCTime d) = Right $ show d - fromPersistValue PersistNull = Left "Unexpected null" - fromPersistValue (PersistBool b) = Right $ show b - fromPersistValue (PersistList _) = Left "Cannot convert PersistList to String" - fromPersistValue (PersistMap _) = Left "Cannot convert PersistMap to String" - fromPersistValue (PersistObjectId _) = Left "Cannot convert PersistObjectId to String" - sqlType _ = SqlString - -instance PersistField ByteString where - toPersistValue = PersistByteString - fromPersistValue (PersistByteString bs) = Right bs - fromPersistValue x = T.encodeUtf8 <$> fromPersistValue x - sqlType _ = SqlBlob - -instance PersistField T.Text where - toPersistValue = PersistText - fromPersistValue (PersistText s) = Right s - fromPersistValue (PersistByteString bs) = - Right $ T.decodeUtf8With T.lenientDecode bs - fromPersistValue (PersistInt64 i) = Right $ T.pack $ show i - fromPersistValue (PersistDouble d) = Right $ T.pack $ show d - fromPersistValue (PersistDay d) = Right $ T.pack $ show d - fromPersistValue (PersistTimeOfDay d) = Right $ T.pack $ show d - fromPersistValue (PersistUTCTime d) = Right $ T.pack $ show d - fromPersistValue PersistNull = Left "Unexpected null" - fromPersistValue (PersistBool b) = Right $ T.pack $ show b - fromPersistValue (PersistList _) = Left "Cannot convert PersistList to Text" - fromPersistValue (PersistMap _) = Left "Cannot convert PersistMap to Text" - fromPersistValue (PersistObjectId _) = Left "Cannot convert PersistObjectId to Text" - sqlType _ = SqlString - -instance PersistField Html where - toPersistValue = PersistByteString . S.concat . L.toChunks . renderHtml - fromPersistValue = fmap unsafeByteString . fromPersistValue - sqlType _ = SqlString - -instance PersistField Int where - toPersistValue = PersistInt64 . fromIntegral - fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue x = Left $ "Expected Integer, received: " ++ show x - sqlType x = case bitSize x of - 32 -> SqlInt32 - _ -> SqlInteger - -instance PersistField Int8 where - toPersistValue = PersistInt64 . fromIntegral - fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue x = Left $ "Expected Integer, received: " ++ show x - sqlType _ = SqlInt32 - -instance PersistField Int16 where - toPersistValue = PersistInt64 . fromIntegral - fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue x = Left $ "Expected Integer, received: " ++ show x - sqlType _ = SqlInt32 - -instance PersistField Int32 where - toPersistValue = PersistInt64 . fromIntegral - fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue x = Left $ "Expected Integer, received: " ++ show x - sqlType _ = SqlInt32 - -instance PersistField Int64 where - toPersistValue = PersistInt64 . fromIntegral - fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue x = Left $ "Expected Integer, received: " ++ show x - sqlType _ = SqlInteger - -instance PersistField Word8 where - toPersistValue = PersistInt64 . fromIntegral - fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x - sqlType _ = SqlInt32 - -instance PersistField Word16 where - toPersistValue = PersistInt64 . fromIntegral - fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x - sqlType _ = SqlInt32 - -instance PersistField Word32 where - toPersistValue = PersistInt64 . fromIntegral - fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x - sqlType _ = SqlInteger - -instance PersistField Word64 where - toPersistValue = PersistInt64 . fromIntegral - fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x - sqlType _ = SqlInteger - -instance PersistField Double where - toPersistValue = PersistDouble - fromPersistValue (PersistDouble d) = Right d - fromPersistValue x = Left $ "Expected Double, received: " ++ show x - sqlType _ = SqlReal - -instance PersistField Bool where - toPersistValue = PersistBool - fromPersistValue (PersistBool b) = Right b - fromPersistValue (PersistInt64 i) = Right $ i /= 0 - fromPersistValue x = Left $ "Expected Bool, received: " ++ show x - sqlType _ = SqlBool - -instance PersistField Day where - toPersistValue = PersistDay - fromPersistValue (PersistDay d) = Right d - fromPersistValue x@(PersistText t) = - case reads $ T.unpack t of - (d, _):_ -> Right d - _ -> Left $ "Expected Day, received " ++ show x - fromPersistValue x@(PersistByteString s) = - case reads $ unpack s of - (d, _):_ -> Right d - _ -> Left $ "Expected Day, received " ++ show x - fromPersistValue x = Left $ "Expected Day, received: " ++ show x - sqlType _ = SqlDay - -instance PersistField TimeOfDay where - toPersistValue = PersistTimeOfDay - fromPersistValue (PersistTimeOfDay d) = Right d - fromPersistValue x@(PersistText t) = - case reads $ T.unpack t of - (d, _):_ -> Right d - _ -> Left $ "Expected TimeOfDay, received " ++ show x - fromPersistValue x@(PersistByteString s) = - case reads $ unpack s of - (d, _):_ -> Right d - _ -> Left $ "Expected TimeOfDay, received " ++ show x - fromPersistValue x = Left $ "Expected TimeOfDay, received: " ++ show x - sqlType _ = SqlTime - -instance PersistField UTCTime where - toPersistValue = PersistUTCTime - fromPersistValue (PersistUTCTime d) = Right d - fromPersistValue x@(PersistText t) = - case reads $ T.unpack t of - (d, _):_ -> Right d - _ -> Left $ "Expected UTCTime, received " ++ show x - fromPersistValue x@(PersistByteString s) = - case reads $ unpack s of - (d, _):_ -> Right d - _ -> Left $ "Expected UTCTime, received " ++ show x - fromPersistValue x = Left $ "Expected UTCTime, received: " ++ show x - sqlType _ = SqlDayTime - -instance PersistField a => PersistField (Maybe a) where - toPersistValue Nothing = PersistNull - toPersistValue (Just a) = toPersistValue a - fromPersistValue PersistNull = Right Nothing - fromPersistValue x = fmap Just $ fromPersistValue x - sqlType _ = sqlType (error "this is the problem" :: a) - isNullable _ = True - -data Update v = forall typ. PersistField typ => Update - { updateField :: EntityField v typ - , updateValue :: typ - , updateUpdate :: PersistUpdate -- FIXME Replace with expr down the road - } - -updateFieldName :: PersistEntity v => Update v -> String -updateFieldName (Update f _ _) = columnName $ persistColumnDef f - -data SelectOpt v = forall typ. Asc (EntityField v typ) - | forall typ. Desc (EntityField v typ) - | OffsetBy Int - | LimitTo Int - --- | Filters which are available for 'select', 'updateWhere' and --- 'deleteWhere'. Each filter constructor specifies the field being --- filtered on, the type of comparison applied (equals, not equals, etc) --- and the argument for the comparison. -data Filter v = forall typ. PersistField typ => Filter - { filterField :: EntityField v typ - , filterValue :: Either typ [typ] -- FIXME - , filterFilter :: PersistFilter -- FIXME - } - | FilterAnd [Filter v] -- ^ convenient for internal use, not needed for the API - | FilterOr [Filter v] - --- | A single database entity. For example, if writing a blog application, a --- blog entry would be an entry, containing fields such as title and content. -class PersistEntity val where - -- | Parameters: val and datatype of the field - data EntityField val :: * -> * - persistColumnDef :: EntityField val typ -> ColumnDef - - -- | Unique keys in existence on this entity. - data Unique val :: ((* -> *) -> * -> *) -> * - - entityDef :: val -> EntityDef - toPersistFields :: val -> [SomePersistField] - fromPersistValues :: [PersistValue] -> Either String val - halfDefined :: val - - persistUniqueToFieldNames :: Unique val backend -> [String] - persistUniqueToValues :: Unique val backend -> [PersistValue] - persistUniqueKeys :: val -> [Unique val backend] - -data SomePersistField = forall a. PersistField a => SomePersistField a -instance PersistField SomePersistField where - toPersistValue (SomePersistField a) = toPersistValue a - fromPersistValue x = fmap SomePersistField (fromPersistValue x :: Either String String) - sqlType (SomePersistField a) = sqlType a - -newtype Key (backend :: (* -> *) -> * -> *) entity = Key { unKey :: PersistValue } - deriving (Show, Read, Eq, Ord, PersistField) - -class (Trans.MonadIO (b m), Trans.MonadIO m, Monad (b m), Monad m) => PersistBackend b m where - - -- | Create a new record in the database, returning the newly created - -- identifier. - insert :: PersistEntity val => val -> b m (Key b val) - - -- | Replace the record in the database with the given key. Result is - -- undefined if such a record does not exist. - replace :: PersistEntity val => Key b val -> val -> b m () - - -- | Update individual fields on a specific record. - update :: PersistEntity val => Key b val -> [Update val] -> b m () - - -- | Update individual fields on any record matching the given criterion. - updateWhere :: PersistEntity val => [Filter val] -> [Update val] -> b m () - - -- | Delete a specific record by identifier. Does nothing if record does - -- not exist. - delete :: PersistEntity val => Key b val -> b m () - - -- | Delete a specific record by unique key. Does nothing if no record - -- matches. - deleteBy :: PersistEntity val => Unique val b -> b m () - - -- | Delete all records matching the given criterion. - deleteWhere :: PersistEntity val => [Filter val] -> b m () - - -- | Get a record by identifier, if available. - get :: PersistEntity val => Key b val -> b m (Maybe val) - - -- | Get a record by unique key, if available. Returns also the identifier. - getBy :: PersistEntity val => Unique val b -> b m (Maybe (Key b val, val)) - - -- | Get all records matching the given criterion in the specified order. - -- Returns also the identifiers. - selectEnum - :: PersistEntity val - => [Filter val] - -> [SelectOpt val] - -> Enumerator (Key b val, val) (b m) a - - -- | get just the first record for the criterion - selectFirst :: PersistEntity val - => [Filter val] - -> [SelectOpt val] - -> b m (Maybe (Key b val, val)) - selectFirst filts opts = run_ $ selectEnum filts ((LimitTo 1):opts) ==<< EL.head - - - -- | Get the 'Key's of all records matching the given criterion. - selectKeys :: PersistEntity val - => [Filter val] - -> Enumerator (Key b val) (b m) a - - -- | The total number of records fulfilling the given criterion. - count :: PersistEntity val => [Filter val] -> b m Int - --- | Insert a value, checking for conflicts with any unique constraints. If a --- duplicate exists in the database, it is returned as 'Left'. Otherwise, the --- new 'Key' is returned as 'Right'. -insertBy :: (PersistEntity v, PersistBackend b m) - => v -> b m (Either (Key b v, v) (Key b v)) -insertBy val = - go $ persistUniqueKeys val - where - go [] = Right `liftM` insert val - go (x:xs) = do - y <- getBy x - case y of - Nothing -> go xs - Just z -> return $ Left z - --- | A modification of 'getBy', which takes the 'PersistEntity' itself instead --- of a 'Unique' value. Returns a value matching /one/ of the unique keys. This --- function makes the most sense on entities with a single 'Unique' --- constructor. -getByValue :: (PersistEntity v, PersistBackend b m) - => v -> b m (Maybe (Key b v, v)) -getByValue val = - go $ persistUniqueKeys val - where - go [] = return Nothing - go (x:xs) = do - y <- getBy x - case y of - Nothing -> go xs - Just z -> return $ Just z - --- | curry this to make a convenience function that loads an associated model --- > foreign = belongsTo foeignId -belongsTo :: - (PersistBackend b m - , PersistEntity ent1 - , PersistEntity ent2) => (ent1 -> Maybe (Key b ent2)) -> ent1 -> b m (Maybe ent2) -belongsTo foreignKeyField model = case foreignKeyField model of - Nothing -> return Nothing - Just f -> get f - --- | same as belongsTo, but uses @getJust@ and therefore is similarly unsafe -belongsToJust :: - (PersistBackend b m - , PersistEntity ent1 - , PersistEntity ent2) => (ent1 -> Key b ent2) -> ent1 -> b m ent2 -belongsToJust getForeignKey model = getJust $ getForeignKey model - --- | Same as get, but for a non-null (not Maybe) foreign key --- Unsafe unless your database is enforcing that the foreign key is valid -getJust :: (PersistBackend b m, PersistEntity val, Show (Key b val)) => Key b val -> b m val -getJust key = get key >>= maybe - (Trans.liftIO . E.throwIO $ PersistForeignConstraintUnmet (show key)) - return - - --- | Check whether there are any conflicts for unique keys with this entity and --- existing entities in the database. --- --- Returns 'True' if the entity would be unique, and could thus safely be --- 'insert'ed; returns 'False' on a conflict. -checkUnique :: (PersistEntity val, PersistBackend b m) => val -> b m Bool -checkUnique val = - go $ persistUniqueKeys val - where - go [] = return True - go (x:xs) = do - y <- getBy x - case y of - Nothing -> go xs - Just _ -> return False - -limitOffsetOrder :: PersistEntity val => [SelectOpt val] -> (Int, Int, [SelectOpt val]) -limitOffsetOrder opts = - foldr go (0, 0, []) opts - where - go (LimitTo l) (_, b, c) = (l, b ,c) - go (OffsetBy o) (a, _, c) = (a, o, c) - go x (a, b, c) = (a, b, x : c) - --- | Call 'select' but return the result as a list. -selectList :: (PersistEntity val, PersistBackend b m) - => [Filter val] - -> [SelectOpt val] - -> b m [(Key b val, val)] -selectList a b = do - res <- run $ selectEnum a b ==<< consume - case res of - Left e -> Trans.liftIO . E.throwIO $ PersistError $ show e - Right x -> return x - -data EntityDef = EntityDef - { entityName :: String - , entityAttribs :: [String] - , entityColumns :: [ColumnDef] - , entityUniques :: [UniqueDef] - , entityDerives :: [String] - } - deriving Show - -type ColumnName = String -type ColumnType = String - -data ColumnDef = ColumnDef -- FIXME rename to FieldDef? Also, do we need a columnHaskellName and columnDBName? - { columnName :: ColumnName - , columnType :: ColumnType - , columnAttribs :: [String] - } - deriving Show - -data UniqueDef = UniqueDef - { uniqueName :: String - , uniqueColumns :: [ColumnName] - } - deriving Show - -data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le | In | NotIn - | BackendSpecificFilter String - deriving (Read, Show) - -class PersistEntity a => DeleteCascade a b where - deleteCascade :: PersistBackend b m => Key b a -> b m () - -deleteCascadeWhere :: (DeleteCascade a b, PersistBackend b m) - => [Filter a] -> b m () -deleteCascadeWhere filts = do - res <- run $ selectKeys filts $ Continue iter - case res of - Left e -> Trans.liftIO . E.throwIO $ PersistError $ show e - Right () -> return () - where - iter EOF = Iteratee $ return $ Yield () EOF - iter (Chunks keys) = Iteratee $ do - mapM_ deleteCascade keys - return $ Continue iter - - -data PersistUpdate = Assign | Add | Subtract | Multiply | Divide -- FIXME need something else here - deriving (Read, Show, Enum, Bounded) - -instance PersistField PersistValue where - toPersistValue = id - fromPersistValue = Right - sqlType _ = SqlInteger -- since PersistValue should only be used like this for keys, which in SQL are Int64 - --- | Represents a value containing all the configuration options for a specific --- backend. This abstraction makes it easier to write code that can easily swap --- backends. -class PersistConfig c where - type PersistConfigBackend c :: (* -> *) -> * -> * - type PersistConfigPool c - loadConfig :: TextObject -> Either String c - -- | I really don't want Applicative here, but it's necessary for Mongo. - withPool :: (Applicative m, MBCIO m, MonadIO m) => c -> (PersistConfigPool c -> m a) -> m a - runPool :: (MBCIO m, MonadIO m) => c -> PersistConfigBackend c m a - -> PersistConfigPool c - -> m a diff --git a/Database/Persist/EntityDef.hs b/Database/Persist/EntityDef.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/EntityDef.hs @@ -0,0 +1,53 @@ +module Database.Persist.EntityDef + ( -- * Helper types + HaskellName (..) + , DBName (..) + , FieldType (..) + , Attr + -- * Defs + , EntityDef (..) + , FieldDef (..) + , UniqueDef (..) + , ExtraLine + ) where + +import Data.Text (Text) +import Data.Map (Map) + +data EntityDef = EntityDef + { entityHaskell :: HaskellName + , entityDB :: DBName + , entityID :: DBName + , entityAttrs :: [Attr] + , entityFields :: [FieldDef] + , entityUniques :: [UniqueDef] + , entityDerives :: [Text] + , entityExtra :: Map Text [ExtraLine] + } + deriving (Show, Eq, Read, Ord) + +type ExtraLine = [Text] + +newtype HaskellName = HaskellName { unHaskellName :: Text } + deriving (Show, Eq, Read, Ord) +newtype DBName = DBName { unDBName :: Text } + deriving (Show, Eq, Read, Ord) +newtype FieldType = FieldType { unFieldType :: Text } + deriving (Show, Eq, Read, Ord) + +type Attr = Text + +data FieldDef = FieldDef + { fieldHaskell :: HaskellName + , fieldDB :: DBName + , fieldType :: FieldType + , fieldAttrs :: [Attr] + } + deriving (Show, Eq, Read, Ord) + +data UniqueDef = UniqueDef + { uniqueHaskell :: HaskellName + , uniqueDBName :: DBName + , uniqueFields :: [(HaskellName, DBName)] + } + deriving (Show, Eq, Read, Ord) diff --git a/Database/Persist/GenericSql.hs b/Database/Persist/GenericSql.hs --- a/Database/Persist/GenericSql.hs +++ b/Database/Persist/GenericSql.hs @@ -17,6 +17,15 @@ , Statement , runSqlConn , runSqlPool + , Key (..) + + -- * Raw SQL queries + -- $rawSql + , rawSql + , Entity(..) + , Single(..) + + -- * Migrations , Migration , parseMigration , parseMigration' @@ -28,22 +37,20 @@ , migrate , commit , rollback - , Key (..) ) where -import Database.Persist.Base -import Data.List (intercalate) +import qualified Prelude as P +import Prelude hiding ((++), unlines, concat, show) +import Control.Applicative ((<$>), (<*>)) +import Control.Arrow ((&&&)) +import Database.Persist.Store import Control.Monad.IO.Class import Control.Monad.Trans.Reader -import Control.Monad.Trans.Class (MonadTrans (..)) -import Data.Pool -import Control.Monad.Trans.Writer -import System.IO +import Data.Conduit.Pool import Database.Persist.GenericSql.Internal +import Database.Persist.GenericSql.Migration import qualified Database.Persist.GenericSql.Raw as R import Database.Persist.GenericSql.Raw (SqlPersist (..)) -import Control.Monad (liftM, unless) -import Data.Enumerator (Stream (..), Iteratee (..), Step (..)) #if MIN_VERSION_monad_control(0, 3, 0) import Control.Monad.Trans.Control (MonadBaseControl, control) import qualified Control.Exception as E @@ -54,33 +61,33 @@ #define MBCIO MonadControlIO #endif -import Control.Exception (throw, toException) -import Data.Text (Text, pack, unpack, snoc) -import qualified Data.Text.IO -import Web.PathPieces (SinglePiece (..)) +import Control.Exception (throw) +import Data.Text (Text, pack, unpack, concat) +import qualified Data.Text as T +import Web.PathPieces (PathPiece (..)) import qualified Data.Text.Read +import Data.Monoid (Monoid, mappend) +import Database.Persist.EntityDef +import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL type ConnectionPool = Pool Connection -instance SinglePiece (Key SqlPersist entity) where - toSinglePiece (Key (PersistInt64 i)) = toSinglePiece i - toSinglePiece k = throw $ PersistInvalidField $ "Invalid Key: " ++ show k - fromSinglePiece t = +instance PathPiece (Key SqlPersist entity) where + toPathPiece (Key (PersistInt64 i)) = toPathPiece i + toPathPiece k = throw $ PersistInvalidField $ "Invalid Key: " ++ show k + fromPathPiece t = case Data.Text.Read.signed Data.Text.Read.decimal t of Right (i, "") -> Just $ Key $ PersistInt64 i _ -> Nothing -withStmt' - :: (MBCIO m, MonadIO m) - => Text -> [PersistValue] - -> (RowPopper (SqlPersist m) -> SqlPersist m a) -> SqlPersist m a -withStmt' = R.withStmt - execute' :: MonadIO m => Text -> [PersistValue] -> SqlPersist m () execute' = R.execute +-- | Get a connection from the pool, run the given action, and then return the +-- connection to the pool. runSqlPool :: (MBCIO m, MonadIO m) => SqlPersist m a -> Pool Connection -> m a -runSqlPool r pconn = withPool' pconn $ runSqlConn r +runSqlPool r pconn = withResource pconn $ runSqlConn r runSqlConn :: (MBCIO m, MonadIO m) => SqlPersist m a -> Connection -> m a runSqlConn (SqlPersist r) conn = do @@ -92,19 +99,19 @@ liftIO $ commitC conn getter return x -instance (MonadIO m, MBCIO m) => PersistBackend SqlPersist m where +instance C.ResourceIO m => PersistStore SqlPersist m where insert val = do conn <- SqlPersist ask - let esql = insertSql conn (rawTableName t) (map fst3 $ tableColumns t) + let esql = insertSql conn (entityDB t) (map fieldDB $ entityFields t) i <- case esql of - Left sql -> withStmt' sql vals $ \pop -> do - Just [PersistInt64 i] <- pop + Left sql -> C.runResourceT $ R.withStmt sql vals C.$$ do + Just [PersistInt64 i] <- CL.head return i Right (sql1, sql2) -> do execute' sql1 vals - withStmt' sql2 [] $ \pop -> do - Just [PersistInt64 i] <- pop + C.runResourceT $ R.withStmt sql2 [] C.$$ do + Just [PersistInt64 i] <- CL.head return i return $ Key $ PersistInt64 i where @@ -114,257 +121,126 @@ replace k val = do conn <- SqlPersist ask let t = entityDef val - let sql = pack $ concat + let sql = concat [ "UPDATE " - , escapeName conn (rawTableName t) + , escapeName conn (entityDB t) , " SET " - , intercalate "," (map (go conn . fst3) $ tableColumns t) + , T.intercalate "," (map (go conn . fieldDB) $ entityFields t) , " WHERE id=?" ] execute' sql $ map toPersistValue (toPersistFields val) - ++ [unKey k] + `mappend` [unKey k] where go conn x = escapeName conn x ++ "=?" + insertKey = insrepHelper "INSERT" + + repsert = insrepHelper "REPLACE" + get k = do conn <- SqlPersist ask let t = entityDef $ dummyFromKey k - let cols = intercalate "," - $ map (\(x, _, _) -> escapeName conn x) $ tableColumns t - let sql = pack $ concat + let cols = T.intercalate "," + $ map (escapeName conn . fieldDB) $ entityFields t + let sql = concat [ "SELECT " , cols , " FROM " - , escapeName conn $ rawTableName t + , escapeName conn $ entityDB t , " WHERE id=?" ] - withStmt' sql [unKey k] $ \pop -> do - res <- pop + C.runResourceT $ R.withStmt sql [unKey k] C.$$ do + res <- CL.head case res of Nothing -> return Nothing Just vals -> case fromPersistValues vals of - Left e -> error $ "get " ++ show (unKey k) ++ ": " ++ e + Left e -> error $ unpack $ "get " ++ show (unKey k) ++ ": " ++ e Right v -> return $ Just v - count filts = do - conn <- SqlPersist ask - let wher = if null filts - then "" - else filterClause False conn filts - let sql = pack $ concat - [ "SELECT COUNT(*) FROM " - , escapeName conn $ rawTableName t - , wher - ] - withStmt' sql (getFiltsValues conn filts) $ \pop -> do - Just [PersistInt64 i] <- pop - return $ fromIntegral i - where - t = entityDef $ dummyFromFilts filts - - selectEnum filts opts = - Iteratee . start - where - (limit, offset, orders) = limitOffsetOrder opts - - start x = do - conn <- SqlPersist ask - withStmt' (sql conn) (getFiltsValues conn filts) $ loop x - loop (Continue k) pop = do - res <- pop - case res of - Nothing -> return $ Continue k - Just vals -> do - case fromPersistValues' vals of - Left s -> return $ Error $ toException - $ PersistMarshalError s - Right row -> do - step <- runIteratee $ k $ Chunks [row] - loop step pop - loop step _ = return step - t = entityDef $ dummyFromFilts filts - fromPersistValues' (PersistInt64 x:xs) = do - case fromPersistValues xs of - Left e -> Left e - Right xs' -> Right (Key $ PersistInt64 x, xs') - fromPersistValues' _ = Left "error in fromPersistValues'" - wher conn = if null filts - then "" - else filterClause False conn filts - ord conn = - case map (orderClause False conn) orders of - [] -> "" - ords -> " ORDER BY " ++ intercalate "," ords - lim conn = case (limit, offset) of - (0, 0) -> "" - (0, _) -> ' ' : noLimit conn - (_, _) -> " LIMIT " ++ show limit - off = if offset == 0 - then "" - else " OFFSET " ++ show offset - cols conn = intercalate "," $ (unRawName $ rawTableIdName t) - : (map (\(x, _, _) -> escapeName conn x) $ tableColumns t) - sql conn = pack $ concat - [ "SELECT " - , cols conn - , " FROM " - , escapeName conn $ rawTableName t - , wher conn - , ord conn - , lim conn - , off - ] - - selectKeys filts = - Iteratee . start - where - start x = do - conn <- SqlPersist ask - withStmt' (sql conn) (getFiltsValues conn filts) $ loop x - loop (Continue k) pop = do - res <- pop - case res of - Nothing -> return $ Continue k - Just [PersistInt64 i] -> do - step <- runIteratee $ k $ Chunks [Key $ PersistInt64 i] - loop step pop - Just y -> return $ Error $ toException $ PersistMarshalError - $ "Unexpected in selectKeys: " ++ show y - loop step _ = return step - t = entityDef $ dummyFromFilts filts - wher conn = if null filts - then "" - else filterClause False conn filts - sql conn = pack $ concat - [ "SELECT id FROM " - , escapeName conn $ rawTableName t - , wher conn - ] - delete k = do conn <- SqlPersist ask execute' (sql conn) [unKey k] where t = entityDef $ dummyFromKey k - sql conn = pack $ concat + sql conn = concat [ "DELETE FROM " - , escapeName conn $ rawTableName t + , escapeName conn $ entityDB t , " WHERE id=?" ] - deleteWhere filts = do - conn <- SqlPersist ask - let t = entityDef $ dummyFromFilts filts - let wher = if null filts - then "" - else filterClause False conn filts - sql = pack $ concat - [ "DELETE FROM " - , escapeName conn $ rawTableName t - , wher - ] - execute' sql $ getFiltsValues conn filts +insrepHelper :: (MonadIO m, PersistEntity val) + => Text + -> Key SqlPersist val + -> val + -> SqlPersist m () +insrepHelper command (Key k) val = do + conn <- SqlPersist ask + execute' (sql conn) vals + where + t = entityDef val + sql conn = concat + [ command + , " INTO " + , escapeName conn (entityDB t) + , "(" + , T.intercalate "," + $ map (escapeName conn) + $ entityID t : map fieldDB (entityFields t) + , ") VALUES(" + , T.intercalate "," ("?" : map (const "?") (entityFields t)) + , ")" + ] + vals = k : map toPersistValue (toPersistFields val) +instance C.ResourceIO m => PersistUnique SqlPersist m where deleteBy uniq = do conn <- SqlPersist ask execute' (sql conn) $ persistUniqueToValues uniq where t = entityDef $ dummyFromUnique uniq - go = map (getFieldName t) . persistUniqueToFieldNames + go = map snd . persistUniqueToFieldNames go' conn x = escapeName conn x ++ "=?" - sql conn = pack $ concat + sql conn = concat [ "DELETE FROM " - , escapeName conn $ rawTableName t + , escapeName conn $ entityDB t , " WHERE " - , intercalate " AND " $ map (go' conn) $ go uniq + , T.intercalate " AND " $ map (go' conn) $ go uniq ] - update _ [] = return () - update k upds = do - conn <- SqlPersist ask - let go'' n Assign = n ++ "=?" - go'' n Add = n ++ '=' : n ++ "+?" - go'' n Subtract = n ++ '=' : n ++ "-?" - go'' n Multiply = n ++ '=' : n ++ "*?" - go'' n Divide = n ++ '=' : n ++ "/?" - let go' (x, pu) = go'' (escapeName conn x) pu - let sql = pack $ concat - [ "UPDATE " - , escapeName conn $ rawTableName t - , " SET " - , intercalate "," $ map (go' . go) upds - , " WHERE id=?" - ] - execute' sql $ - map updatePersistValue upds ++ [unKey k] - where - t = entityDef $ dummyFromKey k - go x = ( getFieldName t $ updateFieldName x - , updateUpdate x - ) - - updateWhere _ [] = return () - updateWhere filts upds = do - conn <- SqlPersist ask - let wher = if null filts - then "" - else filterClause False conn filts - let sql = pack $ concat - [ "UPDATE " - , escapeName conn $ rawTableName t - , " SET " - , intercalate "," $ map (go' conn . go) upds - , wher - ] - let dat = map updatePersistValue upds ++ getFiltsValues conn filts - execute' sql dat - where - t = entityDef $ dummyFromFilts filts - go'' n Assign = n ++ "=?" - go'' n Add = n ++ '=' : n ++ "+?" - go'' n Subtract = n ++ '=' : n ++ "-?" - go'' n Multiply = n ++ '=' : n ++ "*?" - go'' n Divide = n ++ '=' : n ++ "/?" - go' conn (x, pu) = go'' (escapeName conn x) pu - go x = ( getFieldName t $ updateFieldName x - , updateUpdate x - ) - getBy uniq = do conn <- SqlPersist ask - let cols = intercalate "," $ (unRawName $ rawTableIdName t) - : (map (\(x, _, _) -> escapeName conn x) $ tableColumns t) - let sql = pack $ concat + let cols = T.intercalate "," $ (escapeName conn $ entityID t) + : map (escapeName conn . fieldDB) (entityFields t) + let sql = concat [ "SELECT " , cols , " FROM " - , escapeName conn $ rawTableName t + , escapeName conn $ entityDB t , " WHERE " , sqlClause conn ] - withStmt' sql (persistUniqueToValues uniq) $ \pop -> do - row <- pop + C.runResourceT $ R.withStmt sql (persistUniqueToValues uniq) C.$$ do + row <- CL.head case row of Nothing -> return Nothing Just (PersistInt64 k:vals) -> case fromPersistValues vals of - Left s -> error s - Right x -> return $ Just (Key $ PersistInt64 k, x) + Left s -> error $ unpack s + Right x -> return $ Just (Entity (Key $ PersistInt64 k) x) Just _ -> error "Database.Persist.GenericSql: Bad list in getBy" where sqlClause conn = - intercalate " AND " $ map (go conn) $ toFieldNames' uniq + T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq go conn x = escapeName conn x ++ "=?" t = entityDef $ dummyFromUnique uniq - toFieldNames' = map (getFieldName t) . persistUniqueToFieldNames - -dummyFromUnique :: Unique v b -> v -dummyFromUnique _ = error "dummyFromUnique" + toFieldNames' = map snd . persistUniqueToFieldNames dummyFromKey :: Key SqlPersist v -> v dummyFromKey _ = error "dummyFromKey" +{- FIXME +<<<<<<< HEAD type Sql = Text @@ -391,7 +267,7 @@ parseMigration' m = do x <- parseMigration m case x of - Left errs -> error $ unlines $ map unpack errs + Left errs -> error $ unpack $ unlines errs Right sql -> return sql printMigration :: (MBCIO m, MonadIO m) => Migration (SqlPersist m) -> SqlPersist m () @@ -425,10 +301,10 @@ mig <- parseMigration' m case unsafeSql mig of [] -> mapM (executeMigrate silent) $ safeSql mig - errs -> error $ concat + errs -> error $ unpack $ concat [ "\n\nDatabase migration: manual intervention required.\n" , "The following actions are considered unsafe:\n\n" - , unlines $ map (\s -> " " ++ unpack s ++ ";") $ errs + , unlines $ map (\s -> " " ++ s ++ ";") $ errs ] runMigrationUnsafe :: (MBCIO m, MonadIO m) @@ -440,17 +316,18 @@ executeMigrate :: MonadIO m => Bool -> Text -> SqlPersist m Text executeMigrate silent s = do - unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ unpack s + unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ s execute' s [] return s migrate :: (MonadIO m, MBCIO m, PersistEntity val) - => val + => [EntityDef] + -> val -> Migration (SqlPersist m) -migrate val = do +migrate allDefs val = do conn <- lift $ lift $ SqlPersist ask let getter = R.getStmt' conn - res <- liftIO $ migrateSql conn getter val + res <- liftIO $ migrateSql conn allDefs getter val either tell (lift . tell) res updatePersistValue :: Update v -> PersistValue @@ -469,10 +346,301 @@ conn <- SqlPersist ask let getter = R.getStmt' conn liftIO $ rollbackC conn getter >> begin conn getter +======= +-} +dummyFromUnique :: Unique v b -> v +dummyFromUnique _ = error "dummyFromUnique" + #if MIN_VERSION_monad_control(0, 3, 0) onException :: MonadBaseControl IO m => m α -> m β -> m α onException m what = control $ \runInIO -> E.onException (runInIO m) (runInIO what) #endif + +infixr 5 ++ +(++) :: Text -> Text -> Text +(++) = mappend + +show :: Show a => a -> Text +show = pack . P.show + + +-- $rawSql +-- +-- Although it covers most of the useful cases, @persistent@'s +-- API may not be enough for some of your tasks. May be you need +-- some complex @JOIN@ query, or a database-specific command +-- needs to be issued. +-- +-- To issue raw SQL queries you could use 'R.withStmt', which +-- allows you to do anything you need. However, its API is +-- /low-level/ and you need to parse each row yourself. However, +-- most of your complex queries will have simple results -- some +-- of your entities and maybe a couple of derived columns. +-- +-- This is where 'rawSql' comes in. Like 'R.withStmt', you may +-- issue /any/ SQL query. However, it does all the hard work for +-- you and automatically parses the rows of the result. It may +-- return: +-- +-- * An 'Entity', which is analogous to the tuples that +-- 'selectList' returns. All of your entity's fields are +-- automatically parsed. +-- +-- * A @'Single' a@, which is a single, raw column of type @a@. +-- You may use a Haskell type (such as in your entity +-- definitions), for example @Single Text@ or @Single Int@, +-- or you may get the raw column value with @Single +-- 'PersistValue'@. +-- +-- * A tuple combining any of these (including other tuples). +-- Using tuples allows you to return many entities in one +-- query. +-- +-- The only difference between issuing SQL queries with 'rawSql' +-- and using other means is that we have an /entity selection/ +-- /placeholder/, the double question mark @??@. It /must/ be +-- used whenever you want to @SELECT@ an 'Entity' from your +-- query. Here's a sample SQL query @sampleStmt@ that may be +-- issued: +-- +-- @ +-- SELECT ??, ?? +-- FROM \"Person\", \"Likes\", \"Object\" +-- WHERE \"Person\".id = \"Likes\".\"personId\" +-- AND \"Object\".id = \"Likes\".\"objectId\" +-- AND \"Person\".name LIKE ? +-- @ +-- +-- To use that query, you could say +-- +-- @ +-- do results <- 'rawSql' sampleStmt [\"%Luke%\"] +-- forM_ results $ +-- \\( Entity personKey person +-- , Entity objectKey object +-- ) -> do ... +-- @ +-- +-- Note that 'rawSql' knows how to replace the double question +-- marks @??@ because of the type of the @results@. + + +-- | A single column (see 'rawSql'). Any 'PersistField' may be +-- used here, including 'PersistValue' (which does not do any +-- processing). +newtype Single a = Single {unSingle :: a} + deriving (Eq, Ord, Show, Read) + + +-- | Execute a raw SQL statement and return its results as a +-- list. +-- +-- If you're using 'Entity'@s@ (which is quite likely), then you +-- /must/ use entity selection placeholders (double question +-- mark, @??@). These @??@ placeholders are then replaced for +-- the names of the columns that we need for your entities. +-- You'll receive an error if you don't use the placeholders. +-- Please see the 'Entity'@s@ documentation for more details. +-- +-- You may put value placeholders (question marks, @?@) in your +-- SQL query. These placeholders are then replaced by the values +-- you pass on the second parameter, already correctly escaped. +-- You may want to use 'toPersistValue' to help you constructing +-- the placeholder values. +-- +-- Since you're giving a raw SQL statement, you don't get any +-- guarantees regarding safety. If 'rawSql' is not able to parse +-- the results of your query back, then an exception is raised. +-- However, most common problems are mitigated by using the +-- entity selection placeholder @??@, and you shouldn't see any +-- error at all if you're not using 'Single'. +rawSql :: (RawSql a, C.ResourceIO m) => + Text -- ^ SQL statement, possibly with placeholders. + -> [PersistValue] -- ^ Values to fill the placeholders. + -> SqlPersist m [a] +rawSql stmt = run + where + getType :: (x -> SqlPersist m [a]) -> a + getType = undefined + + x = getType run + process = rawSqlProcessRow + + withStmt' colSubsts = R.withStmt $ T.concat $ + makeSubsts colSubsts $ + T.splitOn placeholder stmt + where + placeholder = "??" + makeSubsts (s:ss) (t:ts) = t : s : makeSubsts ss ts + makeSubsts [] [] = [] + makeSubsts [] ts = [T.intercalate placeholder ts] + makeSubsts ss [] = error (P.concat err) + where + err = [ "rawsql: there are still ", P.show (length ss) + , "'??' placeholder substitutions to be made " + , "but all '??' placeholders have already been " + , "consumed. Please read 'rawSql's documentation " + , "on how '??' placeholders work." + ] + + run params = do + conn <- SqlPersist ask + let (colCount, colSubsts) = rawSqlCols (escapeName conn) x + C.runResourceT $ withStmt' colSubsts params C.$$ firstRow colCount + + firstRow colCount = do + mrow <- CL.head + case mrow of + Nothing -> return [] + Just row + | colCount == length row -> getter mrow + | otherwise -> fail $ P.concat + [ "rawSql: wrong number of columns, got " + , P.show (length row), " but expected ", P.show colCount + , " (", rawSqlColCountReason x, ")." ] + + getter = go id + where + go acc Nothing = return (acc []) + go acc (Just row) = + case process row of + Left err -> fail (T.unpack err) + Right r -> CL.head >>= go (acc . (r:)) + + +-- | Class for data types that may be retrived from a 'rawSql' +-- query. +class RawSql a where + -- | Number of columns that this data type needs and the list + -- of substitutions for @SELECT@ placeholders @??@. + rawSqlCols :: (DBName -> Text) -> a -> (Int, [Text]) + + -- | A string telling the user why the column count is what + -- it is. + rawSqlColCountReason :: a -> String + + -- | Transform a row of the result into the data type. + rawSqlProcessRow :: [PersistValue] -> Either Text a + +instance PersistField a => RawSql (Single a) where + rawSqlCols _ _ = (1, []) + rawSqlColCountReason _ = "one column for a 'Single' data type" + rawSqlProcessRow [pv] = Single <$> fromPersistValue pv + rawSqlProcessRow _ = Left "RawSql (Single a): wrong number of columns." + +instance PersistEntity a => RawSql (Entity backend a) where + rawSqlCols escape = ((+1).length.entityFields &&& process) . entityDef . entityVal + where + process ed = (:[]) $ + T.intercalate ", " $ + map ((name ed ++) . escape) $ + (entityID ed:) $ + map fieldDB $ + entityFields ed + name ed = escape (entityDB ed) ++ "." + + rawSqlColCountReason a = + case fst (rawSqlCols undefined a) of + 1 -> "one column for an 'Entity' data type without fields" + n -> P.show n P.++ " columns for an 'Entity' data type" + rawSqlProcessRow (idCol:ent) = Entity <$> fromPersistValue idCol + <*> fromPersistValues ent + rawSqlProcessRow _ = Left "RawSql (Entity a): wrong number of columns." + +instance (RawSql a, RawSql b) => RawSql (a, b) where + rawSqlCols e x = rawSqlCols e (fst x) # rawSqlCols e (snd x) + where (cnta, lsta) # (cntb, lstb) = (cnta + cntb, lsta P.++ lstb) + rawSqlColCountReason x = rawSqlColCountReason (fst x) P.++ ", " P.++ + rawSqlColCountReason (snd x) + rawSqlProcessRow = + let x = getType processRow + getType :: (z -> Either y x) -> x + getType = undefined + + colCountFst = fst $ rawSqlCols undefined (fst x) + processRow row = + let (rowFst, rowSnd) = splitAt colCountFst row + in (,) <$> rawSqlProcessRow rowFst + <*> rawSqlProcessRow rowSnd + + in colCountFst `seq` processRow + -- Avoids recalculating 'colCountFst'. + +instance (RawSql a, RawSql b, RawSql c) => RawSql (a, b, c) where + rawSqlCols e = rawSqlCols e . from3 + rawSqlColCountReason = rawSqlColCountReason . from3 + rawSqlProcessRow = fmap to3 . rawSqlProcessRow + +from3 :: (a,b,c) -> ((a,b),c) +from3 (a,b,c) = ((a,b),c) + +to3 :: ((a,b),c) -> (a,b,c) +to3 ((a,b),c) = (a,b,c) + +instance (RawSql a, RawSql b, RawSql c, RawSql d) => RawSql (a, b, c, d) where + rawSqlCols e = rawSqlCols e . from4 + rawSqlColCountReason = rawSqlColCountReason . from4 + rawSqlProcessRow = fmap to4 . rawSqlProcessRow + +from4 :: (a,b,c,d) -> ((a,b),(c,d)) +from4 (a,b,c,d) = ((a,b),(c,d)) + +to4 :: ((a,b),(c,d)) -> (a,b,c,d) +to4 ((a,b),(c,d)) = (a,b,c,d) + +instance (RawSql a, RawSql b, RawSql c, + RawSql d, RawSql e) + => RawSql (a, b, c, d, e) where + rawSqlCols e = rawSqlCols e . from5 + rawSqlColCountReason = rawSqlColCountReason . from5 + rawSqlProcessRow = fmap to5 . rawSqlProcessRow + +from5 :: (a,b,c,d,e) -> ((a,b),(c,d),e) +from5 (a,b,c,d,e) = ((a,b),(c,d),e) + +to5 :: ((a,b),(c,d),e) -> (a,b,c,d,e) +to5 ((a,b),(c,d),e) = (a,b,c,d,e) + +instance (RawSql a, RawSql b, RawSql c, + RawSql d, RawSql e, RawSql f) + => RawSql (a, b, c, d, e, f) where + rawSqlCols e = rawSqlCols e . from6 + rawSqlColCountReason = rawSqlColCountReason . from6 + rawSqlProcessRow = fmap to6 . rawSqlProcessRow + +from6 :: (a,b,c,d,e,f) -> ((a,b),(c,d),(e,f)) +from6 (a,b,c,d,e,f) = ((a,b),(c,d),(e,f)) + +to6 :: ((a,b),(c,d),(e,f)) -> (a,b,c,d,e,f) +to6 ((a,b),(c,d),(e,f)) = (a,b,c,d,e,f) + +instance (RawSql a, RawSql b, RawSql c, + RawSql d, RawSql e, RawSql f, + RawSql g) + => RawSql (a, b, c, d, e, f, g) where + rawSqlCols e = rawSqlCols e . from7 + rawSqlColCountReason = rawSqlColCountReason . from7 + rawSqlProcessRow = fmap to7 . rawSqlProcessRow + +from7 :: (a,b,c,d,e,f,g) -> ((a,b),(c,d),(e,f),g) +from7 (a,b,c,d,e,f,g) = ((a,b),(c,d),(e,f),g) + +to7 :: ((a,b),(c,d),(e,f),g) -> (a,b,c,d,e,f,g) +to7 ((a,b),(c,d),(e,f),g) = (a,b,c,d,e,f,g) + +instance (RawSql a, RawSql b, RawSql c, + RawSql d, RawSql e, RawSql f, + RawSql g, RawSql h) + => RawSql (a, b, c, d, e, f, g, h) where + rawSqlCols e = rawSqlCols e . from8 + rawSqlColCountReason = rawSqlColCountReason . from8 + rawSqlProcessRow = fmap to8 . rawSqlProcessRow + +from8 :: (a,b,c,d,e,f,g,h) -> ((a,b),(c,d),(e,f),(g,h)) +from8 (a,b,c,d,e,f,g,h) = ((a,b),(c,d),(e,f),(g,h)) + +to8 :: ((a,b),(c,d),(e,f),(g,h)) -> (a,b,c,d,e,f,g,h) +to8 ((a,b),(c,d),(e,f),(g,h)) = (a,b,c,d,e,f,g,h) 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 @@ -2,80 +2,75 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} -- | Code that is only needed for writing GenericSql backends. module Database.Persist.GenericSql.Internal ( Connection (..) , Statement (..) , withSqlConn , withSqlPool - , RowPopper + , createSqlPool , mkColumns , Column (..) - , UniqueDef' - , refName - , tableColumns - , rawFieldName - , rawTableName - , rawTableIdName - , RawName (..) - , filterClause - , filterClauseNoWhere - , getFieldName - , dummyFromFilts - , orderClause - , getFiltsValues ) where import qualified Data.Map as Map import Data.IORef import Control.Monad.IO.Class -import Data.Pool -import Database.Persist.Base -import Data.Maybe (fromMaybe) -import Control.Arrow -#if MIN_VERSION_monad_control(0, 3, 0) -import Control.Monad.Trans.Control (MonadBaseControl, control, restoreM) -import qualified Control.Exception as E -#define MBCIO MonadBaseControl IO -#else -import Control.Monad.IO.Control (MonadControlIO) -import Control.Exception.Control (bracket) - -#define MBCIO MonadControlIO -#endif +import Data.Conduit.Pool +import Database.Persist.Store +import Control.Exception.Lifted (bracket) import Database.Persist.Util (nullable) -import Data.List (intercalate) import Data.Text (Text) - -type RowPopper m = m (Maybe [PersistValue]) +import qualified Data.Text as T +import Data.Monoid (Monoid, mappend, mconcat) +import Database.Persist.EntityDef +import qualified Data.Conduit as C data Connection = Connection { prepare :: Text -> IO Statement - , insertSql :: RawName -> [RawName] -> Either Text (Text, Text) + -- ^ table name, column names, either 1 or 2 statements to run + , insertSql :: DBName -> [DBName] -> Either Text (Text, Text) , stmtMap :: IORef (Map.Map Text Statement) , close :: IO () , migrateSql :: forall v. PersistEntity v - => (Text -> IO Statement) -> v + => [EntityDef] + -> (Text -> IO Statement) + -> v -> IO (Either [Text] [(Bool, Text)]) , begin :: (Text -> IO Statement) -> IO () , commitC :: (Text -> IO Statement) -> IO () , rollbackC :: (Text -> IO Statement) -> IO () - , escapeName :: RawName -> String - , noLimit :: String + , escapeName :: DBName -> Text + , noLimit :: Text } data Statement = Statement { finalize :: IO () , reset :: IO () , execute :: [PersistValue] -> IO () - , withStmt :: forall a m. (MBCIO m, MonadIO m) - => [PersistValue] -> (RowPopper m -> m a) -> m a + , withStmt :: forall m. C.ResourceIO m + => [PersistValue] + -> C.Source m [PersistValue] } -withSqlPool :: (MonadIO m, MBCIO m) - => IO Connection -> Int -> (Pool Connection -> m a) -> m a -withSqlPool mkConn = createPool mkConn close' +withSqlPool :: MonadIO m + => IO Connection -- ^ create a new connection + -> Int -- ^ connection count + -> (Pool Connection -> m a) + -> m a +withSqlPool mkConn connCount f = do + pool <- createSqlPool mkConn connCount + f pool -withSqlConn :: (MonadIO m, MBCIO m) => IO Connection -> (Connection -> m a) -> m a +createSqlPool :: MonadIO m + => IO Connection + -> Int + -> m (Pool Connection) +createSqlPool mkConn = liftIO . createPool mkConn close' 1 20 + +withSqlConn :: C.ResourceIO m + => IO Connection -> (Connection -> m a) -> m a withSqlConn open = bracket (liftIO open) (liftIO . close') close' :: Connection -> IO () @@ -83,51 +78,70 @@ readIORef (stmtMap conn) >>= mapM_ finalize . Map.elems close conn +resolveTableName :: [EntityDef] -> HaskellName -> DBName +resolveTableName [] (HaskellName hn) = error $ "Table not found: " `mappend` T.unpack hn +resolveTableName (e:es) hn + | entityHaskell e == hn = entityDB e + | otherwise = resolveTableName es hn + -- | Create the list of columns for the given entity. -mkColumns :: PersistEntity val => val -> ([Column], [UniqueDef']) -mkColumns val = - (cols, uniqs) +mkColumns :: PersistEntity val => [EntityDef] -> val -> ([Column], [UniqueDef]) +mkColumns allDefs val = + (cols, entityUniques t) where - colNameMap = map (columnName &&& rawFieldName) $ entityColumns t - uniqs = map (RawName *** map (unjustLookup colNameMap)) - $ map (uniqueName &&& uniqueColumns) - $ entityUniques t - cols = zipWith go (tableColumns t) $ toPersistFields $ halfDefined `asTypeOf` val - - -- Like fromJust . lookup, but gives a more useful error message - unjustLookup m a = fromMaybe (error $ "Column not found: " ++ a) - $ lookup a m + cols :: [Column] + cols = zipWith go (entityFields t) + $ toPersistFields + $ halfDefined `asTypeOf` val + t :: EntityDef t = entityDef val - tn = rawTableName t - go (name, t', as) p = - Column name (nullable as) (sqlType p) (def as) (ref name t' as) + + tn :: DBName + tn = entityDB t + + go :: FieldDef -> SomePersistField -> Column + go fd p = + Column + (fieldDB fd) + (nullable $ fieldAttrs fd) + (sqlType p) + (def $ fieldAttrs fd) + (ref (fieldDB fd) (fieldType fd) (fieldAttrs fd)) + + def :: [Attr] -> Maybe Text def [] = Nothing - def (('d':'e':'f':'a':'u':'l':'t':'=':d):_) = Just d - def (_:rest) = def rest - ref c t' [] = - let l = length t' - (f, b) = splitAt (l - 2) t' - in if b == "Id" - then Just (RawName f, refName tn c) - else Nothing + def (a:as) + | Just d <- T.stripPrefix "default=" a = Just d + | otherwise = def as + + ref :: DBName + -> FieldType + -> [Attr] + -> Maybe (DBName, DBName) -- table name, constraint name + ref c (FieldType t') [] + | Just f <- T.stripSuffix "Id" t' = + Just (resolveTableName allDefs $ HaskellName f, refName tn c) + | otherwise = Nothing ref _ _ ("noreference":_) = Nothing - ref c _ (('r':'e':'f':'e':'r':'e':'n':'c':'e':'=':x):_) = - Just (RawName x, refName tn c) - ref c x (_:y) = ref c x y + ref c _ (a:_) + | Just x <- T.stripPrefix "reference=" a = + Just (DBName x, refName tn c) + ref c x (_:as) = ref c x as -refName :: RawName -> RawName -> RawName -refName (RawName table) (RawName column) = - RawName $ table ++ '_' : column ++ "_fkey" +refName :: DBName -> DBName -> DBName +refName (DBName table) (DBName column) = + DBName $ mconcat [table, "_", column, "_fkey"] data Column = Column - { cName :: RawName - , cNull :: Bool - , cType :: SqlType - , cDefault :: Maybe String - , cReference :: (Maybe (RawName, RawName)) -- table name, constraint name + { cName :: DBName + , cNull :: Bool + , cType :: SqlType + , cDefault :: Maybe Text + , cReference :: (Maybe (DBName, DBName)) -- table name, constraint name } +{- FIXME getSqlValue :: [String] -> Maybe String getSqlValue (('s':'q':'l':'=':x):_) = Just x getSqlValue (_:x) = getSqlValue x @@ -137,148 +151,14 @@ getIdNameValue (('i':'d':'=':x):_) = Just x getIdNameValue (_:x) = getIdNameValue x getIdNameValue [] = Nothing +-} +{- FIXME tableColumns :: EntityDef -> [(RawName, String, [String])] tableColumns = map (\a@(ColumnDef _ y z) -> (rawFieldName a, y, z)) . entityColumns - -type UniqueDef' = (RawName, [RawName]) - -rawFieldName :: ColumnDef -> RawName -rawFieldName (ColumnDef n _ as) = RawName $ - case getSqlValue as of - Just x -> x - Nothing -> n - -rawTableName :: EntityDef -> RawName -rawTableName t = RawName $ - case getSqlValue $ entityAttribs t of - Nothing -> entityName t - Just x -> x - -rawTableIdName :: EntityDef -> RawName -rawTableIdName t = RawName $ - case getIdNameValue $ entityAttribs t of - Nothing -> "id" - Just x -> x - -newtype RawName = RawName { unRawName :: String } -- FIXME Text - deriving (Eq, Ord) - -getFiltsValues :: forall val. PersistEntity val => Connection -> [Filter val] -> [PersistValue] -getFiltsValues conn = snd . filterClauseHelper False False conn - -filterClause :: PersistEntity val - => Bool -- ^ include table name? - -> Connection -> [Filter val] -> String -filterClause b c = fst . filterClauseHelper b True c - -filterClauseNoWhere :: PersistEntity val - => Bool -- ^ include table name? - -> Connection -> [Filter val] -> String -filterClauseNoWhere b c = fst . filterClauseHelper b False c - -filterClauseHelper :: PersistEntity val - => Bool -- ^ include table name? - -> Bool -- ^ include WHERE? - -> Connection -> [Filter val] -> (String, [PersistValue]) -filterClauseHelper includeTable includeWhere conn filters = - (if not (null sql) && includeWhere - then " WHERE " ++ sql - else sql, vals) - where - (sql, vals) = combineAND filters - combineAND = combine " AND " - - combine s fs = - (intercalate s $ map wrapP a, concat b) - where - (a, b) = unzip $ map go fs - wrapP x = concat ["(", x, ")"] - - go (FilterAnd []) = ("1=0", []) - go (FilterAnd fs) = combineAND fs - go (FilterOr []) = ("1=1", []) - go (FilterOr fs) = combine " OR " fs - go (Filter field value pfilter) = - case (isNull, pfilter, varCount) of - (True, Eq, _) -> (name ++ " IS NULL", []) - (True, Ne, _) -> (name ++ " IS NOT NULL", []) - (False, Ne, _) -> (concat - [ "(" - , name - , " IS NULL OR " - , name - , " <> " - , qmarks - , ")" - ], notNullVals) - -- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since - -- not all databases support those words directly. - (_, In, 0) -> ("1=2", []) - (False, In, _) -> (name ++ " IN " ++ qmarks, allVals) - (True, In, _) -> (concat - [ "(" - , name - , " IS NULL OR " - , name - , " IN " - , qmarks - , ")" - ], notNullVals) - (_, NotIn, 0) -> ("1=1", []) - (False, NotIn, _) -> (concat - [ "(" - , name - , " IS NULL OR " - , name - , " NOT IN " - , qmarks - , ")" - ], notNullVals) - (True, NotIn, _) -> (concat - [ "(" - , name - , " IS NOT NULL AND " - , name - , " NOT IN " - , qmarks - , ")" - ], notNullVals) - _ -> (name ++ showSqlFilter pfilter ++ "?", allVals) - where - filterValueToPersistValues :: forall a. PersistField a => Either a [a] -> [PersistValue] - filterValueToPersistValues v = map toPersistValue $ either return id v - - isNull = any (== PersistNull) allVals - notNullVals = filter (/= PersistNull) allVals - allVals = filterValueToPersistValues value - t = entityDef $ dummyFromFilts [Filter field value pfilter] - name = - (if includeTable - then (++) (escapeName conn (rawTableName t) ++ ".") - else id) - $ escapeName conn $ getFieldName t $ columnName $ persistColumnDef field - qmarks = case value of - Left _ -> "?" - Right x -> - let x' = filter (/= PersistNull) $ map toPersistValue x - in '(' : intercalate "," (map (const "?") x') ++ ")" - varCount = case value of - Left _ -> 1 - Right x -> length x - showSqlFilter Eq = "=" - showSqlFilter Ne = "<>" - showSqlFilter Gt = ">" - showSqlFilter Lt = "<" - showSqlFilter Ge = ">=" - showSqlFilter Le = "<=" - showSqlFilter In = " IN " - showSqlFilter NotIn = " NOT IN " - showSqlFilter (BackendSpecificFilter s) = s - -dummyFromFilts :: [Filter v] -> v -dummyFromFilts _ = error "dummyFromFilts" +-} +{- FIXME getFieldName :: EntityDef -> String -> RawName getFieldName t s = rawFieldName $ tableColumn t s @@ -291,33 +171,4 @@ go (ColumnDef x y z:rest) | x == s = ColumnDef x y z | otherwise = go rest - -dummyFromOrder :: SelectOpt a -> a -dummyFromOrder _ = undefined - -orderClause :: PersistEntity val => Bool -> Connection -> SelectOpt val -> String -orderClause includeTable conn o = - case o of - Asc x -> name x - Desc x -> name x ++ " DESC" - _ -> error $ "expected Asc or Desc, not limit or offset" - where - cd x = persistColumnDef x - t = entityDef $ dummyFromOrder o - name x = - (if includeTable - then (++) (escapeName conn (rawTableName t) ++ ".") - else id) - $ escapeName conn $ getFieldName t $ columnName $ cd x - -#if MIN_VERSION_monad_control(0, 3, 0) -bracket :: MonadBaseControl IO m - => m a -- ^ computation to run first (\"acquire resource\") - -> (a -> m b) -- ^ computation to run last (\"release resource\") - -> (a -> m c) -- ^ computation to run in-between - -> m c -bracket before after thing = control $ \runInIO -> - E.bracket (runInIO before) - (\st -> runInIO $ restoreM st >>= after) - (\st -> runInIO $ restoreM st >>= thing) -#endif +-} diff --git a/Database/Persist/GenericSql/Migration.hs b/Database/Persist/GenericSql/Migration.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/GenericSql/Migration.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +module Database.Persist.GenericSql.Migration + ( Migration + , parseMigration + , parseMigration' + , printMigration + , getMigration + , runMigration + , runMigrationSilent + , runMigrationUnsafe + , migrate + , commit + , rollback + ) where + + +import Database.Persist.GenericSql.Internal +import Database.Persist.EntityDef +import qualified Database.Persist.GenericSql.Raw as R +import Database.Persist.Store +import Database.Persist.GenericSql.Raw (SqlPersist (..)) +#if MIN_VERSION_monad_control(0, 3, 0) +import Control.Monad.Trans.Control (MonadBaseControl) +#define MBCIO MonadBaseControl IO +#else +import Control.Monad.IO.Control (MonadControlIO) +#define MBCIO MonadControlIO +#endif +import Control.Monad.Trans.Class (MonadTrans (..)) +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Writer +import Control.Monad (liftM, unless) +import Data.Text (Text, unpack, snoc) +import qualified Data.Text.IO +import System.IO + +execute' :: MonadIO m => Text -> [PersistValue] -> SqlPersist m () +execute' = R.execute + +type Sql = Text + +-- Bool indicates if the Sql is safe +type CautiousMigration = [(Bool, Sql)] +allSql :: CautiousMigration -> [Sql] +allSql = map snd +unsafeSql :: CautiousMigration -> [Sql] +unsafeSql = allSql . filter fst +safeSql :: CautiousMigration -> [Sql] +safeSql = allSql . filter (not . fst) + +type Migration m = WriterT [Text] (WriterT CautiousMigration m) () + +parseMigration :: Monad m => Migration m -> m (Either [Text] CautiousMigration) +parseMigration = + liftM go . runWriterT . execWriterT + where + go ([], sql) = Right sql + go (errs, _) = Left errs + +-- like parseMigration, but call error or return the CautiousMigration +parseMigration' :: Monad m => Migration m -> m (CautiousMigration) +parseMigration' m = do + x <- parseMigration m + case x of + Left errs -> error $ unlines $ map unpack errs + Right sql -> return sql + +printMigration :: (MBCIO m, MonadIO m) => Migration (SqlPersist m) -> SqlPersist m () +printMigration m = do + mig <- parseMigration' m + mapM_ (liftIO . Data.Text.IO.putStrLn . flip snoc ';') (allSql mig) + +getMigration :: (MBCIO m, MonadIO m) => Migration (SqlPersist m) -> SqlPersist m [Sql] +getMigration m = do + mig <- parseMigration' m + return $ allSql mig + +runMigration :: (MonadIO m, MBCIO m) + => Migration (SqlPersist m) + -> SqlPersist m () +runMigration m = runMigration' m False >> return () + +-- | Same as 'runMigration', but returns a list of the SQL commands executed +-- instead of printing them to stderr. +runMigrationSilent :: (MBCIO m, MonadIO m) + => Migration (SqlPersist m) + -> SqlPersist m [Text] +runMigrationSilent m = runMigration' m True + +runMigration' + :: (MBCIO m, MonadIO m) + => Migration (SqlPersist m) + -> Bool -- ^ is silent? + -> SqlPersist m [Text] +runMigration' m silent = do + mig <- parseMigration' m + case unsafeSql mig of + [] -> mapM (executeMigrate silent) $ safeSql mig + errs -> error $ concat + [ "\n\nDatabase migration: manual intervention required.\n" + , "The following actions are considered unsafe:\n\n" + , unlines $ map (\s -> " " ++ unpack s ++ ";") $ errs + ] + +runMigrationUnsafe :: (MBCIO m, MonadIO m) + => Migration (SqlPersist m) + -> SqlPersist m () +runMigrationUnsafe m = do + mig <- parseMigration' m + mapM_ (executeMigrate False) $ allSql mig + +executeMigrate :: MonadIO m => Bool -> Text -> SqlPersist m Text +executeMigrate silent s = do + unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ unpack s + execute' s [] + return s + +migrate :: (MonadIO m, MBCIO m, PersistEntity val) + => [EntityDef] + -> val + -> Migration (SqlPersist m) +migrate allDefs val = do + conn <- lift $ lift $ SqlPersist ask + let getter = R.getStmt' conn + res <- liftIO $ migrateSql conn allDefs getter val + either tell (lift . tell) res + +-- | Perform a database commit. +commit :: MonadIO m => SqlPersist m () +commit = do + conn <- SqlPersist ask + let getter = R.getStmt' conn + liftIO $ commitC conn getter >> begin conn getter + +-- | Perform a database rollback. +rollback :: MonadIO m => SqlPersist m () +rollback = do + conn <- SqlPersist ask + let getter = R.getStmt' conn + liftIO $ rollbackC conn getter >> begin conn getter 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 @@ -16,7 +16,7 @@ import qualified Database.Persist.GenericSql.Internal as I import Database.Persist.GenericSql.Internal hiding (execute, withStmt) -import Database.Persist.Base (PersistValue) +import Database.Persist.Store (PersistValue) import Data.IORef import Control.Monad.IO.Class import Control.Monad.Trans.Reader @@ -34,6 +34,8 @@ #endif import Data.Text (Text) import Control.Monad (MonadPlus) +import Control.Monad.Trans.Resource (ResourceThrow (..), ResourceIO) +import qualified Data.Conduit as C newtype SqlPersist m a = SqlPersist { unSqlPersist :: ReaderT Connection m a } deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadPlus @@ -42,6 +44,9 @@ #endif ) +instance ResourceThrow m => ResourceThrow (SqlPersist m) where + resourceThrow = lift . resourceThrow + instance MonadBase b m => MonadBase b (SqlPersist m) where liftBase = lift . liftBase @@ -56,13 +61,24 @@ restoreT = SqlPersist . ReaderT . const . liftM unStReader #endif -withStmt :: (MonadIO m, MBCIO m) => Text -> [PersistValue] - -> (RowPopper (SqlPersist m) -> SqlPersist m a) -> SqlPersist m a -withStmt sql vals pop = do - stmt <- getStmt sql - ret <- I.withStmt stmt vals pop - liftIO $ reset stmt - return ret +withStmt :: ResourceIO m + => Text + -> [PersistValue] + -> C.Source (SqlPersist m) [PersistValue] +withStmt sql vals = C.Source $ do + stmt <- lift $ getStmt sql + src <- C.prepareSource $ I.withStmt stmt vals + return C.PreparedSource + { C.sourcePull = do + res <- C.sourcePull src + case res of + C.Closed -> liftIO $ I.reset stmt + _ -> return () + return res + , C.sourceClose = do + liftIO $ I.reset stmt + C.sourceClose src + } execute :: MonadIO m => Text -> [PersistValue] -> SqlPersist m () execute sql vals = do diff --git a/Database/Persist/Join.hs b/Database/Persist/Join.hs deleted file mode 100644 --- a/Database/Persist/Join.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -module Database.Persist.Join - ( -- * Typeclass - RunJoin (..) - -- * One-to-many relation - , SelectOneMany (..) - , selectOneMany - ) where - -import Database.Persist.Base -import Data.Maybe (mapMaybe) -import qualified Data.Map as Map -import Data.List (foldl') - -class PersistBackend b m => RunJoin a b m where - type Result a - runJoin :: a -> b m (Result a) - -data SelectOneMany backend one many = SelectOneMany - { somFilterOne :: [Filter one] - , somOrderOne :: [SelectOpt one] - , somFilterMany :: [Filter many] - , somOrderMany :: [SelectOpt many] - , somFilterKeys :: [Key backend one] -> Filter many - , somGetKey :: many -> Key backend one - , somIncludeNoMatch :: Bool - } - -selectOneMany :: ([Key backend one] -> Filter many) -> (many -> Key backend one) -> SelectOneMany backend one many -selectOneMany filts get' = SelectOneMany [] [] [] [] filts get' False -instance (PersistEntity one, PersistEntity many, Ord (Key backend one), PersistBackend backend monad) - => RunJoin (SelectOneMany backend one many) backend monad where - type Result (SelectOneMany backend one many) = - [((Key backend one, one), [(Key backend many, many)])] - runJoin (SelectOneMany oneF oneO manyF manyO eq getKey isOuter) = do - x <- selectList oneF oneO - -- FIXME use select instead of selectList - y <- selectList (eq (map fst x) : manyF) manyO - let y' = foldl' go Map.empty y - return $ mapMaybe (go' y') x - where - go m many@(_, many') = - Map.insert (getKey many') - (case Map.lookup (getKey many') m of - Nothing -> (:) many - Just v -> v . (:) many - ) m - go' y' one@(k, _) = - case Map.lookup k y' of - Nothing -> - if isOuter - then Just (one, []) - else Nothing - Just many -> Just (one, many []) diff --git a/Database/Persist/Join/Sql.hs b/Database/Persist/Join/Sql.hs deleted file mode 100644 --- a/Database/Persist/Join/Sql.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE CPP #-} -module Database.Persist.Join.Sql - ( RunJoin (..) - ) where - -import Database.Persist.Join hiding (RunJoin (..)) -import qualified Database.Persist.Join as J -import Database.Persist.Base -import Control.Monad (liftM) -import Data.Maybe (mapMaybe) -import Data.List (intercalate, groupBy) -import Database.Persist.GenericSql -import Database.Persist.GenericSql.Internal hiding (withStmt) -import Database.Persist.GenericSql.Raw (withStmt) -import Control.Monad.Trans.Reader (ask) -#if MIN_VERSION_monad_control(0, 3, 0) -import Control.Monad.Trans.Control (MonadBaseControl) -#define MBCIO MonadBaseControl IO -#else -import Control.Monad.IO.Control (MonadControlIO) -#define MBCIO MonadControlIO -#endif -import Data.Function (on) -import Control.Arrow ((&&&)) -import Data.Text (pack) -import Control.Monad.IO.Class (MonadIO) - -fromPersistValuesId :: PersistEntity v => [PersistValue] -> Either String (Key SqlPersist v, v) -fromPersistValuesId [] = Left "fromPersistValuesId: No values provided" -fromPersistValuesId (PersistInt64 i:rest) = - case fromPersistValues rest of - Left e -> Left e - Right x -> Right (Key $ PersistInt64 i, x) -fromPersistValuesId _ = Left "fromPersistValuesId: invalid ID" - -class RunJoin a where - runJoin :: (MonadIO m, MBCIO m) => a -> SqlPersist m (J.Result a) - -instance (PersistEntity one, PersistEntity many, Eq (Key SqlPersist one)) - => RunJoin (SelectOneMany SqlPersist one many) where - runJoin (SelectOneMany oneF oneO manyF manyO eq _getKey isOuter) = do - conn <- SqlPersist ask - liftM go $ withStmt (sql conn) (getFiltsValues conn oneF ++ getFiltsValues conn manyF) $ loop id - where - go :: Eq a => [((a, b), Maybe (c, d))] -> [((a, b), [(c, d)])] - go = map (fst . head &&& mapMaybe snd) . groupBy ((==) `on` (fst . fst)) - loop front popper = do - x <- popper - case x of - Nothing -> return $ front [] - Just vals -> do - let (y, z) = splitAt oneCount vals - case (fromPersistValuesId y, fromPersistValuesId z) of - (Right y', Right z') -> loop (front . (:) (y', Just z')) popper - (Left e, _) -> error $ "selectOneMany: " ++ e - (Right y', Left e) -> - case z of - PersistNull:_ -> loop (front . (:) (y', Nothing)) popper - _ -> error $ "selectOneMany: " ++ e - oneCount = 1 + length (tableColumns $ entityDef one) - one = dummyFromFilts oneF - many = dummyFromFilts manyF - sql conn = pack $ concat - [ "SELECT " - , intercalate "," $ colsPlusId conn one ++ colsPlusId conn many - , " FROM " - , escapeName conn $ rawTableName $ entityDef one - , if isOuter then " LEFT JOIN " else " INNER JOIN " - , escapeName conn $ rawTableName $ entityDef many - , " ON " - , escapeName conn $ rawTableName $ entityDef one - , ".id = " - , escapeName conn $ rawTableName $ entityDef many - , "." - , escapeName conn $ RawName $ filterName $ eq undefined - , filts - , if null ords - then "" - else " ORDER BY " ++ intercalate ", " ords - ] - where - filts1 = filterClauseNoWhere True conn oneF - filts2 = filterClauseNoWhere True conn manyF - - orders :: PersistEntity val => [SelectOpt val] -> [SelectOpt val] - orders = third3 . limitOffsetOrder - - filts - | null filts1 && null filts2 = "" - | null filts1 = " WHERE " ++ filts2 - | null filts2 = " WHERE " ++ filts1 - | otherwise = " WHERE " ++ filts1 ++ " AND " ++ filts2 - ords = map (orderClause True conn) (orders oneO) ++ map (orderClause True conn) (orders manyO) - -addTable :: PersistEntity val => - Connection -> val -> [Char] -> [Char] -addTable conn e s = concat [escapeName conn $ rawTableName $ entityDef e, ".", s] - -colsPlusId :: PersistEntity e => Connection -> e -> [String] -colsPlusId conn e = - map (addTable conn e) $ - id_ : (map (\(x, _, _) -> escapeName conn x) cols) - where - id_ = unRawName $ rawTableIdName $ entityDef e - cols = tableColumns $ entityDef e - -filterName :: PersistEntity v => Filter v -> String -filterName (Filter f _ _) = columnName $ persistColumnDef f -filterName (FilterAnd _) = error "expected a raw filter, not an And" -filterName (FilterOr _) = error "expected a raw filter, not an Or" diff --git a/Database/Persist/Quasi.hs b/Database/Persist/Quasi.hs --- a/Database/Persist/Quasi.hs +++ b/Database/Persist/Quasi.hs @@ -1,39 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} module Database.Persist.Quasi ( parse + , PersistSettings (..) + , upperCaseSettings + , lowerCaseSettings ) where -import Database.Persist.Base +import Prelude hiding (lines) +import Database.Persist.EntityDef import Data.Char import Data.Maybe (mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Control.Arrow ((&&&)) +import qualified Data.Map as Map +data PersistSettings = PersistSettings + { psToDBName :: Text -> Text + } + +upperCaseSettings :: PersistSettings +upperCaseSettings = PersistSettings + { psToDBName = id + } + +lowerCaseSettings :: PersistSettings +lowerCaseSettings = PersistSettings + { psToDBName = + let go c + | isUpper c = T.pack ['_', toLower c] + | otherwise = T.singleton c + in T.dropWhile (== '_') . T.concatMap go + } + -- | Parses a quasi-quoted syntax into a list of entity definitions. -parse :: String -> [EntityDef] -parse = parse' +parse :: PersistSettings -> Text -> [EntityDef] +parse ps = parse' ps . removeSpaces . filter (not . empty) . map tokenize - . lines + . T.lines -- | A token used by the parser. data Token = Spaces !Int -- ^ @Spaces n@ are @n@ consecutive spaces. - | Token String -- ^ @Token tok@ is token @tok@ already unquoted. + | Token Text -- ^ @Token tok@ is token @tok@ already unquoted. -- | Tokenize a string. -tokenize :: String -> [Token] -tokenize [] = [] -tokenize ('-':'-':_) = [] -- Comment until the end of the line. -tokenize ('"':xs) = go xs "" - where - go ('\"':rest) acc = Token (reverse acc) : tokenize rest - go ('\\':y:ys) acc = go ys (y:acc) - go (y:ys) acc = go ys (y:acc) - go [] acc = error $ "Unterminated quoted (\") string starting with " ++ - show (reverse acc) ++ "." -tokenize (x:xs) - | isSpace x = let (spaces, rest) = span isSpace xs - in Spaces (1 + length spaces) : tokenize rest -tokenize xs = let (token, rest) = break isSpace xs - in Token token : tokenize rest +tokenize :: Text -> [Token] +tokenize t + | T.null t = [] + | "--" `T.isPrefixOf` t = [] -- Comment until the end of the line. + | T.head t == '"' = quotes (T.tail t) id + | isSpace (T.head t) = + let (spaces, rest) = T.span isSpace t + in Spaces (T.length spaces) : tokenize rest + | otherwise = + let (token, rest) = T.break isSpace t + in Token token : tokenize rest + where + quotes t' front + | T.null t' = error $ T.unpack $ T.concat $ + "Unterminated quoted string starting with " : front [] + | T.head t' == '"' = Token (T.concat $ front []) : tokenize (T.tail t') + | T.head t' == '\\' && T.length t' > 1 = + quotes (T.drop 2 t') (front . (T.take 2 t':)) + | otherwise = + let (x, y) = T.break (`elem` "\\\"") t' + in quotes y (front . (x:)) -- | A string of tokens is empty when it has only spaces. There -- can't be two consecutive 'Spaces', so this takes /O(1)/ time. @@ -44,72 +77,102 @@ -- | A line. We don't care about spaces in the middle of the -- line. Also, we don't care about the ammount of indentation. -data Line = Line { lineType :: LineType - , tokens :: [String] } - --- | A line may be part of a header or body. -data LineType = Header | Body - deriving (Eq) +data Line = Line { lineIndent :: Int + , tokens :: [Text] + } -- | Remove leading spaces and remove spaces in the middle of the -- tokens. removeSpaces :: [[Token]] -> [Line] -removeSpaces xs = map (makeLine . subtractSpace) xs - where - -- | Ammount of leading spaces. - s = minimum $ map headSpace xs - - -- | Ammount of leading space in a single token string. - headSpace (Spaces n : _) = n - headSpace _ = 0 - - -- | Subtract the leading space. - subtractSpace ys | s == 0 = ys - subtractSpace (Spaces n : rest) - | n == s = rest - | otherwise = Spaces (n - s) : rest - subtractSpace _ = error "Database.Persist.Quasi: never here" +removeSpaces = + map toLine + where + toLine (Spaces i:rest) = toLine' i rest + toLine xs = toLine' 0 xs - -- | Get all tokens while ignoring spaces. - getTokens (Token tok : rest) = tok : getTokens rest - getTokens (Spaces _ : rest) = getTokens rest - getTokens [] = [] + toLine' i = Line i . mapMaybe toToken - -- | Make a 'Line' from a @[Token]@. - makeLine (Spaces _ : rest) = Line Body (getTokens rest) - makeLine rest = Line Header (getTokens rest) + toToken (Token t) = Just t + toToken Spaces{} = Nothing -- | Divide lines into blocks and make entity definitions. -parse' :: [Line] -> [EntityDef] -parse' (Line Header (name:entattribs) : rest) = - let (x, y) = span ((== Body) . lineType) rest - in mkEntityDef name entattribs (map tokens x) : parse' y -parse' ((Line Header []) : _) = error "Indented line must contain at least name." -parse' ((Line Body _) : _) = error "Blocks must begin with non-indented lines." -parse' [] = [] +parse' :: PersistSettings -> [Line] -> [EntityDef] +parse' ps (Line indent (name:entattribs) : rest) = + let (x, y) = span ((> indent) . lineIndent) rest + in mkEntityDef ps name entattribs x : parse' ps y +parse' ps (Line _ []:rest) = parse' ps rest +parse' _ [] = [] -- | Construct an entity definition. -mkEntityDef :: String -> [String] -> [[String]] -> EntityDef -mkEntityDef name entattribs attribs = - EntityDef name entattribs cols uniqs derives +mkEntityDef :: PersistSettings + -> Text -- ^ name + -> [Attr] -- ^ entity attributes + -> [Line] -- ^ indented lines + -> EntityDef +mkEntityDef ps name entattribs lines = + EntityDef + (HaskellName name) + (DBName $ psToDBName ps name) + (DBName $ idName entattribs) + entattribs cols uniqs derives + extras where - cols = mapMaybe takeCols attribs - uniqs = mapMaybe takeUniqs attribs + (attribs, extras) = splitExtras lines + idName [] = "id" + idName (t:ts) = + case T.stripPrefix "id=" t of + Nothing -> idName ts + Just s -> s + cols = mapMaybe (takeCols ps) attribs + uniqs = mapMaybe (takeUniqs ps cols) attribs derives = case mapMaybe takeDerives attribs of [] -> ["Show", "Read", "Eq"] x -> concat x -takeCols :: [String] -> Maybe ColumnDef -takeCols ("deriving":_) = Nothing -takeCols (n@(f:_):ty:rest) - | isLower f = Just $ ColumnDef n ty rest -takeCols _ = Nothing +splitExtras :: [Line] -> ([[Text]], Map.Map Text [[Text]]) +splitExtras [] = ([], Map.empty) +splitExtras (Line indent [name]:rest) + | not (T.null name) && isUpper (T.head name) = + let (children, rest') = span ((> indent) . lineIndent) rest + (x, y) = splitExtras rest' + in (x, Map.insert name (map tokens children) y) +splitExtras (Line _ ts:rest) = + let (x, y) = splitExtras rest + in (ts:x, y) -takeUniqs :: [String] -> Maybe UniqueDef -takeUniqs (n@(f:_):rest) - | isUpper f = Just $ UniqueDef n rest -takeUniqs _ = Nothing +takeCols :: PersistSettings -> [Text] -> Maybe FieldDef +takeCols _ ("deriving":_) = Nothing +takeCols ps (n:ty:rest) + | not (T.null n) && isLower (T.head n) = Just $ FieldDef + (HaskellName n) + (DBName $ db rest) + (FieldType ty) + rest + where + db [] = psToDBName ps n + db (a:as) = + case T.stripPrefix "sql=" a of + Nothing -> db as + Just s -> s +takeCols _ _ = Nothing -takeDerives :: [String] -> Maybe [String] +takeUniqs :: PersistSettings + -> [FieldDef] + -> [Text] + -> Maybe UniqueDef +takeUniqs ps defs (n:rest) + | not (T.null n) && isUpper (T.head n) + = Just $ UniqueDef + (HaskellName n) + (DBName $ psToDBName ps n) + (map (HaskellName &&& getDBName defs) rest) + where + getDBName [] t = error $ "Unknown column in unique constraint: " ++ show t + getDBName (d:ds) t + | fieldHaskell d == HaskellName t = fieldDB d + | otherwise = getDBName ds t +takeUniqs _ _ _ = Nothing + +takeDerives :: [Text] -> Maybe [Text] takeDerives ("deriving":rest) = Just rest takeDerives _ = Nothing diff --git a/Database/Persist/Query.hs b/Database/Persist/Query.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Query.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Database.Persist.Query + ( PersistQuery (..) + , selectList + , deleteCascadeWhere + + , SelectOpt (..) + , Filter (..) + + -- * query combinators + , (=.), (+=.), (-=.), (*=.), (/=.) + , (==.), (!=.), (<.), (>.), (<=.), (>=.) + , (<-.), (/<-.) + , (||.) + ) where + +import Database.Persist.Store +import Database.Persist.Query.Internal + +-- import and export the GenericSql instance (orphaned for convenience of modularity) +import Database.Persist.Query.GenericSql () + +infixr 3 =., +=., -=., *=., /=. +(=.), (+=.), (-=.), (*=.), (/=.) :: forall v typ. PersistField typ => EntityField v typ -> typ -> Update v +-- | assign a field a value +f =. a = Update f a Assign +-- | assign a field by addition (+=) +f +=. a = Update f a Add +-- | assign a field by subtraction (-=) +f -=. a = Update f a Subtract +-- | assign a field by multiplication (*=) +f *=. a = Update f a Multiply +-- | assign a field by division (/=) +f /=. a = Update f a Divide + +infix 4 ==., <., <=., >., >=., !=. +(==.), (!=.), (<.), (<=.), (>.), (>=.) :: + forall v typ. PersistField typ => EntityField v typ -> typ -> Filter v +f ==. a = Filter f (Left a) Eq +f !=. a = Filter f (Left a) Ne +f <. a = Filter f (Left a) Lt +f <=. a = Filter f (Left a) Le +f >. a = Filter f (Left a) Gt +f >=. a = Filter f (Left a) Ge + +infix 4 <-., /<-. +(<-.), (/<-.) :: forall v typ. PersistField typ => EntityField v typ -> [typ] -> Filter v +-- | In +f <-. a = Filter f (Right a) In +-- | NotIn +f /<-. a = Filter f (Right a) NotIn + +infixl 3 ||. +(||.) :: forall v. [Filter v] -> [Filter v] -> [Filter v] +-- | the OR of two lists of filters +a ||. b = [FilterOr [FilterAnd a, FilterAnd b]] diff --git a/Database/Persist/Query/GenericSql.hs b/Database/Persist/Query/GenericSql.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Query/GenericSql.hs @@ -0,0 +1,354 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} -- FIXME + +module Database.Persist.Query.GenericSql + ( PersistQuery (..) + , SqlPersist (..) + , filterClauseNoWhere + , getFiltsValues + , selectSourceConn + , dummyFromFilts + , orderClause + ) + where + +import qualified Prelude +import Prelude hiding ((++), unlines, concat, show) +import Data.Text (Text, pack, concat) +import Database.Persist.Store +import Database.Persist.Query.Internal +import Database.Persist.GenericSql +import Database.Persist.GenericSql.Internal +import qualified Database.Persist.GenericSql.Raw as R + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader + +import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL + +import Control.Exception (throwIO) +import qualified Data.Text as T +import Database.Persist.EntityDef +import Data.Monoid (Monoid, mappend, mconcat) + +-- orphaned instance for convenience of modularity +instance C.ResourceIO m => PersistQuery SqlPersist m where + update _ [] = return () + update k upds = do + conn <- SqlPersist ask + let go'' n Assign = n ++ "=?" + go'' n Add = concat [n, "=", n, "+?"] + go'' n Subtract = concat [n, "=", n, "-?"] + go'' n Multiply = concat [n, "=", n, "*?"] + go'' n Divide = concat [n, "=", n, "/?"] + let go' (x, pu) = go'' (escapeName conn x) pu + let sql = concat + [ "UPDATE " + , escapeName conn $ entityDB t + , " SET " + , T.intercalate "," $ map (go' . go) upds + , " WHERE id=?" + ] + execute' sql $ + map updatePersistValue upds `mappend` [unKey k] + where + t = entityDef $ dummyFromKey k + go x = (fieldDB $ updateFieldDef x, updateUpdate x) + + count filts = do + conn <- SqlPersist ask + let wher = if null filts + then "" + else filterClause False conn filts + let sql = concat + [ "SELECT COUNT(*) FROM " + , escapeName conn $ entityDB t + , wher + ] + C.runResourceT $ R.withStmt sql (getFiltsValues conn filts) C.$$ do + Just [PersistInt64 i] <- CL.head + return $ fromIntegral i + where + t = entityDef $ dummyFromFilts filts + + selectSource filts opts = C.Source $ do + conn <- lift $ SqlPersist ask + C.prepareSource $ R.withStmt (sql conn) (getFiltsValues conn filts) C.$= CL.mapM parse + where + (limit, offset, orders) = limitOffsetOrder opts + + parse vals = + case fromPersistValues' vals of + Left s -> liftIO $ throwIO $ PersistMarshalError s + Right row -> return row + + t = entityDef $ dummyFromFilts filts + fromPersistValues' (PersistInt64 x:xs) = do + case fromPersistValues xs of + Left e -> Left e + Right xs' -> Right (Entity (Key $ PersistInt64 x) xs') + fromPersistValues' _ = Left "error in fromPersistValues'" + wher conn = if null filts + then "" + else filterClause False conn filts + ord conn = + case map (orderClause False conn) orders of + [] -> "" + ords -> " ORDER BY " ++ T.intercalate "," ords + lim conn = case (limit, offset) of + (0, 0) -> "" + (0, _) -> T.cons ' ' $ noLimit conn + (_, _) -> " LIMIT " ++ show limit + off = if offset == 0 + then "" + else " OFFSET " ++ show offset + cols conn = T.intercalate "," + $ (escapeName conn $ entityID t) + : map (escapeName conn . fieldDB) (entityFields t) + sql conn = concat + [ "SELECT " + , cols conn + , " FROM " + , escapeName conn $ entityDB t + , wher conn + , ord conn + , lim conn + , off + ] + + selectKeys filts = C.Source $ do + conn <- lift $ SqlPersist ask + C.prepareSource $ R.withStmt (sql conn) (getFiltsValues conn filts) C.$= CL.mapM parse + where + parse [PersistInt64 i] = return $ Key $ PersistInt64 i + parse y = liftIO $ throwIO $ PersistMarshalError $ "Unexpected in selectKeys: " ++ show y + t = entityDef $ dummyFromFilts filts + wher conn = if null filts + then "" + else filterClause False conn filts + sql conn = concat + [ "SELECT " + , escapeName conn $ entityID t + , " FROM " + , escapeName conn $ entityDB t + , wher conn + ] + + deleteWhere filts = do + conn <- SqlPersist ask + let t = entityDef $ dummyFromFilts filts + let wher = if null filts + then "" + else filterClause False conn filts + sql = concat + [ "DELETE FROM " + , escapeName conn $ entityDB t + , wher + ] + execute' sql $ getFiltsValues conn filts + + updateWhere _ [] = return () + updateWhere filts upds = do + conn <- SqlPersist ask + let wher = if null filts + then "" + else filterClause False conn filts + let sql = concat + [ "UPDATE " + , escapeName conn $ entityDB t + , " SET " + , T.intercalate "," $ map (go' conn . go) upds + , wher + ] + let dat = map updatePersistValue upds `mappend` + getFiltsValues conn filts + execute' sql dat + where + t = entityDef $ dummyFromFilts filts + go'' n Assign = n ++ "=?" + go'' n Add = concat [n, "=", n, "+?"] + go'' n Subtract = concat [n, "=", n, "-?"] + go'' n Multiply = concat [n, "=", n, "*?"] + go'' n Divide = concat [n, "=", n, "/?"] + go' conn (x, pu) = go'' (escapeName conn x) pu + go x = (fieldDB $ updateFieldDef x, updateUpdate x) + +updatePersistValue :: Update v -> PersistValue +updatePersistValue (Update _ v _) = toPersistValue v + +dummyFromKey :: Key SqlPersist v -> v +dummyFromKey _ = error "dummyFromKey" + +execute' :: MonadIO m => Text -> [PersistValue] -> SqlPersist m () +execute' = R.execute + +getFiltsValues :: forall val. PersistEntity val => Connection -> [Filter val] -> [PersistValue] +getFiltsValues conn = snd . filterClauseHelper False False conn + +filterClause :: PersistEntity val + => Bool -- ^ include table name? + -> Connection + -> [Filter val] + -> Text +filterClause b c = fst . filterClauseHelper b True c + +filterClauseNoWhere :: PersistEntity val + => Bool -- ^ include table name? + -> Connection + -> [Filter val] + -> Text +filterClauseNoWhere b c = fst . filterClauseHelper b False c + +filterClauseHelper :: PersistEntity val + => Bool -- ^ include table name? + -> Bool -- ^ include WHERE? + -> Connection + -> [Filter val] + -> (Text, [PersistValue]) +filterClauseHelper includeTable includeWhere conn filters = + (if not (T.null sql) && includeWhere + then " WHERE " ++ sql + else sql, vals) + where + (sql, vals) = combineAND filters + combineAND = combine " AND " + + combine s fs = + (T.intercalate s $ map wrapP a, mconcat b) + where + (a, b) = unzip $ map go fs + wrapP x = T.concat ["(", x, ")"] + + go (FilterAnd []) = ("1=1", []) + go (FilterAnd fs) = combineAND fs + go (FilterOr []) = ("1=0", []) + go (FilterOr fs) = combine " OR " fs + go (Filter field value pfilter) = + case (isNull, pfilter, varCount) of + (True, Eq, _) -> (name ++ " IS NULL", []) + (True, Ne, _) -> (name ++ " IS NOT NULL", []) + (False, Ne, _) -> (T.concat + [ "(" + , name + , " IS NULL OR " + , name + , " <> " + , qmarks + , ")" + ], notNullVals) + -- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since + -- not all databases support those words directly. + (_, In, 0) -> ("1=2", []) + (False, In, _) -> (name ++ " IN " ++ qmarks, allVals) + (True, In, _) -> (T.concat + [ "(" + , name + , " IS NULL OR " + , name + , " IN " + , qmarks + , ")" + ], notNullVals) + (_, NotIn, 0) -> ("1=1", []) + (False, NotIn, _) -> (T.concat + [ "(" + , name + , " IS NULL OR " + , name + , " NOT IN " + , qmarks + , ")" + ], notNullVals) + (True, NotIn, _) -> (T.concat + [ "(" + , name + , " IS NOT NULL AND " + , name + , " NOT IN " + , qmarks + , ")" + ], notNullVals) + _ -> (name ++ showSqlFilter pfilter ++ "?", allVals) + where + filterValueToPersistValues :: forall a. PersistField a => Either a [a] -> [PersistValue] + filterValueToPersistValues v = map toPersistValue $ either return id v + + isNull = any (== PersistNull) allVals + notNullVals = filter (/= PersistNull) allVals + allVals = filterValueToPersistValues value + tn = escapeName conn $ entityDB + $ entityDef $ dummyFromFilts [Filter field value pfilter] + name = + (if includeTable + then ((tn ++ ".") ++) + else id) + $ escapeName conn $ fieldDB $ persistFieldDef field + qmarks = case value of + Left _ -> "?" + Right x -> + let x' = filter (/= PersistNull) $ map toPersistValue x + in "(" ++ T.intercalate "," (map (const "?") x') ++ ")" + varCount = case value of + Left _ -> 1 + Right x -> length x + showSqlFilter Eq = "=" + showSqlFilter Ne = "++" + showSqlFilter Gt = ">" + showSqlFilter Lt = "<" + showSqlFilter Ge = ">=" + showSqlFilter Le = "<=" + showSqlFilter In = " IN " + showSqlFilter NotIn = " NOT IN " + showSqlFilter (BackendSpecificFilter s) = s + +infixr 5 ++ +(++) :: Text -> Text -> Text +(++) = mappend + +show :: Show a => a -> Text +show = pack . Prelude.show + +-- | Equivalent to 'selectSource', but instead of getting the connection from +-- the environment inside a 'SqlPersist' monad, provide an explicit +-- 'Connection'. This can allow you to use the returned 'Source' in an +-- arbitrary monad. +selectSourceConn :: (C.ResourceIO m, PersistEntity val) + => Connection + -> [Filter val] + -> [SelectOpt val] + -> C.Source m (Entity SqlPersist val) +selectSourceConn conn fs opts = + C.transSource (flip runSqlConn conn) (selectSource fs opts) + +dummyFromFilts :: [Filter v] -> v +dummyFromFilts _ = error "dummyFromFilts" + +orderClause :: PersistEntity val + => Bool -- ^ include the table name + -> Connection + -> SelectOpt val + -> Text +orderClause includeTable conn o = + case o of + Asc x -> name x + Desc x -> name x ++ " DESC" + _ -> error $ "orderClause: expected Asc or Desc, not limit or offset" + where + dummyFromOrder :: SelectOpt a -> a + dummyFromOrder _ = undefined + + tn = escapeName conn $ entityDB $ entityDef $ dummyFromOrder o + + name x = + (if includeTable + then ((tn ++ ".") ++) + else id) + $ escapeName conn $ fieldDB $ persistFieldDef x diff --git a/Database/Persist/Query/Internal.hs b/Database/Persist/Query/Internal.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Query/Internal.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Database.Persist.Query.Internal + ( -- re-exported as public + PersistQuery (..) + , selectList + + -- just Internal + , SelectOpt (..) + , limitOffsetOrder + , Filter (..) + , PersistUpdate (..) + , Update (..) + , updateFieldDef + , deleteCascadeWhere + ) where + +import Database.Persist.Store +import Database.Persist.EntityDef + +import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL + + +class PersistStore b m => PersistQuery b m where + -- | Update individual fields on a specific record. + update :: PersistEntity val => Key b val -> [Update val] -> b m () + + -- | Update individual fields on any record matching the given criterion. + updateWhere :: PersistEntity val => [Filter val] -> [Update val] -> b m () + + -- | Delete all records matching the given criterion. + deleteWhere :: PersistEntity val => [Filter val] -> b m () + + -- | Get all records matching the given criterion in the specified order. + -- Returns also the identifiers. + selectSource + :: PersistEntity val + => [Filter val] + -> [SelectOpt val] + -> C.Source (b m) (Entity b val) + + -- | get just the first record for the criterion + selectFirst :: PersistEntity val + => [Filter val] + -> [SelectOpt val] + -> b m (Maybe (Entity b val)) + selectFirst filts opts = C.runResourceT + $ selectSource filts ((LimitTo 1):opts) C.$$ CL.head + + + -- | Get the 'Key's of all records matching the given criterion. + selectKeys :: PersistEntity val + => [Filter val] + -> C.Source (b m) (Key b val) + + -- | The total number of records fulfilling the given criterion. + count :: PersistEntity val => [Filter val] -> b m Int + +-- | Filters which are available for 'select', 'updateWhere' and +-- 'deleteWhere'. Each filter constructor specifies the field being +-- filtered on, the type of comparison applied (equals, not equals, etc) +-- and the argument for the comparison. +data Filter v = forall typ. PersistField typ => Filter + { filterField :: EntityField v typ + , filterValue :: Either typ [typ] -- FIXME + , filterFilter :: PersistFilter -- FIXME + } + | FilterAnd [Filter v] -- ^ convenient for internal use, not needed for the API + | FilterOr [Filter v] + + +data SelectOpt v = forall typ. Asc (EntityField v typ) + | forall typ. Desc (EntityField v typ) + | OffsetBy Int + | LimitTo Int + +-- | Call 'select' but return the result as a list. +selectList :: (PersistEntity val, PersistQuery b m) + => [Filter val] + -> [SelectOpt val] + -> b m [Entity b val] +selectList a b = C.runResourceT $ selectSource a b C.$$ CL.consume + +data PersistUpdate = Assign | Add | Subtract | Multiply | Divide -- FIXME need something else here + deriving (Read, Show, Enum, Bounded) + +data Update v = forall typ. PersistField typ => Update + { updateField :: EntityField v typ + , updateValue :: typ + , updateUpdate :: PersistUpdate -- FIXME Replace with expr down the road + } + +limitOffsetOrder :: PersistEntity val => [SelectOpt val] -> (Int, Int, [SelectOpt val]) +limitOffsetOrder opts = + foldr go (0, 0, []) opts + where + go (LimitTo l) (_, b, c) = (l, b ,c) + go (OffsetBy o) (a, _, c) = (a, o, c) + go x (a, b, c) = (a, b, x : c) + +updateFieldDef :: PersistEntity v => Update v -> FieldDef +updateFieldDef (Update f _ _) = persistFieldDef f + +deleteCascadeWhere :: (DeleteCascade a b m, PersistQuery b m) + => [Filter a] -> b m () +deleteCascadeWhere filts = do + C.runResourceT $ selectKeys filts C.$$ CL.mapM_ deleteCascade diff --git a/Database/Persist/Query/Join.hs b/Database/Persist/Query/Join.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Query/Join.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +module Database.Persist.Query.Join + ( -- * Typeclass + RunJoin (..) + -- * One-to-many relation + , SelectOneMany (..) + , selectOneMany + ) where + +import Database.Persist.Store +import Database.Persist.Query.Internal +import Data.Maybe (mapMaybe) +import qualified Data.Map as Map +import Data.List (foldl') + +class PersistQuery b m => RunJoin a b m where + type Result a + runJoin :: a -> b m (Result a) + +data SelectOneMany backend one many = SelectOneMany + { somFilterOne :: [Filter one] + , somOrderOne :: [SelectOpt one] + , somFilterMany :: [Filter many] + , somOrderMany :: [SelectOpt many] + , somFilterKeys :: [Key backend one] -> Filter many + , somGetKey :: many -> Key backend one + , somIncludeNoMatch :: Bool + } + +selectOneMany :: ([Key backend one] -> Filter many) -> (many -> Key backend one) -> SelectOneMany backend one many +selectOneMany filts get' = SelectOneMany [] [] [] [] filts get' False +instance (PersistEntity one, PersistEntity many, Ord (Key backend one), PersistQuery backend monad) + => RunJoin (SelectOneMany backend one many) backend monad where + type Result (SelectOneMany backend one many) = + [((Entity backend one), [(Entity backend many)])] + runJoin (SelectOneMany oneF oneO manyF manyO eq getKey isOuter) = do + x <- selectList oneF oneO + -- FIXME use select instead of selectList + y <- selectList (eq (map entityKey x) : manyF) manyO + let y' = foldl' go Map.empty y + return $ mapMaybe (go' y') x + where + go m many@(Entity _ many') = + Map.insert (getKey many') + (case Map.lookup (getKey many') m of + Nothing -> (:) many + Just v -> v . (:) many + ) m + go' y' one@(Entity k _) = + case Map.lookup k y' of + Nothing -> + if isOuter + then Just (one, []) + else Nothing + Just many -> Just (one, many []) diff --git a/Database/Persist/Query/Join/Sql.hs b/Database/Persist/Query/Join/Sql.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Query/Join/Sql.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Database.Persist.Query.Join.Sql + ( RunJoin (..) + ) where + +import Database.Persist.Query.Join hiding (RunJoin (..)) +import Database.Persist.EntityDef +import qualified Database.Persist.Query.Join as J +import Database.Persist.Store +import Database.Persist.Query.Internal +import Database.Persist.Query.GenericSql +import Control.Monad (liftM) +import Data.Maybe (mapMaybe) +import Data.List (groupBy) +import Database.Persist.GenericSql +import Database.Persist.GenericSql.Internal hiding (withStmt) +import Database.Persist.GenericSql.Raw (withStmt) +import Control.Monad.Trans.Reader (ask) +import Data.Function (on) +import Control.Arrow ((&&&)) +import Data.Text (Text, concat, null) +import Prelude hiding ((++), unlines, concat, show, null) +import Data.Monoid (Monoid, mappend) +import qualified Data.Text as T +import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL + +fromPersistValuesId :: PersistEntity v => [PersistValue] -> Either Text (Entity SqlPersist v) +fromPersistValuesId [] = Left "fromPersistValuesId: No values provided" +fromPersistValuesId (PersistInt64 i:rest) = + case fromPersistValues rest of + Left e -> Left e + Right x -> Right (Entity (Key $ PersistInt64 i) x) +fromPersistValuesId _ = Left "fromPersistValuesId: invalid ID" + +class RunJoin a where + runJoin :: C.ResourceIO m => a -> SqlPersist m (J.Result a) + +instance (PersistEntity one, PersistEntity many, Eq (Key SqlPersist one)) + => RunJoin (SelectOneMany SqlPersist one many) where + runJoin (SelectOneMany oneF oneO manyF manyO eq _getKey isOuter) = do + conn <- SqlPersist ask + C.runResourceT $ liftM go $ withStmt (sql conn) (getFiltsValues conn oneF ++ getFiltsValues conn manyF) C.$$ loop id + where + go :: [(Entity a b, Maybe (Entity c d))] + -> [(Entity a b, [Entity c d])] + go = map (fst . head &&& mapMaybe snd) + . groupBy ((==) `on` (entityKey . fst)) + + loop front = do + x <- CL.head + case x of + Nothing -> return $ front [] + Just vals -> do + let (y, z) = splitAt oneCount vals + case (fromPersistValuesId y, fromPersistValuesId z) of + (Right y', Right z') -> loop (front . (:) (y', Just z')) + (Left e, _) -> error $ "selectOneMany: " ++ T.unpack e + (Right y', Left e) -> + case z of + PersistNull:_ -> loop (front . (:) (y', Nothing)) + _ -> error $ "selectOneMany: " ++ T.unpack e + oneCount = 1 + length (entityFields $ entityDef one) + one = dummyFromFilts oneF + many = dummyFromFilts manyF + sql conn = concat + [ "SELECT " + , T.intercalate "," $ colsPlusId conn one ++ colsPlusId conn many + , " FROM " + , escapeName conn $ entityDB $ entityDef one + , if isOuter then " LEFT JOIN " else " INNER JOIN " + , escapeName conn $ entityDB $ entityDef many + , " ON " + , escapeName conn $ entityDB $ entityDef one + , ".id = " + , escapeName conn $ entityDB $ entityDef many + , "." + , escapeName conn $ filterName $ eq undefined + , filts + , case ords of + [] -> "" + _ -> " ORDER BY " ++ T.intercalate ", " ords + ] + where + filts1 = filterClauseNoWhere True conn oneF + filts2 = filterClauseNoWhere True conn manyF + + orders :: PersistEntity val + => [SelectOpt val] + -> [SelectOpt val] + orders x = let (_, _, y) = limitOffsetOrder x in y + + filts + | null filts1 && null filts2 = "" + | null filts1 = " WHERE " ++ filts2 + | null filts2 = " WHERE " ++ filts1 + | otherwise = " WHERE " ++ filts1 ++ " AND " ++ filts2 + ords = map (orderClause True conn) (orders oneO) ++ map (orderClause True conn) (orders manyO) + +addTable :: PersistEntity val + => Connection + -> val + -> Text + -> Text +addTable conn e s = concat + [ escapeName conn $ entityDB $ entityDef e + , "." + , s + ] + +colsPlusId :: PersistEntity e => Connection -> e -> [Text] +colsPlusId conn e = + map (addTable conn e) $ + id_ : (map (escapeName conn . fieldDB) cols) + where + id_ = escapeName conn $ entityID $ entityDef e + cols = entityFields $ entityDef e + +filterName :: PersistEntity v => Filter v -> DBName +filterName (Filter f _ _) = fieldDB $ persistFieldDef f +filterName (FilterAnd _) = error "expected a raw filter, not an And" +filterName (FilterOr _) = error "expected a raw filter, not an Or" + +infixr 5 ++ +(++) :: Monoid m => m -> m -> m +(++) = mappend diff --git a/Database/Persist/Store.hs b/Database/Persist/Store.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Store.hs @@ -0,0 +1,582 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +-- This is to test our assumption that OverlappingInstances is just for String +#ifndef NO_OVERLAP +{-# LANGUAGE OverlappingInstances #-} +#endif + +-- | API for database actions. The API deals with fields and entities. +-- In SQL, a field corresponds to a column, and should be a single non-composite value. +-- An entity corresponds to a SQL table, so an entity is a collection of fields. +module Database.Persist.Store + ( PersistValue (..) + , SqlType (..) + , PersistField (..) + , PersistEntity (..) + , PersistStore (..) + , PersistUnique (..) + , PersistFilter (..) + , SomePersistField (..) + + , insertBy + , getByValue + , getJust + , belongsTo + , belongsToJust + + , checkUnique + , DeleteCascade (..) + , PersistException (..) + , Key (..) + , Entity (..) + + -- * Config + , PersistConfig (..) + ) where + +import qualified Prelude +import Prelude hiding ((++), show) +import Data.Monoid (mappend) +import Data.Time (Day, TimeOfDay, UTCTime) +import Data.ByteString.Char8 (ByteString, unpack) +import Control.Applicative +import Data.Typeable (Typeable) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word (Word8, Word16, Word32, Word64) +import Text.Blaze (Html, unsafeByteString) +import Text.Blaze.Renderer.Utf8 (renderHtml) +import qualified Data.Text as T +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Control.Monad.IO.Class as Trans + +import qualified Control.Exception as E +import Control.Monad.Trans.Error (Error (..)) +import Database.Persist.EntityDef + +import Data.Bits (bitSize) +import Control.Monad (liftM) + +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +import Web.PathPieces (PathPiece (..)) +import qualified Data.Text.Read +import qualified Data.Conduit as C + +import Data.Aeson (Value) +import Data.Aeson.Types (Parser) + +data PersistException + = PersistError T.Text -- ^ Generic Exception + | PersistMarshalError T.Text + | PersistInvalidField T.Text + | PersistForeignConstraintUnmet T.Text + | PersistMongoDBError T.Text + | PersistMongoDBUnsupported T.Text + deriving (Show, Typeable) + +instance E.Exception PersistException +instance Error PersistException where + strMsg = PersistError . T.pack + +-- | A raw value which can be stored in any backend and can be marshalled to +-- and from a 'PersistField'. +data PersistValue = PersistText T.Text + | PersistByteString ByteString + | PersistInt64 Int64 + | PersistDouble Double + | PersistBool Bool + | PersistDay Day + | PersistTimeOfDay TimeOfDay + | PersistUTCTime UTCTime + | PersistNull + | PersistList [PersistValue] + | PersistMap [(T.Text, PersistValue)] + | PersistObjectId ByteString -- ^ intended especially for MongoDB backend + deriving (Show, Read, Eq, Typeable, Ord) + +instance PathPiece PersistValue where + fromPathPiece t = + case Data.Text.Read.signed Data.Text.Read.decimal t of + Right (i, t') + | T.null t' -> Just $ PersistInt64 i + _ -> Just $ PersistText t + toPathPiece x = + case fromPersistValue x of + Left e -> error $ T.unpack e + Right y -> y + +-- | A SQL data type. Naming attempts to reflect the underlying Haskell +-- datatypes, eg SqlString instead of SqlVarchar. Different SQL databases may +-- have different translations for these types. +data SqlType = SqlString + | SqlInt32 + | SqlInteger -- ^ FIXME 8-byte integer; should be renamed SqlInt64 + | SqlReal + | SqlBool + | SqlDay + | SqlTime + | SqlDayTime + | SqlBlob + deriving (Show, Read, Eq, Typeable) + +-- | A value which can be marshalled to and from a 'PersistValue'. +class PersistField a where + toPersistValue :: a -> PersistValue + fromPersistValue :: PersistValue -> Either T.Text a + sqlType :: a -> SqlType + isNullable :: a -> Bool + isNullable _ = False + +#ifndef NO_OVERLAP +instance PersistField String where + toPersistValue = PersistText . T.pack + fromPersistValue (PersistText s) = Right $ T.unpack s + fromPersistValue (PersistByteString bs) = + Right $ T.unpack $ T.decodeUtf8With T.lenientDecode bs + fromPersistValue (PersistInt64 i) = Right $ Prelude.show i + fromPersistValue (PersistDouble d) = Right $ Prelude.show d + fromPersistValue (PersistDay d) = Right $ Prelude.show d + fromPersistValue (PersistTimeOfDay d) = Right $ Prelude.show d + fromPersistValue (PersistUTCTime d) = Right $ Prelude.show d + fromPersistValue PersistNull = Left "Unexpected null" + fromPersistValue (PersistBool b) = Right $ Prelude.show b + fromPersistValue (PersistList _) = Left "Cannot convert PersistList to String" + fromPersistValue (PersistMap _) = Left "Cannot convert PersistMap to String" + fromPersistValue (PersistObjectId _) = Left "Cannot convert PersistObjectId to String" + sqlType _ = SqlString +#endif + +instance PersistField ByteString where + toPersistValue = PersistByteString + fromPersistValue (PersistByteString bs) = Right bs + fromPersistValue x = T.encodeUtf8 <$> fromPersistValue x + sqlType _ = SqlBlob + +instance PersistField T.Text where + toPersistValue = PersistText + fromPersistValue (PersistText s) = Right s + fromPersistValue (PersistByteString bs) = + Right $ T.decodeUtf8With T.lenientDecode bs + fromPersistValue (PersistInt64 i) = Right $ show i + fromPersistValue (PersistDouble d) = Right $ show d + fromPersistValue (PersistDay d) = Right $ show d + fromPersistValue (PersistTimeOfDay d) = Right $ show d + fromPersistValue (PersistUTCTime d) = Right $ show d + fromPersistValue PersistNull = Left "Unexpected null" + fromPersistValue (PersistBool b) = Right $ show b + fromPersistValue (PersistList _) = Left "Cannot convert PersistList to Text" + fromPersistValue (PersistMap _) = Left "Cannot convert PersistMap to Text" + fromPersistValue (PersistObjectId _) = Left "Cannot convert PersistObjectId to Text" + sqlType _ = SqlString + +instance PersistField Html where + toPersistValue = PersistByteString . S.concat . L.toChunks . renderHtml + fromPersistValue = fmap unsafeByteString . fromPersistValue + sqlType _ = SqlString + +instance PersistField Int where + toPersistValue = PersistInt64 . fromIntegral + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue x = Left $ "Expected Integer, received: " ++ show x + sqlType x = case bitSize x of + 32 -> SqlInt32 + _ -> SqlInteger + +instance PersistField Int8 where + toPersistValue = PersistInt64 . fromIntegral + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue x = Left $ "Expected Integer, received: " ++ show x + sqlType _ = SqlInt32 + +instance PersistField Int16 where + toPersistValue = PersistInt64 . fromIntegral + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue x = Left $ "Expected Integer, received: " ++ show x + sqlType _ = SqlInt32 + +instance PersistField Int32 where + toPersistValue = PersistInt64 . fromIntegral + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue x = Left $ "Expected Integer, received: " ++ show x + sqlType _ = SqlInt32 + +instance PersistField Int64 where + toPersistValue = PersistInt64 . fromIntegral + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue x = Left $ "Expected Integer, received: " ++ show x + sqlType _ = SqlInteger + +instance PersistField Word8 where + toPersistValue = PersistInt64 . fromIntegral + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x + sqlType _ = SqlInt32 + +instance PersistField Word16 where + toPersistValue = PersistInt64 . fromIntegral + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x + sqlType _ = SqlInt32 + +instance PersistField Word32 where + toPersistValue = PersistInt64 . fromIntegral + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x + sqlType _ = SqlInteger + +instance PersistField Word64 where + toPersistValue = PersistInt64 . fromIntegral + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x + sqlType _ = SqlInteger + +instance PersistField Double where + toPersistValue = PersistDouble + fromPersistValue (PersistDouble d) = Right d + fromPersistValue x = Left $ "Expected Double, received: " ++ show x + sqlType _ = SqlReal + +instance PersistField Bool where + toPersistValue = PersistBool + fromPersistValue (PersistBool b) = Right b + fromPersistValue (PersistInt64 i) = Right $ i /= 0 + fromPersistValue x = Left $ "Expected Bool, received: " ++ show x + sqlType _ = SqlBool + +instance PersistField Day where + toPersistValue = PersistDay + fromPersistValue (PersistDay d) = Right d + fromPersistValue x@(PersistText t) = + case reads $ T.unpack t of + (d, _):_ -> Right d + _ -> Left $ "Expected Day, received " ++ show x + fromPersistValue x@(PersistByteString s) = + case reads $ unpack s of + (d, _):_ -> Right d + _ -> Left $ "Expected Day, received " ++ show x + fromPersistValue x = Left $ "Expected Day, received: " ++ show x + sqlType _ = SqlDay + +instance PersistField TimeOfDay where + toPersistValue = PersistTimeOfDay + fromPersistValue (PersistTimeOfDay d) = Right d + fromPersistValue x@(PersistText t) = + case reads $ T.unpack t of + (d, _):_ -> Right d + _ -> Left $ "Expected TimeOfDay, received " ++ show x + fromPersistValue x@(PersistByteString s) = + case reads $ unpack s of + (d, _):_ -> Right d + _ -> Left $ "Expected TimeOfDay, received " ++ show x + fromPersistValue x = Left $ "Expected TimeOfDay, received: " ++ show x + sqlType _ = SqlTime + +instance PersistField UTCTime where + toPersistValue = PersistUTCTime + fromPersistValue (PersistUTCTime d) = Right d + fromPersistValue x@(PersistText t) = + case reads $ T.unpack t of + (d, _):_ -> Right d + _ -> Left $ "Expected UTCTime, received " ++ show x + fromPersistValue x@(PersistByteString s) = + case reads $ unpack s of + (d, _):_ -> Right d + _ -> Left $ "Expected UTCTime, received " ++ show x + fromPersistValue x = Left $ "Expected UTCTime, received: " ++ show x + sqlType _ = SqlDayTime + +instance PersistField a => PersistField (Maybe a) where + toPersistValue Nothing = PersistNull + toPersistValue (Just a) = toPersistValue a + fromPersistValue PersistNull = Right Nothing + fromPersistValue x = fmap Just $ fromPersistValue x + sqlType _ = sqlType (error "this is the problem" :: a) + isNullable _ = True + +-- | A single database entity. For example, if writing a blog application, a +-- blog entry would be an entry, containing fields such as title and content. +class PersistEntity val where + -- | Parameters: val and datatype of the field + data EntityField val :: * -> * + persistFieldDef :: EntityField val typ -> FieldDef + + type PersistEntityBackend val :: ((* -> *) -> * -> *) + + -- | Unique keys in existence on this entity. + data Unique val :: ((* -> *) -> * -> *) -> * + + entityDef :: val -> EntityDef + toPersistFields :: val -> [SomePersistField] + fromPersistValues :: [PersistValue] -> Either T.Text val + halfDefined :: val + + persistUniqueToFieldNames :: Unique val backend -> [(HaskellName, DBName)] + persistUniqueToValues :: Unique val backend -> [PersistValue] + persistUniqueKeys :: val -> [Unique val backend] + + persistIdField :: EntityField val (Key (PersistEntityBackend val) val) + +#ifdef WITH_MONGODB +instance PersistField a => PersistField [a] where + toPersistValue = PersistList . map toPersistValue + fromPersistValue (PersistList l) = fromPersistList l + fromPersistValue x = Left $ "Expected PersistList, received: " ++ show x + sqlType _ = SqlString + +instance (Ord a, PersistField a) => PersistField (S.Set a) where + toPersistValue = PersistList . map toPersistValue . S.toList + fromPersistValue (PersistList list) = + either Left (Right . S.fromList) $ fromPersistList list + fromPersistValue x = Left $ "Expected PersistList, received: " ++ show x + sqlType _ = SqlString + +fromPersistList :: PersistField a => [PersistValue] -> Either String [a] +fromPersistList list = + foldl (\eithList v -> + case (eithList, fromPersistValue v) of + (Left e, _) -> Left e + (_, Left e) -> Left e + (Right xs, Right x) -> Right (x:xs) + ) (Right []) list + +instance (PersistField a, PersistField b) => PersistField (a,b) where + toPersistValue (x,y) = PersistList [toPersistValue x, toPersistValue y] + fromPersistValue (PersistList (vx:vy:[])) = + case (fromPersistValue vx, fromPersistValue vy) of + (Right x, Right y) -> Right (x, y) + (Left e, _) -> Left e + (_, Left e) -> Left e + fromPersistValue x = Left $ "Expected 2 item PersistList, received: " ++ show x + sqlType _ = SqlString + +instance PersistField v => PersistField (M.Map T.Text v) where + toPersistValue = PersistMap . map (\(k,v) -> (k, toPersistValue v)) . M.toList + fromPersistValue (PersistMap kvs) = case ( + foldl (\eithAssocs (k,v) -> + case (eithAssocs, fromPersistValue v) of + (Left e, _) -> Left e + (_, Left e) -> Left e + (Right assocs, Right v') -> Right ((k,v'):assocs) + ) (Right []) kvs + ) of + Right vs -> Right $ M.fromList vs + Left e -> Left e + + fromPersistValue x = Left $ "Expected PersistMap, received: " ++ show x + sqlType _ = SqlString +#endif + + +data SomePersistField = forall a. PersistField a => SomePersistField a +instance PersistField SomePersistField where + toPersistValue (SomePersistField a) = toPersistValue a + fromPersistValue x = fmap SomePersistField (fromPersistValue x :: Either T.Text T.Text) + sqlType (SomePersistField a) = sqlType a + +newtype Key (backend :: (* -> *) -> * -> *) entity = Key { unKey :: PersistValue } + deriving (Show, Read, Eq, Ord, PersistField) + +-- | Datatype that represents an entity, with both its key and +-- its Haskell representation. +-- +-- When using the an SQL-based backend (such as SQLite or +-- PostgreSQL), an 'Entity' may take any number of columns +-- depending on how many fields it has. In order to reconstruct +-- your entity on the Haskell side, @persistent@ needs all of +-- your entity columns and in the right order. Note that you +-- don't need to worry about this when using @persistent@\'s API +-- since everything is handled correctly behind the scenes. +-- +-- However, if you want to issue a raw SQL command that returns +-- an 'Entity', then you have to be careful with the column +-- order. While you could use @SELECT Entity.* WHERE ...@ and +-- that would work most of the time, there are times when the +-- order of the columns on your database is different from the +-- order that @persistent@ expects (for example, if you add a new +-- field in the middle of you entity definition and then use the +-- migration code -- @persistent@ will expect the column to be in +-- the middle, but your DBMS will put it as the last column). +-- So, instead of using a query like the one above, you may use +-- 'Database.Persist.GenericSql.rawSql' (from the +-- "Database.Persist.GenericSql" module) with its /entity +-- selection placeholder/ (a double question mark @??@). Using +-- @rawSql@ the query above must be written as @SELECT ?? WHERE +-- ..@. Then @rawSql@ will replace @??@ with the list of all +-- columns that we need from your entity in the right order. If +-- your query returns two entities (i.e. @(Entity backend a, +-- Entity backend b)@), then you must you use @SELECT ??, ?? +-- WHERE ...@, and so on. +data Entity backend entity = + Entity { entityKey :: Key backend entity + , entityVal :: entity } + deriving (Eq, Ord, Show, Read) + +class (C.ResourceIO m, C.ResourceIO (b m)) => PersistStore b m where + + -- | Create a new record in the database, returning an automatically created + -- key (in SQL an auto-increment id). + insert :: PersistEntity val => val -> b m (Key b val) + + -- | Create a new record in the database using the given key. + insertKey :: PersistEntity val => Key b val -> val -> b m () + + -- | Put the record in the database with the given key. + -- Unlike 'replace', if a record with the given key does not + -- exist then a new record will be inserted. + repsert :: PersistEntity val => Key b val -> val -> b m () + + -- | Replace the record in the database with the given + -- key. Note that the result is undefined if such record does + -- not exist, so you must use 'insertKey' or 'repsert' in + -- these cases. + replace :: PersistEntity val => Key b val -> val -> b m () + + -- | Delete a specific record by identifier. Does nothing if record does + -- not exist. + delete :: PersistEntity val => Key b val -> b m () + + -- | Get a record by identifier, if available. + get :: PersistEntity val => Key b val -> b m (Maybe val) + +class PersistStore b m => PersistUnique b m where + -- | Get a record by unique key, if available. Returns also the identifier. + getBy :: PersistEntity val => Unique val b -> b m (Maybe (Entity b val)) + + -- | Delete a specific record by unique key. Does nothing if no record + -- matches. + deleteBy :: PersistEntity val => Unique val b -> b m () + + -- | Like 'insert', but returns 'Nothing' when the record + -- couldn't be inserted because of a uniqueness constraint. + insertUnique :: PersistEntity val => val -> b m (Maybe (Key b val)) + insertUnique datum = do + isUnique <- checkUnique datum + if isUnique then Just <$> insert datum else return Nothing + + + +-- | Insert a value, checking for conflicts with any unique constraints. If a +-- duplicate exists in the database, it is returned as 'Left'. Otherwise, the +-- new 'Key' is returned as 'Right'. +insertBy :: (PersistEntity v, PersistStore b m, PersistUnique b m) + => v -> b m (Either (Entity b v) (Key b v)) +insertBy val = + go $ persistUniqueKeys val + where + go [] = Right `liftM` insert val + go (x:xs) = do + y <- getBy x + case y of + Nothing -> go xs + Just z -> return $ Left z + +-- | A modification of 'getBy', which takes the 'PersistEntity' itself instead +-- of a 'Unique' value. Returns a value matching /one/ of the unique keys. This +-- function makes the most sense on entities with a single 'Unique' +-- constructor. +getByValue :: (PersistEntity v, PersistUnique b m) + => v -> b m (Maybe (Entity b v)) +getByValue val = + go $ persistUniqueKeys val + where + go [] = return Nothing + go (x:xs) = do + y <- getBy x + case y of + Nothing -> go xs + Just z -> return $ Just z + +-- | curry this to make a convenience function that loads an associated model +-- > foreign = belongsTo foeignId +belongsTo :: + (PersistStore b m + , PersistEntity ent1 + , PersistEntity ent2) => (ent1 -> Maybe (Key b ent2)) -> ent1 -> b m (Maybe ent2) +belongsTo foreignKeyField model = case foreignKeyField model of + Nothing -> return Nothing + Just f -> get f + +-- | same as belongsTo, but uses @getJust@ and therefore is similarly unsafe +belongsToJust :: + (PersistStore b m + , PersistEntity ent1 + , PersistEntity ent2) => (ent1 -> Key b ent2) -> ent1 -> b m ent2 +belongsToJust getForeignKey model = getJust $ getForeignKey model + +-- | Same as get, but for a non-null (not Maybe) foreign key +-- Unsafe unless your database is enforcing that the foreign key is valid +getJust :: (PersistStore b m, PersistEntity val, Show (Key b val)) => Key b val -> b m val +getJust key = get key >>= maybe + (Trans.liftIO $ E.throwIO $ PersistForeignConstraintUnmet $ show key) + return + + +-- | Check whether there are any conflicts for unique keys with this entity and +-- existing entities in the database. +-- +-- Returns 'True' if the entity would be unique, and could thus safely be +-- 'insert'ed; returns 'False' on a conflict. +checkUnique :: (PersistEntity val, PersistUnique b m) => val -> b m Bool +checkUnique val = + go $ persistUniqueKeys val + where + go [] = return True + go (x:xs) = do + y <- getBy x + case y of + Nothing -> go xs + Just _ -> return False + +data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le | In | NotIn + | BackendSpecificFilter T.Text + deriving (Read, Show) + +class PersistEntity a => DeleteCascade a b m where + deleteCascade :: Key b a -> b m () + +instance PersistField PersistValue where + toPersistValue = id + fromPersistValue = Right + sqlType _ = SqlInteger -- since PersistValue should only be used like this for keys, which in SQL are Int64 + +-- | Represents a value containing all the configuration options for a specific +-- backend. This abstraction makes it easier to write code that can easily swap +-- backends. +class PersistConfig c where + type PersistConfigBackend c :: (* -> *) -> * -> * + type PersistConfigPool c + + -- | Load the config settings from a 'Value', most likely taken from a YAML + -- config file. + loadConfig :: Value -> Parser c + + -- | Modify the config settings based on environment variables. + applyEnv :: c -> IO c + applyEnv = return + + -- | Create a new connection pool based on the given config settings. + createPoolConfig :: c -> IO (PersistConfigPool c) + + -- | Run a database action by taking a connection from the pool. + runPool :: C.ResourceIO m => c -> PersistConfigBackend c m a + -> PersistConfigPool c + -> m a + +infixr 5 ++ +(++) :: T.Text -> T.Text -> T.Text +(++) = mappend + +show :: Show a => a -> T.Text +show = T.pack . Prelude.show diff --git a/Database/Persist/Util.hs b/Database/Persist/Util.hs --- a/Database/Persist/Util.hs +++ b/Database/Persist/Util.hs @@ -1,11 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} module Database.Persist.Util ( nullable , deprecate ) where import System.IO.Unsafe (unsafePerformIO) +import Data.Text -nullable :: [String] -> Bool +nullable :: [Text] -> Bool nullable s | "Maybe" `elem` s = True | "null" `elem` s = deprecate "Please replace null with Maybe" True diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,42 +1,57 @@ name: persistent -version: 0.6.4.4 +version: 0.7.0 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. +synopsis: Type-safe, multi-backend data serialization. +description: Type-safe, data serialization. You must use a specific backend in order to make this useful. category: Database, Yesod stability: Stable cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/book/persistent +flag nooverlap + default: False + description: test out our assumption that OverlappingInstances is just for String + library + if flag(nooverlap) + cpp-options: -DNO_OVERLAP + build-depends: base >= 4 && < 5 , bytestring >= 0.9 && < 0.10 , transformers >= 0.2.1 && < 0.3 , time >= 1.1.4 - , text >= 0.8 && < 0.12 + , text >= 0.8 && < 1 , containers >= 0.2 && < 0.5 - , enumerator >= 0.4.9 && < 0.5 - , monad-control >= 0.2 && < 0.4 - , pool >= 0.1 && < 0.2 + , conduit >= 0.0 && < 0.2 + , monad-control >= 0.3 && < 0.4 + , lifted-base >= 0.1 && < 0.2 + , pool-conduit >= 0.0 && < 0.1 , blaze-html >= 0.4 && < 0.5 - , path-pieces >= 0.0 && < 0.1 + , path-pieces >= 0.1 && < 0.2 , mtl >= 2.0 && < 2.1 - , data-object >= 0.3.1.7 && < 0.4 + , aeson >= 0.5 && < 0.6 , transformers-base + exposed-modules: Database.Persist - Database.Persist.Base + Database.Persist.EntityDef + Database.Persist.Store Database.Persist.Quasi Database.Persist.GenericSql - Database.Persist.GenericSql.Internal Database.Persist.GenericSql.Raw + Database.Persist.GenericSql.Migration Database.Persist.TH.Library Database.Persist.Util - Database.Persist.Join - Database.Persist.Join.Sql + Database.Persist.Query + Database.Persist.Query.Internal + Database.Persist.Query.GenericSql + Database.Persist.Query.Join + Database.Persist.Query.Join.Sql + Database.Persist.GenericSql.Internal + ghc-options: -Wall source-repository head