{-# 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) = f (ObjectTypeResolver m) -> (Value -> f (ObjectTypeResolver m)) -> Key -> Object -> f (ObjectTypeResolver m) forall k (c :: * -> *) d a. IsMap k c => d -> (a -> d) -> k -> c a -> d selectOr f (ObjectTypeResolver m) forall (m :: * -> *) (a :: * -> *). Monad m => m (ObjectTypeResolver a) mkEmptyObject (ResolverValue m -> f (ObjectTypeResolver m) forall (f :: * -> *) (m :: * -> *). MonadError GQLError f => ResolverValue m -> f (ObjectTypeResolver m) requireObject (ResolverValue m -> f (ObjectTypeResolver m)) -> (Value -> f (ResolverValue m)) -> Value -> f (ObjectTypeResolver m) forall (m :: * -> *) b c a. Monad m => (b -> m c) -> (a -> m b) -> a -> m c <=< Value -> f (ResolverValue m) forall (f :: * -> *) (m :: * -> *). (MonadReader ResolverContext f, MonadReader ResolverContext m) => Value -> f (ResolverValue m) mkValue) (FieldName -> Key forall a (t :: NAME). NamePacking a => Name t -> a forall (t :: NAME). Name t -> Key unpackName FieldName name) Object fields lookupResJSON FieldName _ Value _ = f (ObjectTypeResolver m) 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 = ObjectTypeResolver a -> m (ObjectTypeResolver a) forall a. a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure (ObjectTypeResolver a -> m (ObjectTypeResolver a)) -> ObjectTypeResolver a -> m (ObjectTypeResolver a) forall a b. (a -> b) -> a -> b $ HashMap FieldName (a (ResolverValue a)) -> ObjectTypeResolver a forall (m :: * -> *). HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m ObjectTypeResolver HashMap FieldName (a (ResolverValue a)) 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) = ResolverValue m -> f (ResolverValue m) forall a. a -> f a forall (f :: * -> *) a. Applicative f => a -> f a pure (ResolverValue m -> f (ResolverValue m)) -> ResolverValue m -> f (ResolverValue m) forall a b. (a -> b) -> a -> b $ Maybe TypeName -> [ResolverEntry m] -> ResolverValue m forall (m :: * -> *). Maybe TypeName -> [ResolverEntry m] -> ResolverValue m mkObjectMaybe Maybe TypeName typename [ResolverEntry m] fields where typename :: Maybe TypeName typename = Key -> Object -> Maybe Value forall a. Key -> KeyMap a -> Maybe a forall k (m :: * -> *) a. IsMap k m => k -> m a -> Maybe a lookup Key "__typename" Object v Maybe Value -> (Value -> Maybe TypeName) -> Maybe TypeName forall a b. Maybe a -> (a -> Maybe b) -> Maybe b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= Value -> Maybe TypeName unpackJSONName fields :: [ResolverEntry m] fields = ((Key, Value) -> ResolverEntry m) -> [(Key, Value)] -> [ResolverEntry m] forall a b. (a -> b) -> [a] -> [b] map ((Key -> FieldName) -> (Value -> m (ResolverValue m)) -> (Key, Value) -> ResolverEntry m forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d) forall (p :: * -> * -> *) a b c d. Bifunctor p => (a -> b) -> (c -> d) -> p a c -> p b d bimap Key -> FieldName forall a (t :: NAME). NamePacking a => a -> Name t forall (t :: NAME). Key -> Name t packName Value -> m (ResolverValue m) forall (f :: * -> *) (m :: * -> *). (MonadReader ResolverContext f, MonadReader ResolverContext m) => Value -> f (ResolverValue m) mkValue) (Object -> [(Key, Value)] forall a. KeyMap a -> [(Key, a)] forall k (m :: * -> *) a. IsMap k m => m a -> [(k, a)] toAssoc Object v) mkValue (Array Array ls) = [ResolverValue m] -> ResolverValue m forall (m :: * -> *). [ResolverValue m] -> ResolverValue m mkList ([ResolverValue m] -> ResolverValue m) -> f [ResolverValue m] -> f (ResolverValue m) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Value -> f (ResolverValue m)) -> [Value] -> f [ResolverValue m] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) forall (f :: * -> *) a b. Applicative f => (a -> f b) -> [a] -> f [b] traverse Value -> f (ResolverValue m) forall (f :: * -> *) (m :: * -> *). (MonadReader ResolverContext f, MonadReader ResolverContext m) => Value -> f (ResolverValue m) mkValue (Array -> [Value] forall a. Vector a -> [a] forall (t :: * -> *) a. Foldable t => t a -> [a] toList Array ls) mkValue Value Null = ResolverValue m -> f (ResolverValue m) forall a. a -> f a forall (f :: * -> *) a. Applicative f => a -> f a pure ResolverValue m forall (m :: * -> *). ResolverValue m mkNull mkValue (Number Scientific x) = ResolverValue m -> f (ResolverValue m) forall a. a -> f a forall (f :: * -> *) a. Applicative f => a -> f a pure (ResolverValue m -> f (ResolverValue m)) -> ResolverValue m -> f (ResolverValue m) forall a b. (a -> b) -> a -> b $ ScalarValue -> ResolverValue m 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 <- (ResolverContext -> Selection VALID) -> f (Selection VALID) forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks ResolverContext -> Selection VALID currentSelection Value -> f (ResolverValue m) forall (f :: * -> *) (m :: * -> *). (MonadReader ResolverContext f, MonadReader ResolverContext m) => Value -> f (ResolverValue m) mkValue (Value -> Maybe Value -> Value forall a. a -> Maybe a -> a fromMaybe Value Null (Text -> Selection VALID -> Maybe Value forall node name. (SelectionTree node, ToString name) => name -> node -> Maybe Value forall name. ToString name => name -> Selection VALID -> Maybe Value getArgument Text name Selection VALID sel)) NoAPI Text v -> ResolverValue m -> f (ResolverValue m) forall a. a -> f a forall (f :: * -> *) a. Applicative f => a -> f a pure (ResolverValue m -> f (ResolverValue m)) -> ResolverValue m -> f (ResolverValue m) forall a b. (a -> b) -> a -> b $ Text -> ResolverValue m forall (m :: * -> *). Text -> ResolverValue m mkString Text v mkValue (Bool Bool x) = ResolverValue m -> f (ResolverValue m) forall a. a -> f a forall (f :: * -> *) a. Applicative f => a -> f a pure (ResolverValue m -> f (ResolverValue m)) -> ResolverValue m -> f (ResolverValue m) forall a b. (a -> b) -> a -> b $ Bool -> ResolverValue m forall (m :: * -> *). Bool -> ResolverValue m mkBoolean Bool x data SelfAPI = ARG Text | NoAPI Text withSelf :: Text -> SelfAPI withSelf :: Text -> SelfAPI withSelf Text txt = case HasCallStack => Text -> Text -> (Text, Text) Text -> Text -> (Text, Text) breakOnEnd Text "::" Text txt of (Text "@SELF::", Text field) -> case HasCallStack => Text -> Text -> [Text] 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) = ObjectTypeResolver m -> f (ObjectTypeResolver m) forall a. a -> f a forall (f :: * -> *) a. Applicative f => a -> f a pure ObjectTypeResolver m x requireObject ResolverValue m _ = GQLError -> f (ObjectTypeResolver m) forall a. GQLError -> f a 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) = TypeName -> Maybe TypeName forall a. a -> Maybe a Just (Text -> TypeName forall a (t :: NAME). NamePacking a => a -> Name t forall (t :: NAME). Text -> Name t packName Text x) unpackJSONName Value _ = Maybe TypeName 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 :: HashMap FieldName (m (ResolverValue m)) objectFields :: forall (m :: * -> *). ObjectTypeResolver m -> HashMap FieldName (m (ResolverValue m)) ..} = m' a -> (m (ResolverValue m) -> m' a) -> Maybe (m (ResolverValue m)) -> m' a forall b a. b -> (a -> b) -> Maybe a -> b maybe (a -> m' a forall a. a -> m' a forall (f :: * -> *) a. Applicative f => a -> f a pure a fb) m (ResolverValue m) -> m' a suc (FieldName -> HashMap FieldName (m (ResolverValue m)) -> Maybe (m (ResolverValue m)) forall a. FieldName -> HashMap FieldName a -> Maybe a 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 = Maybe TypeName -> m value -> m value forall (m :: * -> *) a. (MonadReader ResolverContext m, MonadError GQLError m) => Maybe TypeName -> m a -> m a updateCurrentType Maybe TypeName __typename (m value -> m value) -> (SelectionContent VALID -> m value) -> SelectionContent VALID -> m value 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 (MergeMap 'False FieldName (Selection VALID) -> Maybe (MergeMap 'False FieldName (Selection VALID)) forall a. a -> Maybe a Just MergeMap 'False FieldName (Selection VALID) SelectionSet VALID selection) checkContent (UnionSelection Maybe (SelectionSet VALID) interface UnionSelection VALID unionSel) = do TypeName typename <- (ResolverContext -> TypeName) -> m TypeName forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks (TypeDefinition ANY VALID -> TypeName forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName typeName (TypeDefinition ANY VALID -> TypeName) -> (ResolverContext -> TypeDefinition ANY VALID) -> ResolverContext -> TypeName forall b c a. (b -> c) -> (a -> b) -> a -> c . ResolverContext -> TypeDefinition ANY VALID currentType) Maybe (MergeMap 'False FieldName (Selection VALID)) selection <- m (Maybe (MergeMap 'False FieldName (Selection VALID))) -> (UnionTag -> m (Maybe (MergeMap 'False FieldName (Selection VALID)))) -> TypeName -> MergeMap 'False TypeName UnionTag -> m (Maybe (MergeMap 'False FieldName (Selection VALID))) forall k (c :: * -> *) d a. IsMap k c => d -> (a -> d) -> k -> c a -> d selectOr (Maybe (MergeMap 'False FieldName (Selection VALID)) -> m (Maybe (MergeMap 'False FieldName (Selection VALID))) forall a. a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure Maybe (MergeMap 'False FieldName (Selection VALID)) Maybe (SelectionSet VALID) interface) (Maybe (MergeMap 'False FieldName (Selection VALID)) -> UnionTag -> m (Maybe (MergeMap 'False FieldName (Selection VALID))) forall {f :: * -> *}. MonadError GQLError f => Maybe (MergeMap 'False FieldName (Selection VALID)) -> UnionTag -> f (Maybe (MergeMap 'False FieldName (Selection VALID))) fx Maybe (MergeMap 'False FieldName (Selection VALID)) Maybe (SelectionSet VALID) interface) TypeName typename MergeMap 'False TypeName UnionTag UnionSelection VALID unionSel Maybe (SelectionSet VALID) -> m value f Maybe (MergeMap 'False FieldName (Selection VALID)) Maybe (SelectionSet 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 = MergeMap 'False FieldName (Selection VALID) -> Maybe (MergeMap 'False FieldName (Selection VALID)) forall a. a -> Maybe a Just (MergeMap 'False FieldName (Selection VALID) -> Maybe (MergeMap 'False FieldName (Selection VALID))) -> f (MergeMap 'False FieldName (Selection VALID)) -> f (Maybe (MergeMap 'False FieldName (Selection VALID))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (MergeMap 'False FieldName (Selection VALID) x MergeMap 'False FieldName (Selection VALID) -> MergeMap 'False FieldName (Selection VALID) -> f (MergeMap 'False FieldName (Selection VALID)) 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 = Maybe (MergeMap 'False FieldName (Selection VALID)) -> f (Maybe (MergeMap 'False FieldName (Selection VALID))) forall a. a -> f a forall (f :: * -> *) a. Applicative f => a -> f a pure (Maybe (MergeMap 'False FieldName (Selection VALID)) -> f (Maybe (MergeMap 'False FieldName (Selection VALID)))) -> Maybe (MergeMap 'False FieldName (Selection VALID)) -> f (Maybe (MergeMap 'False FieldName (Selection VALID))) forall a b. (a -> b) -> a -> b $ SelectionSet VALID -> Maybe (SelectionSet VALID) forall a. a -> Maybe a Just (SelectionSet VALID -> Maybe (SelectionSet VALID)) -> SelectionSet VALID -> Maybe (SelectionSet VALID) forall a b. (a -> b) -> a -> b $ UnionTag -> SelectionSet VALID unionTagSelection UnionTag y checkContent SelectionContent VALID SelectionField = do Selection VALID sel <- (ResolverContext -> Selection VALID) -> m (Selection VALID) forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks ResolverContext -> Selection VALID currentSelection GQLError -> m value forall a. GQLError -> m a forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (GQLError -> m value) -> GQLError -> m value forall a b. (a -> b) -> a -> b $ FieldName -> TypeName -> Position -> GQLError subfieldsNotSelected (Selection VALID -> FieldName forall (s :: Stage). Selection s -> FieldName selectionName Selection VALID sel) TypeName "" (Selection VALID -> Position forall (s :: Stage). Selection s -> Position selectionPosition Selection VALID sel)