Settings.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Database.Groundhog.TH.Settings
  ( PersistDefinitions (..),
    THEntityDef (..),
    THEmbeddedDef (..),
    THPrimitiveDef (..),
    THConstructorDef (..),
    THFieldDef (..),
    THUniqueDef (..),
    THUniqueKeyDef (..),
    THAutoKeyDef (..),
    PSEntityDef (..),
    PSEmbeddedDef (..),
    PSPrimitiveDef (..),
    PSConstructorDef (..),
    PSFieldDef (..),
    PSUniqueDef (..),
    PSUniqueKeyDef (..),
    PSAutoKeyDef (..),
  )
where

import Control.Applicative
import Control.Monad (forM, mzero, when)
import Data.Aeson
import Data.Aeson.Types (Pair)
import qualified Data.Foldable as Fold
import qualified Data.HashMap.Strict as H
import Data.Maybe (catMaybes)
import Data.Text (Text)
import Database.Groundhog.Core (ReferenceActionType (..), UniqueType (..))
import Database.Groundhog.Generic (PSFieldDef (..))
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Lift (..))

data PersistDefinitions = PersistDefinitions {psEntities :: [PSEntityDef], psEmbeddeds :: [PSEmbeddedDef], psPrimitives :: [PSPrimitiveDef]}
  deriving (Show, Lift)

-- data SomeData a = U1 { foo :: Int} | U2 { bar :: Maybe String, asc :: Int64, add :: a} | U3 deriving (Show, Eq)

data THEntityDef = THEntityDef
  { thDataName :: Name, -- SomeData
    thDbEntityName :: String, -- SQLSomeData
    thEntitySchema :: Maybe String,
    thAutoKey :: Maybe THAutoKeyDef,
    thUniqueKeys :: [THUniqueKeyDef],
#if MIN_VERSION_template_haskell(2, 17, 0)
    thTypeParams :: [TyVarBndr ()],
#else
    thTypeParams :: [TyVarBndr],
#endif
    thConstructors :: [THConstructorDef]
  }
  deriving (Eq, Show)

data THAutoKeyDef = THAutoKeyDef
  { thAutoKeyConstrName :: String,
    thAutoKeyIsDef :: Bool
  }
  deriving (Eq, Show)

data THEmbeddedDef = THEmbeddedDef
  { thEmbeddedName :: Name,
    thEmbeddedConstructorName :: Name,
    -- | It is used only to set polymorphic part of name of its container
    thDbEmbeddedName :: String,
#if MIN_VERSION_template_haskell(2, 17, 0)
    thEmbeddedTypeParams :: [TyVarBndr ()],
#else
    thEmbeddedTypeParams :: [TyVarBndr],
#endif
    thEmbeddedFields :: [THFieldDef]
  }
  deriving (Eq, Show)

data THPrimitiveDef = THPrimitiveDef
  { thPrimitiveName :: Name,
    -- | It is used only to set polymorphic part of name of its container
    thPrimitiveDbName :: String,
    -- | Name of a pair of functions converting the value to and from a type that is an instance of `PrimitivePersistField`
    thPrimitiveConverter :: Name
  }
  deriving (Eq, Show)

data THConstructorDef = THConstructorDef
  { thConstrName :: Name, -- U2
    thPhantomConstrName :: String, -- U2Constructor
    thDbConstrName :: String, -- SQLU2
    thDbAutoKeyName :: Maybe String, -- u2_id
    thConstrFields :: [THFieldDef],
    thConstrUniques :: [THUniqueDef]
  }
  deriving (Eq, Show)

data THFieldDef = THFieldDef
  { -- | name in the record, bar
    thFieldName :: String,
    -- | column name, SQLbar
    thDbFieldName :: String,
    -- | column type, inet, NUMERIC(5, 2), VARCHAR(50), etc.
    thDbTypeName :: Maybe String,
    -- | name of constructor in the Field GADT, BarField
    thExprName :: String,
    thFieldType :: Type,
    thEmbeddedDef :: Maybe [PSFieldDef String],
    -- | default value in the database
    thDefaultValue :: Maybe String,
    thReferenceParent :: Maybe (Maybe ((Maybe String, String), [String]), Maybe ReferenceActionType, Maybe ReferenceActionType),
    -- | name of a pair of functions
    thFieldConverter :: Maybe Name
  }
  deriving (Eq, Show)

