persistent-2.18.1.0: Database/Persist/Sql/Internal.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}

-- | Intended for creating new backends.
module Database.Persist.Sql.Internal
    ( mkColumns
    , defaultAttribute
    , BackendSpecificOverrides (..)
    , getBackendSpecificForeignKeyName
    , setBackendSpecificForeignKeyName
    , getBackendSpecificForeignKeyCascadeDefault
    , setBackendSpecificForeignKeyCascadeDefault
    , emptyBackendSpecificOverrides
    ) where

import Control.Applicative ((<|>))
import Data.Monoid (mappend, mconcat)
import Data.Text (Text)
import qualified Data.Text as T

import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Database.Persist.EntityDef
import Database.Persist.Sql.Types
import Database.Persist.Types

-- | Record of functions to override the default behavior in 'mkColumns'.  It is
-- recommended you initialize this with 'emptyBackendSpecificOverrides' and
-- override the default values, so that as new fields are added, your code still
-- compiles.
--
-- For added safety, use the @getBackendSpecific*@ and @setBackendSpecific*@
-- functions, as a breaking change to the record field labels won't be reflected
-- in a major version bump of the library.
--
-- @since 2.11
data BackendSpecificOverrides = BackendSpecificOverrides
    { backendSpecificForeignKeyName
        :: Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
    , backendSpecificForeignKeyCascadeDefault :: CascadeAction
    }

-- | If the override is defined, then this returns a function that accepts an
-- entity name and field name and provides the 'ConstraintNameDB' for the
-- foreign key constraint.
--
-- An abstract accessor for the 'BackendSpecificOverrides'
--
-- @since 2.13.0.0
getBackendSpecificForeignKeyName
    :: BackendSpecificOverrides
    -> Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
getBackendSpecificForeignKeyName =
    backendSpecificForeignKeyName

