Schema.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Deriving.Schema
  ( compileTimeSchemaValidation,
    deriveSchema,
    SCHEMA,
  )
where

import Control.Monad.Except (MonadError (..))
import Data.Map (alter, findWithDefault, insert)
import Data.Morpheus.Core (defaultConfig, validateSchema)
import Data.Morpheus.Generic (CBox, runCBox)
import Data.Morpheus.Internal.Ext (GQLResult)
import Data.Morpheus.Internal.Utils (IsMap (..), toAssoc)
import Data.Morpheus.Server.Deriving.Utils.GScan
  ( FreeCatType (..),
    scanFree,
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded (outputType)
import Data.Morpheus.Server.Deriving.Utils.Types (CatType (OutputType), GQLTypeNode (..), GQLTypeNodeExtension (..), NodeTypeVariant (..), coerceObject, fromSchema, nodeToType)
import Data.Morpheus.Server.Deriving.Utils.Use
  ( UseGQLType (useDeriveNode, useExploreRef, useFingerprint),
  )
import Data.Morpheus.Server.Types.GQLType
  ( GQLType (..),
    IgnoredResolver,
    ignoreUndefined,
    withGQL,
  )
import Data.Morpheus.Server.Types.TypeName (TypeFingerprint (..))
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    CONST,
    DirectiveDefinition,
    OBJECT,
    OUT,
    Schema,
    TypeCategory (..),
    TypeContent (..),
    TypeDefinition (..),
    TypeName,
    defineDirective,
    defineSchemaWith,
    mkEnumContent,
    mkType,
    msg,
    toAny,
    unitTypeName,
  )
import Language.Haskell.TH (Exp, Q)
import Relude hiding (empty)

type SCHEMA qu mu su =
  ( GQLType (qu IgnoredResolver),
    GQLType (mu IgnoredResolver),
    GQLType (su IgnoredResolver)
  )

-- | normal morpheus server validates schema at runtime (after the schema derivation).
--   this method allows you to validate it at compile time.
compileTimeSchemaValidation :: (SCHEMA qu mu su) => proxy (root m event qu mu su) -> Q Exp
compileTimeSchemaValidation = fromSchema . (deriveSchema >=> validateSchema True defaultConfig)

explore :: forall f (a :: (Type -> Type) -> Type). (GQLType (a IgnoredResolver)) => f a -> [CBox FreeCatType GQLType]
explore _ = scanFree (useExploreRef withGQL) (OutputType :: CatType OUT (a IgnoredResolver))

toDerivation :: TypeFingerprint -> GQLTypeNode c -> (TypeFingerprint, GQLTypeNode ANY)
toDerivation fp (GQLTypeNode node xs) = (fp, GQLTypeNode (toAny node) xs)
toDerivation fp (GQLDirectiveNode node) = (fp, GQLDirectiveNode node)

resolveNode :: (GQLType a) => FreeCatType a -> GQLResult (TypeFingerprint, GQLTypeNode ANY)
resolveNode (FreeCatType proxy) = toDerivation (useFingerprint withGQL proxy) <$> useDeriveNode withGQL proxy

deriveRoot :: (GQLType a) => f a -> GQLResult (TypeDefinition OBJECT CONST)
deriveRoot prx = useDeriveNode withGQL (outputType prx) >>= nodeToType >>= coerceObject

data SchemaState where
  SchemaState ::
    { typeDefinitions :: Map TypeFingerprint (TypeDefinition ANY CONST),
      implements :: Map TypeName [TypeName],
      directiveDefinitions :: Map TypeFingerprint (DirectiveDefinition CONST)
    } ->
    SchemaState

instance Semigroup SchemaState where
  SchemaState t1 i1 d1 <> SchemaState t2 i2 d2 = SchemaState (t1 <> t2) (i1 <> i2) (d1 <> d2)

instance Monoid SchemaState where
  mempty = SchemaState mempty mempty mempty