data THUniqueDef = THUniqueDef
  { thUniqueName :: String,
    thUniqueType :: UniqueType,
    -- | Either name of field, i.e, thFieldName, or expression
    thUniqueFields :: [Either String String]
  }
  deriving (Eq, Show)

data THUniqueKeyDef = THUniqueKeyDef
  { thUniqueKeyName :: String,
    thUniqueKeyPhantomName :: String,
    thUniqueKeyConstrName :: String,
    -- | It is used only to set polymorphic part of name of its container
    -- | It should repeat fields from THUniqueDef but it may give different settings for them. It is done to allow foreign key fields to be different from parent fields of the entity. These fields are used for creating a the key constructor and instances for it. For example, it can have a default value, or even a different type (INT8 may reference INT4).
    thUniqueKeyDbName :: String,
    thUniqueKeyFields :: [THFieldDef],
    -- | If True, make it an instance of Embedded
    thUniqueKeyMakeEmbedded :: Bool,
    thUniqueKeyIsDef :: Bool
  }
  deriving (Eq, Show)

data PSEntityDef = PSEntityDef
  { psDataName :: String, -- SomeData
    psDbEntityName :: Maybe String, -- SQLSomeData
    psEntitySchema :: Maybe String,
    psAutoKey :: Maybe (Maybe PSAutoKeyDef), -- SomeDataKey. Nothing - default key. Just Nothing - no autokey. Just (Just _) - specify autokey settings
    psUniqueKeys :: Maybe [PSUniqueKeyDef],
    psConstructors :: Maybe [PSConstructorDef]
  }
  deriving (Eq, Show, Lift)

data PSEmbeddedDef = PSEmbeddedDef
  { psEmbeddedName :: String,
    -- | It is used only to set polymorphic part of name of its container
    psDbEmbeddedName :: Maybe String,
    psEmbeddedFields :: Maybe [PSFieldDef String]
  }
  deriving (Eq, Show, Lift)

data PSPrimitiveDef = PSPrimitiveDef
  { psPrimitiveName :: String,
    -- | It is used only to set polymorphic part of name of its container
    psPrimitiveDbName :: Maybe String,
    -- | Name of a pair of functions converting the value to and from a type that is an instance of `PrimitivePersistField`
    psPrimitiveConverter :: String
  }
  deriving (Eq, Show, Lift)

data PSConstructorDef = PSConstructorDef
  { psConstrName :: String, -- U2
    psPhantomConstrName :: Maybe String, -- U2Constructor
    psDbConstrName :: Maybe String, -- SQLU2
    psDbAutoKeyName :: Maybe String, -- u2_id
    psConstrFields :: Maybe [PSFieldDef String],
    psConstrUniques :: Maybe [PSUniqueDef]
  }
  deriving (Eq, Show, Lift)

data PSUniqueDef = PSUniqueDef
  { psUniqueName :: String,
    psUniqueType :: Maybe UniqueType,
    psUniqueFields :: [Either String String]
  }
  deriving (Eq, Show, Lift)

data PSUniqueKeyDef = PSUniqueKeyDef
  { psUniqueKeyName :: String,
    psUniqueKeyPhantomName :: Maybe String,
    psUniqueKeyConstrName :: Maybe String,
    psUniqueKeyDbName :: Maybe String,
    psUniqueKeyFields :: Maybe [PSFieldDef String],
    psUniqueKeyMakeEmbedded :: Maybe Bool,
    psUniqueKeyIsDef :: Maybe Bool
  }
  deriving (Eq, Show, Lift)

data PSAutoKeyDef = PSAutoKeyDef
  { psAutoKeyConstrName :: Maybe String,
    psAutoKeyIsDef :: Maybe Bool
  }
  deriving (Eq, Show, Lift)

deriving instance Lift a => Lift (PSFieldDef a)

deriving instance Lift UniqueType

deriving instance Lift ReferenceActionType

