{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.App.Internal.Resolving.Utils ( ResolverValue (..), requireObject, NamedResolverRef (..), ObjectTypeResolver, lookupResJSON, mkValue, ResolverMonad, withField, withObject, ) where import Control.Monad.Except (MonadError (throwError)) import Data.Aeson (Value (..)) import Data.Morpheus.App.Internal.Resolving.ResolverState ( ResolverContext (..), updateCurrentType, ) import Data.Morpheus.App.Internal.Resolving.Types ( NamedResolverRef (..), ObjectTypeResolver (..), ResolverValue (..), mkBoolean, mkList, mkNull, mkObjectMaybe, mkString, ) import Data.Morpheus.Error (subfieldsNotSelected) import Data.Morpheus.Internal.Utils (IsMap (..), selectOr, toAssoc, (<:>)) import Data.Morpheus.Types.Internal.AST ( FieldName, GQLError, Selection (..), SelectionContent (..), SelectionSet, TypeDefinition (..), TypeName, UnionTag (..), VALID, decodeScientific, internal, packName, unpackName, ) import Data.Morpheus.Types.SelectionTree (SelectionTree (..)) import Data.Text (breakOnEnd, splitOn) import Relude hiding (break) type ResolverMonad m = (MonadError GQLError m, MonadReader ResolverContext m) lookupResJSON :: (ResolverMonad f, MonadReader ResolverContext m) => FieldName -> Value -> f (ObjectTypeResolver m) lookupResJSON :: forall (f :: * -> *) (m :: * -> *). (ResolverMonad f, MonadReader ResolverContext m) => FieldName -> Value -> f (ObjectTypeResolver m) lookupResJSON FieldName name (Object Object fields) = forall k (c :: * -> *) d a. IsMap k c => d -> (a -> d) -> k -> c a -> d selectOr forall (m :: * -> *) (a :: * -> *). Monad m => m (ObjectTypeResolver a) mkEmptyObject (forall (f :: * -> *) (m :: * -> *). MonadError GQLError f => ResolverValue m -> f (ObjectTypeResolver m) requireObject forall (m :: * -> *) b c a. Monad m => (b -> m c) -> (a -> m b) -> a -> m c <=< forall (f :: * -> *) (m :: * -> *). (MonadReader ResolverContext f, MonadReader ResolverContext m) => Value -> f (ResolverValue m) mkValue) (forall a (t :: NAME). NamePacking a => Name t -> a unpackName FieldName name) Object fields lookupResJSON FieldName _ Value _ = forall (m :: * -> *) (a :: * -> *). Monad m => m (ObjectTypeResolver a) mkEmptyObject mkEmptyObject :: Monad m => m (ObjectTypeResolver a) mkEmptyObject :: forall (m :: * -> *) (a :: * -> *). Monad m => m (ObjectTypeResolver a) mkEmptyObject = forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m ObjectTypeResolver forall a. Monoid a => a mempty mkValue :: ( MonadReader ResolverContext f, MonadReader ResolverContext m ) => Value -> f (ResolverValue m) mkValue :: forall (f :: * -> *) (m :: * -> *). (MonadReader ResolverContext f, MonadReader ResolverContext m) => Value -> f (ResolverValue m) mkValue (Object Object v) = forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). Maybe TypeName -> [ResolverEntry m] -> ResolverValue m mkObjectMaybe Maybe TypeName typename [(FieldName, m (ResolverValue m))] fields where typename :: Maybe TypeName typename = forall k (m :: * -> *) a. IsMap k m => k -> m a -> Maybe a lookup Key "__typename" Object v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= Value -> Maybe TypeName unpackJSONName fields :: [(FieldName, m (ResolverValue m))] fields = forall a b. (a -> b) -> [a] -> [b] map (forall (p :: * -> * -> *) a b c d. Bifunctor p => (a -> b) -> (c -> d) -> p a c -> p b d bimap forall a (t :: NAME). NamePacking a => a -> Name t packName forall (f :: * -> *) (m :: * -> *). (MonadReader ResolverContext f, MonadReader ResolverContext m) => Value -> f (ResolverValue m) mkValue) (forall k (m :: * -> *) a. IsMap k m => m a -> [(k, a)] toAssoc Object v) mkValue (Array Array ls) = forall (m :: * -> *). [ResolverValue m] -> ResolverValue m mkList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse forall (f :: * -> *) (m :: * -> *). (MonadReader ResolverContext f, MonadReader ResolverContext m) => Value -> f (ResolverValue m) mkValue (forall (t :: * -> *) a. Foldable t => t a -> [a] toList Array ls) mkValue Value Null = forall (f :: * -> *) a. Applicative f => a -> f a pure forall (m :: * -> *). ResolverValue m mkNull mkValue (Number Scientific x) = forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). ScalarValue -> ResolverValue m ResScalar (Scientific -> ScalarValue decodeScientific Scientific x) mkValue (String Text txt) = case Text -> SelfAPI withSelf Text txt of ARG Text name -> do Selection VALID sel <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks ResolverContext -> Selection VALID currentSelection forall (f :: * -> *) (m :: * -> *). (MonadReader ResolverContext f, MonadReader ResolverContext m) => Value -> f (ResolverValue m) mkValue (forall a. a -> Maybe a -> a fromMaybe Value Null (forall node name. (SelectionTree node, ToString name) => name -> node -> Maybe Value getArgument Text name Selection VALID sel)) NoAPI Text v -> forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). Text -> ResolverValue m mkString Text v mkValue (Bool Bool x) = forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). Bool -> ResolverValue m mkBoolean Bool x data SelfAPI = ARG Text | NoAPI Text withSelf :: Text -> SelfAPI withSelf :: Text -> SelfAPI withSelf Text txt = case Text -> Text -> (Text, Text) breakOnEnd Text "::" Text txt of (Text "@SELF::", Text field) -> case Text -> Text -> [Text] splitOn Text "." Text field of [Text "ARG", Text name] -> Text -> SelfAPI ARG Text name [Text] _ -> Text -> SelfAPI NoAPI Text txt (Text, Text) _ -> Text -> SelfAPI NoAPI Text txt requireObject :: MonadError GQLError f => ResolverValue m -> f (ObjectTypeResolver m) requireObject :: forall (f :: * -> *) (m :: * -> *). MonadError GQLError f => ResolverValue m -> f (ObjectTypeResolver m) requireObject (ResObject Maybe TypeName _ ObjectTypeResolver m x) = forall (f :: * -> *) a. Applicative f => a -> f a pure ObjectTypeResolver m x requireObject ResolverValue m _ = forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (GQLError -> GQLError internal GQLError "resolver must be an object") unpackJSONName :: Value -> Maybe TypeName unpackJSONName :: Value -> Maybe TypeName unpackJSONName (String Text x) = forall a. a -> Maybe a Just (forall a (t :: NAME). NamePacking a => a -> Name t packName Text x) unpackJSONName Value _ = forall a. Maybe a Nothing withField :: Monad m' => a -> (m (ResolverValue m) -> m' a) -> FieldName -> ObjectTypeResolver m -> m' a withField :: forall (m' :: * -> *) a (m :: * -> *). Monad m' => a -> (m (ResolverValue m) -> m' a) -> FieldName -> ObjectTypeResolver m -> m' a withField a fb m (ResolverValue m) -> m' a suc FieldName selectionName ObjectTypeResolver {HashMap FieldName (m (ResolverValue m)) objectFields :: forall (m :: * -> *). ObjectTypeResolver m -> HashMap FieldName (m (ResolverValue m)) objectFields :: HashMap FieldName (m (ResolverValue m)) ..} = forall b a. b -> (a -> b) -> Maybe a -> b maybe (forall (f :: * -> *) a. Applicative f => a -> f a pure a fb) m (ResolverValue m) -> m' a suc (forall k (m :: * -> *) a. IsMap k m => k -> m a -> Maybe a lookup FieldName selectionName HashMap FieldName (m (ResolverValue m)) objectFields) withObject :: (ResolverMonad m) => Maybe TypeName -> (Maybe (SelectionSet VALID) -> m value) -> SelectionContent VALID -> m value withObject :: forall (m :: * -> *) value. ResolverMonad m => Maybe TypeName -> (Maybe (SelectionSet VALID) -> m value) -> SelectionContent VALID -> m value withObject Maybe TypeName __typename Maybe (SelectionSet VALID) -> m value f = forall (m :: * -> *) a. (MonadReader ResolverContext m, MonadError GQLError m) => Maybe TypeName -> m a -> m a updateCurrentType Maybe TypeName __typename forall b c a. (b -> c) -> (a -> b) -> a -> c . SelectionContent VALID -> m value checkContent where checkContent :: SelectionContent VALID -> m value checkContent (SelectionSet SelectionSet VALID selection) = Maybe (SelectionSet VALID) -> m value f (forall a. a -> Maybe a Just SelectionSet VALID selection) checkContent (UnionSelection Maybe (SelectionSet VALID) interface UnionSelection VALID unionSel) = do TypeName typename <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks (forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName typeName forall b c a. (b -> c) -> (a -> b) -> a -> c . ResolverContext -> TypeDefinition ANY VALID currentType) Maybe (MergeMap 'False FieldName (Selection VALID)) selection <- forall k (c :: * -> *) d a. IsMap k c => d -> (a -> d) -> k -> c a -> d selectOr (forall (f :: * -> *) a. Applicative f => a -> f a pure Maybe (SelectionSet VALID) interface) (forall {f :: * -> *}. MonadError GQLError f => Maybe (MergeMap 'False FieldName (Selection VALID)) -> UnionTag -> f (Maybe (MergeMap 'False FieldName (Selection VALID))) fx Maybe (SelectionSet VALID) interface) TypeName typename UnionSelection VALID unionSel Maybe (SelectionSet VALID) -> m value f Maybe (MergeMap 'False FieldName (Selection VALID)) selection where fx :: Maybe (MergeMap 'False FieldName (Selection VALID)) -> UnionTag -> f (Maybe (MergeMap 'False FieldName (Selection VALID))) fx (Just MergeMap 'False FieldName (Selection VALID) x) UnionTag y = forall a. a -> Maybe a Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (MergeMap 'False FieldName (Selection VALID) x forall (m :: * -> *) a. (Merge (HistoryT m) a, Monad m) => a -> a -> m a <:> UnionTag -> SelectionSet VALID unionTagSelection UnionTag y) fx Maybe (MergeMap 'False FieldName (Selection VALID)) Nothing UnionTag y = forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ UnionTag -> SelectionSet VALID unionTagSelection UnionTag y checkContent SelectionContent VALID SelectionField = do Selection VALID sel <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks ResolverContext -> Selection VALID currentSelection forall e (m :: * -> *) a. MonadError e m => e -> m a throwError forall a b. (a -> b) -> a -> b $ FieldName -> TypeName -> Position -> GQLError subfieldsNotSelected (forall (s :: Stage). Selection s -> FieldName selectionName Selection VALID sel) TypeName "" (forall (s :: Stage). Selection s -> Position selectionPosition Selection VALID sel)