{-# LANGUAGE RecordWildCards, TemplateHaskell, QuasiQuotes, CPP, OverloadedStrings, FlexibleContexts #-}
-- | A library for creating datatypes and Groundhog mappings from a database schema. The mappings match the database structure
-- so if you run migration for the generated mappings, no changes to schema should be suggested.
-- The generated Haskell identifiers may sometimes conflict with each other and with Haskell keywords. If that happens, adjust 'ReverseNamingStyle'.
module Database.Groundhog.Inspector
(
-- * Mapping essentials
collectTables
, ReverseNamingStyle(..)
, defaultReverseNamingStyle
, followReferencedTables
-- * Creating Haskell datatypes
, DataCodegenConfig(..)
, defaultDataCodegenConfig
, generateData
, showData
, defaultMkType
, sqliteMkType
-- * Creating mapping settings
, generateMapping
, minimizeMapping
, showMappings
) where
import Database.Groundhog.Core
import Database.Groundhog.Generic (haveSameElems, findOne, getDefaultAutoKeyType)
import Database.Groundhog.Generic.Migration
import Database.Groundhog.TH (NamingStyle, firstChar, mkTHEntityDef)
import Database.Groundhog.TH.Settings
import Control.Applicative
import Control.Arrow (left)
import Control.Monad (liftM2, mfilter)
import Data.Aeson.Encode.Pretty
import Data.Char (isAlphaNum, toLower, toUpper)
import Data.Either (lefts)
import qualified Data.Foldable as Fold
import Data.Function (on)
import Data.List (groupBy, elemIndex, isInfixOf, sort, sortBy)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, mapMaybe)
import Data.Monoid
import qualified Data.Traversable as Traversable
import Language.Haskell.TH
#if MIN_VERSION_base(4, 7, 0)
import Data.Bits (finiteBitSize)
#else
import Data.Bits (bitSize)
#endif
import Data.ByteString.Lazy (ByteString)
import Data.Int (Int32, Int64)
import Data.Time (Day, TimeOfDay, UTCTime)
import Data.Time.LocalTime (ZonedTime)
import Data.Generics
import Text.Regex
-- | Confuguration datatype generation
data DataCodegenConfig = DataCodegenConfig {
-- | The unique key phantoms can be generated by groundhog-inspector when creating mappings or by groundhog-th when processing mappings.
-- Set this to False in case you have declaration collisions. They may happen if the mappings are passed to groundhog-th on the fly.
generateUniqueKeysPhantoms :: Bool
-- | Creates a Haskell type. Typically this function analyzes column nullability and its DB type
, mkType :: Column -> Type
}
defaultDataCodegenConfig :: DataCodegenConfig
defaultDataCodegenConfig = DataCodegenConfig
True
defaultMkType
-- | It supplies the names for the haskell datatypes
data ReverseNamingStyle = ReverseNamingStyle {
-- | Create name of the datatype. Parameters: table name.
mkEntityName :: QualifiedName -> String
-- | Create name of the constructor. Parameters: table name.
, mkConstructorName :: QualifiedName -> String
-- | Create name of the field. Parameters: table name, column name.
, mkFieldName :: QualifiedName -> String -> String
-- | Create name for unique key field. It creates record name both for one-column and composite keys. Parameters: table name, reference.
, mkKeyFieldName :: QualifiedName -> Reference -> String
-- | There can be several uniques with the same columns (one primary key and multiple constraints and indexes).
-- The function must return a stable name regardless of the list order.
, mkChooseReferencedUnique :: QualifiedName -> [UniqueDefInfo] -> UniqueDefInfo
-- | Create name for phantom unique key used to parametrise 'Key'. Parameters: table name, unique key definition.
, mkUniqueKeyPhantomName :: QualifiedName -> UniqueDefInfo -> String
-- | Create name of unique in mapping. Parameters: table name, unique number, unique key definition.
, mkUniqueName :: QualifiedName -> Int -> UniqueDefInfo -> String
}
-- | It uses Sqlite type affinity to find the corresponding Haskell type
sqliteMkType :: Column -> Type
sqliteMkType c = typ' where
typ' = if colNull c then ConT ''Maybe `AppT` typ else typ
typ = case colType c of
DbOther t -> ConT $ affinityType $ showOther t
t -> getType t
affinityType str = (case () of
_ | contains ["INT"] -> ''Int
_ | contains ["CHAR", "CLOB", "TEXT"] -> ''String
_ | contains ["BLOB"] || null str -> ''ByteString
_ | contains ["REAL", "FLOA", "DOUB"] -> ''Double
_ -> ''ByteString) where
contains = any (`isInfixOf` map toUpper str)
showOther :: OtherTypeDef -> String
showOther (OtherTypeDef ts) = concatMap (either id (error "showOther: OtherTypeDef returned from database analysis contains DbTypePrimitive")) ts
defaultMkType :: Column -> Type
defaultMkType c = typ' where
typ' = if colNull c then ConT ''Maybe `AppT` typ else typ
typ = getType $ colType c
getType :: DbTypePrimitive -> Type
getType typ = ConT $ getType' typ where
getType' t = case t of
DbString -> ''String
DbInt32 -> if intSize == 32 then ''Int else ''Int32
DbInt64 -> if intSize == 64 then ''Int else ''Int64
DbReal -> ''Double
DbBool -> ''Bool
DbDay -> ''Day
DbTime -> ''TimeOfDay
DbDayTime -> ''UTCTime
DbDayTimeZoned -> ''ZonedTime
DbBlob -> ''ByteString
DbOther _ -> ''ByteString
intSize = finiteBitSize (0 :: Int)
#if !MIN_VERSION_base(4, 7, 0)
finiteBitSize = bitSize
#endif
defaultReverseNamingStyle :: ReverseNamingStyle
defaultReverseNamingStyle = ReverseNamingStyle {
mkEntityName = \(_, tName) -> firstUpper tName
, mkConstructorName = \(_, tName) -> firstUpper tName
, mkFieldName = \(_, tName) col -> firstLower tName ++ firstUpper col
, mkKeyFieldName = \(_, tName) ref -> firstLower tName ++ case map fst $ referencedColumns ref of
[childCol] -> firstUpper childCol
refCols -> firstUpper $ concat refCols
, mkChooseReferencedUnique = \tName uniqs -> let
uniqs' = sortBy (compare `on` uniqueDefName) uniqs
isPrimary x = case x of
UniquePrimary _ -> True
_ -> False
-- try primary key, then constraints, then indexes
filterUnique f = filter (f . uniqueDefType)
uniq = case filterUnique isPrimary uniqs' ++ filterUnique (== UniqueConstraint) uniqs' ++ filterUnique (== UniqueIndex) uniqs' of
[] -> error $ "mkChooseReferencedUnique: " ++ show tName ++ " uniques list must be not empty"
(u:_) -> u
in uniq
, mkUniqueKeyPhantomName = \(_, tName) uniq -> let
-- table cannot reference an expression index
name' = filter' tName ++ concatMap firstUpper (lefts $ uniqueDefFields uniq)
in firstUpper $ fromMaybe name' $ uniqueDefName uniq
, mkUniqueName = \(_, tName) uNum uniq -> let
name' = filter' tName ++ concatMap firstUpper (lefts $ uniqueDefFields uniq) ++ show uNum
in fromMaybe name' $ uniqueDefName uniq
} where
filter' = filter (\c -> isAlphaNum c || c == '_')
firstLower = firstChar toLower . filter'
firstUpper = firstChar toUpper . filter'
-- | It looks for the references to the tables not contained in the passed map.
-- If there are such references and the reference filter function returns True, the corresponding TableInfo is fetched and included into the map.
-- The references for the newly added tables are processed in the same way. This function can be useful if your set of tables is created not by 'collectTables'.
followReferencedTables :: (PersistBackend m, SchemaAnalyzer (Conn m))
=> (QualifiedName -> Bool) -- ^ Decides if we follow reference to this table. It can be used to prevent mapping of the referenced audit or system tables
-> Map QualifiedName TableInfo
-> m (Map QualifiedName TableInfo)
followReferencedTables p = go mempty where
getDirectMissingReferences checkedTables currentTables = do
let getRefs = Set.fromList . map (referencedTableName . snd) . tableReferences
allReferences = Fold.foldr ((<>) . getRefs) mempty currentTables
isMissing ref = p ref && ref `Map.notMember` checkedTables && ref `Map.notMember` currentTables
missingReferences = Set.filter isMissing allReferences
Fold.foldlM (\acc ref -> do
x <- analyzeTable ref
case x of
Nothing -> fail $ "Reference to " ++ show ref ++ "not found"
Just x' -> return $ Map.insert ref x' acc) mempty missingReferences
go checkedTables currentTables | Map.null currentTables = return checkedTables
go checkedTables currentTables = do
newTables <- getDirectMissingReferences checkedTables currentTables
go (checkedTables <> currentTables) newTables
-- | Returns tables from a passed schema and tables which they reference.
-- If you call collectTables several times with different filtering functions,
-- it is better to call 'followReferencedTables' afterwards manually to ensure that no dependencies are missing
--
-- > let filterRefs (schema, tableName) = schema /= "audit"
-- > publicTables <- collectTables filterRefs (Just "public")
-- > websiteTables <- collectTables filterRefs (Just "website")
-- > let allTables = publicTables <> websiteTables
collectTables :: (PersistBackend m, SchemaAnalyzer (Conn m))
=> (QualifiedName -> Bool) -- ^ Decides if we follow the reference to a table. It can be used to prevent mapping of the referenced audit or system tables
-> Maybe String -- ^ Schema name
-> m (Map QualifiedName TableInfo)
collectTables p schema = do
sch <- liftM2 (<|>) (pure schema) getCurrentSchema
tables <- filter p . map (\t -> (sch, t)) <$> listTables sch
let analyzeTable' ref = do
x <- analyzeTable ref
case x of
Nothing -> error $ "Reference to " ++ show ref ++ "not found"
Just x' -> return x'
analyzedTables <- Traversable.mapM analyzeTable' $ Map.fromList $ zip tables tables
followReferencedTables p analyzedTables
-- | Returns declarations for the mapped datatype and auxiliary declarations like unique key phantom datatypes
generateData :: DataCodegenConfig -> ReverseNamingStyle
-> Map QualifiedName TableInfo -- ^ Tables for which the mappings will be generated
-> Map QualifiedName (Dec, [Dec])
generateData config style tables = Map.mapWithKey (generateData' config style tables) tables
generateData' :: DataCodegenConfig -> ReverseNamingStyle
-> Map QualifiedName TableInfo
-> QualifiedName -> TableInfo -> (Dec, [Dec])
generateData' DataCodegenConfig{..} ReverseNamingStyle{..} tables tName tInfo = decs where
decs = (dataD' [] (mkName $ mkEntityName tName) [] [constr] [], uniquePhantoms)
constr = RecC (mkName $ mkConstructorName tName) fields
-- if a set of columns is referenced, do nothing. If we have a reference to a mapped table, collect all columns and create Key. If reference is to a not mapped table, do nothing
-- Drop autogenerated id
idColumns = (filter ((== UniquePrimary True) . uniqueDefType) $ tableUniques tInfo) >>= uniqueDefFields
-- returns parent name and list of columns for references to mapped datatypes
getReference c = result where
-- list of references which include this column
refs = filter ((c `elem`) . map fst . referencedColumns) $ map snd $ tableReferences tInfo
result = case refs of
[] -> Nothing
[ref] -> Just ref
refs' -> error $ "Column " ++ c ++ " in table " ++ show tName ++ " participates in multiple references: " ++ show refs'
refUniqueMatch ref u = haveSameElems (==) (map (Left . snd) $ referencedColumns ref) $ uniqueDefFields u
getReferencedUnique parentName parentInfo ref = mkChooseReferencedUnique parentName uniqs where
uniqs = filter (refUniqueMatch ref) $ tableUniques parentInfo
isReferenced u = Fold.any getRefs tables where
compareRef ref = referencedTableName ref == tName && refUniqueMatch ref u
getRefs = any (compareRef . snd) . tableReferences
uniquePhantoms = if generateUniqueKeysPhantoms then map mkPhantom uniqueKeys else [] where
entity = ConT $ mkName $ mkEntityName tName
mkPhantom u = dataD' [] name [PlainTV v] [c] [] where
v = mkName "v"
name = mkName $ mkUniqueKeyPhantomName tName u
phantom = ConT ''UniqueMarker `AppT` entity
c = ForallC [] [equalP' (VarT v) phantom] $ NormalC name []
uniqueKeys = filter isReferenced
$ map (mkChooseReferencedUnique tName)
$ groupBy ((==) `on` sort . uniqueDefFields) uniqueDefs
uniqueDefs = sortBy (compare `on` \u -> (sort $ uniqueDefFields u, uniqueDefType u, uniqueDefName u))
$ filter ((/= UniquePrimary True) . uniqueDefType)
$ tableUniques tInfo
fields = go mappedColumns where
mappedColumns = filter ((`notElem` idColumns) . Left . colName) $ tableColumns tInfo
go [] = []
go (c:cs) = case getReference $ colName c of
Just ref -> (case Map.lookup parentName tables of
Just parentInfo ->
(mkName $ mkKeyFieldName tName ref, notStrict', mkKeyType parentInfo)
Nothing ->
(mkName $ mkKeyFieldName tName ref, notStrict', notMappedRefType)
):go (filter (`notElem` childCols) cs) where
parentName = referencedTableName ref
getCols info cols = map (\cName -> findOne "column" colName cName $ tableColumns info) cols
childCols = getCols tInfo $ map fst $ referencedColumns ref
notMappedRefType = case childCols of
[col] -> mkType col
_ -> foldl AppT (TupleT (length childCols)) $ map mkType childCols
mkKeyType parentInfo = typ' where
entity = ConT $ mkName $ mkEntityName parentName
uniq = getReferencedUnique parentName parentInfo ref
typ = if uniqueDefType uniq == UniquePrimary True
then ConT ''AutoKey `AppT` entity
else ConT ''Key `AppT` entity `AppT` (ConT ''Unique `AppT` (ConT $ mkName $ mkUniqueKeyPhantomName parentName uniq))
typ' = case () of
_ | map colNull childCols == map colNull parentCols -> typ
_ | map colNull childCols == [True] -> ConT ''Maybe `AppT` typ -- wrap non-composite keys in Maybe
_ -> notMappedRefType
parentCols = getCols parentInfo $ map snd $ referencedColumns ref
Nothing -> (mkName $ mkFieldName tName $ colName c, notStrict', mkType c):go cs
equalP' :: Type -> Type -> Pred
equalP' t1 t2 =
#if MIN_VERSION_template_haskell(2, 10, 0)
foldl AppT EqualityT [t1, t2]
#else
EqualP t1 t2
#endif
generateMapping :: (PersistBackend m, SchemaAnalyzer (Conn m)) => ReverseNamingStyle -> Map QualifiedName TableInfo -> m (Map QualifiedName PSEntityDef)
generateMapping style tables = do
m <- getMigrationPack
return $ generateMappingPure style m tables
generateMappingPure :: DbDescriptor conn => ReverseNamingStyle -> MigrationPack conn -> Map QualifiedName TableInfo -> Map QualifiedName PSEntityDef
generateMappingPure style m tables = Map.mapWithKey (generateMapping' style m tables) tables
generateMapping' :: DbDescriptor conn => ReverseNamingStyle -> MigrationPack conn -> Map QualifiedName TableInfo -> QualifiedName -> TableInfo -> PSEntityDef
generateMapping' ReverseNamingStyle{..} m@MigrationPack{..} tables tName tInfo = entity where
entity = PSEntityDef (mkEntityName tName) (Just $ snd tName) (fst tName) autoKey (Just uniqueKeyDefs) (Just [constr])
idColumns = (filter ((== UniquePrimary True) . uniqueDefType) $ tableUniques tInfo) >>= uniqueDefFields
-- returns parent name and list of columns for references to mapped datatypes
getReference c = result where
-- list of references which include this column
refs = filter ((c `elem`) . map fst . referencedColumns) $ map snd $ tableReferences tInfo
result = case refs of
[] -> Nothing
[ref] -> Just ref
refs' -> error $ "Column " ++ c ++ " in table " ++ show tName ++ " participates in multiple references: " ++ show refs'
(autoKey, autoKeyName) = case idColumns of
[] -> (Just Nothing, Nothing)
[Left name] -> (Nothing, Just name)
_ -> error $ "More than one autoincremented column for " ++ show tName ++ ": " ++ show idColumns
refUniqueMatch ref u = haveSameElems (==) (map (Left . snd) $ referencedColumns ref) $ uniqueDefFields u
getReferencedUnique parentName parentInfo ref = mkChooseReferencedUnique parentName uniqs where
uniqs = filter (refUniqueMatch ref) $ tableUniques parentInfo
isReferenced u = Fold.any getRefs tables where
compareRef ref = referencedTableName ref == tName && refUniqueMatch ref u
getRefs = any (compareRef . snd) . tableReferences
uniqueKeyDefs = map mkUniqueKeyDef uniqueKeys where
mkUniqueKeyDef u = PSUniqueKeyDef (mkUniqueName tName (fromJust $ elemIndex u uniqueDefs) u) Nothing Nothing Nothing Nothing Nothing (isDef u)
-- choose a default unique key if there is no autoincremented key
defaultUnique = mkChooseReferencedUnique tName uniqueKeys
isDef u = case autoKey of
Just Nothing | u == defaultUnique -> Just True
_ -> Nothing
-- create keys from uniques only if there are references to them. Autoincremented key is processed separately, so we ignore it.
uniqueKeys = filter isReferenced
$ map (mkChooseReferencedUnique tName)
$ groupBy ((==) `on` sort . uniqueDefFields) uniqueDefs
uniqueDefs = sortBy (compare `on` \u -> (sort $ uniqueDefFields u, uniqueDefType u, uniqueDefName u))
$ filter ((/= UniquePrimary True) . uniqueDefType)
$ tableUniques tInfo
uniques = zipWith (\uNum u -> PSUniqueDef (mkUniqueName tName uNum u) (Just $ uniqueDefType u) (map (left $ mkFieldName tName) $ uniqueDefFields u)) [0..] uniqueDefs
constr = PSConstructorDef (mkConstructorName tName) Nothing Nothing autoKeyName (Just fields) (Just uniques)
fields = go mappedColumns where
mappedColumns = filter ((`notElem` idColumns) . Left . colName) $ tableColumns tInfo
go [] = []
go (c:cs) = case getReference $ colName c of
Just ref -> (case Map.lookup parentName tables of
Just parentInfo -> let
uniq = getReferencedUnique parentName parentInfo ref
parentCols = getCols parentInfo $ map snd $ referencedColumns ref
in if uniqueDefType uniq == UniquePrimary True
then autoKeyRef
-- if nulls don't match, a record will have a tuple or a primitive datatype instead of Key.
else if map colNull childCols == map colNull parentCols || map colNull childCols == [True]
then mappedEmbeddedRef parentCols
else if length childCols == 1 then notMappedRef else notMappedEmbeddedRef
Nothing -> if length childCols == 1 then notMappedRef else notMappedEmbeddedRef
):go (filter (`notElem` childCols) cs) where
parentName = referencedTableName ref
notMappedRef = PSFieldDef (mkKeyFieldName tName ref) (Just $ colName c) (case colType c of DbOther t -> Just $ showOther t; _ -> Nothing) Nothing Nothing (colDefault c) (Just (Just (referencedTableName ref, map snd $ referencedColumns ref), refOnDelete, refOnUpdate)) Nothing
notMappedEmbeddedRef = PSFieldDef (mkKeyFieldName tName ref) Nothing Nothing Nothing (Just embeddeds) Nothing (Just (Just (referencedTableName ref, map snd $ referencedColumns ref), refOnDelete, refOnUpdate)) Nothing where
embeddeds = zipWith (\c1 i -> PSFieldDef ("val" ++ show i) (Just $ colName c1) (case colType c1 of DbOther t -> Just $ showOther t; _ -> Nothing) Nothing Nothing (colDefault c1) Nothing Nothing) childCols [0 :: Int ..]
mappedEmbeddedRef parentCols = PSFieldDef (mkKeyFieldName tName ref) Nothing Nothing Nothing (Just embeddeds) Nothing (Just (Nothing, refOnDelete, refOnUpdate)) Nothing where
embeddeds = zipWith (\c1 c2 -> PSFieldDef (colName c2) (Just $ colName c1) (showSqlType <$> mfilter (/= colType c2) (Just $ colType c1)) Nothing Nothing (colDefault c1) Nothing Nothing) childCols parentCols
autoKeyRef = PSFieldDef (mkKeyFieldName tName ref) (Just $ colName c) (showSqlType <$> mfilter (/= autoKeyType) (Just $ colType c)) Nothing Nothing (colDefault c) (Just (Nothing, refOnDelete, refOnUpdate)) Nothing where
autoKeyType = getDefaultAutoKeyType $ (undefined :: MigrationPack conn -> p conn) m
refOnDelete = mfilter (/= defaultReferenceOnDelete) $ referenceOnDelete ref
refOnUpdate = mfilter (/= defaultReferenceOnUpdate) $ referenceOnUpdate ref
getCols info cols = map (\cName -> findOne "column" colName cName $ tableColumns info) cols
childCols = getCols tInfo $ map fst $ referencedColumns ref
Nothing -> PSFieldDef (mkFieldName tName $ colName c) (Just $ colName c) (case colType c of DbOther t -> Just $ showOther t; _ -> Nothing) Nothing Nothing (colDefault c) Nothing Nothing:go cs
subtractSame :: THEntityDef -> PSEntityDef -> PSEntityDef
subtractSame = subtractEntity where
subtractEntity THEntityDef{..} def@PSEntityDef{..} = def {
psDbEntityName = psDbEntityName ?= thDbEntityName
, psConstructors = fmap (catMaybes . zipWith subtractConstructor thConstructors) psConstructors ?= []
}
subtractConstructor THConstructorDef{..} def = mfilter notEmpty $ Just def {
psDbConstrName = psDbConstrName def ?= thDbConstrName
, psDbAutoKeyName = psDbAutoKeyName def ?=? thDbAutoKeyName
, psConstrFields = fmap (mapMaybe $ \f -> subtractField (findOne "field" thFieldName (psFieldName f) thConstrFields) f) (psConstrFields def) ?= []
, psConstrUniques = psConstrUniques def ?= []
} where
notEmpty PSConstructorDef{..} = isJust psDbConstrName || isJust psDbAutoKeyName || isJust psConstrFields || isJust psConstrUniques
subtractField THFieldDef{..} def = mfilter notEmpty $ Just def {
psDbFieldName = psDbFieldName def ?= thDbFieldName
, psDbTypeName = psDbTypeName def ?=? thDbTypeName
, psDefaultValue = psDefaultValue def ?=? thDefaultValue
} where
notEmpty PSFieldDef{..} = isJust psDbFieldName || isJust psDbTypeName || isJust psEmbeddedDef || isJust psDefaultValue || isJust psReferenceParent
a ?= b = mfilter (/= b) a
a ?=? b = mfilter (const $ a /= b) a
-- | The mappings created by 'generateMapping' contain a lot of setttings. This function makes the settings more compact by eliminating settings
-- which are default for the passed 'NamingStyle'.
minimizeMapping :: NamingStyle -> Dec -> PSEntityDef -> PSEntityDef
minimizeMapping style dec settings = subtractSame (mkTHEntityDef style dec) settings
-- | It pretty-prints Template Haskell declaration into compilable Haskell code
showData :: Dec -> String
showData = removeForalls . pprint . removeModules where
removeForalls s = subRegex (mkRegex "\\bforall\\s*\\.\\s*") s ""
removeModules = everywhere (mkT $ \name -> mkName $ nameBase name)
-- | It pretty-prints the mapping settings as JSON. Package groundhog-th accepts JSON and YAML which is a more human-readable superset of JSON.
-- You can use a third-party tool to convert JSON to YAML.
showMappings :: [PSEntityDef] -> ByteString
showMappings = encodePretty' config where
config = Config { confIndent = Spaces 4, confCompare = keyOrder keys }
keys = ["entity", "name", "dbName", "schema", "autoKey", "keyDbName", "type", "embeddedType", "columns", "keys", "fields", "uniques"]
dataD' :: Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> InstanceDec
dataD' cxt name types constrs derives =
#if MIN_VERSION_template_haskell(2, 11, 0)
DataD cxt name types Nothing constrs (map ConT derives)
#else
DataD cxt name types constrs derives
#endif
#if MIN_VERSION_template_haskell(2, 11, 0)
notStrict' :: Bang
notStrict' = Bang NoSourceUnpackedness NoSourceStrictness
#else
notStrict' :: Strict
notStrict' = NotStrict
#endif