instance FromJSON PersistDefinitions where
  {- it allows omitting parts of the settings file. All these forms are possible:
        definitions:
          - entity:name
        ---
          - entity:name
        ---
          entity: name
  -}
  parseJSON value =
    case value of
      Object v -> do
        defs <- v .:? "definitions"
        case defs of
          Just (Array arr) -> Fold.foldrM go initial arr
          Nothing -> go value initial
          Just _ -> mzero
      Array arr -> Fold.foldrM go initial arr
      _ -> mzero
    where
      initial = PersistDefinitions [] [] []
      go obj p@PersistDefinitions {..} = flip (withObject "definition") obj $ \v -> case () of
        _ | H.member "entity" v -> (\x -> p {psEntities = x : psEntities}) <$> parseJSON obj
        _ | H.member "embedded" v -> (\x -> p {psEmbeddeds = x : psEmbeddeds}) <$> parseJSON obj
        _ | H.member "primitive" v -> (\x -> p {psPrimitives = x : psPrimitives}) <$> parseJSON obj
        _ -> fail $ "Invalid definition: " ++ show obj

instance FromJSON PSEntityDef where
  parseJSON = withObject "entity" $ \v ->
    PSEntityDef <$> v .: "entity" <*> v .:? "dbName" <*> v .:? "schema" <*> optional (v .: "autoKey") <*> v .:? "keys" <*> v .:? "constructors"

instance FromJSON PSEmbeddedDef where
  parseJSON = withObject "embedded" $ \v ->
    PSEmbeddedDef <$> v .: "embedded" <*> v .:? "dbName" <*> v .:? "fields"

instance FromJSON PSPrimitiveDef where
  parseJSON = withObject "primitive" $ \v -> do
    when (H.member "representation" v) $ fail $ "parseJSON: field 'representation' is deprecated. Use 'converter' instead: " ++ show v
    PSPrimitiveDef <$> v .: "primitive" <*> v .:? "dbName" <*> v .: "converter"

instance FromJSON PSConstructorDef where
  parseJSON = withObject "constructor" $ \v ->
    PSConstructorDef <$> v .: "name" <*> v .:? "phantomName" <*> v .:? "dbName" <*> v .:? "keyDbName" <*> v .:? "fields" <*> v .:? "uniques"

instance FromJSON PSUniqueDef where
  parseJSON = withObject "unique" $ \v -> do
    fields <- v .: "fields"
    fields' <- forM fields $ \case
      Object expr -> Right <$> expr .: "expr"
      field -> Left <$> parseJSON field
    PSUniqueDef <$> v .: "name" <*> v .:? "type" <*> pure fields'

instance FromJSON UniqueType where
  parseJSON o = do
    x <- parseJSON o
    let vals = [("constraint", UniqueConstraint), ("index", UniqueIndex), ("primary", UniquePrimary False)]
    case lookup x vals of
      Just a -> pure a
      Nothing -> fail $ "parseJSON: UniqueType expected " ++ show (map fst vals) ++ ", but got " ++ x

instance FromJSON ReferenceActionType where
  parseJSON o = do
    x <- parseJSON o
    let vals = [("no action", NoAction), ("restrict", Restrict), ("cascade", Cascade), ("set null", SetNull), ("set default", SetDefault)]
    case lookup x vals of
      Just a -> pure a
      Nothing -> fail $ "parseJSON: UniqueType expected " ++ show (map fst vals) ++ ", but got " ++ x

instance FromJSON (PSFieldDef String) where
  parseJSON = withObject "field" $ \v ->
    PSFieldDef <$> v .: "name" <*> v .:? "dbName" <*> v .:? "type" <*> v .:? "exprName" <*> v .:? "embeddedType" <*> v .:? "default" <*> mkRefSettings v <*> v .:? "converter"
    where
      mkRefSettings v = do
        ref <- v .:? "reference"
        (parent, onDel, onUpd) <- case ref of
          Just (Object r) -> (,,) <$> optional parentRef <*> r .:? "onDelete" <*> r .:? "onUpdate"
            where
              parentRef = (,) <$> ((,) <$> r .:? "schema" <*> r .: "table") <*> r .: "columns"
          _ -> pure (Nothing, Nothing, Nothing)
        -- this temporary solution uses onDelete and onUpdate both from inside reference object (preferred) and from field level (for compatibility)
        (onDel', onUpd') <- (,) <$> v .:? "onDelete" <*> v .:? "onUpdate"
        pure $ case (parent, onDel <|> onDel', onUpd <|> onUpd') of
          (Nothing, Nothing, Nothing) -> Nothing
          refSettings -> Just refSettings

