From c93c64a7f4828a202770b1cfadc79f28aba1da99 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Wed, 23 Mar 2022 21:58:12 +0100 Subject: Put test helpers into Test.Hspec.GraphQL --- src/Language/GraphQL/Foundation.hs | 58 -------------- src/Language/GraphQL/JSON.hs | 153 +++++++++++++++++++++++++++++++++++++ src/Language/GraphQL/Serialize.hs | 102 ------------------------- 3 files changed, 153 insertions(+), 160 deletions(-) delete mode 100644 src/Language/GraphQL/Foundation.hs create mode 100644 src/Language/GraphQL/JSON.hs delete mode 100644 src/Language/GraphQL/Serialize.hs (limited to 'src/Language/GraphQL') diff --git a/src/Language/GraphQL/Foundation.hs b/src/Language/GraphQL/Foundation.hs deleted file mode 100644 index 4d0d4f3..0000000 --- a/src/Language/GraphQL/Foundation.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} - -module Language.GraphQL.Foundation - ( module Language.GraphQL.Serialize - , graphql - ) where - -import Language.GraphQL.Serialize -import Control.Monad.Catch (MonadCatch) -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Types as Aeson -import Data.HashMap.Strict (HashMap) -import qualified Data.Aeson.KeyMap as KeyMap -import Data.Maybe (catMaybes) -import qualified Data.Sequence as Seq -import Data.Text (Text) -import Data.Vector (Vector) -import qualified Data.Vector as Vector -import qualified Language.GraphQL as GraphQL -import Language.GraphQL.AST -import Language.GraphQL.Error -import Language.GraphQL.Type.Schema (Schema) -import Data.Bifunctor (Bifunctor(..)) - --- | If the text parses correctly as a @GraphQL@ query the query is --- executed using the given 'Schema'. -graphql :: MonadCatch m - => Schema m -- ^ Resolvers. - -> Text -- ^ Text representing a @GraphQL@ request document. - -> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response. -graphql schema = fmap (bimap stream formatResponse) - . GraphQL.graphql schema mempty (mempty :: HashMap Name JSON) - where - stream :: ResponseEventStream m JSON -> ResponseEventStream m Aeson.Value - stream = undefined - formatResponse :: Response JSON -> Aeson.Object - formatResponse Response{ errors, data' = JSON json } = - let dataResponse = KeyMap.singleton "data" json - in case errors of - Seq.Empty -> dataResponse - _ -> flip (KeyMap.insert "errors") dataResponse - $ Aeson.Array $ foldr fromError mempty errors - fromError :: Error -> Vector Aeson.Value -> Vector Aeson.Value - fromError Error{..} = Vector.cons $ Aeson.object $ catMaybes - [ Just ("message", Aeson.String message) - , toMaybe fromLocation "locations" locations - , toMaybe fromPath "path" path - ] - fromPath (Segment segment) = Aeson.String segment - fromPath (Index index) = Aeson.toJSON index - fromLocation Location{..} = Aeson.object - [ ("line", Aeson.toJSON line) - , ("column", Aeson.toJSON column) - ] - toMaybe _ _ [] = Nothing - toMaybe f key xs = Just (key, Aeson.listValue f xs) diff --git a/src/Language/GraphQL/JSON.hs b/src/Language/GraphQL/JSON.hs new file mode 100644 index 0000000..bdbc4f4 --- /dev/null +++ b/src/Language/GraphQL/JSON.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +module Language.GraphQL.JSON + ( JSON(..) + , graphql + ) where + +import Control.Monad.Catch (MonadCatch) +import qualified Data.Aeson.Types as Aeson +import Data.Maybe (catMaybes) +import qualified Data.Sequence as Seq +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import qualified Language.GraphQL as GraphQL +import Language.GraphQL.AST (Location(..), Name) +import Language.GraphQL.Error +import Language.GraphQL.Type.Schema (Schema) +import Data.Bifunctor (Bifunctor(..)) +import qualified Conduit +import qualified Data.Aeson.Key as Aeson.Key +import qualified Data.Aeson.KeyMap as KeyMap +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Scientific (toBoundedInteger, toRealFloat) +import Data.Text (Text) +import Language.GraphQL.Execute.Coerce +import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap +import qualified Language.GraphQL.Type.In as In +import qualified Language.GraphQL.Type.Out as Out +import qualified Language.GraphQL.Type as Type + +newtype JSON = JSON Aeson.Value + +instance Aeson.ToJSON JSON where + toJSON (JSON value) = value + +instance Aeson.FromJSON JSON where + parseJSON = pure . JSON + +instance Serialize JSON where + serialize (Out.ScalarBaseType scalarType) value + | Type.ScalarType "Int" _ <- scalarType + , Int int <- value = Just $ JSON $ Aeson.Number $ fromIntegral int + | Type.ScalarType "Float" _ <- scalarType + , Float float <- value = Just $ JSON $ Aeson.toJSON float + | Type.ScalarType "String" _ <- scalarType + , String string <- value = Just $ JSON $ Aeson.String string + | Type.ScalarType "ID" _ <- scalarType + , String string <- value = Just $ JSON $ Aeson.String string + | Type.ScalarType "Boolean" _ <- scalarType + , Boolean boolean <- value = Just $ JSON $ Aeson.Bool boolean + serialize _ (Enum enum) = Just $ JSON $ Aeson.String enum + serialize _ (List list) = Just $ JSON $ Aeson.toJSON list + serialize _ (Object object) = Just + $ JSON + $ Aeson.object + $ toJSONKeyValue <$> OrderedMap.toList object + where + toJSONKeyValue (key, value) = (Aeson.Key.fromText key, Aeson.toJSON value) + serialize _ _ = Nothing + null = JSON Aeson.Null + +instance VariableValue JSON where + coerceVariableValue _ (JSON Aeson.Null) = Just Type.Null + coerceVariableValue (In.ScalarBaseType scalarType) (JSON value) + | (Aeson.String stringValue) <- value = Just $ Type.String stringValue + | (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue + | (Aeson.Number numberValue) <- value + , (Type.ScalarType "Float" _) <- scalarType = + Just $ Type.Float $ toRealFloat numberValue + | (Aeson.Number numberValue) <- value = -- ID or Int + Type.Int <$> toBoundedInteger numberValue + coerceVariableValue (In.EnumBaseType _) (JSON (Aeson.String stringValue)) = + Just $ Type.Enum stringValue + coerceVariableValue (In.InputObjectBaseType objectType) (JSON value) + | (Aeson.Object objectValue) <- value = do + let (In.InputObjectType _ _ inputFields) = objectType + (newObjectValue, resultMap) <- foldWithKey objectValue inputFields + if KeyMap.null newObjectValue + then Just $ Type.Object resultMap + else Nothing + where + foldWithKey :: Aeson.Object + -> HashMap Name In.InputField + -> Maybe (Aeson.Object, HashMap Name Type.Value) + foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues' + $ Just (objectValue, HashMap.empty) + matchFieldValues' :: Text + -> In.InputField + -> Maybe (Aeson.Object, HashMap Name Type.Value) + -> Maybe (Aeson.Object, HashMap Name Type.Value) + matchFieldValues' _ _ Nothing = Nothing + matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) = + let fieldKey = Aeson.Key.fromText fieldName + In.InputField _ fieldType _ = inputField + insert = flip (HashMap.insert fieldName) resultMap + newObjectValue = KeyMap.delete fieldKey objectValue + in case KeyMap.lookup fieldKey objectValue of + Just variableValue -> do + coerced <- coerceVariableValue fieldType + $ JSON variableValue + pure (newObjectValue, insert coerced) + Nothing -> Just (objectValue, resultMap) + coerceVariableValue (In.ListBaseType listType) (JSON value) + | (Aeson.Array arrayValue) <- value = + Type.List <$> foldr foldVector (Just []) arrayValue + | otherwise = coerceVariableValue listType $ JSON value + where + foldVector _ Nothing = Nothing + foldVector variableValue (Just list) = do + coerced <- coerceVariableValue listType $ JSON variableValue + pure $ coerced : list + coerceVariableValue _ _ = Nothing + +-- | If the text parses correctly as a @GraphQL@ query the query is +-- executed using the given 'Schema'. +graphql :: MonadCatch m + => Schema m -- ^ Resolvers. + -> Maybe Text -- ^ Operation name. + -> Aeson.Object -- ^ Variables. + -> Text -- ^ Text representing a @GraphQL@ request document. + -> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response. +graphql schema operationName variableValues = fmap (bimap stream formatResponse) + . GraphQL.graphql schema operationName jsonVariables + where + jsonVariables = JSON <$> KeyMap.toHashMapText variableValues + -- stream :: ResponseEventStream m JSON -> ResponseEventStream m Aeson.Value + stream = Conduit.mapOutput mapResponse + mapResponse response@Response{ data' = JSON json } = + response{ data' = json } + formatResponse :: Response JSON -> Aeson.Object + formatResponse Response{ errors, data' = JSON json } = + let dataResponse = KeyMap.singleton "data" json + in case errors of + Seq.Empty -> dataResponse + _ -> flip (KeyMap.insert "errors") dataResponse + $ Aeson.Array $ foldr fromError mempty errors + fromError :: Error -> Vector Aeson.Value -> Vector Aeson.Value + fromError Error{..} = Vector.cons $ Aeson.object $ catMaybes + [ Just ("message", Aeson.String message) + , toMaybe fromLocation "locations" locations + , toMaybe fromPath "path" path + ] + fromPath (Segment segment) = Aeson.String segment + fromPath (Index index) = Aeson.toJSON index + fromLocation Location{..} = Aeson.object + [ ("line", Aeson.toJSON line) + , ("column", Aeson.toJSON column) + ] + toMaybe _ _ [] = Nothing + toMaybe f key xs = Just (key, Aeson.listValue f xs) diff --git a/src/Language/GraphQL/Serialize.hs b/src/Language/GraphQL/Serialize.hs deleted file mode 100644 index cad4f47..0000000 --- a/src/Language/GraphQL/Serialize.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Language.GraphQL.Serialize - ( JSON(..) - ) where - -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Key as Aeson.Key -import qualified Data.Aeson.KeyMap as KeyMap -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Scientific (toBoundedInteger, toRealFloat) -import Data.Text (Text) -import Language.GraphQL.AST (Name) -import Language.GraphQL.Execute.Coerce -import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap -import qualified Language.GraphQL.Type.In as In -import qualified Language.GraphQL.Type.Out as Out -import qualified Language.GraphQL.Type as Type - -newtype JSON = JSON Aeson.Value - -instance Aeson.ToJSON JSON where - toJSON (JSON value) = value - -instance Aeson.FromJSON JSON where - parseJSON = pure . JSON - -instance Serialize JSON where - serialize (Out.ScalarBaseType scalarType) value - | Type.ScalarType "Int" _ <- scalarType - , Int int <- value = Just $ JSON $ Aeson.Number $ fromIntegral int - | Type.ScalarType "Float" _ <- scalarType - , Float float <- value = Just $ JSON $ Aeson.toJSON float - | Type.ScalarType "String" _ <- scalarType - , String string <- value = Just $ JSON $ Aeson.String string - | Type.ScalarType "ID" _ <- scalarType - , String string <- value = Just $ JSON $ Aeson.String string - | Type.ScalarType "Boolean" _ <- scalarType - , Boolean boolean <- value = Just $ JSON $ Aeson.Bool boolean - serialize _ (Enum enum) = Just $ JSON $ Aeson.String enum - serialize _ (List list) = Just $ JSON $ Aeson.toJSON list - serialize _ (Object object) = Just - $ JSON - $ Aeson.object - $ toJSONKeyValue <$> OrderedMap.toList object - where - toJSONKeyValue (key, value) = (Aeson.Key.fromText key, Aeson.toJSON value) - serialize _ _ = Nothing - null = JSON Aeson.Null - -instance VariableValue JSON where - coerceVariableValue _ (JSON Aeson.Null) = Just Type.Null - coerceVariableValue (In.ScalarBaseType scalarType) (JSON value) - | (Aeson.String stringValue) <- value = Just $ Type.String stringValue - | (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue - | (Aeson.Number numberValue) <- value - , (Type.ScalarType "Float" _) <- scalarType = - Just $ Type.Float $ toRealFloat numberValue - | (Aeson.Number numberValue) <- value = -- ID or Int - Type.Int <$> toBoundedInteger numberValue - coerceVariableValue (In.EnumBaseType _) (JSON (Aeson.String stringValue)) = - Just $ Type.Enum stringValue - coerceVariableValue (In.InputObjectBaseType objectType) (JSON value) - | (Aeson.Object objectValue) <- value = do - let (In.InputObjectType _ _ inputFields) = objectType - (newObjectValue, resultMap) <- foldWithKey objectValue inputFields - if KeyMap.null newObjectValue - then Just $ Type.Object resultMap - else Nothing - where - foldWithKey :: Aeson.Object - -> HashMap Name In.InputField - -> Maybe (Aeson.Object, HashMap Name Type.Value) - foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues' - $ Just (objectValue, HashMap.empty) - matchFieldValues' :: Text - -> In.InputField - -> Maybe (Aeson.Object, HashMap Name Type.Value) - -> Maybe (Aeson.Object, HashMap Name Type.Value) - matchFieldValues' _ _ Nothing = Nothing - matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) = - let fieldKey = Aeson.Key.fromText fieldName - In.InputField _ fieldType _ = inputField - insert = flip (HashMap.insert fieldName) resultMap - newObjectValue = KeyMap.delete fieldKey objectValue - in case KeyMap.lookup fieldKey objectValue of - Just variableValue -> do - coerced <- coerceVariableValue fieldType - $ JSON variableValue - pure (newObjectValue, insert coerced) - Nothing -> Just (objectValue, resultMap) - coerceVariableValue (In.ListBaseType listType) (JSON value) - | (Aeson.Array arrayValue) <- value = - Type.List <$> foldr foldVector (Just []) arrayValue - | otherwise = coerceVariableValue listType $ JSON value - where - foldVector _ Nothing = Nothing - foldVector variableValue (Just list) = do - coerced <- coerceVariableValue listType $ JSON variableValue - pure $ coerced : list - coerceVariableValue _ _ = Nothing -- cgit v1.2.3