{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.App.Internal.Resolving.Utils ( ResolverValue (..), requireObject, NamedResolverRef (..), ObjectTypeResolver, lookupResJSON, mkValue, ) where import Control.Monad.Except (MonadError (throwError)) import qualified Data.Aeson as A import Data.Morpheus.App.Internal.Resolving.ResolverState import Data.Morpheus.App.Internal.Resolving.Types ( NamedResolverRef (..), ObjectTypeResolver (..), ResolverValue (..), mkList, mkNull, mkObjectMaybe, ) import Data.Morpheus.Internal.Utils (selectOr, toAssoc) import qualified Data.Morpheus.Internal.Utils as U import Data.Morpheus.Types.Internal.AST ( FieldName, GQLError, ScalarValue (..), TypeName, decodeScientific, internal, packName, unpackName, ) import Data.Morpheus.Types.SelectionTree (SelectionTree (..)) import Data.Text (breakOnEnd, splitOn) import qualified Data.Vector as V import Relude hiding (break) lookupResJSON :: ( MonadError GQLError f, MonadReader ResolverContext f, MonadReader ResolverContext m ) => FieldName -> A.Value -> f (ObjectTypeResolver m) lookupResJSON :: forall (f :: * -> *) (m :: * -> *). (MonadError GQLError f, MonadReader ResolverContext f, MonadReader ResolverContext m) => FieldName -> Value -> f (ObjectTypeResolver m) lookupResJSON FieldName name (A.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 ) => A.Value -> f (ResolverValue m) mkValue :: forall (f :: * -> *) (m :: * -> *). (MonadReader ResolverContext f, MonadReader ResolverContext m) => Value -> f (ResolverValue m) mkValue (A.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 U.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 (A.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 a. Vector a -> [a] V.toList Array ls) mkValue Value A.Null = forall (f :: * -> *) a. Applicative f => a -> f a pure forall (m :: * -> *). ResolverValue m mkNull mkValue (A.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 (A.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 A.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 :: * -> *). ScalarValue -> ResolverValue m ResScalar (Text -> ScalarValue String Text v) mkValue (A.Bool Bool x) = forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). ScalarValue -> ResolverValue m ResScalar (Bool -> ScalarValue Boolean 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 :: A.Value -> Maybe TypeName unpackJSONName :: Value -> Maybe TypeName unpackJSONName (A.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