From 8ee50727bde4779ba5c3aa98f74e669ada66bb26 Mon Sep 17 00:00:00 2001 From: Danny Navarro Date: Wed, 17 Feb 2016 18:13:10 +0100 Subject: Overhaul Schema DSL Aside of making the definition of Schemas easier, it takes care of issues like nested aliases which previously wasn't possible. The naming of the DSL functions is still provisional. --- Data/GraphQL/Execute.hs | 79 ++++++++++++++++++------------------------------- Data/GraphQL/Schema.hs | 76 ++++++++++++++++++++++++++++++++++++++++------- 2 files changed, 94 insertions(+), 61 deletions(-) (limited to 'Data') diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs index 1abda00..ba1eded 100644 --- a/Data/GraphQL/Execute.hs +++ b/Data/GraphQL/Execute.hs @@ -2,64 +2,41 @@ module Data.GraphQL.Execute (execute) where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), pure) -import Data.Traversable (traverse) +import Control.Applicative ((<$>)) #endif -import Control.Applicative (Alternative, empty) -import Data.Foldable (fold) +import Control.Applicative (Alternative) import Data.Maybe (catMaybes) import qualified Data.Aeson as Aeson -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Text as T import Data.GraphQL.AST -import Data.GraphQL.Schema (Resolver, Schema(..)) +import Data.GraphQL.Schema (Schema(..)) import qualified Data.GraphQL.Schema as Schema execute - :: (Alternative m, Monad m) + :: Alternative m => Schema m -> Schema.Subs -> Document -> m Aeson.Value -execute (Schema resolv) f doc = selectionSet f resolv =<< query doc - -query :: Alternative f => Document -> f SelectionSet -query (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) = pure sels -query _ = empty - -selectionSet - :: Alternative f - => Schema.Subs -> Resolver f -> SelectionSet -> f Aeson.Value -selectionSet f resolv = fmap (Aeson.Object . fold) - . traverse (selection f resolv) - -selection - :: Alternative f - => Schema.Subs -> Resolver f -> Selection -> f Aeson.Object -selection f resolv (SelectionField field@(Field alias name _ _ _)) = - fmap (HashMap.singleton aliasOrName) - $ Aeson.toJSON - <$> resolv (fieldToInput f field) - where - aliasOrName = if T.null alias then name else alias -selection _ _ _ = empty - --- * AST/Schema conversions - -argument :: Schema.Subs -> Argument -> Maybe Schema.Argument -argument f (Argument n (ValueVariable (Variable v))) = - maybe Nothing (\v' -> Just (n, v')) $ f v -argument _ (Argument n (ValueInt v)) = - Just (n, Schema.ScalarInt $ fromIntegral v) -argument _ (Argument n (ValueString (StringValue v))) = - Just (n, Schema.ScalarString v) -argument _ _ = error "argument: not implemented yet" - -fieldToInput :: Schema.Subs -> Field -> Schema.Input -fieldToInput f (Field _ n as _ sels) = - -- TODO: Get rid of `catMaybes`, invalid arguments should raise an error - Schema.InputField n (catMaybes $ argument f <$> as) - (fieldToInput f . selectionToField <$> sels) - -selectionToField :: Selection -> Field -selectionToField (SelectionField x) = x -selectionToField _ = error "selectionField: not implemented yet" +execute (Schema resolvm) subs = + fmap Aeson.toJSON . Schema.withFields resolvm . rootFields subs + +rootFields :: Schema.Subs -> Document -> [Field] +rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) = + Schema.fields $ substitute subs <$> sels +rootFields _ _ = [] + +substitute :: Schema.Subs -> Selection -> Selection +substitute subs (SelectionField (Field alias name args directives sels)) = + SelectionField $ Field + alias + name + -- TODO: Get rid of `catMaybes`, invalid arguments should raise an error + (catMaybes $ subsArg subs <$> args) + directives + (substitute subs <$> sels) +substitute _ sel = sel + +-- TODO: Support different value types +subsArg :: Schema.Subs -> Argument -> Maybe Argument +subsArg subs (Argument n (ValueVariable (Variable v))) = + Argument n . ValueString . StringValue <$> subs v +subsArg _ arg = Just arg diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs index 4ec3748..510741b 100644 --- a/Data/GraphQL/Schema.hs +++ b/Data/GraphQL/Schema.hs @@ -1,20 +1,46 @@ {-# LANGUAGE CPP #-} -module Data.GraphQL.Schema where +module Data.GraphQL.Schema + ( Schema(..) + , QueryRoot + , ResolverO + , ResolverM + , Output(..) + , Subs + , Scalar(..) + , withField + , withFieldFinal + , withFields + , withArgument + , outputTraverse + , fields + -- * Reexports + , Field + , Argument + ) where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) +import Data.Traversable (traverse) #endif +import Control.Applicative +import Data.Maybe (catMaybes) +import Data.Foldable (fold) import Data.String (IsString(fromString)) import Data.Aeson (ToJSON(toJSON)) import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap import Data.Text (Text, pack) +import qualified Data.Text as T (null) + +import Data.GraphQL.AST data Schema f = Schema (QueryRoot f) -type QueryRoot f = Resolver f +type QueryRoot f = ResolverM f -type Resolver f = Input -> f Output +-- TODO: Come up with a unique data type or better renaming +type ResolverM f = Field -> f (HashMap Text Output) +type ResolverO f = [Field] -> f Output data Output = OutputObject (HashMap Text Output) | OutputList [Output] @@ -22,12 +48,7 @@ data Output = OutputObject (HashMap Text Output) | OutputEnum Text deriving (Show) -type Argument = (Text, Scalar) - -type Subs = Text -> Maybe Scalar - -data Input = InputField Text [Argument] [Input] - deriving (Show) +type Subs = Text -> Maybe Text -- TODO: GraphQL spec for Integer Scalar is 32bits data Scalar = ScalarInt Int @@ -53,3 +74,38 @@ instance ToJSON Output where toJSON (OutputScalar x) = toJSON x toJSON (OutputEnum x) = toJSON x +-- * Helpers + +withField :: Alternative f => Text -> ([Argument] -> ResolverO f) -> ResolverM f +withField n f (Field alias name' args _ sels) = + if n == name' + then HashMap.singleton aliasOrName <$> f args (fields sels) + else empty + where + aliasOrName = if T.null alias then name' else alias + +withFieldFinal :: Alternative f => Text -> Output -> ResolverM f +withFieldFinal n o fld@(Field _ _ [] _ []) = withField n (\_ _ -> pure o) fld +withFieldFinal _ _ _ = empty + +withFields :: Alternative f => ResolverM f -> ResolverO f +withFields f = fmap (OutputObject . fold) . traverse f + +outputTraverse :: Applicative f => (a -> f Output) -> [a] -> f Output +outputTraverse f = fmap OutputList . traverse f + +withArgument :: Text -> [Argument] -> Maybe Scalar +withArgument x [Argument n s] = if x == n then scalarValue s else Nothing +withArgument _ _ = Nothing + +scalarValue :: Value -> Maybe Scalar +scalarValue (ValueInt x) = Just . ScalarInt $ fromIntegral x +scalarValue (ValueString (StringValue x)) = Just $ ScalarString x +scalarValue _ = Nothing + +fields :: SelectionSet -> [Field] +fields = catMaybes . fmap field + +field :: Selection -> Maybe Field +field (SelectionField x) = Just x +field _ = Nothing -- cgit v1.2.3