Put test helpers into Test.Hspec.GraphQL

2022-03-23 21:58:12 +01:00
parent 0cf459b8eb
commit c93c64a7f4
8 changed files with 198 additions and 148 deletions
@@ -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)