-- | Set the backend's foreign key generation function to this value.
--
-- @since 2.13.0.0
setBackendSpecificForeignKeyName
    :: (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
    -> BackendSpecificOverrides
    -> BackendSpecificOverrides
setBackendSpecificForeignKeyName func bso =
    bso{backendSpecificForeignKeyName = Just func}

-- | If the override is defined, then this specifies what cascade action
-- should be used if there is none defined for the column.
--
-- @since 2.18.1.0
getBackendSpecificForeignKeyCascadeDefault
    :: BackendSpecificOverrides
    -> CascadeAction
getBackendSpecificForeignKeyCascadeDefault =
    backendSpecificForeignKeyCascadeDefault

-- | Set the backend's default cascade action.
--
-- @since 2.18.1.0
setBackendSpecificForeignKeyCascadeDefault
    :: CascadeAction
    -> BackendSpecificOverrides
    -> BackendSpecificOverrides
setBackendSpecificForeignKeyCascadeDefault action bso =
    bso{backendSpecificForeignKeyCascadeDefault = action}

findMaybe :: (a -> Maybe b) -> [a] -> Maybe b
findMaybe p = listToMaybe . mapMaybe p

-- | Creates an empty 'BackendSpecificOverrides' (i.e. use the default behavior; no overrides)
--
-- @since 2.11
emptyBackendSpecificOverrides :: BackendSpecificOverrides
emptyBackendSpecificOverrides = BackendSpecificOverrides Nothing Restrict

defaultAttribute :: [FieldAttr] -> Maybe Text
defaultAttribute = findMaybe $ \case
    FieldAttrDefault x -> Just x
    _ -> Nothing

-- | Create the list of columns for the given entity.
mkColumns
    :: [EntityDef]
    -> EntityDef
    -> BackendSpecificOverrides
    -> ([Column], [UniqueDef], [ForeignDef])
mkColumns allDefs t overrides =
    (cols, getEntityUniquesNoPrimaryKey t, getEntityForeignDefs t)
  where
    cols :: [Column]
    cols = map goId idCol `mappend` map go (getEntityFieldsDatabase t)

    idCol :: [FieldDef]
    idCol =
        case getEntityId t of
            EntityIdNaturalKey _ ->
                []
            EntityIdField fd ->
                [fd]

    goId :: FieldDef -> Column
    goId fd =
        Column
            { cName = fieldDB fd
            , cNull = False
            , cSqlType = fieldSqlType fd
            , cDefault =
                case defaultAttribute $ fieldAttrs fd of
                    Nothing ->
                        -- So this is not necessarily a problem...
                        -- because you can use eg `inserKey` to insert
                        -- a value into the database without ever asking
                        -- for a default attribute.
                        Nothing
                    -- But we need to be able to say "Hey, if this is
                    -- an *auto generated ID column*, then I need to
                    -- specify that it has the default serial picking
                    -- behavior for whatever SQL backend this is using.
                    -- Because naturally MySQL, Postgres, MSSQL, etc
                    -- all do ths differently, sigh.
                    -- Really, this should be something like,
                    --
                    -- > data ColumnDefault
                    -- >     = Custom Text
                    -- >     | AutogenerateId
                    -- >     | NoDefault
                    --
                    -- where Autogenerated is determined by the
                    -- MkPersistSettings.
                    Just def ->
                        Just def
            , cGenerated = fieldGenerated fd
            , cDefaultConstraintName = Nothing
            , cMaxLen = maxLen $ fieldAttrs fd
            , cReference = mkColumnReference fd
            }

    tableName :: EntityNameDB
    tableName = getEntityDBName t

    go :: FieldDef -> Column
    go fd =
        Column
            { cName = fieldDB fd
            , cNull =
                case isFieldNullable fd of
                    Nullable _ -> True
                    NotNullable -> isFieldMaybe fd || isEntitySum t
            , cSqlType = fieldSqlType fd
            , cDefault = defaultAttribute $ fieldAttrs fd
            , cGenerated = fieldGenerated fd
            , cDefaultConstraintName = Nothing
            , cMaxLen = maxLen $ fieldAttrs fd
            , cReference = mkColumnReference fd
            }

    maxLen :: [FieldAttr] -> Maybe Integer
    maxLen = findMaybe $ \case
        FieldAttrMaxlen n -> Just n
        _ -> Nothing

    refNameFn = fromMaybe refName (backendSpecificForeignKeyName overrides)

    mkColumnReference :: FieldDef -> Maybe ColumnReference
    mkColumnReference fd =
        fmap
            ( \(tName, cName) ->
                ColumnReference tName cName $ overrideNothings $ fieldCascade fd
            )
            $ ref (fieldDB fd) (fieldReference fd) (fieldAttrs fd)

    -- a 'Nothing' in the definition means that the QQ migration doesn't
    -- specify behavior. the default is RESTRICT. setting this here
    -- explicitly makes migrations run smoother.
    overrideNothings (FieldCascade{fcOnUpdate = upd, fcOnDelete = del}) =
        FieldCascade
            { fcOnUpdate = upd <|> Just defaultAction
            , fcOnDelete = del <|> Just defaultAction
            }
      where
        defaultAction = (backendSpecificForeignKeyCascadeDefault overrides)

    ref
        :: FieldNameDB
        -> ReferenceDef
        -> [FieldAttr]
        -> Maybe (EntityNameDB, ConstraintNameDB) -- table name, constraint name
    ref c fe []
        | ForeignRef f <- fe =
            Just (resolveTableName allDefs f, refNameFn tableName c)
        | otherwise = Nothing
    ref _ _ (FieldAttrNoreference : _) = Nothing
    ref c fe (a : as) = case a of
        FieldAttrReference x -> do
            (_, constraintName) <- ref c fe as
            pure (EntityNameDB x, constraintName)
        FieldAttrConstraint x -> do
            (tableName_, _) <- ref c fe as
            pure (tableName_, ConstraintNameDB x)
        _ -> ref c fe as

refName :: EntityNameDB -> FieldNameDB -> ConstraintNameDB
refName (EntityNameDB table) (FieldNameDB column) =
    ConstraintNameDB $ Data.Monoid.mconcat [table, "_", column, "_fkey"]

resolveTableName :: [EntityDef] -> EntityNameHS -> EntityNameDB
resolveTableName [] (EntityNameHS t) = error $ "Table not found: " `Data.Monoid.mappend` T.unpack t
resolveTableName (e : es) hn
    | getEntityHaskellName e == hn = getEntityDBName e
    | otherwise = resolveTableName es hn