diff --git a/morpheus-graphql-core.cabal b/morpheus-graphql-core.cabal --- a/morpheus-graphql-core.cabal +++ b/morpheus-graphql-core.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: morpheus-graphql-core -version: 0.24.3 +version: 0.25.0 synopsis: Morpheus GraphQL Core description: Build GraphQL APIs with your favorite functional language! category: web, graphql @@ -183,7 +183,6 @@ Data.Morpheus.Error.Input Data.Morpheus.Error.Operation Data.Morpheus.Error.Selection - Data.Morpheus.Error.Utils Data.Morpheus.Error.Variable Data.Morpheus.Error.Warning Data.Morpheus.Ext.Empty @@ -274,7 +273,7 @@ , hashable >=1.0.0 && <2.0.0 , megaparsec >=7.0.0 && <10.0.0 , morpheus-graphql-core - , morpheus-graphql-tests >=0.24.0 && <0.25.0 + , morpheus-graphql-tests >=0.25.0 && <0.26.0 , mtl >=2.0.0 && <3.0.0 , relude >=0.3.0 && <2.0.0 , scientific >=0.3.6.2 && <0.4.0 diff --git a/src/Data/Mergeable/MergeMap.hs b/src/Data/Mergeable/MergeMap.hs --- a/src/Data/Mergeable/MergeMap.hs +++ b/src/Data/Mergeable/MergeMap.hs @@ -48,7 +48,8 @@ Eq, Functor, Foldable, - Traversable + Traversable, + Hashable ) instance (Lift a, Lift k) => Lift (MergeMap dups k a) where @@ -94,7 +95,7 @@ resolveMergeable (x :| xs) = recursiveMerge (MergeMap . NM.fromList) (x : xs) toNonEmpty :: (IsString e, MonadError e f) => [a] -> f (NonEmpty a) -toNonEmpty [] = throwError $ fromString "empty selection sets are not supported." +toNonEmpty [] = throwError "empty selection sets are not supported." toNonEmpty (x : xs) = pure (x :| xs) instance diff --git a/src/Data/Mergeable/OrdMap.hs b/src/Data/Mergeable/OrdMap.hs --- a/src/Data/Mergeable/OrdMap.hs +++ b/src/Data/Mergeable/OrdMap.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -40,7 +42,9 @@ ( Show, Eq, Functor, - Traversable + Traversable, + Generic, + Hashable ) instance Empty (OrdMap k a) where diff --git a/src/Data/Morpheus/Error.hs b/src/Data/Morpheus/Error.hs --- a/src/Data/Morpheus/Error.hs +++ b/src/Data/Morpheus/Error.hs @@ -1,9 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Error - ( errorMessage, - globalErrorMessage, - renderGQLErrors, + ( renderGQLErrors, deprecatedField, subfieldsNotSelected, NameCollision (..), @@ -15,5 +13,4 @@ import Data.Mergeable import Data.Morpheus.Error.Selection -import Data.Morpheus.Error.Utils import Data.Morpheus.Error.Warning diff --git a/src/Data/Morpheus/Error/Utils.hs b/src/Data/Morpheus/Error/Utils.hs deleted file mode 100644 --- a/src/Data/Morpheus/Error/Utils.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.Error.Utils - ( errorMessage, - globalErrorMessage, - ) -where - -import Data.Morpheus.Types.Internal.AST.Base - ( Position (..), - ) -import Data.Morpheus.Types.Internal.AST.Error - ( GQLError, - Message, - at, - msg, - ) - -{-# DEPRECATED errorMessage "\"my error\" `at` position" #-} -errorMessage :: Position -> Message -> [GQLError] -errorMessage position message = [msg message `at` position] - -{-# DEPRECATED globalErrorMessage "use validation errors" #-} -globalErrorMessage :: Message -> [GQLError] -globalErrorMessage message = [msg message] diff --git a/src/Data/Morpheus/Error/Warning.hs b/src/Data/Morpheus/Error/Warning.hs --- a/src/Data/Morpheus/Error/Warning.hs +++ b/src/Data/Morpheus/Error/Warning.hs @@ -1,11 +1,9 @@ -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Error.Warning ( renderGQLErrors, - deprecatedEnum, deprecatedField, gqlWarnings, printWarning, @@ -18,17 +16,16 @@ import Data.Morpheus.Types.Internal.AST.Base ( Description, Position (..), - Ref (..), ) import Data.Morpheus.Types.Internal.AST.Error ( GQLError (..), GQLErrors, PropName (..), - at, msg, ) import Data.Morpheus.Types.Internal.AST.Name ( FieldName, + TypeName, ) import qualified Data.Text as T import Language.Haskell.TH @@ -37,26 +34,12 @@ renderGQLErrors :: GQLErrors -> String renderGQLErrors = unpack . encode . toList --- TODO: implement warnings, is not used -deprecatedEnum :: FieldName -> Ref FieldName -> Maybe Description -> GQLError -deprecatedEnum typeName Ref {refPosition, refName} reason = - "the enum value " - <> msg typeName - <> "." - <> msg refName - <> " is deprecated." - <> msg (maybe "" (" " <>) reason) - `at` refPosition - -deprecatedField :: FieldName -> Ref FieldName -> Maybe Description -> GQLError -deprecatedField typeName Ref {refPosition, refName} reason = +deprecatedField :: TypeName -> FieldName -> Maybe Description -> GQLError +deprecatedField typeName refName reason = "the field " - <> msg typeName - <> "." - <> msg refName + <> msg (coerce typeName <> "." <> refName) <> " is deprecated." <> msg (maybe "" (" " <>) reason) - `at` refPosition gqlWarnings :: [GQLError] -> Q () gqlWarnings [] = pure () @@ -77,7 +60,7 @@ propLoc = concat $ toList $ locations warning description = indent <> withColor (toString (message warning)) loc - | null propPath = "" + | null propLoc = "" | otherwise = indent <> " locations: " <> concatMap printLocation propLoc printedPath | null propPath = "" diff --git a/src/Data/Morpheus/Internal/Ext.hs b/src/Data/Morpheus/Internal/Ext.hs --- a/src/Data/Morpheus/Internal/Ext.hs +++ b/src/Data/Morpheus/Internal/Ext.hs @@ -1,8 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Internal.Ext - ( Failure, - PushEvents (..), + ( PushEvents (..), Result (..), ResultT (..), cleanEvents, @@ -15,7 +14,6 @@ runResolutionT, toEither, Merge (..), - failure, GQLResult, ) where diff --git a/src/Data/Morpheus/Internal/Utils.hs b/src/Data/Morpheus/Internal/Utils.hs --- a/src/Data/Morpheus/Internal/Utils.hs +++ b/src/Data/Morpheus/Internal/Utils.hs @@ -8,8 +8,6 @@ module Data.Morpheus.Internal.Utils ( IsMap (..), - Failure, - failure, KeyOf (..), toPair, selectBy, @@ -31,7 +29,7 @@ ) where -import Control.Monad.Except (MonadError (throwError)) +import Control.Monad.Except (MonadError) import Data.ByteString.Lazy (ByteString) import Data.Mergeable ( IsMap (..), @@ -63,14 +61,6 @@ fromList, ) -{-# DEPRECATED Failure "use MonadError" #-} - -type Failure = MonadError - -{-# DEPRECATED failure "use throwError" #-} -failure :: MonadError e m => e -> m a -failure = throwError - (<:>) :: (Merge (HistoryT m) a, Monad m) => a -> a -> m a x <:> y = startHistory (merge x y) @@ -93,7 +83,7 @@ traverseCollection :: ( Monad m, - Failure GQLError m, + MonadError GQLError m, KeyOf k b, FromList m map k b, Foldable t @@ -115,7 +105,7 @@ insert :: ( NameCollision e a, KeyOf k a, - Failure e m + MonadError e m ) => a -> SafeHashMap k a -> diff --git a/src/Data/Morpheus/Types/Internal/AST/Base.hs b/src/Data/Morpheus/Types/Internal/AST/Base.hs --- a/src/Data/Morpheus/Types/Internal/AST/Base.hs +++ b/src/Data/Morpheus/Types/Internal/AST/Base.hs @@ -53,6 +53,9 @@ Lift ) +instance Hashable Position where + hashWithSalt s _ = hashWithSalt s (0 :: Int) + -- Positions 2 Value with same structure -- but different Positions should be Equal instance Eq Position where diff --git a/src/Data/Morpheus/Types/Internal/AST/Fields.hs b/src/Data/Morpheus/Types/Internal/AST/Fields.hs --- a/src/Data/Morpheus/Types/Internal/AST/Fields.hs +++ b/src/Data/Morpheus/Types/Internal/AST/Fields.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -114,7 +116,7 @@ argumentName :: FieldName, argumentValue :: Value valid } - deriving (Show, Eq, Lift) + deriving (Show, Eq, Lift, Generic, Hashable) instance KeyOf FieldName (Argument stage) where keyOf = argumentName @@ -143,7 +145,7 @@ directiveName :: FieldName, directiveArgs :: Arguments s } - deriving (Show, Lift, Eq) + deriving (Show, Lift, Eq, Generic, Hashable) instance NameCollision GQLError (Directive s) where nameCollision Directive {directiveName} = @@ -295,6 +297,8 @@ instance RenderGQL (FieldDefinition cat s) where renderGQL FieldDefinition {fieldContent = Just (FieldArgs args), ..} = renderGQL fieldName <> renderGQL args <> ": " <> renderGQL fieldType <> addDirectives fieldDirectives + renderGQL FieldDefinition {fieldContent = Just (DefaultInputValue x), ..} = + renderEntry fieldName fieldType <> " = " <> renderGQL x <> addDirectives fieldDirectives renderGQL FieldDefinition {..} = renderEntry fieldName fieldType <> addDirectives fieldDirectives diff --git a/src/Data/Morpheus/Types/Internal/AST/Selection.hs b/src/Data/Morpheus/Types/Internal/AST/Selection.hs --- a/src/Data/Morpheus/Types/Internal/AST/Selection.hs +++ b/src/Data/Morpheus/Types/Internal/AST/Selection.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -109,7 +111,7 @@ fragmentSelection :: SelectionSet stage, fragmentDirectives :: Directives stage } - deriving (Show, Eq, Lift) + deriving (Show, Eq, Lift, Generic, Hashable) -- ERRORs instance NameCollision GQLError (Fragment s) where @@ -131,6 +133,11 @@ } -> SelectionContent VALID +instance Hashable (SelectionContent s) where + hashWithSalt s SelectionField = hashWithSalt s (1 :: Int) + hashWithSalt s (SelectionSet x) = hashWithSalt s (2 :: Int, x) + hashWithSalt s (UnionSelection x xs) = hashWithSalt s (3 :: Int, x, xs) + renderSelectionSet :: SelectionSet VALID -> Rendering renderSelectionSet = renderObject . toList @@ -179,7 +186,7 @@ { unionTagName :: TypeName, unionTagSelection :: SelectionSet VALID } - deriving (Show, Eq, Lift) + deriving (Show, Eq, Lift, Generic, Hashable) instance KeyOf TypeName UnionTag where keyOf = unionTagName @@ -239,6 +246,20 @@ Selection s InlineFragment :: Fragment RAW -> Selection RAW Spread :: Directives RAW -> Ref FragmentName -> Selection RAW + +instance Hashable (Selection s) where + hashWithSalt s (InlineFragment x) = hashWithSalt s (1 :: Int, x) + hashWithSalt s (Spread x y) = hashWithSalt s (2 :: Int, x, refName y) + hashWithSalt s Selection {..} = + hashWithSalt + s + ( 3 :: Int, + selectionAlias, + selectionName, + selectionArguments, + selectionDirectives, + selectionContent + ) instance RenderGQL (Selection VALID) where renderGQL diff --git a/src/Data/Morpheus/Types/Internal/AST/Value.hs b/src/Data/Morpheus/Types/Internal/AST/Value.hs --- a/src/Data/Morpheus/Types/Internal/AST/Value.hs +++ b/src/Data/Morpheus/Types/Internal/AST/Value.hs @@ -288,3 +288,15 @@ mkObject = Object . unsafeFromList . fmap toEntry where toEntry (key, value) = (key, ObjectEntry key value) + +instance Hashable (Value a) where + hashWithSalt s (Object x) = hashWithSalt s (0 :: Int, toList x) + hashWithSalt s (List x) = hashWithSalt s (1 :: Int, x) + hashWithSalt s (Enum x) = hashWithSalt s (2 :: Int, x) + hashWithSalt s (Scalar x) = hashWithSalt s (3 :: Int, show x :: String) + hashWithSalt s Null = hashWithSalt s (4 :: Int) + hashWithSalt s (ResolvedVariable _ _) = hashWithSalt s (5 :: Int) + hashWithSalt s (VariableValue Ref {refName}) = hashWithSalt s (6 :: Int, refName) + +instance Hashable (ObjectEntry s) where + hashWithSalt s (ObjectEntry name value) = hashWithSalt s (name, value) diff --git a/src/Data/Morpheus/Validation/Query/Fragment.hs b/src/Data/Morpheus/Validation/Query/Fragment.hs --- a/src/Data/Morpheus/Validation/Query/Fragment.hs +++ b/src/Data/Morpheus/Validation/Query/Fragment.hs @@ -22,11 +22,8 @@ import Data.Morpheus.Error.Fragment ( cannotBeSpreadOnType, ) -import Data.Morpheus.Internal.Utils - ( Empty (empty), - ) import Data.Morpheus.Types.Internal.AST - ( Directives, + ( DirectiveLocation (..), Fragment (..), FragmentName, Fragments, @@ -50,6 +47,7 @@ constraint, selectKnown, ) +import Data.Morpheus.Validation.Internal.Directive (validateDirectives) import Relude hiding (empty) class ValidateFragmentSelection (s :: Stage) where @@ -76,33 +74,32 @@ UnionTag fragmentType . fmap (\s -> s {selectionOrigin = Just fragmentName}) <$> validateFragmentSelection f fragment validateFragment :: + DirectiveLocation -> (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) -> [TypeName] -> Fragment RAW -> FragmentValidator s (Fragment VALID) -validateFragment validate allowedTypes fragment@Fragment {fragmentPosition} = +validateFragment loc validate allowedTypes fragment@Fragment {fragmentPosition} = castFragmentType Nothing fragmentPosition allowedTypes fragment - >>= onlyValidateFrag validate + >>= onlyValidateFrag loc validate validateFragments :: (Fragment RAW -> FragmentValidator RAW (SelectionSet VALID)) -> FragmentValidator RAW (Fragments VALID) -validateFragments f = askFragments >>= traverse (onlyValidateFrag f) +validateFragments f = askFragments >>= traverse (onlyValidateFrag FRAGMENT_DEFINITION f) onlyValidateFrag :: + DirectiveLocation -> (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) -> Fragment RAW -> FragmentValidator s (Fragment VALID) -onlyValidateFrag validate f@Fragment {..} = +onlyValidateFrag loc validate f@Fragment {..} = Fragment fragmentName fragmentType fragmentPosition <$> validate f - <*> validateFragmentDirectives fragmentDirectives - -validateFragmentDirectives :: Directives RAW -> FragmentValidator s (Directives VALID) -validateFragmentDirectives _ = pure empty -- TODO: validate fragment directives + <*> validateDirectives loc fragmentDirectives castFragmentType :: Maybe FragmentName -> diff --git a/src/Data/Morpheus/Validation/Query/Selection.hs b/src/Data/Morpheus/Validation/Query/Selection.hs --- a/src/Data/Morpheus/Validation/Query/Selection.hs +++ b/src/Data/Morpheus/Validation/Query/Selection.hs @@ -218,7 +218,7 @@ FragmentValidator s (SelectionSet VALID) validateInlineFragmentSelection typeDef x = do types <- possibleTypes typeDef <$> asks schema - fragmentSelection <$> validateFragment validateFragmentSelection types x + fragmentSelection <$> validateFragment INLINE_FRAGMENT validateFragmentSelection types x selectSelectionField :: Ref FieldName -> @@ -291,7 +291,6 @@ -- Validate Regular selection set __validate DataObject {..} = fmap SelectionSet . validateSelectionSet (TypeDefinition {typeContent = DataObject {..}, ..}) - -- TODO: Union Like Validation __validate DataInterface {..} = validateInterfaceSelection validateFragmentSelection diff --git a/src/Data/Morpheus/Validation/Query/UnionSelection.hs b/src/Data/Morpheus/Validation/Query/UnionSelection.hs --- a/src/Data/Morpheus/Validation/Query/UnionSelection.hs +++ b/src/Data/Morpheus/Validation/Query/UnionSelection.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -24,6 +25,7 @@ selectOr, startHistory, ) +import Data.Morpheus.Types.Internal.AST.DirectiveLocation (DirectiveLocation (FRAGMENT_SPREAD, INLINE_FRAGMENT)) import Data.Morpheus.Types.Internal.AST.Name (TypeName) import Data.Morpheus.Types.Internal.AST.Selection ( Fragment (..), @@ -51,6 +53,7 @@ askTypeMember, asksScope, ) +import Data.Morpheus.Validation.Internal.Directive (validateDirectives) import Data.Morpheus.Validation.Query.Fragment ( ValidateFragmentSelection, castFragmentType, @@ -68,18 +71,17 @@ Selection RAW -> FragmentValidator s (Either UnionTag (Selection RAW)) splitFragment _ _ x@Selection {} = pure (Right x) -splitFragment f types (Spread _ ref) = Left <$> validateSpread f (typeName <$> types) ref -splitFragment f types (InlineFragment fragment@Fragment {fragmentType}) = +splitFragment f types (Spread dirs ref) = do + _ <- validateDirectives FRAGMENT_SPREAD dirs + Left <$> validateSpread f (typeName <$> types) ref +splitFragment f types (InlineFragment fragment@Fragment {..}) = do + _ <- validateDirectives INLINE_FRAGMENT fragmentDirectives Left . UnionTag fragmentType - <$> ( castFragmentType Nothing (fragmentPosition fragment) (typeName <$> types) fragment - >>= f - ) + <$> (castFragmentType Nothing fragmentPosition (typeName <$> types) fragment >>= f) exploreFragments :: (ValidateFragmentSelection s) => - ( Fragment RAW -> - FragmentValidator s (SelectionSet VALID) - ) -> + (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) -> OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID) -> SelectionSet RAW -> FragmentValidator s ([UnionTag], Maybe (SelectionSet RAW))