instance FromJSON PSUniqueKeyDef where
  parseJSON = withObject "unique key" $ \v ->
    PSUniqueKeyDef <$> v .: "name" <*> v .:? "keyPhantom" <*> v .:? "constrName" <*> v .:? "dbName" <*> v .:? "fields" <*> v .:? "mkEmbedded" <*> v .:? "default"

instance FromJSON PSAutoKeyDef where
  parseJSON = withObject "autogenerated key" $ \v ->
    PSAutoKeyDef <$> v .:? "constrName" <*> v .:? "default"

(.=?) :: ToJSON a => Text -> Maybe a -> Maybe Pair
name .=? value = (name .=) <$> value

(.=:) :: ToJSON a => Text -> Maybe [a] -> Maybe Pair
name .=: value = case value of
  Just (_ : _) -> Just $ name .= value
  _ -> Nothing

instance ToJSON PSEntityDef where
  toJSON PSEntityDef {..} = object $ catMaybes [Just $ "entity" .= psDataName, "dbName" .=? psDbEntityName, "schema" .=? psEntitySchema, "autoKey" .=? psAutoKey, "keys" .=: psUniqueKeys, "constructors" .=: psConstructors]

instance ToJSON PSConstructorDef where
  toJSON PSConstructorDef {..} = object $ catMaybes [Just $ "name" .= psConstrName, "phantomName" .=? psPhantomConstrName, "dbName" .=? psDbConstrName, "keyDbName" .=? psDbAutoKeyName, "fields" .=: psConstrFields, "uniques" .=: psConstrUniques]

instance ToJSON PSUniqueDef where
  toJSON PSUniqueDef {..} = object $ catMaybes [Just $ "name" .= psUniqueName, "type" .=? psUniqueType, "fields" .=? fields]
    where
      fields =
        if null psUniqueFields
          then Nothing
          else Just $ map (either toJSON (\x -> object ["expr" .= x])) psUniqueFields

instance ToJSON UniqueType where
  toJSON a = toJSON $ case a of
    UniqueConstraint -> "constraint" :: String
    UniqueIndex -> "index"
    UniquePrimary _ -> "primary"

instance ToJSON ReferenceActionType where
  toJSON a = toJSON $ case a of
    NoAction -> "no action" :: String
    Restrict -> "restrict"
    Cascade -> "cascade"
    SetNull -> "set null"
    SetDefault -> "set default"

instance ToJSON (PSFieldDef String) where
  toJSON PSFieldDef {..} = object $ catMaybes [Just $ "name" .= psFieldName, "dbName" .=? psDbFieldName, "type" .=? psDbTypeName, "exprName" .=? psExprName, "embeddedType" .=: psEmbeddedDef, "default" .=? psDefaultValue, "reference" .=? (psReferenceParent >>= mkRefSettings)]
    where
      mkRefSettings (parent, onDel, onUpd) = if null fields then Nothing else Just $ object fields
        where
          fields = catMaybes $ parent' ++ ["onDelete" .=? onDel, "onUpdate" .=? onUpd]
          parent' = case parent of
            Nothing -> []
            Just ((schema, table), columns) -> ["schema" .=? schema, Just $ "table" .= table, Just $ "columns" .= columns]

instance ToJSON PSUniqueKeyDef where
  toJSON PSUniqueKeyDef {..} = object $ catMaybes [Just $ "name" .= psUniqueKeyName, "keyPhantom" .=? psUniqueKeyPhantomName, "constrName" .=? psUniqueKeyConstrName, "dbName" .=? psUniqueKeyDbName, "mkEmbedded" .=? psUniqueKeyMakeEmbedded, "default" .=? psUniqueKeyIsDef, "fields" .=: psUniqueKeyFields]

instance ToJSON PSAutoKeyDef where
  toJSON PSAutoKeyDef {..} = object $ catMaybes ["constrName" .=? psAutoKeyConstrName, "default" .=? psAutoKeyIsDef]