From 0cf459b8eb9e4847f9b199566d130e816760a0d3 Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Wed, 2 Feb 2022 09:39:57 +0100
Subject: [PATCH] Convert the response to JSON

---
 cabal.project                      |  3 +-
 graphql-spice.cabal                |  4 +++
 src/Language/GraphQL/Foundation.hs | 53 ++++++++++++++++++++++++++++++
 3 files changed, 58 insertions(+), 2 deletions(-)

diff --git a/cabal.project b/cabal.project
index 566a70e..0742af9 100644
--- a/cabal.project
+++ b/cabal.project
@@ -1,4 +1,3 @@
-packages: .
+packages: . ../graphql
 
 constraints: graphql -json
-tests: False
diff --git a/graphql-spice.cabal b/graphql-spice.cabal
index a56d044..c2efb06 100644
--- a/graphql-spice.cabal
+++ b/graphql-spice.cabal
@@ -32,9 +32,13 @@ library
     build-depends:
       aeson ^>= 2.0.3,
       base ^>=4.14.3.0,
+      containers ^>= 0.6.2,
+      exceptions ^>= 0.10.4,
       graphql ^>= 1.0.2,
+      megaparsec >= 9.0 && < 10,
       scientific ^>= 0.3.7,
       text ^>= 1.2.5,
+      vector ^>= 0.12.3,
       unordered-containers ^>= 0.2.16
     default-language: Haskell2010
 
diff --git a/src/Language/GraphQL/Foundation.hs b/src/Language/GraphQL/Foundation.hs
index 4647a47..4d0d4f3 100644
--- a/src/Language/GraphQL/Foundation.hs
+++ b/src/Language/GraphQL/Foundation.hs
@@ -1,5 +1,58 @@
+{-# 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)