{-# LANGUAGE GADTs, TypeFamilies, ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, EmptyDataDecls, ConstraintKinds, CPP, LiberalTypeSynonyms #-}
{-# LANGUAGE UndecidableInstances, UndecidableSuperClasses #-}
module Database.Groundhog.Core
(
PersistEntity(..)
, PersistValue(..)
, PersistField(..)
, SinglePersistField(..)
, PurePersistField(..)
, PrimitivePersistField(..)
, Embedded(..)
, Projection(..)
, Projection'
, RestrictionHolder
, Unique
, KeyForBackend(..)
, BackendSpecific
, ConstructorMarker
, UniqueMarker
, 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(..)
, PersistBackendConn(..)
, Action
, TryAction
, RowStream
, DbDescriptor(..)
, ExtractConnection(..)
, ConnectionManager(..)
, TryConnectionManager(..)
, Savepoint(..)
, withSavepoint
, runDb
, runDbConn
, runTryDbConn
, runTryDbConn'
, runDb'
, runDbConn'
) where
import Control.Exception.Safe (MonadCatch, SomeException(..), Exception, tryAny)
import Control.Monad.Fail (MonadFail)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)
import Control.Monad.Trans.State (StateT(..))
import Control.Monad.Reader (MonadReader(..))
import Data.Acquire (Acquire)
import Data.ByteString.Char8 (ByteString)
import Data.ByteString.Lazy (toStrict)
import Data.Int (Int64)
import Data.Map (Map)
import Data.Text (Text)
import Data.Text.Lazy.Builder (Builder, fromText, toLazyText)
import Data.Text.Lazy.Encoding (encodeUtf8)
import Data.Time (Day, TimeOfDay, UTCTime)
import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone)
import Data.String (IsString)
import Data.Semigroup (Semigroup)
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 :: 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 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}
class PrimitivePersistField (AutoKeyType db) => DbDescriptor db where
type AutoKeyType db
type QueryRaw db :: * -> *
backendName :: proxy db -> String
class (DbDescriptor conn, ConnectionManager conn) => PersistBackendConn conn where
insert :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => v -> m (AutoKey v)
insert_ :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => v -> m ()
insertBy :: (PersistEntity v, IsUniqueKey (Key v (Unique u)), PersistBackend m, Conn m ~ conn) => u (UniqueMarker v) -> v -> m (Either (AutoKey v) (AutoKey v))
insertByAll :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => v -> m (Either (AutoKey v) (AutoKey v))
replace :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific), PersistBackend m, Conn m ~ conn) => Key v BackendSpecific -> v -> m ()
replaceBy :: (PersistEntity v, IsUniqueKey (Key v (Unique u)), PersistBackend m, Conn m ~ conn) => u (UniqueMarker v) -> v -> m ()
select :: (PersistEntity v, EntityConstr v c, HasSelectOptions opts conn (RestrictionHolder v c), PersistBackend m, Conn m ~ conn)
=> opts -> m [v]
selectStream :: (PersistEntity v, EntityConstr v c, HasSelectOptions opts conn (RestrictionHolder v c), PersistBackend m, Conn m ~ conn)
=> opts -> m (RowStream v)
selectAll :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => m [(AutoKey v, v)]
selectAllStream :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => m (RowStream (AutoKey v, v))
get :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific), PersistBackend m, Conn m ~ conn) => Key v BackendSpecific -> m (Maybe v)
getBy :: (PersistEntity v, IsUniqueKey (Key v (Unique u)), PersistBackend m, Conn m ~ conn) => Key v (Unique u) -> m (Maybe v)
update :: (PersistEntity v, EntityConstr v c, PersistBackend m, Conn m ~ conn) => [Update conn (RestrictionHolder v c)] -> Cond conn (RestrictionHolder v c) -> m ()
delete :: (PersistEntity v, EntityConstr v c, PersistBackend m, Conn m ~ conn) => Cond conn (RestrictionHolder v c) -> m ()
deleteBy :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific), PersistBackend m, Conn m ~ conn) => Key v BackendSpecific -> m ()
deleteAll :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => v -> m ()
count :: (PersistEntity v, EntityConstr v c, PersistBackend m, Conn m ~ conn) => Cond conn (RestrictionHolder v c) -> m Int
countAll :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => v -> m Int
project :: (PersistEntity v, EntityConstr v c, Projection' p conn (RestrictionHolder v c) a, HasSelectOptions opts conn (RestrictionHolder v c), PersistBackend m, Conn m ~ conn)
=> p
-> opts
-> m [a]
projectStream :: (PersistEntity v, EntityConstr v c, Projection' p conn (RestrictionHolder v c) a, HasSelectOptions opts conn (RestrictionHolder v c), PersistBackend m, Conn m ~ conn)
=> p
-> opts
-> m (RowStream a)
migrate :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => v -> Migration (m)
executeRaw :: (PersistBackend m, Conn m ~ conn) => Bool
-> String
-> [PersistValue]
-> m ()
queryRaw :: (PersistBackend m, Conn m ~ conn) => Bool
-> String
-> [PersistValue]
-> m (RowStream [PersistValue])
insertList :: (PersistField a, PersistBackend m, Conn m ~ conn) => [a] -> m Int64
getList :: (PersistField a, PersistBackend m, Conn m ~ conn) => Int64 -> m [a]
type Action conn = ReaderT conn IO
type TryAction e m conn = ReaderT conn (ExceptT e m)
type RowStream a = Acquire (IO (Maybe a))
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
deriving (Eq, Ord, Show, Semigroup, Monoid, IsString)
fromUtf8 :: Utf8 -> ByteString
fromUtf8 (Utf8 s) = toStrict $ encodeUtf8 $ toLazyText s
instance Read Utf8 where
readsPrec prec str = map (\(a, b) -> (Utf8 $ fromText a, b)) $ readsPrec prec str
data PersistValue = PersistString String
| PersistText Text
| PersistByteString ByteString
| PersistInt64 Int64
| PersistDouble Double
| PersistBool Bool
| PersistDay Day
| PersistTimeOfDay TimeOfDay
| PersistUTCTime UTCTime
| PersistZonedTime ZT
| PersistNull
| PersistCustom Utf8 [PersistValue]
deriving (Eq, Show, Read)
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 :: DbType -> 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 :: a -> ([PersistValue] -> [PersistValue])
fromPurePersistValues :: [PersistValue] -> (a, [PersistValue])
class PersistField a => PrimitivePersistField a where
toPrimitivePersistValue :: a -> PersistValue
fromPrimitivePersistValue :: PersistValue -> a
delim :: Char
delim = '#'
class ExtractConnection cm conn | cm -> conn where
extractConn :: (MonadBaseControl IO m, MonadIO m) => (conn -> m a) -> cm -> m a
class ConnectionManager conn where
withConn :: (MonadBaseControl IO m, MonadIO m) => (conn -> m a) -> conn -> m a
class TryConnectionManager conn where
tryWithConn :: (MonadBaseControl IO m, MonadIO m, MonadCatch m) => (conn -> n a) -> (n a -> m (Either SomeException a)) -> conn -> m (Either SomeException a)
class Savepoint conn where
withConnSavepoint :: (MonadBaseControl IO m, MonadIO m) => String -> m a -> conn -> m a
class (Monad m, Applicative m, Functor m, MonadIO m, MonadFail m, ConnectionManager (Conn m), PersistBackendConn (Conn m)) => PersistBackend m where
type Conn m
getConnection :: m (Conn m)
instance (Monad m, Applicative m, Functor m, MonadIO m, MonadFail m, PersistBackendConn conn) => PersistBackend (ReaderT conn m) where
type Conn (ReaderT conn m) = conn
getConnection = ask
runDb :: PersistBackend m => Action (Conn m) a -> m a
runDb f = getConnection >>= liftIO . withConn (runReaderT f)
runDbConn :: (MonadIO m, MonadBaseControl IO m, ConnectionManager conn, ExtractConnection cm conn) => Action conn a -> cm -> m a
runDbConn f cm = extractConn (liftIO . withConn (runReaderT f)) cm
runTryDbConn :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, TryConnectionManager conn, ExtractConnection cm conn, Exception e) => TryAction e m conn a -> cm -> m (Either SomeException a)
runTryDbConn f cm = extractConn (tryWithConn (runReaderT f) tryExceptT) cm
runTryDbConn' :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, TryConnectionManager conn, ExtractConnection cm conn) => Action conn a -> cm -> m (Either SomeException a)
runTryDbConn' f cm = extractConn (liftIO . tryWithConn (runReaderT f) tryAny) cm
runDb' :: PersistBackend m => Action (Conn m) a -> m a
runDb' f = getConnection >>= liftIO . runReaderT f
runDbConn' :: (MonadIO m, MonadBaseControl IO m, ConnectionManager conn, ExtractConnection cm conn) => Action conn a -> cm -> m a
runDbConn' f cm = extractConn (liftIO . runReaderT f) cm
withSavepoint :: (PersistBackend m, MonadBaseControl IO m, MonadIO m, Savepoint (Conn m)) => String -> m a -> m a
withSavepoint name m = getConnection >>= withConnSavepoint name m
tryExceptT :: ( MonadCatch m
, Exception e )
=> ExceptT e m a
-> m (Either SomeException a)
tryExceptT e = do
outside <- tryAny $ runExceptT e
case outside of
Left outsideErr -> return . Left $ outsideErr
Right inside -> case inside of
Left insideErr -> return . Left . SomeException $ insideErr
Right y -> return $ Right y