diff options
Diffstat (limited to 'Data')
| -rw-r--r-- | Data/GraphQL/Execute.hs | 79 | ||||
| -rw-r--r-- | Data/GraphQL/Schema.hs | 76 |
2 files changed, 94 insertions, 61 deletions
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 |