insertImplements :: Map TypeName [TypeName] -> TypeDefinition c CONST -> TypeDefinition c CONST
insertImplements implementsMap TypeDefinition {typeContent = DataObject {..}, ..} = TypeDefinition {..}
  where
    typeContent = DataObject {objectImplements = objectImplements <> implements, ..}
    implements = findWithDefault [] typeName implementsMap
insertImplements _ t = t

checkTypeCollisions :: [(TypeFingerprint, TypeDefinition k a)] -> GQLResult [TypeDefinition k a]
checkTypeCollisions = fmap toList . foldlM collectTypes mempty
  where
    collectTypes :: Map (TypeName, TypeFingerprint) (TypeDefinition k a) -> (TypeFingerprint, TypeDefinition k a) -> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
    collectTypes accum (fp, typ) = maybe addType (handleCollision typ) (key `lookup` accum)
      where
        addType = pure $ insert key typ accum
        key = (typeName typ, withSameCategory fp)
        handleCollision t1@TypeDefinition {typeContent = DataEnum {}} t2 | t1 == t2 = pure accum
        handleCollision TypeDefinition {typeContent = DataScalar {}} TypeDefinition {typeContent = DataScalar {}} = pure accum
        handleCollision TypeDefinition {typeName = name1} _ = failureRequirePrefix name1

failureRequirePrefix :: TypeName -> GQLResult b
failureRequirePrefix typename =
  throwError
    $ "It appears that the Haskell type "
    <> msg typename
    <> " was used as both input and output type, which is not allowed by GraphQL specifications."
    <> "\n\n "
    <> "If you use \"InputTypeNamespace\" directive, "
    <> "you can override the default type names for "
    <> msg typename
    <> " to solve this problem."

withSameCategory :: TypeFingerprint -> TypeFingerprint
withSameCategory (TypeableFingerprint _ xs) = TypeableFingerprint OUT xs
withSameCategory x = x

execNode :: (TypeFingerprint, GQLTypeNode ANY) -> SchemaState -> SchemaState
execNode (InternalFingerprint {}, _) s = s
execNode (fp, GQLTypeNode t xs) s = foldr execExtension (s {typeDefinitions = insert fp t (typeDefinitions s)}) xs
execNode (fp, GQLDirectiveNode d) s = s {directiveDefinitions = insert fp d (directiveDefinitions s)}

execExtension :: GQLTypeNodeExtension -> SchemaState -> SchemaState
execExtension (ImplementsExtension interface types) s = s {implements = foldr insertInterface (implements s) types}
  where
    insertInterface = alter (Just . (interface :) . fromMaybe [])
execExtension (UnionVariantsExtension nodes) s = foldr execNodeTypeVariant s nodes

execNodeTypeVariant :: NodeTypeVariant -> SchemaState -> SchemaState
execNodeTypeVariant (NodeTypeVariant consName fields) s = s {typeDefinitions = insert fp t (typeDefinitions s)}
  where
    fp = CustomFingerprint consName
    t = mkType consName fields
execNodeTypeVariant NodeUnitType s = s {typeDefinitions = insert fp t (typeDefinitions s)}
  where
    fp = CustomFingerprint unitTypeName
    t = mkType unitTypeName (mkEnumContent [unitTypeName])

deriveSchema :: forall root f m e qu mu su. (SCHEMA qu mu su) => f (root m e qu mu su) -> GQLResult (Schema CONST)
deriveSchema _ = do
  query <- deriveRoot (Proxy @(qu IgnoredResolver))
  mutation <- traverse deriveRoot (ignoreUndefined (Proxy @(mu IgnoredResolver)))
  subscription <- traverse deriveRoot (ignoreUndefined (Proxy @(su IgnoredResolver)))
  typeNodes <- traverse (runCBox resolveNode) (explore (Proxy @qu) <> explore (Proxy @mu) <> explore (Proxy @su))
  let SchemaState {..} = foldr execNode mempty typeNodes
  types <- map (insertImplements implements) <$> checkTypeCollisions (toAssoc typeDefinitions)
  schema <- defineSchemaWith types (Just query, mutation, subscription)
  foldlM defineDirective schema directiveDefinitions