persistent-2.11.0.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(..)
    , emptyBackendSpecificOverrides
    ) where

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

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

-- | 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.
--
-- @since 2.11
data BackendSpecificOverrides = BackendSpecificOverrides
    { backendSpecificForeignKeyName :: Maybe (DBName -> DBName -> DBName)
    }

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

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, entityUniques t, entityForeigns t)
  where
    cols :: [Column]
    cols = map goId idCol `mappend` map go (entityFields t)

    idCol :: [FieldDef]
    idCol = case entityPrimary t of
        Just _ -> []
        Nothing -> [entityId t]

    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 :: DBName
    tableName = entityDB t


    go :: FieldDef -> Column
    go fd =
        Column
            { cName = fieldDB fd
            , cNull = nullable (fieldAttrs fd) /= NotNullable || entitySum 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 Restrict
            , fcOnDelete = del <|> Just Restrict
            }

    ref :: DBName
        -> ReferenceDef
        -> [FieldAttr]
        -> Maybe (DBName, DBName) -- 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 (DBName x, constraintName)
        FieldAttrConstraint x -> do
            (tableName_, _) <- ref c fe as
            pure (tableName_, DBName x)
        _ -> ref c fe as

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

resolveTableName :: [EntityDef] -> HaskellName -> DBName
resolveTableName [] (HaskellName hn) = error $ "Table not found: " `Data.Monoid.mappend` T.unpack hn
resolveTableName (e:es) hn
    | entityHaskell e == hn = entityDB e
    | otherwise = resolveTableName es hn