module Database.Groundhog.Core
(
PersistEntity(..)
, PersistValue(..)
, PersistField(..)
, SinglePersistField(..)
, PurePersistField(..)
, PrimitivePersistField(..)
, Embedded(..)
, 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
, DbTypePrimitive(..)
, DbType(..)
, EntityDef(..)
, EmbeddedDef(..)
, OtherTypeDef(..)
, ConstructorDef(..)
, Constructor(..)
, EntityConstr(..)
, IsUniqueKey(..)
, 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)
class (PersistField v, PurePersistField (AutoKey v)) => PersistEntity v where
data Field v :: ((* -> *) -> *) -> * -> *
data Key v :: * -> *
type AutoKey v
type DefaultKey v
type IsSumType v
entityDef :: 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 :: 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 db r a => Update f (UntypedExpr db r)
data Order db r = forall a f . (FieldLike f db r a) => Asc f
| forall a f . (FieldLike f db r a) => Desc f
type FieldChain = ((String, DbType), [(String, EmbeddedDef)])
class PersistField a => Projection p db r a | p -> db r a where
projectionExprs :: p -> [UntypedExpr db r] -> [UntypedExpr db r]
projectionResult :: PersistBackend m => p -> [PersistValue] -> m (a, [PersistValue])
class Projection f db r a => Assignable f db r a | f -> r a
class Assignable f db r a => FieldLike f db r a | f -> r a where
fieldChain :: f -> FieldChain
class PersistField v => Embedded v where
data Selector v :: * -> *
selectorNum :: Selector v a -> Int
infixl 5 ~>
(~>) :: (EntityConstr v c, FieldLike f db (RestrictionHolder v c) a, Embedded a) => f -> Selector a a' -> SubField v c a'
field ~> sel = case fieldChain 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
newtype SubField 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 = SelectOptions {
condOptions :: Cond db r
, limitOptions :: Maybe Int
, offsetOptions :: Maybe Int
, orderOptions :: [Order db r]
}
class HasSelectOptions a db r | a -> db r where
type HasLimit a
type HasOffset a
type HasOrder a
getSelectOptions :: a -> SelectOptions db r (HasLimit a) (HasOffset a) (HasOrder a)
instance 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
getSelectOptions a = SelectOptions a Nothing Nothing []
instance HasSelectOptions (SelectOptions db r hasLimit hasOffset hasOrder) db r where
type HasLimit (SelectOptions db r hasLimit hasOffset hasOrder) = hasLimit
type HasOffset (SelectOptions db r hasLimit hasOffset hasOrder) = hasOffset
type HasOrder (SelectOptions db r hasLimit hasOffset hasOrder) = hasOrder
getSelectOptions = id
limitTo :: (HasSelectOptions a db r, HasLimit a ~ HFalse) => a -> Int -> SelectOptions db r HTrue (HasOffset a) (HasOrder a)
limitTo opts lim = case getSelectOptions opts of
SelectOptions c _ off ord -> SelectOptions c (Just lim) off ord
offsetBy :: (HasSelectOptions a db r, HasOffset a ~ HFalse) => a -> Int -> SelectOptions db r (HasLimit a) HTrue (HasOrder a)
offsetBy opts off = case getSelectOptions opts of
SelectOptions c lim _ ord -> SelectOptions c lim (Just off) ord
orderBy :: (HasSelectOptions a db r, HasOrder a ~ HFalse) => a -> [Order db r] -> SelectOptions db r (HasLimit a) (HasOffset a) HTrue
orderBy opts ord = case getSelectOptions opts of
SelectOptions c lim off _ -> SelectOptions c lim off ord
newtype Monad m => 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 ()
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 ()
deleteByKey :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => Key v BackendSpecific -> 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 = EntityDef {
entityName :: String
, entitySchema :: Maybe String
, typeParams :: [DbType]
, constructors :: [ConstructorDef]
} deriving (Show, Eq)
data ConstructorDef = ConstructorDef {
constrNum :: Int
, constrName :: String
, constrAutoKeyName :: Maybe String
, constrParams :: [(String, DbType)]
, constrUniques :: [UniqueDef]
} deriving (Show, Eq)
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 = UniqueDef {
uniqueName :: String
, uniqueType :: UniqueType
, uniqueFields :: [(String, DbType)]
} deriving (Show, Eq)
data UniqueType = UniqueConstraint | UniqueIndex | UniquePrimary deriving (Show, Eq)
data ReferenceActionType = NoAction
| Restrict
| Cascade
| SetNull
| SetDefault
deriving (Eq, Show)
data DbTypePrimitive =
DbString
| DbInt32
| DbInt64
| DbReal
| DbBool
| DbDay
| DbTime
| DbDayTime
| DbDayTimeZoned
| DbBlob
| DbOther OtherTypeDef
| DbAutoKey
deriving (Eq, Show)
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 = OtherTypeDef ((DbTypePrimitive -> String) -> String)
instance Eq OtherTypeDef where
OtherTypeDef f1 == OtherTypeDef f2 = f1 show == f2 show
instance Show OtherTypeDef where
showsPrec p (OtherTypeDef f) = showParen (p > 10) $ showString "OtherTypeDef " . showsPrec 11 (f show)
data EmbeddedDef = EmbeddedDef Bool [(String, DbType)] deriving (Eq, Show)
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 :: forall db r a . PersistField a => Expr db r a -> UntypedExpr db r
ExprField :: FieldChain -> UntypedExpr db r
ExprPure :: forall db r a . PurePersistField a => a -> UntypedExpr db r
newtype Expr db r a = Expr (QueryRaw 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 :: 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