{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.Beam.AutoMigrate.Annotated
(
Annotation (..),
AnnotatedDatabaseSettings,
AnnotatedDatabaseEntity (..),
IsAnnotatedDatabaseEntity (..),
TableSchema,
TableFieldSchema (..),
FieldSchema (..),
dbAnnotatedSchema,
dbAnnotatedConstraints,
annotatedDescriptor,
defaultTableSchema,
lowerEntityDescriptor,
deannotate,
annotateTableFields,
defaultsTo,
UniqueConstraint (..),
uniqueConstraintOn,
ForeignKeyConstraint (..),
foreignKeyOnPk,
foreignKeyOn,
TableKind,
DatabaseKind,
zipTables,
GZipDatabase,
pgDefaultConstraint,
)
where
import Data.Kind
import Data.Monoid (Endo (..))
import Data.Proxy
import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Database.Beam as Beam
import Database.Beam.AutoMigrate.Compat
import Database.Beam.AutoMigrate.Types
import Database.Beam.AutoMigrate.Util
import Database.Beam.Backend.SQL (HasSqlValueSyntax (..), displaySyntax)
import Database.Beam.Postgres (Postgres)
import qualified Database.Beam.Postgres.Syntax as Pg
import Database.Beam.Query (QExpr)
import Database.Beam.Schema.Tables
( DatabaseEntity,
DatabaseEntityDefaultRequirements,
DatabaseEntityDescriptor,
DatabaseEntityRegularRequirements,
EntityModification (..),
FieldModification (..),
IsDatabaseEntity,
PrimaryKey,
TableEntity,
dbEntityDescriptor,
dbEntityName,
dbTableSettings,
)
import GHC.Generics as Generic
import Lens.Micro (SimpleGetter, (^.))
import qualified Lens.Micro as Lens
type DatabaseKind = (Type -> Type) -> Type
type TableKind = (Type -> Type) -> Type
data Annotation where
UserDefinedFk :: TableKind -> Annotation
zipTables ::
( Generic (db f),
Generic (db g),
Generic (db h),
Monad m,
GZipDatabase be f g h (Rep (db f)) (Rep (db g)) (Rep (db h))
) =>
Proxy be ->
(forall tbl. (IsAnnotatedDatabaseEntity be tbl, AnnotatedDatabaseEntityRegularRequirements be tbl) => f tbl -> g tbl -> m (h tbl)) ->
db f ->
db g ->
m (db h)
zipTables be combine (f :: db f) (g :: db g) =
refl $ \h ->
to <$> gZipDatabase (Proxy @f, Proxy @g, h, be) combine (from f) (from g)
where
refl :: (Proxy h -> m (db h)) -> m (db h)
refl fn = fn Proxy
class GZipDatabase be f g h x y z where
gZipDatabase ::
Monad m =>
(Proxy f, Proxy g, Proxy h, Proxy be) ->
(forall tbl. (IsAnnotatedDatabaseEntity be tbl, AnnotatedDatabaseEntityRegularRequirements be tbl) => f tbl -> g tbl -> m (h tbl)) ->
x () ->
y () ->
m (z ())
instance GZipDatabase be f g h x y z => GZipDatabase be f g h (M1 a b x) (M1 a b y) (M1 a b z) where
gZipDatabase p combine ~(M1 f) ~(M1 g) = M1 <$> gZipDatabase p combine f g
instance
( GZipDatabase be f g h ax ay az,
GZipDatabase be f g h bx by bz
) =>
GZipDatabase be f g h (ax :*: bx) (ay :*: by) (az :*: bz)
where
gZipDatabase p combine ~(ax :*: bx) ~(ay :*: by) = do
a <- gZipDatabase p combine ax ay
b <- gZipDatabase p combine bx by
pure (a :*: b)
instance
( IsAnnotatedDatabaseEntity be tbl,
AnnotatedDatabaseEntityRegularRequirements be tbl
) =>
GZipDatabase be f g h (K1 Generic.R (f tbl)) (K1 Generic.R (g tbl)) (K1 Generic.R (h tbl))
where
gZipDatabase _ combine ~(K1 x) ~(K1 y) =
K1 <$> combine x y
instance
( Beam.Database be db,
Generic (db f),
Generic (db g),
Generic (db h),
GZipDatabase be f g h (Rep (db f)) (Rep (db g)) (Rep (db h))
) =>
GZipDatabase be f g h (K1 Generic.R (db f)) (K1 Generic.R (db g)) (K1 Generic.R (db h))
where
gZipDatabase _ combine ~(K1 x) ~(K1 y) =
K1 <$> zipTables (Proxy :: Proxy be) combine x y
type AnnotatedDatabaseSettings be db = db (AnnotatedDatabaseEntity be db)
data AnnotatedDatabaseEntity be (db :: (* -> *) -> *) entityType where
AnnotatedDatabaseEntity ::
(IsAnnotatedDatabaseEntity be entityType, IsDatabaseEntity be entityType) =>
AnnotatedDatabaseEntityDescriptor be entityType ->
DatabaseEntity be db entityType ->
AnnotatedDatabaseEntity be db entityType
class IsDatabaseEntity be entityType => IsAnnotatedDatabaseEntity be entityType where
data AnnotatedDatabaseEntityDescriptor be entityType :: *
type AnnotatedDatabaseEntityDefaultRequirements be entityType :: Constraint
type AnnotatedDatabaseEntityRegularRequirements be entityType :: Constraint
dbAnnotatedEntityAuto ::
AnnotatedDatabaseEntityRegularRequirements be entityType =>
DatabaseEntityDescriptor be entityType ->
AnnotatedDatabaseEntityDescriptor be entityType
instance
IsDatabaseEntity be (TableEntity tbl) =>
IsAnnotatedDatabaseEntity be (TableEntity tbl)
where
data AnnotatedDatabaseEntityDescriptor be (TableEntity tbl) where
AnnotatedDatabaseTable ::
Beam.Table tbl =>
{ dbAnnotatedSchema :: TableSchema tbl,
dbAnnotatedConstraints :: Set TableConstraint
} ->
AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
type
AnnotatedDatabaseEntityDefaultRequirements be (TableEntity tbl) =
(DatabaseEntityDefaultRequirements be (TableEntity tbl))
type
AnnotatedDatabaseEntityRegularRequirements be (TableEntity tbl) =
( DatabaseEntityRegularRequirements be (TableEntity tbl),
GDefaultTableSchema (Rep (TableSchema tbl) ()) (Rep (Beam.TableSettings tbl) ()),
Generic (TableSchema tbl),
Generic (Beam.TableSettings tbl)
)
dbAnnotatedEntityAuto edesc = AnnotatedDatabaseTable (defaultTableSchema . dbTableSettings $ edesc) mempty
lowerEntityDescriptor :: SimpleGetter (AnnotatedDatabaseEntity be db entityType) (DatabaseEntityDescriptor be entityType)
lowerEntityDescriptor = Lens.to (\(AnnotatedDatabaseEntity _ e) -> e ^. dbEntityDescriptor)
annotatedDescriptor :: SimpleGetter (AnnotatedDatabaseEntity be db entityType) (AnnotatedDatabaseEntityDescriptor be entityType)
annotatedDescriptor = Lens.to (\(AnnotatedDatabaseEntity e _) -> e)
deannotate :: SimpleGetter (AnnotatedDatabaseEntity be db entityType) (DatabaseEntity be db entityType)
deannotate = Lens.to (\(AnnotatedDatabaseEntity _ e) -> e)
type TableSchema tbl =
tbl (TableFieldSchema tbl)
data TableFieldSchema (tbl :: (* -> *) -> *) ty where
TableFieldSchema ::
{ tableFieldName :: ColumnName,
tableFieldSchema :: FieldSchema ty
} ->
TableFieldSchema tbl ty
data FieldSchema ty where
FieldSchema ::
ColumnType ->
Set ColumnConstraint ->
FieldSchema ty
deriving instance Show (FieldSchema ty)
class GDefaultTableSchema x y where
gDefTblSchema :: Proxy x -> y -> x
instance GDefaultTableSchema (x p) (y p) => GDefaultTableSchema (D1 f x p) (D1 f y p) where
gDefTblSchema (Proxy :: Proxy (D1 f x p)) (M1 y) =
M1 $ gDefTblSchema (Proxy :: Proxy (x p)) y
instance GDefaultTableSchema (x p) (y p) => GDefaultTableSchema (C1 f x p) (C1 f y p) where
gDefTblSchema (Proxy :: Proxy (C1 f x p)) (M1 y) =
M1 $ gDefTblSchema (Proxy :: Proxy (x p)) y
instance
(GDefaultTableSchema (a p) (c p), GDefaultTableSchema (b p) (d p)) =>
GDefaultTableSchema ((a :*: b) p) ((c :*: d) p)
where
gDefTblSchema (Proxy :: Proxy ((a :*: b) p)) (c :*: d) =
gDefTblSchema (Proxy :: Proxy (a p)) c
:*: gDefTblSchema (Proxy :: Proxy (b p)) d
instance
( SchemaConstraint (Beam.TableField tbl ty) ~ ColumnConstraint,
HasSchemaConstraints (Beam.TableField tbl ty),
HasColumnType ty
) =>
GDefaultTableSchema
(S1 f (K1 Generic.R (TableFieldSchema tbl ty)) p)
(S1 f (K1 Generic.R (Beam.TableField tbl ty)) p)
where
gDefTblSchema (_ :: Proxy (S1 f (K1 Generic.R (TableFieldSchema tbl ty)) p)) (M1 (K1 fName)) = M1 (K1 s)
where
s = TableFieldSchema (ColumnName $ fName ^. Beam.fieldName) defaultFieldSchema
defaultFieldSchema =
FieldSchema
(defaultColumnType (Proxy @ty))
(schemaConstraints (Proxy @(Beam.TableField tbl ty)))
instance
( Generic (g (Beam.TableField tbl2)),
Generic (g (TableFieldSchema tbl2)),
GDefaultTableSchema
(Rep (g (TableFieldSchema tbl2)) ())
(Rep (g (Beam.TableField tbl2)) ())
) =>
GDefaultTableSchema
(S1 f (K1 Generic.R (g (TableFieldSchema tbl2))) ())
(S1 f (K1 Generic.R (g (Beam.TableField tbl2))) ())
where
gDefTblSchema (_ :: Proxy (S1 f (K1 Generic.R (g (TableFieldSchema tbl2))) ())) (M1 (K1 fName)) =
M1 (K1 $ to' $ gDefTblSchema Proxy (from' fName))
instance
( Generic (PrimaryKey tbl1 (g (Beam.TableField tbl2))),
Generic (PrimaryKey tbl1 (g (TableFieldSchema tbl2))),
GDefaultTableSchema
(Rep (PrimaryKey tbl1 (g (TableFieldSchema tbl2))) ())
(Rep (PrimaryKey tbl1 (g (Beam.TableField tbl2))) ())
) =>
GDefaultTableSchema
(S1 f (K1 Generic.R (PrimaryKey tbl1 (g (TableFieldSchema tbl2)))) p)
(S1 f (K1 Generic.R (PrimaryKey tbl1 (g (Beam.TableField tbl2)))) p)
where
gDefTblSchema (_ :: Proxy (S1 f (K1 Generic.R (PrimaryKey tbl1 (g (TableFieldSchema tbl2)))) p)) (M1 (K1 fName)) =
M1 (K1 $ to' $ gDefTblSchema Proxy (from' fName))
defaultTableSchema ::
forall tbl.
( GDefaultTableSchema (Rep (TableSchema tbl) ()) (Rep (Beam.TableSettings tbl) ()),
Generic (TableSchema tbl),
Generic (Beam.TableSettings tbl)
) =>
Beam.TableSettings tbl ->
TableSchema tbl
defaultTableSchema tSettings =
to $ gDefTblSchema (Proxy :: Proxy (Rep (TableSchema tbl) ())) (from' tSettings)
from' :: Generic a => a -> Rep a ()
from' = from
to' :: Generic a => Rep a () -> a
to' = to
annotateTableFields ::
tbl (FieldModification (TableFieldSchema tbl)) ->
EntityModification (AnnotatedDatabaseEntity be db) be (TableEntity tbl)
annotateTableFields modFields =
EntityModification
( Endo
( \(AnnotatedDatabaseEntity tbl@(AnnotatedDatabaseTable {}) e) ->
AnnotatedDatabaseEntity
( tbl
{ dbAnnotatedSchema = Beam.withTableModification modFields (dbAnnotatedSchema tbl)
}
)
e
)
)
defaultsTo ::
(HasColumnType ty, HasSqlValueSyntax Pg.PgValueSyntax ty) =>
(forall ctx s. Beam.QGenExpr ctx Postgres s ty) ->
FieldModification (TableFieldSchema tbl) ty
defaultsTo tyVal = FieldModification $ \old ->
case tableFieldSchema old of
FieldSchema ty c ->
old
{ tableFieldSchema =
FieldSchema ty $ S.singleton (pgDefaultConstraint tyVal) <> c
}
pgDefaultConstraint ::
forall ty.
(HasColumnType ty, HasSqlValueSyntax Pg.PgValueSyntax ty) =>
(forall ctx s. Beam.QGenExpr ctx Postgres s ty) ->
ColumnConstraint
pgDefaultConstraint tyVal =
let syntaxFragment = T.pack . displaySyntax . Pg.fromPgExpression $ defaultTo_ tyVal
dVal = case defaultTypeCast (Proxy @ty) of
Nothing -> syntaxFragment
Just tc | T.head syntaxFragment == '\'' -> syntaxFragment <> "::" <> tc
Just tc | syntaxFragment == "CURRENT_TIMESTAMP" -> "(" <> syntaxFragment <> ")::" <> tc
Just tc -> "'" <> syntaxFragment <> "'::" <> tc
in Default dVal
where
defaultTo_ :: (forall s. QExpr Postgres s a) -> Pg.PgExpressionSyntax
defaultTo_ (Beam.QExpr e) = e "t"
data UniqueConstraint (tbl :: ((* -> *) -> *)) where
U :: HasColumnNames entity tbl => (tbl (Beam.TableField tbl) -> entity) -> UniqueConstraint tbl
uniqueConstraintOn ::
[UniqueConstraint tbl] ->
EntityModification (AnnotatedDatabaseEntity be db) be (TableEntity tbl)
uniqueConstraintOn us =
EntityModification
( Endo
( \(AnnotatedDatabaseEntity tbl@(AnnotatedDatabaseTable {}) e) ->
AnnotatedDatabaseEntity
( tbl
{ dbAnnotatedConstraints =
let cols = concatMap (\case (U f) -> colNames (tableSettings e) f) us
tName = e ^. dbEntityDescriptor . dbEntityName
conname = T.intercalate "_" (tName : map columnName cols) <> "_ukey"
in S.insert (Unique conname (S.fromList cols)) (dbAnnotatedConstraints tbl)
}
)
e
)
)
data ForeignKeyConstraint (tbl :: ((* -> *) -> *)) (tbl' :: ((* -> *) -> *)) where
References ::
Beam.Beamable (PrimaryKey tbl') =>
(tbl (Beam.TableField tbl) -> PrimaryKey tbl' (Beam.TableField tbl)) ->
(tbl' (Beam.TableField tbl') -> Beam.Columnar Beam.Identity (Beam.TableField tbl' ty)) ->
ForeignKeyConstraint tbl tbl'
foreignKeyOnPk ::
( Beam.Beamable (PrimaryKey tbl'),
Beam.Beamable tbl',
Beam.Table tbl',
PrimaryKey tbl' f ~ PrimaryKey tbl' g
) =>
DatabaseEntity be db (TableEntity tbl') ->
(tbl (Beam.TableField tbl) -> PrimaryKey tbl' (Beam.TableField tbl)) ->
ReferenceAction ->
ReferenceAction ->
EntityModification (AnnotatedDatabaseEntity be db) be (TableEntity tbl)
foreignKeyOnPk externalEntity ourColumn onDelete onUpdate =
EntityModification
( Endo
( \(AnnotatedDatabaseEntity tbl@(AnnotatedDatabaseTable {}) e) ->
AnnotatedDatabaseEntity
( tbl
{ dbAnnotatedConstraints =
let colPairs =
zipWith
(,)
(fieldAsColumnNames (ourColumn (tableSettings e)))
(fieldAsColumnNames (Beam.pk (tableSettings externalEntity)))
tName = externalEntity ^. dbEntityDescriptor . dbEntityName
conname = T.intercalate "_" (tName : map (columnName . snd) colPairs) <> "_fkey"
in S.insert
(ForeignKey conname (TableName tName) (S.fromList colPairs) onDelete onUpdate)
(dbAnnotatedConstraints tbl)
}
)
e
)
)
foreignKeyOn ::
Beam.Beamable tbl' =>
DatabaseEntity be db (TableEntity tbl') ->
[ForeignKeyConstraint tbl tbl'] ->
ReferenceAction ->
ReferenceAction ->
EntityModification (AnnotatedDatabaseEntity be db) be (TableEntity tbl)
foreignKeyOn externalEntity us onDelete onUpdate =
EntityModification
( Endo
( \(AnnotatedDatabaseEntity tbl@(AnnotatedDatabaseTable {}) e) ->
AnnotatedDatabaseEntity
( tbl
{ dbAnnotatedConstraints =
let colPairs =
concatMap
( \case
(References ours theirs) ->
zipWith
(,)
(fieldAsColumnNames (ours (tableSettings e)))
[ColumnName (theirs (tableSettings externalEntity) ^. Beam.fieldName)]
)
us
tName = externalEntity ^. dbEntityDescriptor . dbEntityName
conname = T.intercalate "_" (tName : map (columnName . snd) colPairs) <> "_fkey"
in S.insert
(ForeignKey conname (TableName tName) (S.fromList colPairs) onDelete onUpdate)
(dbAnnotatedConstraints tbl)
}
)
e
)
)