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