diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Language/GraphQL/AST/Core.hs | 4 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Transform.hs | 9 | ||||
| -rw-r--r-- | src/Language/GraphQL/Encoder.hs | 367 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute.hs | 50 |
4 files changed, 278 insertions, 152 deletions
diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs index 00072e0..87dced9 100644 --- a/src/Language/GraphQL/AST/Core.hs +++ b/src/Language/GraphQL/AST/Core.hs @@ -21,8 +21,8 @@ type Name = Text type Document = NonEmpty Operation -data Operation = Query (NonEmpty Field) - | Mutation (NonEmpty Field) +data Operation = Query (Maybe Text) (NonEmpty Field) + | Mutation (Maybe Text) (NonEmpty Field) deriving (Eq,Show) data Field = Field (Maybe Alias) Name [Argument] [Field] deriving (Eq,Show) diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs index 64670db..63a2c72 100644 --- a/src/Language/GraphQL/AST/Transform.hs +++ b/src/Language/GraphQL/AST/Transform.hs @@ -41,7 +41,6 @@ operations -> Maybe Core.Document operations subs fr = NonEmpty.nonEmpty <=< traverse (operation subs fr) --- TODO: Replace Maybe by MonadThrow CustomError operation :: Schema.Subs -> Fragmenter @@ -50,10 +49,10 @@ operation operation subs fr (Full.OperationSelectionSet sels) = operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels -- TODO: Validate Variable definitions with substituter -operation subs fr (Full.OperationDefinition ot _n _vars _dirs sels) = - case ot of - Full.Query -> Core.Query <$> node - Full.Mutation -> Core.Mutation <$> node +operation subs fr (Full.OperationDefinition operationType name _vars _dirs sels) + = case operationType of + Full.Query -> Core.Query name <$> node + Full.Mutation -> Core.Mutation name <$> node where node = traverse (hush . selection subs fr) sels diff --git a/src/Language/GraphQL/Encoder.hs b/src/Language/GraphQL/Encoder.hs index c315091..11115b1 100644 --- a/src/Language/GraphQL/Encoder.hs +++ b/src/Language/GraphQL/Encoder.hs @@ -1,156 +1,238 @@ {-# LANGUAGE OverloadedStrings #-} --- | This module defines a printer for the @GraphQL@ language. +{-# LANGUAGE ExplicitForAll #-} + +-- | This module defines a minifier and a printer for the @GraphQL@ language. module Language.GraphQL.Encoder - ( document - , spaced + ( Formatter + , definition + , directive + , document + , minified + , pretty + , type' + , value ) where import Data.Foldable (fold) import Data.Monoid ((<>)) import qualified Data.List.NonEmpty as NonEmpty (toList) -import Data.Text (Text, cons, intercalate, pack, snoc) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as Text.Lazy +import Data.Text.Lazy.Builder (toLazyText) +import Data.Text.Lazy.Builder.Int (decimal) +import Data.Text.Lazy.Builder.RealFloat (realFloat) import Language.GraphQL.AST --- * Document - -document :: Document -> Text -document defs = (`snoc` '\n') . mconcat . NonEmpty.toList $ definition <$> defs - -definition :: Definition -> Text -definition (DefinitionOperation x) = operationDefinition x -definition (DefinitionFragment x) = fragmentDefinition x - -operationDefinition :: OperationDefinition -> Text -operationDefinition (OperationSelectionSet sels) = selectionSet sels -operationDefinition (OperationDefinition Query name vars dirs sels) = - "query " <> node (fold name) vars dirs sels -operationDefinition (OperationDefinition Mutation name vars dirs sels) = - "mutation " <> node (fold name) vars dirs sels - -node :: Name -> VariableDefinitions -> Directives -> SelectionSet -> Text -node name vars dirs sels = - name - <> optempty variableDefinitions vars - <> optempty directives dirs - <> selectionSet sels - -variableDefinitions :: [VariableDefinition] -> Text -variableDefinitions = parensCommas variableDefinition - -variableDefinition :: VariableDefinition -> Text -variableDefinition (VariableDefinition var ty dv) = - variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv - -defaultValue :: Value -> Text -defaultValue val = "=" <> value val +-- | Instructs the encoder whether a GraphQL should be minified or pretty +-- printed. +-- +-- Use 'pretty' and 'minified' to construct the formatter. +data Formatter + = Minified + | Pretty Word + +-- Constructs a formatter for pretty printing. +pretty :: Formatter +pretty = Pretty 0 + +-- Constructs a formatter for minifying. +minified :: Formatter +minified = Minified + +-- | Converts a 'Document' into a string. +document :: Formatter -> Document -> Text +document formatter defs + | Pretty _ <- formatter = Text.Lazy.intercalate "\n" encodeDocument + | Minified <-formatter = Text.Lazy.snoc (mconcat encodeDocument) '\n' + where + encodeDocument = NonEmpty.toList $ definition formatter <$> defs + +-- | Converts a 'Definition' into a string. +definition :: Formatter -> Definition -> Text +definition formatter x + | Pretty _ <- formatter = Text.Lazy.snoc (encodeDefinition x) '\n' + | Minified <- formatter = encodeDefinition x + where + encodeDefinition (DefinitionOperation operation) + = operationDefinition formatter operation + encodeDefinition (DefinitionFragment fragment) + = fragmentDefinition formatter fragment + +operationDefinition :: Formatter -> OperationDefinition -> Text +operationDefinition formatter (OperationSelectionSet sels) + = selectionSet formatter sels +operationDefinition formatter (OperationDefinition Query name vars dirs sels) + = "query " <> node formatter name vars dirs sels +operationDefinition formatter (OperationDefinition Mutation name vars dirs sels) + = "mutation " <> node formatter name vars dirs sels + +node :: Formatter + -> Maybe Name + -> VariableDefinitions + -> Directives + -> SelectionSet + -> Text +node formatter name vars dirs sels + = Text.Lazy.fromStrict (fold name) + <> optempty (variableDefinitions formatter) vars + <> optempty (directives formatter) dirs + <> eitherFormat formatter " " mempty + <> selectionSet formatter sels + +variableDefinitions :: Formatter -> [VariableDefinition] -> Text +variableDefinitions formatter + = parensCommas formatter $ variableDefinition formatter + +variableDefinition :: Formatter -> VariableDefinition -> Text +variableDefinition formatter (VariableDefinition var ty dv) + = variable var + <> eitherFormat formatter ": " ":" + <> type' ty + <> maybe mempty (defaultValue formatter) dv + +defaultValue :: Formatter -> Value -> Text +defaultValue formatter val + = eitherFormat formatter " = " "=" + <> value formatter val variable :: Name -> Text -variable var = "$" <> var - -selectionSet :: SelectionSet -> Text -selectionSet = bracesCommas selection . NonEmpty.toList - -selectionSetOpt :: SelectionSetOpt -> Text -selectionSetOpt = bracesCommas selection - -selection :: Selection -> Text -selection (SelectionField x) = field x -selection (SelectionInlineFragment x) = inlineFragment x -selection (SelectionFragmentSpread x) = fragmentSpread x - -field :: Field -> Text -field (Field alias name args dirs selso) = - optempty (`snoc` ':') (fold alias) - <> name - <> optempty arguments args - <> optempty directives dirs - <> optempty selectionSetOpt selso - -arguments :: [Argument] -> Text -arguments = parensCommas argument - -argument :: Argument -> Text -argument (Argument name v) = name <> ":" <> value v +variable var = "$" <> Text.Lazy.fromStrict var + +selectionSet :: Formatter -> SelectionSet -> Text +selectionSet formatter + = bracesList formatter (selection formatter) + . NonEmpty.toList + +selectionSetOpt :: Formatter -> SelectionSetOpt -> Text +selectionSetOpt formatter = bracesList formatter $ selection formatter + +selection :: Formatter -> Selection -> Text +selection formatter = Text.Lazy.append indent . f + where + f (SelectionField x) = field incrementIndent x + f (SelectionInlineFragment x) = inlineFragment incrementIndent x + f (SelectionFragmentSpread x) = fragmentSpread incrementIndent x + incrementIndent + | Pretty n <- formatter = Pretty $ n + 1 + | otherwise = Minified + indent + | Pretty n <- formatter = Text.Lazy.replicate (fromIntegral $ n + 1) " " + | otherwise = mempty + +field :: Formatter -> Field -> Text +field formatter (Field alias name args dirs selso) + = optempty (`Text.Lazy.append` colon) (Text.Lazy.fromStrict $ fold alias) + <> Text.Lazy.fromStrict name + <> optempty (arguments formatter) args + <> optempty (directives formatter) dirs + <> selectionSetOpt' + where + colon = eitherFormat formatter ": " ":" + selectionSetOpt' + | null selso = mempty + | otherwise = eitherFormat formatter " " mempty <> selectionSetOpt formatter selso + +arguments :: Formatter -> [Argument] -> Text +arguments formatter = parensCommas formatter $ argument formatter + +argument :: Formatter -> Argument -> Text +argument formatter (Argument name v) + = Text.Lazy.fromStrict name + <> eitherFormat formatter ": " ":" + <> value formatter v -- * Fragments -fragmentSpread :: FragmentSpread -> Text -fragmentSpread (FragmentSpread name ds) = - "..." <> name <> optempty directives ds - -inlineFragment :: InlineFragment -> Text -inlineFragment (InlineFragment tc dirs sels) = - "... on " <> fold tc - <> directives dirs - <> selectionSet sels - -fragmentDefinition :: FragmentDefinition -> Text -fragmentDefinition (FragmentDefinition name tc dirs sels) = - "fragment " <> name <> " on " <> tc - <> optempty directives dirs - <> selectionSet sels - --- * Values - -value :: Value -> Text -value (ValueVariable x) = variable x --- TODO: This will be replaced with `decimal` Builder -value (ValueInt x) = pack $ show x --- TODO: This will be replaced with `decimal` Builder -value (ValueFloat x) = pack $ show x -value (ValueBoolean x) = booleanValue x -value ValueNull = mempty -value (ValueString x) = stringValue x -value (ValueEnum x) = x -value (ValueList x) = listValue x -value (ValueObject x) = objectValue x +fragmentSpread :: Formatter -> FragmentSpread -> Text +fragmentSpread formatter (FragmentSpread name ds) + = "..." <> Text.Lazy.fromStrict name <> optempty (directives formatter) ds + +inlineFragment :: Formatter -> InlineFragment -> Text +inlineFragment formatter (InlineFragment tc dirs sels) + = "... on " + <> Text.Lazy.fromStrict (fold tc) + <> directives formatter dirs + <> eitherFormat formatter " " mempty + <> selectionSet formatter sels + +fragmentDefinition :: Formatter -> FragmentDefinition -> Text +fragmentDefinition formatter (FragmentDefinition name tc dirs sels) + = "fragment " <> Text.Lazy.fromStrict name + <> " on " <> Text.Lazy.fromStrict tc + <> optempty (directives formatter) dirs + <> eitherFormat formatter " " mempty + <> selectionSet formatter sels + +-- * Miscellaneous + +-- | Converts a 'Directive' into a string. +directive :: Formatter -> Directive -> Text +directive formatter (Directive name args) + = "@" <> Text.Lazy.fromStrict name <> optempty (arguments formatter) args + +directives :: Formatter -> Directives -> Text +directives formatter@(Pretty _) = Text.Lazy.cons ' ' . spaces (directive formatter) +directives Minified = spaces (directive Minified) + +-- | Converts a 'Value' into a string. +value :: Formatter -> Value -> Text +value _ (ValueVariable x) = variable x +value _ (ValueInt x) = toLazyText $ decimal x +value _ (ValueFloat x) = toLazyText $ realFloat x +value _ (ValueBoolean x) = booleanValue x +value _ ValueNull = mempty +value _ (ValueString x) = stringValue $ Text.Lazy.fromStrict x +value _ (ValueEnum x) = Text.Lazy.fromStrict x +value formatter (ValueList x) = listValue formatter x +value formatter (ValueObject x) = objectValue formatter x booleanValue :: Bool -> Text booleanValue True = "true" booleanValue False = "false" --- TODO: Escape characters stringValue :: Text -> Text -stringValue = quotes - -listValue :: [Value] -> Text -listValue = bracketsCommas value - -objectValue :: [ObjectField] -> Text -objectValue = bracesCommas objectField - -objectField :: ObjectField -> Text -objectField (ObjectField name v) = name <> ":" <> value v - --- * Directives - -directives :: [Directive] -> Text -directives = spaces directive - -directive :: Directive -> Text -directive (Directive name args) = "@" <> name <> optempty arguments args - --- * Type Reference - -type_ :: Type -> Text -type_ (TypeNamed x) = x -type_ (TypeList x) = listType x -type_ (TypeNonNull x) = nonNullType x +stringValue + = quotes + . Text.Lazy.replace "\"" "\\\"" + . Text.Lazy.replace "\\" "\\\\" + +listValue :: Formatter -> [Value] -> Text +listValue formatter = bracketsCommas formatter $ value formatter + +objectValue :: Formatter -> [ObjectField] -> Text +objectValue formatter = intercalate $ objectField formatter + where + intercalate f + = braces + . Text.Lazy.intercalate (eitherFormat formatter ", " ",") + . fmap f + + +objectField :: Formatter -> ObjectField -> Text +objectField formatter (ObjectField name v) + = Text.Lazy.fromStrict name <> colon <> value formatter v + where + colon + | Pretty _ <- formatter = ": " + | Minified <- formatter = ":" + +-- | Converts a 'Type' a type into a string. +type' :: Type -> Text +type' (TypeNamed x) = Text.Lazy.fromStrict x +type' (TypeList x) = listType x +type' (TypeNonNull x) = nonNullType x listType :: Type -> Text -listType x = brackets (type_ x) +listType x = brackets (type' x) nonNullType :: NonNullType -> Text -nonNullType (NonNullTypeNamed x) = x <> "!" +nonNullType (NonNullTypeNamed x) = Text.Lazy.fromStrict x <> "!" nonNullType (NonNullTypeList x) = listType x <> "!" -- * Internal -spaced :: Text -> Text -spaced = cons '\SP' - between :: Char -> Char -> Text -> Text -between open close = cons open . (`snoc` close) +between open close = Text.Lazy.cons open . (`Text.Lazy.snoc` close) parens :: Text -> Text parens = between '(' ')' @@ -164,17 +246,32 @@ braces = between '{' '}' quotes :: Text -> Text quotes = between '"' '"' -spaces :: (a -> Text) -> [a] -> Text -spaces f = intercalate "\SP" . fmap f - -parensCommas :: (a -> Text) -> [a] -> Text -parensCommas f = parens . intercalate "," . fmap f - -bracketsCommas :: (a -> Text) -> [a] -> Text -bracketsCommas f = brackets . intercalate "," . fmap f - -bracesCommas :: (a -> Text) -> [a] -> Text -bracesCommas f = braces . intercalate "," . fmap f +spaces :: forall a. (a -> Text) -> [a] -> Text +spaces f = Text.Lazy.intercalate "\SP" . fmap f + +parensCommas :: forall a. Formatter -> (a -> Text) -> [a] -> Text +parensCommas formatter f + = parens + . Text.Lazy.intercalate (eitherFormat formatter ", " ",") + . fmap f + +bracketsCommas :: Formatter -> (a -> Text) -> [a] -> Text +bracketsCommas formatter f + = brackets + . Text.Lazy.intercalate (eitherFormat formatter ", " ",") + . fmap f + +bracesList :: forall a. Formatter -> (a -> Text) -> [a] -> Text +bracesList (Pretty intendation) f xs + = Text.Lazy.snoc (Text.Lazy.intercalate "\n" content) '\n' + <> (Text.Lazy.snoc $ Text.Lazy.replicate (fromIntegral intendation) " ") '}' + where + content = "{" : fmap f xs +bracesList Minified f xs = braces $ Text.Lazy.intercalate "," $ fmap f xs optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b optempty f xs = if xs == mempty then mempty else f xs + +eitherFormat :: forall a. Formatter -> a -> a -> a +eitherFormat (Pretty _) x _ = x +eitherFormat Minified _ x = x diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 9dbfb36..5a815b8 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -4,12 +4,15 @@ -- according to a 'Schema'. module Language.GraphQL.Execute ( execute + , executeWithName ) where import Control.Monad.IO.Class (MonadIO) +import qualified Data.Aeson as Aeson import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty((:|))) -import qualified Data.Aeson as Aeson +import Data.Text (Text) +import qualified Data.Text as Text import qualified Language.GraphQL.AST as AST import qualified Language.GraphQL.AST.Core as AST.Core import qualified Language.GraphQL.AST.Transform as Transform @@ -23,20 +26,47 @@ import qualified Language.GraphQL.Schema as Schema -- -- Returns the result of the query against the 'Schema' wrapped in a /data/ field, or -- errors wrapped in an /errors/ field. -execute - :: MonadIO m - => Schema m -> Schema.Subs -> AST.Document -> m Aeson.Value +execute :: MonadIO m + => Schema m + -> Schema.Subs + -> AST.Document + -> m Aeson.Value execute schema subs doc = - maybe transformError (document schema) $ Transform.document subs doc + maybe transformError (document schema Nothing) $ Transform.document subs doc + where + transformError = return $ singleError "Schema transformation error." + +-- | Takes a 'Schema', operation name, a variable substitution function ('Schema.Subs'), +-- and a @GraphQL@ 'document'. The substitution is applied to the document using +-- 'rootFields', and the 'Schema''s resolvers are applied to the resulting fields. +-- +-- Returns the result of the query against the 'Schema' wrapped in a /data/ field, or +-- errors wrapped in an /errors/ field. +executeWithName :: MonadIO m + => Schema m + -> Text + -> Schema.Subs + -> AST.Document + -> m Aeson.Value +executeWithName schema name subs doc = + maybe transformError (document schema $ Just name) $ Transform.document subs doc where transformError = return $ singleError "Schema transformation error." -document :: MonadIO m => Schema m -> AST.Core.Document -> m Aeson.Value -document schema (op :| []) = operation schema op -document _ _ = return $ singleError "Multiple operations not supported yet." +document :: MonadIO m => Schema m -> Maybe Text -> AST.Core.Document -> m Aeson.Value +document schema Nothing (op :| []) = operation schema op +document schema (Just name) operations = case NE.dropWhile matchingName operations of + [] -> return $ singleError + $ Text.unwords ["Operation", name, "couldn't be found in the document."] + (op:_) -> operation schema op + where + matchingName (AST.Core.Query (Just name') _) = name == name' + matchingName (AST.Core.Mutation (Just name') _) = name == name' + matchingName _ = False +document _ _ _ = return $ singleError "Missing operation name." operation :: MonadIO m => Schema m -> AST.Core.Operation -> m Aeson.Value -operation schema (AST.Core.Query flds) +operation schema (AST.Core.Query _ flds) = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds)) -operation schema (AST.Core.Mutation flds) +operation schema (AST.Core.Mutation _ flds) = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds)) |