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

-- | Intended for creating new backends.
module Database.Persist.Sql.Internal
    ( mkColumns
    , defaultAttribute
    , BackendSpecificOverrides(..)
    , getBackendSpecificForeignKeyName
    , setBackendSpecificForeignKeyName
    , 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
    { BackendSpecificOverrides
-> Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
backendSpecificForeignKeyName :: Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
    }

-- | 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 :: BackendSpecificOverrides
-> Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
getBackendSpecificForeignKeyName =
    BackendSpecificOverrides
-> Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
backendSpecificForeignKeyName

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

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

-- | Creates an empty 'BackendSpecificOverrides' (i.e. use the default behavior; no overrides)
--
-- @since 2.11
emptyBackendSpecificOverrides :: BackendSpecificOverrides
emptyBackendSpecificOverrides :: BackendSpecificOverrides
emptyBackendSpecificOverrides = Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
-> BackendSpecificOverrides
BackendSpecificOverrides Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
forall a. Maybe a
Nothing

defaultAttribute :: [FieldAttr] -> Maybe Text
defaultAttribute :: [FieldAttr] -> Maybe Text
defaultAttribute = (FieldAttr -> Maybe Text) -> [FieldAttr] -> Maybe Text
forall a b. (a -> Maybe b) -> [a] -> Maybe b
findMaybe ((FieldAttr -> Maybe Text) -> [FieldAttr] -> Maybe Text)
-> (FieldAttr -> Maybe Text) -> [FieldAttr] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ \case
    FieldAttrDefault Text
x -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x
    FieldAttr
_ -> Maybe Text
forall a. Maybe a
Nothing

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

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

    goId :: FieldDef -> Column
    goId :: FieldDef -> Column
goId FieldDef
fd =
        Column
            { cName :: FieldNameDB
cName = FieldDef -> FieldNameDB
fieldDB FieldDef
fd
            , cNull :: Bool
cNull = Bool
False
            , cSqlType :: SqlType
cSqlType = FieldDef -> SqlType
fieldSqlType FieldDef
fd
            , cDefault :: Maybe Text
cDefault =
                case [FieldAttr] -> Maybe Text
defaultAttribute ([FieldAttr] -> Maybe Text) -> [FieldAttr] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ FieldDef -> [FieldAttr]
fieldAttrs FieldDef
fd of
                    Maybe Text
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.
                        Maybe Text
forall a. Maybe a
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 Text
def ->
                        Text -> Maybe Text
forall a. a -> Maybe a
Just Text
def

            , cGenerated :: Maybe Text
cGenerated = FieldDef -> Maybe Text
fieldGenerated FieldDef
fd
            , cDefaultConstraintName :: Maybe ConstraintNameDB
cDefaultConstraintName =  Maybe ConstraintNameDB
forall a. Maybe a
Nothing
            , cMaxLen :: Maybe Integer
cMaxLen = [FieldAttr] -> Maybe Integer
maxLen ([FieldAttr] -> Maybe Integer) -> [FieldAttr] -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ FieldDef -> [FieldAttr]
fieldAttrs FieldDef
fd
            , cReference :: Maybe ColumnReference
cReference = FieldDef -> Maybe ColumnReference
mkColumnReference FieldDef
fd
            }

    tableName :: EntityNameDB
    tableName :: EntityNameDB
tableName = EntityDef -> EntityNameDB
getEntityDBName EntityDef
t

    go :: FieldDef -> Column
    go :: FieldDef -> Column
go FieldDef
fd =
        Column
            { cName :: FieldNameDB
cName = FieldDef -> FieldNameDB
fieldDB FieldDef
fd
            , cNull :: Bool
cNull =
                case FieldDef -> IsNullable
isFieldNullable FieldDef
fd of
                    Nullable WhyNullable
_ -> Bool
True
                    IsNullable
NotNullable -> FieldDef -> Bool
isFieldMaybe FieldDef
fd Bool -> Bool -> Bool
|| EntityDef -> Bool
isEntitySum EntityDef
t
            , cSqlType :: SqlType
cSqlType = FieldDef -> SqlType
fieldSqlType FieldDef
fd
            , cDefault :: Maybe Text
cDefault = [FieldAttr] -> Maybe Text
defaultAttribute ([FieldAttr] -> Maybe Text) -> [FieldAttr] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ FieldDef -> [FieldAttr]
fieldAttrs FieldDef
fd
            , cGenerated :: Maybe Text
cGenerated = FieldDef -> Maybe Text
fieldGenerated FieldDef
fd
            , cDefaultConstraintName :: Maybe ConstraintNameDB
cDefaultConstraintName =  Maybe ConstraintNameDB
forall a. Maybe a
Nothing
            , cMaxLen :: Maybe Integer
cMaxLen = [FieldAttr] -> Maybe Integer
maxLen ([FieldAttr] -> Maybe Integer) -> [FieldAttr] -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ FieldDef -> [FieldAttr]
fieldAttrs FieldDef
fd
            , cReference :: Maybe ColumnReference
cReference = FieldDef -> Maybe ColumnReference
mkColumnReference FieldDef
fd
            }

    maxLen :: [FieldAttr] -> Maybe Integer
    maxLen :: [FieldAttr] -> Maybe Integer
maxLen = (FieldAttr -> Maybe Integer) -> [FieldAttr] -> Maybe Integer
forall a b. (a -> Maybe b) -> [a] -> Maybe b
findMaybe ((FieldAttr -> Maybe Integer) -> [FieldAttr] -> Maybe Integer)
-> (FieldAttr -> Maybe Integer) -> [FieldAttr] -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ \case
        FieldAttrMaxlen Integer
n -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
n
        FieldAttr
_ -> Maybe Integer
forall a. Maybe a
Nothing

    refNameFn :: EntityNameDB -> FieldNameDB -> ConstraintNameDB
refNameFn = (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
-> Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
-> EntityNameDB
-> FieldNameDB
-> ConstraintNameDB
forall a. a -> Maybe a -> a
fromMaybe EntityNameDB -> FieldNameDB -> ConstraintNameDB
refName (BackendSpecificOverrides
-> Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
backendSpecificForeignKeyName BackendSpecificOverrides
overrides)

    mkColumnReference :: FieldDef -> Maybe ColumnReference
    mkColumnReference :: FieldDef -> Maybe ColumnReference
mkColumnReference FieldDef
fd =
        ((EntityNameDB, ConstraintNameDB) -> ColumnReference)
-> Maybe (EntityNameDB, ConstraintNameDB) -> Maybe ColumnReference
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (\(EntityNameDB
tName, ConstraintNameDB
cName) ->
                EntityNameDB -> ConstraintNameDB -> FieldCascade -> ColumnReference
ColumnReference EntityNameDB
tName ConstraintNameDB
cName (FieldCascade -> ColumnReference)
-> FieldCascade -> ColumnReference
forall a b. (a -> b) -> a -> b
$ FieldCascade -> FieldCascade
overrideNothings (FieldCascade -> FieldCascade) -> FieldCascade -> FieldCascade
forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldCascade
fieldCascade FieldDef
fd
            )
        (Maybe (EntityNameDB, ConstraintNameDB) -> Maybe ColumnReference)
-> Maybe (EntityNameDB, ConstraintNameDB) -> Maybe ColumnReference
forall a b. (a -> b) -> a -> b
$ FieldNameDB
-> ReferenceDef
-> [FieldAttr]
-> Maybe (EntityNameDB, ConstraintNameDB)
ref (FieldDef -> FieldNameDB
fieldDB FieldDef
fd) (FieldDef -> ReferenceDef
fieldReference FieldDef
fd) (FieldDef -> [FieldAttr]
fieldAttrs FieldDef
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 -> FieldCascade
overrideNothings (FieldCascade { fcOnUpdate :: FieldCascade -> Maybe CascadeAction
fcOnUpdate = Maybe CascadeAction
upd, fcOnDelete :: FieldCascade -> Maybe CascadeAction
fcOnDelete = Maybe CascadeAction
del }) =
        FieldCascade
            { fcOnUpdate :: Maybe CascadeAction
fcOnUpdate = Maybe CascadeAction
upd Maybe CascadeAction -> Maybe CascadeAction -> Maybe CascadeAction
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CascadeAction -> Maybe CascadeAction
forall a. a -> Maybe a
Just CascadeAction
Restrict
            , fcOnDelete :: Maybe CascadeAction
fcOnDelete = Maybe CascadeAction
del Maybe CascadeAction -> Maybe CascadeAction -> Maybe CascadeAction
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CascadeAction -> Maybe CascadeAction
forall a. a -> Maybe a
Just CascadeAction
Restrict
            }

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

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

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