module Database.Groundhog.Core
(
PersistEntity(..)
, PersistValue(..)
, PersistField(..)
, SinglePersistField(..)
, PurePersistField(..)
, PrimitivePersistField(..)
, Embedded(..)
, Projection(..)
, Projection'
, RestrictionHolder
, Unique
, KeyForBackend(..)
, BackendSpecific
, ConstructorMarker
, UniqueMarker
, Proxy
, HFalse
, HTrue
, ZT (..)
, Utf8(..)
, fromUtf8
, delim
, Cond(..)
, ExprRelation(..)
, Update(..)
, (~>)
, FieldLike(..)
, Assignable
, SubField(..)
, AutoKeyField(..)
, FieldChain
, NeverNull
, UntypedExpr(..)
, Expr(..)
, Order(..)
, HasSelectOptions(..)
, SelectOptions(..)
, limitTo
, offsetBy
, orderBy
, distinct
, DbTypePrimitive'(..)
, DbTypePrimitive
, DbType(..)
, EntityDef'(..)
, EntityDef
, EmbeddedDef'(..)
, EmbeddedDef
, OtherTypeDef'(..)
, OtherTypeDef
, ConstructorDef'(..)
, ConstructorDef
, Constructor(..)
, EntityConstr(..)
, IsUniqueKey(..)
, UniqueDef'(..)
, UniqueDef
, UniqueType(..)
, ReferenceActionType(..)
, ParentTableReference
, SingleMigration
, NamedMigrations
, Migration
, PersistBackend(..)
, DbDescriptor(..)
, RowPopper
, DbPersist(..)
, runDbPersist
, ConnectionManager(..)
, SingleConnectionManager
, Savepoint(..)
) where
import Blaze.ByteString.Builder (Builder, toByteString)
import Control.Applicative (Applicative)
import Control.Monad.Base (MonadBase (liftBase))
import Control.Monad.Logger (MonadLogger(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Control (MonadBaseControl (..), ComposeSt, defaultLiftBaseWith, defaultRestoreM, MonadTransControl (..))
import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)
import Control.Monad.Trans.State (StateT)
import Control.Monad.Reader (MonadReader(..))
import Control.Monad (liftM)
import Data.ByteString.Char8 (ByteString)
import Data.Int (Int64)
import Data.Map (Map)
import Data.Time (Day, TimeOfDay, UTCTime)
import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone)
import GHC.Exts (Constraint)
class (PurePersistField (AutoKey v), PurePersistField (DefaultKey v)) => PersistEntity v where
data Field v :: ((* -> *) -> *) -> * -> *
data Key v :: * -> *
type AutoKey v
type DefaultKey v
type IsSumType v
entityDef :: DbDescriptor db => proxy db -> v -> EntityDef
toEntityPersistValues :: PersistBackend m => v -> m ([PersistValue] -> [PersistValue])
fromEntityPersistValues :: PersistBackend m => [PersistValue] -> m (v, [PersistValue])
getUniques :: DbDescriptor db => proxy db -> v -> (Int, [(String, [PersistValue] -> [PersistValue])])
entityFieldChain :: DbDescriptor db => proxy db -> Field v c a -> FieldChain
data Unique (u :: (* -> *) -> *)
data BackendSpecific
data ConstructorMarker v a
data UniqueMarker v a
data KeyForBackend db v = (DbDescriptor db, PersistEntity v) => KeyForBackend (AutoKeyType db)
data Proxy a
data HFalse
data HTrue
data Cond db r =
And (Cond db r) (Cond db r)
| Or (Cond db r) (Cond db r)
| Not (Cond db r)
| Compare ExprRelation (UntypedExpr db r) (UntypedExpr db r)
| CondRaw (QueryRaw db r)
| CondEmpty
data ExprRelation = Eq | Ne | Gt | Lt | Ge | Le deriving Show
data Update db r = forall f a . (Assignable f a, Projection' f db r a) => Update f (UntypedExpr db r)
data Order db r = forall a f . (Projection' f db r a) => Asc f
| forall a f . (Projection' f db r a) => Desc f
type FieldChain = ((String, DbType), [(String, EmbeddedDef)])
class Projection p a | p -> a where
type ProjectionDb p db :: Constraint
type ProjectionRestriction p r :: Constraint
projectionExprs :: (DbDescriptor db, ProjectionDb p db, ProjectionRestriction p r) => p -> [UntypedExpr db r] -> [UntypedExpr db r]
projectionResult :: PersistBackend m => p -> [PersistValue] -> m (a, [PersistValue])
class (Projection p a, ProjectionDb p db, ProjectionRestriction p r) => Projection' p db r a
instance (Projection p a, ProjectionDb p db, ProjectionRestriction p r) => Projection' p db r a
class Projection f a => Assignable f a | f -> a
class Assignable f a => FieldLike f a | f -> a where
fieldChain :: (DbDescriptor db, ProjectionDb f db) => proxy db -> f -> FieldChain
class PersistField v => Embedded v where
data Selector v :: * -> *
selectorNum :: Selector v a -> Int
infixl 5 ~>
(~>) :: (EntityConstr v c, FieldLike f a, DbDescriptor db, Projection' f db (RestrictionHolder v c) a, Embedded a) => f -> Selector a a' -> SubField db v c a'
field ~> sel = subField where
subField = case fieldChain db field of
((name, typ), prefix) -> case typ of
DbEmbedded emb@(EmbeddedDef _ ts) _ -> SubField (ts !! selectorNum sel, (name, emb):prefix)
other -> error $ "(~>): cannot get subfield of non-embedded type " ++ show other
db = (undefined :: SubField db v c a' -> proxy db) subField
newtype SubField db v (c :: (* -> *) -> *) a = SubField FieldChain
data AutoKeyField v (c :: (* -> *) -> *) where
AutoKeyField :: AutoKeyField v c
data RestrictionHolder v (c :: (* -> *) -> *)
data SelectOptions db r hasLimit hasOffset hasOrder hasDistinct = SelectOptions {
condOptions :: Cond db r
, limitOptions :: Maybe Int
, offsetOptions :: Maybe Int
, orderOptions :: [Order db r]
, distinctOptions :: Bool
, dbSpecificOptions :: [(String, QueryRaw db r)]
}
class HasSelectOptions a db r | a -> db r where
type HasLimit a
type HasOffset a
type HasOrder a
type HasDistinct a
getSelectOptions :: a -> SelectOptions db r (HasLimit a) (HasOffset a) (HasOrder a) (HasDistinct a)
instance db' ~ db => HasSelectOptions (Cond db r) db' r where
type HasLimit (Cond db r) = HFalse
type HasOffset (Cond db r) = HFalse
type HasOrder (Cond db r) = HFalse
type HasDistinct (Cond db r) = HFalse
getSelectOptions a = SelectOptions a Nothing Nothing [] False []
instance db' ~ db => HasSelectOptions (SelectOptions db r hasLimit hasOffset hasOrder hasDistinct) db' r where
type HasLimit (SelectOptions db r hasLimit hasOffset hasOrder hasDistinct) = hasLimit
type HasOffset (SelectOptions db r hasLimit hasOffset hasOrder hasDistinct) = hasOffset
type HasOrder (SelectOptions db r hasLimit hasOffset hasOrder hasDistinct) = hasOrder
type HasDistinct (SelectOptions db r hasLimit hasOffset hasOrder hasDistinct) = hasDistinct
getSelectOptions = id
limitTo :: (HasSelectOptions a db r, HasLimit a ~ HFalse) => a -> Int -> SelectOptions db r HTrue (HasOffset a) (HasOrder a) (HasDistinct a)
limitTo opts lim = (getSelectOptions opts) {limitOptions = Just lim}
offsetBy :: (HasSelectOptions a db r, HasOffset a ~ HFalse) => a -> Int -> SelectOptions db r (HasLimit a) HTrue (HasOrder a) (HasDistinct a)
offsetBy opts off = (getSelectOptions opts) {offsetOptions = Just off}
orderBy :: (HasSelectOptions a db r, HasOrder a ~ HFalse) => a -> [Order db r] -> SelectOptions db r (HasLimit a) (HasOffset a) HTrue (HasDistinct a)
orderBy opts ord = (getSelectOptions opts) {orderOptions = ord}
distinct :: (HasSelectOptions a db r, HasDistinct a ~ HFalse) => a -> SelectOptions db r (HasLimit a) (HasOffset a) (HasOrder a) HTrue
distinct opts = (getSelectOptions opts) {distinctOptions = True}
newtype DbPersist conn m a = DbPersist { unDbPersist :: ReaderT conn m a }
deriving (Monad, MonadIO, Functor, Applicative, MonadTrans, MonadReader conn)
instance MonadBase IO m => MonadBase IO (DbPersist conn m) where
liftBase = lift . liftBase
instance MonadTransControl (DbPersist conn) where
newtype StT (DbPersist conn) a = StReader {unStReader :: a}
liftWith f = DbPersist $ ReaderT $ \r -> f $ \t -> liftM StReader $ runReaderT (unDbPersist t) r
restoreT = DbPersist . ReaderT . const . liftM unStReader
instance MonadBaseControl IO m => MonadBaseControl IO (DbPersist conn m) where
newtype StM (DbPersist conn m) a = StMSP {unStMSP :: ComposeSt (DbPersist conn) m a}
liftBaseWith = defaultLiftBaseWith StMSP
restoreM = defaultRestoreM unStMSP
instance MonadLogger m => MonadLogger (DbPersist conn m) where
monadLoggerLog a b c = lift . monadLoggerLog a b c
runDbPersist :: Monad m => DbPersist conn m a -> conn -> m a
runDbPersist = runReaderT . unDbPersist
class PrimitivePersistField (AutoKeyType db) => DbDescriptor db where
type AutoKeyType db
type QueryRaw db :: * -> *
backendName :: proxy db -> String
class (Monad m, DbDescriptor (PhantomDb m)) => PersistBackend m where
type PhantomDb m
insert :: PersistEntity v => v -> m (AutoKey v)
insert_ :: PersistEntity v => v -> m ()
insertBy :: (PersistEntity v, IsUniqueKey (Key v (Unique u))) => u (UniqueMarker v) -> v -> m (Either (AutoKey v) (AutoKey v))
insertByAll :: PersistEntity v => v -> m (Either (AutoKey v) (AutoKey v))
replace :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => Key v BackendSpecific -> v -> m ()
replaceBy :: (PersistEntity v, IsUniqueKey (Key v (Unique u))) => u (UniqueMarker v) -> v -> m ()
select :: (PersistEntity v, EntityConstr v c, HasSelectOptions opts (PhantomDb m) (RestrictionHolder v c))
=> opts -> m [v]
selectAll :: PersistEntity v => m [(AutoKey v, v)]
get :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => Key v BackendSpecific -> m (Maybe v)
getBy :: (PersistEntity v, IsUniqueKey (Key v (Unique u))) => Key v (Unique u) -> m (Maybe v)
update :: (PersistEntity v, EntityConstr v c) => [Update (PhantomDb m) (RestrictionHolder v c)] -> Cond (PhantomDb m) (RestrictionHolder v c) -> m ()
delete :: (PersistEntity v, EntityConstr v c) => Cond (PhantomDb m) (RestrictionHolder v c) -> m ()
deleteBy :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => Key v BackendSpecific -> m ()
deleteAll :: PersistEntity v => v -> m ()
count :: (PersistEntity v, EntityConstr v c) => Cond (PhantomDb m) (RestrictionHolder v c) -> m Int
countAll :: PersistEntity v => v -> m Int
project :: (PersistEntity v, EntityConstr v c, Projection' p (PhantomDb m) (RestrictionHolder v c) a, HasSelectOptions opts (PhantomDb m) (RestrictionHolder v c))
=> p
-> opts
-> m [a]
migrate :: PersistEntity v => v -> Migration m
executeRaw :: Bool
-> String
-> [PersistValue]
-> m ()
queryRaw :: Bool
-> String
-> [PersistValue]
-> (RowPopper m -> m a)
-> m a
insertList :: PersistField a => [a] -> m Int64
getList :: PersistField a => Int64 -> m [a]
type RowPopper m = m (Maybe [PersistValue])
type Migration m = StateT NamedMigrations m ()
type NamedMigrations = Map String SingleMigration
type SingleMigration = Either [String] [(Bool, Int, String)]
data EntityDef' str dbType = EntityDef {
entityName :: str
, entitySchema :: Maybe str
, typeParams :: [dbType]
, constructors :: [ConstructorDef' str dbType]
} deriving (Show, Eq)
type EntityDef = EntityDef' String DbType
data ConstructorDef' str dbType = ConstructorDef {
constrName :: str
, constrAutoKeyName :: Maybe str
, constrParams :: [(str, dbType)]
, constrUniques :: [UniqueDef' str (Either (str, dbType) str)]
} deriving (Show, Eq)
type ConstructorDef = ConstructorDef' String DbType
class Constructor c where
phantomConstrNum :: c (a :: * -> *) -> Int
class PersistEntity v => EntityConstr v c where
entityConstrNum :: proxy v -> c (a :: * -> *) -> Int
class PurePersistField uKey => IsUniqueKey uKey where
extractUnique :: uKey ~ Key v u => v -> uKey
uniqueNum :: uKey -> Int
data UniqueDef' str field = UniqueDef {
uniqueDefName :: Maybe str
, uniqueDefType :: UniqueType
, uniqueDefFields :: [field]
} deriving (Show, Eq)
type UniqueDef = UniqueDef' String (Either (String, DbType) String)
data UniqueType = UniqueConstraint
| UniqueIndex
| UniquePrimary Bool
deriving (Show, Eq, Ord)
data ReferenceActionType = NoAction
| Restrict
| Cascade
| SetNull
| SetDefault
deriving (Eq, Show)
data DbTypePrimitive' str =
DbString
| DbInt32
| DbInt64
| DbReal
| DbBool
| DbDay
| DbTime
| DbDayTime
| DbDayTimeZoned
| DbBlob
| DbOther (OtherTypeDef' str)
deriving (Eq, Show)
type DbTypePrimitive = DbTypePrimitive' String
data DbType =
DbTypePrimitive DbTypePrimitive Bool (Maybe String) (Maybe ParentTableReference)
| DbEmbedded EmbeddedDef (Maybe ParentTableReference)
| DbList String DbType
deriving (Eq, Show)
type ParentTableReference = (Either (EntityDef, Maybe String) (Maybe String, String, [String]), Maybe ReferenceActionType, Maybe ReferenceActionType)
newtype OtherTypeDef' str = OtherTypeDef ([Either str (DbTypePrimitive' str)]) deriving (Eq, Show)
type OtherTypeDef = OtherTypeDef' String
data EmbeddedDef' str dbType = EmbeddedDef Bool [(str, dbType)] deriving (Eq, Show)
type EmbeddedDef = EmbeddedDef' String DbType
newtype Utf8 = Utf8 Builder
instance Eq Utf8 where
a == b = fromUtf8 a == fromUtf8 b
instance Show Utf8 where
show = show . fromUtf8
fromUtf8 :: Utf8 -> ByteString
fromUtf8 (Utf8 a) = toByteString a
data PersistValue = PersistString String
| PersistByteString ByteString
| PersistInt64 Int64
| PersistDouble Double
| PersistBool Bool
| PersistDay Day
| PersistTimeOfDay TimeOfDay
| PersistUTCTime UTCTime
| PersistZonedTime ZT
| PersistNull
| PersistCustom Utf8 [PersistValue]
deriving (Eq, Show)
newtype ZT = ZT ZonedTime deriving (Show, Read)
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
class NeverNull a
data UntypedExpr db r where
ExprRaw :: QueryRaw db r -> UntypedExpr db r
ExprField :: FieldChain -> UntypedExpr db r
ExprPure :: forall db r a . PurePersistField a => a -> UntypedExpr db r
ExprCond :: Cond db r -> UntypedExpr db r
newtype Expr db r a = Expr (UntypedExpr db r)
instance Show (Expr db r a) where show _ = "Expr"
instance Eq (Expr db r a) where (==) = error "(==): this instance Eq (Expr db r a) is made only for Num superclass constraint"
class PersistField a where
persistName :: a -> String
toPersistValues :: PersistBackend m => a -> m ([PersistValue] -> [PersistValue])
fromPersistValues :: PersistBackend m => [PersistValue] -> m (a, [PersistValue])
dbType :: DbDescriptor db => proxy db -> a -> DbType
class PersistField a => SinglePersistField a where
toSinglePersistValue :: PersistBackend m => a -> m PersistValue
fromSinglePersistValue :: PersistBackend m => PersistValue -> m a
class PersistField a => PurePersistField a where
toPurePersistValues :: DbDescriptor db => proxy db -> a -> ([PersistValue] -> [PersistValue])
fromPurePersistValues :: DbDescriptor db => proxy db -> [PersistValue] -> (a, [PersistValue])
class PersistField a => PrimitivePersistField a where
toPrimitivePersistValue :: DbDescriptor db => proxy db -> a -> PersistValue
fromPrimitivePersistValue :: DbDescriptor db => proxy db -> PersistValue -> a
delim :: Char
delim = '#'
class ConnectionManager cm conn | cm -> conn where
withConn :: (MonadBaseControl IO m, MonadIO m) => (conn -> m a) -> cm -> m a
withConnNoTransaction :: (MonadBaseControl IO m, MonadIO m) => (conn -> m a) -> cm -> m a
class ConnectionManager cm conn => SingleConnectionManager cm conn
class Savepoint conn where
withConnSavepoint :: (MonadBaseControl IO m, MonadIO m) => String -> m a -> conn -> m a