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: Convert the response to JSON

---
 src/Language/GraphQL/Foundation.hs | 53 ++++++++++++++++++++++++++++++++++++++
 1 file changed, 53 insertions(+)

(limited to 'src/Language/GraphQL')

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)
-- 
cgit v1.2.3